pax_global_header00006660000000000000000000000064144627434070014525gustar00rootroot0000000000000052 comment=2859444a65e51799795e80ad774a01f84b5d4518 base-0.16.3/000077500000000000000000000000001446274340700125265ustar00rootroot00000000000000base-0.16.3/.github/000077500000000000000000000000001446274340700140665ustar00rootroot00000000000000base-0.16.3/.github/workflows/000077500000000000000000000000001446274340700161235ustar00rootroot00000000000000base-0.16.3/.github/workflows/workflow.yml000066400000000000000000000022221446274340700205160ustar00rootroot00000000000000name: Main workflow on: pull_request: push: schedule: - cron: '0 1 * * SAT' concurrency: group: ci-${{ github.ref }} cancel-in-progress: true jobs: Tests: strategy: fail-fast: false matrix: os: [macos-latest, ubuntu-latest, windows-latest] ocaml: - ocaml-base-compiler.5.0.0~alpha0 - 4.14.0 include: - {os: ubuntu-latest, ocaml: 4.13.1} - {os: ubuntu-latest, ocaml: 4.12.1} - {os: ubuntu-latest, ocaml: 4.11.2} exclude: - {os: windows-latest, ocaml: ocaml-base-compiler.5.0.0~alpha0} runs-on: ${{ matrix.os }} steps: - name: Checkout code uses: actions/checkout@v3 - name: Setup OCaml ${{ matrix.ocaml }} uses: ocaml/setup-ocaml@v2 with: cache-prefix: v1-${{ matrix.os }}-${{ matrix.ocaml }} dune-cache: true ocaml-compiler: ${{ matrix.ocaml }} - name: Build dependencies run: opam install . --deps-only --with-test - name: Build library run: opam exec -- dune build - name: Run test suite run: opam exec -- dune runtest base-0.16.3/.gitignore000066400000000000000000000000411446274340700145110ustar00rootroot00000000000000_build *.install *.merlin _opam base-0.16.3/CHANGES.md000066400000000000000000000335551446274340700141330ustar00rootroot00000000000000## Release v0.16.0 Changes across many modules: * Replaced `Caml` with `Stdlib`. The `Caml` module predated `Stdlib` and has been redundant for some time. * Added support for local allocations. This is a nonstandard OCaml extension available at . Support includes: - updating functions to accept `[@local]` arguments, especially closures - local constructors, like `Array.create_local` and `Bytes.create_local` - new versions of interfaces supporting `local` values, such as `Applicative.S_local` - `[@@deriving globalize]` on some types, for converting local values to global values * Rename `Polymorphic_compare` submodules to `Comparisons`. The former was a misnomer. While the comparisons for a given type are meant to replace polymorphic compare operators, they are not polymorphic themselves. * Added `Container.S_with_creators` and `Indexed_container.S_with_creators`. Used these in container modules such as `Array`, `List`, and `String`. These interfaces standardize functions like `map` and `filter`. Along the way, refactored module types in `Container` and `Indexed_container`. * In signatures for `fold*` functions, renamed accumulator type variables to `'acc` for improved readability. * Added `of_string_opt` to `Int_intf.S`. * Added `dequeue_and_ignore_exn` to `Queue_intf.S`. Changes to individual modules: * `Bool`: added `select`, a primitive using `CMOV` on architectures that support it. * `Comparable`: * Added `'a reversed` and `compare_reversed`, to support deriving inverted comparisons, e.g.: `[%compare: My_type.t Comparable.reversed]` * Added `Derived2_phantom`, similar to `Derived_phantom`. * Made `Derived*.comparator_witness` types injective. * `Float`: * Added hyperbolic trig functions `acosh`, `asinh`, and `atanh` to `Float`. * Added `Float.of_string_opt`. * `Hash_set`: Made `t` injective. * `Hashtbl`: * Added `choose_randomly` and `choose_randomly_exn`. * Made `Hashtbl.t` injective. * `Lazy`: Added `peek`, extracting an already-forced value if present. * `Map`: * Added `split_le_gt`, `split_lt_ge`, and `transpose_keys`. * Added `Make_applicative_traversals`, allowing some applicatives to improve performance when operating on maps. * Corrected documentation of performance for `filter*` functions. * Refactored module types in `map_intf.ml`. Among other changes, propagated `~comparator` argument slightly differently to allow expressing type of `transpose_keys` properly. * `Monad`: Documented performance characteristics of `Ident`. * `Option`: Deprecated functions from `Container` but not particularly useful for options. * `Ppx_compare_lib`: Removed primitive functions; `ppx_compare` now explicitly refers to these via `Stdlib`. * `Sequence`: Changed `Step.t` variant type to use inlined records. * `Set`: * Added `of_tree`, `to_tree`, `split_le_gt`, and `split_lt_ge`. * Created a single shared `'a Named.t` type to `set_intf.ml`, rather than using a new type in every instance of `Accessors`. * Made `Set.t` injective in both type arguments. * Refactored module types in `set_intf.ml`. * `Sexpable`: `Of_stringable` now provides `t_sexp_grammar`. * `Sign` and `Sign_or_nan`: Added `to_string_hum`. * `Stack`: added `filter`, `filter_inplace`, and `filter_map`. * `String`: added `concat_lines`, `pad_left`, `pad_right`, and `unsafe_sub` * `Sys`: added `opaque_identity_global`, which forces its argument to be globally allocated. * `Type_equal`: `Id.Uid` now implements `Identifiable.S` * `Uniform_array`: add `sort` ## Old pre-v0.15 changelogs (very likely stale and incomplete) ## git version - Renamed `Result.ok_fst` to `Result.to_either` (old name remains as deprecated alias). Added analogous `Result.of_either` function. - Removed deprecated values `Array.truncate`, `{Obj_array, Uniform_array}.unsafe_truncate`, `Result.ok_unit`, `{Result, Or_error}.ignore`. - Changed the signature of `Hashtbl.equal` to take the data equality function first, allowing it to be used with `[%equal: t]`. - Remove deprecated function `List.dedup`. - Remove deprecated string mutation functions from the `String` module. - Removed deprecated function `Monad.all_ignore` in favor of `Monad.all_unit`. - Deprecated `Or_error.ignore` and `Result.ignore` in favor of `Or_error.ignore_m` and `Result.ignore_m`. - `Ordered_collection_common.get_pos_len` now returns an `Or_error.t` - Added `Bool.Non_short_circuiting`. - Added `Float.square`. - Remove module `Or_error.Ok`. - module `Ref` doesn't implement `Container.S1` anymore. - Rename parameter of `Sequence.merge` from `cmp` to `compare`. - Added `Info.of_lazy_t` - Added `List.partition_result` function, to partition a list of `Result.t` values - Changed the signature of `equal` from `'a t -> 'a t -> equal:('a -> 'a -> bool) -> bool` to `('a -> 'a -> bool) -> 'a t -> 'a t -> bool`. - Optimized `Lazy.compare` to check physical equality before forcing the lazy values. - Deprecated `Args` in the `Applicative` interface in favor of using `ppx_let`. - Deprecated `Array.replace arr i ~f` in favor of using `arr.(i) <- (f (arr.(i)))` - Rename collection length parameter of `Ordered_collection_common` functions from `length` to `total_length`, and add a unit argument to `get_pos_len` and `get_pos_len_exn`. - Removed functions that were deprecated in 2016 from the `Array` and `Set` modules. - `Int.Hex.of_string` and friends no longer silently ignore a suffix of non-hexadecimal garbage. - Added `?backtrace` argument to `Or_error.of_exn_result`. - `List.zip` now returns a `List.Or_unequal_lengths.t` instead of an `option`. - Remove functions from the `Sequence` module that were deprecated in 2015. - `Container.Make` and `Container.Make0` now require callers to either provide a custom `length` function or request that one be derived from `fold`. `Container.to_array`'s signature is also changed to accept `length` and `iter` instead of `fold`. - Exposed module `Int_math`. ## v0.11 - Deprecated `Not_found`, people who need it can use `Caml.Not_found`, but its use isn't recommended. - Added the `Sexp.Not_found_s` exception which will replace `Caml.Not_found` as the default exception in a future release. - Document that `Array.find_exn`, `Array.find_map_exn`, and `Array.findi_exn` may throw `Caml.Not_found` _or_ `Not_found_s`. - Document that `Hashtbl.find_exn` may throw `Caml.Not_found` _or_ `Not_found_s`. - Document that `List.find_exn`, and `List.find_map_exn` may throw `Caml.Not_found` _or_ `Not_found_s`. - Document that `List.find_exn` may throw `Caml.Not_found` _or_ `Not_found_s`. - Document that `String.lsplit2_exn`, and `String.rsplit2_exn` may throw `Caml.Not_found` _or_ `Not_found_s`. - Added `Sys.backend_type`. - Removed unnecessary unit argument from `Hashtbl.create`. - Removed deprecated operations from `Hashtbl`. - Removed `Hashable.t` constructors from `Hashtbl` and `Hash_set`, instead favoring the first-class module constructors. - Removed `Container` operations from `Either.First` and `Either.Second`. - Changed the type of `fold_until` in the `Container` interfaces. Rather than returning a `Finished_or_stopped_early.t` (which has also been removed), the function now takes a `finish` function that will be applied the result if `f` never returned a `Stop _`. - Removed the `String_dict` module. - Added a `Queue` module that is backed by an `Option_array` for efficient and (non-allocating) implementations of most operations. - Added a `Poly` submodule to `Map` and `Set` that exposes constructors that use polymorphic compare. - Deprecated `all_ignore` in the `Monad` and `Applicative` interfaces in favor of `all_unit`. - Deprecated `Array.replace_all` in favor of `Array.map_inplace`, which is the standard name for that sort of operation within Base. - Document that `List.find_exn`, and `List.find_map_exn` may throw `Caml.Not_found` _or_ `Not_found_s`. - Make `~compare` a required argument to `List.dedup_and_sort`, `List.dedup`, `List.find_a_dup`, `List.contains_dup`, and `List.find_all_dups`. - Removed `List.exn_if_dup`. It is still available in core_kernel. - Removed "normalized" index operation `List.slice`. It is still available in core_kernel. - Remove "normalized" index operations from `Array`, which incluced `Array.normalize`, `Array.slice`, `Array.nget` and `Array.nset`. These operations are still available in core_kernel. - Added `Uniform_array` module that is just like an `Array` except guarantees that the representation array is not tagged with `Double_array_tag`, the tag for float arrays. - Added `Option_array` module that allows for a compact representation of `'a optoin array`, which avoids allocating heap objects representing `Some a`. - Remove "normalized" index operations from `String`, which incluced `String.normalize`, `String.slice`, `String.nget` and `String.nset`. These operations are still available in core_kernel. - Added missing conversions between `Int63` and other integer types, specifically, the versions that return options. - Added truncating versions of integer conversions, with a suffix of `_trunc`. These allow fast conversions via bit arithmetic without any conditional failure; excess bits beyond the width of the output type are simply dropped. - Added `Sequence.group`, similar to `List.group`. - Reimplemented `String.Caseless.compare` so that it does not allocate. - Added `String.is_substring_at string ~pos ~substring`. Used it as back-end for `is_suffix` and `is_prefix`. - Moved all remaining `Replace_polymorphic_compare` submodules from Base types and consolidated them in one place within `Import0`. - Removed `(<=.)` and its friends. - Added `Sys.argv`. - Added a infix exponentation operator for int. - Added a `Formatter` module to reexport the `Format.formatter` type and updated the deprecation message for `Format`. ## v0.10 (Changes that can break existing programs are marked with a "\*") ### Bugfixes - Generalized the type of `Printf.ifprintf` to reflect OCaml's stdlib. - Made `Sequence.fold_m` and `iter_m` respect `Skip` steps and explicitly bind when they occur. - Changed `Float.is_negative` and `is_non_positive` on `NaN` to return `false` rather than `true`. - Fixed the `Validate.protect` function, which was mistakenly raising exceptions. ### API changes - Renamed `Map.add` as `set`, and deprecated `add`. A later feature will add `add` and `add_exn` in the style of `Hashtbl`. - A different hash function is used to implement `Base.Int.hash`. The old implementation was `Int.abs` but collision resistance is not enough, we want avalanching as well. The new function is an adaptation of one of the [Thomas Wang](http://web.archive.org/web/20071223173210/http://www.concentric.net/~Ttwang/tech/inthash.htm) hash functions to OCaml (63-bit integers), which results in reasonably good avalanching. - Made `open Base` expose infix float operators (+., -., etc.). * Renamed `List.dedup` to `List.dedup_and_sort`, to better reflect its existing behavior. - Added `Hashtbl.find_multi` and `Map.find_multi`. - Added function `Map.of_increasing_sequence` for constructing a `Map.t` from an ordered `Sequence.t` - Added function `List.chunks_of : 'a t -> length : int -> 'a t t`, for breaking a list into chunks of equal length. - Add to module `Random` numeric functions that take upper and lower inclusive bounds, e.g. `Random.int_incl : int -> int -> int`. * Replaced `Exn.Never_elide_backtrace` with `Backtrace.elide`, a `ref` cell that determines whether `Backtrace.to_string` and `Backtrace.sexp_of_t` elide backtraces. - Exposed infix operator `Base.( @@ )`. - Exposed modules `Base.Continue_or_stop` and `Finished_or_stopped_early`, used with the `Container.fold_until` function. - Exposed module types Base.T, T1, T2, and T3. - Added `Sequence.Expert` functions `next_step` and `delayed_fold_step`, for clients that want to explicitly handle `Skip` steps. - Added `Bytes` module. This includes the submodules `From_string` and `To_string` with blit functions. N.B. the signature (and name) of `unsafe_to_string` and `unsafe_of_string` are different from the one in the standard library (and hopefully more explicit). - Add bytes functions to `Buffer`. Also added `Buffer.content_bytes`, the analog of `contents` but that returns `bytes` rather than `string`. * Enabled `-safe-string`. - Added function `Int63.of_int32`, which was missing. * Deprecated a number of `String` mutating functions. - Added module `Obj_array`, moved in from `Core_kernel`. * In module type `Hashtbl.Accessors`, removed deprecated functions, moving them into a new module type, `Deprecated`. - Exported `sexp_*` types that are recognized by `ppx_sexp_*` converters: `sexp_array`, `sexp_list`, `sexp_opaque`, `sexp_option`. * Reworked the `Or_error` module's interface, moving the `Container.S` interface to an `Ok` submodule, and adding functions `is_ok`, `is_error`, and `ok` to more closely resemble the interface of the `Result` module. - Removed `Int.O.of_int_exn`. - Exposed `Base.force` function. - Changed the deprecation warning for `mod` to recommend `( % )` rather than `Caml.( mod )`. ### Performance related changes - Optimized `List.compare`, removing its closure allocation. - Optimized `String.mem` to not allocate. - Optimized `Float.is_negative`, `is_non_negative`, `is_positive`, and `is_non_positive` to avoid some boxing. - Changed `Hashtbl.merge` to relax its equality check on the input tables' `Hashable.t` records, checking physical equality componentwise if the records aren't physically equal. - Added `Result.combine_errors`, similar to `Or_error.combine_errors`, with a slightly different type. - Added `Result.combine_errors_unit`, similar to `Or_error.combine_errors_unit`. - Optimized the `With_return.return` type by adding the `[@@unboxed]` attribute. - Improved a number of deprecation warnings. ## v0.9 Initial release. base-0.16.3/CONTRIBUTING.md000066400000000000000000000044101446274340700147560ustar00rootroot00000000000000This repository contains open source software that is developed and maintained by [Jane Street][js]. Contributions to this project are welcome and should be submitted via GitHub pull requests. Signing contributions --------------------- We require that you sign your contributions. Your signature certifies that you wrote the patch or otherwise have the right to pass it on as an open-source patch. The rules are pretty simple: if you can certify the below (from [developercertificate.org][dco]): ``` Developer Certificate of Origin Version 1.1 Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 1 Letterman Drive Suite D4700 San Francisco, CA, 94129 Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Developer's Certificate of Origin 1.1 By making a contribution to this project, I certify that: (a) The contribution was created in whole or in part by me and I have the right to submit it under the open source license indicated in the file; or (b) The contribution is based upon previous work that, to the best of my knowledge, is covered under an appropriate open source license and I have the right under that license to submit that work with modifications, whether created in whole or in part by me, under the same open source license (unless I am permitted to submit under a different license), as indicated in the file; or (c) The contribution was provided directly to me by some other person who certified (a), (b) or (c) and I have not modified it. (d) I understand and agree that this project and the contribution are public and that a record of the contribution (including all personal information I submit with it, including my sign-off) is maintained indefinitely and may be redistributed consistent with this project or the open source license(s) involved. ``` Then you just add a line to every git commit message: ``` Signed-off-by: Joe Smith ``` Use your real name (sorry, no pseudonyms or anonymous contributions.) If you set your `user.name` and `user.email` git configs, you can sign your commit automatically with git commit -s. [dco]: http://developercertificate.org/ [js]: https://opensource.janestreet.com/ base-0.16.3/LICENSE.md000066400000000000000000000021461446274340700141350ustar00rootroot00000000000000The MIT License Copyright (c) 2016--2023 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. base-0.16.3/Makefile000066400000000000000000000004031446274340700141630ustar00rootroot00000000000000INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) default: dune build install: dune install $(INSTALL_ARGS) uninstall: dune uninstall $(INSTALL_ARGS) reinstall: uninstall install clean: dune clean .PHONY: default install uninstall reinstall clean base-0.16.3/README.org000066400000000000000000000160101446274340700141720ustar00rootroot00000000000000* Base [[https://github.com/janestreet/base/actions][https://github.com/janestreet/base/actions/workflows/workflow.yml/badge.svg]] Base is a standard library for OCaml. It provides a standard set of general purpose modules that are well-tested, performant, and fully-portable across any environment that can run OCaml code. Unlike other standard library projects, Base is meant to be used as a wholesale replacement of the standard library distributed with the OCaml compiler. In particular it makes different choices and doesn't re-export features that are not fully portable such as I/O, which are left to other libraries. You also might want to browse the [[https://ocaml.janestreet.com/ocaml-core/latest/doc/base/index.html][API Documentation]]. ** Installation Install Base via [[https://opam.ocaml.org][OPAM]]: #+begin_src $ opam install base #+end_src Base has no runtime dependencies and is fast to build. Its sole build dependencies are [[https://github.com/ocaml/dune][dune]], which itself requires nothing more than the compiler, and [[https://github.com/janestreet/sexplib0][sexplib0]]. ** Using the OCaml standard library with Base Base is intended as a full stdlib replacement. As a result, after an =open Base=, all the modules, values, types, ... coming from the OCaml standard library that one normally gets in the default environment are deprecated. In order to access these values, one must use the =Stdlib= library, which re-exports them all through the toplevel name =Stdlib=: =Stdlib.String=, =Stdlib.print_string=, ... ** Differences between Base and the OCaml standard library Programmers who are used to the OCaml standard library should read through this section to understand major differences between the two libraries that one should be aware of when switching to Base. *** Comparison operators The comparison operators exposed by the OCaml standard library are polymorphic: #+begin_src ocaml val compare : 'a -> 'a -> int val ( <= ) : 'a -> 'a -> bool ... #+end_src What they implement is structural comparison of the runtime representation of values. Since these are often error-prone, i.e. they don't correspond to what the user expects, they are not exposed directly by Base. To use polymorphic comparison with Base, one should use the =Poly= module. The default comparison operators exposed by Base are the integer ones, just like the default arithmetic operators are the integer ones. The recommended way to compare arbitrary complex data structures is to use the specific =compare= functions. For instance: #+begin_src ocaml List.compare String.compare x y #+end_src The [[https://github.com/janestreet/ppx_compare][ppx_compare]] rewriter offers an alternative way to write this: #+begin_src ocaml [%compare: string list] x y #+end_src ** Base and ppx code generators Base uses a few ppx code generators to implement: - reliable and customizable comparison of OCaml values - reliable and customizable hash of OCaml values - conversions between OCaml values and s-expression However, it doesn't need these code generators to build. What it does instead is use ppx as a code verification tool during development. It works in a very similar fashion to [[https://github.com/janestreet/ppx_expect][expectation tests]]. Whenever you see this in the code source: #+begin_src ocaml type t = ... [@@deriving_inline sexp_of] let sexp_of_t = ... [@@@end] #+end_src the code between the =[@@deriving_inline]= and the =[@@@end]= is generated code. The generated code is currently quite big and hard to read, however we are working on making it look like human-written code. You can put the following elisp code in your =~/.emacs= file to hide these blocks: #+begin_src scheme (defun deriving-inline-forward-sexp (&optional arg) (search-forward-regexp "\\[@@@end\\]") nil nil arg) (defun setup-hide-deriving-inline () (inline) (hs-minor-mode t) (let ((hs-hide-comments-when-hiding-all nil)) (hs-hide-all))) (require 'hideshow) (add-to-list 'hs-special-modes-alist '(tuareg-mode "\\[@@deriving_inline[^]]*\\]" "\\[@@@end\\]" nil deriving-inline-forward-sexp nil)) (add-hook 'tuareg-mode-hook 'setup-hide-deriving-inline) #+end_src Things are not yet setup in the git repository to make it convenient to change types and update the generated code, but they will be setup soon. ** Base coding rules There are a few coding rules across the code base that are enforced by lint tools. These rules are: - Opening the =Stdlib= module is not allowed. Inside Base, the OCaml stdlib is shadowed and accessible through the =Stdlib= module. We forbid opening =Stdlib= so that we know exactly where things come from. - =Stdlib.Foo= modules cannot be aliased, one must use =Stdlib.Foo= explicitly. This is to avoid having to remember a list of aliases at the beginning of each file. - For some modules that are both in the OCaml stdlib and Base, such as =String=, we define a module =String0= for common functions that cannot be defined directly in =Base.String= to avoid creating a circular dependency. Except for =String= itself, other modules are not allowed to use =Stdlib.String= and must use either =String= or =String0= instead. - Indentation is exactly the one of =ocp-indent=. - A few other coding style rules enforced by [[https://github.com/janestreet/ppx_js_style][ppx_js_style]]. The Base specific coding rules are checked by =ppx_base_lint=, in the =lint= subfolder. The indentation rules are checked by a wrapper around =ocp-indent= and the coding style rules are checked by =ppx_js_style=. These checks are currently not run by =dune=, but it will soon get a =-dev= flag to run them automatically. ** Sexp (de-)serializers Most types in Base have ~sexp_of_t~ and ~t_of_sexp~ functions for converting between values of that type and their sexp representations. One pair of functions deserves special attention: ~String.sexp_of_t~ and ~String.t_of_sexp~. These functions have the same types as ~Sexp.of_string~ and ~Sexp.to_string~ but very different behavior. ~String.sexp_of_t~ and ~String.t_of_sexp~ are used to encode and decode strings "embedded" in a sexp representation. On the other hand, ~Sexp.of_string~ and ~Sexp.to_string~ are used to encode and decode the textual form of s-expressions. The following example demonstrates the two pairs of functions in action: #+begin_src ocaml open! Base open! Stdio (* Embed a string in a sexp *) let example_sexp : Sexp.t = List.sexp_of_t String.sexp_of_t [ "hello"; "world" ] let () = assert (Sexp.equal example_sexp (Sexp.List [ Sexp.Atom "hello"; Sexp.Atom "world" ])) ;; let () = assert ( List.equal String.equal [ "hello"; "world" ] (List.t_of_sexp String.t_of_sexp example_sexp)) ;; (* Embed a sexp in text (string) *) let write_sexp_to_file sexp = Out_channel.write_all "/tmp/file" ~data:(Sexp.to_string example_sexp) ;; (* /tmp/file now contains: {v (hello world) v} *) let () = assert (Sexp.equal example_sexp (Sexp.of_string (In_channel.read_all "/tmp/file"))) ;; #+end_src base-0.16.3/ROADMAP.md000066400000000000000000000104721446274340700141370ustar00rootroot00000000000000# Stable Interface (v1.0) - [X] Make the entire library `-safe-string` compliant. This will involve introducing a `Bytes` module, removing all direct mutation on strings from the `String` module, and "re-typing" string values that require mutation to `bytes`. - [X] Do not export the `\*\_intf` modules from Base. Instead, any signatures should be exported by the `.ml` and `.mli`s. - [X] Only expose the first-class module interface of `Hashtbl`. Accompanying this should be cleanup of `Hashtbl_intf`, moving anything that's still required in core_kernel to the appropriate files in that project. - [X] Replace `Hashtbl.create (module String) ()` by just `Hashtbl.create (module String)` - [X] Remove `replace` from `Hashtbl_intf.Accessors`. - [X] Label one of the arguments of `Hashtbl_intf.merge_into` to indicate the flow of data. - [X] Merge `Hashtbl_intf.Key_common` and `Hashtbl_intf.Key_plain`. - [X] Use `Either.t` as the return value for `Map.partition`. - [X] Rename `Monad_intf.all_ignore` to `Monad_intf.all_unit`. - [ ] Eliminate all uses of `Not_found`, replacing them with descriptive error messages. - [X] Move the various private modules to `Base.Base_private` instead of `Base.Exported_for_specific_uses` and `Base.Not_exposed_properly` - [X] Use `compare` rather than `cmp` as the label for comparison functions throughout. # Implementation Cleanup - [ ] Remove `ignore` and `(=)` from `Sexp_conv`'s public interface. These values are hidden from the documentation so their removal won't be considered a breaking API change. - [ ] Do not expose the type equality `Int63_emul.W.t = int64`. - [ ] Replace the exception thrown by `Float.of_string` with a named exception that's more descriptive. - [X] Delete the `Hashable` toplevel module. This is a vestige of the previous `Map` and `Set` implementations and is no longer needed. - [ ] Ensure that `Map` operations that are effective NO-OPs return the same `Map.t` they were provided. Candidate operations include e.g `add`, `remove`, `filter`. - [ ] Simplify the implementation of `Option.value_exn`, if possible. - [ ] Eliminate all instances of `open! Polymorphic_compare` - [ ] Refactor common blit code in `String.replace_all` and `String.replace_first`. - [ ] Delete unused function aliases in `Import0` - [ ] Put `Sexp_conv.Exn_converter` into its own file, with only an alias in Sexp_conv, so that it doesn't get pulled unless used - [ ] Create a file with all the basic types and their associated combinators (`sexp_of_t`, `compare`, `hash`), and expose the declaration - [ ] Put all the exported private modules from `Base.Exported_for_specific_uses` and `Base.Not_exposed_properly` in `Base.Base_private` - [ ] Decide on a better name for `Polymorphic_compare`. `Polymorphic_compare_intf` contains interface for comparison of non-polymorphic types, which is weird. Get rid of it and inline things in `Comparable_intf` - [X] `hashtbl_of_sexp` shouldn't live in Base.Sexp_conv since we have our own hash tables. Move it to sexplib # Performance Improvements - [ ] In `Hash_set.diff`, use the size of each set to determine which to iterate over. - [ ] Ensure that the correct `compare` function and other related functions are exported by all modules. These functions should not be derived from a functor application, in order to ensure proper inlining. Implementing this change should also include benchmarks to verify the initial result, and to maintain it on an ongoing basis. See `bench/bench_int.ml` for examples. - [X] Optimize `Lazy.compare` by performing a `phys_equal` check before forcing the lazy value. Note that this will also change the semantics of `compare` and should be documented and rolled out with care. - [ ] Conduct a thorough performance review of the `Sequence` module. # Documentation - [ ] Consolidate documentation the interface and implementation files related to the `Hash` module. - [ ] Add documentation to the `Ref` toplevel module. - [ ] Document properly how `String.unescape_gen` handles malformed strings # Changes For The Distant Future - [ ] Make the various comparison functions return an `Ordering.t` instead of an `int`. base-0.16.3/base.opam000066400000000000000000000021431446274340700143160ustar00rootroot00000000000000opam-version: "2.0" version: "v0.16.3" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/base" bug-reports: "https://github.com/janestreet/base/issues" dev-repo: "git+https://github.com/janestreet/base.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/base/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "4.14.0"} "sexplib0" {>= "v0.16" & < "v0.17"} "dune" {>= "2.0.0"} "dune-configurator" ] synopsis: "Full standard library replacement for OCaml" description: " Full standard library replacement for OCaml Base is a complete and portable alternative to the OCaml standard library. It provides all standard functionalities one would expect from a language standard library. It uses consistent conventions across all of its module. Base aims to be usable in any context. As a result system dependent features such as I/O are not offered by Base. They are instead provided by companion libraries such as stdio: https://github.com/janestreet/stdio " base-0.16.3/compiler-stdlib/000077500000000000000000000000001446274340700156175ustar00rootroot00000000000000base-0.16.3/compiler-stdlib/src/000077500000000000000000000000001446274340700164065ustar00rootroot00000000000000base-0.16.3/compiler-stdlib/src/caml.ml000066400000000000000000000001121446274340700176460ustar00rootroot00000000000000[@@@deprecated "[since v0.16] use Stdlib instead of Caml"] include Stdlib base-0.16.3/compiler-stdlib/src/dune000066400000000000000000000001141446274340700172600ustar00rootroot00000000000000(library (name caml) (public_name base.caml) (preprocess no_preprocessing)) base-0.16.3/dune-project000066400000000000000000000000201446274340700150400ustar00rootroot00000000000000(lang dune 1.10)base-0.16.3/generate/000077500000000000000000000000001446274340700143205ustar00rootroot00000000000000base-0.16.3/generate/dune000066400000000000000000000001411446274340700151720ustar00rootroot00000000000000(executables (names generate_pow_overflow_bounds) (libraries num) (preprocess no_preprocessing))base-0.16.3/generate/generate_pow_overflow_bounds.ml000066400000000000000000000111501446274340700226240ustar00rootroot00000000000000(* NB: This needs to be pure OCaml (no Base!), since we need this in order to build Base. *) (* This module generates lookup tables to detect integer overflow when calculating integer exponents. At index [e], [table.[e]^e] will not overflow, but [(table[e] + 1)^e] will. *) type mode = | Normal | Atomic of { out_fn : string ; tmp_fn : string } let oc, mode = match Sys.argv with | [| _ |] -> stdout, Normal | [| _; "-o"; out_fn |] | [| _; "-atomic"; "-o"; out_fn |] -> (* Always produce the file atomically, we just have this option to remember that we need to do it *) let tmp_fn, oc = Filename.open_temp_file ~temp_dir:(Filename.dirname out_fn) "generate_pow_overflow_bounds" ".ml.tmp" in oc, Atomic { out_fn; tmp_fn } | _ -> failwith "bad command line arguments" ;; module Big_int = struct include Big_int let ( > ) = gt_big_int let ( <= ) = le_big_int let ( ^ ) = power_big_int_positive_int let ( - ) = sub_big_int let ( + ) = add_big_int let one = unit_big_int let sqrt = sqrt_big_int let to_string = string_of_big_int end module Array = StdLabels.Array type generated_type = | Int | Int32 | Int63 | Int64 let max_big_int_for_bits bits = let shift = bits - 1 in (* sign bit *) Big_int.(shift_left_big_int one shift - one) ;; let safe_to_print_as_int = let int31_max = max_big_int_for_bits 31 in fun x -> Big_int.(x <= int31_max) ;; let format_entry typ b = let s = Big_int.to_string b in match typ with | Int -> if safe_to_print_as_int b then s else Printf.sprintf "Stdlib.Int64.to_int %sL" s | Int32 -> s ^ "l" | Int63 | Int64 -> s ^ "L" ;; let bits = function | Int -> assert false (* architecture dependent *) | Int32 -> 32 | Int63 -> 63 | Int64 -> 64 ;; let max_val typ = max_big_int_for_bits (bits typ) let name = function | Int -> "int" | Int32 -> "int32" | Int63 -> "int63_on_int64" | Int64 -> "int64" ;; let ocaml_type_name = function | Int -> "int" | Int32 -> "int32" | Int63 | Int64 -> "int64" ;; let generate_negative_bounds = function | Int -> false | Int32 -> false | Int63 -> false | Int64 -> true ;; let highest_base exponent max_val = let open Big_int in match exponent with | 0 | 1 -> max_val | 2 -> sqrt max_val | _ -> let rec search possible_base = if possible_base ^ exponent > max_val then ( let res = possible_base - one in assert (res ^ exponent <= max_val); res) else search (possible_base + one) in search one ;; type sign = | Pos | Neg let pr fmt = Printf.fprintf oc (fmt ^^ "\n") let gen_array ~typ ~bits ~sign ~indent = let pr fmt = pr ("%*s" ^^ fmt) indent "" in let max_val = max_big_int_for_bits bits in let pos_bounds = Array.init 64 ~f:(fun i -> highest_base i max_val) in let bounds = match sign with | Pos -> pos_bounds | Neg -> Array.map pos_bounds ~f:Big_int.minus_big_int in pr "[| %s" (format_entry typ bounds.(0)); for i = 1 to Array.length bounds - 1 do pr "; %s" (format_entry typ bounds.(i)) done; pr "|]" ;; let gen_bounds typ = pr "let overflow_bound_max_%s_value : %s =" (name typ) (ocaml_type_name typ); (match typ with | Int -> pr " (-1) lsr 1" | _ -> pr " %s" (format_entry typ (max_val typ))); pr ""; let array_name typ sign = Printf.sprintf "%s_%s_overflow_bounds" (name typ) (match sign with | Pos -> "positive" | Neg -> "negative") in pr "let %s : %s array =" (array_name typ Pos) (ocaml_type_name typ); (match typ with | Int -> pr " match Int_conversions.num_bits_int with"; pr " | 32 -> Array.map %s ~f:Stdlib.Int32.to_int" (array_name Int32 Pos); pr " | 63 ->"; gen_array ~typ ~bits:63 ~sign:Pos ~indent:4; pr " | 31 ->"; gen_array ~typ ~bits:31 ~sign:Pos ~indent:4; pr " | _ -> assert false" | _ -> gen_array ~typ ~bits:(bits typ) ~sign:Pos ~indent:2); pr ""; if generate_negative_bounds typ then ( pr "let %s : %s array =" (array_name typ Neg) (ocaml_type_name typ); gen_array ~typ ~bits:(bits typ) ~sign:Neg ~indent:2) ;; let () = pr "(* This file was autogenerated by %s *)" Sys.argv.(0); pr ""; pr "open! Import"; pr ""; pr "module Array = Array0"; pr ""; pr "(* We have to use Int64.to_int_exn instead of int constants to make"; pr " sure that file can be preprocessed on 32-bit machines. *)"; pr ""; gen_bounds Int32; gen_bounds Int; gen_bounds Int63; gen_bounds Int64 ;; let () = match mode with | Normal -> () | Atomic { tmp_fn; out_fn } -> close_out oc; Sys.rename tmp_fn out_fn ;; base-0.16.3/generate/generate_pow_overflow_bounds.mli000066400000000000000000000000551446274340700227770ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/hash_types/000077500000000000000000000000001446274340700146755ustar00rootroot00000000000000base-0.16.3/hash_types/README.org000066400000000000000000000002141446274340700163400ustar00rootroot00000000000000#+TITLE: Base_internalhash_types This micro-library allows hash states, seeds, and values to be type-equal between ~Base~ and ~Base_boot~. base-0.16.3/hash_types/src/000077500000000000000000000000001446274340700154645ustar00rootroot00000000000000base-0.16.3/hash_types/src/base_internalhash_types.ml000066400000000000000000000015071446274340700227170ustar00rootroot00000000000000(** [state] is defined as a subtype of [int] using the [private] keyword. This makes it an opaque type for most purposes, and tells the compiler that the type is immediate. *) type state = private int type seed = int type hash_value = int external create_seeded : seed -> state = "%identity" [@@noalloc] external fold_int64 : state -> int64 -> state = "Base_internalhash_fold_int64" [@@noalloc] external fold_int : state -> int -> state = "Base_internalhash_fold_int" [@@noalloc] external fold_float : state -> float -> state = "Base_internalhash_fold_float" [@@noalloc] external fold_string : state -> string -> state = "Base_internalhash_fold_string" [@@noalloc] external get_hash_value : state -> hash_value = "Base_internalhash_get_hash_value" [@@noalloc] base-0.16.3/hash_types/src/dune000066400000000000000000000003521446274340700163420ustar00rootroot00000000000000(library (name base_internalhash_types) (public_name base.base_internalhash_types) (libraries) (preprocess no_preprocessing) (js_of_ocaml (javascript_files runtime.js)) (c_names internalhash_stubs) (install_c_headers internalhash))base-0.16.3/hash_types/src/internalhash.h000066400000000000000000000002061446274340700203130ustar00rootroot00000000000000#include #include CAMLexport uint32_t Base_internalhash_fold_blob(uint32_t h, mlsize_t len, uint8_t *s); base-0.16.3/hash_types/src/internalhash_stubs.c000066400000000000000000000051231446274340700215310ustar00rootroot00000000000000#include #include #include #include "internalhash.h" /* This pretends that the state of the OCaml internal hash function, which is an int32, is actually stored in an OCaml int. */ CAMLprim value Base_internalhash_fold_int32(value st, value i) { return Val_long(caml_hash_mix_uint32(Long_val(st), Int32_val(i))); } CAMLprim value Base_internalhash_fold_nativeint(value st, value i) { return Val_long(caml_hash_mix_intnat(Long_val(st), Nativeint_val(i))); } CAMLprim value Base_internalhash_fold_int64(value st, value i) { return Val_long(caml_hash_mix_int64(Long_val(st), Int64_val(i))); } CAMLprim value Base_internalhash_fold_int(value st, value i) { return Val_long(caml_hash_mix_intnat(Long_val(st), Long_val(i))); } CAMLprim value Base_internalhash_fold_float(value st, value i) { return Val_long(caml_hash_mix_double(Long_val(st), Double_val(i))); } /* This code mimics what hashtbl.hash does in OCaml's hash.c */ #define FINAL_MIX(h) \ h ^= h >> 16; \ h *= 0x85ebca6b; \ h ^= h >> 13; \ h *= 0xc2b2ae35; \ h ^= h >> 16; CAMLprim value Base_internalhash_get_hash_value(value st) { uint32_t h = Int_val(st); FINAL_MIX(h); return Val_int(h & 0x3FFFFFFFU); /*30 bits*/ } /* Macros copied from hash.c in ocaml distribution */ #define ROTL32(x,n) ((x) << n | (x) >> (32-n)) #define MIX(h,d) \ d *= 0xcc9e2d51; \ d = ROTL32(d, 15); \ d *= 0x1b873593; \ h ^= d; \ h = ROTL32(h, 13); \ h = h * 5 + 0xe6546b64; /* Version of [caml_hash_mix_string] from hash.c - adapted for arbitrary char arrays */ CAMLexport uint32_t Base_internalhash_fold_blob(uint32_t h, mlsize_t len, uint8_t *s) { mlsize_t i; uint32_t w; /* Mix by 32-bit blocks (little-endian) */ for (i = 0; i + 4 <= len; i += 4) { #ifdef ARCH_BIG_ENDIAN w = s[i] | (s[i+1] << 8) | (s[i+2] << 16) | (s[i+3] << 24); #else w = *((uint32_t *) &(s[i])); #endif MIX(h, w); } /* Finish with up to 3 bytes */ w = 0; switch (len & 3) { case 3: w = s[i+2] << 16; /* fallthrough */ case 2: w |= s[i+1] << 8; /* fallthrough */ case 1: w |= s[i]; MIX(h, w); default: /*skip*/; /* len & 3 == 0, no extra bytes, do nothing */ } /* Finally, mix in the length. Ignore the upper 32 bits, generally 0. */ h ^= (uint32_t) len; return h; } CAMLprim value Base_internalhash_fold_string(value st, value v_str) { uint32_t h = Long_val(st); mlsize_t len = caml_string_length(v_str); uint8_t *s = (uint8_t *) String_val(v_str); h = Base_internalhash_fold_blob(h, len, s); return Val_long(h); } base-0.16.3/hash_types/src/runtime.js000066400000000000000000000012771446274340700175140ustar00rootroot00000000000000//Provides: Base_internalhash_fold_int64 //Requires: caml_hash_mix_int64 var Base_internalhash_fold_int64 = caml_hash_mix_int64; //Provides: Base_internalhash_fold_int //Requires: caml_hash_mix_int var Base_internalhash_fold_int = caml_hash_mix_int; //Provides: Base_internalhash_fold_float //Requires: caml_hash_mix_float var Base_internalhash_fold_float = caml_hash_mix_float; //Provides: Base_internalhash_fold_string //Requires: caml_hash_mix_string var Base_internalhash_fold_string = caml_hash_mix_string; //Provides: Base_internalhash_get_hash_value //Requires: caml_hash_mix_final function Base_internalhash_get_hash_value(seed) { var h = caml_hash_mix_final(seed); return h & 0x3FFFFFFF; } base-0.16.3/hash_types/test/000077500000000000000000000000001446274340700156545ustar00rootroot00000000000000base-0.16.3/hash_types/test/dune000066400000000000000000000001721446274340700165320ustar00rootroot00000000000000(library (name base_internalhash_types_test) (libraries base expect_test_helpers_core stdio) (preprocess (pps ppx_jane)))base-0.16.3/hash_types/test/import.ml000066400000000000000000000000571446274340700175220ustar00rootroot00000000000000include Stdio include Expect_test_helpers_core base-0.16.3/hash_types/test/test_immediate.ml000066400000000000000000000005261446274340700212060ustar00rootroot00000000000000open! Base open! Import let%expect_test "[Base.Hash.state] is still immediate" = require_no_allocation [%here] (fun () -> ignore (Sys.opaque_identity (Base.Hash.create ()))); [%expect {| |}] let%expect_test _ = print_s [%sexp (Stdlib.Obj.is_int (Stdlib.Obj.repr (Base.Hash.create ~seed:1 ())) : bool)]; [%expect {| true |}]; ;; base-0.16.3/hash_types/test/test_immediate.mli000066400000000000000000000000551446274340700213540ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/lint/000077500000000000000000000000001446274340700134745ustar00rootroot00000000000000base-0.16.3/lint/dune000066400000000000000000000002101446274340700143430ustar00rootroot00000000000000(library (name ppx_base_lint) (kind ppx_rewriter) (libraries compiler-libs.common base ppxlib ppx_cold) (preprocess no_preprocessing))base-0.16.3/lint/ppx_base_lint.ml000066400000000000000000000134521446274340700166620ustar00rootroot00000000000000open Ppxlib open Base let error ~loc fmt = Location.raise_errorf ~loc (Stdlib.( ^^ ) "ppx_base_lint:" fmt) type suspicious_id = Stdlib_submodule of string let rec iter_suspicious (id : Longident.t) ~f = match id with | Ldot (Lident "Stdlib", s) when String.( <> ) s "" && match s.[0] with | 'A' .. 'Z' -> true | _ -> false -> f (Stdlib_submodule s) | Ldot (x, _) -> iter_suspicious x ~f | Lapply (a, b) -> iter_suspicious a ~f; iter_suspicious b ~f | Lident _ -> () ;; let zero_modules () = Stdlib.Sys.readdir "." |> Array.to_list |> List.filter ~f:(fun fn -> Stdlib.Filename.check_suffix fn "0.ml") |> List.map ~f:(fun fn -> String.capitalize (String.sub fn ~pos:0 ~len:(String.length fn - 4))) |> Set.of_list (module String) ;; let check_open (id : Longident.t Asttypes.loc) = match id.txt with | Lident "Stdlib" -> error ~loc:id.loc "you are not allowed to open Stdlib inside Base" | _ -> () ;; let rec is_stdlib_dot_something : Longident.t -> bool = function | Ldot (Lident "Stdlib", _) -> true | Ldot (id, _) -> is_stdlib_dot_something id | _ -> false ;; let print_payload ppf = function | PStr x -> Pprintast.structure ppf x | PSig x -> Pprintast.signature ppf x | PTyp x -> Pprintast.core_type ppf x | PPat (x, None) -> Pprintast.pattern ppf x | PPat (x, Some w) -> Stdlib.Format.fprintf ppf "%a@ when@ %a" Pprintast.pattern x Pprintast.expression w ;; let remove_loc = object inherit Ast_traverse.map method! location _ = Location.none method! location_stack _ = [] end ;; let check current_module = let zero_modules = zero_modules () in object inherit Ast_traverse.iter as super method! longident_loc { txt = id; loc } = (* Note: we don't distinguish between module identifiers and constructors names. Since there is no [Stdlib.String], [Stdlib.Array], ... constructors this is not a problem. *) iter_suspicious id ~f:(fun (Stdlib_submodule m) -> if not (Set.mem zero_modules m) then (* We are allowed to use Stdlib modules that don't have a Foo0 version *) () else if String.equal (m ^ "0") current_module then () (* Foo0 is allowed to use Stdlib.Foo *) else ( match current_module with | "Import0" | "Base" -> () | _ -> error ~loc "you cannot use [Stdlib.%s] here, use [%s0] instead" m m)) (* We allow references to Stdlib in types. This is primarily to allow ppx-derived code to refer to Stdlib. *) method! core_type _ = () method! expression e = super#expression e; match e.pexp_desc with | Pexp_open ({ popen_expr = { pmod_desc = Pmod_ident id; _ }; _ }, _) -> check_open id | _ -> () method! open_description op = super#open_description op; check_open op.popen_expr method! module_binding mb = super#module_binding mb; match current_module with | "Import0" -> () | _ -> (match mb.pmb_expr.pmod_desc with | Pmod_ident { txt = id; _ } when is_stdlib_dot_something id -> error ~loc:mb.pmb_loc "you cannot alias [Stdlib] sub-modules, use them directly" | _ -> ()) method! attributes attrs = super#attributes attrs; let is_cold attr = String.equal attr.attr_name.txt "cold" in match List.find attrs ~f:is_cold with | None -> () | Some attr -> let expansion = Ppx_cold.expand_cold_attribute attr |> List.map ~f:(fun a -> { a with attr_name = { a.attr_name with txt = String.chop_prefix a.attr_name.txt ~prefix:"ocaml." |> Option.value ~default:a.attr_name.txt } }) in let is_part_of_expansion attr = List.exists expansion ~f:(fun a -> String.equal a.attr_name.txt attr.attr_name.txt || String.equal ("ocaml." ^ a.attr_name.txt) attr.attr_name.txt) in let new_attrs = List.concat_map attrs ~f:(fun a -> if is_cold a then a :: expansion else if is_part_of_expansion a then [] else [ a ]) in if not (Poly.equal (remove_loc#attributes attrs) (remove_loc#attributes new_attrs)) then ( (* Remove attributes written by the user that correspond to attributes in the expansion *) List.iter attrs ~f:(fun a -> if is_part_of_expansion a then Driver.register_correction ~loc:a.attr_loc ~repl:""); let attribute_level = String.make (attr.attr_name.loc.loc_start.pos_cnum - attr.attr_loc.loc_start.pos_cnum - 1) '@' in let repl = Stdlib.Format.asprintf "@[%a@]" (Stdlib.Format.pp_print_list (fun ppf x -> Stdlib.Format.fprintf ppf "[%s%s@ %a]" attribute_level x.attr_name.txt print_payload x.attr_payload)) (attr :: expansion) in Driver.register_correction ~loc:attr.attr_loc ~repl) end ;; let module_of_loc (loc : Location.t) = String.capitalize (Stdlib.Filename.chop_extension (Stdlib.Filename.basename loc.loc_start.pos_fname)) ;; let () = Ppxlib.Driver.register_transformation "base_lint" ~impl:(function | [] -> [] | { pstr_loc = loc; _ } :: _ as st -> (check (module_of_loc loc))#structure st; st) ~intf:(function | [] -> [] | { psig_loc = loc; _ } :: _ as sg -> (check (module_of_loc loc))#signature sg; sg) ;; base-0.16.3/md5/000077500000000000000000000000001446274340700132135ustar00rootroot00000000000000base-0.16.3/md5/src/000077500000000000000000000000001446274340700140025ustar00rootroot00000000000000base-0.16.3/md5/src/dune000066400000000000000000000001731446274340700146610ustar00rootroot00000000000000(library (name md5_lib) (public_name base.md5) (preprocess no_preprocessing) (libraries) (js_of_ocaml (javascript_files)))base-0.16.3/md5/src/md5_lib.ml000066400000000000000000000010031446274340700156410ustar00rootroot00000000000000type t = string (* Share the digest of the empty string *) let empty = Digest.string "" let make s = if s = empty then empty else s let compare = compare let length = 16 let to_binary s = s let of_binary_exn s = assert (String.length s = length); make s let unsafe_of_binary = make let to_hex = Digest.to_hex let of_hex_exn s = make (Digest.from_hex s) let string s = make (Digest.string s) let bytes s = make (Digest.bytes s) let subbytes bytes ~pos ~len = make (Digest.subbytes bytes pos len) base-0.16.3/md5/src/md5_lib.mli000066400000000000000000000006401446274340700160200ustar00rootroot00000000000000type t val compare : t -> t -> int (** [length = 16] is the size of the digest in bytes. *) val length : int val to_binary : t -> string val of_binary_exn : string -> t (** assumes the input is 16 bytes without checking *) val unsafe_of_binary : string -> t val to_hex : t -> string val of_hex_exn : string -> t val string : string -> t val bytes : bytes -> t val subbytes : bytes -> pos:int -> len:int -> t base-0.16.3/shadow-stdlib/000077500000000000000000000000001446274340700152725ustar00rootroot00000000000000base-0.16.3/shadow-stdlib/gen/000077500000000000000000000000001446274340700160435ustar00rootroot00000000000000base-0.16.3/shadow-stdlib/gen/dune000066400000000000000000000002061446274340700167170ustar00rootroot00000000000000(executables (names gen) (libraries str compiler-libs.common) (link_flags -linkall) (preprocess no_preprocessing)) (ocamllex mapper)base-0.16.3/shadow-stdlib/gen/gen.ml000066400000000000000000000025561446274340700171560ustar00rootroot00000000000000open StdLabels let () = (* -permissive indicates that we should tolerate additions to stdlib. It's [true] in public-release so that new versions of the stdlib can be compatible with base, but it should be [false] internally so that we remember to consider implementing the equivalents in base. *) let permissive, cmi_fn, oc = match Sys.argv with | [| _; "-caml-cmi"; cmi_fn; "-o"; fn |] -> false, cmi_fn, open_out fn | [| _; "-caml-cmi"; "-permissive"; cmi_fn1; cmi_fn2; "-o"; fn |] -> let cmi_fn = if Sys.file_exists cmi_fn1 then cmi_fn1 else cmi_fn2 in true, cmi_fn, open_out fn | _ -> failwith "bad command line arguments" in try let cmi = Cmi_format.read_cmi cmi_fn in let buf = Buffer.create 512 in let pp = Format.formatter_of_buffer buf in Format.pp_set_margin pp max_int; (* so we can parse line by line below *) Format.fprintf pp "%a@." Printtyp.signature cmi.Cmi_format.cmi_sign; let s = Buffer.contents buf in let lines = Str.split (Str.regexp "\n") s in Printf.fprintf oc "[@@@warning \"-3\"]\n\n"; Mapper.permissive := permissive; List.iter lines ~f:(fun line -> let repl = Mapper.line (Lexing.from_string line) in if repl <> "" then Printf.fprintf oc "%s\n\n" repl); flush oc with | exn -> Location.report_exception Format.err_formatter exn; exit 2 ;; base-0.16.3/shadow-stdlib/gen/gen.mli000066400000000000000000000000551446274340700173170ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/shadow-stdlib/gen/mapper.mll000066400000000000000000000352051446274340700200420ustar00rootroot00000000000000{ open StdLabels open Printf let deprecated_msg ~is_exn what = sprintf "[%sdeprecated \"\\\n\ [2016-09] this element comes from the stdlib distributed with OCaml.\n\ Referring to the stdlib directly is discouraged by Base. You should either\n\ use the equivalent functionality offered by Base, or if you really want to\n\ refer to the stdlib, use Stdlib.%s instead\"]" (if is_exn then "@" else "@@") what let deprecated_msg_no_equivalent ~is_exn what = sprintf "[%sdeprecated \"\\\n\ [2016-09] this element comes from the stdlib distributed with OCaml.\n\ There is not equivalent functionality in Base or Stdio at the moment,\n\ so you need to use [Stdlib.%s] instead\"]" (if is_exn then "@" else "@@") what let deprecated_msg_with_repl_text ~is_exn text = sprintf "[%sdeprecated \"\\\n\ [2016-09] this element comes from the stdlib distributed with OCaml.\n\ %s.\"]" (if is_exn then "@" else "@@") text let deprecated_msg_with_repl ~is_exn repl = deprecated_msg_with_repl_text ~is_exn (sprintf "Use [%s] instead" repl) let deprecated_msg_with_approx_repl ~is_exn ~id repl = sprintf "[%sdeprecated \"\\\n\ [2016-09] this element comes from the stdlib distributed with OCaml.\n\ There is no equivalent functionality in Base or Stdio but you can use\n\ [%s] instead.\n\ Alternatively, if you really want to refer the stdlib you can use\n\ [Stdlib.%s].\"]" (if is_exn then "@" else "@@") repl id type replacement = | No_equivalent | Repl of string | Repl_text of string | Approx of string let permissive = ref false let val_replacement = function | "( ! )" -> No_equivalent | "( != )" -> Repl "not (phys_equal ...)" | "( & )" -> No_equivalent | "( && )" -> No_equivalent | "( * )" -> No_equivalent | "( ** )" -> Repl "**." | "( *. )" -> No_equivalent | "( + )" -> No_equivalent | "( +. )" -> No_equivalent | "( - )" -> No_equivalent | "( -. )" -> No_equivalent | "( / )" -> No_equivalent | "( /. )" -> No_equivalent | "( := )" -> No_equivalent | "( < )" -> No_equivalent | "( <= )" -> No_equivalent | "( <> )" -> No_equivalent | "( = )" -> No_equivalent | "( == )" -> Repl "phys_equal" | "( > )" -> No_equivalent | "( >= )" -> No_equivalent | "( @ )" -> No_equivalent | "( @@ )" -> No_equivalent | "( ^ )" -> No_equivalent | "( ^^ )" -> No_equivalent | "( asr )" -> No_equivalent | "( land )" -> No_equivalent | "( lor )" -> No_equivalent | "( lsl )" -> No_equivalent | "( lsr )" -> No_equivalent | "( lxor )" -> No_equivalent | "( mod )" -> Repl_text "Use (%), which has slightly different semantics, or Int.rem which is equivalent" | "( or )" -> No_equivalent | "( |> )" -> No_equivalent | "( || )" -> No_equivalent | "( ~+ )" -> No_equivalent | "( ~+. )" -> No_equivalent | "( ~- )" -> No_equivalent | "( ~-. )" -> No_equivalent | "__FILE__" -> No_equivalent | "__FUNCTION__" -> No_equivalent | "__LINE__" -> No_equivalent | "__LINE_OF__" -> No_equivalent | "__LOC__" -> No_equivalent | "__LOC_OF__" -> No_equivalent | "__MODULE__" -> No_equivalent | "__POS__" -> No_equivalent | "__POS_OF__" -> No_equivalent | "abs" -> No_equivalent | "abs_float" -> No_equivalent | "acos" -> Repl "Float.acos" | "acosh" -> Repl "Float.acosh" | "asinh" -> Repl "Float.asinh" | "atanh" -> Repl "Float.atanh" | "asin" -> Repl "Float.asin" | "at_exit" -> No_equivalent | "atan" -> Repl "Float.atan" | "atan2" -> Repl "Float.atan2" | "bool_of_string" -> Repl "Bool.of_string" | "bool_of_string_opt" -> No_equivalent | "ceil" -> Repl "Float.round_up" | "char_of_int" -> Repl "Char.of_int_exn" | "classify_float" -> Repl "Float.classify" | "close_in" -> Repl "Stdio.In_channel.close" | "close_in_noerr" -> Repl "Stdio.In_channel.close" | "close_out" -> Repl "Stdio.Out_channel.close" | "close_out_noerr" -> Repl "Stdio.Out_channel.close" | "compare" -> No_equivalent | "copysign" -> Repl "Float.copysign" | "cos" -> Repl "Float.cos" | "cosh" -> Repl "Float.cosh" | "decr" -> Repl "Int.decr" | "do_at_exit" -> No_equivalent | "epsilon_float" -> Repl "Float.epsilon_float" | "exit" -> No_equivalent | "exp" -> Repl "Float.exp" | "expm1" -> Repl "Float.expm1" | "failwith" -> No_equivalent | "float" -> Repl "Float.of_int" | "float_of_int" -> Repl "Float.of_int" | "float_of_string" -> Repl "Float.of_string" | "float_of_string_opt" -> No_equivalent | "floor" -> Repl "Float.round_down" | "flush" -> Repl "Stdio.Out_channel.flush" | "flush_all" -> No_equivalent | "format_of_string" -> No_equivalent | "frexp" -> Repl "Float.frexp" | "fst" -> No_equivalent | "hypot" -> Repl "Float.hypot" | "ignore" -> No_equivalent | "in_channel_length" -> Repl "Stdio.In_channel.length" | "incr" -> Repl "Int.incr" | "infinity" -> Repl "Float.infinity" | "input" -> Repl "Stdio.In_channel.input" | "input_binary_int" -> Repl "Stdio.In_channel.input_binary_int" | "input_byte" -> Repl "Stdio.In_channel.input_byte" | "input_char" -> Repl "Stdio.In_channel.input_char" | "input_line" -> Repl "Stdio.In_channel.input_line" | "input_value" -> Repl "Stdio.In_channel.unsafe_input_value" | "int_of_char" -> Repl "Char.to_int" | "int_of_float" -> Repl "Int.of_float" | "int_of_string" -> Repl "Int.of_string" | "int_of_string_opt" -> No_equivalent | "invalid_arg" -> No_equivalent | "ldexp" -> Repl "Float.ldexp" | "lnot" -> No_equivalent | "log" -> Repl "Float.log" | "log10" -> Repl "Float.log10" | "log1p" -> Repl "Float.log1p" | "max" -> No_equivalent | "max_float" -> Repl "Float.max_finite_value" | "max_int" -> Repl "Int.max_value" | "min" -> No_equivalent | "min_float" -> Repl "Float.min_positive_normal_value" | "min_int" -> Repl "Int.min_value" | "mod_float" -> Repl "Float.mod_float" | "modf" -> Repl "Float.modf" | "nan" -> Repl "Float.nan" | "neg_infinity" -> Repl "Float.neg_infinity" | "not" -> No_equivalent | "open_in" -> Repl "Stdio.In_channel.create" | "open_in_bin" -> Repl "Stdio.In_channel.create" | "open_in_gen" -> No_equivalent | "open_out" -> Repl "Stdio.Out_channel.create" | "open_out_bin" -> Repl "Stdio.Out_channel.create" | "open_out_gen" -> No_equivalent | "out_channel_length" -> Repl "Stdio.Out_channel.length" | "output" -> Repl "Stdio.Out_channel.output" | "output_binary_int" -> Repl "Stdio.Out_channel.output_binary_int" | "output_byte" -> Repl "Stdio.Out_channel.output_byte" | "output_bytes" -> Repl "Stdio.Out_channel.output_bytes" | "output_char" -> Repl "Stdio.Out_channel.output_char" | "output_string" -> Repl "Stdio.Out_channel.output_string" | "output_substring" -> Repl "Stdio.Out_channel.output" | "output_value" -> Repl "Stdio.Out_channel.output_value" | "pos_in" -> Repl "Stdio.In_channel.pos" | "pos_out" -> Repl "Stdio.Out_channel.pos" | "pred" -> Repl "Int.pred" | "prerr_bytes" -> Repl "Stdio.Out_channel.output_bytes Stdio.stderr" | "prerr_char" -> Repl "Stdio.Out_channel.output_char Stdio.stderr" | "prerr_endline" -> Repl "Stdio.prerr_endline" | "prerr_float" -> Repl "Stdio.eprintf \"%f\"" | "prerr_int" -> Repl "Stdio.eprintf \"%d\"" | "prerr_newline" -> Repl "Stdio.eprintf \"\n%!\"" | "prerr_string" -> Repl "Stdio.Out_channel.output_string Stdio.stderr" | "print_bytes" -> Repl "Stdio.Out_channel.output_bytes Stdio.stdout" | "print_char" -> Repl "Stdio.Out_channel.output_char Stdio.stdout" | "print_endline" -> Repl "Stdio.print_endline" | "print_float" -> Repl "Stdio.eprintf \"%f\"" | "print_int" -> Repl "Stdio.eprintf \"%d\"" | "print_newline" -> Repl "Stdio.eprintf \"\n%!\"" | "print_string" -> Repl "Stdio.Out_channel.output_string Stdio.stdout" | "raise" -> No_equivalent | "raise_notrace" -> No_equivalent | "read_float" -> No_equivalent | "read_float_opt" -> No_equivalent | "read_int" -> No_equivalent | "read_int_opt" -> No_equivalent | "read_line" -> Repl "Stdio.In_channel.input_line" | "really_input" -> Repl "Stdio.In_channel.really_input" | "really_input_string" -> Approx "Stdio.In_channel" | "ref" -> No_equivalent | "seek_in" -> Repl "Stdio.In_channel.seek" | "seek_out" -> Repl "Stdio.Out_channel.seek" | "set_binary_mode_in" -> Repl "Stdio.In_channel.set_binary_mode" | "set_binary_mode_out" -> Repl "Stdio.Out_channel.set_binary_mode" | "sin" -> Repl "Float.sin" | "sinh" -> Repl "Float.sinh" | "snd" -> No_equivalent | "sqrt" -> Repl "Float.sqrt" | "stderr" -> Repl "Stdio.stderr" | "stdin" -> Repl "Stdio.stdin" | "stdout" -> Repl "Stdio.stdout" | "string_of_bool" -> Repl "Bool.to_string" | "string_of_float" -> Repl "Float.to_string" | "string_of_format" -> No_equivalent | "string_of_int" -> Repl "Int.to_string" | "succ" -> Repl "Int.succ" | "tan" -> Repl "Float.tan" | "tanh" -> Repl "Float.tanh" | "truncate" -> Repl "Int.of_float" | "unsafe_really_input" -> No_equivalent | "valid_float_lexem" -> No_equivalent | symbol -> if !permissive then No_equivalent else failwith (sprintf "Consider adding to [Base] an equivalent for symbol %S defined in stdlib" symbol) ;; let exception_replacement = function | "Not_found" -> Some (Repl_text "\ Instead of raising [Not_found], consider using [raise_s] with an informative error\n\ message. If code needs to distinguish [Not_found] from other exceptions, please change\n\ it to handle both [Not_found] and [Not_found_s]. Then, instead of raising [Not_found],\n\ raise [Not_found_s] with an informative error message") | _ -> None let type_replacement = function | "in_channel" -> Some (Repl "Stdio.In_channel.t") | "out_channel" -> Some (Repl "Stdio.Out_channel.t") | "result" -> Some (Repl "Result.t") | _ -> None ;; let module_replacement = function | "Format" -> let repl_text = "[Base] doesn't export a [Format] module, although the \n\ [Stdlib.Format.formatter] type is available (as [Formatter.t])\n\ for interaction with other libraries" in Some (Repl_text repl_text) | "Fun" -> Some (Repl "Fn") | "Gc" -> Some No_equivalent | "Printexc" -> Some (Repl_text "Use [Exn] or [Backtrace] instead") | "Seq" -> Some (Approx "Sequence") | _ -> None let replace ~is_exn id replacement = match replacement with | No_equivalent -> deprecated_msg_no_equivalent ~is_exn id | Repl repl -> deprecated_msg_with_repl ~is_exn repl | Repl_text text -> deprecated_msg_with_repl_text ~is_exn text | Approx repl -> deprecated_msg_with_approx_repl ~is_exn repl ~id ;; let is_alias = function | "format" | "format4" | "format6" -> true | _ -> false } let id_trail = ['a'-'z' 'A'-'Z' '_' '0'-'9']* let id = ['a'-'z' 'A'-'Z' '_' '0'-'9'] id_trail let val_id = id | '(' [^ ')']* ')' let params = ('(' [^')']* ')' | ['+' '-']? '\'' id) " " let val_ = "val " | "external " rule line = parse | "module Camlinternal" _* { "" (* We can't deprecate these *) } | "module Bigarray" _* { "" (* Don't deprecate it yet *) } | "type " (params? as params) (id as id) (_* as def) { sprintf "type nonrec %s%s = %sStdlib.%s%s\n%s" params id params id (if is_alias id then "" else def) (match type_replacement id with | Some replacement -> replace ~is_exn:false id replacement | None -> deprecated_msg ~is_exn:false id) } | val_ (val_id as id) _* as line { sprintf "%s\n%s" line (replace ~is_exn:false id (val_replacement id)) } | "module " (id as id) " = Stdlib__" (id as id2) (_* as line) { Printf.sprintf "module %s = Stdlib.%s %s\n%s" id (String.capitalize_ascii id2) line (match module_replacement id with | Some replacement -> replace ~is_exn:false id replacement | None -> deprecated_msg ~is_exn:false id) } | "exception " (id as id) _* as line { match exception_replacement id with | Some replacement -> sprintf "%s\n%s" line (replace ~is_exn:true id replacement) | None -> let predefined_exceptions = [ "Out_of_memory" ; "Sys_error" ; "Failure" ; "Invalid_argument" ; "End_of_file" ; "Division_by_zero" ; "Not_found" ; "Match_failure" ; "Stack_overflow" ; "Sys_blocked_io" ; "Assert_failure" ; "Undefined_recursive_module" ] in if List.mem id ~set:predefined_exceptions then "" else sprintf "%s\n%s" line (deprecated_msg ~is_exn:true id) } | "module " (id as id) _* { sprintf "module %s = Stdlib.%s\n%s" id id (match module_replacement id with | Some replacement -> replace ~is_exn:false id replacement | None -> deprecated_msg ~is_exn:false id) } | _* as line { ksprintf failwith "cannot parse this: %s" line } base-0.16.3/shadow-stdlib/src/000077500000000000000000000000001446274340700160615ustar00rootroot00000000000000base-0.16.3/shadow-stdlib/src/dune000066400000000000000000000004531446274340700167410ustar00rootroot00000000000000(library (name shadow_stdlib) (public_name base.shadow_stdlib) (libraries) (preprocess no_preprocessing)) (rule (targets shadow_stdlib.mli) (deps %{ocaml_where}/stdlib.cma) (action (run ../gen/gen.exe -caml-cmi -permissive %{ocaml_where}/stdlib.cmi %{ocaml_where}/stdlib.cma -o %{targets})))base-0.16.3/shadow-stdlib/src/shadow_stdlib.ml000066400000000000000000000000171446274340700212370ustar00rootroot00000000000000include Stdlib base-0.16.3/src/000077500000000000000000000000001446274340700133155ustar00rootroot00000000000000base-0.16.3/src/am_testing.c000066400000000000000000000004221446274340700156110ustar00rootroot00000000000000#include /* The default [Base_am_testing] value is [false]. [ppx_inline_test] overrides the default by linking against an implementation of [Base_am_testing] that returns [true]. */ CAMLprim CAMLweakdef value Base_am_testing() { return Val_false; } base-0.16.3/src/am_testing.h000066400000000000000000000003021446274340700156130ustar00rootroot00000000000000#ifndef BASE_AM_TESTING_H #define BASE_AM_TESTING_H #include CAMLprim value Base_am_testing(); static inline int am_testing() { return Bool_val(Base_am_testing()); } #endif base-0.16.3/src/applicative.ml000066400000000000000000000154231446274340700161550ustar00rootroot00000000000000open! Import include Applicative_intf module List = List0 (** This module serves mostly as a partial check that [S2] and [S] are in sync, but actually calling it is occasionally useful. *) module S_to_S2 (X : S) : S2 with type ('a, 'e) t = 'a X.t = struct include X type ('a, 'e) t = 'a X.t end module S2_to_S (T : T.T) (X : S2) : S with type 'a t = ('a, T.t) X.t = struct include X type 'a t = ('a, T.t) X.t end module S2_to_S3 (X : S2) : S3 with type ('a, 'd, 'e) t = ('a, 'd) X.t = struct include X type ('a, 'd, 'e) t = ('a, 'd) X.t end module S3_to_S2 (T : T.T) (X : S3) : S2 with type ('a, 'd) t = ('a, 'd, T.t) X.t = struct include X type ('a, 'd) t = ('a, 'd, T.t) X.t end module S3_to_S (T1 : T.T) (T2 : T.T) (X : S3) : S with type 'a t = ('a, T1.t, T2.t) X.t = struct include X type 'a t = ('a, T1.t, T2.t) X.t end module Make3 (X : Basic3) : S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t = struct include X let ( <*> ) = apply let derived_map t ~f = return f <*> t let map = match X.map with | `Define_using_apply -> derived_map | `Custom x -> x ;; let ( >>| ) t f = map t ~f let map2 ta tb ~f = map ~f ta <*> tb let map3 ta tb tc ~f = map ~f ta <*> tb <*> tc let all ts = List.fold_right ts ~init:(return []) ~f:(map2 ~f:(fun x xs -> x :: xs)) let both ta tb = map2 ta tb ~f:(fun a b -> a, b) let ( *> ) u v = return (fun () y -> y) <*> u <*> v let ( <* ) u v = return (fun x () -> x) <*> u <*> v let all_unit ts = List.fold ts ~init:(return ()) ~f:( *> ) module Applicative_infix = struct let ( <*> ) = ( <*> ) let ( *> ) = ( *> ) let ( <* ) = ( <* ) let ( >>| ) = ( >>| ) end end module Make2 (X : Basic2) : S2 with type ('a, 'e) t := ('a, 'e) X.t = Make3 (struct include X type ('a, 'd, 'e) t = ('a, 'd) X.t end) module Make (X : Basic) : S with type 'a t := 'a X.t = Make2 (struct include X type ('a, 'e) t = 'a X.t end) module Make_let_syntax3 (X : For_let_syntax3) (Intf : sig module type S end) (Impl : Intf.S) = struct module Let_syntax = struct include X module Let_syntax = struct include X module Open_on_rhs = Impl end end end module Make_let_syntax2 (X : For_let_syntax2) (Intf : sig module type S end) (Impl : Intf.S) = Make_let_syntax3 (struct include X type ('a, 'd, _) t = ('a, 'd) X.t end) (Intf) (Impl) module Make_let_syntax (X : For_let_syntax) (Intf : sig module type S end) (Impl : Intf.S) = Make_let_syntax2 (struct include X type ('a, _) t = 'a X.t end) (Intf) (Impl) (** This functor closely resembles [Make3], and indeed it could be implemented much shorter in terms of [Make3]. However, we implement it by hand so that the resulting functions are more efficient, e.g. using [map2] directly instead of defining [apply] in terms of it and then [map2] in terms of that. For most applicatives this does not matter, but for some (such as Bonsai.Value.t), it has a larger impact. *) module Make3_using_map2 (X : Basic3_using_map2) : S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t = struct include X let apply tf ta = map2 tf ta ~f:(fun f a -> f a) let ( <*> ) = apply let derived_map t ~f = return f <*> t let map = match X.map with | `Define_using_map2 -> derived_map | `Custom x -> x ;; let ( >>| ) t f = map t ~f let both ta tb = map2 ta tb ~f:(fun a b -> a, b) let map3 ta tb tc ~f = map2 (map2 ta tb ~f) tc ~f:(fun fab c -> fab c) let all ts = List.fold_right ts ~init:(return []) ~f:(map2 ~f:(fun x xs -> x :: xs)) let ( *> ) u v = map2 u v ~f:(fun () y -> y) let ( <* ) u v = map2 u v ~f:(fun x () -> x) let all_unit ts = List.fold ts ~init:(return ()) ~f:( *> ) module Applicative_infix = struct let ( <*> ) = ( <*> ) let ( *> ) = ( *> ) let ( <* ) = ( <* ) let ( >>| ) = ( >>| ) end end module Make2_using_map2 (X : Basic2_using_map2) : S2 with type ('a, 'e) t := ('a, 'e) X.t = Make3_using_map2 (struct include X type ('a, 'd, 'e) t = ('a, 'd) X.t end) module Make_using_map2 (X : Basic_using_map2) : S with type 'a t := 'a X.t = Make2_using_map2 (struct include X type ('a, 'e) t = 'a X.t end) module Make3_using_map2_local (X : Basic3_using_map2_local) : S3_local with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t = struct include X let apply tf ta = map2 tf ta ~f:(fun f a -> f a) let ( <*> ) = apply let derived_map t ~f = map2 ~f:(fun () -> f) (return ()) t [@nontail] let map = match X.map with | `Define_using_map2 -> derived_map | `Custom map -> map ;; let ( >>| ) t f = map t ~f let both ta tb = map2 ta tb ~f:(fun a b -> a, b) let map3 ta tb tc ~f = let res = map2 (both ta tb) tc ~f:(fun (a, b) c -> f a b c) in res ;; let all ts = List.fold_right ts ~init:(return []) ~f:(map2 ~f:(fun x xs -> x :: xs)) let ( *> ) u v = map2 u v ~f:(fun () y -> y) let ( <* ) u v = map2 u v ~f:(fun x () -> x) let all_unit ts = List.fold ts ~init:(return ()) ~f:( *> ) module Applicative_infix = struct let ( <*> ) = ( <*> ) let ( *> ) = ( *> ) let ( <* ) = ( <* ) let ( >>| ) = ( >>| ) end end module Make2_using_map2_local (X : Basic2_using_map2_local) : S2_local with type ('a, 'e) t := ('a, 'e) X.t = Make3_using_map2_local (struct include X type ('a, 'd, 'e) t = ('a, 'd) X.t end) module Make_using_map2_local (X : Basic_using_map2_local) : S_local with type 'a t := 'a X.t = Make2_using_map2_local (struct include X type ('a, 'e) t = 'a X.t end) module Of_monad2 (M : Monad.S2) : S2 with type ('a, 'e) t := ('a, 'e) M.t = Make2 (struct type ('a, 'e) t = ('a, 'e) M.t let return = M.return let apply mf mx = M.bind mf ~f:(fun f -> M.map mx ~f) let map = `Custom M.map end) module Of_monad (M : Monad.S) : S with type 'a t := 'a M.t = Of_monad2 (struct include M type ('a, _) t = 'a M.t end) module Compose (F : S) (G : S) : S with type 'a t = 'a F.t G.t = struct type 'a t = 'a F.t G.t include Make (struct type nonrec 'a t = 'a t let return a = G.return (F.return a) let apply tf tx = G.apply (G.map ~f:F.apply tf) tx let custom_map t ~f = G.map ~f:(F.map ~f) t let map = `Custom custom_map end) end module Pair (F : S) (G : S) : S with type 'a t = 'a F.t * 'a G.t = struct type 'a t = 'a F.t * 'a G.t include Make (struct type nonrec 'a t = 'a t let return a = F.return a, G.return a let apply tf tx = F.apply (fst tf) (fst tx), G.apply (snd tf) (snd tx) let custom_map t ~f = F.map ~f (fst t), G.map ~f (snd t) let map = `Custom custom_map end) end base-0.16.3/src/applicative.mli000066400000000000000000000000641446274340700163210ustar00rootroot00000000000000include Applicative_intf.Applicative (** @inline *) base-0.16.3/src/applicative_intf.ml000066400000000000000000000405441446274340700171770ustar00rootroot00000000000000(** Applicatives model computations in which values computed by subcomputations cannot affect what subsequent computations will take place. Relative to monads, this restriction takes power away from the user of the interface and gives it to the implementation. In particular, because the structure of the entire computation is known, one can augment its definition with some description of that structure. For more information, see: {v Applicative Programming with Effects. Conor McBride and Ross Paterson. Journal of Functional Programming 18:1 (2008), pages 1-13. http://staff.city.ac.uk/~ross/papers/Applicative.pdf v} *) open! Import module type Basic = sig type 'a t val return : 'a -> 'a t val apply : ('a -> 'b) t -> 'a t -> 'b t (** The following identities ought to hold for every Applicative (for some value of =): - identity: [return Fn.id <*> t = t] - composition: [return Fn.compose <*> tf <*> tg <*> tx = tf <*> (tg <*> tx)] - homomorphism: [return f <*> return x = return (f x)] - interchange: [tf <*> return x = return (fun f -> f x) <*> tf] Note: <*> is the infix notation for apply. *) (** The [map] argument to [Applicative.Make] says how to implement the applicative's [map] function. [`Define_using_apply] means to define [map t ~f = return f <*> t]. [`Custom] overrides the default implementation, presumably with something more efficient. Some other functions returned by [Applicative.Make] are defined in terms of [map], so passing in a more efficient [map] will improve their efficiency as well. *) val map : [ `Define_using_apply | `Custom of 'a t -> f:('a -> 'b) -> 'b t ] end (** Similar to [Basic], with the same laws, and the additional requirement that ['a t] can be mapped with a local function. *) module type Basic_local = sig type 'a t val return : 'a -> 'a t val apply : ('a -> 'b) t -> 'a t -> 'b t val map : 'a t -> f:(('a -> 'b)[@local]) -> 'b t end module type Basic_using_map2 = sig type 'a t val return : 'a -> 'a t val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t val map : [ `Define_using_map2 | `Custom of 'a t -> f:('a -> 'b) -> 'b t ] end module type Basic_using_map2_local = sig type 'a t val return : 'a -> 'a t val map2 : 'a t -> 'b t -> f:(('a -> 'b -> 'c)[@local]) -> 'c t val map : [ `Define_using_map2 | `Custom of 'a t -> f:(('a -> 'b)[@local]) -> 'b t ] end module type Applicative_infix_gen = sig type 'a t type ('a, 'b) fn (** same as [apply] *) val ( <*> ) : ('a -> 'b) t -> 'a t -> 'b t val ( <* ) : 'a t -> unit t -> 'a t val ( *> ) : unit t -> 'a t -> 'a t val ( >>| ) : 'a t -> ('a -> 'b, 'b t) fn end module type Applicative_infix = Applicative_infix_gen with type ('a, 'b) fn := 'a -> 'b module type Applicative_infix_local = Applicative_infix_gen with type ('a, 'b) fn := ('a[@local]) -> 'b module type For_let_syntax_gen = sig type 'a t type ('a, 'b) fn type ('a, 'b) f_labeled_fn val return : 'a -> 'a t val map : 'a t -> ('a -> 'b, 'b t) f_labeled_fn val both : 'a t -> 'b t -> ('a * 'b) t include Applicative_infix_gen with type 'a t := 'a t and type ('a, 'b) fn := ('a, 'b) fn end module type For_let_syntax = For_let_syntax_gen with type ('a, 'b) fn := 'a -> 'b and type ('a, 'b) f_labeled_fn := f:'a -> 'b module type For_let_syntax_local = For_let_syntax_gen with type ('a, 'b) fn := ('a[@local]) -> 'b and type ('a, 'b) f_labeled_fn := f:('a[@local]) -> 'b module type S_gen = sig include For_let_syntax_gen type ('a, 'b, 'c) fun2 type ('a, 'b, 'c, 'd) fun3 val apply : ('a -> 'b) t -> 'a t -> 'b t val map2 : 'a t -> 'b t -> (('a, 'b, 'c) fun2, 'c t) f_labeled_fn val map3 : 'a t -> 'b t -> 'c t -> (('a, 'b, 'c, 'd) fun3, 'd t) f_labeled_fn val all : 'a t list -> 'a list t val all_unit : unit t list -> unit t module Applicative_infix : Applicative_infix_gen with type 'a t := 'a t and type ('a, 'b) fn := ('a, 'b) fn end module type S = S_gen with type ('a, 'b) fn := 'a -> 'b and type ('a, 'b) f_labeled_fn := f:'a -> 'b and type ('a, 'b, 'c) fun2 := 'a -> 'b -> 'c and type ('a, 'b, 'c, 'd) fun3 := 'a -> 'b -> 'c -> 'd module type S_local = S_gen with type ('a, 'b) fn := ('a[@local]) -> 'b and type ('a, 'b) f_labeled_fn := f:('a[@local]) -> 'b and type ('a, 'b, 'c) fun2 := 'a -> (('b -> 'c)[@local]) and type ('a, 'b, 'c, 'd) fun3 := 'a -> (('b -> (('c -> 'd)[@local]))[@local]) module type Let_syntax = sig type 'a t module Open_on_rhs_intf : sig module type S end module Let_syntax : sig val return : 'a -> 'a t include Applicative_infix with type 'a t := 'a t module Let_syntax : sig val return : 'a -> 'a t val map : 'a t -> f:('a -> 'b) -> 'b t val both : 'a t -> 'b t -> ('a * 'b) t module Open_on_rhs : Open_on_rhs_intf.S end end end module type Basic2 = sig type ('a, 'e) t val return : 'a -> ('a, _) t val apply : ('a -> 'b, 'e) t -> ('a, 'e) t -> ('b, 'e) t val map : [ `Define_using_apply | `Custom of ('a, 'e) t -> f:('a -> 'b) -> ('b, 'e) t ] end module type Basic2_local = sig type ('a, 'e) t val return : 'a -> ('a, _) t val apply : ('a -> 'b, 'e) t -> ('a, 'e) t -> ('b, 'e) t val map : ('a, 'e) t -> f:(('a -> 'b)[@local]) -> ('b, 'e) t end module type Basic2_using_map2 = sig type ('a, 'e) t val return : 'a -> ('a, _) t val map2 : ('a, 'e) t -> ('b, 'e) t -> f:('a -> 'b -> 'c) -> ('c, 'e) t val map : [ `Define_using_map2 | `Custom of ('a, 'e) t -> f:('a -> 'b) -> ('b, 'e) t ] end module type Basic2_using_map2_local = sig type ('a, 'e) t val return : 'a -> ('a, _) t val map2 : ('a, 'e) t -> ('b, 'e) t -> f:(('a -> 'b -> 'c)[@local]) -> ('c, 'e) t val map : [ `Define_using_map2 | `Custom of ('a, 'e) t -> f:(('a -> 'b)[@local]) -> ('b, 'e) t ] end module type Applicative_infix2_gen = sig type ('a, 'e) t type ('a, 'b) fn val ( <*> ) : ('a -> 'b, 'e) t -> ('a, 'e) t -> ('b, 'e) t val ( <* ) : ('a, 'e) t -> (unit, 'e) t -> ('a, 'e) t val ( *> ) : (unit, 'e) t -> ('a, 'e) t -> ('a, 'e) t val ( >>| ) : ('a, 'e) t -> ('a -> 'b, ('b, 'e) t) fn end module type Applicative_infix2 = Applicative_infix2_gen with type ('a, 'b) fn := 'a -> 'b module type Applicative_infix2_local = Applicative_infix2_gen with type ('a, 'b) fn := ('a[@local]) -> 'b module type For_let_syntax2_gen = sig type ('a, 'e) t type ('a, 'b) fn type ('a, 'b) f_labeled_fn val return : 'a -> ('a, _) t val map : ('a, 'e) t -> ('a -> 'b, ('b, 'e) t) f_labeled_fn val both : ('a, 'e) t -> ('b, 'e) t -> ('a * 'b, 'e) t include Applicative_infix2_gen with type ('a, 'e) t := ('a, 'e) t and type ('a, 'b) fn := ('a, 'b) fn end module type For_let_syntax2 = For_let_syntax2_gen with type ('a, 'b) fn := 'a -> 'b and type ('a, 'b) f_labeled_fn := f:'a -> 'b module type For_let_syntax2_local = For_let_syntax2_gen with type ('a, 'b) fn := ('a[@local]) -> 'b and type ('a, 'b) f_labeled_fn := f:('a[@local]) -> 'b module type S2_gen = sig include For_let_syntax2_gen type ('a, 'b, 'c) fun2 type ('a, 'b, 'c, 'd) fun3 val apply : ('a -> 'b, 'e) t -> ('a, 'e) t -> ('b, 'e) t val map2 : ('a, 'e) t -> ('b, 'e) t -> (('a, 'b, 'c) fun2, ('c, 'e) t) f_labeled_fn val map3 : ('a, 'e) t -> ('b, 'e) t -> ('c, 'e) t -> (('a, 'b, 'c, 'd) fun3, ('d, 'e) t) f_labeled_fn val all : ('a, 'e) t list -> ('a list, 'e) t val all_unit : (unit, 'e) t list -> (unit, 'e) t module Applicative_infix : Applicative_infix2_gen with type ('a, 'e) t := ('a, 'e) t and type ('a, 'b) fn := ('a, 'b) fn end module type S2 = S2_gen with type ('a, 'b) fn := 'a -> 'b and type ('a, 'b) f_labeled_fn := f:'a -> 'b and type ('a, 'b, 'c) fun2 := 'a -> 'b -> 'c and type ('a, 'b, 'c, 'd) fun3 := 'a -> 'b -> 'c -> 'd module type S2_local = S2_gen with type ('a, 'b) fn := ('a[@local]) -> 'b and type ('a, 'b) f_labeled_fn := f:('a[@local]) -> 'b and type ('a, 'b, 'c) fun2 := 'a -> (('b -> 'c)[@local]) and type ('a, 'b, 'c, 'd) fun3 := 'a -> (('b -> (('c -> 'd)[@local]))[@local]) module type Let_syntax2 = sig type ('a, 'e) t module Open_on_rhs_intf : sig module type S end module Let_syntax : sig val return : 'a -> ('a, _) t include Applicative_infix2 with type ('a, 'e) t := ('a, 'e) t module Let_syntax : sig val return : 'a -> ('a, _) t val map : ('a, 'e) t -> f:('a -> 'b) -> ('b, 'e) t val both : ('a, 'e) t -> ('b, 'e) t -> ('a * 'b, 'e) t module Open_on_rhs : Open_on_rhs_intf.S end end end module type Basic3 = sig type ('a, 'd, 'e) t val return : 'a -> ('a, _, _) t val apply : ('a -> 'b, 'd, 'e) t -> ('a, 'd, 'e) t -> ('b, 'd, 'e) t val map : [ `Define_using_apply | `Custom of ('a, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'd, 'e) t ] end module type Basic3_using_map2 = sig type ('a, 'd, 'e) t val return : 'a -> ('a, _, _) t val map2 : ('a, 'd, 'e) t -> ('b, 'd, 'e) t -> f:('a -> 'b -> 'c) -> ('c, 'd, 'e) t val map : [ `Define_using_map2 | `Custom of ('a, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'd, 'e) t ] end module type Basic3_using_map2_local = sig type ('a, 'd, 'e) t val return : 'a -> ('a, _, _) t val map2 : ('a, 'd, 'e) t -> ('b, 'd, 'e) t -> f:(('a -> 'b -> 'c)[@local]) -> ('c, 'd, 'e) t val map : [ `Define_using_map2 | `Custom of ('a, 'd, 'e) t -> f:(('a -> 'b)[@local]) -> ('b, 'd, 'e) t ] end module type Applicative_infix3_gen = sig type ('a, 'd, 'e) t type ('a, 'b) fn val ( <*> ) : ('a -> 'b, 'd, 'e) t -> ('a, 'd, 'e) t -> ('b, 'd, 'e) t val ( <* ) : ('a, 'd, 'e) t -> (unit, 'd, 'e) t -> ('a, 'd, 'e) t val ( *> ) : (unit, 'd, 'e) t -> ('a, 'd, 'e) t -> ('a, 'd, 'e) t val ( >>| ) : ('a, 'd, 'e) t -> ('a -> 'b, ('b, 'd, 'e) t) fn end module type Applicative_infix3 = Applicative_infix3_gen with type ('a, 'b) fn := 'a -> 'b module type Applicative_infix3_local = Applicative_infix3_gen with type ('a, 'b) fn := ('a[@local]) -> 'b module type For_let_syntax3_gen = sig type ('a, 'd, 'e) t type ('a, 'b) fn type ('a, 'b) f_labeled_fn val return : 'a -> ('a, _, _) t val map : ('a, 'd, 'e) t -> ('a -> 'b, ('b, 'd, 'e) t) f_labeled_fn val both : ('a, 'd, 'e) t -> ('b, 'd, 'e) t -> ('a * 'b, 'd, 'e) t include Applicative_infix3_gen with type ('a, 'd, 'e) t := ('a, 'd, 'e) t and type ('a, 'b) fn := ('a, 'b) fn end module type For_let_syntax3 = For_let_syntax3_gen with type ('a, 'b) fn := 'a -> 'b and type ('a, 'b) f_labeled_fn := f:'a -> 'b module type For_let_syntax3_local = For_let_syntax3_gen with type ('a, 'b) fn := ('a[@local]) -> 'b and type ('a, 'b) f_labeled_fn := f:('a[@local]) -> 'b module type S3_gen = sig include For_let_syntax3_gen type ('a, 'b, 'c) fun2 type ('a, 'b, 'c, 'd) fun3 val apply : ('a -> 'b, 'd, 'e) t -> ('a, 'd, 'e) t -> ('b, 'd, 'e) t val map2 : ('a, 'd, 'e) t -> ('b, 'd, 'e) t -> (('a, 'b, 'c) fun2, ('c, 'd, 'e) t) f_labeled_fn val map3 : ('a, 'd, 'e) t -> ('b, 'd, 'e) t -> ('c, 'd, 'e) t -> (('a, 'b, 'c, 'result) fun3, ('result, 'd, 'e) t) f_labeled_fn val all : ('a, 'd, 'e) t list -> ('a list, 'd, 'e) t val all_unit : (unit, 'd, 'e) t list -> (unit, 'd, 'e) t module Applicative_infix : Applicative_infix3_gen with type ('a, 'd, 'e) t := ('a, 'd, 'e) t and type ('a, 'b) fn := ('a, 'b) fn end module type S3 = S3_gen with type ('a, 'b) fn := 'a -> 'b and type ('a, 'b) f_labeled_fn := f:'a -> 'b and type ('a, 'b, 'c) fun2 := 'a -> 'b -> 'c and type ('a, 'b, 'c, 'd) fun3 := 'a -> 'b -> 'c -> 'd module type S3_local = S3_gen with type ('a, 'b) fn := ('a[@local]) -> 'b and type ('a, 'b) f_labeled_fn := f:('a[@local]) -> 'b and type ('a, 'b, 'c) fun2 := 'a -> (('b -> 'c)[@local]) and type ('a, 'b, 'c, 'd) fun3 := 'a -> (('b -> (('c -> 'd)[@local]))[@local]) module type Let_syntax3 = sig type ('a, 'd, 'e) t module Open_on_rhs_intf : sig module type S end module Let_syntax : sig val return : 'a -> ('a, _, _) t include Applicative_infix3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) t module Let_syntax : sig val return : 'a -> ('a, _, _) t val map : ('a, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'd, 'e) t val both : ('a, 'd, 'e) t -> ('b, 'd, 'e) t -> ('a * 'b, 'd, 'e) t module Open_on_rhs : Open_on_rhs_intf.S end end end (** [Lazy_applicative] is an applicative whose structure may be computed on-demand, instead of being constructed up-front. This is useful when implementing traversals over large data structures, where otherwise we have to pay O(n) up-front cost both in time and in memory. *) module type Lazy_applicative = sig include S val of_thunk : (unit -> 'a t) -> 'a t end module type Applicative = sig module type Applicative_infix = Applicative_infix module type Applicative_infix2 = Applicative_infix2 module type Applicative_infix3 = Applicative_infix3 module type Applicative_infix_local = Applicative_infix_local module type Applicative_infix2_local = Applicative_infix2_local module type Basic = Basic module type Basic2 = Basic2 module type Basic3 = Basic3 module type Basic_local = Basic_local module type Basic2_local = Basic2_local module type Basic_using_map2 = Basic_using_map2 module type Basic2_using_map2 = Basic2_using_map2 module type Basic3_using_map2 = Basic3_using_map2 module type Basic_using_map2_local = Basic_using_map2_local module type Basic2_using_map2_local = Basic2_using_map2_local module type Basic3_using_map2_local = Basic3_using_map2_local module type Let_syntax = Let_syntax module type Let_syntax2 = Let_syntax2 module type Let_syntax3 = Let_syntax3 module type S = S module type S2 = S2 module type S3 = S3 module type Lazy_applicative = Lazy_applicative module type S_local = S_local module type S2_local = S2_local module S2_to_S (T : T.T) (X : S2) : S with type 'a t = ('a, T.t) X.t module S_to_S2 (X : S) : S2 with type ('a, 'e) t = 'a X.t module S3_to_S2 (T : T.T) (X : S3) : S2 with type ('a, 'd) t = ('a, 'd, T.t) X.t module S3_to_S (T1 : T.T) (T2 : T.T) (X : S3) : S with type 'a t = ('a, T1.t, T2.t) X.t module S2_to_S3 (X : S2) : S3 with type ('a, 'd, 'e) t = ('a, 'd) X.t module Make (X : Basic) : S with type 'a t := 'a X.t module Make2 (X : Basic2) : S2 with type ('a, 'e) t := ('a, 'e) X.t module Make3 (X : Basic3) : S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t module Make_let_syntax (X : For_let_syntax) (Intf : sig module type S end) (Impl : Intf.S) : Let_syntax with type 'a t := 'a X.t with module Open_on_rhs_intf := Intf module Make_let_syntax2 (X : For_let_syntax2) (Intf : sig module type S end) (Impl : Intf.S) : Let_syntax2 with type ('a, 'e) t := ('a, 'e) X.t with module Open_on_rhs_intf := Intf module Make_let_syntax3 (X : For_let_syntax3) (Intf : sig module type S end) (Impl : Intf.S) : Let_syntax3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t with module Open_on_rhs_intf := Intf module Make_using_map2 (X : Basic_using_map2) : S with type 'a t := 'a X.t module Make2_using_map2 (X : Basic2_using_map2) : S2 with type ('a, 'e) t := ('a, 'e) X.t module Make3_using_map2 (X : Basic3_using_map2) : S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t module Make_using_map2_local (X : Basic_using_map2_local) : S_local with type 'a t := 'a X.t module Make2_using_map2_local (X : Basic2_using_map2_local) : S2_local with type ('a, 'e) t := ('a, 'e) X.t module Make3_using_map2_local (X : Basic3_using_map2_local) : S3_local with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t (** The following functors give a sense of what Applicatives one can define. Of these, [Of_monad] is likely the most useful. The others are mostly didactic. *) (** Every monad is Applicative via: {[ let apply mf mx = mf >>= fun f -> mx >>| fun x -> f x ]} *) module Of_monad (M : Monad.S) : S with type 'a t := 'a M.t module Of_monad2 (M : Monad.S2) : S2 with type ('a, 'e) t := ('a, 'e) M.t module Compose (F : S) (G : S) : S with type 'a t = 'a F.t G.t module Pair (F : S) (G : S) : S with type 'a t = 'a F.t * 'a G.t end base-0.16.3/src/array.ml000066400000000000000000000577141446274340700150030ustar00rootroot00000000000000open! Import include Array0 type 'a t = 'a array [@@deriving_inline compare, globalize, sexp, sexp_grammar] let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = compare_array let globalize : 'a. (('a[@ocaml.local]) -> 'a) -> ('a t[@ocaml.local]) -> 'a t = fun (type a__005_) : (((a__005_[@ocaml.local]) -> a__005_) -> (a__005_ t[@ocaml.local]) -> a__005_ t) -> globalize_array ;; let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = array_of_sexp let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = sexp_of_array let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> array_sexp_grammar _'a_sexp_grammar ;; [@@@end] (* This module implements a new in-place, constant heap sorting algorithm to replace the one used by the standard libraries. Its only purpose is to be faster (hopefully strictly faster) than the base sort and stable_sort. At a high level the algorithm is: - pick two pivot points by: - pick 5 arbitrary elements from the array - sort them within the array - take the elements on either side of the middle element of the sort as the pivots - sort the array with: - all elements less than pivot1 to the left (range 1) - all elements >= pivot1 and <= pivot2 in the middle (range 2) - all elements > pivot2 to the right (range 3) - if pivot1 and pivot2 are equal, then the middle range is sorted, so ignore it - recurse into range 1, 2 (if pivot1 and pivot2 are unequal), and 3 - during recursion there are two inflection points: - if the size of the current range is small, use insertion sort to sort it - if the stack depth is large, sort the range with heap-sort to avoid n^2 worst-case behavior See the following for more information: - "Dual-Pivot Quicksort" by Vladimir Yaroslavskiy. Available at http://www.kriche.com.ar/root/programming/spaceTimeComplexity/DualPivotQuicksort.pdf - "Quicksort is Optimal" by Sedgewick and Bentley. Slides at http://www.cs.princeton.edu/~rs/talks/QuicksortIsOptimal.pdf - http://www.sorting-algorithms.com/quick-sort-3-way *) module Sorter (S : sig type 'a t val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> unit val length : 'a t -> int end) = struct include S let swap arr i j = let tmp = get arr i in set arr i (get arr j); set arr j tmp ;; module type Sort = sig val sort : 'a t -> compare:(('a -> 'a -> int)[@local]) -> left:int (* leftmost index of sub-array to sort *) -> right:int (* rightmost index of sub-array to sort *) -> unit end (* http://en.wikipedia.org/wiki/Insertion_sort *) module Insertion_sort : Sort = struct (* loop invariants: 1. the subarray arr[left .. i-1] is sorted 2. the subarray arr[i+1 .. pos] is sorted and contains only elements > v 3. arr[i] may be thought of as containing v *) let rec insert_loop arr ~left ~compare i v = let i_next = i - 1 in if i_next >= left && compare (get arr i_next) v > 0 then ( set arr i (get arr i_next); insert_loop arr ~left ~compare i_next v) else i ;; let sort arr ~compare ~left ~right = (* loop invariant: [arr] is sorted from [left] to [pos - 1], inclusive *) for pos = left + 1 to right do let v = get arr pos in let final_pos = insert_loop arr ~left ~compare pos v in set arr final_pos v done ;; end (* http://en.wikipedia.org/wiki/Heapsort *) module Heap_sort : Sort = struct (* loop invariant: root's children are both either roots of max-heaps or > right *) let rec heapify arr ~compare root ~left ~right = let relative_root = root - left in let left_child = (2 * relative_root) + left + 1 in let right_child = (2 * relative_root) + left + 2 in let largest = if left_child <= right && compare (get arr left_child) (get arr root) > 0 then left_child else root in let largest = if right_child <= right && compare (get arr right_child) (get arr largest) > 0 then right_child else largest in if largest <> root then ( swap arr root largest; heapify arr ~compare largest ~left ~right) ;; let build_heap arr ~compare ~left ~right = (* Elements in the second half of the array are already heaps of size 1. We move through the first half of the array from back to front examining the element at hand, and the left and right children, fixing the heap property as we go. *) for i = (left + right) / 2 downto left do heapify arr ~compare i ~left ~right done ;; let sort arr ~compare ~left ~right = build_heap arr ~compare ~left ~right; (* loop invariants: 1. the subarray arr[left ... i] is a max-heap H 2. the subarray arr[i+1 ... right] is sorted (call it S) 3. every element of H is less than every element of S *) for i = right downto left + 1 do swap arr left i; heapify arr ~compare left ~left ~right:(i - 1) done ;; end (* http://en.wikipedia.org/wiki/Introsort *) module Intro_sort : sig include Sort val five_element_sort : 'a t -> compare:(('a -> 'a -> int)[@local]) -> int -> int -> int -> int -> int -> unit end = struct let five_element_sort arr ~compare:((compare : _ -> _ -> _) [@local]) m1 m2 m3 m4 m5 = let compare_and_swap i j = if compare (get arr i) (get arr j) > 0 then swap arr i j in (* Optimal 5-element sorting network: {v 1--o-----o-----o--------------1 | | | 2--o-----|--o--|-----o--o-----2 | | | | | 3--------o--o--|--o--|--o-----3 | | | 4-----o--------o--o--|-----o--4 | | | 5-----o--------------o-----o--5 v} *) compare_and_swap m1 m2; compare_and_swap m4 m5; compare_and_swap m1 m3; compare_and_swap m2 m3; compare_and_swap m1 m4; compare_and_swap m3 m4; compare_and_swap m2 m5; compare_and_swap m2 m3; compare_and_swap m4 m5 [@nontail] ;; (* choose pivots for the array by sorting 5 elements and examining the center three elements. The goal is to choose two pivots that will either: - break the range up into 3 even partitions or - eliminate a commonly appearing element by sorting it into the center partition by itself To this end we look at the center 3 elements of the 5 and return pairs of equal elements or the widest range *) let choose_pivots arr ~compare:((compare : _ -> _ -> _) [@local]) ~left ~right = let sixth = (right - left) / 6 in let m1 = left + sixth in let m2 = m1 + sixth in let m3 = m2 + sixth in let m4 = m3 + sixth in let m5 = m4 + sixth in five_element_sort arr ~compare m1 m2 m3 m4 m5; let m2_val = get arr m2 in let m3_val = get arr m3 in let m4_val = get arr m4 in if compare m2_val m3_val = 0 then m2_val, m3_val, true else if compare m3_val m4_val = 0 then m3_val, m4_val, true else m2_val, m4_val, false ;; let dual_pivot_partition arr ~compare:((compare : _ -> _ -> _) [@local]) ~left ~right = let pivot1, pivot2, pivots_equal = choose_pivots arr ~compare ~left ~right in (* loop invariants: 1. left <= l < r <= right 2. l <= p <= r 3. l <= x < p implies arr[x] >= pivot1 and arr[x] <= pivot2 4. left <= x < l implies arr[x] < pivot1 5. r < x <= right implies arr[x] > pivot2 *) let rec loop l p r = let pv = get arr p in if compare pv pivot1 < 0 then ( swap arr p l; cont (l + 1) (p + 1) r) else if compare pv pivot2 > 0 then ( (* loop invariants: same as those of the outer loop *) let rec scan_backwards r = if r > p && compare (get arr r) pivot2 > 0 then scan_backwards (r - 1) else r in let r = scan_backwards r in swap arr r p; cont l p (r - 1)) else cont l (p + 1) r and cont l p r = if p > r then l, r else loop l p r in let l, r = cont left left right in l, r, pivots_equal ;; let rec intro_sort arr ~max_depth ~compare ~left ~right = let len = right - left + 1 in (* This takes care of some edge cases, such as left > right or very short arrays, since Insertion_sort.sort handles these cases properly. Thus we don't need to make sure that left and right are valid in recursive calls. *) if len <= 32 then Insertion_sort.sort arr ~compare ~left ~right else if max_depth < 0 then Heap_sort.sort arr ~compare ~left ~right else ( let max_depth = max_depth - 1 in let l, r, middle_sorted = dual_pivot_partition arr ~compare ~left ~right in intro_sort arr ~max_depth ~compare ~left ~right:(l - 1); if not middle_sorted then intro_sort arr ~max_depth ~compare ~left:l ~right:r; intro_sort arr ~max_depth ~compare ~left:(r + 1) ~right) ;; let sort arr ~compare ~left ~right = let heap_sort_switch_depth = (* We bail out to heap sort at a recursion depth of 32. GNU introsort uses 2lg(n). The expected recursion depth for perfect 3-way splits is log_3(n). Using 32 means a balanced 3-way split would work up to 3^32 elements (roughly 2^50 or 10^15). GNU reaches a depth of 32 at 65536 elements. For small arrays, this makes us less likely to bail out to heap sort, but the 32*N cost before we do is not that much. For large arrays, this means we are more likely to bail out to heap sort at some point if we get some bad splits or if the array is huge. But that's only a constant factor cost in the final stages of recursion. All in all, this seems to be a small tradeoff and avoids paying a cost to compute a logarithm at the start. *) 32 in intro_sort arr ~max_depth:heap_sort_switch_depth ~compare ~left ~right ;; end let sort ?pos ?len arr ~compare:((compare : _ -> _ -> _) [@local]) = let pos, len = Ordered_collection_common.get_pos_len_exn () ?pos ?len ~total_length:(length arr) in Intro_sort.sort arr ~compare ~left:pos ~right:(pos + len - 1) ;; end [@@inline] module Sort = Sorter (struct type nonrec 'a t = 'a t let get = unsafe_get let set = unsafe_set let length = length end) let sort = Sort.sort let of_array t = t let to_array t = t let is_empty t = length t = 0 let is_sorted t ~compare = let i = ref (length t - 1) in let result = ref true in while !i > 0 && !result do let elt_i = unsafe_get t !i in let elt_i_minus_1 = unsafe_get t (!i - 1) in if compare elt_i_minus_1 elt_i > 0 then result := false; decr i done; !result ;; let is_sorted_strictly t ~compare = let i = ref (length t - 1) in let result = ref true in while !i > 0 && !result do let elt_i = unsafe_get t !i in let elt_i_minus_1 = unsafe_get t (!i - 1) in if compare elt_i_minus_1 elt_i >= 0 then result := false; decr i done; !result ;; let merge a1 a2 ~compare = let l1 = Array.length a1 in let l2 = Array.length a2 in if l1 = 0 then copy a2 else if l2 = 0 then copy a1 else if compare (unsafe_get a2 0) (unsafe_get a1 (l1 - 1)) >= 0 then append a1 a2 else if compare (unsafe_get a1 0) (unsafe_get a2 (l2 - 1)) > 0 then append a2 a1 else ( let len = l1 + l2 in let merged = create ~len (unsafe_get a1 0) in let a1_index = ref 0 in let a2_index = ref 0 in for i = 0 to len - 1 do let use_a1 = if l1 = !a1_index then false else if l2 = !a2_index then true else compare (unsafe_get a1 !a1_index) (unsafe_get a2 !a2_index) <= 0 in if use_a1 then ( unsafe_set merged i (unsafe_get a1 !a1_index); a1_index := !a1_index + 1) else ( unsafe_set merged i (unsafe_get a2 !a2_index); a2_index := !a2_index + 1) done; merged) ;; let copy_matrix = map ~f:copy let folding_map t ~init ~f = let acc = ref init in map t ~f:(fun x -> let new_acc, y = f !acc x in acc := new_acc; y) [@nontail] ;; let fold_map t ~init ~f = let acc = ref init in let result = map t ~f:(fun x -> let new_acc, y = f !acc x in acc := new_acc; y) in !acc, result ;; let fold_result t ~init ~f = Container.fold_result ~fold ~init ~f t let fold_until t ~init ~f ~finish = Container.fold_until ~fold ~init ~f t ~finish let count t ~f = Container.count ~fold t ~f let sum m t ~f = Container.sum ~fold m t ~f let min_elt t ~compare = Container.min_elt ~fold t ~compare let max_elt t ~compare = Container.max_elt ~fold t ~compare let foldi t ~init ~f = let acc = ref init in for i = 0 to length t - 1 do acc := f i !acc (unsafe_get t i) done; !acc ;; let folding_mapi t ~init ~f = let acc = ref init in mapi t ~f:(fun i x -> let new_acc, y = f i !acc x in acc := new_acc; y) [@nontail] ;; let fold_mapi t ~init ~f = let acc = ref init in let result = mapi t ~f:(fun i x -> let new_acc, y = f i !acc x in acc := new_acc; y) in !acc, result ;; let counti t ~f = foldi t ~init:0 ~f:(fun idx count a -> if f idx a then count + 1 else count) [@nontail] ;; let concat_map t ~f = concat (to_list (map ~f t)) let concat_mapi t ~f = concat (to_list (mapi ~f t)) let rev_inplace t = let i = ref 0 in let j = ref (length t - 1) in while !i < !j do swap t !i !j; incr i; decr j done ;; let rev t = let t = copy t in rev_inplace t; t ;; let of_list_rev l = match l with | [] -> [||] | a :: l -> let len = 1 + List.length l in let t = create ~len a in let r = ref l in (* We start at [len - 2] because we already put [a] at [t.(len - 1)]. *) for i = len - 2 downto 0 do match !r with | [] -> assert false | a :: l -> t.(i) <- a; r := l done; t ;; (* [of_list_map] and [of_list_rev_map] are based on functions from the OCaml distribution. *) let of_list_map xs ~f = match xs with | [] -> [||] | hd :: tl -> let a = create ~len:(1 + List.length tl) (f hd) in let rec fill i = function | [] -> a | hd :: tl -> unsafe_set a i (f hd); fill (i + 1) tl in fill 1 tl [@nontail] ;; let of_list_mapi xs ~f = match xs with | [] -> [||] | hd :: tl -> let a = create ~len:(1 + List.length tl) (f 0 hd) in let rec fill a i = function | [] -> a | hd :: tl -> unsafe_set a i (f i hd); fill a (i + 1) tl in fill a 1 tl [@nontail] ;; let of_list_rev_map xs ~f = let t = of_list_map xs ~f in rev_inplace t; t ;; let of_list_rev_mapi xs ~f = let t = of_list_mapi xs ~f in rev_inplace t; t ;; let filter_mapi t ~f = let r = ref [||] in let k = ref 0 in for i = 0 to length t - 1 do match f i (unsafe_get t i) with | None -> () | Some a -> if !k = 0 then r := create ~len:(length t) a; unsafe_set !r !k a; incr k done; if !k = length t then !r else if !k > 0 then sub ~pos:0 ~len:!k !r else [||] ;; let filter_map t ~f = filter_mapi t ~f:(fun _i a -> f a) [@nontail] let filter_opt t = filter_map t ~f:Fn.id let raise_length_mismatch name n1 n2 = invalid_argf "length mismatch in %s: %d <> %d" name n1 n2 () [@@cold] [@@inline never] [@@local never] [@@specialise never] ;; let check_length2_exn name t1 t2 = let n1 = length t1 in let n2 = length t2 in if n1 <> n2 then raise_length_mismatch name n1 n2 ;; let iter2_exn t1 t2 ~f = check_length2_exn "Array.iter2_exn" t1 t2; iteri t1 ~f:(fun i x1 -> f x1 (unsafe_get t2 i)) [@nontail] ;; let map2_exn t1 t2 ~f = check_length2_exn "Array.map2_exn" t1 t2; init (length t1) ~f:(fun i -> f (unsafe_get t1 i) (unsafe_get t2 i)) [@nontail] ;; let fold2_exn t1 t2 ~init ~f = check_length2_exn "Array.fold2_exn" t1 t2; foldi t1 ~init ~f:(fun i ac x -> f ac x (unsafe_get t2 i)) [@nontail] ;; let filter t ~f = filter_map t ~f:(fun x -> if f x then Some x else None) [@nontail] let filteri t ~f = filter_mapi t ~f:(fun i x -> if f i x then Some x else None) [@nontail] let exists t ~f = let i = ref (length t - 1) in let result = ref false in while !i >= 0 && not !result do if f (unsafe_get t !i) then result := true else decr i done; !result ;; let existsi t ~f = let i = ref (length t - 1) in let result = ref false in while !i >= 0 && not !result do if f !i (unsafe_get t !i) then result := true else decr i done; !result ;; let mem t a ~equal = exists t ~f:(equal a) [@nontail] let for_all t ~f = let i = ref (length t - 1) in let result = ref true in while !i >= 0 && !result do if not (f (unsafe_get t !i)) then result := false else decr i done; !result ;; let for_alli t ~f = let length = length t in let i = ref (length - 1) in let result = ref true in while !i >= 0 && !result do if not (f !i (unsafe_get t !i)) then result := false else decr i done; !result ;; let exists2_exn t1 t2 ~f = check_length2_exn "Array.exists2_exn" t1 t2; let i = ref (length t1 - 1) in let result = ref false in while !i >= 0 && not !result do if f (unsafe_get t1 !i) (unsafe_get t2 !i) then result := true else decr i done; !result ;; let for_all2_exn t1 t2 ~f = check_length2_exn "Array.for_all2_exn" t1 t2; let i = ref (length t1 - 1) in let result = ref true in while !i >= 0 && !result do if not (f (unsafe_get t1 !i) (unsafe_get t2 !i)) then result := false else decr i done; !result ;; let equal equal t1 t2 = length t1 = length t2 && for_all2_exn t1 t2 ~f:equal let map_inplace t ~f = for i = 0 to length t - 1 do unsafe_set t i (f (unsafe_get t i)) done ;; let[@inline always] findi_internal t ~f ~if_found ~if_not_found = let length = length t in if length = 0 then if_not_found () else ( let i = ref 0 in let found = ref false in let value_found = ref (unsafe_get t 0) in while (not !found) && !i < length do let value = unsafe_get t !i in if f !i value then ( value_found := value; found := true) else incr i done; if !found then if_found ~i:!i ~value:!value_found else if_not_found ()) ;; let findi t ~f = findi_internal t ~f ~if_found:(fun ~i ~value -> Some (i, value)) ~if_not_found:(fun () -> None) ;; let findi_exn t ~f = findi_internal t ~f ~if_found:(fun ~i ~value -> i, value) ~if_not_found:(fun () -> raise (Not_found_s (Atom "Array.findi_exn: not found"))) ;; let find_exn t ~f = findi_internal t ~f:(fun _i x -> f x) ~if_found:(fun ~i:_ ~value -> value) ~if_not_found:(fun () -> raise (Not_found_s (Atom "Array.find_exn: not found"))) [@nontail] ;; let find t ~f = Option.map (findi t ~f:(fun _i x -> f x)) ~f:(fun (_i, x) -> x) let find_map t ~f = let length = length t in if length = 0 then None else ( let i = ref 0 in let value_found = ref None in while Option.is_none !value_found && !i < length do let value = unsafe_get t !i in value_found := f value; incr i done; !value_found) ;; let find_map_exn = let not_found = Not_found_s (Atom "Array.find_map_exn: not found") in let find_map_exn t ~f = match find_map t ~f with | None -> raise not_found | Some x -> x in (* named to preserve symbol in compiled binary *) find_map_exn ;; let find_mapi t ~f = let length = length t in if length = 0 then None else ( let i = ref 0 in let value_found = ref None in while Option.is_none !value_found && !i < length do let value = unsafe_get t !i in value_found := f !i value; incr i done; !value_found) ;; let find_mapi_exn = let not_found = Not_found_s (Atom "Array.find_mapi_exn: not found") in let find_mapi_exn t ~f = match find_mapi t ~f with | None -> raise not_found | Some x -> x in (* named to preserve symbol in compiled binary *) find_mapi_exn ;; let find_consecutive_duplicate t ~equal = let n = length t in if n <= 1 then None else ( let result = ref None in let i = ref 1 in let prev = ref (unsafe_get t 0) in while !i < n do let cur = unsafe_get t !i in if equal cur !prev then ( result := Some (!prev, cur); i := n) else ( prev := cur; incr i) done; !result) ;; let reduce t ~f = if length t = 0 then None else ( let r = ref (unsafe_get t 0) in for i = 1 to length t - 1 do r := f !r (unsafe_get t i) done; Some !r) ;; let reduce_exn t ~f = match reduce t ~f with | None -> invalid_arg "Array.reduce_exn" | Some v -> v ;; let permute = Array_permute.permute let random_element_exn ?(random_state = Random.State.default) t = if is_empty t then failwith "Array.random_element_exn: empty array" else t.(Random.State.int random_state (length t)) ;; let random_element ?(random_state = Random.State.default) t = try Some (random_element_exn ~random_state t) with | _ -> None ;; let zip t1 t2 = if length t1 <> length t2 then None else Some (map2_exn t1 t2 ~f:(fun x1 x2 -> x1, x2)) ;; let zip_exn t1 t2 = if length t1 <> length t2 then failwith "Array.zip_exn" else map2_exn t1 t2 ~f:(fun x1 x2 -> x1, x2) ;; let unzip t = let n = length t in if n = 0 then [||], [||] else ( let x, y = t.(0) in let res1 = create ~len:n x in let res2 = create ~len:n y in for i = 1 to n - 1 do let x, y = t.(i) in res1.(i) <- x; res2.(i) <- y done; res1, res2) ;; let sorted_copy t ~compare = let t1 = copy t in sort t1 ~compare; t1 ;; let partition_mapi t ~f = let (both : _ Either.t t) = mapi t ~f in let firsts = filter_map both ~f:(function | First x -> Some x | Second _ -> None) in let seconds = filter_map both ~f:(function | First _ -> None | Second x -> Some x) in firsts, seconds ;; let partitioni_tf t ~f = partition_mapi t ~f:(fun i x -> if f i x then First x else Second x) [@nontail] ;; let partition_map t ~f = partition_mapi t ~f:(fun _ x -> f x) [@nontail] let partition_tf t ~f = partitioni_tf t ~f:(fun _ x -> f x) [@nontail] let last t = t.(length t - 1) (* Convert to a sequence but does not attempt to protect against modification in the array. *) let to_sequence_mutable t = Sequence.unfold_step ~init:0 ~f:(fun i -> if i >= length t then Sequence.Step.Done else Sequence.Step.Yield { value = t.(i); state = i + 1 }) ;; let to_sequence t = to_sequence_mutable (copy t) let cartesian_product t1 t2 = if is_empty t1 || is_empty t2 then [||] else ( let n1 = length t1 in let n2 = length t2 in let t = create ~len:(n1 * n2) (t1.(0), t2.(0)) in let r = ref 0 in for i1 = 0 to n1 - 1 do for i2 = 0 to n2 - 1 do t.(!r) <- t1.(i1), t2.(i2); incr r done done; t) ;; let transpose tt = if length tt = 0 then Some [||] else ( let width = length tt in let depth = length tt.(0) in if exists tt ~f:(fun t -> length t <> depth) then None else Some (init depth ~f:(fun d -> init width ~f:(fun w -> tt.(w).(d))))) ;; let transpose_exn tt = match transpose tt with | None -> invalid_arg "Array.transpose_exn" | Some tt' -> tt' ;; include Binary_searchable.Make1 (struct type nonrec 'a t = 'a t let get = get let length = length end) include Blit.Make1 (struct type nonrec 'a t = 'a t let length = length let create_like ~len t = if len = 0 then [||] else ( assert (length t > 0); create ~len t.(0)) ;; let unsafe_blit = unsafe_blit end) let invariant invariant_a t = iter t ~f:invariant_a module Private = struct module Sort = Sort module Sorter = Sorter end base-0.16.3/src/array.mli000066400000000000000000000314551446274340700151460ustar00rootroot00000000000000(** Fixed-length, mutable vector of elements with O(1) [get] and [set] operations. *) open! Import type 'a t = 'a array [@@deriving_inline compare, globalize, sexp, sexp_grammar] include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t val globalize : (('a[@ocaml.local]) -> 'a) -> ('a t[@ocaml.local]) -> 'a t include Sexplib0.Sexpable.S1 with type 'a t := 'a t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] include Binary_searchable.S1 with type 'a t := 'a t include Indexed_container.S1_with_creators with type 'a t := 'a t include Invariant.S1 with type 'a t := 'a t (** Maximum length of a normal array. The maximum length of a float array is [max_length/2] on 32-bit machines and [max_length] on 64-bit machines. *) val max_length : int (*_ Declared as externals so that the compiler skips the caml_apply_X wrapping even when compiling without cross library inlining. *) external length : ('a t[@local_opt]) -> int = "%array_length" (** [Array.get a n] returns the element number [n] of array [a]. The first element has number 0. The last element has number [Array.length a - 1]. You can also write [a.(n)] instead of [Array.get a n]. Raise [Invalid_argument "index out of bounds"] if [n] is outside the range 0 to [(Array.length a - 1)]. *) external get : ('a t[@local_opt]) -> (int[@local_opt]) -> 'a = "%array_safe_get" (** [Array.set a n x] modifies array [a] in place, replacing element number [n] with [x]. You can also write [a.(n) <- x] instead of [Array.set a n x]. Raise [Invalid_argument "index out of bounds"] if [n] is outside the range 0 to [Array.length a - 1]. *) external set : ('a t[@local_opt]) -> (int[@local_opt]) -> 'a -> unit = "%array_safe_set" (** Unsafe version of [get]. Can cause arbitrary behavior when used for an out-of-bounds array access. *) external unsafe_get : ('a t[@local_opt]) -> (int[@local_opt]) -> 'a = "%array_unsafe_get" (** Unsafe version of [set]. Can cause arbitrary behavior when used for an out-of-bounds array access. *) external unsafe_set : ('a t[@local_opt]) -> (int[@local_opt]) -> 'a -> unit = "%array_unsafe_set" (** [create ~len x] creates an array of length [len] with the value [x] populated in each element. *) val create : len:int -> 'a -> 'a t (** [create_local ~len x] is like [create]. It allocates the array on the local stack. The array's elements are still global. *) val create_local : len:int -> 'a -> ('a t[@local]) (** [create_float_uninitialized ~len] creates a float array of length [len] with uninitialized elements -- that is, they may contain arbitrary, nondeterministic float values. This can be significantly faster than using [create], when unboxed float array representations are enabled. *) val create_float_uninitialized : len:int -> float t (** [Array.make_matrix dimx dimy e] returns a two-dimensional array (an array of arrays) with first dimension [dimx] and second dimension [dimy]. All the elements of this new matrix are initially physically equal to [e]. The element ([x,y]) of a matrix [m] is accessed with the notation [m.(x).(y)]. Raise [Invalid_argument] if [dimx] or [dimy] is negative or greater than [Array.max_length]. If the value of [e] is a floating-point number, then the maximum size is only [Array.max_length / 2]. *) val make_matrix : dimx:int -> dimy:int -> 'a -> 'a t t (** [Array.copy_matrix t] returns a fresh copy of the array of arrays [t]. This is typically used when [t] is a matrix created by [Array.make_matrix]. *) val copy_matrix : 'a t t -> 'a t t (** Like [Array.append], but concatenates a list of arrays. *) val concat : 'a t list -> 'a t (** [Array.copy a] returns a copy of [a], that is, a fresh array containing the same elements as [a]. *) val copy : 'a t -> 'a t (** [Array.fill a ofs len x] modifies the array [a] in place, storing [x] in elements number [ofs] to [ofs + len - 1]. Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not designate a valid subarray of [a]. *) val fill : 'a t -> pos:int -> len:int -> 'a -> unit (** [Array.blit v1 o1 v2 o2 len] copies [len] elements from array [v1], starting at element number [o1], to array [v2], starting at element number [o2]. It works correctly even if [v1] and [v2] are the same array, and the source and destination chunks overlap. Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not designate a valid subarray of [v1], or if [o2] and [len] do not designate a valid subarray of [v2]. [int_blit] and [float_blit] provide fast bound-checked blits for immediate data types. The unsafe versions do not bound-check the arguments. *) include Blit.S1 with type 'a t := 'a t (** [folding_map] is a version of [map] that threads an accumulator through calls to [f]. *) val folding_map : 'a t -> init:'acc -> f:(('acc -> 'a -> 'acc * 'b)[@local]) -> 'b t val folding_mapi : 'a t -> init:'acc -> f:((int -> 'acc -> 'a -> 'acc * 'b)[@local]) -> 'b t (** [Array.fold_map] is a combination of [Array.fold] and [Array.map] that threads an accumulator through calls to [f]. *) val fold_map : 'a t -> init:'acc -> f:(('acc -> 'a -> 'acc * 'b)[@local]) -> 'acc * 'b t val fold_mapi : 'a t -> init:'acc -> f:((int -> 'acc -> 'a -> 'acc * 'b)[@local]) -> 'acc * 'b t (** [Array.fold_right f a ~init] computes [f a.(0) (f a.(1) ( ... (f a.(n-1) init) ...))], where [n] is the length of the array [a]. *) val fold_right : 'a t -> f:(('a -> 'acc -> 'acc)[@local]) -> init:'acc -> 'acc (** All sort functions in this module sort in increasing order by default. *) (** [sort] uses constant heap space. [stable_sort] uses linear heap space. To sort only part of the array, specify [pos] to be the index to start sorting from and [len] indicating how many elements to sort. *) val sort : ?pos:int -> ?len:int -> 'a t -> compare:(('a -> 'a -> int)[@local]) -> unit val stable_sort : 'a t -> compare:('a -> 'a -> int) -> unit val is_sorted : 'a t -> compare:(('a -> 'a -> int)[@local]) -> bool (** [is_sorted_strictly xs ~compare] iff [is_sorted xs ~compare] and no two consecutive elements in [xs] are equal according to [compare]. *) val is_sorted_strictly : 'a t -> compare:(('a -> 'a -> int)[@local]) -> bool (** Merges two arrays: assuming that [a1] and [a2] are sorted according to the comparison function [compare], [merge a1 a2 ~compare] will return a sorted array containing all the elements of [a1] and [a2]. If several elements compare equal, the elements of [a1] will be before the elements of [a2]. *) val merge : 'a t -> 'a t -> compare:(('a -> 'a -> int)[@local]) -> 'a t val partitioni_tf : 'a t -> f:((int -> 'a -> bool)[@local]) -> 'a t * 'a t val cartesian_product : 'a t -> 'b t -> ('a * 'b) t (** [transpose] in the sense of a matrix transpose. It returns [None] if the arrays are not all the same length. *) val transpose : 'a t t -> 'a t t option val transpose_exn : 'a t t -> 'a t t (** [filter_opt array] returns a new array where [None] entries are omitted and [Some x] entries are replaced with [x]. Note that this changes the index at which elements will appear. *) val filter_opt : 'a option t -> 'a t (** Functions with the 2 suffix raise an exception if the lengths of the two given arrays aren't the same. *) val iter2_exn : 'a t -> 'b t -> f:(('a -> 'b -> unit)[@local]) -> unit val map2_exn : 'a t -> 'b t -> f:(('a -> 'b -> 'c)[@local]) -> 'c t val fold2_exn : 'a t -> 'b t -> init:'acc -> f:(('acc -> 'a -> 'b -> 'acc)[@local]) -> 'acc (** [for_all2_exn t1 t2 ~f] fails if [length t1 <> length t2]. *) val for_all2_exn : 'a t -> 'b t -> f:(('a -> 'b -> bool)[@local]) -> bool (** [exists2_exn t1 t2 ~f] fails if [length t1 <> length t2]. *) val exists2_exn : 'a t -> 'b t -> f:(('a -> 'b -> bool)[@local]) -> bool (** [swap arr i j] swaps the value at index [i] with that at index [j]. *) val swap : 'a t -> int -> int -> unit (** [rev_inplace t] reverses [t] in place. *) val rev_inplace : 'a t -> unit (** [rev t] returns a reversed copy of [t] *) val rev : 'a t -> 'a t (** [of_list_rev l] converts from list then reverses in place. *) val of_list_rev : 'a list -> 'a t (** [of_list_map l ~f] is the same as [of_list (List.map l ~f)]. *) val of_list_map : 'a list -> f:(('a -> 'b)[@local]) -> 'b t (** [of_list_mapi l ~f] is the same as [of_list (List.mapi l ~f)]. *) val of_list_mapi : 'a list -> f:((int -> 'a -> 'b)[@local]) -> 'b t (** [of_list_rev_map l ~f] is the same as [of_list (List.rev_map l ~f)]. *) val of_list_rev_map : 'a list -> f:(('a -> 'b)[@local]) -> 'b t (** [of_list_rev_mapi l ~f] is the same as [of_list (List.rev_mapi l ~f)]. *) val of_list_rev_mapi : 'a list -> f:((int -> 'a -> 'b)[@local]) -> 'b t (** Modifies an array in place, applying [f] to every element of the array *) val map_inplace : 'a t -> f:(('a -> 'a)[@local]) -> unit (** [find_exn f t] returns the first [a] in [t] for which [f t.(i)] is true. It raises [Stdlib.Not_found] or [Not_found_s] if there is no such [a]. *) val find_exn : 'a t -> f:(('a -> bool)[@local]) -> 'a (** Returns the first evaluation of [f] that returns [Some]. Raises [Stdlib.Not_found] or [Not_found_s] if [f] always returns [None]. *) val find_map_exn : 'a t -> f:(('a -> 'b option)[@local]) -> 'b (** [findi_exn t f] returns the first index [i] of [t] for which [f i t.(i)] is true. It raises [Stdlib.Not_found] or [Not_found_s] if there is no such element. *) val findi_exn : 'a t -> f:((int -> 'a -> bool)[@local]) -> int * 'a (** [find_mapi_exn] is like [find_map_exn] but passes the index as an argument. *) val find_mapi_exn : 'a t -> f:((int -> 'a -> 'b option)[@local]) -> 'b (** [find_consecutive_duplicate t ~equal] returns the first pair of consecutive elements [(a1, a2)] in [t] such that [equal a1 a2]. They are returned in the same order as they appear in [t]. *) val find_consecutive_duplicate : 'a t -> equal:(('a -> 'a -> bool)[@local]) -> ('a * 'a) option (** [reduce f [a1; ...; an]] is [Some (f (... (f (f a1 a2) a3) ...) an)]. Returns [None] on the empty array. *) val reduce : 'a t -> f:(('a -> 'a -> 'a)[@local]) -> 'a option val reduce_exn : 'a t -> f:(('a -> 'a -> 'a)[@local]) -> 'a (** [permute ?random_state ?pos ?len t] randomly permutes [t] in place. To permute only part of the array, specify [pos] to be the index to start permuting from and [len] indicating how many elements to permute. [permute] side-effects [random_state] by repeated calls to [Random.State.int]. If [random_state] is not supplied, [permute] uses [Random.State.default]. *) val permute : ?random_state:Random.State.t -> ?pos:int -> ?len:int -> 'a t -> unit (** [random_element ?random_state t] is [None] if [t] is empty, else it is [Some x] for some [x] chosen uniformly at random from [t]. [random_element] side-effects [random_state] by calling [Random.State.int]. If [random_state] is not supplied, [random_element] uses [Random.State.default]. *) val random_element : ?random_state:Random.State.t -> 'a t -> 'a option val random_element_exn : ?random_state:Random.State.t -> 'a t -> 'a (** [zip] is like [List.zip], but for arrays. *) val zip : 'a t -> 'b t -> ('a * 'b) t option val zip_exn : 'a t -> 'b t -> ('a * 'b) t (** [unzip] is like [List.unzip], but for arrays. *) val unzip : ('a * 'b) t -> 'a t * 'b t (** [sorted_copy ar compare] returns a shallow copy of [ar] that is sorted. Similar to List.sort *) val sorted_copy : 'a t -> compare:(('a -> 'a -> int)[@local]) -> 'a t val last : 'a t -> 'a val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** The input array is copied internally so that future modifications of it do not change the sequence. *) val to_sequence : 'a t -> 'a Sequence.t (** The input array is shared with the sequence and modifications of it will result in modification of the sequence. *) val to_sequence_mutable : 'a t -> 'a Sequence.t (**/**) (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig module Sort : sig module type Sort = sig val sort : 'a t -> compare:(('a -> 'a -> int)[@local]) -> left:int -> right:int -> unit end module Insertion_sort : Sort module Heap_sort : Sort module Intro_sort : sig include Sort val five_element_sort : 'a t -> compare:(('a -> 'a -> int)[@local]) -> int -> int -> int -> int -> int -> unit end end module Sorter (S : sig type 'a t val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> unit val length : 'a t -> int end) : sig val sort : ?pos:int -> ?len:int -> 'a S.t -> compare:(('a -> 'a -> int)[@local]) -> unit end end base-0.16.3/src/array0.ml000066400000000000000000000077561446274340700150640ustar00rootroot00000000000000(* [Array0] defines array functions that are primitives or can be simply defined in terms of [Stdlib.Array]. [Array0] is intended to completely express the part of [Stdlib.Array] that [Base] uses -- no other file in Base other than array0.ml should use [Stdlib.Array]. [Array0] has few dependencies, and so is available early in Base's build order. All Base files that need to use arrays and come before [Base.Array] in build order should do [module Array = Array0]. This includes uses of subscript syntax ([x.(i)], [x.(i) <- e]), which the OCaml parser desugars into calls to [Array.get] and [Array.set]. Defining [module Array = Array0] is also necessary because it prevents ocamldep from mistakenly causing a file to depend on [Base.Array]. *) open! Import0 module Sys = Sys0 let invalid_argf = Printf.invalid_argf module Array = struct external create : int -> 'a -> 'a array = "caml_make_vect" external create_local : int -> 'a -> ('a array[@local]) = "caml_make_vect" external create_float_uninitialized : int -> float array = "caml_make_float_vect" external get : ('a array[@local_opt]) -> (int[@local_opt]) -> 'a = "%array_safe_get" external length : ('a array[@local_opt]) -> int = "%array_length" external set : ('a array[@local_opt]) -> (int[@local_opt]) -> 'a -> unit = "%array_safe_set" external unsafe_get : ('a array[@local_opt]) -> (int[@local_opt]) -> 'a = "%array_unsafe_get" external unsafe_set : ('a array[@local_opt]) -> (int[@local_opt]) -> 'a -> unit = "%array_unsafe_set" external unsafe_blit : src:('a array[@local_opt]) -> src_pos:int -> dst:('a array[@local_opt]) -> dst_pos:int -> len:int -> unit = "caml_array_blit" end include Array let max_length = Sys.max_array_length let create ~len x = try create len x with | Invalid_argument _ -> invalid_argf "Array.create ~len:%d: invalid length" len () ;; let create_local ~len x = (try create_local len x with | Invalid_argument _ -> invalid_argf "Array.create_local ~len:%d: invalid length" len ()) ;; let create_float_uninitialized ~len = try create_float_uninitialized len with | Invalid_argument _ -> invalid_argf "Array.create_float_uninitialized ~len:%d: invalid length" len () ;; let append = Stdlib.Array.append let blit = Stdlib.Array.blit let concat = Stdlib.Array.concat let copy = Stdlib.Array.copy let fill = Stdlib.Array.fill let init len ~f:((f : _ -> _) [@local]) = if len = 0 then [||] else if len < 0 then invalid_arg "Array.init" else ( let res = create ~len (f 0) in for i = 1 to Int0.pred len do unsafe_set res i (f i) done; res) ;; let make_matrix = Stdlib.Array.make_matrix let of_list = Stdlib.Array.of_list let sub = Stdlib.Array.sub let to_list = Stdlib.Array.to_list let fold t ~init ~f:((f : _ -> _ -> _) [@local]) = let r = ref init in for i = 0 to length t - 1 do r := f !r (unsafe_get t i) done; !r ;; let fold_right t ~f:((f : _ -> _ -> _) [@local]) ~init = let r = ref init in for i = length t - 1 downto 0 do r := f (unsafe_get t i) !r done; !r ;; let iter t ~f:((f : _ -> _) [@local]) = for i = 0 to length t - 1 do f (unsafe_get t i) done ;; let iteri t ~f:((f : _ -> _ -> _) [@local]) = for i = 0 to length t - 1 do f i (unsafe_get t i) done ;; let map t ~f:((f : _ -> _) [@local]) = let len = length t in if len = 0 then [||] else ( let r = create ~len (f (unsafe_get t 0)) in for i = 1 to len - 1 do unsafe_set r i (f (unsafe_get t i)) done; r) ;; let mapi t ~f:((f : _ -> _ -> _) [@local]) = let len = length t in if len = 0 then [||] else ( let r = create ~len (f 0 (unsafe_get t 0)) in for i = 1 to len - 1 do unsafe_set r i (f i (unsafe_get t i)) done; r) ;; let stable_sort t ~compare = Stdlib.Array.stable_sort t ~cmp:compare let swap t i j = let elt_i = t.(i) in let elt_j = t.(j) in unsafe_set t i elt_j; unsafe_set t j elt_i ;; base-0.16.3/src/array_permute.ml000066400000000000000000000014351446274340700165310ustar00rootroot00000000000000(** An internal-only module factored out due to a circular dependency between core_array and core_list. Contains code for permuting an array. *) open! Import include Array0 let permute ?(random_state = Random.State.default) ?(pos = 0) ?len t = (* Copied from [Ordered_collection_common0] to avoid allocating a tuple when compiling without flambda. *) let total_length = length t in let len = match len with | Some l -> l | None -> total_length - pos in Ordered_collection_common0.check_pos_len_exn ~pos ~len ~total_length; let num_swaps = len - 1 in for i = num_swaps downto 1 do let this_i = pos + i in (* [random_i] is drawn from [pos,this_i] *) let random_i = pos + Random.State.int random_state (i + 1) in swap t this_i random_i done ;; base-0.16.3/src/avltree.ml000066400000000000000000000371511446274340700153200ustar00rootroot00000000000000(* A few small things copied from other parts of Base because they depend on us, so we can't use them. *) open! Import let raise_s = Error.raise_s module Int = struct type t = int let max (x : t) y = if x > y then x else y end (* Its important that Empty have no args. It's tempting to make this type a record (e.g. to hold the compare function), but a lot of memory is saved by Empty being an immediate, since all unused buckets in the hashtbl don't use any memory (besides the array cell) *) type ('k, 'v) t = | Empty | Node of { mutable left : ('k, 'v) t ; key : 'k ; mutable value : 'v ; mutable height : int ; mutable right : ('k, 'v) t } | Leaf of { key : 'k ; mutable value : 'v } let empty = Empty let is_empty = function | Empty -> true | Leaf _ | Node _ -> false ;; let height = function | Empty -> 0 | Leaf _ -> 1 | Node { left = _; key = _; value = _; height; right = _ } -> height ;; let invariant compare = let legal_left_key key = function | Empty -> () | Leaf { key = left_key; value = _ } | Node { left = _; key = left_key; value = _; height = _; right = _ } -> assert (compare left_key key < 0) in let legal_right_key key = function | Empty -> () | Leaf { key = right_key; value = _ } | Node { left = _; key = right_key; value = _; height = _; right = _ } -> assert (compare right_key key > 0) in let rec inv = function | Empty | Leaf _ -> () | Node { left; key = k; value = _; height = h; right } -> let hl, hr = height left, height right in inv left; inv right; legal_left_key k left; legal_right_key k right; assert (h = Int.max hl hr + 1); assert (abs (hl - hr) <= 2) in inv ;; let invariant t ~compare = invariant compare t (* In the following comments, 't is balanced' means that 'invariant t' does not raise an exception. This implies of course that each node's height field is correct. 't is balanceable' means that height of the left and right subtrees of t differ by at most 3. *) (* @pre: left and right subtrees have correct heights @post: output has the correct height *) let update_height = function | Node ({ left; key = _; value = _; height = old_height; right } as x) -> let new_height = Int.max (height left) (height right) + 1 in if new_height <> old_height then x.height <- new_height | Empty | Leaf _ -> assert false ;; (* @pre: left and right subtrees are balanced @pre: tree is balanceable @post: output is balanced (in particular, height is correct) *) let balance tree = match tree with | Empty | Leaf _ -> tree | Node ({ left; key = _; value = _; height = _; right } as root_node) -> let hl = height left and hr = height right in (* + 2 is critically important, lowering it to 1 will break the Leaf assumptions in the code below, and will force us to promote leaf nodes in the balance routine. It's also faster, since it will balance less often. Note that the following code is delicate. The update_height calls must occur in the correct order, since update_height assumes its children have the correct heights. *) if hl > hr + 2 then ( match left with (* It cannot be a leaf, because even if right is empty, a leaf is only height 1 *) | Empty | Leaf _ -> assert false | Node ({ left = left_node_left ; key = _ ; value = _ ; height = _ ; right = left_node_right } as left_node) -> if height left_node_left >= height left_node_right then ( root_node.left <- left_node_right; left_node.right <- tree; update_height tree; update_height left; left) else ( (* if right is a leaf, then left must be empty. That means height is 2. Even if hr is empty we still can't get here. *) match left_node_right with | Empty | Leaf _ -> assert false | Node ({ left = lr_left; key = _; value = _; height = _; right = lr_right } as lr_node) -> left_node.right <- lr_left; root_node.left <- lr_right; lr_node.right <- tree; lr_node.left <- left; update_height left; update_height tree; update_height left_node_right; left_node_right)) else if hr > hl + 2 then ( (* see above for an explanation of why right cannot be a leaf *) match right with | Empty | Leaf _ -> assert false | Node ({ left = right_node_left ; key = _ ; value = _ ; height = _ ; right = right_node_right } as right_node) -> if height right_node_right >= height right_node_left then ( root_node.right <- right_node_left; right_node.left <- tree; update_height tree; update_height right; right) else ( (* see above for an explanation of why this cannot be a leaf *) match right_node_left with | Empty | Leaf _ -> assert false | Node ({ left = rl_left; key = _; value = _; height = _; right = rl_right } as rl_node) -> right_node.left <- rl_right; root_node.right <- rl_left; rl_node.left <- tree; rl_node.right <- right; update_height right; update_height tree; update_height right_node_left; right_node_left)) else ( update_height tree; tree) ;; (* @pre: tree is balanceable @pre: abs (height (right node) - height (balance tree)) <= 3 @post: result is balanceable *) (* @pre: tree is balanceable @pre: abs (height (right node) - height (balance tree)) <= 3 @post: result is balanceable *) let set_left node tree = let tree = balance tree in match node with | Node ({ left; key = _; value = _; height = _; right = _ } as r) -> if phys_equal left tree then () else r.left <- tree; update_height node | _ -> assert false ;; (* @pre: tree is balanceable @pre: abs (height (left node) - height (balance tree)) <= 3 @post: result is balanceable *) let set_right node tree = let tree = balance tree in match node with | Node ({ left = _; key = _; value = _; height = _; right } as r) -> if phys_equal right tree then () else r.right <- tree; update_height node | _ -> assert false ;; (* @pre: t is balanced. @post: result is balanced, with new node inserted @post: !added = true iff the shape of the input tree changed. *) let add = let rec add t replace added compare k v = match t with | Empty -> added := true; Leaf { key = k; value = v } | Leaf ({ key = k'; value = _ } as r) -> let c = compare k' k in (* This compare is reversed on purpose, we are pretending that the leaf was just inserted instead of the other way round, that way we only allocate one node. *) if c = 0 then ( added := false; if replace then r.value <- v; t) else ( added := true; if c < 0 then Node { left = t; key = k; value = v; height = 2; right = Empty } else Node { left = Empty; key = k; value = v; height = 2; right = t }) | Node ({ left; key = k'; value = _; height = _; right } as r) -> let c = compare k k' in if c = 0 then ( added := false; if replace then r.value <- v) else if c < 0 then set_left t (add left replace added compare k v) else set_right t (add right replace added compare k v); t in fun t ~replace ~compare ~added ~key ~data -> let t = add t replace added compare key data in if !added then balance t else t ;; let rec first t = match t with | Empty -> None | Leaf { key = k; value = v } | Node { left = Empty; key = k; value = v; height = _; right = _ } -> Some (k, v) | Node { left = l; key = _; value = _; height = _; right = _ } -> first l ;; let rec last t = match t with | Empty -> None | Leaf { key = k; value = v } | Node { left = _; key = k; value = v; height = _; right = Empty } -> Some (k, v) | Node { left = _; key = _; value = _; height = _; right = r } -> last r ;; let[@inline always] rec findi_and_call_impl t ~compare k arg1 arg2 ~call_if_found ~call_if_not_found ~if_found ~if_not_found = match t with | Empty -> call_if_not_found ~if_not_found k arg1 arg2 | Leaf { key = k'; value = v } -> if compare k k' = 0 then call_if_found ~if_found ~key:k' ~data:v arg1 arg2 else call_if_not_found ~if_not_found k arg1 arg2 | Node { left; key = k'; value = v; height = _; right } -> let c = compare k k' in if c = 0 then call_if_found ~if_found ~key:k' ~data:v arg1 arg2 else findi_and_call_impl (if c < 0 then left else right) ~compare k arg1 arg2 ~call_if_found ~call_if_not_found ~if_found ~if_not_found ;; let find_and_call = let call_if_found ~if_found ~key:_ ~data () () = if_found data in let call_if_not_found ~if_not_found key () () = if_not_found key in fun t ~compare k ~if_found ~if_not_found -> findi_and_call_impl t ~compare k () () ~call_if_found ~call_if_not_found ~if_found ~if_not_found ;; let findi_and_call = let call_if_found ~if_found ~key ~data () () = if_found ~key ~data in let call_if_not_found ~if_not_found key () () = if_not_found key in fun t ~compare k ~if_found ~if_not_found -> findi_and_call_impl t ~compare k () () ~call_if_found ~call_if_not_found ~if_found ~if_not_found ;; let find_and_call1 = let call_if_found ~if_found ~key:_ ~data arg () = if_found data arg in let call_if_not_found ~if_not_found key arg () = if_not_found key arg in fun t ~compare k ~a ~if_found ~if_not_found -> findi_and_call_impl t ~compare k a () ~call_if_found ~call_if_not_found ~if_found ~if_not_found ;; let findi_and_call1 = let call_if_found ~if_found ~key ~data arg () = if_found ~key ~data arg in let call_if_not_found ~if_not_found key arg () = if_not_found key arg in fun t ~compare k ~a ~if_found ~if_not_found -> findi_and_call_impl t ~compare k a () ~call_if_found ~call_if_not_found ~if_found ~if_not_found ;; let find_and_call2 = let call_if_found ~if_found ~key:_ ~data arg1 arg2 = if_found data arg1 arg2 in let call_if_not_found ~if_not_found key arg1 arg2 = if_not_found key arg1 arg2 in fun t ~compare k ~a ~b ~if_found ~if_not_found -> findi_and_call_impl t ~compare k a b ~call_if_found ~call_if_not_found ~if_found ~if_not_found ;; let findi_and_call2 = let call_if_found ~if_found ~key ~data arg1 arg2 = if_found ~key ~data arg1 arg2 in let call_if_not_found ~if_not_found key arg1 arg2 = if_not_found key arg1 arg2 in fun t ~compare k ~a ~b ~if_found ~if_not_found -> findi_and_call_impl t ~compare k a b ~call_if_found ~call_if_not_found ~if_found ~if_not_found ;; let find = let if_found v = Some v in let if_not_found _ = None in fun t ~compare k -> find_and_call t ~compare k ~if_found ~if_not_found ;; let mem = let if_found _ = true in let if_not_found _ = false in fun t ~compare k -> find_and_call t ~compare k ~if_found ~if_not_found ;; let remove = let rec min_elt tree = match tree with | Empty -> Empty | Leaf _ -> tree | Node { left = Empty; key = _; value = _; height = _; right = _ } -> tree | Node { left; key = _; value = _; height = _; right = _ } -> min_elt left in let rec remove_min_elt tree = match tree with | Empty -> assert false | Leaf _ -> Empty (* This must be the root *) | Node { left = Empty; key = _; value = _; height = _; right } -> right | Node { left = Leaf _; key = k; value = v; height = _; right = Empty } -> Leaf { key = k; value = v } | Node { left = Leaf _; key = _; value = _; height = _; right = _ } as node -> set_left node Empty; tree | Node { left; key = _; value = _; height = _; right = _ } as node -> set_left node (remove_min_elt left); tree in let merge t1 t2 = match t1, t2 with | Empty, t -> t | t, Empty -> t | _, _ -> let tree = min_elt t2 in (match tree with | Empty -> assert false | Leaf { key = k; value = v } -> let t2 = balance (remove_min_elt t2) in Node { left = t1 ; key = k ; value = v ; height = Int.max (height t1) (height t2) + 1 ; right = t2 } | Node _ as node -> set_right node (remove_min_elt t2); set_left node t1; node) in let rec remove t removed compare k = match t with | Empty -> removed := false; Empty | Leaf { key = k'; value = _ } -> if compare k k' = 0 then ( removed := true; Empty) else ( removed := false; t) | Node { left; key = k'; value = _; height = _; right } -> let c = compare k k' in if c = 0 then ( removed := true; merge left right) else if c < 0 then ( set_left t (remove left removed compare k); t) else ( set_right t (remove right removed compare k); t) in fun t ~removed ~compare k -> balance (remove t removed compare k) ;; let rec fold t ~init ~f = match t with | Empty -> init | Leaf { key; value = data } -> f ~key ~data init | Node { left = Leaf { key = lkey; value = ldata } ; key ; value = data ; height = _ ; right = Leaf { key = rkey; value = rdata } } -> f ~key:rkey ~data:rdata (f ~key ~data (f ~key:lkey ~data:ldata init)) | Node { left = Leaf { key = lkey; value = ldata } ; key ; value = data ; height = _ ; right = Empty } -> f ~key ~data (f ~key:lkey ~data:ldata init) | Node { left = Empty ; key ; value = data ; height = _ ; right = Leaf { key = rkey; value = rdata } } -> f ~key:rkey ~data:rdata (f ~key ~data init) | Node { left; key; value = data; height = _; right = Leaf { key = rkey; value = rdata } } -> f ~key:rkey ~data:rdata (f ~key ~data (fold left ~init ~f)) | Node { left = Leaf { key = lkey; value = ldata }; key; value = data; height = _; right } -> fold right ~init:(f ~key ~data (f ~key:lkey ~data:ldata init)) ~f | Node { left; key; value = data; height = _; right } -> fold right ~init:(f ~key ~data (fold left ~init ~f)) ~f ;; let rec iter t ~f = match t with | Empty -> () | Leaf { key; value = data } -> f ~key ~data | Node { left; key; value = data; height = _; right } -> iter left ~f; f ~key ~data; iter right ~f ;; let rec mapi_inplace t ~f = match t with | Empty -> () | Leaf ({ key; value } as t) -> t.value <- f ~key ~data:value | Node ({ left; key; value; height = _; right } as t) -> mapi_inplace ~f left; t.value <- f ~key ~data:value; mapi_inplace ~f right ;; let choose_exn = function | Empty -> raise_s (Sexp.message "[Avltree.choose_exn] of empty hashtbl" []) | Leaf { key; value; _ } | Node { key; value; _ } -> key, value ;; base-0.16.3/src/avltree.mli000066400000000000000000000142671446274340700154740ustar00rootroot00000000000000(** A low-level, mutable AVL tree. It is not intended to be used directly by casual users. It is used for implementing other data structures. The interface is somewhat ugly, and it's that way for a reason: the goal of this module is minimum memory overhead and maximum performance. {2 Caveats} 1. [compare] is passed to every function where it is used. If you pass a different [compare] to functions on the same tree, then behavior is indeterminate. Why? Because otherwise we'd need a top-level record to store [compare], and when building a hash table, or other structure, that little [t] is a block that increases memory overhead. However, if an empty tree is just a constructor [Empty], then it's just a number, and uses no extra memory beyond the array bucket that holds it. That's the first secret of how Hashtbl's memory overhead isn't higher than INRIA's, even though it uses a tree instead of a list for buckets. 2. But if it's mutable, why do all the "mutators" return [t]? Answer: it is mutable, but the root node might change due to balancing. Since we have no top-level record to hold the current root node (see point 1), you have to do it. If you fail to do it, and use an old root node, you're responsible for the (sure to be nasty) consequences. 3. What on earth is up with the [~removed] argument to some functions? See point 1: since there is no top-level node, it isn't possible to keep track of how many nodes are in the tree unless each mutator tells you whether or not it added or removed a node (vs. replacing an existing one). If you intend to keep a count (as you must in a hash table), then you will need to pay attention to this flag. After all this, you're probably asking yourself whether all these hacks are worth it. Yes! They are! With them, we built a hash table that is faster than INRIA's (no small feat) with the same memory overhead, sane add semantics (the add semantics they used were a performance hack), and worst-case log(N) insertion, lookup, and removal. *) open! Import (** We expose [t] to allow an optimization in Hashtbl that makes iter and fold more than twice as fast. We keep the type private to reduce opportunities for external code to violate avltree invariants. *) type ('k, 'v) t = private | Empty | Node of { mutable left : ('k, 'v) t ; key : 'k ; mutable value : 'v ; mutable height : int ; mutable right : ('k, 'v) t } | Leaf of { key : 'k ; mutable value : 'v } val empty : ('k, 'v) t val is_empty : _ t -> bool (** Checks invariants, raising an exception if any invariants fail. *) val invariant : ('k, 'v) t -> compare:('k -> 'k -> int) -> unit (** Adds the specified key and data to the tree destructively (previous [t]'s are no longer valid) using the specified comparison function. O(log(N)) time, O(1) space. The returned [t] is the new root node of the tree, and should be used on all further calls to any other function in this module. The bool [ref], added, will be set to [true] if a new node is added to the tree, or [false] if an existing node is replaced (in the case that the key already exists). If [replace] (default true) is true then [add] will overwrite any existing mapping for [key]. If [replace] is false, and there is an existing mapping for key, then [add] has no effect. *) val add : ('k, 'v) t -> replace:bool -> compare:(('k -> 'k -> int)[@local]) -> added:(bool ref[@local]) -> key:'k -> data:'v -> ('k, 'v) t (** Returns the first (leftmost) or last (rightmost) element in the tree. *) val first : ('k, 'v) t -> ('k * 'v) option val last : ('k, 'v) t -> ('k * 'v) option (** If the specified key exists in the tree, returns the corresponding value. O(log(N)) time and O(1) space. *) val find : ('k, 'v) t -> compare:(('k -> 'k -> int)[@local]) -> 'k -> 'v option (** [find_and_call t ~compare k ~if_found ~if_not_found] is equivalent to: [match find t ~compare k with Some v -> if_found v | None -> if_not_found k] except that it doesn't allocate the option. *) val find_and_call : ('k, 'v) t -> compare:(('k -> 'k -> int)[@local]) -> 'k -> if_found:(('v -> 'a)[@local]) -> if_not_found:(('k -> 'a)[@local]) -> 'a val find_and_call1 : ('k, 'v) t -> compare:(('k -> 'k -> int)[@local]) -> 'k -> a:'a -> if_found:(('v -> 'a -> 'b)[@local]) -> if_not_found:(('k -> 'a -> 'b)[@local]) -> 'b val find_and_call2 : ('k, 'v) t -> compare:(('k -> 'k -> int)[@local]) -> 'k -> a:'a -> b:'b -> if_found:(('v -> 'a -> 'b -> 'c)[@local]) -> if_not_found:(('k -> 'a -> 'b -> 'c)[@local]) -> 'c val findi_and_call : ('k, 'v) t -> compare:(('k -> 'k -> int)[@local]) -> 'k -> if_found:((key:'k -> data:'v -> 'a)[@local]) -> if_not_found:(('k -> 'a)[@local]) -> 'a val findi_and_call1 : ('k, 'v) t -> compare:(('k -> 'k -> int)[@local]) -> 'k -> a:'a -> if_found:((key:'k -> data:'v -> 'a -> 'b)[@local]) -> if_not_found:(('k -> 'a -> 'b)[@local]) -> 'b val findi_and_call2 : ('k, 'v) t -> compare:(('k -> 'k -> int)[@local]) -> 'k -> a:'a -> b:'b -> if_found:((key:'k -> data:'v -> 'a -> 'b -> 'c)[@local]) -> if_not_found:(('k -> 'a -> 'b -> 'c)[@local]) -> 'c (** Returns true if key is present in the tree, and false otherwise. *) val mem : ('k, 'v) t -> compare:(('k -> 'k -> int)[@local]) -> 'k -> bool (** Removes key destructively from the tree if it exists, returning the new root node. Previous root nodes are not usable anymore; do so at your peril. The [removed] ref will be set to true if a node was actually removed, and false otherwise. *) val remove : ('k, 'v) t -> removed:(bool ref[@local]) -> compare:(('k -> 'k -> int)[@local]) -> 'k -> ('k, 'v) t (** Folds over the tree. *) val fold : ('k, 'v) t -> init:'acc -> f:((key:'k -> data:'v -> 'acc -> 'acc)[@local]) -> 'acc (** Iterates over the tree. *) val iter : ('k, 'v) t -> f:((key:'k -> data:'v -> unit)[@local]) -> unit (** Map over the the tree, changing the data in place. *) val mapi_inplace : ('k, 'v) t -> f:((key:'k -> data:'v -> 'v)[@local]) -> unit val choose_exn : ('k, 'v) t -> 'k * 'v base-0.16.3/src/backtrace.ml000066400000000000000000000026721446274340700155750ustar00rootroot00000000000000open! Import module Sys = Sys0 type t = Stdlib.Printexc.raw_backtrace let elide = ref false let elided_message = "" let get ?(at_most_num_frames = Int.max_value) () = Stdlib.Printexc.get_callstack at_most_num_frames ;; let to_string t = if !elide then elided_message else Stdlib.Printexc.raw_backtrace_to_string t ;; let to_string_list t = String.split_lines (to_string t) let sexp_of_t t = Sexp.List (List.map (to_string_list t) ~f:(fun x -> Sexp.Atom x)) module Exn = struct let set_recording = Stdlib.Printexc.record_backtrace let am_recording = Stdlib.Printexc.backtrace_status let most_recent () = Stdlib.Printexc.get_raw_backtrace () let most_recent_for_exn exn = if Exn.is_phys_equal_most_recent exn then Some (most_recent ()) else None ;; (* We turn on backtraces by default if OCAMLRUNPARAM doesn't explicitly mention them. *) let maybe_set_recording () = let ocamlrunparam_mentions_backtraces = match Sys.getenv "OCAMLRUNPARAM" with | None -> false | Some x -> List.exists (String.split x ~on:',') ~f:(String.is_prefix ~prefix:"b") in if not ocamlrunparam_mentions_backtraces then set_recording true ;; (* the caller set something, they are responsible *) let with_recording b ~f = let saved = am_recording () in set_recording b; Exn.protect ~f ~finally:(fun () -> set_recording saved) ;; end let initialize_module () = Exn.maybe_set_recording () base-0.16.3/src/backtrace.mli000066400000000000000000000115671446274340700157510ustar00rootroot00000000000000(** Module for managing stack backtraces. The [Backtrace] module deals with two different kinds of backtraces: + Snapshots of the stack obtained on demand ([Backtrace.get]) + The stack frames unwound when an exception is raised ([Backtrace.Exn]) *) open! Import (** A [Backtrace.t] is a snapshot of the stack obtained by calling [Backtrace.get]. It is represented as a string with newlines separating the frames. [sexp_of_t] splits the string at newlines and removes some of the cruft, leaving a human-friendly list of frames, but [to_string] does not. *) type t = Stdlib.Printexc.raw_backtrace [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] val get : ?at_most_num_frames:int -> unit -> t val to_string : t -> string val to_string_list : t -> string list (** The value of [elide] controls the behavior of backtrace serialization functions such as {!to_string}, {!to_string_list}, and {!sexp_of_t}. When set to [false], these functions behave as expected, returning a faithful representation of their argument. When set to [true], these functions will ignore their argument and return a message indicating that behavior. The default value is [false]. *) val elide : bool ref (** [Backtrace.Exn] has functions for controlling and printing the backtrace of the most recently raised exception. When an exception is raised, the runtime "unwinds" the stack, i.e., removes stack frames, until it reaches a frame with an exception handler. It then matches the exception against the patterns in the handler. If the exception matches, then the program continues. If not, then the runtime continues unwinding the stack to the next handler. If [am_recording () = true], then while the runtime is unwinding the stack, it keeps track of the part of the stack that is unwound. This is available as a backtrace via [most_recent ()]. Calling [most_recent] if [am_recording () = false] will yield the empty backtrace. With [am_recording () = true], OCaml keeps only a backtrace for the most recently raised exception. When one raises an exception, OCaml checks if it is physically equal to the most recently raised exception. If it is, then OCaml appends the string representation of the stack unwound by the current raise to the stored backtrace. If the exception being raised is not physically equally to the most recently raised exception, then OCaml starts recording a new backtrace. Thus one must call [most_recent] before a subsequent [raise] of a (physically) distinct exception, or the backtrace is lost. The initial value of [am_recording ()] is determined by the environment variable OCAMLRUNPARAM. If OCAMLRUNPARAM is set and contains a "b" parameter, then [am_recording ()] is set according to OCAMLRUNPARAM: true if "b" or "b=1" appears; false if "b=0" appears. If OCAMLRUNPARAM is not set (as is always the case when running in a web browser) or does not contain a "b" parameter, then [am_recording ()] is initially true. This is the same functionality as provided by the OCaml stdlib [Printexc] functions [backtrace_status], [record_backtraces], [get_backtrace]. *) module Exn : sig val am_recording : unit -> bool val set_recording : bool -> unit val with_recording : bool -> f:((unit -> 'a)[@local]) -> 'a (** [most_recent ()] returns a backtrace containing the stack that was unwound by the most recently raised exception. Normally this includes just the function calls that lead from the exception handler being set up to the exception being raised. However, due to inlining, the stack frame that has the exception handler may correspond to a chain of multiple function calls. All of those function calls are then reported in this backtrace, even though they are not themselves on the path from the exception handler to the "raise". *) val most_recent : unit -> t (** [most_recent_for_exn exn] returns a backtrace containing the stack that was unwound when raising [exn] if [exn] is the most recently raised exception. Otherwise it returns [None]. Note that this may return a misleading backtrace instead of [None] if different raise events happen to raise physically equal exceptions. Consider the example below. Here if [e = Not_found] and [g] usees [Not_found] internally then the backtrace will correspond to the internal backtrace in [g] instead of the one used in [f], which is not desirable. {[ try f () with | e -> g (); let bt = Backtrace.Exn.most_recent_for_exn e in ... ]} *) val most_recent_for_exn : Exn.t -> t option end (** User code never calls this. It is called only in [base.ml], as a top-level side effect, to initialize [am_recording ()] as specified above. *) val initialize_module : unit -> unit base-0.16.3/src/base.ml000066400000000000000000000511001446274340700145560ustar00rootroot00000000000000(** This module is the toplevel of the Base library; it's what you get when you write [open Base]. The goal of Base is both to be a more complete standard library, with richer APIs, and to be more consistent in its design. For instance, in the standard library some things have modules and others don't; in Base, everything is a module. Base extends some modules and data structures from the standard library, like [Array], [Buffer], [Bytes], [Char], [Hashtbl], [Int32], [Int64], [Lazy], [List], [Map], [Nativeint], [Printf], [Random], [Set], [String], [Sys], and [Uchar]. One key difference is that Base doesn't use exceptions as much as the standard library and instead makes heavy use of the [Result] type, as in: {[ type ('a,'b) result = Ok of 'a | Error of 'b ]} Base also adds entirely new modules, most notably: - [Comparable], [Comparator], and [Comparisons] in lieu of polymorphic compare. - [Container], which provides a consistent interface across container-like data structures (arrays, lists, strings). - [Result], [Error], and [Or_error], supporting the or-error pattern. *) (*_ We hide this from the web docs because the line wrapping is bad, making it pretty much inscrutable. *) (**/**) (* The intent is to shadow all of INRIA's standard library. Modules below would cause compilation errors without being removed from [Shadow_stdlib] before inclusion. *) include ( Shadow_stdlib : module type of struct include Shadow_stdlib end (* Modules defined in Base *) with module Array := Shadow_stdlib.Array with module Atomic := Shadow_stdlib.Atomic with module Bool := Shadow_stdlib.Bool with module Buffer := Shadow_stdlib.Buffer with module Bytes := Shadow_stdlib.Bytes with module Char := Shadow_stdlib.Char with module Either := Shadow_stdlib.Either with module Float := Shadow_stdlib.Float with module Hashtbl := Shadow_stdlib.Hashtbl with module In_channel := Shadow_stdlib.In_channel with module Int := Shadow_stdlib.Int with module Int32 := Shadow_stdlib.Int32 with module Int64 := Shadow_stdlib.Int64 with module Lazy := Shadow_stdlib.Lazy with module List := Shadow_stdlib.List with module Map := Shadow_stdlib.Map with module Nativeint := Shadow_stdlib.Nativeint with module Option := Shadow_stdlib.Option with module Out_channel := Shadow_stdlib.Out_channel with module Printf := Shadow_stdlib.Printf with module Queue := Shadow_stdlib.Queue with module Random := Shadow_stdlib.Random with module Result := Shadow_stdlib.Result with module Set := Shadow_stdlib.Set with module Stack := Shadow_stdlib.Stack with module String := Shadow_stdlib.String with module Sys := Shadow_stdlib.Sys with module Uchar := Shadow_stdlib.Uchar with module Unit := Shadow_stdlib.Unit (* Support for generated lexers *) with module Lexing := Shadow_stdlib.Lexing with type ('a, 'b, 'c) format := ('a, 'b, 'c) format with type ('a, 'b, 'c, 'd) format4 := ('a, 'b, 'c, 'd) format4 with type ('a, 'b, 'c, 'd, 'e, 'f) format6 := ('a, 'b, 'c, 'd, 'e, 'f) format6 with type 'a ref := 'a ref) [@ocaml.warning "-3"] (**/**) open! Import module Applicative = Applicative module Array = Array module Avltree = Avltree module Backtrace = Backtrace module Binary_search = Binary_search module Binary_searchable = Binary_searchable module Blit = Blit module Bool = Bool module Buffer = Buffer module Bytes = Bytes module Char = Char module Comparable = Comparable module Comparator = Comparator module Comparisons = Comparisons module Container = Container module Either = Either module Equal = Equal module Error = Error module Exn = Exn module Field = Field module Float = Float module Floatable = Floatable module Fn = Fn module Formatter = Formatter module Hash = Hash module Hash_set = Hash_set module Hashable = Hashable module Hasher = Hasher module Hashtbl = Hashtbl module Identifiable = Identifiable module Indexed_container = Indexed_container module Info = Info module Int = Int module Int_conversions = Int_conversions module Int32 = Int32 module Int63 = Int63 module Int64 = Int64 module Intable = Intable module Int_math = Int_math module Invariant = Invariant module Lazy = Lazy module List = List module Map = Map module Maybe_bound = Maybe_bound module Monad = Monad module Nativeint = Nativeint module Nothing = Nothing module Option = Option module Option_array = Option_array module Or_error = Or_error module Ordered_collection_common = Ordered_collection_common module Ordering = Ordering module Poly = Poly module Popcount = Popcount [@@deprecated "[since 2018-10] use [popcount] functions in the individual int modules"] module Pretty_printer = Pretty_printer module Printf = Printf module Linked_queue = Linked_queue module Queue = Queue module Random = Random module Ref = Ref module Result = Result module Sequence = Sequence module Set = Set module Sexpable = Sexpable module Sign = Sign module Sign_or_nan = Sign_or_nan module Source_code_position = Source_code_position module Stack = Stack module Staged = Staged module String = String module Stringable = Stringable module Sys = Sys module T = T module Type_equal = Type_equal module Uniform_array = Uniform_array module Unit = Unit module Uchar = Uchar module Variant = Variant module With_return = With_return module Word_size = Word_size (* Avoid a level of indirection for uses of the signatures defined in [T]. *) include T (* This is a hack so that odoc creates better documentation. *) module Sexp = struct include Sexp_with_comparable (** @inline *) end (**/**) module Exported_for_specific_uses = struct module Fieldslib = Fieldslib module Globalize = Globalize module Obj_local = Obj_local module Ppx_compare_lib = Ppx_compare_lib module Ppx_enumerate_lib = Ppx_enumerate_lib module Ppx_hash_lib = Ppx_hash_lib module Variantslib = Variantslib let am_testing = am_testing end (**/**) module Export = struct (* [deriving hash] is missing for [array] and [ref] since these types are mutable. *) type 'a array = 'a Array.t [@@deriving_inline compare, equal, globalize, sexp, sexp_grammar] let compare_array : 'a. ('a -> 'a -> int) -> 'a array -> 'a array -> int = Array.compare let equal_array : 'a. ('a -> 'a -> bool) -> 'a array -> 'a array -> bool = Array.equal let globalize_array : 'a. (('a[@ocaml.local]) -> 'a) -> ('a array[@ocaml.local]) -> 'a array = fun (type a__009_) : (((a__009_[@ocaml.local]) -> a__009_) -> (a__009_ array[@ocaml.local]) -> a__009_ array) -> Array.globalize ;; let array_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a array = Array.t_of_sexp ;; let sexp_of_array : 'a. ('a -> Sexplib0.Sexp.t) -> 'a array -> Sexplib0.Sexp.t = Array.sexp_of_t ;; let array_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a array Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> Array.t_sexp_grammar _'a_sexp_grammar ;; [@@@end] type bool = Bool.t [@@deriving_inline compare, equal, globalize, hash, sexp, sexp_grammar] let compare_bool = (Bool.compare : bool -> bool -> int) let equal_bool = (Bool.equal : bool -> bool -> bool) let (globalize_bool : (bool[@ocaml.local]) -> bool) = (Bool.globalize : (bool[@ocaml.local]) -> bool) ;; let (hash_fold_bool : Ppx_hash_lib.Std.Hash.state -> bool -> Ppx_hash_lib.Std.Hash.state) = Bool.hash_fold_t and (hash_bool : bool -> Ppx_hash_lib.Std.Hash.hash_value) = let func = Bool.hash in fun x -> func x ;; let bool_of_sexp = (Bool.t_of_sexp : Sexplib0.Sexp.t -> bool) let sexp_of_bool = (Bool.sexp_of_t : bool -> Sexplib0.Sexp.t) let (bool_sexp_grammar : bool Sexplib0.Sexp_grammar.t) = Bool.t_sexp_grammar [@@@end] type char = Char.t [@@deriving_inline compare, equal, globalize, hash, sexp, sexp_grammar] let compare_char = (Char.compare : char -> char -> int) let equal_char = (Char.equal : char -> char -> bool) let (globalize_char : (char[@ocaml.local]) -> char) = (Char.globalize : (char[@ocaml.local]) -> char) ;; let (hash_fold_char : Ppx_hash_lib.Std.Hash.state -> char -> Ppx_hash_lib.Std.Hash.state) = Char.hash_fold_t and (hash_char : char -> Ppx_hash_lib.Std.Hash.hash_value) = let func = Char.hash in fun x -> func x ;; let char_of_sexp = (Char.t_of_sexp : Sexplib0.Sexp.t -> char) let sexp_of_char = (Char.sexp_of_t : char -> Sexplib0.Sexp.t) let (char_sexp_grammar : char Sexplib0.Sexp_grammar.t) = Char.t_sexp_grammar [@@@end] type exn = Exn.t [@@deriving_inline sexp_of] let sexp_of_exn = (Exn.sexp_of_t : exn -> Sexplib0.Sexp.t) [@@@end] type float = Float.t [@@deriving_inline compare, equal, globalize, hash, sexp, sexp_grammar] let compare_float = (Float.compare : float -> float -> int) let equal_float = (Float.equal : float -> float -> bool) let (globalize_float : (float[@ocaml.local]) -> float) = (Float.globalize : (float[@ocaml.local]) -> float) ;; let (hash_fold_float : Ppx_hash_lib.Std.Hash.state -> float -> Ppx_hash_lib.Std.Hash.state) = Float.hash_fold_t and (hash_float : float -> Ppx_hash_lib.Std.Hash.hash_value) = let func = Float.hash in fun x -> func x ;; let float_of_sexp = (Float.t_of_sexp : Sexplib0.Sexp.t -> float) let sexp_of_float = (Float.sexp_of_t : float -> Sexplib0.Sexp.t) let (float_sexp_grammar : float Sexplib0.Sexp_grammar.t) = Float.t_sexp_grammar [@@@end] type int = Int.t [@@deriving_inline compare, equal, globalize, hash, sexp, sexp_grammar] let compare_int = (Int.compare : int -> int -> int) let equal_int = (Int.equal : int -> int -> bool) let (globalize_int : (int[@ocaml.local]) -> int) = (Int.globalize : (int[@ocaml.local]) -> int) ;; let (hash_fold_int : Ppx_hash_lib.Std.Hash.state -> int -> Ppx_hash_lib.Std.Hash.state) = Int.hash_fold_t and (hash_int : int -> Ppx_hash_lib.Std.Hash.hash_value) = let func = Int.hash in fun x -> func x ;; let int_of_sexp = (Int.t_of_sexp : Sexplib0.Sexp.t -> int) let sexp_of_int = (Int.sexp_of_t : int -> Sexplib0.Sexp.t) let (int_sexp_grammar : int Sexplib0.Sexp_grammar.t) = Int.t_sexp_grammar [@@@end] type int32 = Int32.t [@@deriving_inline compare, equal, globalize, hash, sexp, sexp_grammar] let compare_int32 = (Int32.compare : int32 -> int32 -> int) let equal_int32 = (Int32.equal : int32 -> int32 -> bool) let (globalize_int32 : (int32[@ocaml.local]) -> int32) = (Int32.globalize : (int32[@ocaml.local]) -> int32) ;; let (hash_fold_int32 : Ppx_hash_lib.Std.Hash.state -> int32 -> Ppx_hash_lib.Std.Hash.state) = Int32.hash_fold_t and (hash_int32 : int32 -> Ppx_hash_lib.Std.Hash.hash_value) = let func = Int32.hash in fun x -> func x ;; let int32_of_sexp = (Int32.t_of_sexp : Sexplib0.Sexp.t -> int32) let sexp_of_int32 = (Int32.sexp_of_t : int32 -> Sexplib0.Sexp.t) let (int32_sexp_grammar : int32 Sexplib0.Sexp_grammar.t) = Int32.t_sexp_grammar [@@@end] type int64 = Int64.t [@@deriving_inline compare, equal, globalize, hash, sexp, sexp_grammar] let compare_int64 = (Int64.compare : int64 -> int64 -> int) let equal_int64 = (Int64.equal : int64 -> int64 -> bool) let (globalize_int64 : (int64[@ocaml.local]) -> int64) = (Int64.globalize : (int64[@ocaml.local]) -> int64) ;; let (hash_fold_int64 : Ppx_hash_lib.Std.Hash.state -> int64 -> Ppx_hash_lib.Std.Hash.state) = Int64.hash_fold_t and (hash_int64 : int64 -> Ppx_hash_lib.Std.Hash.hash_value) = let func = Int64.hash in fun x -> func x ;; let int64_of_sexp = (Int64.t_of_sexp : Sexplib0.Sexp.t -> int64) let sexp_of_int64 = (Int64.sexp_of_t : int64 -> Sexplib0.Sexp.t) let (int64_sexp_grammar : int64 Sexplib0.Sexp_grammar.t) = Int64.t_sexp_grammar [@@@end] type 'a list = 'a List.t [@@deriving_inline compare, equal, globalize, hash, sexp, sexp_grammar] let compare_list : 'a. ('a -> 'a -> int) -> 'a list -> 'a list -> int = List.compare let equal_list : 'a. ('a -> 'a -> bool) -> 'a list -> 'a list -> bool = List.equal let globalize_list : 'a. (('a[@ocaml.local]) -> 'a) -> ('a list[@ocaml.local]) -> 'a list = fun (type a__062_) : (((a__062_[@ocaml.local]) -> a__062_) -> (a__062_ list[@ocaml.local]) -> a__062_ list) -> List.globalize ;; let hash_fold_list : 'a. (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) -> Ppx_hash_lib.Std.Hash.state -> 'a list -> Ppx_hash_lib.Std.Hash.state = List.hash_fold_t ;; let list_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a list = List.t_of_sexp ;; let sexp_of_list : 'a. ('a -> Sexplib0.Sexp.t) -> 'a list -> Sexplib0.Sexp.t = List.sexp_of_t ;; let list_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a list Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> List.t_sexp_grammar _'a_sexp_grammar ;; [@@@end] type nativeint = Nativeint.t [@@deriving_inline compare, equal, globalize, hash, sexp, sexp_grammar] let compare_nativeint = (Nativeint.compare : nativeint -> nativeint -> int) let equal_nativeint = (Nativeint.equal : nativeint -> nativeint -> bool) let (globalize_nativeint : (nativeint[@ocaml.local]) -> nativeint) = (Nativeint.globalize : (nativeint[@ocaml.local]) -> nativeint) ;; let (hash_fold_nativeint : Ppx_hash_lib.Std.Hash.state -> nativeint -> Ppx_hash_lib.Std.Hash.state) = Nativeint.hash_fold_t and (hash_nativeint : nativeint -> Ppx_hash_lib.Std.Hash.hash_value) = let func = Nativeint.hash in fun x -> func x ;; let nativeint_of_sexp = (Nativeint.t_of_sexp : Sexplib0.Sexp.t -> nativeint) let sexp_of_nativeint = (Nativeint.sexp_of_t : nativeint -> Sexplib0.Sexp.t) let (nativeint_sexp_grammar : nativeint Sexplib0.Sexp_grammar.t) = Nativeint.t_sexp_grammar ;; [@@@end] type 'a option = 'a Option.t [@@deriving_inline compare, equal, globalize, hash, sexp, sexp_grammar] let compare_option : 'a. ('a -> 'a -> int) -> 'a option -> 'a option -> int = Option.compare ;; let equal_option : 'a. ('a -> 'a -> bool) -> 'a option -> 'a option -> bool = Option.equal ;; let globalize_option : 'a. (('a[@ocaml.local]) -> 'a) -> ('a option[@ocaml.local]) -> 'a option = fun (type a__085_) : (((a__085_[@ocaml.local]) -> a__085_) -> (a__085_ option[@ocaml.local]) -> a__085_ option) -> Option.globalize ;; let hash_fold_option : 'a. (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) -> Ppx_hash_lib.Std.Hash.state -> 'a option -> Ppx_hash_lib.Std.Hash.state = Option.hash_fold_t ;; let option_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a option = Option.t_of_sexp ;; let sexp_of_option : 'a. ('a -> Sexplib0.Sexp.t) -> 'a option -> Sexplib0.Sexp.t = Option.sexp_of_t ;; let option_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a option Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> Option.t_sexp_grammar _'a_sexp_grammar ;; [@@@end] type 'a ref = 'a Ref.t [@@deriving_inline compare, equal, globalize, sexp, sexp_grammar] let compare_ref : 'a. ('a -> 'a -> int) -> 'a ref -> 'a ref -> int = Ref.compare let equal_ref : 'a. ('a -> 'a -> bool) -> 'a ref -> 'a ref -> bool = Ref.equal let globalize_ref : 'a. (('a[@ocaml.local]) -> 'a) -> ('a ref[@ocaml.local]) -> 'a ref = fun (type a__102_) : (((a__102_[@ocaml.local]) -> a__102_) -> (a__102_ ref[@ocaml.local]) -> a__102_ ref) -> Ref.globalize ;; let ref_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a ref = Ref.t_of_sexp ;; let sexp_of_ref : 'a. ('a -> Sexplib0.Sexp.t) -> 'a ref -> Sexplib0.Sexp.t = Ref.sexp_of_t ;; let ref_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a ref Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> Ref.t_sexp_grammar _'a_sexp_grammar ;; [@@@end] type string = String.t [@@deriving_inline compare, equal, globalize, hash, sexp, sexp_grammar] let compare_string = (String.compare : string -> string -> int) let equal_string = (String.equal : string -> string -> bool) let (globalize_string : (string[@ocaml.local]) -> string) = (String.globalize : (string[@ocaml.local]) -> string) ;; let (hash_fold_string : Ppx_hash_lib.Std.Hash.state -> string -> Ppx_hash_lib.Std.Hash.state) = String.hash_fold_t and (hash_string : string -> Ppx_hash_lib.Std.Hash.hash_value) = let func = String.hash in fun x -> func x ;; let string_of_sexp = (String.t_of_sexp : Sexplib0.Sexp.t -> string) let sexp_of_string = (String.sexp_of_t : string -> Sexplib0.Sexp.t) let (string_sexp_grammar : string Sexplib0.Sexp_grammar.t) = String.t_sexp_grammar [@@@end] type bytes = Bytes.t [@@deriving_inline compare, equal, globalize, sexp, sexp_grammar] let compare_bytes = (Bytes.compare : bytes -> bytes -> int) let equal_bytes = (Bytes.equal : bytes -> bytes -> bool) let (globalize_bytes : (bytes[@ocaml.local]) -> bytes) = (Bytes.globalize : (bytes[@ocaml.local]) -> bytes) ;; let bytes_of_sexp = (Bytes.t_of_sexp : Sexplib0.Sexp.t -> bytes) let sexp_of_bytes = (Bytes.sexp_of_t : bytes -> Sexplib0.Sexp.t) let (bytes_sexp_grammar : bytes Sexplib0.Sexp_grammar.t) = Bytes.t_sexp_grammar [@@@end] type unit = Unit.t [@@deriving_inline compare, equal, globalize, hash, sexp, sexp_grammar] let compare_unit = (Unit.compare : unit -> unit -> int) let equal_unit = (Unit.equal : unit -> unit -> bool) let (globalize_unit : (unit[@ocaml.local]) -> unit) = (Unit.globalize : (unit[@ocaml.local]) -> unit) ;; let (hash_fold_unit : Ppx_hash_lib.Std.Hash.state -> unit -> Ppx_hash_lib.Std.Hash.state) = Unit.hash_fold_t and (hash_unit : unit -> Ppx_hash_lib.Std.Hash.hash_value) = let func = Unit.hash in fun x -> func x ;; let unit_of_sexp = (Unit.t_of_sexp : Sexplib0.Sexp.t -> unit) let sexp_of_unit = (Unit.sexp_of_t : unit -> Sexplib0.Sexp.t) let (unit_sexp_grammar : unit Sexplib0.Sexp_grammar.t) = Unit.t_sexp_grammar [@@@end] (** Format stuff *) type nonrec ('a, 'b, 'c) format = ('a, 'b, 'c) format type nonrec ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'd) format4 type nonrec ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) format6 (** List operators *) include List.Infix (** Int operators and comparisons *) include Int.O include Int_replace_polymorphic_compare (** Float operators *) include Float.O_dot (* This is declared as an external to be optimized away in more contexts. *) (** Reverse application operator. [x |> g |> f] is equivalent to [f (g (x))]. *) external ( |> ) : 'a -> (('a -> 'b)[@local_opt]) -> 'b = "%revapply" (** Application operator. [g @@ f @@ x] is equivalent to [g (f (x))]. *) external ( @@ ) : (('a -> 'b)[@local_opt]) -> 'a -> 'b = "%apply" (** Boolean operations *) (* These need to be declared as an external to get the lazy behavior *) external ( && ) : (bool[@local_opt]) -> (bool[@local_opt]) -> bool = "%sequand" external ( || ) : (bool[@local_opt]) -> (bool[@local_opt]) -> bool = "%sequor" external not : (bool[@local_opt]) -> bool = "%boolnot" (* This must be declared as an external for the warnings to work properly. *) external ignore : (_[@local_opt]) -> unit = "%ignore" (** Common string operations *) let ( ^ ) = String.( ^ ) (** Reference operations *) (* Declared as an externals so that the compiler skips the caml_modify when possible and to keep reference unboxing working *) external ( ! ) : ('a ref[@local_opt]) -> 'a = "%field0" external ref : 'a -> ('a ref[@local_opt]) = "%makemutable" external ( := ) : ('a ref[@local_opt]) -> 'a -> unit = "%setfield0" (** Pair operations *) let fst = fst let snd = snd (** Exceptions stuff *) (* Declared as an external so that the compiler may rewrite '%raise' as '%reraise'. *) external raise : exn -> _ = "%raise" let failwith = failwith let invalid_arg = invalid_arg let raise_s = Error.raise_s (** Misc *) external phys_equal : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%eq" external force : ('a Lazy.t[@local_opt]) -> 'a = "%lazy_force" end include Export include Container_intf.Export (** @inline *) exception Not_found_s = Not_found_s (* We perform these side effects here because we want them to run for any code that uses [Base]. If this were in another module in [Base] that was not used in some program, then the side effects might not be run in that program. This will run as long as the program refers to at least one value directly in [Base]; referring to values in [Base.Bool], for example, is not sufficient. *) let () = Backtrace.initialize_module () base-0.16.3/src/binary_search.ml000066400000000000000000000105611446274340700164630ustar00rootroot00000000000000open! Import (* These functions implement a search for the first (resp. last) element satisfying a predicate, assuming that the predicate is increasing on the container, meaning that, if the container is [u1...un], there exists a k such that p(u1)=....=p(uk) = false and p(uk+1)=....=p(un)= true. If this k = 1 (resp n), find_last_not_satisfying (resp find_first_satisfying) will return None. *) let rec linear_search_first_satisfying t ~get ~lo ~hi ~pred = if lo > hi then None else if pred (get t lo) then Some lo else linear_search_first_satisfying t ~get ~lo:(lo + 1) ~hi ~pred ;; (* Takes a container [t], a predicate [pred] and two indices [lo < hi], such that [pred] is increasing on [t] between [lo] and [hi]. return a range (lo, hi) where: - lo and hi are close enough together for a linear search - If [pred] is not constantly [false] on [t] between [lo] and [hi], the first element on which [pred] is [true] is between [lo] and [hi]. *) (* Invariant: the first element satisfying [pred], if it exists is between [lo] and [hi] *) let rec find_range_near_first_satisfying t ~get ~lo ~hi ~pred = (* Warning: this function will not terminate if the constant (currently 8) is set <= 1 *) if hi - lo <= 8 then lo, hi else ( let mid = lo + ((hi - lo) / 2) in if pred (get t mid) (* INVARIANT check: it means the first satisfying element is between [lo] and [mid] *) then find_range_near_first_satisfying t ~get ~lo ~hi:mid ~pred (* INVARIANT check: it means the first satisfying element, if it exists, is between [mid+1] and [hi] *) else find_range_near_first_satisfying t ~get ~lo:(mid + 1) ~hi ~pred) ;; let find_first_satisfying ?pos ?len t ~get ~length ~pred = let pos, len = Ordered_collection_common.get_pos_len_exn () ?pos ?len ~total_length:(length t) in let lo = pos in let hi = pos + len - 1 in let lo, hi = find_range_near_first_satisfying t ~get ~lo ~hi ~pred in linear_search_first_satisfying t ~get ~lo ~hi ~pred ;; (* Takes an array with shape [true,...true,false,...false] (i.e., the _reverse_ of what is described above) and returns the index of the last true or None if there are no true*) let find_last_satisfying ?pos ?len t ~pred ~get ~length = let pos, len = Ordered_collection_common.get_pos_len_exn () ?pos ?len ~total_length:(length t) in if len = 0 then None else ( (* The last satisfying is the one just before the first not satisfying *) match find_first_satisfying ~pos ~len t ~get ~length ~pred:(fun x -> not (pred x)) with | None -> Some (pos + len - 1) (* This means that all elements satisfy pred. There is at least an element as (len > 0) *) | Some i when i = pos -> None (* no element satisfies pred *) | Some i -> Some (i - 1)) ;; let binary_search ?pos ?len t ~length:((length : _ -> _) [@local]) ~get:((get : _ -> _ -> _) [@local]) ~compare:((compare : _ -> _ -> _) [@local]) how v = match how with | `Last_strictly_less_than -> find_last_satisfying ?pos ?len t ~get ~length ~pred:(fun x -> compare x v < 0) [@nontail ] | `Last_less_than_or_equal_to -> find_last_satisfying ?pos ?len t ~get ~length ~pred:(fun x -> compare x v <= 0) [@nontail ] | `First_equal_to -> (match find_first_satisfying ?pos ?len t ~get ~length ~pred:(fun x -> compare x v >= 0) with | Some x when compare (get t x) v = 0 -> Some x | None | Some _ -> None) | `Last_equal_to -> (match find_last_satisfying ?pos ?len t ~get ~length ~pred:(fun x -> compare x v <= 0) with | Some x when compare (get t x) v = 0 -> Some x | None | Some _ -> None) | `First_greater_than_or_equal_to -> find_first_satisfying ?pos ?len t ~get ~length ~pred:(fun x -> compare x v >= 0) [@nontail ] | `First_strictly_greater_than -> find_first_satisfying ?pos ?len t ~get ~length ~pred:(fun x -> compare x v > 0) [@nontail ] ;; let binary_search_segmented ?pos ?len t ~length ~get ~segment_of how = let is_left x = match segment_of x with | `Left -> true | `Right -> false in let is_right x = not (is_left x) in match how with | `Last_on_left -> find_last_satisfying ?pos ?len t ~length ~get ~pred:is_left [@nontail] | `First_on_right -> find_first_satisfying ?pos ?len t ~length ~get ~pred:is_right [@nontail] ;; base-0.16.3/src/binary_search.mli000066400000000000000000000070301446274340700166310ustar00rootroot00000000000000(** Functions for performing binary searches over ordered sequences given [length] and [get] functions. These functions can be specialized and added to a data structure using the functors supplied in {{!Base.Binary_searchable}[Binary_searchable]} and described in {{!Base.Binary_searchable_intf}[Binary_searchable_intf]}. {2:examples Examples} Below we assume that the functions [get], [length] and [compare] are in scope: {[ (* Find the index of an element [e] in [t] *) binary_search t ~get ~length ~compare `First_equal_to e; (* Find the index where an element [e] should be inserted *) binary_search t ~get ~length ~compare `First_greater_than_or_equal_to e; (* Find the index in [t] where all elements to the left are less than [e] *) binary_search_segmented t ~get ~length ~segment_of:(fun e' -> if compare e' e <= 0 then `Left else `Right) `First_on_right ]} *) open! Import (** [binary_search ?pos ?len t ~length ~get ~compare which elt] takes [t] that is sorted in increasing order according to [compare], where [compare] and [elt] divide [t] into three (possibly empty) segments: {v | < elt | = elt | > elt | v} [binary_search] returns the index in [t] of an element on the boundary of segments as specified by [which]. See the diagram below next to the [which] variants. By default, [binary_search] searches the entire [t]. One can supply [?pos] or [?len] to search a slice of [t]. [binary_search] does not check that [compare] orders [t], and behavior is unspecified if [compare] doesn't order [t]. Behavior is also unspecified if [compare] mutates [t]. *) val binary_search : ?pos:int -> ?len:int -> 't -> length:(('t -> int)[@local]) -> get:(('t -> int -> 'elt)[@local]) -> compare:(('elt -> 'key -> int)[@local]) -> [ `Last_strictly_less_than (** {v | < elt X | v} *) | `Last_less_than_or_equal_to (** {v | <= elt X | v} *) | `Last_equal_to (** {v | = elt X | v} *) | `First_equal_to (** {v | X = elt | v} *) | `First_greater_than_or_equal_to (** {v | X >= elt | v} *) | `First_strictly_greater_than (** {v | X > elt | v} *) ] -> 'key -> int option (** [binary_search_segmented ?pos ?len t ~length ~get ~segment_of which] takes a [segment_of] function that divides [t] into two (possibly empty) segments: {v | segment_of elt = `Left | segment_of elt = `Right | v} [binary_search_segmented] returns the index of the element on the boundary of the segments as specified by [which]: [`Last_on_left] yields the index of the last element of the left segment, while [`First_on_right] yields the index of the first element of the right segment. It returns [None] if the segment is empty. By default, [binary_search] searches the entire [t]. One can supply [?pos] or [?len] to search a slice of [t]. [binary_search_segmented] does not check that [segment_of] segments [t] as in the diagram, and behavior is unspecified if [segment_of] doesn't segment [t]. Behavior is also unspecified if [segment_of] mutates [t]. *) val binary_search_segmented : ?pos:int -> ?len:int -> 't -> length:(('t -> int)[@local]) -> get:(('t -> int -> 'elt)[@local]) -> segment_of:(('elt -> [ `Left | `Right ])[@local]) -> [ `Last_on_left | `First_on_right ] -> int option base-0.16.3/src/binary_searchable.ml000066400000000000000000000014121446274340700173020ustar00rootroot00000000000000open! Import include Binary_searchable_intf module type Arg = sig type 'a elt type 'a t val get : 'a t -> int -> 'a elt val length : _ t -> int end module Make_gen (T : Arg) = struct let get = T.get let length = T.length let binary_search ?pos ?len t ~compare how v = Binary_search.binary_search ?pos ?len t ~get ~length ~compare how v ;; let binary_search_segmented ?pos ?len t ~segment_of how = Binary_search.binary_search_segmented ?pos ?len t ~get ~length ~segment_of how ;; end module Make (T : Indexable) = Make_gen (struct include T type 'a elt = T.elt type 'a t = T.t end) module Make1 (T : Indexable1) = Make_gen (struct type 'a elt = 'a type 'a t = 'a T.t let get = T.get let length = T.length end) base-0.16.3/src/binary_searchable.mli000066400000000000000000000001001446274340700174440ustar00rootroot00000000000000include Binary_searchable_intf.Binary_searchable (** @inline *) base-0.16.3/src/binary_searchable_intf.ml000066400000000000000000000056371446274340700203370ustar00rootroot00000000000000(** Module types for a [binary_search] function for a sequence, and functors for building [binary_search] functions. *) open! Import (** An [Indexable] type is a finite sequence of elements indexed by consecutive integers [0] ... [length t - 1]. [get] and [length] must be O(1) for the resulting [binary_search] to be lg(n). *) module type Indexable = sig type elt type t val get : t -> int -> elt val length : t -> int end module type Indexable1 = sig type 'a t val get : 'a t -> int -> 'a val length : _ t -> int end module Which_target_by_key = struct type t = [ `Last_strictly_less_than (** {v | < elt X | v} *) | `Last_less_than_or_equal_to (** {v | <= elt X | v} *) | `Last_equal_to (** {v | = elt X | v} *) | `First_equal_to (** {v | X = elt | v} *) | `First_greater_than_or_equal_to (** {v | X >= elt | v} *) | `First_strictly_greater_than (** {v | X > elt | v} *) ] [@@deriving_inline enumerate] let all = ([ `Last_strictly_less_than ; `Last_less_than_or_equal_to ; `Last_equal_to ; `First_equal_to ; `First_greater_than_or_equal_to ; `First_strictly_greater_than ] : t list) ;; [@@@end] end module Which_target_by_segment = struct type t = [ `Last_on_left | `First_on_right ] [@@deriving_inline enumerate] let all = ([ `Last_on_left; `First_on_right ] : t list) [@@@end] end type ('t, 'elt, 'key) binary_search = ?pos:int -> ?len:int -> 't -> compare:(('elt -> 'key -> int)[@local]) -> Which_target_by_key.t -> 'key -> int option type ('t, 'elt) binary_search_segmented = ?pos:int -> ?len:int -> 't -> segment_of:(('elt -> [ `Left | `Right ])[@local]) -> Which_target_by_segment.t -> int option module type S = sig type elt type t (** See [Binary_search.binary_search] in binary_search.ml *) val binary_search : (t, elt, 'key) binary_search (** See [Binary_search.binary_search_segmented] in binary_search.ml *) val binary_search_segmented : (t, elt) binary_search_segmented end module type S1 = sig type 'a t val binary_search : ('a t, 'a, 'key) binary_search val binary_search_segmented : ('a t, 'a) binary_search_segmented end module type Binary_searchable = sig module type S = S module type S1 = S1 module type Indexable = Indexable module type Indexable1 = Indexable1 module Which_target_by_key = Which_target_by_key module Which_target_by_segment = Which_target_by_segment type nonrec ('t, 'elt, 'key) binary_search = ('t, 'elt, 'key) binary_search type nonrec ('t, 'elt) binary_search_segmented = ('t, 'elt) binary_search_segmented module Make (T : Indexable) : S with type t := T.t with type elt := T.elt module Make1 (T : Indexable1) : S1 with type 'a t := 'a T.t end base-0.16.3/src/blit.ml000066400000000000000000000060251446274340700146040ustar00rootroot00000000000000open! Import include Blit_intf module type Sequence_gen = sig type 'a t val length : (_ t[@local]) -> int end module Make_gen (Src : Sequence_gen) (Dst : sig include Sequence_gen val create_like : len:int -> 'a Src.t -> 'a t val unsafe_blit : ('a Src.t, 'a t) blit end) = struct let unsafe_blit = Dst.unsafe_blit let blit ~src ~src_pos ~dst ~dst_pos ~len = Ordered_collection_common.check_pos_len_exn ~pos:src_pos ~len ~total_length:(Src.length src); Ordered_collection_common.check_pos_len_exn ~pos:dst_pos ~len ~total_length:(Dst.length dst); if len > 0 then unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len ;; let blito ~src ?(src_pos = 0) ?(src_len = Src.length src - src_pos) ~dst ?(dst_pos = 0) () = blit ~src ~src_pos ~len:src_len ~dst ~dst_pos ;; (* [sub] and [subo] ensure that every position of the created sequence is populated by an element of the source array. Thus every element of [dst] below is well defined. *) let sub src ~pos ~len = Ordered_collection_common.check_pos_len_exn ~pos ~len ~total_length:(Src.length src); let dst = Dst.create_like ~len src in if len > 0 then unsafe_blit ~src ~src_pos:pos ~dst ~dst_pos:0 ~len; dst ;; let subo ?(pos = 0) ?len src = sub src ~pos ~len: (match len with | Some i -> i | None -> Src.length src - pos) ;; end module Make1 (Sequence : sig include Sequence_gen val create_like : len:int -> 'a t -> 'a t val unsafe_blit : ('a t, 'a t) blit end) = Make_gen (Sequence) (Sequence) module Make1_generic (Sequence : Sequence1) = Make_gen (Sequence) (Sequence) module Make (Sequence : sig include Sequence val create : len:int -> t val unsafe_blit : (t, t) blit end) = struct module Sequence = struct type 'a t = Sequence.t open Sequence let create_like ~len _ = create ~len let length = length let unsafe_blit = unsafe_blit end include Make_gen (Sequence) (Sequence) end module Make_distinct (Src : Sequence) (Dst : sig include Sequence val create : len:int -> t val unsafe_blit : (Src.t, t) blit end) = Make_gen (struct type 'a t = Src.t open Src let length = length end) (struct type 'a t = Dst.t open Dst let length = length let create_like ~len _ = create ~len let unsafe_blit = unsafe_blit end) module Make_to_string (T : sig type t end) (To_bytes : S_distinct with type src := T.t with type dst := bytes) = struct open To_bytes let sub src ~pos ~len = Bytes0.unsafe_to_string ~no_mutation_while_string_reachable:(sub src ~pos ~len) ;; let subo ?pos ?len src = Bytes0.unsafe_to_string ~no_mutation_while_string_reachable:(subo ?pos ?len src) ;; end base-0.16.3/src/blit.mli000066400000000000000000000000461446274340700147520ustar00rootroot00000000000000include Blit_intf.Blit (** @inline *) base-0.16.3/src/blit_intf.ml000066400000000000000000000125701446274340700156260ustar00rootroot00000000000000(** Standard type for [blit] functions, and reusable code for validating [blit] arguments. *) open! Import (** If [blit : (src, dst) blit], then [blit ~src ~src_pos ~len ~dst ~dst_pos] blits [len] values from [src] starting at position [src_pos] to [dst] at position [dst_pos]. Furthermore, [blit] raises if [src_pos], [len], and [dst_pos] don't specify valid slices of [src] and [dst]. *) type ('src, 'dst) blit = src:('src[@local]) -> src_pos:int -> dst:('dst[@local]) -> dst_pos:int -> len:int -> unit (** [blito] is like [blit], except that the [src_pos], [src_len], and [dst_pos] are optional (hence the "o" in "blito"). Also, we use [src_len] rather than [len] as a reminder that if [src_len] isn't supplied, then the default is to take the slice running from [src_pos] to the end of [src]. *) type ('src, 'dst) blito = src:('src[@local]) -> ?src_pos:int (** default is [0] *) -> ?src_len:int (** default is [length src - src_pos] *) -> dst:('dst[@local]) -> ?dst_pos:int (** default is [0] *) -> unit -> unit (** If [sub : (src, dst) sub], then [sub ~src ~pos ~len] returns a sequence of type [dst] containing [len] characters of [src] starting at [pos]. [subo] is like [sub], except [pos] and [len] are optional. *) type ('src, 'dst) sub = 'src -> pos:int -> len:int -> 'dst type ('src, 'dst) subo = ?pos:int (** default is [0] *) -> ?len:int (** default is [length src - pos] *) -> 'src -> 'dst (*_ These are not implemented less-general-in-terms-of-more-general because odoc produces unreadable documentation in that case, with or without [inline] on [include]. *) module type S = sig type t val blit : (t, t) blit val blito : (t, t) blito val unsafe_blit : (t, t) blit val sub : (t, t) sub val subo : (t, t) subo end module type S1 = sig type 'a t val blit : ('a t, 'a t) blit val blito : ('a t, 'a t) blito val unsafe_blit : ('a t, 'a t) blit val sub : ('a t, 'a t) sub val subo : ('a t, 'a t) subo end module type S_distinct = sig type src type dst val blit : (src, dst) blit val blito : (src, dst) blito val unsafe_blit : (src, dst) blit val sub : (src, dst) sub val subo : (src, dst) subo end module type S1_distinct = sig type 'a src type 'a dst val blit : (_ src, _ dst) blit val blito : (_ src, _ dst) blito val unsafe_blit : (_ src, _ dst) blit val sub : (_ src, _ dst) sub val subo : (_ src, _ dst) subo end module type S_to_string = sig type t val sub : (t, string) sub val subo : (t, string) subo end (** Users of modules matching the blit signatures [S], [S1], and [S1_distinct] only need to understand the code above. The code below is only for those that need to implement modules that match those signatures. *) module type Sequence = sig type t val length : (t[@local]) -> int end type 'a poly = 'a module type Sequence1 = sig type 'a t (** [Make1*] guarantees to only call [create_like ~len t] with [len > 0] if [length t > 0]. *) val create_like : len:int -> 'a t -> 'a t val length : (_ t[@local]) -> int val unsafe_blit : ('a t, 'a t) blit end module type Blit = sig type nonrec ('src, 'dst) blit = ('src, 'dst) blit type nonrec ('src, 'dst) blito = ('src, 'dst) blito type nonrec ('src, 'dst) sub = ('src, 'dst) sub type nonrec ('src, 'dst) subo = ('src, 'dst) subo module type S = S module type S1 = S1 module type S_distinct = S_distinct module type S1_distinct = S1_distinct module type S_to_string = S_to_string module type Sequence = Sequence module type Sequence1 = Sequence1 (** There are various [Make*] functors that turn an [unsafe_blit] function into a [blit] function. The functors differ in whether the sequence type is monomorphic or polymorphic, and whether the src and dst types are distinct or are the same. The blit functions make sure the slices are valid and then call [unsafe_blit]. They guarantee at a call [unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len] that: {[ len > 0 && src_pos >= 0 && src_pos + len <= get_src_len src && dst_pos >= 0 && dst_pos + len <= get_dst_len dst ]} The [Make*] functors also automatically create unit tests. *) (** [Make] is for blitting between two values of the same monomorphic type. *) module Make (Sequence : sig include Sequence val create : len:int -> t val unsafe_blit : (t, t) blit end) : S with type t := Sequence.t (** [Make_distinct] is for blitting between values of distinct monomorphic types. *) module Make_distinct (Src : Sequence) (Dst : sig include Sequence val create : len:int -> t val unsafe_blit : (Src.t, t) blit end) : S_distinct with type src := Src.t with type dst := Dst.t module Make_to_string (T : sig type t end) (To_bytes : S_distinct with type src := T.t with type dst := bytes) : S_to_string with type t := T.t (** [Make1] is for blitting between two values of the same polymorphic type. *) module Make1 (Sequence : Sequence1) : S1 with type 'a t := 'a Sequence.t (** [Make1_generic] is for blitting between two values of the same container type that's not fully polymorphic (in the sense of Container.Generic). *) module Make1_generic (Sequence : Sequence1) : S1 with type 'a t := 'a Sequence.t end base-0.16.3/src/bool.ml000066400000000000000000000055561446274340700146150ustar00rootroot00000000000000open! Import include Bool0 let invalid_argf = Printf.invalid_argf module T = struct type t = bool [@@deriving_inline compare, enumerate, globalize, hash, sexp, sexp_grammar] let compare = (compare_bool : t -> t -> int) let all = ([ false; true ] : t list) let (globalize : (t[@ocaml.local]) -> t) = (globalize_bool : (t[@ocaml.local]) -> t) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = hash_fold_bool and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = hash_bool in fun x -> func x ;; let t_of_sexp = (bool_of_sexp : Sexplib0.Sexp.t -> t) let sexp_of_t = (sexp_of_bool : t -> Sexplib0.Sexp.t) let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = bool_sexp_grammar [@@@end] let hashable : t Hashable.t = { hash; compare; sexp_of_t } let of_string = function | "true" -> true | "false" -> false | s -> invalid_argf "Bool.of_string: expected true or false but got %s" s () ;; let to_string = Stdlib.string_of_bool end include T include Comparator.Make (T) include Pretty_printer.Register (struct type nonrec t = t let to_string = to_string let module_name = "Base.Bool" end) (* Open replace_polymorphic_compare after including functor instantiations so they do not shadow its definitions. This is here so that efficient versions of the comparison functions are available within this module. *) open! Bool_replace_polymorphic_compare let invariant (_ : t) = () let between t ~low ~high = low <= t && t <= high let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max let clamp_exn t ~min ~max = assert (min <= max); clamp_unchecked t ~min ~max ;; let clamp t ~min ~max = if min > max then Or_error.error_s (Sexp.message "clamp requires [min <= max]" [ "min", T.sexp_of_t min; "max", T.sexp_of_t max ]) else Ok (clamp_unchecked t ~min ~max) ;; let to_int x = bool_to_int x module Non_short_circuiting = struct (* We don't expose this, since we don't want to break the invariant mentioned below of (to_int true = 1) and (to_int false = 0). *) let unsafe_of_int (x : int) : bool = Stdlib.Obj.magic x let ( || ) a b = unsafe_of_int (to_int a lor to_int b) let ( && ) a b = unsafe_of_int (to_int a land to_int b) end (* We do this as a direct assert on the theory that it's a cheap thing to test and a really core invariant that we never expect to break, and we should be happy for a program to fail immediately if this is violated. *) let () = assert (Poly.( = ) (to_int true) 1 && Poly.( = ) (to_int false) 0) (* Include type-specific [Replace_polymorphic_compare] at the end, after including functor application that could shadow its definitions. This is here so that efficient versions of the comparison functions are exported by this module. *) include Bool_replace_polymorphic_compare base-0.16.3/src/bool.mli000066400000000000000000000021071446274340700147530ustar00rootroot00000000000000(** Boolean type extended to be enumerable, hashable, sexpable, comparable, and stringable. *) open! Import type t = bool [@@deriving_inline enumerate, globalize, sexp, sexp_grammar] include Ppx_enumerate_lib.Enumerable.S with type t := t val globalize : (t[@ocaml.local]) -> t include Sexplib0.Sexpable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] include Identifiable.S with type t := t include Invariant.S with type t := t (** - [to_int true = 1] - [to_int false = 0] *) val to_int : t -> int external select : bool -> ('a[@local_opt]) -> ('a[@local_opt]) -> ('a[@local_opt]) = "caml_csel_value" [@@noalloc] [@@no_effects] [@@no_coeffects] [@@builtin] module Non_short_circuiting : sig (** Non-short circuiting and branch-free boolean operators. The default versions of these infix operators are short circuiting, which requires branching instructions to implement. The operators below are instead branch-free, and therefore not short-circuiting. *) val ( && ) : t -> t -> t val ( || ) : t -> t -> t end base-0.16.3/src/bool0.ml000066400000000000000000000002521446274340700146610ustar00rootroot00000000000000external select : bool -> ('a[@local_opt]) -> ('a[@local_opt]) -> ('a[@local_opt]) = "caml_csel_value" [@@noalloc] [@@no_effects] [@@no_coeffects] [@@builtin] base-0.16.3/src/bool0.mli000066400000000000000000000002521446274340700150320ustar00rootroot00000000000000external select : bool -> ('a[@local_opt]) -> ('a[@local_opt]) -> ('a[@local_opt]) = "caml_csel_value" [@@noalloc] [@@no_effects] [@@no_coeffects] [@@builtin] base-0.16.3/src/buffer.ml000066400000000000000000000017661446274340700151320ustar00rootroot00000000000000open! Import include Buffer_intf include Stdlib.Buffer let contents_bytes = to_bytes let add_substring t s ~pos ~len = add_substring t s pos len let add_subbytes t s ~pos ~len = add_subbytes t s pos len let sexp_of_t t = sexp_of_string (contents t) let caml_buffer_length = (Stdlib.Obj.magic (Stdlib.Buffer.length : t -> int) : (t[@local]) -> int) ;; let caml_buffer_blit = (Stdlib.Obj.magic (Stdlib.Buffer.blit : Stdlib.Buffer.t -> int -> Bytes.t -> int -> int -> unit) : (Stdlib.Buffer.t[@local]) -> int -> (Bytes.t[@local]) -> int -> int -> unit) ;; module To_bytes = Blit.Make_distinct (struct type nonrec t = t let length = caml_buffer_length end) (struct type t = Bytes.t let create ~len = Bytes.create len let length = Bytes.length let unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len = caml_buffer_blit src src_pos dst dst_pos len ;; end) include To_bytes module To_string = Blit.Make_to_string (Stdlib.Buffer) (To_bytes) base-0.16.3/src/buffer.mli000066400000000000000000000004701446274340700152720ustar00rootroot00000000000000(** Extensible character buffers. This module implements character buffers that automatically expand as necessary. It provides cumulative concatenation of strings in quasi-linear time (instead of quadratic time when strings are concatenated pairwise). *) include Buffer_intf.Buffer (** @inline *) base-0.16.3/src/buffer_intf.ml000066400000000000000000000063361446274340700161500ustar00rootroot00000000000000open! Import module type S = sig (** The abstract type of buffers. *) type t [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] (** [create n] returns a fresh buffer, initially empty. The [n] parameter is the initial size of the internal storage medium that holds the buffer contents. That storage is automatically reallocated when more than [n] characters are stored in the buffer, but shrinks back to [n] characters when [reset] is called. For best performance, [n] should be of the same order of magnitude as the number of characters that are expected to be stored in the buffer (for instance, 80 for a buffer that holds one output line). Nothing bad will happen if the buffer grows beyond that limit, however. In doubt, take [n = 16] for instance. *) val create : int -> t (** Return a copy of the current contents of the buffer. The buffer itself is unchanged. *) val contents : t -> string val contents_bytes : t -> bytes (** [blit ~src ~src_pos ~dst ~dst_pos ~len] copies [len] characters from the current contents of the buffer [src], starting at offset [src_pos] to bytes [dst], starting at character [dst_pos]. Raises [Invalid_argument] if [src_pos] and [len] do not designate a valid substring of [src], or if [dst_pos] and [len] do not designate a valid substring of [dst]. *) include Blit.S_distinct with type src := t with type dst := bytes module To_string : Blit.S_to_string with type t := t (** Gets the (zero-based) n-th character of the buffer. Raises [Invalid_argument] if index out of bounds. *) val nth : t -> int -> char (** Returns the number of characters currently contained in the buffer. *) val length : t -> int (** Empties the buffer. *) val clear : t -> unit (** Empties the buffer and deallocates the internal storage holding the buffer contents, replacing it with the initial internal storage of length [n] that was allocated by [create n]. For long-lived buffers that may have grown a lot, [reset] allows faster reclamation of the space used by the buffer. *) val reset : t -> unit (** [add_char b c] appends the character [c] at the end of the buffer [b]. *) val add_char : t -> char -> unit (** [add_string b s] appends the string [s] at the end of the buffer [b]. *) val add_string : t -> string -> unit (** [add_substring b s pos len] takes [len] characters from offset [pos] in string [s] and appends them at the end of the buffer [b]. *) val add_substring : t -> string -> pos:int -> len:int -> unit (** [add_bytes b s] appends the bytes [s] at the end of the buffer [b]. *) val add_bytes : t -> bytes -> unit (** [add_subbytes b s pos len] takes [len] characters from offset [pos] in bytes [s] and appends them at the end of the buffer [b]. *) val add_subbytes : t -> bytes -> pos:int -> len:int -> unit (** [add_buffer b1 b2] appends the current contents of buffer [b2] at the end of buffer [b1]. [b2] is not modified. *) val add_buffer : t -> t -> unit end module type Buffer = sig module type S = S (** Buffers using strings as underlying storage medium: *) include S with type t = Stdlib.Buffer.t (** @open *) end base-0.16.3/src/bytes.ml000066400000000000000000000101531446274340700147750ustar00rootroot00000000000000open! Import module Array = Array0 let stage = Staged.stage module T = struct type t = bytes [@@deriving_inline globalize, sexp, sexp_grammar] let (globalize : (t[@ocaml.local]) -> t) = (globalize_bytes : (t[@ocaml.local]) -> t) let t_of_sexp = (bytes_of_sexp : Sexplib0.Sexp.t -> t) let sexp_of_t = (sexp_of_bytes : t -> Sexplib0.Sexp.t) let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = bytes_sexp_grammar [@@@end] include Bytes0 let module_name = "Base.Bytes" let pp fmt t = Stdlib.Format.fprintf fmt "%S" (to_string t) end include T module To_bytes = Blit.Make (struct include T let create ~len = create len end) include To_bytes include Comparator.Make (T) include Pretty_printer.Register_pp (T) (* Open replace_polymorphic_compare after including functor instantiations so they do not shadow its definitions. This is here so that efficient versions of the comparison functions are available within this module. *) open! Bytes_replace_polymorphic_compare module To_string = Blit.Make_to_string (T) (To_bytes) module From_string = Blit.Make_distinct (struct type t = string let length = String.length end) (struct type nonrec t = t let create ~len = create len let length = length let unsafe_blit = unsafe_blit_string end) let invariant (_ : t) = () let init n ~f = if Int_replace_polymorphic_compare.( < ) n 0 then Printf.invalid_argf "Bytes.init %d" n (); let t = create n in for i = 0 to n - 1 do unsafe_set t i (f i) done; t ;; let of_char_list l = let t = create (List.length l) in List.iteri l ~f:(fun i c -> set t i c); t ;; let to_list t = let rec loop t i acc = if Int_replace_polymorphic_compare.( < ) i 0 then acc else loop t (i - 1) (unsafe_get t i :: acc) in loop t (length t - 1) [] ;; let to_array t = Array.init (length t) ~f:(fun i -> unsafe_get t i) let map t ~f = map t ~f let mapi t ~f = mapi t ~f let fold = let rec loop t ~f ~len ~pos acc = if Int_replace_polymorphic_compare.equal pos len then acc else loop t ~f ~len ~pos:(pos + 1) (f acc (unsafe_get t pos)) in fun t ~init ~f -> loop t ~f ~len:(length t) ~pos:0 init ;; let foldi = let rec loop t ~f ~len ~pos acc = if Int_replace_polymorphic_compare.equal pos len then acc else loop t ~f ~len ~pos:(pos + 1) (f pos acc (unsafe_get t pos)) in fun t ~init ~f -> loop t ~f ~len:(length t) ~pos:0 init ;; let tr ~target ~replacement s = for i = 0 to length s - 1 do if Char.equal (unsafe_get s i) target then unsafe_set s i replacement done ;; let tr_multi ~target ~replacement = if Int_replace_polymorphic_compare.( = ) (String.length target) 0 then stage ignore else if Int_replace_polymorphic_compare.( = ) (String.length replacement) 0 then invalid_arg "tr_multi: replacement is the empty string" else ( match Bytes_tr.tr_create_map ~target ~replacement with | None -> stage ignore | Some tr_map -> stage (fun s -> for i = 0 to length s - 1 do unsafe_set s i (String.unsafe_get tr_map (Char.to_int (unsafe_get s i))) done)) ;; let between t ~low ~high = low <= t && t <= high let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max let clamp_exn t ~min ~max = assert (min <= max); clamp_unchecked t ~min ~max ;; let clamp t ~min ~max = if min > max then Or_error.error_s (Sexp.message "clamp requires [min <= max]" [ "min", T.sexp_of_t min; "max", T.sexp_of_t max ]) else Ok (clamp_unchecked t ~min ~max) ;; let contains ?pos ?len t char = let pos, len = Ordered_collection_common.get_pos_len_exn () ?pos ?len ~total_length:(length t) in let last = pos + len in let rec loop i = Int_replace_polymorphic_compare.( < ) i last && (Char.equal (get t i) char || loop (i + 1)) in loop pos ;; (* Include type-specific [Replace_polymorphic_compare] at the end, after including functor application that could shadow its definitions. This is here so that efficient versions of the comparison functions are exported by this module. *) include Bytes_replace_polymorphic_compare base-0.16.3/src/bytes.mli000066400000000000000000000243711446274340700151550ustar00rootroot00000000000000(** OCaml's byte sequence type, semantically similar to a [char array], but taking less space in memory. A byte sequence is a mutable data structure that contains a fixed-length sequence of bytes (of type [char]). Each byte can be indexed in constant time for reading or writing. *) open! Import type t = bytes [@@deriving_inline globalize, sexp, sexp_grammar] val globalize : (t[@ocaml.local]) -> t include Sexplib0.Sexpable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] (** {1 Common Interfaces} *) include Blit.S with type t := t include Comparable.S with type t := t include Stringable.S with type t := t (** Note that [pp] allocates in order to preserve the state of the byte sequence it was initially called with. *) include Pretty_printer.S with type t := t include Invariant.S with type t := t module To_string : sig val sub : (t, string) Blit.sub val subo : (t, string) Blit.subo end module From_string : Blit.S_distinct with type src := string and type dst := t (** [create len] returns a newly-allocated and uninitialized byte sequence of length [len]. No guarantees are made about the contents of the return value. *) val create : int -> t (** [create_local] is like [create], but returns a stack-allocated [Bytes.t]. *) val create_local : int -> (t[@local]) (** [make len c] returns a newly-allocated byte sequence of length [len] filled with the byte [c]. *) val make : int -> char -> t (** [map f t] applies function [f] to every byte, in order, and builds the byte sequence with the results returned by [f]. *) val map : t -> f:((char -> char)[@local]) -> t (** Like [map], but passes each character's index to [f] along with the char. *) val mapi : t -> f:((int -> char -> char)[@local]) -> t (** [copy t] returns a newly-allocated byte sequence that contains the same bytes as [t]. *) val copy : t -> t (** [init len ~f] returns a newly-allocated byte sequence of length [len] with index [i] in the sequence being initialized with the result of [f i]. *) val init : int -> f:((int -> char)[@local]) -> t (** [of_char_list l] returns a newly-allocated byte sequence where each byte in the sequence corresponds to the byte in [l] at the same index. *) val of_char_list : char list -> t (** [length t] returns the number of bytes in [t]. *) external length : (t[@local_opt]) -> int = "%bytes_length" (** [get t i] returns the [i]th byte of [t]. *) val get : t -> int -> char external unsafe_get : (t[@local_opt]) -> (int[@local_opt]) -> char = "%bytes_unsafe_get" (** [set t i c] sets the [i]th byte of [t] to [c]. *) external set : (t[@local_opt]) -> (int[@local_opt]) -> (char[@local_opt]) -> unit = "%bytes_safe_set" external unsafe_set : (t[@local_opt]) -> (int[@local_opt]) -> (char[@local_opt]) -> unit = "%bytes_unsafe_set" external unsafe_get_int64 : (t[@local_opt]) -> (int[@local_opt]) -> int64 = "%caml_bytes_get64u" external unsafe_set_int64 : (t[@local_opt]) -> (int[@local_opt]) -> (int64[@local_opt]) -> unit = "%caml_bytes_set64u" external unsafe_get_int32 : (t[@local_opt]) -> (int[@local_opt]) -> int32 = "%caml_bytes_get32u" external unsafe_set_int32 : (t[@local_opt]) -> (int[@local_opt]) -> (int32[@local_opt]) -> unit = "%caml_bytes_set32u" external unsafe_get_int16 : (t[@local_opt]) -> (int[@local_opt]) -> int = "%caml_bytes_get16u" external unsafe_set_int16 : (t[@local_opt]) -> (int[@local_opt]) -> (int[@local_opt]) -> unit = "%caml_bytes_set16u" (** [fill t ~pos ~len c] modifies [t] in place, replacing all the bytes from [pos] to [pos + len] with [c]. *) val fill : t -> pos:int -> len:int -> char -> unit (** [tr ~target ~replacement t] modifies [t] in place, replacing every instance of [target] in [s] with [replacement]. *) val tr : target:char -> replacement:char -> t -> unit (** [tr_multi ~target ~replacement] returns an in-place function that replaces every instance of a character in [target] with the corresponding character in [replacement]. If [replacement] is shorter than [target], it is lengthened by repeating its last character. Empty [replacement] is illegal unless [target] also is. If [target] contains multiple copies of the same character, the last corresponding [replacement] character is used. Note that character ranges are {b not} supported, so [~target:"a-z"] means the literal characters ['a'], ['-'], and ['z']. *) val tr_multi : target:string -> replacement:string -> (t -> unit) Staged.t (** [to_list t] returns the bytes in [t] as a list of chars. *) val to_list : t -> char list (** [to_array t] returns the bytes in [t] as an array of chars. *) val to_array : t -> char array (** [fold a ~f ~init:b] is [f a1 (f a2 (...))] *) val fold : t -> init:'acc -> f:(('acc -> char -> 'acc)[@local]) -> 'acc (** [foldi] works similarly to [fold], but also passes the index of each character to [f]. *) val foldi : t -> init:'acc -> f:((int -> 'acc -> char -> 'acc)[@local]) -> 'acc (** [contains ?pos ?len t c] returns [true] iff [c] appears in [t] between [pos] and [pos + len]. *) val contains : ?pos:int -> ?len:int -> t -> char -> bool (** Maximum length of a byte sequence, which is architecture-dependent. Attempting to create a [Bytes] larger than this will raise an exception. *) val max_length : int (** {2:unsafe Unsafe conversions (for advanced users)} This section describes unsafe, low-level conversion functions between [bytes] and [string]. They might not copy the internal data; used improperly, they can break the immutability invariant on strings provided by the [-safe-string] option. They are available for expert library authors, but for most purposes you should use the always-correct {!Bytes.to_string} and {!Bytes.of_string} instead. *) (** Unsafely convert a byte sequence into a string. To reason about the use of [unsafe_to_string], it is convenient to consider an "ownership" discipline. A piece of code that manipulates some data "owns" it; there are several disjoint ownership modes, including: {ul {- Unique ownership: the data may be accessed and mutated} {- Shared ownership: the data has several owners, that may only access it, not mutate it.}} Unique ownership is linear: passing the data to another piece of code means giving up ownership (we cannot access the data again). A unique owner may decide to make the data shared (giving up mutation rights on it), but shared data may not become uniquely-owned again. [unsafe_to_string s] can only be used when the caller owns the byte sequence [s] -- either uniquely or as shared immutable data. The caller gives up ownership of [s], and gains (the same mode of) ownership of the returned string. There are two valid use-cases that respect this ownership discipline: {ol {- The first is creating a string by initializing and mutating a byte sequence that is never changed after initialization is performed. {[ let string_init len f : string = let s = Bytes.create len in for i = 0 to len - 1 do Bytes.set s i (f i) done; Bytes.unsafe_to_string ~no_mutation_while_string_reachable:s ]} This function is safe because the byte sequence [s] will never be accessed or mutated after [unsafe_to_string] is called. The [string_init] code gives up ownership of [s], and returns the ownership of the resulting string to its caller. Note that it would be unsafe if [s] was passed as an additional parameter to the function [f] as it could escape this way and be mutated in the future -- [string_init] would give up ownership of [s] to pass it to [f], and could not call [unsafe_to_string] safely. We have provided the {!String.init}, {!String.map} and {!String.mapi} functions to cover most cases of building new strings. You should prefer those over [to_string] or [unsafe_to_string] whenever applicable.} {- The second is temporarily giving ownership of a byte sequence to a function that expects a uniquely owned string and returns ownership back, so that we can mutate the sequence again after the call ended. {[ let bytes_length (s : bytes) = String.length (Bytes.unsafe_to_string ~no_mutation_while_string_reachable:s) ]} In this use-case, we do not promise that [s] will never be mutated after the call to [bytes_length s]. The {!String.length} function temporarily borrows unique ownership of the byte sequence (and sees it as a [string]), but returns this ownership back to the caller, which may assume that [s] is still a valid byte sequence after the call. Note that this is only correct because we know that {!String.length} does not capture its argument -- it could escape by a side-channel such as a memoization combinator. The caller may not mutate [s] while the string is borrowed (it has temporarily given up ownership). This affects concurrent programs, but also higher-order functions: if {!String.length} returned a closure to be called later, [s] should not be mutated until this closure is fully applied and returns ownership.}} *) external unsafe_to_string : no_mutation_while_string_reachable:(t[@local_opt]) -> (string[@local_opt]) = "%bytes_to_string" (** Unsafely convert a shared string to a byte sequence that should not be mutated. The same ownership discipline that makes [unsafe_to_string] correct applies to [unsafe_of_string_promise_no_mutation], however unique ownership of string values is extremely difficult to reason about correctly in practice. As such, one should always assume strings are shared, never uniquely owned (For example, string literals are implicitly shared by the compiler, so you never uniquely own them) The only case we have reasonable confidence is safe is if the produced [bytes] is shared -- used as an immutable byte sequence. This is possibly useful for incremental migration of low-level programs that manipulate immutable sequences of bytes (for example {!Marshal.from_bytes}) and previously used the [string] type for this purpose. *) external unsafe_of_string_promise_no_mutation : (string[@local_opt]) -> (t[@local_opt]) = "%bytes_of_string" base-0.16.3/src/bytes0.ml000066400000000000000000000073361446274340700150660ustar00rootroot00000000000000(* [Bytes0] defines string functions that are primitives or can be simply defined in terms of [Stdlib.Bytes]. [Bytes0] is intended to completely express the part of [Stdlib.Bytes] that [Base] uses -- no other file in Base other than bytes0.ml should use [Stdlib.Bytes]. [Bytes0] has few dependencies, and so is available early in Base's build order. All Base files that need to use strings and come before [Base.Bytes] in build order should do: {[ module Bytes = Bytes0 ]} Defining [module Bytes = Bytes0] is also necessary because it prevents ocamldep from mistakenly causing a file to depend on [Base.Bytes]. *) open! Import0 module Sys = Sys0 module Primitives = struct external get : (bytes[@local_opt]) -> (int[@local_opt]) -> char = "%bytes_safe_get" external length : (bytes[@local_opt]) -> int = "%bytes_length" external unsafe_get : (bytes[@local_opt]) -> (int[@local_opt]) -> char = "%bytes_unsafe_get" external set : (bytes[@local_opt]) -> (int[@local_opt]) -> (char[@local_opt]) -> unit = "%bytes_safe_set" external unsafe_set : (bytes[@local_opt]) -> (int[@local_opt]) -> (char[@local_opt]) -> unit = "%bytes_unsafe_set" (* [unsafe_blit_string] is not exported in the [stdlib] so we export it here *) external unsafe_blit_string : src:(string[@local_opt]) -> src_pos:int -> dst:(bytes[@local_opt]) -> dst_pos:int -> len:int -> unit = "caml_blit_string" [@@noalloc] external unsafe_get_int64 : (bytes[@local_opt]) -> (int[@local_opt]) -> int64 = "%caml_bytes_get64u" external unsafe_set_int64 : (bytes[@local_opt]) -> (int[@local_opt]) -> (int64[@local_opt]) -> unit = "%caml_bytes_set64u" external unsafe_get_int32 : (bytes[@local_opt]) -> (int[@local_opt]) -> int32 = "%caml_bytes_get32u" external unsafe_set_int32 : (bytes[@local_opt]) -> (int[@local_opt]) -> (int32[@local_opt]) -> unit = "%caml_bytes_set32u" external unsafe_get_int16 : (bytes[@local_opt]) -> (int[@local_opt]) -> int = "%caml_bytes_get16u" external unsafe_set_int16 : (bytes[@local_opt]) -> (int[@local_opt]) -> (int[@local_opt]) -> unit = "%caml_bytes_set16u" end include Primitives let max_length = Sys.max_string_length let blit = Stdlib.Bytes.blit let blit_string = Stdlib.Bytes.blit_string let compare = Stdlib.Bytes.compare let copy = Stdlib.Bytes.copy let create = Stdlib.Bytes.create external unsafe_create_local : int -> (bytes[@local]) = "Base_unsafe_create_local_bytes" [@@noalloc] let create_local len = (if len > Sys0.max_string_length then invalid_arg "Bytes.create_local"; unsafe_create_local len) ;; let fill = Stdlib.Bytes.fill let make = Stdlib.Bytes.make let map t ~f:((f : _ -> _) [@local]) = let l = length t in if l = 0 then t else ( let r = create l in for i = 0 to l - 1 do unsafe_set r i (f (unsafe_get t i)) done; r) ;; let mapi t ~f:((f : _ -> _ -> _) [@local]) = let l = length t in if l = 0 then t else ( let r = create l in for i = 0 to l - 1 do unsafe_set r i (f i (unsafe_get t i)) done; r) ;; let sub = Stdlib.Bytes.sub external unsafe_blit : src:(bytes[@local_opt]) -> src_pos:int -> dst:(bytes[@local_opt]) -> dst_pos:int -> len:int -> unit = "caml_blit_bytes" [@@noalloc] let to_string = Stdlib.Bytes.to_string let of_string = Stdlib.Bytes.of_string external unsafe_to_string : no_mutation_while_string_reachable:(bytes[@local_opt]) -> (string[@local_opt]) = "%bytes_to_string" external unsafe_of_string_promise_no_mutation : (string[@local_opt]) -> (bytes[@local_opt]) = "%bytes_of_string" base-0.16.3/src/bytes_stubs.c000066400000000000000000000005041446274340700160260ustar00rootroot00000000000000#include /* This is the same as caml_create_local_bytes, except that we skip the bounds-check and instead do it on the ocaml side, so that we can mark the C call noalloc. */ CAMLprim value Base_unsafe_create_local_bytes(value len) { mlsize_t size = Long_val(len); return caml_alloc_string(size); } base-0.16.3/src/bytes_tr.ml000066400000000000000000000031611446274340700155030ustar00rootroot00000000000000open! Import0.Int_replace_polymorphic_compare module Bytes = Bytes0 module String = String0 (* Construct a byte string of length 256, mapping every input character code to its corresponding output character. Benchmarks indicate that this is faster than the lambda (including cost of this function), even if target/replacement are just 2 characters each. Return None if the translation map is equivalent to just the identity. *) let tr_create_map ~target ~replacement = let tr_map = Bytes.create 256 in for i = 0 to 255 do Bytes.unsafe_set tr_map i (Char.of_int_exn i) done; for i = 0 to min (String.length target) (String.length replacement) - 1 do let index = Char.to_int (String.unsafe_get target i) in Bytes.unsafe_set tr_map index (String.unsafe_get replacement i) done; let last_replacement = String.unsafe_get replacement (String.length replacement - 1) in for i = min (String.length target) (String.length replacement) to String.length target - 1 do let index = Char.to_int (String.unsafe_get target i) in Bytes.unsafe_set tr_map index last_replacement done; let rec have_any_different tr_map i = if i = 256 then false else if Char.( <> ) (Bytes0.unsafe_get tr_map i) (Char.of_int_exn i) then true else have_any_different tr_map (i + 1) in (* quick check on the first target character which will 99% be true *) let first_target = target.[0] in if Char.( <> ) (Bytes0.unsafe_get tr_map (Char.to_int first_target)) first_target || have_any_different tr_map 0 then Some (Bytes0.unsafe_to_string ~no_mutation_while_string_reachable:tr_map) else None ;; base-0.16.3/src/char.ml000066400000000000000000000076011446274340700145700ustar00rootroot00000000000000open! Import module Array = Array0 module String = String0 include Char0 module T = struct type t = char [@@deriving_inline compare, hash, globalize, sexp, sexp_grammar] let compare = (compare_char : t -> t -> int) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = hash_fold_char and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = hash_char in fun x -> func x ;; let (globalize : (t[@ocaml.local]) -> t) = (globalize_char : (t[@ocaml.local]) -> t) let t_of_sexp = (char_of_sexp : Sexplib0.Sexp.t -> t) let sexp_of_t = (sexp_of_char : t -> Sexplib0.Sexp.t) let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = char_sexp_grammar [@@@end] let to_string t = String.make 1 t let of_string s = match String.length s with | 1 -> s.[0] | _ -> failwithf "Char.of_string: %S" s () ;; end include T include Identifiable.Make (struct include T let module_name = "Base.Char" end) let pp fmt c = Stdlib.Format.fprintf fmt "%C" c (* Open replace_polymorphic_compare after including functor instantiations so they do not shadow its definitions. This is here so that efficient versions of the comparison functions are available within this module. *) open! Char_replace_polymorphic_compare let invariant (_ : t) = () let all = Array.init 256 ~f:unsafe_of_int |> Array.to_list let is_lowercase = function | 'a' .. 'z' -> true | _ -> false ;; let is_uppercase = function | 'A' .. 'Z' -> true | _ -> false ;; let is_print = function | ' ' .. '~' -> true | _ -> false ;; let is_whitespace = function | '\t' | '\n' | '\011' (* vertical tab *) | '\012' (* form feed *) | '\r' | ' ' -> true | _ -> false ;; let is_digit = function | '0' .. '9' -> true | _ -> false ;; let is_alpha = function | 'a' .. 'z' | 'A' .. 'Z' -> true | _ -> false ;; (* Writing these out, instead of calling [is_alpha] and [is_digit], reduces runtime by approx. 30% *) let is_alphanum = function | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> true | _ -> false ;; let get_digit_unsafe t = to_int t - to_int '0' let get_digit_exn t = if is_digit t then get_digit_unsafe t else failwithf "Char.get_digit_exn %C: not a digit" t () ;; let get_digit t = if is_digit t then Some (get_digit_unsafe t) else None let is_hex_digit = function | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false ;; let is_hex_digit_lower = function | '0' .. '9' | 'a' .. 'f' -> true | _ -> false ;; let is_hex_digit_upper = function | '0' .. '9' | 'A' .. 'F' -> true | _ -> false ;; let get_hex_digit_exn = function | '0' .. '9' as t -> to_int t - to_int '0' | 'a' .. 'f' as t -> to_int t - to_int 'a' + 10 | 'A' .. 'F' as t -> to_int t - to_int 'A' + 10 | t -> Error.raise_s (Sexp.message "Char.get_hex_digit_exn: not a hexadecimal digit" [ "char", sexp_of_t t ]) ;; let get_hex_digit t = if is_hex_digit t then Some (get_hex_digit_exn t) else None module O = struct let ( >= ) = ( >= ) let ( <= ) = ( <= ) let ( = ) = ( = ) let ( > ) = ( > ) let ( < ) = ( < ) let ( <> ) = ( <> ) end module Caseless = struct module T = struct type t = char [@@deriving_inline sexp, sexp_grammar] let t_of_sexp = (char_of_sexp : Sexplib0.Sexp.t -> t) let sexp_of_t = (sexp_of_char : t -> Sexplib0.Sexp.t) let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = char_sexp_grammar [@@@end] let compare c1 c2 = compare (lowercase c1) (lowercase c2) let hash_fold_t state t = hash_fold_char state (lowercase t) let hash t = Hash.run hash_fold_t t end include T include Comparable.Make (T) end (* Include type-specific [Replace_polymorphic_compare] at the end, after including functor application that could shadow its definitions. This is here so that efficient versions of the comparison functions are exported by this module. *) include Char_replace_polymorphic_compare base-0.16.3/src/char.mli000066400000000000000000000052651446274340700147450ustar00rootroot00000000000000(** A type for 8-bit characters. *) open! Import (** An alias for the type of characters. *) type t = char [@@deriving_inline enumerate, globalize, sexp, sexp_grammar] include Ppx_enumerate_lib.Enumerable.S with type t := t val globalize : (t[@ocaml.local]) -> t include Sexplib0.Sexpable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] include Identifiable.S with type t := t include Invariant.S with type t := t module O : Comparisons.Infix with type t := t (** Returns the ASCII code of the argument. *) val to_int : t -> int (** Returns the character with the given ASCII code or [None] is the argument is outside the range 0 to 255. *) val of_int : int -> t option (** Returns the character with the given ASCII code. Raises [Failure] if the argument is outside the range 0 to 255. *) val of_int_exn : int -> t val unsafe_of_int : int -> t (** Returns a string representing the given character, with special characters escaped following the lexical conventions of OCaml. *) val escaped : t -> string (** Converts the given character to its equivalent lowercase character. *) val lowercase : t -> t (** Converts the given character to its equivalent uppercase character. *) val uppercase : t -> t (** '0' - '9' *) val is_digit : t -> bool (** 'a' - 'z' *) val is_lowercase : t -> bool (** 'A' - 'Z' *) val is_uppercase : t -> bool (** 'a' - 'z' or 'A' - 'Z' *) val is_alpha : t -> bool (** 'a' - 'z' or 'A' - 'Z' or '0' - '9' *) val is_alphanum : t -> bool (** ' ' - '~' *) val is_print : t -> bool (** ' ' or '\t' or '\r' or '\n' *) val is_whitespace : t -> bool (** Returns [Some i] if [is_digit c] and [None] otherwise. *) val get_digit : t -> int option (** Returns [i] if [is_digit c] and raises [Failure] otherwise. *) val get_digit_exn : t -> int (** '0' - '9' or 'a' - 'f' or 'A' - 'F' *) val is_hex_digit : t -> bool (** '0' - '9' or 'a' - 'f' *) val is_hex_digit_lower : t -> bool (** '0' - '9' or 'A' - 'F' *) val is_hex_digit_upper : t -> bool (** Returns [Some i] where [0 <= i && i < 16] if [is_hex_digit c] and [None] otherwise. *) val get_hex_digit : t -> int option (** Same as [get_hex_digit] but raises instead of returning None. *) val get_hex_digit_exn : t -> int val min_value : t val max_value : t (** [Caseless] compares and hashes characters ignoring case, so that for example [Caseless.equal 'A' 'a'] and [Caseless.('a' < 'B')] are [true]. *) module Caseless : sig type nonrec t = t [@@deriving_inline hash, sexp, sexp_grammar] include Ppx_hash_lib.Hashable.S with type t := t include Sexplib0.Sexpable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] include Comparable.S with type t := t end base-0.16.3/src/char0.ml000066400000000000000000000026461446274340700146540ustar00rootroot00000000000000(* [Char0] defines char functions that are primitives or can be simply defined in terms of [Stdlib.Char]. [Char0] is intended to completely express the part of [Stdlib.Char] that [Base] uses -- no other file in Base other than char0.ml should use [Stdlib.Char]. [Char0] has few dependencies, and so is available early in Base's build order. All Base files that need to use chars and come before [Base.Char] in build order should do [module Char = Char0]. Defining [module Char = Char0] is also necessary because it prevents ocamldep from mistakenly causing a file to depend on [Base.Char]. *) open! Import0 let failwithf = Printf.failwithf let escaped = Stdlib.Char.escaped let lowercase = Stdlib.Char.lowercase_ascii let to_int = Stdlib.Char.code let unsafe_of_int = Stdlib.Char.unsafe_chr let uppercase = Stdlib.Char.uppercase_ascii (* We use our own range test when converting integers to chars rather than calling [Stdlib.Char.chr] because it's simple and it saves us a function call and the try-with (exceptions cost, especially in the world with backtraces). *) let int_is_ok i = 0 <= i && i <= 255 let min_value = unsafe_of_int 0 let max_value = unsafe_of_int 255 let of_int i = if int_is_ok i then Some (unsafe_of_int i) else None let of_int_exn i = if int_is_ok i then unsafe_of_int i else failwithf "Char.of_int_exn got integer out of range: %d" i () ;; let equal (t1 : char) t2 = Poly.equal t1 t2 base-0.16.3/src/comparable.ml000066400000000000000000000110511446274340700157520ustar00rootroot00000000000000open! Import include Comparable_intf module With_zero (T : sig type t [@@deriving_inline compare] include Ppx_compare_lib.Comparable.S with type t := t [@@@end] val zero : t end) = struct open T let is_positive t = compare t zero > 0 let is_non_negative t = compare t zero >= 0 let is_negative t = compare t zero < 0 let is_non_positive t = compare t zero <= 0 let sign t = Sign0.of_int (compare t zero) end module Poly (T : sig type t [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end) = struct module Replace_polymorphic_compare = struct type t = T.t [@@deriving_inline sexp_of] let sexp_of_t = (T.sexp_of_t : t -> Sexplib0.Sexp.t) [@@@end] include Poly end include Poly let between t ~low ~high = low <= t && t <= high let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max let clamp_exn t ~min ~max = assert (min <= max); clamp_unchecked t ~min ~max ;; let clamp t ~min ~max = if min > max then Or_error.error_s (Sexp.message "clamp requires [min <= max]" [ "min", T.sexp_of_t min; "max", T.sexp_of_t max ]) else Ok (clamp_unchecked t ~min ~max) ;; module C = struct include T include Comparator.Make (Replace_polymorphic_compare) end include C end let gt cmp a b = cmp a b > 0 let lt cmp a b = cmp a b < 0 let geq cmp a b = cmp a b >= 0 let leq cmp a b = cmp a b <= 0 let equal cmp a b = cmp a b = 0 let not_equal cmp a b = cmp a b <> 0 let min cmp t t' = if leq cmp t t' then t else t' let max cmp t t' = if geq cmp t t' then t else t' module Infix (T : sig type t [@@deriving_inline compare] include Ppx_compare_lib.Comparable.S with type t := t [@@@end] end) : Infix with type t := T.t = struct let ( > ) a b = gt T.compare a b let ( < ) a b = lt T.compare a b let ( >= ) a b = geq T.compare a b let ( <= ) a b = leq T.compare a b let ( = ) a b = equal T.compare a b let ( <> ) a b = not_equal T.compare a b end [@@inline always] module Comparisons (T : sig type t [@@deriving_inline compare] include Ppx_compare_lib.Comparable.S with type t := t [@@@end] end) : Comparisons with type t := T.t = struct include Infix (T) let compare = T.compare let equal = ( = ) let min t t' = min compare t t' let max t t' = max compare t t' end [@@inline always] module Make_using_comparator (T : sig type t [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] include Comparator.S with type t := t end) : S with type t := T.t and type comparator_witness = T.comparator_witness = struct module T = struct include T let compare = comparator.compare end include T module Replace_polymorphic_compare = Comparisons (T) include Replace_polymorphic_compare let ascending = compare let descending t t' = compare t' t let between t ~low ~high = low <= t && t <= high let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max let clamp_exn t ~min ~max = assert (min <= max); clamp_unchecked t ~min ~max ;; let clamp t ~min ~max = if min > max then Or_error.error_s (Sexp.message "clamp requires [min <= max]" [ "min", T.sexp_of_t min; "max", T.sexp_of_t max ]) else Ok (clamp_unchecked t ~min ~max) ;; end module Make (T : sig type t [@@deriving_inline compare, sexp_of] include Ppx_compare_lib.Comparable.S with type t := t val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end) = Make_using_comparator [@inlined hint] (struct include T include Comparator.Make (T) end) module Inherit (C : sig type t [@@deriving_inline compare] include Ppx_compare_lib.Comparable.S with type t := t [@@@end] end) (T : sig type t [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] val component : t -> C.t end) = Make (struct type t = T.t [@@deriving_inline sexp_of] let sexp_of_t = (T.sexp_of_t : t -> Sexplib0.Sexp.t) [@@@end] let compare t t' = C.compare (T.component t) (T.component t') end) (* compare [x] and [y] lexicographically using functions in the list [cmps] *) let lexicographic cmps x y = let rec loop = function | cmp :: cmps -> let res = cmp x y in if res = 0 then loop cmps else res | [] -> 0 in loop cmps ;; let lift cmp ~f x y = cmp (f x) (f y) let reverse cmp x y = cmp y x type 'a reversed = 'a let compare_reversed cmp x y = cmp y x base-0.16.3/src/comparable.mli000066400000000000000000000000621446274340700161230ustar00rootroot00000000000000include Comparable_intf.Comparable (** @inline *) base-0.16.3/src/comparable_intf.ml000066400000000000000000000144711446274340700170030ustar00rootroot00000000000000open! Import module type Infix = Comparisons.Infix module type Comparisons = Comparisons.S module Sign = Sign0 (** @canonical Base.Sign *) module type With_compare = sig (** Various combinators for [compare] and [equal] functions. *) (** [lexicographic cmps x y] compares [x] and [y] lexicographically using functions in the list [cmps]. *) val lexicographic : ('a -> 'a -> int) list -> 'a -> 'a -> int (** [lift cmp ~f x y] compares [x] and [y] by comparing [f x] and [f y] via [cmp]. *) val lift : ('a -> 'a -> 'result) -> f:('b -> 'a) -> 'b -> 'b -> 'result (** [reverse cmp x y = cmp y x] Reverses the direction of asymmetric relations by swapping their arguments. Useful, e.g., for relations implementing "is a subset of" or "is a descendant of". Where reversed relations are already provided, use them directly. For example, [Comparable.S] provides [ascending] and [descending], which are more readable as a pair than [compare] and [reverse compare]. Similarly, [<=] is more idiomatic than [reverse (>=)]. *) val reverse : ('a -> 'a -> 'result) -> 'a -> 'a -> 'result (** {!reversed} is the identity type but its associated compare function is the same as the {!reverse} function above. It allows you to get reversed comparisons with [ppx_compare], writing, for example, [[%compare: string Comparable.reversed]] to have strings ordered in the reverse order. *) type 'a reversed = 'a val compare_reversed : ('a -> 'a -> int) -> 'a reversed -> 'a reversed -> int (** The functions below are analogues of the type-specific functions exported by the [Comparable.S] interface. *) val equal : ('a -> 'a -> int) -> 'a -> 'a -> bool val max : ('a -> 'a -> int) -> 'a -> 'a -> 'a val min : ('a -> 'a -> int) -> 'a -> 'a -> 'a end module type With_zero = sig type t val is_positive : t -> bool val is_non_negative : t -> bool val is_negative : t -> bool val is_non_positive : t -> bool (** Returns [Neg], [Zero], or [Pos] in a way consistent with the above functions. *) val sign : t -> Sign.t end module type S = sig include Comparisons (** [ascending] is identical to [compare]. [descending x y = ascending y x]. These are intended to be mnemonic when used like [List.sort ~compare:ascending] and [List.sort ~cmp:descending], since they cause the list to be sorted in ascending or descending order, respectively. *) val ascending : t -> t -> int val descending : t -> t -> int (** [between t ~low ~high] means [low <= t <= high] *) val between : t -> low:t -> high:t -> bool (** [clamp_exn t ~min ~max] returns [t'], the closest value to [t] such that [between t' ~low:min ~high:max] is true. Raises if [not (min <= max)]. *) val clamp_exn : t -> min:t -> max:t -> t val clamp : t -> min:t -> max:t -> t Or_error.t include Comparator.S with type t := t end (** Usage example: {[ module Foo : sig type t = ... include Comparable.S with type t := t end ]} Then use [Comparable.Make] in the struct (see comparable.mli for an example). *) module type Comparable = sig (** Defines functors for making modules comparable. *) (** Usage example: {[ module Foo = struct module T = struct type t = ... [@@deriving compare, sexp] end include T include Comparable.Make (T) end ]} Then include [Comparable.S] in the signature {[ module Foo : sig type t = ... include Comparable.S with type t := t end ]} To add an [Infix] submodule: {[ module C = Comparable.Make (T) include C module Infix = (C : Comparable.Infix with type t := t) ]} A common pattern is to define a module [O] with a restricted signature. It aims to be (locally) opened to bring useful operators into scope without shadowing unexpected variable names. E.g., in the [Date] module: {[ module O = struct include (C : Comparable.Infix with type t := t) let to_string t = .. end ]} Opening [Date] would shadow [now], but opening [Date.O] doesn't: {[ let now = .. in let someday = .. in Date.O.(now > someday) ]} *) module type Infix = Infix module type S = S module type Comparisons = Comparisons module type With_compare = With_compare module type With_zero = With_zero include With_compare (** Derive [Infix] or [Comparisons] functions from just [[@@deriving compare]], without need for the [sexp_of_t] required by [Make*] (see below). *) module Infix (T : sig type t [@@deriving_inline compare] include Ppx_compare_lib.Comparable.S with type t := t [@@@end] end) : Infix with type t := T.t module Comparisons (T : sig type t [@@deriving_inline compare] include Ppx_compare_lib.Comparable.S with type t := t [@@@end] end) : Comparisons with type t := T.t (** Inherit comparability from a component. *) module Inherit (C : sig type t [@@deriving_inline compare] include Ppx_compare_lib.Comparable.S with type t := t [@@@end] end) (T : sig type t [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] val component : t -> C.t end) : S with type t := T.t module Make (T : sig type t [@@deriving_inline compare, sexp_of] include Ppx_compare_lib.Comparable.S with type t := t val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end) : S with type t := T.t module Make_using_comparator (T : sig type t [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] include Comparator.S with type t := t end) : S with type t := T.t with type comparator_witness := T.comparator_witness module Poly (T : sig type t [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end) : S with type t := T.t module With_zero (T : sig type t [@@deriving_inline compare, sexp_of] include Ppx_compare_lib.Comparable.S with type t := t val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] val zero : t end) : sig include With_zero with type t := T.t end end base-0.16.3/src/comparator.ml000066400000000000000000000100501446274340700160120ustar00rootroot00000000000000open! Import type ('a, 'witness) t = { compare : 'a -> 'a -> int ; sexp_of_t : 'a -> Sexp.t } type ('a, 'b) comparator = ('a, 'b) t module type S = sig type t type comparator_witness val comparator : (t, comparator_witness) comparator end module type S1 = sig type 'a t type comparator_witness val comparator : ('a t, comparator_witness) comparator end module type S_fc = sig type comparable_t include S with type t := comparable_t end module Module = struct type ('a, 'b) t = (module S with type t = 'a and type comparator_witness = 'b) end let make (type t) ~compare ~sexp_of_t = (module struct type comparable_t = t type comparator_witness let comparator = { compare; sexp_of_t } end : S_fc with type comparable_t = t) ;; module S_to_S1 (S : S) = struct type 'a t = S.t type comparator_witness = S.comparator_witness open S let comparator = comparator end module Make (M : sig type t [@@deriving_inline compare, sexp_of] include Ppx_compare_lib.Comparable.S with type t := t val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end) = struct include M type comparator_witness let comparator = M.{ compare; sexp_of_t } end module Make1 (M : sig type 'a t val compare : 'a t -> 'a t -> int val sexp_of_t : 'a t -> Sexp.t end) = struct type comparator_witness let comparator = M.{ compare; sexp_of_t } end module Poly = struct type 'a t = 'a include Make1 (struct type 'a t = 'a let compare = Poly.compare let sexp_of_t _ = Sexp.Atom "_" end) end module type Derived = sig type 'a t type !'cmp comparator_witness val comparator : ('a, 'cmp) comparator -> ('a t, 'cmp comparator_witness) comparator end module Derived (M : sig type 'a t [@@deriving_inline compare, sexp_of] include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t [@@@end] end) = struct type !'cmp comparator_witness let comparator a = { compare = M.compare a.compare; sexp_of_t = M.sexp_of_t a.sexp_of_t } ;; end module type Derived2 = sig type ('a, 'b) t type (!'cmp_a, !'cmp_b) comparator_witness val comparator : ('a, 'cmp_a) comparator -> ('b, 'cmp_b) comparator -> (('a, 'b) t, ('cmp_a, 'cmp_b) comparator_witness) comparator end module Derived2 (M : sig type ('a, 'b) t [@@deriving_inline compare, sexp_of] include Ppx_compare_lib.Comparable.S2 with type ('a, 'b) t := ('a, 'b) t val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> ('b -> Sexplib0.Sexp.t) -> ('a, 'b) t -> Sexplib0.Sexp.t [@@@end] end) = struct type (!'cmp_a, !'cmp_b) comparator_witness let comparator a b = { compare = M.compare a.compare b.compare ; sexp_of_t = M.sexp_of_t a.sexp_of_t b.sexp_of_t } ;; end module type Derived_phantom = sig type ('a, 'b) t type 'cmp comparator_witness val comparator : ('a, 'cmp) comparator -> (('a, _) t, 'cmp comparator_witness) comparator end module Derived_phantom (M : sig type ('a, 'b) t val compare : ('a -> 'a -> int) -> ('a, 'b) t -> ('a, 'b) t -> int val sexp_of_t : ('a -> Sexp.t) -> ('a, _) t -> Sexp.t end) = struct type 'cmp_a comparator_witness let comparator a = { compare = M.compare a.compare; sexp_of_t = M.sexp_of_t a.sexp_of_t } ;; end module type Derived2_phantom = sig type ('a, 'b, 'c) t type (!'cmp_a, !'cmp_b) comparator_witness val comparator : ('a, 'cmp_a) comparator -> ('b, 'cmp_b) comparator -> (('a, 'b, _) t, ('cmp_a, 'cmp_b) comparator_witness) comparator end module Derived2_phantom (M : sig type ('a, 'b, 'c) t val compare : ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> int val sexp_of_t : ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b, _) t -> Sexp.t end) = struct type (!'cmp_a, !'cmp_b) comparator_witness let comparator a b = { compare = M.compare a.compare b.compare ; sexp_of_t = M.sexp_of_t a.sexp_of_t b.sexp_of_t } ;; end base-0.16.3/src/comparator.mli000066400000000000000000000114661446274340700161770ustar00rootroot00000000000000(** Comparison and serialization for a type, using a witness type to distinguish between comparison functions with different behavior. *) open! Import (** [('a, 'witness) t] contains a comparison function for values of type ['a]. Two values of type [t] with the same ['witness] are guaranteed to have the same comparison function. *) type ('a, 'witness) t = private { compare : 'a -> 'a -> int ; sexp_of_t : 'a -> Sexp.t } type ('a, 'b) comparator = ('a, 'b) t module type S = sig type t type comparator_witness val comparator : (t, comparator_witness) comparator end module type S1 = sig type 'a t type comparator_witness val comparator : ('a t, comparator_witness) comparator end module type S_fc = sig type comparable_t include S with type t := comparable_t end (** [make] creates a comparator witness for the given comparison. It is intended as a lightweight alternative to the functors below, to be used like so: {[ include (val Comparator.make ~compare ~sexp_of_t) ]} *) val make : compare:('a -> 'a -> int) -> sexp_of_t:('a -> Sexp.t) -> (module S_fc with type comparable_t = 'a) module Poly : S1 with type 'a t = 'a module Module : sig (** First-class module providing a comparator and witness type. *) type ('a, 'b) t = (module S with type t = 'a and type comparator_witness = 'b) end module S_to_S1 (S : S) : S1 with type 'a t = S.t with type comparator_witness = S.comparator_witness (** [Make] creates a [comparator] value and its phantom [comparator_witness] type for a nullary type. *) module Make (M : sig type t [@@deriving_inline compare, sexp_of] include Ppx_compare_lib.Comparable.S with type t := t val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end) : S with type t := M.t (** [Make1] creates a [comparator] value and its phantom [comparator_witness] type for a unary type. It takes a [compare] and [sexp_of_t] that have non-standard types because the [Comparator.t] type doesn't allow passing in additional values for the type argument. *) module Make1 (M : sig type 'a t val compare : 'a t -> 'a t -> int val sexp_of_t : _ t -> Sexp.t end) : S1 with type 'a t := 'a M.t module type Derived = sig type 'a t type !'cmp comparator_witness val comparator : ('a, 'cmp) comparator -> ('a t, 'cmp comparator_witness) comparator end (** [Derived] creates a [comparator] function that constructs a comparator for the type ['a t] given a comparator for the type ['a]. *) module Derived (M : sig type 'a t [@@deriving_inline compare, sexp_of] include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t [@@@end] end) : Derived with type 'a t := 'a M.t module type Derived2 = sig type ('a, 'b) t type (!'cmp_a, !'cmp_b) comparator_witness val comparator : ('a, 'cmp_a) comparator -> ('b, 'cmp_b) comparator -> (('a, 'b) t, ('cmp_a, 'cmp_b) comparator_witness) comparator end (** [Derived2] creates a [comparator] function that constructs a comparator for the type [('a, 'b) t] given comparators for the type ['a] and ['b]. *) module Derived2 (M : sig type ('a, 'b) t [@@deriving_inline compare, sexp_of] include Ppx_compare_lib.Comparable.S2 with type ('a, 'b) t := ('a, 'b) t val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> ('b -> Sexplib0.Sexp.t) -> ('a, 'b) t -> Sexplib0.Sexp.t [@@@end] end) : Derived2 with type ('a, 'b) t := ('a, 'b) M.t module type Derived_phantom = sig type ('a, 'b) t type 'cmp comparator_witness val comparator : ('a, 'cmp) comparator -> (('a, _) t, 'cmp comparator_witness) comparator end (** [Derived_phantom] creates a [comparator] function that constructs a comparator for the type [('a, 'b) t] given a comparator for the type ['a]. *) module Derived_phantom (M : sig type ('a, 'b) t val compare : ('a -> 'a -> int) -> ('a, 'b) t -> ('a, 'b) t -> int val sexp_of_t : ('a -> Sexp.t) -> ('a, _) t -> Sexp.t end) : Derived_phantom with type ('a, 'b) t := ('a, 'b) M.t module type Derived2_phantom = sig type ('a, 'b, 'c) t type (!'cmp_a, !'cmp_b) comparator_witness val comparator : ('a, 'cmp_a) comparator -> ('b, 'cmp_b) comparator -> (('a, 'b, _) t, ('cmp_a, 'cmp_b) comparator_witness) comparator end (** [Derived2_phantom] creates a [comparator] function that constructs a comparator for the type [('a, 'b, 'c) t] given a comparator for the types ['a] and ['b]. *) module Derived2_phantom (M : sig type ('a, 'b, 'c) t val compare : ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> int val sexp_of_t : ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b, _) t -> Sexp.t end) : Derived2_phantom with type ('a, 'b, 'c) t := ('a, 'b, 'c) M.t base-0.16.3/src/comparisons.ml000066400000000000000000000014601446274340700162050ustar00rootroot00000000000000(** Interfaces for infix comparison operators and comparison functions. *) open! Import (** [Infix] lists the typical infix comparison operators. These functions are provided by [.O] modules, i.e., modules that expose monomorphic infix comparisons over some [.t]. *) module type Infix = sig type t val ( >= ) : t -> t -> bool val ( <= ) : t -> t -> bool val ( = ) : t -> t -> bool val ( > ) : t -> t -> bool val ( < ) : t -> t -> bool val ( <> ) : t -> t -> bool end module type S = sig include Infix val equal : t -> t -> bool (** [compare t1 t2] returns 0 if [t1] is equal to [t2], a negative integer if [t1] is less than [t2], and a positive integer if [t1] is greater than [t2]. *) val compare : t -> t -> int val min : t -> t -> t val max : t -> t -> t end base-0.16.3/src/container.ml000066400000000000000000000136031446274340700156340ustar00rootroot00000000000000open! Import module Array = Array0 module Either = Either0 module List = List0 include Container_intf let with_return = With_return.with_return type ('t, 'a, 'accum) fold = 't -> init:'accum -> f:(('accum -> 'a -> 'accum)[@local]) -> 'accum type ('t, 'a) iter = 't -> f:(('a -> unit)[@local]) -> unit type 't length = 't -> int let iter ~(fold : (_, _, _) fold) t ~f = fold t ~init:() ~f:(fun () a -> f a) [@nontail] let count ~fold t ~f = fold t ~init:0 ~f:(fun n a -> if f a then n + 1 else n) [@nontail] let sum (type a) ~fold (module M : Summable with type t = a) t ~f = fold t ~init:M.zero ~f:(fun n a -> M.( + ) n (f a)) [@nontail] ;; let fold_result ~fold ~init ~f t = with_return (fun { return } -> Result.Ok (fold t ~init ~f:(fun acc item -> match f acc item with | Result.Ok x -> x | Error _ as e -> return e))) [@nontail] ;; let fold_until ~fold ~init ~f ~finish t = with_return (fun { return } -> finish (fold t ~init ~f:(fun acc item -> match f acc item with | Continue_or_stop.Continue x -> x | Stop x -> return x))) [@nontail] ;; let min_elt ~fold t ~compare = fold t ~init:None ~f:(fun acc elt -> match acc with | None -> Some elt | Some min -> if compare min elt > 0 then Some elt else acc) [@nontail] ;; let max_elt ~fold t ~compare = fold t ~init:None ~f:(fun acc elt -> match acc with | None -> Some elt | Some max -> if compare max elt < 0 then Some elt else acc) [@nontail] ;; let length ~fold c = fold c ~init:0 ~f:(fun acc _ -> acc + 1) let is_empty ~iter c = with_return (fun r -> iter c ~f:(fun _ -> r.return false); true) ;; let mem ~iter c x ~equal = with_return (fun r -> iter c ~f:(fun y -> if equal x y then r.return true); false) [@nontail] ;; let exists ~iter c ~f = with_return (fun r -> iter c ~f:(fun x -> if f x then r.return true); false) [@nontail] ;; let for_all ~iter c ~f = with_return (fun r -> iter c ~f:(fun x -> if not (f x) then r.return false); true) [@nontail] ;; let find_map ~iter t ~f = with_return (fun r -> iter t ~f:(fun x -> match f x with | None -> () | Some _ as res -> r.return res); None) [@nontail] ;; let find ~iter c ~f = with_return (fun r -> iter c ~f:(fun x -> if f x then r.return (Some x)); None) [@nontail] ;; let to_list ~fold c = List.rev (fold c ~init:[] ~f:(fun acc x -> x :: acc)) let to_array ~length ~iter c = let array = ref [||] in let i = ref 0 in iter c ~f:(fun x -> if !i = 0 then array := Array.create ~len:(length c) x; !array.(!i) <- x; incr i); !array ;; module Make_gen (T : Make_gen_arg) : Generic with type ('a, 'phantom) t := ('a, 'phantom) T.t and type 'a elt := 'a T.elt = struct let fold = T.fold let iter = match T.iter with | `Custom iter -> iter | `Define_using_fold -> fun t ~f -> iter ~fold t ~f ;; let length = match T.length with | `Custom length -> length | `Define_using_fold -> fun t -> length ~fold t ;; let is_empty t = is_empty ~iter t let mem t x ~equal = mem ~iter t x ~equal let sum m t = sum ~fold m t let count t ~f = count ~fold t ~f let exists t ~f = exists ~iter t ~f let for_all t ~f = for_all ~iter t ~f let find_map t ~f = find_map ~iter t ~f let find t ~f = find ~iter t ~f let to_list t = to_list ~fold t let to_array t = to_array ~length ~iter t let min_elt t ~compare = min_elt ~fold t ~compare let max_elt t ~compare = max_elt ~fold t ~compare let fold_result t ~init ~f = fold_result t ~fold ~init ~f let fold_until t ~init ~f ~finish = fold_until t ~fold ~init ~f ~finish end module Make (T : Make_arg) = struct include Make_gen (struct include T type ('a, _) t = 'a T.t type 'a elt = 'a end) end module Make0 (T : Make0_arg) = struct include Make_gen (struct include T type ('a, _) t = T.t type 'a elt = T.Elt.t end) let mem t x = mem t x ~equal:T.Elt.equal end module Make_gen_with_creators (T : Make_gen_with_creators_arg) : Generic_with_creators with type ('a, 'phantom) t := ('a, 'phantom) T.t and type 'a elt := 'a T.elt and type ('a, 'phantom) concat := ('a, 'phantom) T.concat = struct include Make_gen (T) let of_list = T.of_list let of_array = T.of_array let concat = T.concat let concat_of_array = T.concat_of_array let append a b = concat (concat_of_array [| a; b |]) let concat_map t ~f = concat (concat_of_array (Array.map (to_array t) ~f)) let filter_map t ~f = concat_map t ~f:(fun x -> match f x with | None -> of_array [||] | Some y -> of_array [| y |]) [@nontail] ;; let map t ~f = filter_map t ~f:(fun x -> Some (f x)) [@nontail] let filter t ~f = filter_map t ~f:(fun x -> if f x then Some x else None) [@nontail] let partition_map t ~f = let array = Array.map (to_array t) ~f in let xs = Array.fold_right array ~init:[] ~f:(fun either acc -> match (either : _ Either.t) with | First x -> x :: acc | Second _ -> acc) in let ys = Array.fold_right array ~init:[] ~f:(fun either acc -> match (either : _ Either.t) with | First _ -> acc | Second x -> x :: acc) in of_list xs, of_list ys ;; let partition_tf t ~f = partition_map t ~f:(fun x -> if f x then First x else Second x) [@nontail] ;; end module Make_with_creators (T : Make_with_creators_arg) = struct include Make_gen_with_creators (struct include T type ('a, _) t = 'a T.t type 'a elt = 'a type ('a, _) concat = 'a T.t let concat_of_array = of_array end) end module Make0_with_creators (T : Make0_with_creators_arg) = struct include Make_gen_with_creators (struct include T type ('a, _) t = T.t type 'a elt = T.Elt.t type ('a, _) concat = 'a list let concat_of_array = Array.to_list end) let mem t x = mem t x ~equal:T.Elt.equal end base-0.16.3/src/container.mli000066400000000000000000000000601446274340700157760ustar00rootroot00000000000000include Container_intf.Container (** @inline *) base-0.16.3/src/container_intf.ml000066400000000000000000000665161446274340700166670ustar00rootroot00000000000000(** Provides generic signatures for container data structures. These signatures include functions ([iter], [fold], [exists], [for_all], ...) that you would expect to find in any container. Used by including [Container.S0] or [Container.S1] in the signature for every container-like data structure ([Array], [List], [String], ...) to ensure a consistent interface. *) open! Import module Export = struct (** [Continue_or_stop.t] is used by the [f] argument to [fold_until] in order to indicate whether folding should continue, or stop early. @canonical Base.Container.Continue_or_stop *) module Continue_or_stop = struct type ('a, 'b) t = | Continue of 'a | Stop of 'b end end include Export (** @canonical Base.Container.Summable *) module type Summable = sig type t (** The result of summing no values. *) val zero : t (** An operation that combines two [t]'s and handles [zero + x] by just returning [x], as well as in the symmetric case. *) val ( + ) : t -> t -> t end (** Signature for monomorphic container - a container for a specific element type, e.g., string, which is a container of characters ([type elt = char]) and never of anything else. *) module type S0 = sig type t type elt (** Checks whether the provided element is there, using equality on [elt]s. *) val mem : t -> elt -> bool val length : t -> int val is_empty : t -> bool (** [iter] must allow exceptions raised in [f] to escape, terminating the iteration cleanly. The same holds for all functions below taking an [f]. *) val iter : t -> f:((elt -> unit)[@local]) -> unit (** [fold t ~init ~f] returns [f (... f (f (f init e1) e2) e3 ...) en], where [e1..en] are the elements of [t]. *) val fold : t -> init:'acc -> f:(('acc -> elt -> 'acc)[@local]) -> 'acc (** [fold_result t ~init ~f] is a short-circuiting version of [fold] that runs in the [Result] monad. If [f] returns an [Error _], that value is returned without any additional invocations of [f]. *) val fold_result : t -> init:'acc -> f:(('acc -> elt -> ('acc, 'e) Result.t)[@local]) -> ('acc, 'e) Result.t (** [fold_until t ~init ~f ~finish] is a short-circuiting version of [fold]. If [f] returns [Stop _] the computation ceases and results in that value. If [f] returns [Continue _], the fold will proceed. If [f] never returns [Stop _], the final result is computed by [finish]. Example: {[ type maybe_negative = | Found_negative of int | All_nonnegative of { sum : int } (** [first_neg_or_sum list] returns the first negative number in [list], if any, otherwise returns the sum of the list. *) let first_neg_or_sum = List.fold_until ~init:0 ~f:(fun sum x -> if x < 0 then Stop (Found_negative x) else Continue (sum + x)) ~finish:(fun sum -> All_nonnegative { sum }) ;; let x = first_neg_or_sum [1; 2; 3; 4; 5] val x : maybe_negative = All_nonnegative {sum = 15} let y = first_neg_or_sum [1; 2; -3; 4; 5] val y : maybe_negative = Found_negative -3 ]} *) val fold_until : t -> init:'acc -> f:(('acc -> elt -> ('acc, 'final) Continue_or_stop.t)[@local]) -> finish:(('acc -> 'final)[@local]) -> 'final (** Returns [true] if and only if there exists an element for which the provided function evaluates to [true]. This is a short-circuiting operation. *) val exists : t -> f:((elt -> bool)[@local]) -> bool (** Returns [true] if and only if the provided function evaluates to [true] for all elements. This is a short-circuiting operation. *) val for_all : t -> f:((elt -> bool)[@local]) -> bool (** Returns the number of elements for which the provided function evaluates to true. *) val count : t -> f:((elt -> bool)[@local]) -> int (** Returns the sum of [f i] for all [i] in the container. *) val sum : (module Summable with type t = 'sum) -> t -> f:((elt -> 'sum)[@local]) -> 'sum (** Returns as an [option] the first element for which [f] evaluates to true. *) val find : t -> f:((elt -> bool)[@local]) -> elt option (** Returns the first evaluation of [f] that returns [Some], and returns [None] if there is no such element. *) val find_map : t -> f:((elt -> 'a option)[@local]) -> 'a option val to_list : t -> elt list val to_array : t -> elt array (** Returns a min (resp. max) element from the collection using the provided [compare] function. In case of a tie, the first element encountered while traversing the collection is returned. The implementation uses [fold] so it has the same complexity as [fold]. Returns [None] iff the collection is empty. *) val min_elt : t -> compare:((elt -> elt -> int)[@local]) -> elt option val max_elt : t -> compare:((elt -> elt -> int)[@local]) -> elt option end module type S0_phantom = sig type elt type 'a t (** Checks whether the provided element is there, using equality on [elt]s. *) val mem : _ t -> elt -> bool val length : _ t -> int val is_empty : _ t -> bool val iter : _ t -> f:((elt -> unit)[@local]) -> unit (** [fold t ~init ~f] returns [f (... f (f (f init e1) e2) e3 ...) en], where [e1..en] are the elements of [t]. *) val fold : _ t -> init:'acc -> f:(('acc -> elt -> 'acc)[@local]) -> 'acc (** [fold_result t ~init ~f] is a short-circuiting version of [fold] that runs in the [Result] monad. If [f] returns an [Error _], that value is returned without any additional invocations of [f]. *) val fold_result : _ t -> init:'acc -> f:(('acc -> elt -> ('acc, 'e) Result.t)[@local]) -> ('acc, 'e) Result.t (** [fold_until t ~init ~f ~finish] is a short-circuiting version of [fold]. If [f] returns [Stop _] the computation ceases and results in that value. If [f] returns [Continue _], the fold will proceed. If [f] never returns [Stop _], the final result is computed by [finish]. Example: {[ type maybe_negative = | Found_negative of int | All_nonnegative of { sum : int } (** [first_neg_or_sum list] returns the first negative number in [list], if any, otherwise returns the sum of the list. *) let first_neg_or_sum = List.fold_until ~init:0 ~f:(fun sum x -> if x < 0 then Stop (Found_negative x) else Continue (sum + x)) ~finish:(fun sum -> All_nonnegative { sum }) ;; let x = first_neg_or_sum [1; 2; 3; 4; 5] val x : maybe_negative = All_nonnegative {sum = 15} let y = first_neg_or_sum [1; 2; -3; 4; 5] val y : maybe_negative = Found_negative -3 ]} *) val fold_until : _ t -> init:'acc -> f:(('acc -> elt -> ('acc, 'final) Continue_or_stop.t)[@local]) -> finish:(('acc -> 'final)[@local]) -> 'final (** Returns [true] if and only if there exists an element for which the provided function evaluates to [true]. This is a short-circuiting operation. *) val exists : _ t -> f:((elt -> bool)[@local]) -> bool (** Returns [true] if and only if the provided function evaluates to [true] for all elements. This is a short-circuiting operation. *) val for_all : _ t -> f:((elt -> bool)[@local]) -> bool (** Returns the number of elements for which the provided function evaluates to true. *) val count : _ t -> f:((elt -> bool)[@local]) -> int (** Returns the sum of [f i] for all [i] in the container. The order in which the elements will be summed is unspecified. *) val sum : (module Summable with type t = 'sum) -> _ t -> f:((elt -> 'sum)[@local]) -> 'sum (** Returns as an [option] the first element for which [f] evaluates to true. *) val find : _ t -> f:((elt -> bool)[@local]) -> elt option (** Returns the first evaluation of [f] that returns [Some], and returns [None] if there is no such element. *) val find_map : _ t -> f:((elt -> 'a option)[@local]) -> 'a option val to_list : _ t -> elt list val to_array : _ t -> elt array (** Returns a min (resp max) element from the collection using the provided [compare] function, or [None] if the collection is empty. In case of a tie, the first element encountered while traversing the collection is returned. *) val min_elt : _ t -> compare:((elt -> elt -> int)[@local]) -> elt option val max_elt : _ t -> compare:((elt -> elt -> int)[@local]) -> elt option end (** Signature for polymorphic container, e.g., ['a list] or ['a array]. *) module type S1 = sig type 'a t (** Checks whether the provided element is there, using [equal]. *) val mem : 'a t -> 'a -> equal:(('a -> 'a -> bool)[@local]) -> bool val length : 'a t -> int val is_empty : 'a t -> bool val iter : 'a t -> f:(('a -> unit)[@local]) -> unit (** [fold t ~init ~f] returns [f (... f (f (f init e1) e2) e3 ...) en], where [e1..en] are the elements of [t] *) val fold : 'a t -> init:'acc -> f:(('acc -> 'a -> 'acc)[@local]) -> 'acc (** [fold_result t ~init ~f] is a short-circuiting version of [fold] that runs in the [Result] monad. If [f] returns an [Error _], that value is returned without any additional invocations of [f]. *) val fold_result : 'a t -> init:'acc -> f:(('acc -> 'a -> ('acc, 'e) Result.t)[@local]) -> ('acc, 'e) Result.t (** [fold_until t ~init ~f ~finish] is a short-circuiting version of [fold]. If [f] returns [Stop _] the computation ceases and results in that value. If [f] returns [Continue _], the fold will proceed. If [f] never returns [Stop _], the final result is computed by [finish]. Example: {[ type maybe_negative = | Found_negative of int | All_nonnegative of { sum : int } (** [first_neg_or_sum list] returns the first negative number in [list], if any, otherwise returns the sum of the list. *) let first_neg_or_sum = List.fold_until ~init:0 ~f:(fun sum x -> if x < 0 then Stop (Found_negative x) else Continue (sum + x)) ~finish:(fun sum -> All_nonnegative { sum }) ;; let x = first_neg_or_sum [1; 2; 3; 4; 5] val x : maybe_negative = All_nonnegative {sum = 15} let y = first_neg_or_sum [1; 2; -3; 4; 5] val y : maybe_negative = Found_negative -3 ]} *) val fold_until : 'a t -> init:'acc -> f:(('acc -> 'a -> ('acc, 'final) Continue_or_stop.t)[@local]) -> finish:(('acc -> 'final)[@local]) -> 'final (** Returns [true] if and only if there exists an element for which the provided function evaluates to [true]. This is a short-circuiting operation. *) val exists : 'a t -> f:(('a -> bool)[@local]) -> bool (** Returns [true] if and only if the provided function evaluates to [true] for all elements. This is a short-circuiting operation. *) val for_all : 'a t -> f:(('a -> bool)[@local]) -> bool (** Returns the number of elements for which the provided function evaluates to true. *) val count : 'a t -> f:(('a -> bool)[@local]) -> int (** Returns the sum of [f i] for all [i] in the container. *) val sum : (module Summable with type t = 'sum) -> 'a t -> f:(('a -> 'sum)[@local]) -> 'sum (** Returns as an [option] the first element for which [f] evaluates to true. *) val find : 'a t -> f:(('a -> bool)[@local]) -> 'a option (** Returns the first evaluation of [f] that returns [Some], and returns [None] if there is no such element. *) val find_map : 'a t -> f:(('a -> 'b option)[@local]) -> 'b option val to_list : 'a t -> 'a list val to_array : 'a t -> 'a array (** Returns a minimum (resp maximum) element from the collection using the provided [compare] function, or [None] if the collection is empty. In case of a tie, the first element encountered while traversing the collection is returned. The implementation uses [fold] so it has the same complexity as [fold]. *) val min_elt : 'a t -> compare:(('a -> 'a -> int)[@local]) -> 'a option val max_elt : 'a t -> compare:(('a -> 'a -> int)[@local]) -> 'a option end module type S1_phantom = sig type ('a, 'phantom) t (** Checks whether the provided element is there, using [equal]. *) val mem : ('a, _) t -> 'a -> equal:(('a -> 'a -> bool)[@local]) -> bool val length : (_, _) t -> int val is_empty : (_, _) t -> bool val iter : ('a, _) t -> f:(('a -> unit)[@local]) -> unit (** [fold t ~init ~f] returns [f (... f (f (f init e1) e2) e3 ...) en], where [e1..en] are the elements of [t]. *) val fold : ('a, _) t -> init:'acc -> f:(('acc -> 'a -> 'acc)[@local]) -> 'acc (** [fold_result t ~init ~f] is a short-circuiting version of [fold] that runs in the [Result] monad. If [f] returns an [Error _], that value is returned without any additional invocations of [f]. *) val fold_result : ('a, _) t -> init:'acc -> f:(('acc -> 'a -> ('acc, 'e) Result.t)[@local]) -> ('acc, 'e) Result.t (** [fold_until t ~init ~f ~finish] is a short-circuiting version of [fold]. If [f] returns [Stop _] the computation ceases and results in that value. If [f] returns [Continue _], the fold will proceed. If [f] never returns [Stop _], the final result is computed by [finish]. Example: {[ type maybe_negative = | Found_negative of int | All_nonnegative of { sum : int } (** [first_neg_or_sum list] returns the first negative number in [list], if any, otherwise returns the sum of the list. *) let first_neg_or_sum = List.fold_until ~init:0 ~f:(fun sum x -> if x < 0 then Stop (Found_negative x) else Continue (sum + x)) ~finish:(fun sum -> All_nonnegative { sum }) ;; let x = first_neg_or_sum [1; 2; 3; 4; 5] val x : maybe_negative = All_nonnegative {sum = 15} let y = first_neg_or_sum [1; 2; -3; 4; 5] val y : maybe_negative = Found_negative -3 ]} *) val fold_until : ('a, _) t -> init:'acc -> f:(('acc -> 'a -> ('acc, 'final) Continue_or_stop.t)[@local]) -> finish:(('acc -> 'final)[@local]) -> 'final (** Returns [true] if and only if there exists an element for which the provided function evaluates to [true]. This is a short-circuiting operation. *) val exists : ('a, _) t -> f:(('a -> bool)[@local]) -> bool (** Returns [true] if and only if the provided function evaluates to [true] for all elements. This is a short-circuiting operation. *) val for_all : ('a, _) t -> f:(('a -> bool)[@local]) -> bool (** Returns the number of elements for which the provided function evaluates to true. *) val count : ('a, _) t -> f:(('a -> bool)[@local]) -> int (** Returns the sum of [f i] for all [i] in the container. *) val sum : (module Summable with type t = 'sum) -> ('a, _) t -> f:(('a -> 'sum)[@local]) -> 'sum (** Returns as an [option] the first element for which [f] evaluates to true. *) val find : ('a, _) t -> f:(('a -> bool)[@local]) -> 'a option (** Returns the first evaluation of [f] that returns [Some], and returns [None] if there is no such element. *) val find_map : ('a, _) t -> f:(('a -> 'b option)[@local]) -> 'b option val to_list : ('a, _) t -> 'a list val to_array : ('a, _) t -> 'a array (** Returns a min (resp max) element from the collection using the provided [compare] function. In case of a tie, the first element encountered while traversing the collection is returned. The implementation uses [fold] so it has the same complexity as [fold]. Returns [None] iff the collection is empty. *) val min_elt : ('a, _) t -> compare:(('a -> 'a -> int)[@local]) -> 'a option val max_elt : ('a, _) t -> compare:(('a -> 'a -> int)[@local]) -> 'a option end module type Generic = sig type ('a, 'phantom) t type 'a elt val length : (_, _) t -> int val is_empty : (_, _) t -> bool val mem : ('a, _) t -> 'a elt -> equal:(('a elt -> 'a elt -> bool)[@local]) -> bool val iter : ('a, _) t -> f:(('a elt -> unit)[@local]) -> unit val fold : ('a, _) t -> init:'acc -> f:(('acc -> 'a elt -> 'acc)[@local]) -> 'acc val fold_result : ('a, _) t -> init:'acc -> f:(('acc -> 'a elt -> ('acc, 'e) Result.t)[@local]) -> ('acc, 'e) Result.t val fold_until : ('a, _) t -> init:'acc -> f:(('acc -> 'a elt -> ('acc, 'final) Continue_or_stop.t)[@local]) -> finish:(('acc -> 'final)[@local]) -> 'final val exists : ('a, _) t -> f:(('a elt -> bool)[@local]) -> bool val for_all : ('a, _) t -> f:(('a elt -> bool)[@local]) -> bool val count : ('a, _) t -> f:(('a elt -> bool)[@local]) -> int val sum : (module Summable with type t = 'sum) -> ('a, _) t -> f:(('a elt -> 'sum)[@local]) -> 'sum val find : ('a, _) t -> f:(('a elt -> bool)[@local]) -> 'a elt option val find_map : ('a, _) t -> f:(('a elt -> 'b option)[@local]) -> 'b option val to_list : ('a, _) t -> 'a elt list val to_array : ('a, _) t -> 'a elt array val min_elt : ('a, _) t -> compare:(('a elt -> 'a elt -> int)[@local]) -> 'a elt option val max_elt : ('a, _) t -> compare:(('a elt -> 'a elt -> int)[@local]) -> 'a elt option end module type S0_with_creators = sig include S0 val of_list : elt list -> t val of_array : elt array -> t (** E.g., [append (of_list [a; b]) (of_list [c; d; e])] is [of_list [a; b; c; d; e]] *) val append : t -> t -> t (** Concatenates a nested container. The elements of the inner containers are concatenated together in order to give the result. *) val concat : t list -> t (** [map f (of_list [a1; ...; an])] applies [f] to [a1], [a2], ..., [an], in order, and builds a result equivalent to [of_list [f a1; ...; f an]]. *) val map : t -> f:((elt -> elt)[@local]) -> t (** [filter t ~f] returns all the elements of [t] that satisfy the predicate [f]. *) val filter : t -> f:((elt -> bool)[@local]) -> t (** [filter_map t ~f] applies [f] to every [x] in [t]. The result contains every [y] for which [f x] returns [Some y]. *) val filter_map : t -> f:((elt -> elt option)[@local]) -> t (** [concat_map t ~f] is equivalent to [concat (map t ~f)]. *) val concat_map : t -> f:((elt -> t)[@local]) -> t (** [partition_tf t ~f] returns a pair [t1, t2], where [t1] is all elements of [t] that satisfy [f], and [t2] is all elements of [t] that do not satisfy [f]. The "tf" suffix is mnemonic to remind readers that the result is (trues, falses). *) val partition_tf : t -> f:((elt -> bool)[@local]) -> t * t (** [partition_map t ~f] partitions [t] according to [f]. *) val partition_map : t -> f:((elt -> (elt, elt) Either0.t)[@local]) -> t * t end module type S1_with_creators = sig include S1 val of_list : 'a list -> 'a t val of_array : 'a array -> 'a t (** E.g., [append (of_list [1; 2]) (of_list [3; 4; 5])] is [of_list [1; 2; 3; 4; 5]] *) val append : 'a t -> 'a t -> 'a t (** Concatenates a nested container. The elements of the inner containers are concatenated together in order to give the result. *) val concat : 'a t t -> 'a t (** [map f (of_list [a1; ...; an])] applies [f] to [a1], [a2], ..., [an], in order, and builds a result equivalent to [of_list [f a1; ...; f an]]. *) val map : 'a t -> f:(('a -> 'b)[@local]) -> 'b t (** [filter t ~f] returns all the elements of [t] that satisfy the predicate [f]. *) val filter : 'a t -> f:(('a -> bool)[@local]) -> 'a t (** [filter_map t ~f] applies [f] to every [x] in [t]. The result contains every [y] for which [f x] returns [Some y]. *) val filter_map : 'a t -> f:(('a -> 'b option)[@local]) -> 'b t (** [concat_map t ~f] is equivalent to [concat (map t ~f)]. *) val concat_map : 'a t -> f:(('a -> 'b t)[@local]) -> 'b t (** [partition_tf t ~f] returns a pair [t1, t2], where [t1] is all elements of [t] that satisfy [f], and [t2] is all elements of [t] that do not satisfy [f]. The "tf" suffix is mnemonic to remind readers that the result is (trues, falses). *) val partition_tf : 'a t -> f:(('a -> bool)[@local]) -> 'a t * 'a t (** [partition_map t ~f] partitions [t] according to [f]. *) val partition_map : 'a t -> f:(('a -> ('b, 'c) Either0.t)[@local]) -> 'b t * 'c t end module type Generic_with_creators = sig type (_, _) concat include Generic val of_list : 'a elt list -> ('a, _) t val of_array : 'a elt array -> ('a, _) t val append : ('a, 'p) t -> ('a, 'p) t -> ('a, 'p) t val concat : (('a, 'p) t, 'p) concat -> ('a, 'p) t val map : ('a, 'p) t -> f:(('a elt -> 'b elt)[@local]) -> ('b, 'p) t val filter : ('a, 'p) t -> f:(('a elt -> bool)[@local]) -> ('a, 'p) t val filter_map : ('a, 'p) t -> f:(('a elt -> 'b elt option)[@local]) -> ('b, 'p) t val concat_map : ('a, 'p) t -> f:(('a elt -> ('b, 'p) t)[@local]) -> ('b, 'p) t val partition_tf : ('a, 'p) t -> f:(('a elt -> bool)[@local]) -> ('a, 'p) t * ('a, 'p) t val partition_map : ('a, 'p) t -> f:(('a elt -> ('b elt, 'c elt) Either0.t)[@local]) -> ('b, 'p) t * ('c, 'p) t end module type Make_gen_arg = sig type ('a, 'phantom) t type 'a elt val fold : ('a, 'phantom) t -> init:'acc -> f:(('acc -> 'a elt -> 'acc)[@local]) -> 'acc (** The [iter] argument to [Container.Make] specifies how to implement the container's [iter] function. [`Define_using_fold] means to define [iter] via: {[ iter t ~f = Container.iter ~fold t ~f ]} [`Custom] overrides the default implementation, presumably with something more efficient. Several other functions returned by [Container.Make] are defined in terms of [iter], so passing in a more efficient [iter] will improve their efficiency as well. *) val iter : [ `Define_using_fold | `Custom of ('a, 'phantom) t -> f:(('a elt -> unit)[@local]) -> unit ] (** The [length] argument to [Container.Make] specifies how to implement the container's [length] function. [`Define_using_fold] means to define [length] via: {[ length t ~f = Container.length ~fold t ~f ]} [`Custom] overrides the default implementation, presumably with something more efficient. Several other functions returned by [Container.Make] are defined in terms of [length], so passing in a more efficient [length] will improve their efficiency as well. *) val length : [ `Define_using_fold | `Custom of ('a, 'phantom) t -> int ] end module type Make_arg = sig type 'a t include Make_gen_arg with type ('a, _) t := 'a t and type 'a elt := 'a end module type Make0_arg = sig module Elt : sig type t val equal : t -> t -> bool end type t include Make_gen_arg with type ('a, _) t := t and type 'a elt := Elt.t end module type Make_common_with_creators_arg = sig include Make_gen_arg type (_, _) concat val of_list : 'a elt list -> ('a, _) t val of_array : 'a elt array -> ('a, _) t val concat : (('a, _) t, _) concat -> ('a, _) t end module type Make_gen_with_creators_arg = sig include Make_common_with_creators_arg val concat_of_array : 'a array -> ('a, _) concat end module type Make_with_creators_arg = sig type 'a t include Make_common_with_creators_arg with type ('a, _) t := 'a t and type 'a elt := 'a and type ('a, _) concat := 'a t end module type Make0_with_creators_arg = sig module Elt : sig type t val equal : t -> t -> bool end type t include Make_common_with_creators_arg with type ('a, _) t := t and type 'a elt := Elt.t and type ('a, _) concat := 'a list end module type Derived = sig (** Generic definitions of container operations in terms of [fold]. E.g.: [iter ~fold t ~f = fold t ~init:() ~f:(fun () a -> f a)]. *) type ('t, 'a, 'acc) fold = 't -> init:'acc -> f:(('acc -> 'a -> 'acc)[@local]) -> 'acc type ('t, 'a) iter = 't -> f:(('a -> unit)[@local]) -> unit type 't length = 't -> int val iter : fold:('t, 'a, unit) fold -> ('t, 'a) iter val count : fold:('t, 'a, int) fold -> 't -> f:(('a -> bool)[@local]) -> int val min_elt : fold:('t, 'a, 'a option) fold -> 't -> compare:(('a -> 'a -> int)[@local]) -> 'a option val max_elt : fold:('t, 'a, 'a option) fold -> 't -> compare:(('a -> 'a -> int)[@local]) -> 'a option val length : fold:('t, _, int) fold -> 't -> int val to_list : fold:('t, 'a, 'a list) fold -> 't -> 'a list val sum : fold:('t, 'a, 'sum) fold -> (module Summable with type t = 'sum) -> 't -> f:(('a -> 'sum)[@local]) -> 'sum val fold_result : fold:('t, 'a, 'acc) fold -> init:'acc -> f:(('acc -> 'a -> ('acc, 'e) Result.t)[@local]) -> 't -> ('acc, 'e) Result.t val fold_until : fold:('t, 'a, 'acc) fold -> init:'acc -> f:(('acc -> 'a -> ('acc, 'final) Continue_or_stop.t)[@local]) -> finish:(('acc -> 'final)[@local]) -> 't -> 'final (** Generic definitions of container operations in terms of [iter] and [length]. *) val is_empty : iter:('t, 'a) iter -> 't -> bool val mem : iter:('t, 'a) iter -> 't -> 'a -> equal:(('a -> 'a -> bool)[@local]) -> bool val exists : iter:('t, 'a) iter -> 't -> f:(('a -> bool)[@local]) -> bool val for_all : iter:('t, 'a) iter -> 't -> f:(('a -> bool)[@local]) -> bool val find : iter:('t, 'a) iter -> 't -> f:(('a -> bool)[@local]) -> 'a option val find_map : iter:('t, 'a) iter -> 't -> f:(('a -> 'b option)[@local]) -> 'b option val to_array : length:'t length -> iter:('t, 'a) iter -> 't -> 'a array end module type Container = sig include module type of struct include Export end module type S0 = S0 module type S0_phantom = S0_phantom module type S0_with_creators = S0_with_creators module type S1 = S1 module type S1_phantom = S1_phantom module type S1_with_creators = S1_with_creators module type Derived = Derived module type Generic = Generic module type Generic_with_creators = Generic_with_creators module type Summable = Summable include Derived (** The idiom for using [Container.Make] is to bind the resulting module and to explicitly import each of the functions that one wants: {[ module C = Container.Make (struct ... end) let count = C.count let exists = C.exists let find = C.find (* ... *) ]} This is preferable to: {[ include Container.Make (struct ... end) ]} because the [include] makes it too easy to shadow specialized implementations of container functions ([length] being a common one). [Container.Make0] is like [Container.Make], but for monomorphic containers like [string]. *) module Make (T : Make_arg) : S1 with type 'a t := 'a T.t module Make0 (T : Make0_arg) : S0 with type t := T.t and type elt := T.Elt.t module Make_gen (T : Make_gen_arg) : Generic with type ('a, 'phantom) t := ('a, 'phantom) T.t and type 'a elt := 'a T.elt module Make_with_creators (T : Make_with_creators_arg) : S1_with_creators with type 'a t := 'a T.t module Make0_with_creators (T : Make0_with_creators_arg) : S0_with_creators with type t := T.t and type elt := T.Elt.t module Make_gen_with_creators (T : Make_gen_with_creators_arg) : Generic_with_creators with type ('a, 'phantom) t := ('a, 'phantom) T.t and type 'a elt := 'a T.elt and type ('a, 'phantom) concat := ('a, 'phantom) T.concat end base-0.16.3/src/discover/000077500000000000000000000000001446274340700151335ustar00rootroot00000000000000base-0.16.3/src/discover/discover.ml000066400000000000000000000006261446274340700173070ustar00rootroot00000000000000open Configurator.V1 let program = {| int main(int argc, char ** argv) { return __builtin_popcount(argc); } |} ;; let () = let output = ref "" in main ~name:"discover" ~args:[ "-o", Set_string output, "FILENAME output file" ] (fun c -> let has_popcnt = c_test c ~c_flags:[ "-mpopcnt" ] program in Flags.write_sexp !output (if has_popcnt then [ "-mpopcnt" ] else [])) ;; base-0.16.3/src/discover/discover.mli000066400000000000000000000000141446274340700174470ustar00rootroot00000000000000(* empty *) base-0.16.3/src/discover/dune000066400000000000000000000001331446274340700160060ustar00rootroot00000000000000(executables (names discover) (libraries dune-configurator) (preprocess no_preprocessing))base-0.16.3/src/dune000066400000000000000000000020351446274340700141730ustar00rootroot00000000000000(rule (targets random_repr.ml) (deps (:first_dep select-random-repr/select.ml)) (action (run %{ocaml} %{first_dep} -ocaml-version %{ocaml_version} -o %{targets}))) (rule (targets pow_overflow_bounds.ml) (deps (:first_dep ../generate/generate_pow_overflow_bounds.exe)) (action (run %{first_dep} -atomic -o %{targets})) (mode fallback)) (library (name base) (public_name base) (ocamlopt_flags :standard (:include ocamlopt-flags)) (libraries base_internalhash_types caml sexplib0 shadow_stdlib) (c_flags :standard -D_LARGEFILE64_SOURCE (:include mpopcnt.sexp)) (c_names bytes_stubs exn_stubs int_math_stubs hash_stubs am_testing) (preprocess no_preprocessing) (lint (pps ppx_base ppx_base_lint -check-doc-comments -type-conv-keep-w32=both -apply=js_style,base_lint,type_conv,cold)) (js_of_ocaml (javascript_files runtime.js))) (rule (targets mpopcnt.sexp) (action (run ./discover/discover.exe -o %{targets}))) (ocamllex hex_lexer) (documentation) (rule (targets ocamlopt-flags) (deps) (action (bash "echo '()' > ocamlopt-flags")))base-0.16.3/src/either.ml000066400000000000000000000112421446274340700151270ustar00rootroot00000000000000open! Import include Either_intf module List = List0 include Either0 let swap = function | First x -> Second x | Second x -> First x ;; let is_first = function | First _ -> true | Second _ -> false ;; let is_second = function | First _ -> false | Second _ -> true ;; let value (First x | Second x) = x let value_map t ~first ~second = match t with | First x -> first x | Second x -> second x ;; let iter = value_map let map t ~first ~second = match t with | First x -> First (first x) | Second x -> Second (second x) ;; let first x = First x let second x = Second x let equal eq1 eq2 t1 t2 = match t1, t2 with | First x, First y -> eq1 x y | Second x, Second y -> eq2 x y | First _, Second _ | Second _, First _ -> false ;; let invariant f s = function | First x -> f x | Second y -> s y ;; module Focus = struct type ('a, 'b) t = | Focus of { value : 'a [@global] } | Other of { value : 'b [@global] } end module Make_focused (M : sig type (+'a, +'b) t val return : 'a -> ('a, _) t val other : 'b -> (_, 'b) t val focus : ('a, 'b) t -> (('a, 'b) Focus.t[@local]) val combine : ('a, 'd) t -> ('b, 'd) t -> f:(('a -> 'b -> 'c)[@local]) -> other:(('d -> 'd -> 'd)[@local]) -> ('c, 'd) t val bind : ('a, 'b) t -> f:(('a -> ('c, 'b) t)[@local]) -> ('c, 'b) t end) = struct include M open With_return let map t ~f = let res = bind t ~f:(fun x -> return (f x)) in res ;; include Monad.Make2_local (struct type nonrec ('a, 'b) t = ('a, 'b) t let return = return let bind = bind let map = `Custom map end) module App = Applicative.Make2_using_map2_local (struct type nonrec ('a, 'b) t = ('a, 'b) t let return = return let map = `Custom map let map2 : ('a, 'x) t -> ('b, 'x) t -> f:(('a -> 'b -> 'c)[@local]) -> ('c, 'x) t = fun t1 t2 ~f -> bind t1 ~f:(fun x -> bind t2 ~f:(fun y -> return (f x y)) [@nontail]) [@nontail] ;; end) include App let combine_all = let rec other_loop f acc = function | [] -> other acc | t :: ts -> (match focus t with | Focus _ -> other_loop f acc ts | Other o -> other_loop f (f acc o.value) ts) in let rec return_loop f acc = function | [] -> return (List.rev acc) | t :: ts -> (match focus t with | Focus x -> return_loop f (x.value :: acc) ts | Other o -> other_loop f o.value ts) in fun ts ~f -> return_loop f [] ts ;; let combine_all_unit = let rec other_loop f acc = function | [] -> other acc | t :: ts -> (match focus t with | Focus _ -> other_loop f acc ts | Other o -> other_loop f (f acc o.value) ts) in let rec return_loop f = function | [] -> return () | t :: ts -> (match focus t with | Focus { value = () } -> return_loop f ts | Other { value = o } -> other_loop f o ts) in fun ts ~f -> return_loop f ts ;; let to_option t = match focus t with | Focus x -> Some x.value | Other _ -> None ;; let value t ~default = match focus t with | Focus x -> x.value | Other _ -> default ;; let with_return f = with_return (fun ret -> other (f (With_return.prepend ret ~f:return))) [@nontail] ;; end module First = Make_focused (struct type nonrec ('a, 'b) t = ('a, 'b) t let return = first let other = second let focus t : _ Focus.t = match t with | First x -> Focus { value = x } | Second y -> Other { value = y } ;; let combine t1 t2 ~f ~other = match t1, t2 with | First x, First y -> First (f x y) | Second x, Second y -> Second (other x y) | Second x, _ | _, Second x -> Second x ;; let bind t ~f = match t with | First x -> f x (* Reuse the value in order to avoid allocation. *) | Second _ as y -> y ;; end) module Second = Make_focused (struct type nonrec ('a, 'b) t = ('b, 'a) t let return = second let other = first let focus t : _ Focus.t = match t with | Second x -> Focus { value = x } | First y -> Other { value = y } ;; let combine t1 t2 ~f ~other = match t1, t2 with | Second x, Second y -> Second (f x y) | First x, First y -> First (other x y) | First x, _ | _, First x -> First x ;; let bind t ~f = match t with | Second x -> f x (* Reuse the value in order to avoid allocation, like [First.bind] above. *) | First _ as y -> y ;; end) module Export = struct type ('f, 's) _either = ('f, 's) t = | First of 'f | Second of 's end base-0.16.3/src/either.mli000066400000000000000000000000521446274340700152750ustar00rootroot00000000000000include Either_intf.Either (** @inline *) base-0.16.3/src/either0.ml000066400000000000000000000103731446274340700152130ustar00rootroot00000000000000open! Import type ('f, 's) t = | First of 'f | Second of 's [@@deriving_inline compare, hash, sexp, sexp_grammar] let compare : 'f 's. ('f -> 'f -> int) -> ('s -> 's -> int) -> ('f, 's) t -> ('f, 's) t -> int = fun _cmp__f _cmp__s a__001_ b__002_ -> if Stdlib.( == ) a__001_ b__002_ then 0 else ( match a__001_, b__002_ with | First _a__003_, First _b__004_ -> _cmp__f _a__003_ _b__004_ | First _, _ -> -1 | _, First _ -> 1 | Second _a__005_, Second _b__006_ -> _cmp__s _a__005_ _b__006_) ;; let hash_fold_t : type f s. (Ppx_hash_lib.Std.Hash.state -> f -> Ppx_hash_lib.Std.Hash.state) -> (Ppx_hash_lib.Std.Hash.state -> s -> Ppx_hash_lib.Std.Hash.state) -> Ppx_hash_lib.Std.Hash.state -> (f, s) t -> Ppx_hash_lib.Std.Hash.state = fun _hash_fold_f _hash_fold_s hsv arg -> match arg with | First _a0 -> let hsv = Ppx_hash_lib.Std.Hash.fold_int hsv 0 in let hsv = hsv in _hash_fold_f hsv _a0 | Second _a0 -> let hsv = Ppx_hash_lib.Std.Hash.fold_int hsv 1 in let hsv = hsv in _hash_fold_s hsv _a0 ;; let t_of_sexp : 'f 's. (Sexplib0.Sexp.t -> 'f) -> (Sexplib0.Sexp.t -> 's) -> Sexplib0.Sexp.t -> ('f, 's) t = fun (type f__023_ s__024_) : ((Sexplib0.Sexp.t -> f__023_) -> (Sexplib0.Sexp.t -> s__024_) -> Sexplib0.Sexp.t -> (f__023_, s__024_) t) -> let error_source__011_ = "either0.ml.t" in fun _of_f__007_ _of_s__008_ -> function | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom (("first" | "First") as _tag__014_) :: sexp_args__015_) as _sexp__013_ -> (match sexp_args__015_ with | [ arg0__016_ ] -> let res0__017_ = _of_f__007_ arg0__016_ in First res0__017_ | _ -> Sexplib0.Sexp_conv_error.stag_incorrect_n_args error_source__011_ _tag__014_ _sexp__013_) | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom (("second" | "Second") as _tag__019_) :: sexp_args__020_) as _sexp__018_ -> (match sexp_args__020_ with | [ arg0__021_ ] -> let res0__022_ = _of_s__008_ arg0__021_ in Second res0__022_ | _ -> Sexplib0.Sexp_conv_error.stag_incorrect_n_args error_source__011_ _tag__019_ _sexp__018_) | Sexplib0.Sexp.Atom ("first" | "First") as sexp__012_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__011_ sexp__012_ | Sexplib0.Sexp.Atom ("second" | "Second") as sexp__012_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__011_ sexp__012_ | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__010_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__011_ sexp__010_ | Sexplib0.Sexp.List [] as sexp__010_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__011_ sexp__010_ | sexp__010_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__011_ sexp__010_ ;; let sexp_of_t : 'f 's. ('f -> Sexplib0.Sexp.t) -> ('s -> Sexplib0.Sexp.t) -> ('f, 's) t -> Sexplib0.Sexp.t = fun (type f__031_ s__032_) : ((f__031_ -> Sexplib0.Sexp.t) -> (s__032_ -> Sexplib0.Sexp.t) -> (f__031_, s__032_) t -> Sexplib0.Sexp.t) -> fun _of_f__025_ _of_s__026_ -> function | First arg0__027_ -> let res0__028_ = _of_f__025_ arg0__027_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "First"; res0__028_ ] | Second arg0__029_ -> let res0__030_ = _of_s__026_ arg0__029_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Second"; res0__030_ ] ;; let t_sexp_grammar : 'f 's. 'f Sexplib0.Sexp_grammar.t -> 's Sexplib0.Sexp_grammar.t -> ('f, 's) t Sexplib0.Sexp_grammar.t = fun _'f_sexp_grammar _'s_sexp_grammar -> { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "First" ; clause_kind = List_clause { args = Cons (_'f_sexp_grammar.untyped, Empty) } } ; No_tag { name = "Second" ; clause_kind = List_clause { args = Cons (_'s_sexp_grammar.untyped, Empty) } } ] } } ;; [@@@end] base-0.16.3/src/either_intf.ml000066400000000000000000000051631446274340700161540ustar00rootroot00000000000000(** A type that represents values with two possibilities. [Either] can be seen as a generic sum type, the dual of [Tuple]. [First] is neither more important nor less important than [Second]. Many functions in [Either] focus on just one constructor. The [Focused] signature abstracts over which constructor is the focus. To use these functions, use the [First] or [Second] modules in [S]. *) open! Import module type Focused = sig type (+'focus, +'other) t include Monad.S2_local with type ('a, 'b) t := ('a, 'b) t include Applicative.S2_local with type ('a, 'b) t := ('a, 'b) t val value : ('a, _) t -> default:'a -> 'a val to_option : ('a, _) t -> 'a option val with_return : ((('a With_return.return[@local]) -> 'b)[@local]) -> ('a, 'b) t val combine : ('a, 'd) t -> ('b, 'd) t -> f:(('a -> 'b -> 'c)[@local]) -> other:(('d -> 'd -> 'd)[@local]) -> ('c, 'd) t val combine_all : ('a, 'b) t list -> f:(('b -> 'b -> 'b)[@local]) -> ('a list, 'b) t val combine_all_unit : (unit, 'b) t list -> f:(('b -> 'b -> 'b)[@local]) -> (unit, 'b) t end module type Either = sig type ('f, 's) t = ('f, 's) Either0.t = | First of 'f | Second of 's [@@deriving_inline compare, hash, sexp, sexp_grammar] include Ppx_compare_lib.Comparable.S2 with type ('f, 's) t := ('f, 's) t include Ppx_hash_lib.Hashable.S2 with type ('f, 's) t := ('f, 's) t include Sexplib0.Sexpable.S2 with type ('f, 's) t := ('f, 's) t val t_sexp_grammar : 'f Sexplib0.Sexp_grammar.t -> 's Sexplib0.Sexp_grammar.t -> ('f, 's) t Sexplib0.Sexp_grammar.t [@@@end] include Invariant.S2 with type ('a, 'b) t := ('a, 'b) t val swap : ('f, 's) t -> ('s, 'f) t val value : ('a, 'a) t -> 'a val iter : ('a, 'b) t -> first:(('a -> unit)[@local]) -> second:(('b -> unit)[@local]) -> unit val value_map : ('a, 'b) t -> first:(('a -> 'c)[@local]) -> second:(('b -> 'c)[@local]) -> 'c val map : ('a, 'b) t -> first:(('a -> 'c)[@local]) -> second:(('b -> 'd)[@local]) -> ('c, 'd) t val equal : ('f -> 'f -> bool) -> ('s -> 's -> bool) -> ('f, 's) t -> ('f, 's) t -> bool module type Focused = Focused module First : Focused with type ('a, 'b) t = ('a, 'b) t module Second : Focused with type ('a, 'b) t = ('b, 'a) t val is_first : (_, _) t -> bool val is_second : (_, _) t -> bool (** [first] and [second] are [First.return] and [Second.return]. *) val first : 'f -> ('f, _) t val second : 's -> (_, 's) t (**/**) module Export : sig type ('f, 's) _either = ('f, 's) t = | First of 'f | Second of 's end end base-0.16.3/src/equal.ml000066400000000000000000000014441446274340700147610ustar00rootroot00000000000000(** This module defines signatures that are to be included in other signatures to ensure a consistent interface to [equal] functions. There is a signature ([S], [S1], [S2], [S3]) for each arity of type. Usage looks like: {[ type t include Equal.S with type t := t ]} or {[ type 'a t include Equal.S1 with type 'a t := 'a t ]} *) open! Import type 'a t = 'a -> 'a -> bool type 'a equal = 'a t module type S = sig type t val equal : t equal end module type S1 = sig type 'a t val equal : 'a equal -> 'a t equal end module type S2 = sig type ('a, 'b) t val equal : 'a equal -> 'b equal -> ('a, 'b) t equal end module type S3 = sig type ('a, 'b, 'c) t val equal : 'a equal -> 'b equal -> 'c equal -> ('a, 'b, 'c) t equal end base-0.16.3/src/error.ml000066400000000000000000000010141446274340700147740ustar00rootroot00000000000000(* This module is trying to minimize dependencies on modules in Core, so as to allow [Error] and [Or_error] to be used in various places. Please avoid adding new dependencies. *) open! Import include Info let t_sexp_grammar : t Sexplib0.Sexp_grammar.t = { untyped = Any "Error.t" } let raise t = raise (to_exn t) let raise_s sexp = raise (create_s sexp) let to_info t = t let of_info t = t include Pretty_printer.Register_pp (struct type nonrec t = t let module_name = "Base.Error" let pp = pp end) base-0.16.3/src/error.mli000066400000000000000000000005701446274340700151530ustar00rootroot00000000000000(** A lazy string, implemented with [Info], but intended specifically for error messages. *) open! Import include Info_intf.S with type t = private Info.t (** @open *) (** Note that the exception raised by this function maintains a reference to the [t] passed in. *) val raise : t -> _ val raise_s : Sexp.t -> _ val to_info : t -> Info.t val of_info : Info.t -> t base-0.16.3/src/exn.ml000066400000000000000000000114321446274340700144420ustar00rootroot00000000000000open! Import type t = exn [@@deriving_inline sexp_of] let sexp_of_t = (sexp_of_exn : t -> Sexplib0.Sexp.t) [@@@end] let exit = Stdlib.exit exception Finally of t * t [@@deriving_inline sexp] let () = Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Finally] (function | Finally (arg0__001_, arg1__002_) -> let res0__003_ = sexp_of_t arg0__001_ and res1__004_ = sexp_of_t arg1__002_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "exn.ml.Finally"; res0__003_; res1__004_ ] | _ -> assert false) ;; [@@@end] exception Reraised of string * t [@@deriving_inline sexp] let () = Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Reraised] (function | Reraised (arg0__005_, arg1__006_) -> let res0__007_ = sexp_of_string arg0__005_ and res1__008_ = sexp_of_t arg1__006_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "exn.ml.Reraised"; res0__007_; res1__008_ ] | _ -> assert false) ;; [@@@end] exception Sexp of Sexp.t (* We install a custom exn-converter rather than use: {[ exception Sexp of Sexp.t [@@deriving_inline sexp] (* ... *) [@@@end] ]} to eliminate the extra wrapping of [(Sexp ...)]. *) let () = Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Sexp] (function | Sexp t -> t | _ -> (* Reaching this branch indicates a bug in sexplib. *) assert false) ;; let create_s sexp = Sexp sexp let raise_with_original_backtrace t backtrace = Stdlib.Printexc.raise_with_backtrace t backtrace ;; external is_phys_equal_most_recent : t -> bool = "Base_caml_exn_is_most_recent_exn" let reraise exn str = let exn' = Reraised (str, exn) in if is_phys_equal_most_recent exn then ( let bt = Stdlib.Printexc.get_raw_backtrace () in raise_with_original_backtrace exn' bt) else raise exn' ;; let reraisef exc format = Printf.ksprintf (fun str () -> reraise exc str) format let to_string exc = Sexp.to_string_hum ~indent:2 (sexp_of_exn exc) let to_string_mach exc = Sexp.to_string_mach (sexp_of_exn exc) let sexp_of_t = sexp_of_exn let protectx ~f x ~(finally : _ -> unit) = match f x with | res -> finally x; res | exception exn -> let bt = Stdlib.Printexc.get_raw_backtrace () in (match finally x with | () -> raise_with_original_backtrace exn bt | exception final_exn -> (* Unfortunately, the backtrace of the [final_exn] is discarded here. *) raise_with_original_backtrace (Finally (exn, final_exn)) bt) ;; let protect ~f ~finally = protectx ~f () ~finally let does_raise (type a) (f : unit -> a) = try ignore (f () : a); false with | _ -> true ;; include Pretty_printer.Register_pp (struct type t = exn let pp ppf t = match sexp_of_exn_opt t with | Some sexp -> Sexp.pp_hum ppf sexp | None -> Stdlib.Format.pp_print_string ppf (Stdlib.Printexc.to_string t) ;; let module_name = "Base.Exn" end) let print_with_backtrace exc raw_backtrace = Stdlib.Format.eprintf "@[<2>Uncaught exception:@\n@\n@[%a@]@]@\n@." pp exc; if Stdlib.Printexc.backtrace_status () then Stdlib.Printexc.print_raw_backtrace Stdlib.stderr raw_backtrace; Stdlib.flush Stdlib.stderr ;; let set_uncaught_exception_handler () = Stdlib.Printexc.set_uncaught_exception_handler print_with_backtrace ;; let handle_uncaught_aux ~do_at_exit ~exit f = try f () with | exc -> let raw_backtrace = Stdlib.Printexc.get_raw_backtrace () in (* One reason to run [do_at_exit] handlers before printing out the error message is that it helps curses applications bring the terminal in a good state, otherwise the error message might get corrupted. Also, the OCaml top-level uncaught exception handler does the same. *) if do_at_exit then ( try Stdlib.do_at_exit () with | _ -> ()); (try print_with_backtrace exc raw_backtrace with | _ -> (try Stdlib.Printf.eprintf "Exn.handle_uncaught could not print; exiting anyway\n%!" with | _ -> ())); exit 1 ;; let handle_uncaught_and_exit f = handle_uncaught_aux f ~exit ~do_at_exit:true let handle_uncaught ~exit:must_exit f = handle_uncaught_aux f ~exit:(if must_exit then exit else ignore) ~do_at_exit:must_exit ;; let reraise_uncaught str func = try func () with | exn -> let bt = Stdlib.Printexc.get_raw_backtrace () in raise_with_original_backtrace (Reraised (str, exn)) bt ;; external clear_backtrace : unit -> unit = "Base_clear_caml_backtrace_pos" [@@noalloc] let raise_without_backtrace e = (* We clear the backtrace to reduce confusion, so that people don't think whatever is stored corresponds to this raise. *) clear_backtrace (); Stdlib.raise_notrace e ;; let initialize_module () = set_uncaught_exception_handler () module Private = struct let clear_backtrace = clear_backtrace end base-0.16.3/src/exn.mli000066400000000000000000000101701446274340700146110ustar00rootroot00000000000000(** Exceptions. [sexp_of_t] uses a global table of sexp converters. To register a converter for a new exception, add [[@@deriving sexp]] to its definition. If no suitable converter is found, the standard converter in [Printexc] will be used to generate an atomic S-expression. *) open! Import type t = exn [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] include Pretty_printer.S with type t := t (** Raised when finalization after an exception failed, too. The first exception argument is the one raised by the initial function, the second exception the one raised by the finalizer. *) exception Finally of t * t exception Reraised of string * t (** [create_s sexp] returns an exception [t] such that [phys_equal (sexp_of_t t) sexp]. This is useful when one wants to create an exception that serves as a message and the particular exn constructor doesn't matter. *) val create_s : Sexp.t -> t (** Same as [raise], except that the backtrace is not recorded. *) val raise_without_backtrace : t -> _ (** [raise_with_original_backtrace t bt] raises the exception [exn], recording [bt] as the backtrace it was originally raised at. This is useful to re-raise exceptions annotated with extra information. *) val raise_with_original_backtrace : t -> Stdlib.Printexc.raw_backtrace -> _ val reraise : t -> string -> _ (** Types with [format4] are hard to read, so here's an example. {[ let foobar str = try ... with exn -> Exn.reraisef exn "Foobar is buggy on: %s" str () ]} *) val reraisef : t -> ('a, unit, string, unit -> _) format4 -> 'a (** Human-readable, multi-line. *) val to_string : t -> string (** Machine format, single-line. *) val to_string_mach : t -> string (** Executes [f] and afterwards executes [finally], whether [f] throws an exception or not. *) val protectx : f:(('a -> 'b)[@local]) -> 'a -> finally:(('a -> unit)[@local]) -> 'b val protect : f:((unit -> 'a)[@local]) -> finally:((unit -> unit)[@local]) -> 'a (** [handle_uncaught ~exit f] catches an exception escaping [f] and prints an error message to stderr. Exits with return code 1 if [exit] is [true], and returns unit otherwise. Note that since OCaml 4.02.0, you don't need to use this at the entry point of your program, as the OCaml runtime will do better than this function. *) val handle_uncaught : exit:bool -> ((unit -> unit)[@local]) -> unit (** [handle_uncaught_and_exit f] returns [f ()], unless that raises, in which case it prints the exception and exits nonzero. *) val handle_uncaught_and_exit : ((unit -> 'a)[@local]) -> 'a (** Traces exceptions passing through. Useful because in practice, backtraces still don't seem to work. Example: {[ let rogue_function () = if Random.bool () then failwith "foo" else 3 let traced_function () = Exn.reraise_uncaught "rogue_function" rogue_function traced_function ();; ]} {v : Program died with Reraised("rogue_function", Failure "foo") v} *) val reraise_uncaught : string -> ((unit -> 'a)[@local]) -> 'a (** [does_raise f] returns [true] iff [f ()] raises, which is often useful in unit tests. *) val does_raise : ((unit -> _)[@local]) -> bool (** Returns [true] if this exception is physically equal to the most recently raised one. If so, then [Backtrace.Exn.most_recent ()] is a backtrace corresponding to this exception. Note that, confusingly, exceptions can be physically equal even if the caller was not involved in handling of the last-raised exception. See the documentation of [Backtrace.Exn.most_recent_for_exn] for further discussion. *) val is_phys_equal_most_recent : t -> bool (** User code never calls this. It is called in [base.ml] as a top-level side effect to change the display of exceptions and install an uncaught-exception printer. *) val initialize_module : unit -> unit (**/**) (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig val clear_backtrace : unit -> unit end base-0.16.3/src/exn_stubs.c000066400000000000000000000010131446274340700154660ustar00rootroot00000000000000#define CAML_INTERNALS #ifndef CAML_NAME_SPACE #define CAML_NAME_SPACE #endif /* If CAML_NAME_SPACE is not defined, then legacy names like [backtrace_last_exn] are in scope, which can lead to confusing errors. It's cleaner to disable those names. */ #include #include CAMLprim value Base_clear_caml_backtrace_pos() { caml_backtrace_pos = 0; return Val_unit; } CAMLprim value Base_caml_exn_is_most_recent_exn(value exn) { return Val_bool(caml_backtrace_last_exn == exn); } base-0.16.3/src/field.ml000066400000000000000000000054671446274340700147460ustar00rootroot00000000000000(* The type [t] should be abstract to make the fset and set functions unavailable for private types at the level of types (and not by putting None in the field). Unfortunately, making the type abstract means that when creating fields (through a [create] function) value restriction kicks in. This is worked around by instead not making the type abstract, but forcing anyone breaking the abstraction to use the [For_generated_code] module, making it obvious to any reader that something ugly is going on. t_with_perm (and derivatives) is the type that users really use. It is a constructor because: 1. it makes type errors more readable (less aliasing) 2. the typer in ocaml 4.01 allows this: {[ module A = struct type t = {a : int} end type t = A.t let f (x : t) = x.a ]} (although with Warning 40: a is used out of scope) which means that if [t_with_perm] was really an alias on [For_generated_code.t], people could say [t.setter] and break the abstraction with no indication that something ugly is going on in the source code. The warning is (I think) for people who want to make their code compatible with previous versions of ocaml, so we may very well turn it off. The type t_with_perm could also have been a [unit -> For_generated_code.t] to work around value restriction and then [For_generated_code.t] would have been a proper abstract type, but it looks like it could impact performance (for example, a fold on a record type with 40 fields would actually allocate the 40 [For_generated_code.t]'s at every single fold.) *) module For_generated_code = struct type ('perm, 'record, 'field) t = { force_variance : 'perm -> unit ; (* force [t] to be contravariant in ['perm], because phantom type variables on concrete types don't work that well otherwise (using :> can remove them easily) *) name : string ; setter : ('record -> 'field -> unit) option ; getter : 'record -> 'field ; fset : 'record -> 'field -> 'record } let opaque_identity = Sys0.opaque_identity end type ('perm, 'record, 'field) t_with_perm = | Field of ('perm, 'record, 'field) For_generated_code.t [@@unboxed] type ('record, 'field) t = ([ `Read | `Set_and_create ], 'record, 'field) t_with_perm type ('record, 'field) readonly_t = ([ `Read ], 'record, 'field) t_with_perm let name (Field field) = field.name let get (Field field) r = field.getter r let fset (Field field) r v = field.fset r v let setter (Field field) = field.setter type ('perm, 'record, 'result) user = { f : 'field. ('perm, 'record, 'field) t_with_perm -> 'result } let map (Field field) r ~f = field.fset r (f (field.getter r)) let updater (Field field) = match field.setter with | None -> None | Some setter -> Some (fun r ~f -> setter r (f (field.getter r))) ;; base-0.16.3/src/field.mli000066400000000000000000000030361446274340700151050ustar00rootroot00000000000000(** OCaml record field. *) (**/**) module For_generated_code : sig (*_ don't use this by hand, it is only meant for ppx_fields_conv *) type ('perm, 'record, 'field) t = { force_variance : 'perm -> unit ; name : string ; setter : ('record -> 'field -> unit) option ; getter : 'record -> 'field ; fset : 'record -> 'field -> 'record } val opaque_identity : 'a -> 'a end (**/**) (** ['record] is the type of the record. ['field] is the type of the values stored in the record field with name [name]. ['perm] is a way of restricting the operations that can be used. *) type ('perm, 'record, 'field) t_with_perm = | Field of ('perm, 'record, 'field) For_generated_code.t [@@unboxed] (** A record field with no restrictions. *) type ('record, 'field) t = ([ `Read | `Set_and_create ], 'record, 'field) t_with_perm (** A record that can only be read, because it belongs to a private type. *) type ('record, 'field) readonly_t = ([ `Read ], 'record, 'field) t_with_perm val name : (_, _, _) t_with_perm -> string val get : (_, 'r, 'a) t_with_perm -> 'r -> 'a val fset : ([> `Set_and_create ], 'r, 'a) t_with_perm -> 'r -> 'a -> 'r val setter : ([> `Set_and_create ], 'r, 'a) t_with_perm -> ('r -> 'a -> unit) option val map : ([> `Set_and_create ], 'r, 'a) t_with_perm -> 'r -> f:(('a -> 'a)[@local]) -> 'r val updater : ([> `Set_and_create ], 'r, 'a) t_with_perm -> ('r -> f:(('a -> 'a)[@local]) -> unit) option type ('perm, 'record, 'result) user = { f : 'field. ('perm, 'record, 'field) t_with_perm -> 'result } base-0.16.3/src/fieldslib.ml000066400000000000000000000001651446274340700156060ustar00rootroot00000000000000(** This module is for use by ppx_fields_conv, and is thus not in the interface of Base. *) module Field = Field base-0.16.3/src/float.ml000066400000000000000000001072031446274340700147570ustar00rootroot00000000000000open! Import open! Printf module Bytes = Bytes0 include Float0 let raise_s = Error.raise_s module T = struct type t = float [@@deriving_inline hash, globalize, sexp, sexp_grammar] let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = hash_fold_float and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = hash_float in fun x -> func x ;; let (globalize : (t[@ocaml.local]) -> t) = (globalize_float : (t[@ocaml.local]) -> t) let t_of_sexp = (float_of_sexp : Sexplib0.Sexp.t -> t) let sexp_of_t = (sexp_of_float : t -> Sexplib0.Sexp.t) let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = float_sexp_grammar [@@@end] let hashable : t Hashable.t = { hash; compare; sexp_of_t } let compare = Float_replace_polymorphic_compare.compare end include T include Comparator.Make (T) (* Open replace_polymorphic_compare after including functor instantiations so they do not shadow its definitions. This is here so that efficient versions of the comparison functions are available within this module. *) open Float_replace_polymorphic_compare let invariant (_ : t) = () let to_float x = x let of_float x = x let of_string s = try float_of_string s with | _ -> invalid_argf "Float.of_string %s" s () ;; let of_string_opt = float_of_string_opt external format_float : string -> float -> string = "caml_format_float" (* Stolen from [pervasives.ml]. Adds a "." at the end if needed. It is in [pervasives.mli], but it also says not to use it directly, so we copy and paste the code. It makes the assumption on the string passed in argument that it was returned by [format_float]. *) let valid_float_lexem s = let l = String.length s in let rec loop i = if Int_replace_polymorphic_compare.( >= ) i l then s ^ "." else ( match s.[i] with | '0' .. '9' | '-' -> loop (i + 1) | _ -> s) in loop 0 ;; (* Let [y] be a power of 2. Then the next representable float is: [z = y * (1 + 2 ** -52)] and the previous one is [x = y * (1 - 2 ** -53)] In general, every two adjacent floats are within a factor of between [1 + 2**-53] and [1 + 2**-52] from each other, that is within [1 + 1.1e-16] and [1 + 2.3e-16]. So if the decimal representation of a float starts with "1", then its adjacent floats will usually differ from it by 1, and sometimes by 2, at the 17th significant digit (counting from 1). On the other hand, if the decimal representation starts with "9", then the adjacent floats will be off by no more than 23 at the 16th and 17th significant digits. E.g.: {v # sprintf "%.17g" (1024. *. (1. -. 2.** (-53.)));; 11111111 1234 5678901234567 - : string = "1023.9999999999999" v} Printing a couple of extra digits reveals that the difference indeed is roughly 11 at digits 17th and 18th (that is, 13th and 14th after "."): {v # sprintf "%.19g" (1024. *. (1. -. 2.** (-53.)));; 1111111111 1234 567890123456789 - : string = "1023.999999999999886" v} The ulp (the difference between adjacent floats) is twice as big on the other side of 1024.: {v # sprintf "%.19g" (1024. *. (1. +. 2.** (-52.)));; 1111111111 1234 567890123456789 - : string = "1024.000000000000227" v} Now take a power of 2 which starts with 99: {v # 2.**93. ;; 1111111111 1 23456789012345678 - : float = 9.9035203142830422e+27 # 2.**93. *. (1. +. 2.** (-52.));; - : float = 9.9035203142830444e+27 # 2.**93. *. (1. -. 2.** (-53.));; - : float = 9.9035203142830411e+27 v} The difference between 2**93 and its two neighbors is slightly more than, respectively, 1 and 2 at significant digit 16. Those examples show that: - 17 significant digits is always sufficient to represent a float without ambiguity - 15th significant digit can always be represented accurately - converting a decimal number with 16 significant digits to its nearest float and back can change the last decimal digit by no more than 1 To make sure that floats obtained by conversion from decimal fractions (e.g. "3.14") are printed without trailing non-zero digits, one should choose the first among the '%.15g', '%.16g', and '%.17g' representations which does round-trip: {v # sprintf "%.15g" 3.14;; - : string = "3.14" (* pick this one *) # sprintf "%.16g" 3.14;; - : string = "3.14" # sprintf "%.17g" 3.14;; - : string = "3.1400000000000001" (* do not pick this one *) # sprintf "%.15g" 8.000000000000002;; - : string = "8" (* do not pick this one--does not round-trip *) # sprintf "%.16g" 8.000000000000002;; - : string = "8.000000000000002" (* prefer this one *) # sprintf "%.17g" 8.000000000000002;; - : string = "8.0000000000000018" (* this one has one digit of junk at the end *) v} Skipping the '%.16g' in the above procedure saves us some time, but it means that, as seen in the second example above, occasionally numbers with exactly 16 significant digits will have an error introduced at the 17th digit. That is probably OK for typical use, because a number with 16 significant digits is "ugly" already. Adding one more doesn't make it much worse for a human reader. On the other hand, we cannot skip '%.15g' and only look at '%.16g' and '%.17g', since the inaccuracy at the 16th digit might introduce the noise we want to avoid: {v # sprintf "%.15g" 9.992;; - : string = "9.992" (* pick this one *) # sprintf "%.16g" 9.992;; - : string = "9.992000000000001" (* do not pick this one--junk at the end *) # sprintf "%.17g" 9.992;; - : string = "9.9920000000000009" v} *) let to_string x = valid_float_lexem (let y = format_float "%.15g" x in if float_of_string y = x then y else format_float "%.17g" x) ;; let max_value = infinity let min_value = neg_infinity let min_positive_subnormal_value = 2. ** -1074. let min_positive_normal_value = 2. ** -1022. let zero = 0. let one = 1. let minus_one = -1. let pi = 0x3.243F6A8885A308D313198A2E037073 let sqrt_pi = 0x1.C5BF891B4EF6AA79C3B0520D5DB938 let sqrt_2pi = 0x2.81B263FEC4E0B2CAF9483F5CE459DC let euler = 0x0.93C467E37DB0C7A4D1BE3F810152CB let of_int = Int.to_float let to_int = Int.of_float let of_int63 i = Int63.to_float i let of_int64 i = Stdlib.Int64.to_float i let to_int64 = Stdlib.Int64.of_float let iround_lbound = lower_bound_for_int Int.num_bits let iround_ubound = upper_bound_for_int Int.num_bits (* The performance of the "exn" rounding functions is important, so they are written out separately, and tuned individually. (We could have the option versions call the "exn" versions, but that imposes arguably gratuitous overhead---especially in the case where the capture of backtraces is enabled upon "with"---and that seems not worth it when compared to the relatively small amount of code duplication.) *) (* Error reporting below is very carefully arranged so that, e.g., [iround_nearest_exn] itself can be inlined into callers such that they don't need to allocate a box for the [float] argument. This is done with a box [box] function carefully chosen to allow the compiler to create a separate box for the float only in error cases. See, e.g., [../../zero/test/price_test.ml] for a mechanical test of this property when building with [X_LIBRARY_INLINING=true]. *) let iround_up t = if t > 0.0 then ( let t' = ceil t in if t' <= iround_ubound then Some (Int.of_float_unchecked t') else None) else if t >= iround_lbound then Some (Int.of_float_unchecked t) else None ;; let[@ocaml.inline always] iround_up_exn t = if t > 0.0 then ( let t' = ceil t in if t' <= iround_ubound then Int.of_float_unchecked t' else invalid_argf "Float.iround_up_exn: argument (%f) is too large" (box t) ()) else if t >= iround_lbound then Int.of_float_unchecked t else invalid_argf "Float.iround_up_exn: argument (%f) is too small or NaN" (box t) () ;; let iround_down t = if t >= 0.0 then if t <= iround_ubound then Some (Int.of_float_unchecked t) else None else ( let t' = floor t in if t' >= iround_lbound then Some (Int.of_float_unchecked t') else None) ;; let[@ocaml.inline always] iround_down_exn t = if t >= 0.0 then if t <= iround_ubound then Int.of_float_unchecked t else invalid_argf "Float.iround_down_exn: argument (%f) is too large" (box t) () else ( let t' = floor t in if t' >= iround_lbound then Int.of_float_unchecked t' else invalid_argf "Float.iround_down_exn: argument (%f) is too small or NaN" (box t) ()) ;; let iround_towards_zero t = if t >= iround_lbound && t <= iround_ubound then Some (Int.of_float_unchecked t) else None ;; let[@ocaml.inline always] iround_towards_zero_exn t = if t >= iround_lbound && t <= iround_ubound then Int.of_float_unchecked t else invalid_argf "Float.iround_towards_zero_exn: argument (%f) is out of range or NaN" (box t) () ;; (* Outside of the range (round_nearest_lb..round_nearest_ub), all representable doubles are integers in the mathematical sense, and [round_nearest] should be identity. However, for odd numbers with the absolute value between 2**52 and 2**53, the formula [round_nearest x = floor (x + 0.5)] does not hold: {v # let naive_round_nearest x = floor (x +. 0.5);; # let x = 2. ** 52. +. 1.;; val x : float = 4503599627370497. # naive_round_nearest x;; - : float = 4503599627370498. v} *) let round_nearest_lb = -.(2. ** 52.) let round_nearest_ub = 2. ** 52. (* For [x = one_ulp `Down 0.5], the formula [floor (x +. 0.5)] for rounding to nearest does not work, because the exact result is halfway between [one_ulp `Down 1.] and [1.], and it gets rounded up to [1.] due to the round-ties-to-even rule. *) let one_ulp_less_than_half = one_ulp `Down 0.5 let[@ocaml.inline always] add_half_for_round_nearest t = t +. if t = one_ulp_less_than_half then one_ulp_less_than_half (* since t < 0.5, make sure the result is < 1.0 *) else 0.5 ;; let iround_nearest_32 t = if t >= 0. then ( let t' = add_half_for_round_nearest t in if t' <= iround_ubound then Some (Int.of_float_unchecked t') else None) else ( let t' = floor (t +. 0.5) in if t' >= iround_lbound then Some (Int.of_float_unchecked t') else None) ;; let iround_nearest_64 t = if t >= 0. then if t < round_nearest_ub then Some (Int.of_float_unchecked (add_half_for_round_nearest t)) else if t <= iround_ubound then Some (Int.of_float_unchecked t) else None else if t > round_nearest_lb then Some (Int.of_float_unchecked (floor (t +. 0.5))) else if t >= iround_lbound then Some (Int.of_float_unchecked t) else None ;; let iround_nearest = match Word_size.word_size with | W64 -> iround_nearest_64 | W32 -> iround_nearest_32 ;; let iround_nearest_exn_32 t = if t >= 0. then ( let t' = add_half_for_round_nearest t in if t' <= iround_ubound then Int.of_float_unchecked t' else invalid_argf "Float.iround_nearest_exn: argument (%f) is too large" (box t) ()) else ( let t' = floor (t +. 0.5) in if t' >= iround_lbound then Int.of_float_unchecked t' else invalid_argf "Float.iround_nearest_exn: argument (%f) is too small" (box t) ()) ;; let[@ocaml.inline always] iround_nearest_exn_64 t = if t >= 0. then if t < round_nearest_ub then Int.of_float_unchecked (add_half_for_round_nearest t) else if t <= iround_ubound then Int.of_float_unchecked t else invalid_argf "Float.iround_nearest_exn: argument (%f) is too large" (box t) () else if t > round_nearest_lb then Int.of_float_unchecked (floor (t +. 0.5)) else if t >= iround_lbound then Int.of_float_unchecked t else invalid_argf "Float.iround_nearest_exn: argument (%f) is too small or NaN" (box t) () ;; let iround_nearest_exn = match Word_size.word_size with | W64 -> iround_nearest_exn_64 | W32 -> iround_nearest_exn_32 ;; (* The following [iround_exn] and [iround] functions are slower than the ones above. Their equivalence to those functions is tested in the unit tests below. *) let[@inline] iround_exn ?(dir = `Nearest) t = match dir with | `Zero -> iround_towards_zero_exn t | `Nearest -> iround_nearest_exn t | `Up -> iround_up_exn t | `Down -> iround_down_exn t ;; let iround ?(dir = `Nearest) t = try Some (iround_exn ~dir t) with | _ -> None ;; let is_inf t = 1. /. t = 0. let is_finite t = t -. t = 0. let min_inan (x : t) y = if is_nan y then x else if is_nan x then y else if x < y then x else y ;; let max_inan (x : t) y = if is_nan y then x else if is_nan x then y else if x > y then x else y ;; let add = ( +. ) let sub = ( -. ) let neg = ( ~-. ) let abs = abs_float let scale = ( *. ) let square x = x *. x module Parts : sig type t val fractional : t -> float val integral : t -> float val modf : float -> t end = struct type t = float * float let fractional t = fst t let integral t = snd t let modf = modf end let modf = Parts.modf let round_down = floor let round_up = ceil let round_towards_zero t = if t >= 0. then round_down t else round_up t (* see the comment above [round_nearest_lb] and [round_nearest_ub] for an explanation *) let[@ocaml.inline] round_nearest_inline t = if t > round_nearest_lb && t < round_nearest_ub then floor (add_half_for_round_nearest t) else t +. 0. ;; let round_nearest t = (round_nearest_inline [@ocaml.inlined always]) t let round_nearest_half_to_even t = if t <= round_nearest_lb || t >= round_nearest_ub then t +. 0. else ( let floor = floor t in (* [ceil_or_succ = if t is an integer then t +. 1. else ceil t]. Faster than [ceil]. *) let ceil_or_succ = floor +. 1. in let diff_floor = t -. floor in let diff_ceil = ceil_or_succ -. t in if diff_floor < diff_ceil then floor else if diff_floor > diff_ceil then ceil_or_succ else if (* exact tie, pick the even *) mod_float floor 2. = 0. then floor else ceil_or_succ) ;; let int63_round_lbound = lower_bound_for_int Int63.num_bits let int63_round_ubound = upper_bound_for_int Int63.num_bits let int63_round_up_exn t = if t > 0.0 then ( let t' = ceil t in if t' <= int63_round_ubound then Int63.of_float_unchecked t' else invalid_argf "Float.int63_round_up_exn: argument (%f) is too large" (Float0.box t) ()) else if t >= int63_round_lbound then Int63.of_float_unchecked t else invalid_argf "Float.int63_round_up_exn: argument (%f) is too small or NaN" (Float0.box t) () ;; let int63_round_down_exn t = if t >= 0.0 then if t <= int63_round_ubound then Int63.of_float_unchecked t else invalid_argf "Float.int63_round_down_exn: argument (%f) is too large" (Float0.box t) () else ( let t' = floor t in if t' >= int63_round_lbound then Int63.of_float_unchecked t' else invalid_argf "Float.int63_round_down_exn: argument (%f) is too small or NaN" (Float0.box t) ()) ;; let int63_round_nearest_portable_alloc_exn t0 = let t = (round_nearest_inline [@ocaml.inlined always]) t0 in if t > 0. then if t <= int63_round_ubound then Int63.of_float_unchecked t else invalid_argf "Float.int63_round_nearest_portable_alloc_exn: argument (%f) is too large" (box t0) () else if t >= int63_round_lbound then Int63.of_float_unchecked t else invalid_argf "Float.int63_round_nearest_portable_alloc_exn: argument (%f) is too small or NaN" (box t0) () ;; let int63_round_nearest_arch64_noalloc_exn f = Int63.of_int (iround_nearest_exn f) let int63_round_nearest_exn = match Word_size.word_size with | W64 -> int63_round_nearest_arch64_noalloc_exn | W32 -> int63_round_nearest_portable_alloc_exn ;; let round ?(dir = `Nearest) t = match dir with | `Nearest -> round_nearest t | `Down -> round_down t | `Up -> round_up t | `Zero -> round_towards_zero t ;; module Class = struct type t = | Infinite | Nan | Normal | Subnormal | Zero [@@deriving_inline compare, enumerate, sexp, sexp_grammar] let compare = (Stdlib.compare : t -> t -> int) let all = ([ Infinite; Nan; Normal; Subnormal; Zero ] : t list) let t_of_sexp = (let error_source__007_ = "float.ml.Class.t" in function | Sexplib0.Sexp.Atom ("infinite" | "Infinite") -> Infinite | Sexplib0.Sexp.Atom ("nan" | "Nan") -> Nan | Sexplib0.Sexp.Atom ("normal" | "Normal") -> Normal | Sexplib0.Sexp.Atom ("subnormal" | "Subnormal") -> Subnormal | Sexplib0.Sexp.Atom ("zero" | "Zero") -> Zero | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("infinite" | "Infinite") :: _) as sexp__008_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__007_ sexp__008_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("nan" | "Nan") :: _) as sexp__008_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__007_ sexp__008_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("normal" | "Normal") :: _) as sexp__008_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__007_ sexp__008_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("subnormal" | "Subnormal") :: _) as sexp__008_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__007_ sexp__008_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("zero" | "Zero") :: _) as sexp__008_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__007_ sexp__008_ | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__006_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__007_ sexp__006_ | Sexplib0.Sexp.List [] as sexp__006_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__007_ sexp__006_ | sexp__006_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__007_ sexp__006_ : Sexplib0.Sexp.t -> t) ;; let sexp_of_t = (function | Infinite -> Sexplib0.Sexp.Atom "Infinite" | Nan -> Sexplib0.Sexp.Atom "Nan" | Normal -> Sexplib0.Sexp.Atom "Normal" | Subnormal -> Sexplib0.Sexp.Atom "Subnormal" | Zero -> Sexplib0.Sexp.Atom "Zero" : t -> Sexplib0.Sexp.t) ;; let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "Infinite"; clause_kind = Atom_clause } ; No_tag { name = "Nan"; clause_kind = Atom_clause } ; No_tag { name = "Normal"; clause_kind = Atom_clause } ; No_tag { name = "Subnormal"; clause_kind = Atom_clause } ; No_tag { name = "Zero"; clause_kind = Atom_clause } ] } } ;; [@@@end] let to_string t = string_of_sexp (sexp_of_t t) let of_string s = t_of_sexp (sexp_of_string s) end let classify t = let module C = Class in match classify_float t with | FP_normal -> C.Normal | FP_subnormal -> C.Subnormal | FP_zero -> C.Zero | FP_infinite -> C.Infinite | FP_nan -> C.Nan ;; let insert_underscores ?(delimiter = '_') ?(strip_zero = false) string = match String.lsplit2 string ~on:'.' with | None -> Int_conversions.insert_delimiter string ~delimiter | Some (left, right) -> let left = Int_conversions.insert_delimiter left ~delimiter in let right = if strip_zero then String.rstrip right ~drop:(fun c -> Char.( = ) c '0') else right in (match right with | "" -> left | _ -> left ^ "." ^ right) ;; let to_string_hum ?delimiter ?(decimals = 3) ?strip_zero ?(explicit_plus = false) f = if Int_replace_polymorphic_compare.( < ) decimals 0 then invalid_argf "to_string_hum: invalid argument ~decimals=%d" decimals (); match classify f with | Class.Infinite -> if f > 0. then "inf" else "-inf" | Class.Nan -> "nan" | Class.Normal | Class.Subnormal | Class.Zero -> let s = if explicit_plus then sprintf "%+.*f" decimals f else sprintf "%.*f" decimals f in insert_underscores s ?delimiter ?strip_zero ;; let sexp_of_t t = let sexp = sexp_of_t t in match !Sexp.of_float_style with | `No_underscores -> sexp | `Underscores -> (match sexp with | List _ -> raise_s (Sexp.message "[sexp_of_float] produced strange sexp" [ "sexp", Sexp.sexp_of_t sexp ]) | Atom string -> if String.contains string 'E' then sexp else Atom (insert_underscores string)) ;; let to_padded_compact_string_custom t ?(prefix = "") ~kilo ~mega ~giga ~tera ?peta () = (* Round a ratio toward the nearest integer, resolving ties toward the nearest even number. For sane inputs (in particular, when [denominator] is an integer and [abs numerator < 2e52]) this should be accurate. Otherwise, the result might be a little bit off, but we don't really use that case. *) let iround_ratio_exn ~numerator ~denominator = let k = floor (numerator /. denominator) in (* if [abs k < 2e53], then both [k] and [k +. 1.] are accurately represented, and in particular [k +. 1. > k]. If [denominator] is also an integer, and [abs (denominator *. (k +. 1)) < 2e53] (and in some other cases, too), then [lower] and [higher] are actually both accurate. Since (roughly) [numerator = denominator *. k] then for [abs numerator < 2e52] we should be fine. *) let lower = denominator *. k in let higher = denominator *. (k +. 1.) in (* Subtracting numbers within a factor of two from each other is accurate. So either the two subtractions below are accurate, or k = 0, or k = -1. In case of a tie, round to even. *) let diff_right = higher -. numerator in let diff_left = numerator -. lower in let k = iround_nearest_exn k in if diff_right < diff_left then k + 1 else if diff_right > diff_left then k else if (* a tie *) Int_replace_polymorphic_compare.( = ) (k mod 2) 0 then k else k + 1 in match classify t with | Class.Infinite -> if t < 0.0 then "-inf " else "inf " | Class.Nan -> "nan " | Class.Subnormal | Class.Normal | Class.Zero -> let go t = let conv_one t = assert (0. <= t && t < 999.95); let x = prefix ^ format_float "%.1f" t in (* Fix the ".0" suffix *) if String.is_suffix x ~suffix:".0" then ( let x = Bytes.of_string x in let n = Bytes.length x in Bytes.set x (n - 1) ' '; Bytes.set x (n - 2) ' '; Bytes.unsafe_to_string ~no_mutation_while_string_reachable:x) else x in let conv mag t denominator = assert ( (denominator = 100. && t >= 999.95) || (denominator >= 100_000. && t >= round_nearest (denominator *. 9.999_5))); assert (t < round_nearest (denominator *. 9_999.5)); let i, d = let k = iround_ratio_exn ~numerator:t ~denominator in (* [mod] is okay here because we know i >= 0. *) k / 10, k mod 10 in let open Int_replace_polymorphic_compare in assert (0 <= i && i < 1000); assert (0 <= d && d < 10); if d = 0 then sprintf "%s%d%s " prefix i mag else sprintf "%s%d%s%d" prefix i mag d in (* While the standard metric prefixes (e.g. capital "M" rather than "m", [1]) are nominally more correct, this hinders readability in our case. E.g., 10G6 and 1066 look too similar. That's an extreme example, but in general k,m,g,t,p probably stand out better than K,M,G,T,P when interspersed with digits. [1] http://en.wikipedia.org/wiki/Metric_prefix *) (* The trick here is that: - the first boundary (999.95) as a float is slightly over-represented (so it is better approximated as "1k" than as "999.9"), - the other boundaries are accurately represented, because they are integers. That's why the strict equalities below do exactly what we want. *) if t < 999.95E0 then conv_one t else if t < 999.95E3 then conv kilo t 100. else if t < 999.95E6 then conv mega t 100_000. else if t < 999.95E9 then conv giga t 100_000_000. else if t < 999.95E12 then conv tera t 100_000_000_000. else ( match peta with | None -> sprintf "%s%.1e" prefix t | Some peta -> if t < 999.95E15 then conv peta t 100_000_000_000_000. else sprintf "%s%.1e" prefix t) in if t >= 0. then go t else "-" ^ go ~-.t ;; let to_padded_compact_string t = to_padded_compact_string_custom t ~kilo:"k" ~mega:"m" ~giga:"g" ~tera:"t" ~peta:"p" () ;; (* Performance note: Initializing the accumulator to 1 results in one extra multiply; e.g., to compute x ** 4, we in principle only need 2 multiplies, but this function will have 3 multiplies. However, attempts to avoid this (like decrementing n and initializing accum to be x, or handling small exponents as a special case) have not yielded anything that is a net improvement. *) let int_pow x n = let open Int_replace_polymorphic_compare in if n = 0 then 1. else ( (* Using [x +. (-0.)] on the following line convinces the compiler to avoid a certain boxing (that would result in allocation in each iteration). Soon, the compiler shouldn't need this "hint" to avoid the boxing. The reason we add -0 rather than 0 is that [x +. (-0.)] is apparently always the same as [x], whereas [x +. 0.] is not, in that it sends [-0.] to [0.]. This makes a difference because we want [int_pow (-0.) (-1)] to return neg_infinity just like [-0. ** -1.] would. *) let x = ref (x +. -0.) in let n = ref n in let accum = ref 1. in if !n < 0 then ( (* x ** n = (1/x) ** -n *) x := 1. /. !x; n := ~- (!n); if !n < 0 then ( (* n must have been min_int, so it is now so big that it has wrapped around. We decrement it so that it looks positive again, but accordingly have to put an extra factor of x in the accumulator. *) accum := !x; decr n)); (* Letting [a] denote (the original value of) [x ** n], we maintain the invariant that [(x ** n) *. accum = a]. *) while !n > 1 do if !n land 1 <> 0 then accum := !x *. !accum; x := !x *. !x; n := !n lsr 1 done; (* n is necessarily 1 at this point, so there is one additional multiplication by x. *) !x *. !accum) ;; let round_gen x ~how = if x = 0. then 0. else if not (is_finite x) then x else ( (* Significant digits and decimal digits. *) let sd, dd = match how with | `significant_digits sd -> let dd = sd - to_int (round_up (log10 (abs x))) in sd, dd | `decimal_digits dd -> let sd = dd + to_int (round_up (log10 (abs x))) in sd, dd in let open Int_replace_polymorphic_compare in if sd < 0 then 0. else if sd >= 17 then x else ( (* Choose the order that is exactly representable as a float. Small positive integers are, but their inverses in most cases are not. *) let abs_dd = Int.abs dd in if abs_dd > 22 || sd >= 16 (* 10**22 is exactly representable as a float, but 10**23 is not, so use the slow path. Similarly, if we need 16 significant digits in the result, then the integer [round_nearest (x order)] might not be exactly representable as a float, since for some ranges we only have 15 digits of precision guaranteed. That said, we are still rounding twice here: 1) first time when rounding [x *. order] or [x /. order] to the nearest float (just the normal way floating-point multiplication or division works), 2) second time when applying [round_nearest_half_to_even] to the result of the above operation So for arguments within an ulp from a tie we might still produce an off-by-one result. *) then of_string (sprintf "%.*g" sd x) else ( let order = int_pow 10. abs_dd in if dd >= 0 then round_nearest_half_to_even (x *. order) /. order else round_nearest_half_to_even (x /. order) *. order))) ;; let round_significant x ~significant_digits = if Int_replace_polymorphic_compare.( <= ) significant_digits 0 then invalid_argf "Float.round_significant: invalid argument significant_digits:%d" significant_digits () else round_gen x ~how:(`significant_digits significant_digits) ;; let round_decimal x ~decimal_digits = round_gen x ~how:(`decimal_digits decimal_digits) let between t ~low ~high = low <= t && t <= high let clamp_exn t ~min ~max = (* Also fails if [min] or [max] is nan *) assert (min <= max); (* clamp_unchecked is in float0.ml *) clamp_unchecked t ~min ~max ;; let clamp t ~min ~max = (* Also fails if [min] or [max] is nan *) if min <= max then Ok (clamp_unchecked t ~min ~max) else Or_error.error_s (Sexp.message "clamp requires [min <= max]" [ "min", T.sexp_of_t min; "max", T.sexp_of_t max ]) ;; let ( + ) = ( +. ) let ( - ) = ( -. ) let ( * ) = ( *. ) let ( ** ) = ( ** ) let ( / ) = ( /. ) let ( % ) = ( %. ) let ( ~- ) = ( ~-. ) let sign_exn t : Sign.t = if t > 0. then Pos else if t < 0. then Neg else if t = 0. then Zero else Error.raise_s (Sexp.message "Float.sign_exn of NAN" [ "", sexp_of_t t ]) ;; let sign_or_nan t : Sign_or_nan.t = if t > 0. then Pos else if t < 0. then Neg else if t = 0. then Zero else Nan ;; let ieee_negative t = let bits = Stdlib.Int64.bits_of_float t in Poly.(bits < Stdlib.Int64.zero) ;; let exponent_bits = 11 let mantissa_bits = 52 let exponent_mask64 = Int64.(shift_left one exponent_bits - one) let exponent_mask = Int64.to_int_exn exponent_mask64 let mantissa_mask = Int63.(shift_left one mantissa_bits - one) let mantissa_mask64 = Int63.to_int64 mantissa_mask let ieee_exponent t = let bits = Stdlib.Int64.bits_of_float t in Int64.(bit_and (shift_right_logical bits mantissa_bits) exponent_mask64) |> Stdlib.Int64.to_int ;; let ieee_mantissa t = let bits = Stdlib.Int64.bits_of_float t in (* This is safe because mantissa_mask64 < Int63.max_value *) (Int63.of_int64_trunc) Stdlib.Int64.(logand bits mantissa_mask64) ;; let create_ieee_exn ~negative ~exponent ~mantissa = if Int.(bit_and exponent exponent_mask <> exponent) then failwithf "exponent %d out of range [0, %d]" exponent exponent_mask () else if Int63.(bit_and mantissa mantissa_mask <> mantissa) then failwithf "mantissa %s out of range [0, %s]" (Int63.to_string mantissa) (Int63.to_string mantissa_mask) () else ( let sign_bits = if negative then Stdlib.Int64.min_int else Stdlib.Int64.zero in let expt_bits = Stdlib.Int64.shift_left (Stdlib.Int64.of_int exponent) mantissa_bits in let mant_bits = Int63.to_int64 mantissa in let bits = Stdlib.Int64.(logor sign_bits (logor expt_bits mant_bits)) in Stdlib.Int64.float_of_bits bits) ;; let create_ieee ~negative ~exponent ~mantissa = Or_error.try_with (fun () -> create_ieee_exn ~negative ~exponent ~mantissa) ;; module Terse = struct type nonrec t = t let t_of_sexp = t_of_sexp let to_string x = Printf.sprintf "%.8G" x let sexp_of_t x = Sexp.Atom (to_string x) let of_string x = of_string x let t_sexp_grammar = t_sexp_grammar end include Comparable.With_zero (struct include T let zero = zero end) (* These are partly here as a performance hack to avoid some boxing we're getting with the versions we get from [With_zero]. They also make [Float.is_negative nan] and [Float.is_non_positive nan] return [false]; the versions we get from [With_zero] return [true]. *) let is_positive t = t > 0. let is_non_negative t = t >= 0. let is_negative t = t < 0. let is_non_positive t = t <= 0. include Pretty_printer.Register (struct include T let module_name = "Base.Float" let to_string = to_string end) module O = struct let ( + ) = ( + ) let ( - ) = ( - ) let ( * ) = ( * ) let ( / ) = ( / ) let ( % ) = ( % ) let ( ~- ) = ( ~- ) let ( ** ) = ( ** ) include (Float_replace_polymorphic_compare : Comparisons.Infix with type t := t) let abs = abs let neg = neg let zero = zero let of_int = of_int let of_float x = x end module O_dot = struct let ( *. ) = ( * ) let ( +. ) = ( + ) let ( -. ) = ( - ) let ( /. ) = ( / ) let ( %. ) = ( % ) let ( ~-. ) = ( ~- ) let ( **. ) = ( ** ) end module Private = struct let box = box let clamp_unchecked = clamp_unchecked let lower_bound_for_int = lower_bound_for_int let upper_bound_for_int = upper_bound_for_int let specialized_hash = hash_float let one_ulp_less_than_half = one_ulp_less_than_half let int63_round_nearest_portable_alloc_exn = int63_round_nearest_portable_alloc_exn let int63_round_nearest_arch64_noalloc_exn = int63_round_nearest_arch64_noalloc_exn let iround_nearest_exn_64 = iround_nearest_exn_64 end (* Include type-specific [Replace_polymorphic_compare] at the end, after including functor application that could shadow its definitions. This is here so that efficient versions of the comparison functions are exported by this module. *) include Float_replace_polymorphic_compare (* These functions specifically replace defaults in replace_polymorphic_compare. The desired behavior here is to propagate a nan if either argument is nan. Because the first comparison will always return false if either argument is nan, it suffices to check if x is nan. Then, when x is nan or both x and y are nan, we return x = nan; and when y is nan but not x, we return y = nan. There are various ways to implement these functions. The benchmark below shows a few different versions. This benchmark was run over an array of random floats (none of which are nan). ┌────────────────────────────────────────────────┬──────────┐ │ Name │ Time/Run │ ├────────────────────────────────────────────────┼──────────┤ │ if is_nan x then x else if x < y then x else y │ 2.42us │ │ if is_nan x || x < y then x else y │ 2.02us │ │ if x < y || is_nan x then x else y │ 1.88us │ └────────────────────────────────────────────────┴──────────┘ The benchmark below was run when x > y is always true (again, no nan values). ┌────────────────────────────────────────────────┬──────────┐ │ Name │ Time/Run │ ├────────────────────────────────────────────────┼──────────┤ │ if is_nan x then x else if x < y then x else y │ 2.83us │ │ if is_nan x || x < y then x else y │ 1.97us │ │ if x < y || is_nan x then x else y │ 1.56us │ └────────────────────────────────────────────────┴──────────┘ *) let min (x : t) y = if x < y || is_nan x then x else y let max (x : t) y = if x > y || is_nan x then x else y base-0.16.3/src/float.mli000066400000000000000000000547471446274340700151460ustar00rootroot00000000000000(** Floating-point representation and utilities. If using 32-bit OCaml, you cannot quite assume operations act as you'd expect for IEEE 64-bit floats. E.g., one can have [let x = ~-. (2. ** 62.) in x = x -. 1.] evaluate to [false] while [let x = ~-. (2. ** 62.) in let y = x -. 1 in x = y] evaluates to [true]. This is related to 80-bit registers being used for calculations; you can force representation as a 64-bit value by let-binding. *) open! Import type t = float [@@deriving_inline globalize, sexp_grammar] val globalize : (t[@ocaml.local]) -> t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] include Floatable.S with type t := t (** [max] and [min] will return nan if either argument is nan. The [validate_*] functions always fail if class is [Nan] or [Infinite]. *) include Identifiable.S with type t := t val of_string_opt : string -> t option include Comparable.With_zero with type t := t include Invariant.S with type t := t val nan : t val infinity : t val neg_infinity : t (** Equal to [infinity]. *) val max_value : t (** Equal to [neg_infinity]. *) val min_value : t val zero : t val one : t val minus_one : t (** The constant pi. *) val pi : t (** The constant sqrt(pi). *) val sqrt_pi : t (** The constant sqrt(2 * pi). *) val sqrt_2pi : t (** Euler-Mascheroni constant (γ). *) val euler : t (** The difference between 1.0 and the smallest exactly representable floating-point number greater than 1.0. That is: [epsilon_float = (one_ulp `Up 1.0) -. 1.0] This gives the relative accuracy of type [t], in the sense that for numbers on the order of [x], the roundoff error is on the order of [x *. float_epsilon]. See also: {{:http://en.wikipedia.org/wiki/Machine_epsilon} Machine epsilon}. *) val epsilon_float : t val max_finite_value : t (** - [min_positive_subnormal_value = 2 ** -1074] - [min_positive_normal_value = 2 ** -1022] *) val min_positive_subnormal_value : t val min_positive_normal_value : t (** An order-preserving bijection between all floats except for nans, and all int64s with absolute value smaller than or equal to [2**63 - 2**52]. Note both 0. and -0. map to 0L. *) val to_int64_preserve_order : t -> int64 option val to_int64_preserve_order_exn : t -> int64 (** Returns [nan] if the absolute value of the argument is too large. *) val of_int64_preserve_order : int64 -> t (** The next or previous representable float. ULP stands for "unit of least precision", and is the spacing between floating point numbers. Both [one_ulp `Up infinity] and [one_ulp `Down neg_infinity] return a nan. *) val one_ulp : [ `Up | `Down ] -> t -> t (** Note that this doesn't round trip in either direction. For example, [Float.to_int (Float.of_int max_int) <> max_int]. *) val of_int : int -> t val to_int : t -> int val of_int63 : Int63.t -> t val of_int64 : int64 -> t val to_int64 : t -> int64 (** [round] rounds a float to an integer float. [iround{,_exn}] rounds a float to an int. Both round according to a direction [dir], with default [dir] being [`Nearest]. {v | `Down | rounds toward Float.neg_infinity | | `Up | rounds toward Float.infinity | | `Nearest | rounds to the nearest int ("round half-integers up") | | `Zero | rounds toward zero | v} [iround_exn] raises when trying to handle nan or trying to handle a float outside the range \[float min_int, float max_int). Here are some examples for [round] for each direction: {v | `Down | [-2.,-1.) to -2. | [-1.,0.) to -1. | [0.,1.) to 0., [1.,2.) to 1. | | `Up | (-2.,-1.] to -1. | (-1.,0.] to -0. | (0.,1.] to 1., (1.,2.] to 2. | | `Zero | (-2.,-1.] to -1. | (-1.,1.) to 0. | [1.,2.) to 1. | | `Nearest | [-1.5,-0.5) to -1. | [-0.5,0.5) to 0. | [0.5,1.5) to 1. | v} For convenience, versions of these functions with the [dir] argument hard-coded are provided. If you are writing performance-critical code you should use the versions with the hard-coded arguments (e.g. [iround_down_exn]). The [_exn] ones are the fastest. The following properties hold: - [of_int (iround_*_exn i) = i] for any float [i] that is an integer with [min_int <= i <= max_int]. - [round_* i = i] for any float [i] that is an integer. - [iround_*_exn (of_int i) = i] for any int [i] with [-2**52 <= i <= 2**52]. *) val round : ?dir:[ `Zero | `Nearest | `Up | `Down ] -> t -> t val iround : ?dir:[ `Zero | `Nearest | `Up | `Down ] -> t -> int option val iround_exn : ?dir:[ `Zero | `Nearest | `Up | `Down ] -> t -> int val round_towards_zero : t -> t val round_down : t -> t val round_up : t -> t (** Rounds half integers up. *) val round_nearest : t -> t (** Rounds half integers to the even integer. *) val round_nearest_half_to_even : t -> t val iround_towards_zero : t -> int option val iround_down : t -> int option val iround_up : t -> int option val iround_nearest : t -> int option val iround_towards_zero_exn : t -> int val iround_down_exn : t -> int val iround_up_exn : t -> int val iround_nearest_exn : t -> int val int63_round_down_exn : t -> Int63.t val int63_round_up_exn : t -> Int63.t val int63_round_nearest_exn : t -> Int63.t (** If [f < iround_lbound || f > iround_ubound], then [iround*] functions will refuse to round [f], returning [None] or raising as appropriate. *) val iround_lbound : t val iround_ubound : t val int63_round_lbound : t val int63_round_ubound : t (** [round_significant x ~significant_digits:n] rounds to the nearest number with [n] significant digits. More precisely: it returns the representable float closest to [x rounded to n significant digits]. It is meant to be equivalent to [sprintf "%.*g" n x |> Float.of_string] but faster (10x-15x). Exact ties are resolved as round-to-even. However, it might in rare cases break the contract above. It might in some cases appear as if it violates the round-to-even rule: {[ let x = 4.36083208835;; let z = 4.3608320883;; assert (z = fast_approx_round_significant x ~sf:11) ]} But in this case so does sprintf, since [x] as a float is slightly under-represented: {[ sprintf "%.11g" x = "4.3608320883";; sprintf "%.30g" x = "4.36083208834999958014577714493" ]} More importantly, [round_significant] might sometimes give a different result than [sprintf ... |> Float.of_string] because it round-trips through an integer. For example, the decimal fraction 0.009375 is slightly under-represented as a float: {[ sprintf "%.17g" 0.009375 = "0.0093749999999999997" ]} But: {[ 0.009375 *. 1e5 = 937.5 ]} Therefore: {[ round_significant 0.009375 ~significant_digits:3 = 0.00938 ]} whereas: {[ sprintf "%.3g" 0.009375 = "0.00937" ]} In general we believe (and have tested on numerous examples) that the following holds for all x: {[ let s = sprintf "%.*g" significant_digits x |> Float.of_string in s = round_significant ~significant_digits x || s = round_significant ~significant_digits (one_ulp `Up x) || s = round_significant ~significant_digits (one_ulp `Down x) ]} Also, for float representations of decimal fractions (like 0.009375), [round_significant] is more likely to give the "desired" result than [sprintf ... |> of_string] (that is, the result of rounding the decimal fraction, rather than its float representation). But it's not guaranteed either--see the [4.36083208835] example above. *) val round_significant : float -> significant_digits:int -> float (** [round_decimal x ~decimal_digits:n] rounds [x] to the nearest [10**(-n)]. For positive [n] it is meant to be equivalent to [sprintf "%.*f" n x |> Float.of_string], but faster. All the considerations mentioned in [round_significant] apply (both functions use the same code path). *) val round_decimal : float -> decimal_digits:int -> float val is_nan : t -> bool (** A float is infinite when it is either [infinity] or [neg_infinity]. *) val is_inf : t -> bool (** A float is finite when neither [is_nan] nor [is_inf] is true. *) val is_finite : t -> bool (** [is_integer x] is [true] if and only if [x] is an integer. *) val is_integer : t -> bool (** [min_inan] and [max_inan] return, respectively, the min and max of the two given values, except when one of the values is a [nan], in which case the other is returned. (Returns [nan] if both arguments are [nan].) *) val min_inan : t -> t -> t val max_inan : t -> t -> t val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( / ) : t -> t -> t (** In analogy to Int.( % ), ( % ): - always produces non-negative (or NaN) result - raises when given a negative modulus. Like the other infix operators, NaNs in mean NaNs out. Other cases: (a % Infinity) = a when 0 <= a < Infinity, (a % Infinity) = Infinity when -Infinity < a < 0, (+/- Infinity % a) = NaN, (a % 0) = NaN. *) val ( % ) : t -> t -> t val ( * ) : t -> t -> t val ( ** ) : t -> t -> t val ( ~- ) : t -> t (** Returns the fractional part and the whole (i.e., integer) part. For example, [modf (-3.14)] returns [{ fractional = -0.14; integral = -3.; }]! *) module Parts : sig type outer type t val fractional : t -> outer val integral : t -> outer end with type outer := t val modf : t -> Parts.t (** [mod_float x y] returns a result with the same sign as [x]. It returns [nan] if [y] is [0]. It is basically {[ let mod_float x y = x -. float(truncate(x/.y)) *. y]} not {[ let mod_float x y = x -. floor(x/.y) *. y ]} and therefore resembles [mod] on integers more than [%]. *) val mod_float : t -> t -> t (** {6 Ordinary functions for arithmetic operations} These are for modules that inherit from [t], since the infix operators are more convenient. *) val add : t -> t -> t val sub : t -> t -> t val neg : t -> t val scale : t -> t -> t val abs : t -> t (** A sub-module designed to be opened to make working with floats more convenient. *) module O : sig val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t val ( % ) : t -> t -> t val ( ** ) : t -> t -> t val ( ~- ) : t -> t include Comparisons.Infix with type t := t val abs : t -> t val neg : t -> t val zero : t val of_int : int -> t val of_float : float -> t end (** Similar to [O], except that operators are suffixed with a dot, allowing one to have both int and float operators in scope simultaneously. *) module O_dot : sig val ( +. ) : t -> t -> t val ( -. ) : t -> t -> t val ( *. ) : t -> t -> t val ( /. ) : t -> t -> t val ( %. ) : t -> t -> t val ( **. ) : t -> t -> t val ( ~-. ) : t -> t end (** [to_string x] builds a string [s] representing the float [x] that guarantees the round trip, that is such that [Float.equal x (Float.of_string s)]. It usually yields as few significant digits as possible. That is, it won't print [3.14] as [3.1400000000000001243]. The only exception is that occasionally it will output 17 significant digits when the number can be represented with just 16 (but not 15 or less) of them. *) val to_string : t -> string (** Pretty print float, for example [to_string_hum ~decimals:3 1234.1999 = "1_234.200"] [to_string_hum ~decimals:3 ~strip_zero:true 1234.1999 = "1_234.2" ]. No delimiters are inserted to the right of the decimal. *) val to_string_hum : ?delimiter:char (** defaults to ['_'] *) -> ?decimals:int (** defaults to [3] *) -> ?strip_zero:bool (** defaults to [false] *) -> ?explicit_plus:bool (** Forces a + in front of non-negative values. Defaults to [false] *) -> t -> string (** Produce a lossy compact string representation of the float. The float is scaled by an appropriate power of 1000 and rendered with one digit after the decimal point, except that the decimal point is written as '.', 'k', 'm', 'g', 't', or 'p' to indicate the scale factor. (However, if the digit after the "decimal" point is 0, it is suppressed.) The smallest scale factor that allows the number to be rendered with at most 3 digits to the left of the decimal is used. If the number is too large for this format (i.e., the absolute value is at least 999.95e15), scientific notation is used instead. E.g.: - [to_padded_compact_string (-0.01) = "-0 "] - [to_padded_compact_string 1.89 = "1.9"] - [to_padded_compact_string 999_949.99 = "999k9"] - [to_padded_compact_string 999_950. = "1m "] In the case where the digit after the "decimal", or the "decimal" itself is omitted, the numbers are padded on the right with spaces to ensure the last two columns of the string always correspond to the decimal and the digit afterward (except in the case of scientific notation, where the exponent is the right-most element in the string and could take up to four characters). - [to_padded_compact_string 1. = "1 "] - [to_padded_compact_string 1.e6 = "1m "] - [to_padded_compact_string 1.e16 = "1.e+16"] - [to_padded_compact_string max_finite_value = "1.8e+308"] Numbers in the range -.05 < x < .05 are rendered as "0 " or "-0 ". Other cases: - [to_padded_compact_string nan = "nan "] - [to_padded_compact_string infinity = "inf "] - [to_padded_compact_string neg_infinity = "-inf "] Exact ties are resolved to even in the decimal: - [to_padded_compact_string 3.25 = "3.2"] - [to_padded_compact_string 3.75 = "3.8"] - [to_padded_compact_string 33_250. = "33k2"] - [to_padded_compact_string 33_350. = "33k4"] [to_padded_compact_string] is defined in terms of [to_padded_compact_string_custom] below as {[ let to_padded_compact_string t = to_padded_compact_string_custom t ?prefix:None ~kilo:"k" ~mega:"m" ~giga:"g" ~tera:"t" ~peta:"p" () ]} *) val to_padded_compact_string : t -> string (** Similar to [to_padded_compact_string] but allows the user to provide different abbreviations. This can be useful to display currency values, e.g. $1mm3, where prefix="$", mega="mm". *) val to_padded_compact_string_custom : t -> ?prefix:string -> kilo:string -> mega:string -> giga:string -> tera:string -> ?peta:string -> unit -> string (** [int_pow x n] computes [x ** float n] via repeated squaring. It is generally much faster than [**]. Note that [int_pow x 0] always returns [1.], even if [x = nan]. This coincides with [x ** 0.] and is intentional. For [n >= 0] the result is identical to an n-fold product of [x] with itself under [*.], with a certain placement of parentheses. For [n < 0] the result is identical to [int_pow (1. /. x) (-n)]. The error will be on the order of [|n|] ulps, essentially the same as if you perturbed [x] by up to a ulp and then exponentiated exactly. Benchmarks show a factor of 5-10 speedup (relative to [**]) for exponents up to about 1000 (approximately 10ns vs. 70ns). For larger exponents the advantage is smaller but persists into the trillions. For a recent or more detailed comparison, run the benchmarks. Depending on context, calling this function might or might not allocate 2 minor words. Even if called in a way that causes allocation, it still appears to be faster than [**]. *) val int_pow : t -> int -> t (** [square x] returns [x *. x]. *) val square : t -> t (** [ldexp x n] returns [x *. 2 ** n] *) val ldexp : t -> int -> t (** [frexp f] returns the pair of the significant and the exponent of [f]. When [f] is zero, the significant [x] and the exponent [n] of [f] are equal to zero. When [f] is non-zero, they are defined by [f = x *. 2 ** n] and [0.5 <= x < 1.0]. *) val frexp : t -> t * int (** Base 10 logarithm. *) external log10 : t -> t = "caml_log10_float" "log10" [@@unboxed] [@@noalloc] (** [expm1 x] computes [exp x -. 1.0], giving numerically-accurate results even if [x] is close to [0.0]. *) external expm1 : t -> t = "caml_expm1_float" "caml_expm1" [@@unboxed] [@@noalloc] (** [log1p x] computes [log(1.0 +. x)] (natural logarithm), giving numerically-accurate results even if [x] is close to [0.0]. *) external log1p : t -> t = "caml_log1p_float" "caml_log1p" [@@unboxed] [@@noalloc] (** [copysign x y] returns a float whose absolute value is that of [x] and whose sign is that of [y]. If [x] is [nan], returns [nan]. If [y] is [nan], returns either [x] or [-. x], but it is not specified which. *) external copysign : t -> t -> t = "caml_copysign_float" "caml_copysign" [@@unboxed] [@@noalloc] (** Cosine. Argument is in radians. *) external cos : t -> t = "caml_cos_float" "cos" [@@unboxed] [@@noalloc] (** Sine. Argument is in radians. *) external sin : t -> t = "caml_sin_float" "sin" [@@unboxed] [@@noalloc] (** Tangent. Argument is in radians. *) external tan : t -> t = "caml_tan_float" "tan" [@@unboxed] [@@noalloc] (** Arc cosine. The argument must fall within the range [[-1.0, 1.0]]. Result is in radians and is between [0.0] and [pi]. *) external acos : t -> t = "caml_acos_float" "acos" [@@unboxed] [@@noalloc] (** Arc sine. The argument must fall within the range [[-1.0, 1.0]]. Result is in radians and is between [-pi/2] and [pi/2]. *) external asin : t -> t = "caml_asin_float" "asin" [@@unboxed] [@@noalloc] (** Arc tangent. Result is in radians and is between [-pi/2] and [pi/2]. *) external atan : t -> t = "caml_atan_float" "atan" [@@unboxed] [@@noalloc] (** [atan2 y x] returns the arc tangent of [y /. x]. The signs of [x] and [y] are used to determine the quadrant of the result. Result is in radians and is between [-pi] and [pi]. *) external atan2 : t -> t -> t = "caml_atan2_float" "atan2" [@@unboxed] [@@noalloc] (** [hypot x y] returns [sqrt(x *. x + y *. y)], that is, the length of the hypotenuse of a right-angled triangle with sides of length [x] and [y], or, equivalently, the distance of the point [(x,y)] to origin. *) external hypot : t -> t -> t = "caml_hypot_float" "caml_hypot" [@@unboxed] [@@noalloc] (** Hyperbolic cosine. Argument is in radians. *) external cosh : t -> t = "caml_cosh_float" "cosh" [@@unboxed] [@@noalloc] (** Hyperbolic sine. Argument is in radians. *) external sinh : t -> t = "caml_sinh_float" "sinh" [@@unboxed] [@@noalloc] (** Hyperbolic tangent. Argument is in radians. *) external tanh : t -> t = "caml_tanh_float" "tanh" [@@unboxed] [@@noalloc] (** Hyperbolic arc cosine. The argument must fall within the range [[1.0, inf]]. Result is in radians and is between [0.0] and [inf]. *) external acosh : float -> float = "caml_acosh_float" "caml_acosh" [@@unboxed] [@@noalloc] (** Hyperbolic arc sine. The argument and result range over the entire real line. Result is in radians. *) external asinh : float -> float = "caml_asinh_float" "caml_asinh" [@@unboxed] [@@noalloc] (** Hyperbolic arc tangent. The argument must fall within the range [[-1.0, 1.0]]. Result is in radians and ranges over the entire real line. *) external atanh : float -> float = "caml_atanh_float" "caml_atanh" [@@unboxed] [@@noalloc] (** Square root. *) external sqrt : t -> t = "caml_sqrt_float" "sqrt" [@@unboxed] [@@noalloc] (** Exponential. *) external exp : t -> t = "caml_exp_float" "exp" [@@unboxed] [@@noalloc] (** Natural logarithm. *) external log : t -> t = "caml_log_float" "log" [@@unboxed] [@@noalloc] (** Excluding nan the floating-point "number line" looks like: {v t Class.t example ^ neg_infinity Infinite neg_infinity | neg normals Normal -3.14 | neg subnormals Subnormal -.2. ** -1023. | (-/+) zero Zero 0. | pos subnormals Subnormal 2. ** -1023. | pos normals Normal 3.14 v infinity Infinite infinity v} *) module Class : sig type t = | Infinite | Nan | Normal | Subnormal | Zero [@@deriving_inline compare, enumerate, sexp, sexp_grammar] include Ppx_compare_lib.Comparable.S with type t := t include Ppx_enumerate_lib.Enumerable.S with type t := t include Sexplib0.Sexpable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] include Stringable.S with type t := t end val classify : t -> Class.t (*_ Caution: If we remove this sig item, [sign] will still be present from [Comparable.With_zero]. *) val sign : t -> Sign.t [@@deprecated "[since 2016-01] Replace [sign] with [robust_sign] or [sign_exn]"] (** The sign of a float. Both [-0.] and [0.] map to [Zero]. Raises on nan. All other values map to [Neg] or [Pos]. *) val sign_exn : t -> Sign.t (** The sign of a float, with support for NaN. Both [-0.] and [0.] map to [Zero]. All NaN values map to [Nan]. All other values map to [Neg] or [Pos]. *) val sign_or_nan : t -> Sign_or_nan.t (** These functions construct and destruct 64-bit floating point numbers based on their IEEE representation with a sign bit, an 11-bit non-negative (biased) exponent, and a 52-bit non-negative mantissa (or significand). See {{:http://en.wikipedia.org/wiki/Double-precision_floating-point_format} Wikipedia} for details of the encoding. In particular, if 1 <= exponent <= 2046, then: {[ create_ieee_exn ~negative:false ~exponent ~mantissa = 2 ** (exponent - 1023) * (1 + (2 ** -52) * mantissa) ]} *) val create_ieee : negative:bool -> exponent:int -> mantissa:Int63.t -> t Or_error.t val create_ieee_exn : negative:bool -> exponent:int -> mantissa:Int63.t -> t val ieee_negative : t -> bool val ieee_exponent : t -> int val ieee_mantissa : t -> Int63.t (** S-expressions contain at most 8 significant digits. *) module Terse : sig type nonrec t = t [@@deriving_inline sexp, sexp_grammar] include Sexplib0.Sexpable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] include Stringable.S with type t := t end (**/**) (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig val box : t -> t val clamp_unchecked : t -> min:t -> max:t -> t val lower_bound_for_int : int -> t val upper_bound_for_int : int -> t val specialized_hash : t -> int val one_ulp_less_than_half : t val int63_round_nearest_portable_alloc_exn : t -> Int63.t val int63_round_nearest_arch64_noalloc_exn : t -> Int63.t val iround_nearest_exn_64 : t -> int end base-0.16.3/src/float0.ml000066400000000000000000000172551446274340700150460ustar00rootroot00000000000000open! Import (* Open replace_polymorphic_compare after including functor instantiations so they do not shadow its definitions. This is here so that efficient versions of the comparison functions are available within this module. *) open! Float_replace_polymorphic_compare let ceil = Stdlib.ceil let floor = Stdlib.floor let mod_float = Stdlib.mod_float let modf = Stdlib.modf let float_of_string = Stdlib.float_of_string let float_of_string_opt = Stdlib.float_of_string_opt let nan = Stdlib.nan let infinity = Stdlib.infinity let neg_infinity = Stdlib.neg_infinity let max_finite_value = Stdlib.max_float let epsilon_float = Stdlib.epsilon_float let classify_float = Stdlib.classify_float let abs_float = Stdlib.abs_float let is_integer = Stdlib.Float.is_integer let ( ** ) = Stdlib.( ** ) let ( %. ) a b = (* Raise in case of a negative modulus, as does Int.( % ). *) if b < 0. then Printf.invalid_argf "%f %% %f in float0.ml: modulus should be positive" a b (); let m = Stdlib.mod_float a b in (* Produce a non-negative result in analogy with Int.( % ). *) if m < 0. then m +. b else m ;; (* The bits of INRIA's [Pervasives] that we just want to expose in [Float]. Most are already deprecated in [Pervasives], and eventually all of them should be. *) include ( Stdlib : sig external frexp : float -> float * int = "caml_frexp_float" external ldexp : (float[@unboxed]) -> (int[@untagged]) -> (float[@unboxed]) = "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc] external log10 : float -> float = "caml_log10_float" "log10" [@@unboxed] [@@noalloc] external expm1 : float -> float = "caml_expm1_float" "caml_expm1" [@@unboxed] [@@noalloc] external log1p : float -> float = "caml_log1p_float" "caml_log1p" [@@unboxed] [@@noalloc] external copysign : float -> float -> float = "caml_copysign_float" "caml_copysign" [@@unboxed] [@@noalloc] external cos : float -> float = "caml_cos_float" "cos" [@@unboxed] [@@noalloc] external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc] external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc] external acos : float -> float = "caml_acos_float" "acos" [@@unboxed] [@@noalloc] external asin : float -> float = "caml_asin_float" "asin" [@@unboxed] [@@noalloc] external atan : float -> float = "caml_atan_float" "atan" [@@unboxed] [@@noalloc] external acosh : float -> float = "caml_acosh_float" "caml_acosh" [@@unboxed] [@@noalloc] external asinh : float -> float = "caml_asinh_float" "caml_asinh" [@@unboxed] [@@noalloc] external atanh : float -> float = "caml_atanh_float" "caml_atanh" [@@unboxed] [@@noalloc] external atan2 : float -> float -> float = "caml_atan2_float" "atan2" [@@unboxed] [@@noalloc] external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot" [@@unboxed] [@@noalloc] external cosh : float -> float = "caml_cosh_float" "cosh" [@@unboxed] [@@noalloc] external sinh : float -> float = "caml_sinh_float" "sinh" [@@unboxed] [@@noalloc] external tanh : float -> float = "caml_tanh_float" "tanh" [@@unboxed] [@@noalloc] external sqrt : float -> float = "caml_sqrt_float" "sqrt" [@@unboxed] [@@noalloc] external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc] external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc] end) (* We need this indirection because these are exposed as "val" instead of "external" *) let frexp = frexp let ldexp = ldexp let is_nan x = (x : float) <> x (* An order-preserving bijection between all floats except for NaNs, and 99.95% of int64s. Note we don't distinguish 0. and -0. as separate values here, they both map to 0L, which maps back to 0. This should work both on little-endian and high-endian CPUs. Wikipedia says: "on modern standard computers (i.e., implementing IEEE 754), one may in practice safely assume that the endianness is the same for floating point numbers as for integers" (http://en.wikipedia.org/wiki/Endianness#Floating-point_and_endianness). *) let to_int64_preserve_order t = if is_nan t then None else if t = 0. then (* also includes -0. *) Some 0L else if t > 0. then Some (Stdlib.Int64.bits_of_float t) else Some (Stdlib.Int64.neg (Stdlib.Int64.bits_of_float (-.t))) ;; let to_int64_preserve_order_exn x = Option.value_exn (to_int64_preserve_order x) let of_int64_preserve_order x = if Int64_replace_polymorphic_compare.( >= ) x 0L then Stdlib.Int64.float_of_bits x else ~-.(Stdlib.Int64.float_of_bits (Stdlib.Int64.neg x)) ;; let one_ulp dir t = match to_int64_preserve_order t with | None -> Stdlib.nan | Some x -> of_int64_preserve_order (Stdlib.Int64.add x (match dir with | `Up -> 1L | `Down -> -1L)) ;; (* [upper_bound_for_int] and [lower_bound_for_int] are for calculating the max/min float that fits in a given-size integer when rounded towards 0 (using [int_of_float]). max_int/min_int depend on [num_bits], e.g. +/- 2^30, +/- 2^62 if 31-bit, 63-bit (respectively) while float is IEEE standard for double (52 significant bits). In all cases, we want to guarantee that [lower_bound_for_int <= x <= upper_bound_for_int] iff [int_of_float x] fits in an int with [num_bits] bits. [2 ** (num_bits - 1)] is the first float greater that max_int, we use the preceding float as upper bound. [- (2 ** (num_bits - 1))] is equal to min_int. For lower bound we look for the smallest float [f] satisfying [f > min_int - 1] so that [f] rounds toward zero to [min_int] So in particular we will have: [lower_bound_for_int x <= - (2 ** (1-x))] [upper_bound_for_int x < 2 ** (1-x) ] *) let upper_bound_for_int num_bits = let exp = Stdlib.float_of_int (num_bits - 1) in one_ulp `Down (2. ** exp) ;; let is_x_minus_one_exact x = (* [x = x -. 1.] does not work with x87 floating point arithmetic backend (which is used on 32-bit ocaml) because of 80-bit register precision of intermediate computations. An alternative way of computing this: [x -. one_ulp `Down x <= 1.] is also prone to the same precision issues: you need to make sure [x] is 64-bit. *) let open Int64_replace_polymorphic_compare in not (Stdlib.Int64.bits_of_float x = Stdlib.Int64.bits_of_float (x -. 1.)) ;; let lower_bound_for_int num_bits = let exp = Stdlib.float_of_int (num_bits - 1) in let min_int_as_float = ~-.(2. ** exp) in let open Int_replace_polymorphic_compare in if num_bits - 1 < 53 (* 53 = #bits in the float's mantissa with sign included *) then ( (* The smallest float that rounds towards zero to [min_int] is [min_int - 1 + epsilon] *) assert (is_x_minus_one_exact min_int_as_float); one_ulp `Up (min_int_as_float -. 1.)) else ( (* [min_int_as_float] is already the smallest float [f] satisfying [f > min_int - 1]. *) assert (not (is_x_minus_one_exact min_int_as_float)); min_int_as_float) ;; (* Float clamping is structured slightly differently than clamping for other types, so that we get the behavior of [clamp_unchecked nan ~min ~max = nan] (for any [min] and [max]) for free. *) let clamp_unchecked (t : float) ~min ~max = if t < min then min else if max < t then max else t ;; let box = (* Prevent potential constant folding of [+. 0.] in the near ocamlopt future. *) let x = Sys0.opaque_identity 0. in fun f -> f +. x ;; (* Include type-specific [Replace_polymorphic_compare] at the end, after including functor application that could shadow its definitions. This is here so that efficient versions of the comparison functions are exported by this module. *) include Float_replace_polymorphic_compare base-0.16.3/src/floatable.ml000066400000000000000000000002351446274340700156000ustar00rootroot00000000000000(** Module type with float conversion functions. *) open! Import module type S = sig type t val of_float : float -> t val to_float : t -> float end base-0.16.3/src/fn.ml000066400000000000000000000012241446274340700142510ustar00rootroot00000000000000open! Import let const c _ = c external ignore : (_[@local_opt]) -> unit = "%ignore" (* this has the same behavior as [Stdlib.ignore] *) let non f x = not (f x) let forever f = let rec forever () = f (); forever () in try forever () with | e -> e ;; external id : ('a[@local_opt]) -> ('a[@local_opt]) = "%identity" external ( |> ) : 'a -> (('a -> 'b)[@local_opt]) -> 'b = "%revapply" (* The typical use case for these functions is to pass in functional arguments and get functions as a result. *) let compose f g x = f (g x) let flip f x y = f y x let rec apply_n_times ~n f x = if n <= 0 then x else apply_n_times ~n:(n - 1) f (f x) base-0.16.3/src/fn.mli000066400000000000000000000022641446274340700144270ustar00rootroot00000000000000(** Various combinators for functions. *) open! Import (** A "pipe" operator. [x |> f] is equivalent to [f x]. See {{:https://github.com/janestreet/ppx_pipebang} ppx_pipebang} for further details. *) external ( |> ) : 'a -> (('a -> 'b)[@local_opt]) -> 'b = "%revapply" (** Produces a function that just returns its first argument. *) val const : 'a -> _ -> 'a (** Ignores its argument and returns [()]. *) external ignore : (_[@local_opt]) -> unit = "%ignore" (** Negates a boolean function. *) val non : ('a -> bool) -> 'a -> bool (** [forever f] runs [f ()] until it throws an exception and returns the exception. This function is useful for read_line loops, etc. *) val forever : ((unit -> unit)[@local]) -> exn (** [apply_n_times ~n f x] is the [n]-fold application of [f] to [x]. *) val apply_n_times : n:int -> (('a -> 'a)[@local]) -> 'a -> 'a (** The identity function. See also: {!Sys.opaque_identity}. *) external id : ('a[@local_opt]) -> ('a[@local_opt]) = "%identity" (** [compose f g x] is [f (g x)]. *) val compose : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c (** Reverses the order of arguments for a binary function. *) val flip : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c base-0.16.3/src/formatter.ml000066400000000000000000000000411446274340700156450ustar00rootroot00000000000000type t = Stdlib.Format.formatter base-0.16.3/src/formatter.mli000066400000000000000000000006421446274340700160250ustar00rootroot00000000000000(** The [Format.formatter] type from OCaml's standard library, exported here for convenience and compatibility with other libraries. The [Format] module itself is deprecated in Base. You may refer to it explicitly through [Stdlib.Format], though you may wish to search for other alternatives for constructing pretty-printers using the [Format.formatter] type. *) type t = Stdlib.Format.formatter base-0.16.3/src/globalize.ml000066400000000000000000000026551446274340700156270ustar00rootroot00000000000000(* The [globalize_{bool,char,unit}] functions are written as matches plus the identity function so that the type checker can give them the desired type, without having to do anything special. However, [globalize_int] cannot be written this way, so we resort to using an [external]. *) let globalize_bool = function | (true | false) as b -> b ;; let globalize_char = function | '\x00' .. '\xFF' as c -> c ;; external globalize_float : (float[@local]) -> float = "caml_obj_dup" external globalize_int : (int[@local]) -> int = "%identity" external globalize_int32 : (int32[@local]) -> int32 = "caml_obj_dup" external globalize_int64 : (int64[@local]) -> int64 = "caml_obj_dup" external globalize_nativeint : (nativeint[@local]) -> nativeint = "caml_obj_dup" external globalize_bytes : (bytes[@local]) -> bytes = "caml_obj_dup" external globalize_string : (string[@local]) -> string = "caml_obj_dup" let globalize_unit (() as u) = u external globalize_array' : ('a array[@local]) -> 'a array = "caml_obj_dup" let globalize_array _ a = globalize_array' a let rec globalize_list f = function | [] -> [] | x :: xs -> f x :: globalize_list f xs ;; let globalize_option f = function | None -> None | Some x -> Some (f x) ;; let globalize_result globalize_a globalize_b t = match t with | Ok a -> Ok (globalize_a a) | Error b -> Error (globalize_b b) ;; let globalize_ref' r = ref !r let globalize_ref _ r = globalize_ref' r base-0.16.3/src/globalize.mli000066400000000000000000000027341446274340700157760ustar00rootroot00000000000000(** `globalize` functions for the builtin types. These functions are equivalent to the identity function, except that they copy their input rather than return it. They only copy as much as is required to match that type: `global_` and mutable subcomponents are not copied since those are already global. Globalizing a type with mutable contents (e.g., ['a array] or ['a ref]) will therefore create a non-shared copy; mutating the copy won't affect the original and vice versa. Further globalize functions can be generated with `ppx_globalize`. *) val globalize_bool : (bool[@local]) -> bool val globalize_char : (char[@local]) -> char val globalize_float : (float[@local]) -> float val globalize_int : (int[@local]) -> int val globalize_int32 : (int32[@local]) -> int32 val globalize_int64 : (int64[@local]) -> int64 val globalize_nativeint : (nativeint[@local]) -> nativeint val globalize_bytes : (bytes[@local]) -> bytes val globalize_string : (string[@local]) -> string val globalize_unit : (unit[@local]) -> unit val globalize_array : (('a[@local]) -> 'b) -> ('a array[@local]) -> 'a array val globalize_list : (('a[@local]) -> 'b) -> ('a list[@local]) -> 'b list val globalize_option : (('a[@local]) -> 'b) -> ('a option[@local]) -> 'b option val globalize_result : (('ok[@ocaml.local]) -> 'ok) -> (('err[@ocaml.local]) -> 'err) -> (('ok, 'err) result[@ocaml.local]) -> ('ok, 'err) result val globalize_ref : (('a[@local]) -> 'b) -> ('a ref[@local]) -> 'a ref base-0.16.3/src/hash.ml000066400000000000000000000171531446274340700146010ustar00rootroot00000000000000(* This is the interface to the runtime support for [ppx_hash]. The [ppx_hash] syntax extension supports: [@@deriving hash] and [%hash_fold: TYPE] and [%hash: TYPE] For type [t] a function [hash_fold_t] of type [Hash.state -> t -> Hash.state] is generated. The generated [hash_fold_] function is compositional, following the structure of the type; allowing user overrides at every level. This is in contrast to ocaml's builtin polymorphic hashing [Hashtbl.hash] which ignores user overrides. The generator also provides a direct hash-function [hash] (named [hash_] when != "t") of type: [t -> Hash.hash_value]. The folding hash function can be accessed as [%hash_fold: TYPE] The direct hash function can be accessed as [%hash: TYPE] *) open! Import0 module Array = Array0 module Char = Char0 module Int = Int0 module List = List0 include Hash_intf (** Builtin folding-style hash functions, abstracted over [Hash_intf.S] *) module Folding (Hash : Hash_intf.S) : Hash_intf.Builtin_intf with type state = Hash.state and type hash_value = Hash.hash_value = struct type state = Hash.state type hash_value = Hash.hash_value type 'a folder = state -> 'a -> state let hash_fold_unit s () = s let hash_fold_int = Hash.fold_int let hash_fold_int64 = Hash.fold_int64 let hash_fold_float = Hash.fold_float let hash_fold_string = Hash.fold_string let as_int f s x = hash_fold_int s (f x) (* This ignores the sign bit on 32-bit architectures, but it's unlikely to lead to frequent collisions (min_value colliding with 0 is the most likely one). *) let hash_fold_int32 = as_int Stdlib.Int32.to_int let hash_fold_char = as_int Char.to_int let hash_fold_bool = as_int (function | true -> 1 | false -> 0) ;; let hash_fold_nativeint s x = hash_fold_int64 s (Stdlib.Int64.of_nativeint x) let hash_fold_option hash_fold_elem s = function | None -> hash_fold_int s 0 | Some x -> hash_fold_elem (hash_fold_int s 1) x ;; let rec hash_fold_list_body hash_fold_elem s list = match list with | [] -> s | x :: xs -> hash_fold_list_body hash_fold_elem (hash_fold_elem s x) xs ;; let hash_fold_list hash_fold_elem s list = (* The [length] of the list must be incorporated into the hash-state so values of types such as [unit list] - ([], [()], [();()],..) are hashed differently. *) (* The [length] must come before the elements to avoid a violation of the rule enforced by Perfect_hash. *) let s = hash_fold_int s (List.length list) in let s = hash_fold_list_body hash_fold_elem s list in s ;; let hash_fold_lazy_t hash_fold_elem s x = hash_fold_elem s (Stdlib.Lazy.force x) let hash_fold_ref_frozen hash_fold_elem s x = hash_fold_elem s !x let rec hash_fold_array_frozen_i hash_fold_elem s array i = if i = Array.length array then s else ( let e = Array.unsafe_get array i in hash_fold_array_frozen_i hash_fold_elem (hash_fold_elem s e) array (i + 1)) ;; let hash_fold_array_frozen hash_fold_elem s array = hash_fold_array_frozen_i (* [length] must be incorporated for arrays, as it is for lists. See comment above *) hash_fold_elem (hash_fold_int s (Array.length array)) array 0 ;; (* the duplication here is because we think ocaml can't eliminate indirect function calls otherwise. *) let hash_nativeint x = Hash.get_hash_value (hash_fold_nativeint (Hash.reset (Hash.alloc ())) x) ;; let hash_int64 x = Hash.get_hash_value (hash_fold_int64 (Hash.reset (Hash.alloc ())) x) let hash_int32 x = Hash.get_hash_value (hash_fold_int32 (Hash.reset (Hash.alloc ())) x) let hash_char x = Hash.get_hash_value (hash_fold_char (Hash.reset (Hash.alloc ())) x) let hash_int x = Hash.get_hash_value (hash_fold_int (Hash.reset (Hash.alloc ())) x) let hash_bool x = Hash.get_hash_value (hash_fold_bool (Hash.reset (Hash.alloc ())) x) let hash_string x = Hash.get_hash_value (hash_fold_string (Hash.reset (Hash.alloc ())) x) ;; let hash_float x = Hash.get_hash_value (hash_fold_float (Hash.reset (Hash.alloc ())) x) let hash_unit x = Hash.get_hash_value (hash_fold_unit (Hash.reset (Hash.alloc ())) x) end module F (Hash : Hash_intf.S) : Hash_intf.Full with type hash_value = Hash.hash_value and type state = Hash.state and type seed = Hash.seed = struct include Hash type 'a folder = state -> 'a -> state let create ?seed () = reset ?seed (alloc ()) let of_fold hash_fold_t t = get_hash_value (hash_fold_t (create ()) t) module Builtin = Folding (Hash) let run ?seed folder x = Hash.get_hash_value (folder (Hash.reset ?seed (Hash.alloc ())) x) ;; end module Internalhash : sig include Hash_intf.S with type state = Base_internalhash_types.state (* We give a concrete type for [state], albeit only partially exposed (see Base_internalhash_types), so that it unifies with the same type in [Base_boot], and to allow optimizations for the immediate type. *) and type seed = Base_internalhash_types.seed and type hash_value = Base_internalhash_types.hash_value external fold_int64 : state -> int64 -> state = "Base_internalhash_fold_int64" [@@noalloc] external fold_int : state -> int -> state = "Base_internalhash_fold_int" [@@noalloc] external fold_float : state -> float -> state = "Base_internalhash_fold_float" [@@noalloc] external fold_string : state -> string -> state = "Base_internalhash_fold_string" [@@noalloc] external get_hash_value : state -> hash_value = "Base_internalhash_get_hash_value" [@@noalloc] end = struct let description = "internalhash" include Base_internalhash_types let alloc () = create_seeded 0 let reset ?(seed = 0) _t = create_seeded seed module For_tests = struct let compare_state (a : state) (b : state) = compare (a :> int) (b :> int) let state_to_string (state : state) = Int.to_string (state :> int) end end module T = struct include Internalhash type 'a folder = state -> 'a -> state let create ?seed () = reset ?seed (alloc ()) let run ?seed folder x = get_hash_value (folder (reset ?seed (alloc ())) x) let of_fold hash_fold_t t = get_hash_value (hash_fold_t (create ()) t) module Builtin = struct module Folding = Folding (Internalhash) include Folding (* [Folding] provides some default implementations for the [hash_*] functions below, but they are inefficient for some use-cases because of the use of the [hash_fold] functions. At this point, the [hash_value] type has been fixed to [int], so this module can provide specialized implementations. *) let hash_char = Char0.to_int (* This hash was chosen from here: https://gist.github.com/badboy/6267743 It attempts to fulfill the primary goals of a non-cryptographic hash function: - a bit change in the input should change ~1/2 of the output bits - the output should be uniformly distributed across the output range - inputs that are close to each other shouldn't lead to outputs that are close to each other. - all bits of the input are used in generating the output In our case we also want it to be fast, non-allocating, and inlinable. *) let[@inline always] hash_int (t : int) = let t = lnot t + (t lsl 21) in let t = t lxor (t lsr 24) in let t = t + (t lsl 3) + (t lsl 8) in let t = t lxor (t lsr 14) in let t = t + (t lsl 2) + (t lsl 4) in let t = t lxor (t lsr 28) in t + (t lsl 31) ;; let hash_bool x = if x then 1 else 0 external hash_float : float -> int = "Base_hash_double" [@@noalloc] let hash_unit () = 0 end end include T base-0.16.3/src/hash.mli000066400000000000000000000000461446274340700147430ustar00rootroot00000000000000include Hash_intf.Hash (** @inline *) base-0.16.3/src/hash_intf.ml000066400000000000000000000167011446274340700156170ustar00rootroot00000000000000(** [Hash_intf.S] is the interface which a hash function must support. The functions of [Hash_intf.S] are only allowed to be used in specific sequence: [alloc], [reset ?seed], [fold_..*], [get_hash_value], [reset ?seed], [fold_..*], [get_hash_value], ... (The optional [seed]s passed to each reset may differ.) The chain of applications from [reset] to [get_hash_value] must be done in a single-threaded manner (you can't use [fold_*] on a state that's been used before). More precisely, [alloc ()] creates a new family of states. All functions that take [t] and produce [t] return a new state from the same family. At any point in time, at most one state in the family is "valid". The other states are "invalid". - The state returned by [alloc] is invalid. - The state returned by [reset] is valid (all of the other states become invalid). - The [fold_*] family of functions requires a valid state and produces a valid state (thereby making the input state invalid). - [get_hash_value] requires a valid state and makes it invalid. These requirements are currently formally encoded in the [Check_initialized_correctly] module in bench/bench.ml. *) open! Import0 module type S = sig (** Name of the hash-function, e.g., "internalhash", "siphash" *) val description : string (** [state] is the internal hash-state used by the hash function. *) type state (** [fold_ state v] incorporates a value [v] of type into the hash-state, returning a modified hash-state. Implementations of the [fold_] functions may mutate the [state] argument in place, and return a reference to it. Implementations of the fold_ functions should not allocate. *) val fold_int : state -> int -> state val fold_int64 : state -> int64 -> state val fold_float : state -> float -> state val fold_string : state -> string -> state (** [seed] is the type used to seed the initial hash-state. *) type seed (** [alloc ()] returns a fresh uninitialized hash-state. May allocate. *) val alloc : unit -> state (** [reset ?seed state] initializes/resets a hash-state with the given [seed], or else a default-seed. Argument [state] may be mutated. Should not allocate. *) val reset : ?seed:seed -> state -> state (** [hash_value] The type of hash values, returned by [get_hash_value]. *) type hash_value (** [get_hash_value] extracts a hash-value from the hash-state. *) val get_hash_value : state -> hash_value module For_tests : sig val compare_state : state -> state -> int val state_to_string : state -> string end end module type Builtin_hash_fold_intf = sig type state type 'a folder = state -> 'a -> state val hash_fold_nativeint : nativeint folder val hash_fold_int64 : int64 folder val hash_fold_int32 : int32 folder val hash_fold_char : char folder val hash_fold_int : int folder val hash_fold_bool : bool folder val hash_fold_string : string folder val hash_fold_float : float folder val hash_fold_unit : unit folder val hash_fold_option : 'a folder -> 'a option folder val hash_fold_list : 'a folder -> 'a list folder val hash_fold_lazy_t : 'a folder -> 'a lazy_t folder (** Hash support for [array] and [ref] is provided, but is potentially DANGEROUS, since it incorporates the current contents of the array/ref into the hash value. Because of this we add a [_frozen] suffix to the function name. Hash support for [string] is also potentially DANGEROUS, but strings are mutated less often, so we don't append [_frozen] to it. Also note that we don't support [bytes]. *) val hash_fold_ref_frozen : 'a folder -> 'a ref folder val hash_fold_array_frozen : 'a folder -> 'a array folder end module type Builtin_hash_intf = sig type hash_value val hash_nativeint : nativeint -> hash_value val hash_int64 : int64 -> hash_value val hash_int32 : int32 -> hash_value val hash_char : char -> hash_value val hash_int : int -> hash_value val hash_bool : bool -> hash_value val hash_string : string -> hash_value val hash_float : float -> hash_value val hash_unit : unit -> hash_value end module type Builtin_intf = sig include Builtin_hash_fold_intf include Builtin_hash_intf end module type Full = sig include S (** @inline *) type 'a folder = state -> 'a -> state (** [create ?seed ()] is a convenience. Equivalent to [reset ?seed (alloc ())]. *) val create : ?seed:seed -> unit -> state (** [of_fold fold] constructs a standard hash function from an existing fold function. *) val of_fold : (state -> 'a -> state) -> 'a -> hash_value module Builtin : Builtin_intf with type state := state and type 'a folder := 'a folder and type hash_value := hash_value (** [run ?seed folder x] runs [folder] on [x] in a newly allocated hash-state, initialized using optional [seed] or a default-seed. The following identity exists: [run [%hash_fold: T]] == [[%hash: T]] [run] can be used if we wish to run a hash-folder with a non-default seed. *) val run : ?seed:seed -> 'a folder -> 'a -> hash_value end module type Hash = sig module type Full = Full module type S = S module F (Hash : S) : Full with type hash_value = Hash.hash_value and type state = Hash.state and type seed = Hash.seed (** The code of [ppx_hash] is agnostic to the choice of hash algorithm that is used. However, it is not currently possible to mix various choices of hash algorithms in a given code base. We experimented with: - (a) custom hash algorithms implemented in OCaml and - (b) in C; - (c) OCaml's internal hash function (which is a custom version of Murmur3, implemented in C); - (d) siphash, a modern hash function implemented in C. Our findings were as follows: - Implementing our own custom hash algorithms in OCaml and C yielded very little performance improvement over the (c) proposal, without providing the benefit of being a peer-reviewed, widely used hash function. - Siphash (a modern hash function with an internal state of 32 bytes) has a worse performance profile than (a,b,c) above (hashing takes more time). Since its internal state is bigger than an OCaml immediate value, one must either manage allocation of such state explicitly, or paying the cost of allocation each time a hash is computed. While being a supposedly good hash function (with good hash quality), this quality was not translated in measurable improvements in our macro benchmarks. (Also, based on the data available at the time of writing, it's unclear that other hash algorithms in this class would be more than marginally faster.) - By contrast, using the internal combinators of OCaml hash function means that we do not allocate (the internal state of this hash function is 32 bit) and have the same quality and performance as Hashtbl.hash. Hence, we are here making the choice of using this Internalhash (that is, Murmur3, the OCaml hash algorithm as of 4.03) as our hash algorithm. It means that the state of the hash function does not need to be preallocated, and makes for simpler use in hash tables and other structures. *) (** @open *) include Full with type state = Base_internalhash_types.state and type seed = Base_internalhash_types.seed and type hash_value = Base_internalhash_types.hash_value end base-0.16.3/src/hash_set.ml000066400000000000000000000126241446274340700154520ustar00rootroot00000000000000open! Import include Hash_set_intf let hashable_s = Hashtbl.hashable_s let hashable = Hashtbl.Private.hashable let poly_hashable = Hashtbl.Poly.hashable let with_return = With_return.with_return type 'a t = ('a, unit) Hashtbl.t type 'a hash_set = 'a t type 'a elt = 'a module Accessors = struct let hashable = hashable let clear = Hashtbl.clear let length = Hashtbl.length let mem = Hashtbl.mem let is_empty t = Hashtbl.is_empty t let find_map t ~f = with_return (fun r -> Hashtbl.iter_keys t ~f:(fun elt -> match f elt with | None -> () | Some _ as o -> r.return o); None) [@nontail] ;; let find t ~f = find_map t ~f:(fun a -> if f a then Some a else None) [@nontail] let add t k = Hashtbl.set t ~key:k ~data:() let strict_add t k = if mem t k then Or_error.error_string "element already exists" else ( Hashtbl.set t ~key:k ~data:(); Result.Ok ()) ;; let strict_add_exn t k = Or_error.ok_exn (strict_add t k) let remove = Hashtbl.remove let strict_remove t k = if mem t k then ( remove t k; Result.Ok ()) else Or_error.error "element not in set" k (Hashtbl.sexp_of_key t) ;; let strict_remove_exn t k = Or_error.ok_exn (strict_remove t k) let fold t ~init ~f = Hashtbl.fold t ~init ~f:(fun ~key ~data:() acc -> f acc key) [@nontail] ;; let iter t ~f = Hashtbl.iter_keys t ~f let count t ~f = Container.count ~fold t ~f let sum m t ~f = Container.sum ~fold m t ~f let min_elt t ~compare = Container.min_elt ~fold t ~compare let max_elt t ~compare = Container.max_elt ~fold t ~compare let fold_result t ~init ~f = Container.fold_result ~fold ~init ~f t let fold_until t ~init ~f ~finish = Container.fold_until ~fold ~init ~f t ~finish let to_list = Hashtbl.keys let sexp_of_t sexp_of_e t = sexp_of_list sexp_of_e (to_list t |> List.sort ~compare:(hashable t).compare) ;; let to_array t = let len = length t in let index = ref (len - 1) in fold t ~init:[||] ~f:(fun acc key -> if Array.length acc = 0 then Array.create ~len key else ( index := !index - 1; acc.(!index) <- key; acc)) ;; let exists t ~f:(f [@local]) = Hashtbl.existsi t ~f:(fun ~key ~data:() -> f key) [@nontail] ;; let for_all t ~f = not (Hashtbl.existsi t ~f:(fun ~key ~data:() -> not (f key))) let equal t1 t2 = Hashtbl.equal (fun () () -> true) t1 t2 let copy t = Hashtbl.copy t let filter t ~f = Hashtbl.filteri t ~f:(fun ~key ~data:() -> f key) [@nontail] let union t1 t2 = Hashtbl.merge t1 t2 ~f:(fun ~key:_ _ -> Some ()) let diff t1 t2 = filter t1 ~f:(fun key -> not (Hashtbl.mem t2 key)) let inter t1 t2 = let smaller, larger = if length t1 > length t2 then t2, t1 else t1, t2 in Hashtbl.filteri smaller ~f:(fun ~key ~data:() -> Hashtbl.mem larger key) ;; let filter_inplace t ~f = let to_remove = fold t ~init:[] ~f:(fun ac x -> if f x then ac else x :: ac) in List.iter to_remove ~f:(fun x -> remove t x) ;; let of_hashtbl_keys hashtbl = Hashtbl.map hashtbl ~f:ignore let to_hashtbl t ~f = Hashtbl.mapi t ~f:(fun ~key ~data:() -> f key) [@nontail] end include Accessors let create ?growth_allowed ?size m = Hashtbl.create ?growth_allowed ?size m let of_list ?growth_allowed ?size m l = let size = match size with | Some x -> x | None -> List.length l in let t = Hashtbl.create ?growth_allowed ~size m in List.iter l ~f:(fun k -> add t k); t ;; let t_of_sexp m e_of_sexp sexp = match sexp with | Sexp.Atom _ -> of_sexp_error "Hash_set.t_of_sexp requires a list" sexp | Sexp.List list -> let t = create m ~size:(List.length list) in List.iter list ~f:(fun sexp -> let e = e_of_sexp sexp in match strict_add t e with | Ok () -> () | Error _ -> of_sexp_error "Hash_set.t_of_sexp got a duplicate element" sexp); t ;; module Creators (Elt : sig type 'a t val hashable : 'a t Hashable.t end) : sig val t_of_sexp : (Sexp.t -> 'a Elt.t) -> Sexp.t -> 'a Elt.t t include Creators_generic with type 'a t := 'a Elt.t t with type 'a elt := 'a Elt.t with type ('elt, 'z) create_options := ('elt, 'z) create_options_without_first_class_module end = struct let create ?growth_allowed ?size () = create ?growth_allowed ?size (Hashable.to_key Elt.hashable) ;; let of_list ?growth_allowed ?size l = of_list ?growth_allowed ?size (Hashable.to_key Elt.hashable) l ;; let t_of_sexp e_of_sexp sexp = t_of_sexp (Hashable.to_key Elt.hashable) e_of_sexp sexp end module Poly = struct type 'a t = 'a hash_set type 'a elt = 'a let hashable = poly_hashable include Creators (struct type 'a t = 'a let hashable = hashable end) include Accessors let sexp_of_t = sexp_of_t let t_sexp_grammar grammar = Sexplib0.Sexp_grammar.coerce (List.t_sexp_grammar grammar) end module M (Elt : T.T) = struct type nonrec t = Elt.t t end let sexp_of_m__t (type elt) (module Elt : Sexp_of_m with type t = elt) t = sexp_of_t Elt.sexp_of_t t ;; let m__t_of_sexp (type elt) (module Elt : M_of_sexp with type t = elt) sexp = t_of_sexp (module Elt) Elt.t_of_sexp sexp ;; let m__t_sexp_grammar (type elt) (module Elt : M_sexp_grammar with type t = elt) = Sexplib0.Sexp_grammar.coerce (list_sexp_grammar Elt.t_sexp_grammar) ;; let equal_m__t (module _ : Equal_m) t1 t2 = equal t1 t2 module Private = struct let hashable = Hashtbl.Private.hashable end base-0.16.3/src/hash_set.mli000066400000000000000000000000561446274340700156170ustar00rootroot00000000000000include Hash_set_intf.Hash_set (** @inline *) base-0.16.3/src/hash_set_intf.ml000066400000000000000000000133451446274340700164730ustar00rootroot00000000000000open! Import module Key = Hashtbl_intf.Key module type Accessors = sig type 'a t include Container.Generic with type ('a, _) t := 'a t (** override [Container.Generic.mem] *) val mem : 'a t -> 'a -> bool (** preserves the equality function *) val copy : 'a t -> 'a t val add : 'a t -> 'a -> unit (** [strict_add t x] returns [Ok ()] if the [x] was not in [t], or an [Error] if it was. *) val strict_add : 'a t -> 'a -> unit Or_error.t val strict_add_exn : 'a t -> 'a -> unit val remove : 'a t -> 'a -> unit (** [strict_remove t x] returns [Ok ()] if the [x] was in [t], or an [Error] if it was not. *) val strict_remove : 'a t -> 'a -> unit Or_error.t val strict_remove_exn : 'a t -> 'a -> unit val clear : 'a t -> unit val equal : 'a t -> 'a t -> bool val filter : 'a t -> f:(('a -> bool)[@local]) -> 'a t val filter_inplace : 'a t -> f:(('a -> bool)[@local]) -> unit (** [inter t1 t2] computes the set intersection of [t1] and [t2]. Runs in O(min(length t1, length t2)). Behavior is undefined if [t1] and [t2] don't have the same equality function. *) val inter : 'key t -> 'key t -> 'key t val union : 'a t -> 'a t -> 'a t val diff : 'a t -> 'a t -> 'a t val of_hashtbl_keys : ('a, _) Hashtbl.t -> 'a t val to_hashtbl : 'key t -> f:(('key -> 'data)[@local]) -> ('key, 'data) Hashtbl.t end type ('key, 'z) create_options = ('key, unit, 'z) Hashtbl_intf.create_options type ('key, 'z) create_options_without_first_class_module = ('key, unit, 'z) Hashtbl_intf.create_options_without_first_class_module module type Creators = sig type 'a t val create : ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 0 *) -> 'a Key.t -> 'a t val of_list : ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 0 *) -> 'a Key.t -> 'a list -> 'a t end module type Creators_generic = sig type 'a t type 'a elt type ('a, 'z) create_options val create : ('a, unit -> 'a t) create_options val of_list : ('a, 'a elt list -> 'a t) create_options end module type Sexp_of_m = sig type t [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end module type M_of_sexp = sig type t [@@deriving_inline of_sexp] val t_of_sexp : Sexplib0.Sexp.t -> t [@@@end] include Hashtbl_intf.Key.S with type t := t end module type M_sexp_grammar = sig type t [@@deriving_inline sexp_grammar] val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] end module type Equal_m = sig end module type For_deriving = sig type 'a t module type M_of_sexp = M_of_sexp module type Sexp_of_m = Sexp_of_m module type Equal_m = Equal_m (** [M] is meant to be used in combination with OCaml applicative functor types: {[ type string_hash_set = Hash_set.M(String).t ]} which stands for: {[ type string_hash_set = String.t Hash_set.t ]} The point is that [Hash_set.M(String).t] supports deriving, whereas the second syntax doesn't (because [t_of_sexp] doesn't know what comparison/hash function to use). *) module M (Elt : T.T) : sig type nonrec t = Elt.t t end val sexp_of_m__t : (module Sexp_of_m with type t = 'elt) -> 'elt t -> Sexp.t val m__t_of_sexp : (module M_of_sexp with type t = 'elt) -> Sexp.t -> 'elt t val m__t_sexp_grammar : (module M_sexp_grammar with type t = 'elt) -> 'elt t Sexplib0.Sexp_grammar.t val equal_m__t : (module Equal_m) -> 'elt t -> 'elt t -> bool end module type Hash_set = sig type !'a t [@@deriving_inline sexp_of] val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t [@@@end] (** We use [[@@deriving sexp_of]] but not [[@@deriving sexp]] because we want people to be explicit about the hash and comparison functions used when creating hashtables. One can use [Hash_set.Poly.t], which does have [[@@deriving sexp]], to use polymorphic comparison and hashing. *) module Key = Key module type Creators = Creators module type Creators_generic = Creators_generic module type For_deriving = For_deriving type nonrec ('key, 'z) create_options = ('key, 'z) create_options include Creators with type 'a t := 'a t (** @open *) module type Accessors = Accessors include Accessors with type 'a t := 'a t with type 'a elt = 'a (** @open *) val hashable_s : 'key t -> 'key Key.t type nonrec ('key, 'z) create_options_without_first_class_module = ('key, 'z) create_options_without_first_class_module (** A hash set that uses polymorphic comparison *) module Poly : sig type nonrec 'a t = 'a t [@@deriving_inline sexp, sexp_grammar] include Sexplib0.Sexpable.S1 with type 'a t := 'a t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] include Creators_generic with type 'a t := 'a t with type 'a elt = 'a with type ('key, 'z) create_options := ('key, 'z) create_options_without_first_class_module include Accessors with type 'a t := 'a t with type 'a elt := 'a elt end module Creators (Elt : sig type 'a t val hashable : 'a t Hashable.t end) : sig val t_of_sexp : (Sexp.t -> 'a Elt.t) -> Sexp.t -> 'a Elt.t t include Creators_generic with type 'a t := 'a Elt.t t with type 'a elt := 'a Elt.t with type ('elt, 'z) create_options := ('elt, 'z) create_options_without_first_class_module end include For_deriving with type 'a t := 'a t (**/**) (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig val hashable : 'a t -> 'a Hashable.t end end base-0.16.3/src/hash_stubs.c000066400000000000000000000016341446274340700156300ustar00rootroot00000000000000#include #include #include /* Final mix and return from the hash.c implementation from INRIA */ #define FINAL_MIX_AND_RETURN(h) \ h ^= h >> 16; \ h *= 0x85ebca6b; \ h ^= h >> 13; \ h *= 0xc2b2ae35; \ h ^= h >> 16; \ return Val_int(h & 0x3FFFFFFFU); CAMLprim value Base_hash_string(value string) { uint32_t h; h = caml_hash_mix_string(0, string); FINAL_MIX_AND_RETURN(h) } CAMLprim value Base_hash_double(value d) { uint32_t h; h = caml_hash_mix_double(0, Double_val(d)); FINAL_MIX_AND_RETURN(h); } base-0.16.3/src/hashable.ml000066400000000000000000000000431446274340700154130ustar00rootroot00000000000000open! Import include Hashable_intf base-0.16.3/src/hashable.mli000066400000000000000000000002011446274340700155600ustar00rootroot00000000000000open! Import module type Key = Hashable_intf.Key module type Hashable = Hashable_intf.Hashable include Hashable (** @inline *) base-0.16.3/src/hashable_intf.ml000066400000000000000000000043771446274340700164510ustar00rootroot00000000000000open! Import (** @canonical Base.Hashable.Key *) module type Key = sig type t [@@deriving_inline compare, sexp_of] include Ppx_compare_lib.Comparable.S with type t := t val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] (** Values returned by [hash] must be non-negative. An exception will be raised in the case that [hash] returns a negative value. *) val hash : t -> int end module Hashable = struct type 'a t = { hash : 'a -> int ; compare : 'a -> 'a -> int ; sexp_of_t : 'a -> Sexp.t } (** This function is sound but not complete, meaning that if it returns [true] then it's safe to use the two interchangeably. If it's [false], you have no guarantees. For example: {[ > utop open Core;; let equal (a : 'a Hashtbl_intf.Hashable.t) b = phys_equal a b || (phys_equal a.hash b.hash && phys_equal a.compare b.compare && phys_equal a.sexp_of_t b.sexp_of_t) ;; let a = Hashtbl_intf.Hashable.{ hash; compare; sexp_of_t = Int.sexp_of_t };; let b = Hashtbl_intf.Hashable.{ hash; compare; sexp_of_t = Int.sexp_of_t };; equal a b;; (* false?! *) ]} *) let equal a b = phys_equal a b || (phys_equal a.hash b.hash && phys_equal a.compare b.compare && phys_equal a.sexp_of_t b.sexp_of_t) ;; let hash_param = Stdlib.Hashtbl.hash_param let hash = Stdlib.Hashtbl.hash let poly = { hash; compare = Poly.compare; sexp_of_t = (fun _ -> Sexp.Atom "_") } let of_key (type a) (module Key : Key with type t = a) = { hash = Key.hash; compare = Key.compare; sexp_of_t = Key.sexp_of_t } ;; let to_key (type a) { hash; compare; sexp_of_t } = (module struct type t = a let hash = hash let compare = compare let sexp_of_t = sexp_of_t end : Key with type t = a) ;; end include Hashable module type Hashable = sig type 'a t = 'a Hashable.t = { hash : 'a -> int ; compare : 'a -> 'a -> int ; sexp_of_t : 'a -> Sexp.t } val equal : 'a t -> 'a t -> bool val poly : 'a t val of_key : (module Key with type t = 'a) -> 'a t val to_key : 'a t -> (module Key with type t = 'a) val hash_param : int -> int -> 'a -> int val hash : 'a -> int end base-0.16.3/src/hasher.ml000066400000000000000000000041041446274340700151200ustar00rootroot00000000000000open! Import (** Signatures required of types which can be used in [[@@deriving hash]]. *) module type S = sig (** The type that is hashed. *) type t (** [hash_fold_t state x] mixes the content of [x] into the [state]. By default, all our [hash_fold_t] functions (derived or not) should satisfy the following properties. 1. [hash_fold_t state x] should mix all the information present in [x] in the state. That is, by default, [hash_fold_t] will traverse the full term [x] (this is a significant change for Hashtbl.hash which by default stops traversing the term after after considering a small number of "significant values"). [hash_fold_t] must not discard the [state]. 2. [hash_fold_t] must be compatible with the associated [compare] function: that is, for all [x] [y] and [s], [compare x y = 0] must imply [hash_fold_t s x = hash_fold_t s y]. 3. To avoid avoid systematic collisions, [hash_fold_t] should expand to different sequences of built-in mixing functions for different values of [x]. No such sequence is allowed to be a prefix of another. A common mistake is to implement [hash_fold_t] of a collection by just folding all the elements. This makes the folding sequence of [a] be a prefix of [a @ b], thereby violating the requirement. This creates large families of collisions: all of the following collections would hash the same: {v [[]; [1;2;3]] [[1]; [2;3]] [[1; 2]; [3]] [[1; 2; 3]; []] [[1]; [2]; []; [3];] ... v} A good way to avoid this is to mix in the size of the collection to the beginning ([fold ~init:(hash_fold_int state length) ~f:hash_fold_elem]). The default in our libraries is to mix the length of the structure before folding. To prevent the aforementioned collisions, one should respect this ordering. *) val hash_fold_t : Hash.state -> t -> Hash.state end module type S1 = sig type 'a t val hash_fold_t : (Hash.state -> 'a -> Hash.state) -> Hash.state -> 'a t -> Hash.state end base-0.16.3/src/hashtbl.ml000066400000000000000000000710261446274340700153020ustar00rootroot00000000000000open! Import include Hashtbl_intf module type Key = Key.S let with_return = With_return.with_return let hash_param = Hashable.hash_param let hash = Hashable.hash let raise_s = Error.raise_s type ('k, 'v) t = { mutable table : ('k, 'v) Avltree.t array ; mutable length : int ; growth_allowed : bool ; hashable : 'k Hashable.t ; mutable mutation_allowed : bool (* Set during all iteration operations *) } type 'a key = 'a let sexp_of_key t = t.hashable.Hashable.sexp_of_t let compare_key t = t.hashable.Hashable.compare let ensure_mutation_allowed t = if not t.mutation_allowed then failwith "Hashtbl: mutation not allowed during iteration" ;; let without_mutating t f = if t.mutation_allowed then ( t.mutation_allowed <- false; match f () with | x -> t.mutation_allowed <- true; x | exception exn -> t.mutation_allowed <- true; raise exn) else f () ;; (** Internally use a maximum size that is a power of 2. Reverses the above to find the floor power of 2 below the system max array length *) let max_table_length = Int.floor_pow2 Array.max_length (* The default size is chosen to be 0 (as opposed to 128 as it was before) because: - 128 can create substantial memory overhead (x10) when creating many tables, most of which are not big (say, if you have a hashtbl of hashtbl). And memory overhead is not that easy to profile. - if a hashtbl is going to grow, it's not clear why 128 is markedly better than other sizes (if you going to stick 1000 elements, you're going to grow the hashtable once or twice anyway) - in other languages (like rust, python, and apparently go), the default is also a small size. *) let create ?(growth_allowed = true) ?(size = 0) ~hashable () = let size = Int.min (Int.max 1 size) max_table_length in let size = Int.ceil_pow2 size in { table = Array.create ~len:size Avltree.empty ; length = 0 ; growth_allowed ; hashable ; mutation_allowed = true } ;; (** Supplemental hash. This may not be necessary, it is intended as a defense against poor hash functions, for which the power of 2 sized table will be especially sensitive. With some testing we may choose to add it, but this table is designed to be robust to collisions, and in most of my testing this degrades performance. *) let _supplemental_hash h = let h = h lxor ((h lsr 20) lxor (h lsr 12)) in h lxor (h lsr 7) lxor (h lsr 4) ;; let slot t key = let hash = t.hashable.Hashable.hash key in (* this is always non-negative because we do [land] with non-negative number *) hash land (Array.length t.table - 1) ;; let add_worker t ~replace ~key ~data = let i = slot t key in let root = t.table.(i) in let added = (ref false) in let new_root = (* The avl tree might replace the value [replace=true] or do nothing [replace=false] to the entry, in that case the table did not get bigger, so we should not increment length, we pass in the bool ref t.added so that it can tell us whether it added or replaced. We do it this way to avoid extra allocation. Since the bool is an immediate it does not go through the write barrier. *) Avltree.add ~replace root ~compare:(compare_key t) ~added ~key ~data in if !added then t.length <- t.length + 1; (* This little optimization saves a caml_modify when the tree hasn't been rebalanced. *) if not (phys_equal new_root root) then t.table.(i) <- new_root; !added ;; let maybe_resize_table t = let len = Array.length t.table in let should_grow = t.length > len in if should_grow && t.growth_allowed then ( let new_array_length = Int.min (len * 2) max_table_length in if new_array_length > len then ( let new_table = Array.create ~len:new_array_length Avltree.empty in let old_table = t.table in t.table <- new_table; t.length <- 0; let f ~key ~data = ignore (add_worker ~replace:true t ~key ~data : bool) in for i = 0 to Array.length old_table - 1 do Avltree.iter old_table.(i) ~f done)) ;; let set t ~key ~data = ensure_mutation_allowed t; ignore (add_worker ~replace:true t ~key ~data : bool); maybe_resize_table t ;; let add t ~key ~data = ensure_mutation_allowed t; let added = add_worker ~replace:false t ~key ~data in if added then ( maybe_resize_table t; `Ok) else `Duplicate ;; let add_exn t ~key ~data = match add t ~key ~data with | `Ok -> () | `Duplicate -> let sexp_of_key = sexp_of_key t in let error = Error.create "Hashtbl.add_exn got key already present" key sexp_of_key in Error.raise error ;; let clear t = ensure_mutation_allowed t; for i = 0 to Array.length t.table - 1 do t.table.(i) <- Avltree.empty done; t.length <- 0 ;; let find_and_call t key ~if_found ~if_not_found = (* with a good hash function these first two cases will be the overwhelming majority, and Avltree.find is recursive, so it can't be inlined, so doing this avoids a function call in most cases. *) match t.table.(slot t key) with | Avltree.Empty -> if_not_found key | Avltree.Leaf { key = k; value = v } -> if compare_key t k key = 0 then if_found v else if_not_found key | tree -> Avltree.find_and_call tree ~compare:(compare_key t) key ~if_found ~if_not_found ;; let find_and_call1 t key ~a ~if_found ~if_not_found = match t.table.(slot t key) with | Avltree.Empty -> if_not_found key a | Avltree.Leaf { key = k; value = v } -> if compare_key t k key = 0 then if_found v a else if_not_found key a | tree -> Avltree.find_and_call1 tree ~compare:(compare_key t) key ~a ~if_found ~if_not_found ;; let find_and_call2 t key ~a ~b ~if_found ~if_not_found = match t.table.(slot t key) with | Avltree.Empty -> if_not_found key a b | Avltree.Leaf { key = k; value = v } -> if compare_key t k key = 0 then if_found v a b else if_not_found key a b | tree -> Avltree.find_and_call2 tree ~compare:(compare_key t) key ~a ~b ~if_found ~if_not_found ;; let findi_and_call t key ~if_found ~if_not_found = (* with a good hash function these first two cases will be the overwhelming majority, and Avltree.find is recursive, so it can't be inlined, so doing this avoids a function call in most cases. *) match t.table.(slot t key) with | Avltree.Empty -> if_not_found key | Avltree.Leaf { key = k; value = v } -> if compare_key t k key = 0 then if_found ~key:k ~data:v else if_not_found key | tree -> Avltree.findi_and_call tree ~compare:(compare_key t) key ~if_found ~if_not_found ;; let findi_and_call1 t key ~a ~if_found ~if_not_found = match t.table.(slot t key) with | Avltree.Empty -> if_not_found key a | Avltree.Leaf { key = k; value = v } -> if compare_key t k key = 0 then if_found ~key:k ~data:v a else if_not_found key a | tree -> Avltree.findi_and_call1 tree ~compare:(compare_key t) key ~a ~if_found ~if_not_found ;; let findi_and_call2 t key ~a ~b ~if_found ~if_not_found = match t.table.(slot t key) with | Avltree.Empty -> if_not_found key a b | Avltree.Leaf { key = k; value = v } -> if compare_key t k key = 0 then if_found ~key:k ~data:v a b else if_not_found key a b | tree -> Avltree.findi_and_call2 tree ~compare:(compare_key t) key ~a ~b ~if_found ~if_not_found ;; let find = let if_found v = Some v in let if_not_found _ = None in fun t key -> find_and_call t key ~if_found ~if_not_found ;; let mem t key = match t.table.(slot t key) with | Avltree.Empty -> false | Avltree.Leaf { key = k; value = _ } -> compare_key t k key = 0 | tree -> Avltree.mem tree ~compare:(compare_key t) key ;; let remove t key = ensure_mutation_allowed t; let i = slot t key in let root = t.table.(i) in let added_or_removed = (ref false) in let new_root = Avltree.remove root ~removed:added_or_removed ~compare:(compare_key t) key in if not (phys_equal root new_root) then t.table.(i) <- new_root; if !added_or_removed then t.length <- t.length - 1 ;; let length t = t.length let is_empty t = length t = 0 let fold t ~init ~f = if length t = 0 then init else ( let n = Array.length t.table in let acc = ref init in let m = t.mutation_allowed in match t.mutation_allowed <- false; for i = 0 to n - 1 do match Array.unsafe_get t.table i with | Avltree.Empty -> () | Avltree.Leaf { key; value = data } -> acc := f ~key ~data !acc | bucket -> acc := Avltree.fold bucket ~init:!acc ~f done with | () -> t.mutation_allowed <- m; !acc | exception exn -> t.mutation_allowed <- m; raise exn) ;; let iteri t ~f = if t.length = 0 then () else ( let n = Array.length t.table in let m = t.mutation_allowed in match t.mutation_allowed <- false; for i = 0 to n - 1 do match Array.unsafe_get t.table i with | Avltree.Empty -> () | Avltree.Leaf { key; value = data } -> f ~key ~data | bucket -> Avltree.iter bucket ~f done with | () -> t.mutation_allowed <- m | exception exn -> t.mutation_allowed <- m; raise exn) ;; let iter t ~f = iteri t ~f:(fun ~key:_ ~data -> f data) [@nontail] let iter_keys t ~f = iteri t ~f:(fun ~key ~data:_ -> f key) [@nontail] let rec choose_nonempty table i = let avltree = Array.unsafe_get table i in if Avltree.is_empty avltree then choose_nonempty table ((i + 1) land (Array.length table - 1)) else Avltree.choose_exn avltree ;; let choose_exn t = if t.length = 0 then raise_s (Sexp.message "[Hashtbl.choose_exn] of empty hashtbl" []); choose_nonempty t.table 0 ;; let choose t = if is_empty t then None else Some (choose_nonempty t.table 0) let choose_randomly_nonempty ~random_state t = let start_idx = Random.State.int random_state (Array.length t.table) in choose_nonempty t.table start_idx ;; let choose_randomly ?(random_state = Random.State.default) t = if is_empty t then None else Some (choose_randomly_nonempty ~random_state t) ;; let choose_randomly_exn ?(random_state = Random.State.default) t = if t.length = 0 then raise_s (Sexp.message "[Hashtbl.choose_randomly_exn] of empty hashtbl" []); choose_randomly_nonempty ~random_state t ;; let invariant invariant_key invariant_data t = for i = 0 to Array.length t.table - 1 do Avltree.invariant t.table.(i) ~compare:(compare_key t) done; let real_len = fold t ~init:0 ~f:(fun ~key ~data i -> invariant_key key; invariant_data data; i + 1) in assert (real_len = t.length) ;; let find_exn = let if_found v _ = v in let if_not_found k t = raise (Not_found_s (List [ Atom "Hashtbl.find_exn: not found"; t.hashable.sexp_of_t k ])) in let find_exn t key = find_and_call1 t key ~a:t ~if_found ~if_not_found in (* named to preserve symbol in compiled binary *) find_exn ;; let existsi t ~f = with_return (fun r -> iteri t ~f:(fun ~key ~data -> if f ~key ~data then r.return true); false) [@nontail] ;; let exists t ~f = existsi t ~f:(fun ~key:_ ~data -> f data) [@nontail] let for_alli t ~f = not (existsi t ~f:(fun ~key ~data -> not (f ~key ~data))) let for_all t ~f = not (existsi t ~f:(fun ~key:_ ~data -> not (f data))) let counti t ~f = fold t ~init:0 ~f:(fun ~key ~data acc -> if f ~key ~data then acc + 1 else acc) [@nontail ] ;; let count t ~f = fold t ~init:0 ~f:(fun ~key:_ ~data acc -> if f data then acc + 1 else acc) [@nontail] ;; let mapi t ~f = let new_t = create ~growth_allowed:t.growth_allowed ~hashable:t.hashable ~size:t.length () in iteri t ~f:(fun ~key ~data -> set new_t ~key ~data:(f ~key ~data)); new_t ;; let map t ~f = mapi t ~f:(fun ~key:_ ~data -> f data) [@nontail] let copy t = map t ~f:Fn.id let filter_mapi t ~f = let new_t = create ~growth_allowed:t.growth_allowed ~hashable:t.hashable ~size:t.length () in iteri t ~f:(fun ~key ~data -> match f ~key ~data with | Some new_data -> set new_t ~key ~data:new_data | None -> ()); new_t ;; let filter_map t ~f = filter_mapi t ~f:(fun ~key:_ ~data -> f data) [@nontail] let filteri t ~f = filter_mapi t ~f:(fun ~key ~data -> if f ~key ~data then Some data else None) [@nontail] ;; let filter t ~f = filteri t ~f:(fun ~key:_ ~data -> f data) [@nontail] let filter_keys t ~f = filteri t ~f:(fun ~key ~data:_ -> f key) [@nontail] let partition_mapi t ~f = let t0 = create ~growth_allowed:t.growth_allowed ~hashable:t.hashable ~size:t.length () in let t1 = create ~growth_allowed:t.growth_allowed ~hashable:t.hashable ~size:t.length () in iteri t ~f:(fun ~key ~data -> match (f ~key ~data : _ Either.t) with | First new_data -> set t0 ~key ~data:new_data | Second new_data -> set t1 ~key ~data:new_data); t0, t1 ;; let partition_map t ~f = partition_mapi t ~f:(fun ~key:_ ~data -> f data) [@nontail] let partitioni_tf t ~f = partition_mapi t ~f:(fun ~key ~data -> if f ~key ~data then First data else Second data) [@nontail] ;; let partition_tf t ~f = partitioni_tf t ~f:(fun ~key:_ ~data -> f data) [@nontail] let find_or_add t id ~default:(default [@local]) = find_and_call t id ~if_found:(fun data -> data) ~if_not_found:(fun key -> let default = default () in set t ~key ~data:default; default) [@nontail] ;; let findi_or_add t id ~default = find_and_call t id ~if_found:(fun data -> data) ~if_not_found:(fun key -> let default = default key in set t ~key ~data:default; default) [@nontail] ;; (* Some hashtbl implementations may be able to perform this more efficiently than two separate lookups *) let find_and_remove t id = let result = find t id in if Option.is_some result then remove t id; result ;; let change t id ~f = match f (find t id) with | None -> remove t id | Some data -> set t ~key:id ~data ;; let update_and_return t id ~f = let data = f (find t id) in set t ~key:id ~data; data ;; let update t id ~f = ignore (update_and_return t id ~f : _) let incr_by ~remove_if_zero t key by = if remove_if_zero then change t key ~f:(fun opt -> match by + Option.value opt ~default:0 with | 0 -> None | n -> Some n) else update t key ~f:(function | None -> by | Some i -> by + i) ;; let incr ?(by = 1) ?(remove_if_zero = false) t key = incr_by ~remove_if_zero t key by let decr ?(by = 1) ?(remove_if_zero = false) t key = incr_by ~remove_if_zero t key (-by) let add_multi t ~key ~data = update t key ~f:(function | None -> [ data ] | Some l -> data :: l) ;; let remove_multi t key = match find t key with | None -> () | Some [] | Some [ _ ] -> remove t key | Some (_ :: tl) -> set t ~key ~data:tl ;; let find_multi t key = match find t key with | None -> [] | Some l -> l ;; let create_mapped ?growth_allowed ?size ~hashable ~get_key ~get_data rows = let size = match size with | Some s -> s | None -> List.length rows in let res = create ?growth_allowed ~hashable ~size () in let dupes = ref [] in List.iter rows ~f:(fun r -> let key = get_key r in let data = get_data r in if mem res key then dupes := key :: !dupes else set res ~key ~data); match !dupes with | [] -> `Ok res | keys -> `Duplicate_keys (List.dedup_and_sort ~compare:hashable.Hashable.compare keys) ;; let create_mapped_multi ?growth_allowed ?size ~hashable ~get_key ~get_data rows = let size = match size with | Some s -> s | None -> List.length rows in let res = create ?growth_allowed ~size ~hashable () in List.iter rows ~f:(fun r -> let key = get_key r in let data = get_data r in add_multi res ~key ~data); res ;; let of_alist ?growth_allowed ?size ~hashable lst = match create_mapped ?growth_allowed ?size ~hashable ~get_key:fst ~get_data:snd lst with | `Ok t -> `Ok t | `Duplicate_keys k -> `Duplicate_key (List.hd_exn k) ;; let of_alist_report_all_dups ?growth_allowed ?size ~hashable lst = create_mapped ?growth_allowed ?size ~hashable ~get_key:fst ~get_data:snd lst ;; let of_alist_or_error ?growth_allowed ?size ~hashable lst = match of_alist ?growth_allowed ?size ~hashable lst with | `Ok v -> Result.Ok v | `Duplicate_key key -> let sexp_of_key = hashable.Hashable.sexp_of_t in Or_error.error "Hashtbl.of_alist_exn: duplicate key" key sexp_of_key ;; let of_alist_exn ?growth_allowed ?size ~hashable lst = match of_alist_or_error ?growth_allowed ?size ~hashable lst with | Result.Ok v -> v | Result.Error e -> Error.raise e ;; let of_alist_multi ?growth_allowed ?size ~hashable lst = create_mapped_multi ?growth_allowed ?size ~hashable ~get_key:fst ~get_data:snd lst ;; let to_alist t = fold ~f:(fun ~key ~data list -> (key, data) :: list) ~init:[] t let sexp_of_t sexp_of_key sexp_of_data t = t |> to_alist |> List.sort ~compare:(fun (k1, _) (k2, _) -> t.hashable.compare k1 k2) |> sexp_of_list (sexp_of_pair sexp_of_key sexp_of_data) ;; let t_of_sexp ~hashable k_of_sexp d_of_sexp sexp = let alist = list_of_sexp (pair_of_sexp k_of_sexp d_of_sexp) sexp in match of_alist ~hashable alist ~size:(List.length alist) with | `Ok v -> v | `Duplicate_key k -> (* find the sexp of a duplicate key, so the error is narrowed to a key and not the whole map *) let alist_sexps = list_of_sexp (pair_of_sexp Fn.id Fn.id) sexp in let found_first_k = ref false in List.iter2_exn alist alist_sexps ~f:(fun (k2, _) (k2_sexp, _) -> if hashable.compare k k2 = 0 then if !found_first_k then of_sexp_error "Hashtbl.t_of_sexp: duplicate key" k2_sexp else found_first_k := true); assert false ;; let t_sexp_grammar (type k v) (k_grammar : k Sexplib0.Sexp_grammar.t) (v_grammar : v Sexplib0.Sexp_grammar.t) : (k, v) t Sexplib0.Sexp_grammar.t = Sexplib0.Sexp_grammar.coerce (List.Assoc.t_sexp_grammar k_grammar v_grammar) ;; let keys t = fold t ~init:[] ~f:(fun ~key ~data:_ acc -> key :: acc) let data t = fold ~f:(fun ~key:_ ~data list -> data :: list) ~init:[] t let add_to_groups groups ~get_key ~get_data ~combine ~rows = List.iter rows ~f:(fun row -> let key = get_key row in let data = get_data row in let data = match find groups key with | None -> data | Some old -> combine old data in set groups ~key ~data) [@nontail] ;; let group ?growth_allowed ?size ~hashable ~get_key ~get_data ~combine rows = let res = create ?growth_allowed ?size ~hashable () in add_to_groups res ~get_key ~get_data ~combine ~rows; res ;; let create_with_key ?growth_allowed ?size ~hashable ~get_key rows = create_mapped ?growth_allowed ?size ~hashable ~get_key ~get_data:Fn.id rows ;; let create_with_key_or_error ?growth_allowed ?size ~hashable ~get_key rows = match create_with_key ?growth_allowed ?size ~hashable ~get_key rows with | `Ok t -> Result.Ok t | `Duplicate_keys keys -> let sexp_of_key = hashable.Hashable.sexp_of_t in Or_error.error_s (Sexp.message "Hashtbl.create_with_key: duplicate keys" [ "keys", sexp_of_list sexp_of_key keys ]) ;; let create_with_key_exn ?growth_allowed ?size ~hashable ~get_key rows = Or_error.ok_exn (create_with_key_or_error ?growth_allowed ?size ~hashable ~get_key rows) ;; let merge = let maybe_set t ~key ~f d = match f ~key d with | None -> () | Some v -> set t ~key ~data:v in fun t_left t_right ~f -> if not (Hashable.equal t_left.hashable t_right.hashable) then invalid_arg "Hashtbl.merge: different 'hashable' values"; let new_t = create ~growth_allowed:t_left.growth_allowed ~hashable:t_left.hashable ~size:t_left.length () in without_mutating t_left (fun () -> without_mutating t_right (fun () -> iteri t_left ~f:(fun ~key ~data:left -> match find t_right key with | None -> maybe_set new_t ~key ~f (`Left left) | Some right -> maybe_set new_t ~key ~f (`Both (left, right))); iteri t_right ~f:(fun ~key ~data:right -> match find t_left key with | None -> maybe_set new_t ~key ~f (`Right right) | Some _ -> () (* already done above *)) [@nontail]) [@nontail]); new_t ;; let merge_into ~src ~dst ~f = iteri src ~f:(fun ~key ~data -> let dst_data = find dst key in let action = without_mutating dst (fun () -> f ~key data dst_data) in match (action : _ Merge_into_action.t) with | Remove -> remove dst key | Set_to data -> (match dst_data with | None -> set dst ~key ~data | Some dst_data -> if not (phys_equal dst_data data) then set dst ~key ~data)) [@nontail ] ;; let filteri_inplace t ~f = let to_remove = fold t ~init:[] ~f:(fun ~key ~data ac -> if f ~key ~data then ac else key :: ac) in List.iter to_remove ~f:(fun key -> remove t key) ;; let filter_inplace t ~f = filteri_inplace t ~f:(fun ~key:_ ~data -> f data) [@nontail] let filter_keys_inplace t ~f = filteri_inplace t ~f:(fun ~key ~data:_ -> f key) [@nontail] let filter_mapi_inplace t ~f = let map_results = fold t ~init:[] ~f:(fun ~key ~data ac -> (key, f ~key ~data) :: ac) in List.iter map_results ~f:(fun (key, result) -> match result with | None -> remove t key | Some data -> set t ~key ~data) ;; let filter_map_inplace t ~f = filter_mapi_inplace t ~f:(fun ~key:_ ~data -> f data) [@nontail] ;; let mapi_inplace t ~f = ensure_mutation_allowed t; without_mutating t (fun () -> Array.iter t.table ~f:(Avltree.mapi_inplace ~f) [@nontail]) [@nontail] ;; let map_inplace t ~f = mapi_inplace t ~f:(fun ~key:_ ~data -> f data) [@nontail] let equal equal t t' = length t = length t' && (with_return (fun r -> without_mutating t' (fun () -> iteri t ~f:(fun ~key ~data -> match find t' key with | None -> r.return false | Some data' -> if not (equal data data') then r.return false) [@nontail]); true) [@nontail]) ;; let similar = equal module Accessors = struct let invariant = invariant let choose = choose let choose_exn = choose_exn let choose_randomly = choose_randomly let choose_randomly_exn = choose_randomly_exn let clear = clear let copy = copy let remove = remove let set = set let add = add let add_exn = add_exn let change = change let update = update let update_and_return = update_and_return let add_multi = add_multi let remove_multi = remove_multi let find_multi = find_multi let mem = mem let iter_keys = iter_keys let iter = iter let iteri = iteri let exists = exists let existsi = existsi let for_all = for_all let for_alli = for_alli let count = count let counti = counti let fold = fold let length = length let is_empty = is_empty let map = map let mapi = mapi let filter_map = filter_map let filter_mapi = filter_mapi let filter_keys = filter_keys let filter = filter let filteri = filteri let partition_map = partition_map let partition_mapi = partition_mapi let partition_tf = partition_tf let partitioni_tf = partitioni_tf let find_or_add = find_or_add let findi_or_add = findi_or_add let find = find let find_exn = find_exn let find_and_call = find_and_call let find_and_call1 = find_and_call1 let find_and_call2 = find_and_call2 let findi_and_call = findi_and_call let findi_and_call1 = findi_and_call1 let findi_and_call2 = findi_and_call2 let find_and_remove = find_and_remove let to_alist = to_alist let merge = merge let merge_into = merge_into let keys = keys let data = data let filter_keys_inplace = filter_keys_inplace let filter_inplace = filter_inplace let filteri_inplace = filteri_inplace let map_inplace = map_inplace let mapi_inplace = mapi_inplace let filter_map_inplace = filter_map_inplace let filter_mapi_inplace = filter_mapi_inplace let equal = equal let similar = similar let incr = incr let decr = decr let sexp_of_key = sexp_of_key end module Creators (Key : sig type 'a t val hashable : 'a t Hashable.t end) : sig type ('a, 'b) t_ = ('a Key.t, 'b) t val t_of_sexp : (Sexp.t -> 'a Key.t) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) t_ include Creators_generic with type ('a, 'b) t := ('a, 'b) t_ with type 'a key := 'a Key.t with type ('key, 'data, 'a) create_options := ('key, 'data, 'a) create_options_without_first_class_module end = struct let hashable = Key.hashable type ('a, 'b) t_ = ('a Key.t, 'b) t let create ?growth_allowed ?size () = create ?growth_allowed ?size ~hashable () let of_alist ?growth_allowed ?size l = of_alist ?growth_allowed ~hashable ?size l let of_alist_report_all_dups ?growth_allowed ?size l = of_alist_report_all_dups ?growth_allowed ~hashable ?size l ;; let of_alist_or_error ?growth_allowed ?size l = of_alist_or_error ?growth_allowed ~hashable ?size l ;; let of_alist_exn ?growth_allowed ?size l = of_alist_exn ?growth_allowed ~hashable ?size l ;; let t_of_sexp k_of_sexp d_of_sexp sexp = t_of_sexp ~hashable k_of_sexp d_of_sexp sexp let of_alist_multi ?growth_allowed ?size l = of_alist_multi ?growth_allowed ~hashable ?size l ;; let create_mapped ?growth_allowed ?size ~get_key ~get_data l = create_mapped ?growth_allowed ~hashable ?size ~get_key ~get_data l ;; let create_with_key ?growth_allowed ?size ~get_key l = create_with_key ?growth_allowed ~hashable ?size ~get_key l ;; let create_with_key_or_error ?growth_allowed ?size ~get_key l = create_with_key_or_error ?growth_allowed ~hashable ?size ~get_key l ;; let create_with_key_exn ?growth_allowed ?size ~get_key l = create_with_key_exn ?growth_allowed ~hashable ?size ~get_key l ;; let group ?growth_allowed ?size ~get_key ~get_data ~combine l = group ?growth_allowed ~hashable ?size ~get_key ~get_data ~combine l ;; end module Poly = struct type nonrec ('a, 'b) t = ('a, 'b) t type 'a key = 'a let hashable = Hashable.poly include Creators (struct type 'a t = 'a let hashable = hashable end) include Accessors let sexp_of_t = sexp_of_t let t_sexp_grammar = t_sexp_grammar end module Private = struct module type Creators_generic = Creators_generic module type Hashable = Hashable.Hashable type nonrec ('key, 'data, 'z) create_options_without_first_class_module = ('key, 'data, 'z) create_options_without_first_class_module let hashable t = t.hashable end let create ?growth_allowed ?size m = create ~hashable:(Hashable.of_key m) ?growth_allowed ?size () ;; let of_alist ?growth_allowed ?size m l = of_alist ~hashable:(Hashable.of_key m) ?growth_allowed ?size l ;; let of_alist_report_all_dups ?growth_allowed ?size m l = of_alist_report_all_dups ~hashable:(Hashable.of_key m) ?growth_allowed ?size l ;; let of_alist_or_error ?growth_allowed ?size m l = of_alist_or_error ~hashable:(Hashable.of_key m) ?growth_allowed ?size l ;; let of_alist_exn ?growth_allowed ?size m l = of_alist_exn ~hashable:(Hashable.of_key m) ?growth_allowed ?size l ;; let of_alist_multi ?growth_allowed ?size m l = of_alist_multi ~hashable:(Hashable.of_key m) ?growth_allowed ?size l ;; let create_mapped ?growth_allowed ?size m ~get_key ~get_data l = create_mapped ~hashable:(Hashable.of_key m) ?growth_allowed ?size ~get_key ~get_data l ;; let create_with_key ?growth_allowed ?size m ~get_key l = create_with_key ~hashable:(Hashable.of_key m) ?growth_allowed ?size ~get_key l ;; let create_with_key_or_error ?growth_allowed ?size m ~get_key l = create_with_key_or_error ~hashable:(Hashable.of_key m) ?growth_allowed ?size ~get_key l ;; let create_with_key_exn ?growth_allowed ?size m ~get_key l = create_with_key_exn ~hashable:(Hashable.of_key m) ?growth_allowed ?size ~get_key l ;; let group ?growth_allowed ?size m ~get_key ~get_data ~combine l = group ~hashable:(Hashable.of_key m) ?growth_allowed ?size ~get_key ~get_data ~combine l ;; let hashable_s t = Hashable.to_key t.hashable module M (K : T.T) = struct type nonrec 'v t = (K.t, 'v) t end module type Sexp_of_m = sig type t [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end module type M_of_sexp = sig type t [@@deriving_inline of_sexp] val t_of_sexp : Sexplib0.Sexp.t -> t [@@@end] include Key.S with type t := t end module type M_sexp_grammar = sig type t [@@deriving_inline sexp_grammar] val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] end module type Equal_m = sig end let sexp_of_m__t (type k) (module K : Sexp_of_m with type t = k) sexp_of_v t = sexp_of_t K.sexp_of_t sexp_of_v t ;; let m__t_of_sexp (type k) (module K : M_of_sexp with type t = k) v_of_sexp sexp = t_of_sexp ~hashable:(Hashable.of_key (module K)) K.t_of_sexp v_of_sexp sexp ;; let m__t_sexp_grammar (type k) (module K : M_sexp_grammar with type t = k) v_grammar = t_sexp_grammar K.t_sexp_grammar v_grammar ;; let equal_m__t (module _ : Equal_m) equal_v t1 t2 = equal equal_v t1 t2 base-0.16.3/src/hashtbl.mli000066400000000000000000000000541446274340700154440ustar00rootroot00000000000000include Hashtbl_intf.Hashtbl (** @inline *) base-0.16.3/src/hashtbl_intf.ml000066400000000000000000000676071446274340700163340ustar00rootroot00000000000000open! Import (** @canonical Base.Hashtbl.Key *) module Key = struct module type S = sig type t [@@deriving_inline compare, sexp_of] include Ppx_compare_lib.Comparable.S with type t := t val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] (** Two [t]s that [compare] equal must have equal hashes for the hashtable to behave properly. *) val hash : t -> int end type 'a t = (module S with type t = 'a) end (** @canonical Base.Hashtbl.Merge_into_action *) module Merge_into_action = struct type 'a t = | Remove | Set_to of 'a end module type Accessors = sig (** {2 Accessors} *) type ('a, 'b) t type 'a key val sexp_of_key : ('a, _) t -> 'a key -> Sexp.t val clear : (_, _) t -> unit val copy : ('a, 'b) t -> ('a, 'b) t (** Attempting to modify ([set], [remove], etc.) the hashtable during iteration ([fold], [iter], [iter_keys], [iteri]) will raise an exception. *) val fold : ('a, 'b) t -> init:'acc -> f:((key:'a key -> data:'b -> 'acc -> 'acc)[@local]) -> 'acc val iter_keys : ('a, _) t -> f:(('a key -> unit)[@local]) -> unit val iter : (_, 'b) t -> f:(('b -> unit)[@local]) -> unit (** Iterates over both keys and values. Example: {v let h = Hashtbl.of_alist_exn (module Int) [(1, 4); (5, 6)] in Hashtbl.iteri h ~f:(fun ~key ~data -> print_endline (Printf.sprintf "%d-%d" key data));; 1-4 5-6 - : unit = () v} *) val iteri : ('a, 'b) t -> f:((key:'a key -> data:'b -> unit)[@local]) -> unit val existsi : ('a, 'b) t -> f:((key:'a key -> data:'b -> bool)[@local]) -> bool val exists : (_, 'b) t -> f:(('b -> bool)[@local]) -> bool val for_alli : ('a, 'b) t -> f:((key:'a key -> data:'b -> bool)[@local]) -> bool val for_all : (_, 'b) t -> f:(('b -> bool)[@local]) -> bool val counti : ('a, 'b) t -> f:((key:'a key -> data:'b -> bool)[@local]) -> int val count : (_, 'b) t -> f:(('b -> bool)[@local]) -> int val length : (_, _) t -> int val is_empty : (_, _) t -> bool val mem : ('a, _) t -> 'a key -> bool val remove : ('a, _) t -> 'a key -> unit (** Choose an arbitrary key/value pair of a hash table. Returns [None] if [t] is empty. The choice is deterministic. Calling [choose] multiple times on the same table returns the same key/value pair, so long as the table is not mutated in between. Beyond determinism, no guarantees are made about how the choice is made. Expect bias toward certain hash values. This hash bias can lead to degenerate performance in some cases, such as clearing a hash table using repeated [choose] and [remove]. At each iteration, finding the next element may have to scan farther from its initial hash value. *) val choose : ('a, 'b) t -> ('a key * 'b) option (** Like [choose]. Raises if [t] is empty. *) val choose_exn : ('a, 'b) t -> 'a key * 'b (** Chooses a random key/value pair of a hash table. Returns [None] if [t] is empty. The choice is distributed uniformly across hash values, rather than across keys themselves. As a consequence, the closer the keys are to evenly spaced out in the table, the closer this function will be to a uniform choice of keys. This function may be preferable to [choose] when nondeterministic choice is acceptable, and bias toward certain hash values is undesirable. *) val choose_randomly : ?random_state:Random.State.t (** default: [Random.State.default] *) -> ('a, 'b) t -> ('a key * 'b) option (** Like [choose_randomly]. Raises if [t] is empty. *) val choose_randomly_exn : ?random_state:Random.State.t (** default: [Random.State.default] *) -> ('a, 'b) t -> 'a key * 'b (** Sets the given [key] to [data]. *) val set : ('a, 'b) t -> key:'a key -> data:'b -> unit (** [add] and [add_exn] leave the table unchanged if the key was already present. *) val add : ('a, 'b) t -> key:'a key -> data:'b -> [ `Ok | `Duplicate ] val add_exn : ('a, 'b) t -> key:'a key -> data:'b -> unit (** [change t key ~f] changes [t]'s value for [key] to be [f (find t key)]. *) val change : ('a, 'b) t -> 'a key -> f:(('b option -> 'b option)[@local]) -> unit (** [update t key ~f] is [change t key ~f:(fun o -> Some (f o))]. *) val update : ('a, 'b) t -> 'a key -> f:(('b option -> 'b)[@local]) -> unit (** [update_and_return t key ~f] is [update], but returns the result of [f o]. *) val update_and_return : ('a, 'b) t -> 'a key -> f:(('b option -> 'b)[@local]) -> 'b (** [map t f] returns a new table with values replaced by the result of applying [f] to the current values. Example: {v let h = Hashtbl.of_alist_exn (module Int) [(1, 4); (5, 6)] in let h' = Hashtbl.map h ~f:((fun x -> x * 2)[@local]) in Hashtbl.to_alist h';; - : (int * int) list = [(5, 12); (1, 8)] v} *) val map : ('a, 'b) t -> f:(('b -> 'c)[@local]) -> ('a, 'c) t (** Like [map], but the function [f] takes both key and data as arguments. *) val mapi : ('a, 'b) t -> f:((key:'a key -> data:'b -> 'c)[@local]) -> ('a, 'c) t (** Returns a new table by filtering the given table's values by [f]: the keys for which [f] applied to the current value returns [Some] are kept, and those for which it returns [None] are discarded. Example: {v let h = Hashtbl.of_alist_exn (module Int) [(1, 4); (5, 6)] in Hashtbl.filter_map h ~f:((fun x -> if x > 5 then Some x else None)[@local]) |> Hashtbl.to_alist;; - : (int * int) list = [(5, 6)] v} *) val filter_map : ('a, 'b) t -> f:(('b -> 'c option)[@local]) -> ('a, 'c) t (** Like [filter_map], but the function [f] takes both key and data as arguments. *) val filter_mapi : ('a, 'b) t -> f:((key:'a key -> data:'b -> 'c option)[@local]) -> ('a, 'c) t val filter_keys : ('a, 'b) t -> f:(('a key -> bool)[@local]) -> ('a, 'b) t val filter : ('a, 'b) t -> f:(('b -> bool)[@local]) -> ('a, 'b) t val filteri : ('a, 'b) t -> f:((key:'a key -> data:'b -> bool)[@local]) -> ('a, 'b) t (** Returns new tables with bound values partitioned by [f] applied to the bound values. *) val partition_map : ('a, 'b) t -> f:(('b -> ('c, 'd) Either.t)[@local]) -> ('a, 'c) t * ('a, 'd) t (** Like [partition_map], but the function [f] takes both key and data as arguments. *) val partition_mapi : ('a, 'b) t -> f:((key:'a key -> data:'b -> ('c, 'd) Either.t)[@local]) -> ('a, 'c) t * ('a, 'd) t (** Returns a pair of tables [(t1, t2)], where [t1] contains all the elements of the initial table which satisfy the predicate [f], and [t2] contains the rest. *) val partition_tf : ('a, 'b) t -> f:(('b -> bool)[@local]) -> ('a, 'b) t * ('a, 'b) t (** Like [partition_tf], but the function [f] takes both key and data as arguments. *) val partitioni_tf : ('a, 'b) t -> f:((key:'a key -> data:'b -> bool)[@local]) -> ('a, 'b) t * ('a, 'b) t (** [find_or_add t k ~default] returns the data associated with key [k] if it is in the table [t], and otherwise assigns [k] the value returned by [default ()]. *) val find_or_add : ('a, 'b) t -> 'a key -> default:((unit -> 'b)[@local]) -> 'b (** Like [find_or_add] but [default] takes the key as an argument. *) val findi_or_add : ('a, 'b) t -> 'a key -> default:(('a key -> 'b)[@local]) -> 'b (** [find t k] returns [Some] (the current binding) of [k] in [t], or [None] if no such binding exists. *) val find : ('a, 'b) t -> 'a key -> 'b option (** [find_exn t k] returns the current binding of [k] in [t], or raises [Stdlib.Not_found] or [Not_found_s] if no such binding exists. *) val find_exn : ('a, 'b) t -> 'a key -> 'b (** [find_and_call t k ~if_found ~if_not_found] is equivalent to: [match find t k with Some v -> if_found v | None -> if_not_found k] except that it doesn't allocate the option. *) val find_and_call : ('a, 'b) t -> 'a key -> if_found:(('b -> 'c)[@local]) -> if_not_found:(('a key -> 'c)[@local]) -> 'c (** Just like [find_and_call], but takes an extra argument which is passed to [if_found] and [if_not_found], so that the client code can avoid allocating closures or using refs to pass this additional information. This function is only useful in code which tries to minimize heap allocation. *) val find_and_call1 : ('a, 'b) t -> 'a key -> a:'d -> if_found:(('b -> 'd -> 'c)[@local]) -> if_not_found:(('a key -> 'd -> 'c)[@local]) -> 'c val find_and_call2 : ('a, 'b) t -> 'a key -> a:'d -> b:'e -> if_found:(('b -> 'd -> 'e -> 'c)[@local]) -> if_not_found:(('a key -> 'd -> 'e -> 'c)[@local]) -> 'c val findi_and_call : ('a, 'b) t -> 'a key -> if_found:((key:'a key -> data:'b -> 'c)[@local]) -> if_not_found:(('a key -> 'c)[@local]) -> 'c val findi_and_call1 : ('a, 'b) t -> 'a key -> a:'d -> if_found:((key:'a key -> data:'b -> 'd -> 'c)[@local]) -> if_not_found:(('a key -> 'd -> 'c)[@local]) -> 'c val findi_and_call2 : ('a, 'b) t -> 'a key -> a:'d -> b:'e -> if_found:((key:'a key -> data:'b -> 'd -> 'e -> 'c)[@local]) -> if_not_found:(('a key -> 'd -> 'e -> 'c)[@local]) -> 'c (** [find_and_remove t k] returns Some (the current binding) of k in t and removes it, or None is no such binding exists. *) val find_and_remove : ('a, 'b) t -> 'a key -> 'b option (** Merges two hashtables. The result of [merge f h1 h2] has as keys the set of all [k] in the union of the sets of keys of [h1] and [h2] for which [d(k)] is not None, where: d(k) = - [f ~key:k (`Left d1)] if [k] in [h1] maps to d1, and [h2] does not have data for [k]; - [f ~key:k (`Right d2)] if [k] in [h2] maps to d2, and [h1] does not have data for [k]; - [f ~key:k (`Both (d1, d2))] otherwise, where [k] in [h1] maps to [d1] and [k] in [h2] maps to [d2]. Each key [k] is mapped to a single piece of data [x], where [d(k) = Some x]. Example: {v let h1 = Hashtbl.of_alist_exn (module Int) [(1, 5); (2, 3232)] in let h2 = Hashtbl.of_alist_exn (module Int) [(1, 3)] in Hashtbl.merge h1 h2 ~f:(fun ~key:_ -> function | `Left x -> Some (`Left x) | `Right x -> Some (`Right x) | `Both (x, y) -> if x=y then None else Some (`Both (x,y)) ) |> Hashtbl.to_alist;; - : (int * [> `Both of int * int | `Left of int | `Right of int ]) list = [(2, `Left 3232); (1, `Both (5, 3))] v} *) val merge : ('k, 'a) t -> ('k, 'b) t -> f: ((key:'k key -> [ `Left of 'a | `Right of 'b | `Both of 'a * 'b ] -> 'c option) [@local]) -> ('k, 'c) t (** Every [key] in [src] will be removed or set in [dst] according to the return value of [f]. *) val merge_into : src:('k, 'a) t -> dst:('k, 'b) t -> f:((key:'k key -> 'a -> 'b option -> 'b Merge_into_action.t)[@local]) -> unit (** Returns the list of all keys for given hashtable. *) val keys : ('a, _) t -> 'a key list (** Returns the list of all data for given hashtable. *) val data : (_, 'b) t -> 'b list (** [filter_inplace t ~f] removes all the elements from [t] that don't satisfy [f]. *) val filter_keys_inplace : ('a, _) t -> f:(('a key -> bool)[@local]) -> unit val filter_inplace : (_, 'b) t -> f:(('b -> bool)[@local]) -> unit val filteri_inplace : ('a, 'b) t -> f:((key:'a key -> data:'b -> bool)[@local]) -> unit (** [map_inplace t ~f] applies [f] to all elements in [t], transforming them in place. *) val map_inplace : (_, 'b) t -> f:(('b -> 'b)[@local]) -> unit val mapi_inplace : ('a, 'b) t -> f:((key:'a key -> data:'b -> 'b)[@local]) -> unit (** [filter_map_inplace] combines the effects of [map_inplace] and [filter_inplace]. *) val filter_map_inplace : (_, 'b) t -> f:(('b -> 'b option)[@local]) -> unit val filter_mapi_inplace : ('a, 'b) t -> f:((key:'a key -> data:'b -> 'b option)[@local]) -> unit (** [equal f t1 t2] and [similar f t1 t2] both return true iff [t1] and [t2] have the same keys and for all keys [k], [f (find_exn t1 k) (find_exn t2 k)]. [equal] and [similar] only differ in their types. *) val equal : ('b -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t -> bool val similar : ('b1 -> 'b2 -> bool) -> ('a, 'b1) t -> ('a, 'b2) t -> bool (** Returns the list of all (key, data) pairs for given hashtable. *) val to_alist : ('a, 'b) t -> ('a key * 'b) list (** [remove_if_zero]'s default is [false]. *) val incr : ?by:int -> ?remove_if_zero:bool -> ('a, int) t -> 'a key -> unit val decr : ?by:int -> ?remove_if_zero:bool -> ('a, int) t -> 'a key -> unit end module type Multi = sig type ('a, 'b) t type 'a key (** [add_multi t ~key ~data] if [key] is present in the table then cons [data] on the list, otherwise add [key] with a single element list. *) val add_multi : ('a, 'b list) t -> key:'a key -> data:'b -> unit (** [remove_multi t key] updates the table, removing the head of the list bound to [key]. If the list has only one element (or is empty) then the binding is removed. *) val remove_multi : ('a, _ list) t -> 'a key -> unit (** [find_multi t key] returns the empty list if [key] is not present in the table, returns [t]'s values for [key] otherwise. *) val find_multi : ('a, 'b list) t -> 'a key -> 'b list end type ('key, 'data, 'z) create_options = ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 0 *) -> 'key Key.t -> 'z type ('key, 'data, 'z) create_options_without_first_class_module = ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 0 *) -> 'z module type Creators_generic = sig type ('a, 'b) t type 'a key type ('key, 'data, 'z) create_options val create : ('a key, 'b, unit -> ('a, 'b) t) create_options val of_alist : ( 'a key , 'b , ('a key * 'b) list -> [ `Ok of ('a, 'b) t | `Duplicate_key of 'a key ] ) create_options val of_alist_report_all_dups : ( 'a key , 'b , ('a key * 'b) list -> [ `Ok of ('a, 'b) t | `Duplicate_keys of 'a key list ] ) create_options val of_alist_or_error : ('a key, 'b, ('a key * 'b) list -> ('a, 'b) t Or_error.t) create_options val of_alist_exn : ('a key, 'b, ('a key * 'b) list -> ('a, 'b) t) create_options val of_alist_multi : ('a key, 'b list, ('a key * 'b) list -> ('a, 'b list) t) create_options (** {[ create_mapped get_key get_data [x1,...,xn] = of_alist [get_key x1, get_data x1; ...; get_key xn, get_data xn] ]} *) val create_mapped : ( 'a key , 'b , get_key:(('r -> 'a key)[@local]) -> get_data:(('r -> 'b)[@local]) -> 'r list -> [ `Ok of ('a, 'b) t | `Duplicate_keys of 'a key list ] ) create_options (** {[ create_with_key ~get_key [x1,...,xn] = of_alist [get_key x1, x1; ...; get_key xn, xn] ]} *) val create_with_key : ( 'a key , 'r , get_key:(('r -> 'a key)[@local]) -> 'r list -> [ `Ok of ('a, 'r) t | `Duplicate_keys of 'a key list ] ) create_options val create_with_key_or_error : ( 'a key , 'r , get_key:(('r -> 'a key)[@local]) -> 'r list -> ('a, 'r) t Or_error.t ) create_options val create_with_key_exn : ( 'a key , 'r , get_key:(('r -> 'a key)[@local]) -> 'r list -> ('a, 'r) t ) create_options val group : ( 'a key , 'b , get_key:(('r -> 'a key)[@local]) -> get_data:(('r -> 'b)[@local]) -> combine:(('b -> 'b -> 'b)[@local]) -> 'r list -> ('a, 'b) t ) create_options end module type Creators = sig type ('a, 'b) t (** {2 Creators} *) (** The module you pass to [create] must have a type that is hashable, sexpable, and comparable. Example: {v Hashtbl.create (module Int);; - : (int, '_a) Hashtbl.t = ;; v} *) val create : ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 0 *) -> 'a Key.t -> ('a, 'b) t (** Example: {v Hashtbl.of_alist (module Int) [(3, "something"); (2, "whatever")] - : [ `Duplicate_key of int | `Ok of (int, string) Hashtbl.t ] = `Ok v} *) val of_alist : ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 0 *) -> 'a Key.t -> ('a * 'b) list -> [ `Ok of ('a, 'b) t | `Duplicate_key of 'a ] (** Whereas [of_alist] will report [Duplicate_key] no matter how many dups there are in your list, [of_alist_report_all_dups] will report each and every duplicate entry. For example: {v Hashtbl.of_alist (module Int) [(1, "foo"); (1, "bar"); (2, "foo"); (2, "bar")];; - : [ `Duplicate_key of int | `Ok of (int, string) Hashtbl.t ] = `Duplicate_key 1 Hashtbl.of_alist_report_all_dups (module Int) [(1, "foo"); (1, "bar"); (2, "foo"); (2, "bar")];; - : [ `Duplicate_keys of int list | `Ok of (int, string) Hashtbl.t ] = `Duplicate_keys [1; 2] v} *) val of_alist_report_all_dups : ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 0 *) -> 'a Key.t -> ('a * 'b) list -> [ `Ok of ('a, 'b) t | `Duplicate_keys of 'a list ] val of_alist_or_error : ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 0 *) -> 'a Key.t -> ('a * 'b) list -> ('a, 'b) t Or_error.t val of_alist_exn : ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 0 *) -> 'a Key.t -> ('a * 'b) list -> ('a, 'b) t (** Creates a {{!Multi} "multi"} hashtable, i.e., a hashtable where each key points to a list potentially containing multiple values. So instead of short-circuiting with a [`Duplicate_key] variant on duplicates, as in [of_alist], [of_alist_multi] folds those values into a list for the given key: {v let h = Hashtbl.of_alist_multi (module Int) [(1, "a"); (1, "b"); (2, "c"); (2, "d")];; val h : (int, string list) Hashtbl.t = Hashtbl.find_exn h 1;; - : string list = ["b"; "a"] v} *) val of_alist_multi : ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 0 *) -> 'a Key.t -> ('a * 'b) list -> ('a, 'b list) t (** Applies the [get_key] and [get_data] functions to the ['r list] to create the initial keys and values, respectively, for the new hashtable. {[ create_mapped get_key get_data [x1;...;xn] = of_alist [get_key x1, get_data x1; ...; get_key xn, get_data xn] ]} Example: {v let h = Hashtbl.create_mapped (module Int) ~get_key:((fun x -> x)[@local]) ~get_data:((fun x -> x + 1)[@local]) [1; 2; 3];; val h : [ `Duplicate_keys of int list | `Ok of (int, int) Hashtbl.t ] = `Ok let h = match h with | `Ok x -> x | `Duplicate_keys _ -> failwith "" in Hashtbl.find_exn h 1;; - : int = 2 v} *) val create_mapped : ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 0 *) -> 'a Key.t -> get_key:(('r -> 'a)[@local]) -> get_data:(('r -> 'b)[@local]) -> 'r list -> [ `Ok of ('a, 'b) t | `Duplicate_keys of 'a list ] (** {[ create_with_key ~get_key [x1;...;xn] = of_alist [get_key x1, x1; ...; get_key xn, xn] ]} *) val create_with_key : ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 0 *) -> 'a Key.t -> get_key:(('r -> 'a)[@local]) -> 'r list -> [ `Ok of ('a, 'r) t | `Duplicate_keys of 'a list ] val create_with_key_or_error : ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 0 *) -> 'a Key.t -> get_key:(('r -> 'a)[@local]) -> 'r list -> ('a, 'r) t Or_error.t val create_with_key_exn : ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 0 *) -> 'a Key.t -> get_key:(('r -> 'a)[@local]) -> 'r list -> ('a, 'r) t (** Like [create_mapped], applies the [get_key] and [get_data] functions to the ['r list] to create the initial keys and values, respectively, for the new hashtable -- and then, like [add_multi], folds together values belonging to the same keys. Here, though, the function used for the folding is given by [combine] (instead of just being a [cons]). Example: {v Hashtbl.group (module Int) ~get_key:((fun x -> x / 2)[@local]) ~get_data:((fun x -> x)[@local]) ~combine:((fun x y -> x * y)[@local]) [ 1; 2; 3; 4] |> Hashtbl.to_alist;; - : (int * int) list = [(2, 4); (1, 6); (0, 1)] v} *) val group : ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 0 *) -> 'a Key.t -> get_key:(('r -> 'a)[@local]) -> get_data:(('r -> 'b)[@local]) -> combine:(('b -> 'b -> 'b)[@local]) -> 'r list -> ('a, 'b) t end module type S_without_submodules = sig val hash : 'a -> int val hash_param : int -> int -> 'a -> int type (!'a, !'b) t (** We provide a [sexp_of_t] but not a [t_of_sexp] for this type because one needs to be explicit about the hash and comparison functions used when creating a hashtable. Note that [Hashtbl.Poly.t] does have [[@@deriving sexp]], and uses OCaml's built-in polymorphic comparison and and polymorphic hashing. *) val sexp_of_t : ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t include Creators with type ('a, 'b) t := ('a, 'b) t (** @inline *) include Accessors with type ('a, 'b) t := ('a, 'b) t with type 'a key = 'a (** @inline *) include Multi with type ('a, 'b) t := ('a, 'b) t with type 'a key := 'a key (** @inline *) val hashable_s : ('key, _) t -> 'key Key.t include Invariant.S2 with type ('a, 'b) t := ('a, 'b) t end module type S_poly = sig type ('a, 'b) t [@@deriving_inline sexp, sexp_grammar] include Sexplib0.Sexpable.S2 with type ('a, 'b) t := ('a, 'b) t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'b Sexplib0.Sexp_grammar.t -> ('a, 'b) t Sexplib0.Sexp_grammar.t [@@@end] val hashable : 'a Hashable.t include Invariant.S2 with type ('a, 'b) t := ('a, 'b) t include Creators_generic with type ('a, 'b) t := ('a, 'b) t with type 'a key = 'a with type ('key, 'data, 'z) create_options := ('key, 'data, 'z) create_options_without_first_class_module include Accessors with type ('a, 'b) t := ('a, 'b) t with type 'a key := 'a key include Multi with type ('a, 'b) t := ('a, 'b) t with type 'a key := 'a key end module type For_deriving = sig type ('k, 'v) t module type Sexp_of_m = sig type t [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end module type M_of_sexp = sig type t [@@deriving_inline of_sexp] val t_of_sexp : Sexplib0.Sexp.t -> t [@@@end] include Key.S with type t := t end module type M_sexp_grammar = sig type t [@@deriving_inline sexp_grammar] val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] end module type Equal_m = sig end val sexp_of_m__t : (module Sexp_of_m with type t = 'k) -> ('v -> Sexp.t) -> ('k, 'v) t -> Sexp.t val m__t_of_sexp : (module M_of_sexp with type t = 'k) -> (Sexp.t -> 'v) -> Sexp.t -> ('k, 'v) t val m__t_sexp_grammar : (module M_sexp_grammar with type t = 'k) -> 'v Sexplib0.Sexp_grammar.t -> ('k, 'v) t Sexplib0.Sexp_grammar.t val equal_m__t : (module Equal_m) -> ('v -> 'v -> bool) -> ('k, 'v) t -> ('k, 'v) t -> bool end module type Hashtbl = sig (** A hash table is a mutable data structure implementing a map between keys and values. It supports constant-time lookup and in-place modification. {1 Usage} As a simple example, we'll create a hash table with string keys using the {{!create}[create]} constructor, which expects a module defining the key's type: {[ let h = Hashtbl.create (module String);; val h : (string, '_a) Hashtbl.t = ]} We can set the values of individual keys with {{!set}[set]}. If the key already has a value, it will be overwritten. {v Hashtbl.set h ~key:"foo" ~data:5;; - : unit = () Hashtbl.set h ~key:"foo" ~data:6;; - : unit = () Hashtbl.set h ~key:"bar" ~data:6;; - : unit = () v} We can access values by key, or dump all of the hash table's data: {v Hashtbl.find h "foo";; - : int option = Some 6 Hashtbl.find_exn h "foo";; - : int = 6 Hashtbl.to_alist h;; - : (string * int) list = [("foo", 6); ("bar", 6)] v} {{!change}[change]} lets us change a key's value by applying the given function: {v Hashtbl.change h "foo" (fun x -> match x with | Some x -> Some (x * 2) | None -> None );; - : unit = () Hashtbl.to_alist h;; - : (string * int) list = [("foo", 12); ("bar", 6)] v} We can use {{!merge}[merge]} to merge two hashtables with fine-grained control over how we choose values when a key is present in the first ("left") hashtable, the second ("right"), or both. Here, we'll cons the values when both hashtables have a key: {v let h1 = Hashtbl.of_alist_exn (module Int) [(1, 5); (2, 3232)] in let h2 = Hashtbl.of_alist_exn (module Int) [(1, 3)] in Hashtbl.merge h1 h2 ~f:(fun ~key:_ -> function | `Left x -> Some (`Left x) | `Right x -> Some (`Right x) | `Both (x, y) -> if x=y then None else Some (`Both (x,y)) ) |> Hashtbl.to_alist;; - : (int * [> `Both of int * int | `Left of int | `Right of int ]) list = [(2, `Left 3232); (1, `Both (5, 3))] v} {1 Interface} *) include S_without_submodules (** @inline *) module type Accessors = Accessors module type Creators = Creators module type Multi = Multi module type S_poly = S_poly module type S_without_submodules = S_without_submodules module type For_deriving = For_deriving module Key = Key module Merge_into_action = Merge_into_action type nonrec ('key, 'data, 'z) create_options = ('key, 'data, 'z) create_options module Creators (Key : sig type 'a t val hashable : 'a t Hashable.t end) : sig type ('a, 'b) t_ = ('a Key.t, 'b) t val t_of_sexp : (Sexp.t -> 'a Key.t) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) t_ include Creators_generic with type ('a, 'b) t := ('a, 'b) t_ with type 'a key := 'a Key.t with type ('key, 'data, 'a) create_options := ('key, 'data, 'a) create_options_without_first_class_module end module Poly : S_poly with type ('a, 'b) t = ('a, 'b) t (** [M] is meant to be used in combination with OCaml applicative functor types: {[ type string_to_int_table = int Hashtbl.M(String).t ]} which stands for: {[ type string_to_int_table = (String.t, int) Hashtbl.t ]} The point is that [int Hashtbl.M(String).t] supports deriving, whereas the second syntax doesn't (because [t_of_sexp] doesn't know what comparison/hash function to use). *) module M (K : T.T) : sig type nonrec 'v t = (K.t, 'v) t end include For_deriving with type ('a, 'b) t := ('a, 'b) t (**/**) (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig module type Creators_generic = Creators_generic type nonrec ('key, 'data, 'z) create_options_without_first_class_module = ('key, 'data, 'z) create_options_without_first_class_module val hashable : ('key, _) t -> 'key Hashable.t end end base-0.16.3/src/hex_lexer.mli000066400000000000000000000001331446274340700160000ustar00rootroot00000000000000type result = | Neg of string | Pos of string val parse_hex : Lexing.lexbuf -> result base-0.16.3/src/hex_lexer.mll000066400000000000000000000005371446274340700160130ustar00rootroot00000000000000{ type result = | Neg of string | Pos of string } let hex_digit = ['0' - '9' 'A' - 'F' 'a' - 'f'] let body = (hex_digit (hex_digit | '_')*) as body let body_with_suffix = '0' ['X' 'x'] body let pos = body_with_suffix let neg = '-' body_with_suffix rule parse_hex = parse | neg { Neg body } | pos { Pos body } base-0.16.3/src/identifiable.ml000066400000000000000000000006751446274340700162760ustar00rootroot00000000000000open! Import include Identifiable_intf module Make (T : Arg) = struct include T include Comparable.Make (T) include Pretty_printer.Register (T) let hashable : t Hashable.t = { hash; compare; sexp_of_t } end module Make_using_comparator (T : Arg_with_comparator) = struct include T include Comparable.Make_using_comparator (T) include Pretty_printer.Register (T) let hashable : t Hashable.t = { hash; compare; sexp_of_t } end base-0.16.3/src/identifiable.mli000066400000000000000000000000661446274340700164410ustar00rootroot00000000000000include Identifiable_intf.Identifiable (** @inline *) base-0.16.3/src/identifiable_intf.ml000066400000000000000000000037401446274340700173120ustar00rootroot00000000000000(** A signature combining functionality that is commonly used for types that are intended to act as names or identifiers. Modules that satisfy [Identifiable] can be printed and parsed (both through string and s-expression converters) and can be used in hash-based and comparison-based containers (e.g., hashtables and maps). This module also provides functors for conveniently constructing identifiable modules. *) open! Import module type Arg = sig type t [@@deriving_inline compare, hash, sexp] include Ppx_compare_lib.Comparable.S with type t := t include Ppx_hash_lib.Hashable.S with type t := t include Sexplib0.Sexpable.S with type t := t [@@@end] include Stringable.S with type t := t (** For registering the pretty printer. *) val module_name : string end module type Arg_with_comparator = sig include Arg include Comparator.S with type t := t end module type S = sig type t [@@deriving_inline hash, sexp] include Ppx_hash_lib.Hashable.S with type t := t include Sexplib0.Sexpable.S with type t := t [@@@end] include Stringable.S with type t := t include Comparable.S with type t := t include Pretty_printer.S with type t := t val hashable : t Hashable.t end module type Identifiable = sig module type Arg = Arg module type Arg_with_comparator = Arg_with_comparator module type S = S (** Used for making an Identifiable module. Here's an example. {[ module Id = struct module T = struct type t = A | B [@@deriving compare, hash, sexp] let of_string s = t_of_sexp (sexp_of_string s) let to_string t = string_of_sexp (sexp_of_t t) let module_name = "My_library.Id" end include T include Identifiable.Make (T) end ]} *) module Make (M : Arg) : S with type t := M.t module Make_using_comparator (M : Arg_with_comparator) : S with type t := M.t with type comparator_witness := M.comparator_witness end base-0.16.3/src/import.ml000066400000000000000000000002341446274340700151600ustar00rootroot00000000000000include Import0 include Sexplib0.Sexp_conv include Hash.Builtin include Ppx_compare_lib.Builtin include Globalize exception Not_found_s = Sexp.Not_found_s base-0.16.3/src/import0.ml000066400000000000000000000310401446274340700152370ustar00rootroot00000000000000(* This module is included in [Import]. It is aimed at modules that define the standard combinators for [sexp_of], [of_sexp], [compare] and [hash] and are included in [Import]. *) include ( Shadow_stdlib : module type of struct include Shadow_stdlib end with type 'a ref := 'a ref with type ('a, 'b, 'c) format := ('a, 'b, 'c) format with type ('a, 'b, 'c, 'd) format4 := ('a, 'b, 'c, 'd) format4 with type ('a, 'b, 'c, 'd, 'e, 'f) format6 := ('a, 'b, 'c, 'd, 'e, 'f) format6 (* These modules are redefined in Base *) with module Array := Shadow_stdlib.Array with module Atomic := Shadow_stdlib.Atomic with module Bool := Shadow_stdlib.Bool with module Buffer := Shadow_stdlib.Buffer with module Bytes := Shadow_stdlib.Bytes with module Char := Shadow_stdlib.Char with module Either := Shadow_stdlib.Either with module Float := Shadow_stdlib.Float with module Hashtbl := Shadow_stdlib.Hashtbl with module Int := Shadow_stdlib.Int with module Int32 := Shadow_stdlib.Int32 with module Int64 := Shadow_stdlib.Int64 with module Lazy := Shadow_stdlib.Lazy with module List := Shadow_stdlib.List with module Map := Shadow_stdlib.Map with module Nativeint := Shadow_stdlib.Nativeint with module Option := Shadow_stdlib.Option with module Printf := Shadow_stdlib.Printf with module Queue := Shadow_stdlib.Queue with module Random := Shadow_stdlib.Random with module Result := Shadow_stdlib.Result with module Set := Shadow_stdlib.Set with module Stack := Shadow_stdlib.Stack with module String := Shadow_stdlib.String with module Sys := Shadow_stdlib.Sys with module Uchar := Shadow_stdlib.Uchar with module Unit := Shadow_stdlib.Unit) [@ocaml.warning "-3"] type 'a ref = 'a Stdlib.ref = { mutable contents : 'a } (* Reshuffle [Stdlib] so that we choose the modules using labels when available. *) module Stdlib = struct include Stdlib include Stdlib.StdLabels include Stdlib.MoreLabels end external ( |> ) : 'a -> (('a -> 'b)[@local_opt]) -> 'b = "%revapply" (* These need to be declared as an external to get the lazy behavior *) external ( && ) : (bool[@local_opt]) -> (bool[@local_opt]) -> bool = "%sequand" external ( || ) : (bool[@local_opt]) -> (bool[@local_opt]) -> bool = "%sequor" external not : (bool[@local_opt]) -> bool = "%boolnot" (* We use [Obj.magic] here as other implementations generate a conditional jump and the performance difference is noticeable. *) let bool_to_int (x : bool) : int = Stdlib.Obj.magic x (* This need to be declared as an external for the warnings to work properly *) external ignore : _ -> unit = "%ignore" let ( != ) = Stdlib.( != ) let ( * ) = Stdlib.( * ) let ( ** ) = Stdlib.( ** ) let ( *. ) = Stdlib.( *. ) let ( + ) = Stdlib.( + ) let ( +. ) = Stdlib.( +. ) let ( - ) = Stdlib.( - ) let ( -. ) = Stdlib.( -. ) let ( / ) = Stdlib.( / ) let ( /. ) = Stdlib.( /. ) module Poly = Poly0 (** @canonical Base.Poly *) module Int_replace_polymorphic_compare = struct (* Declared as externals so that the compiler skips the caml_apply_X wrapping even when compiling without cross library inlining. *) external ( = ) : (int[@local_opt]) -> (int[@local_opt]) -> bool = "%equal" external ( <> ) : (int[@local_opt]) -> (int[@local_opt]) -> bool = "%notequal" external ( < ) : (int[@local_opt]) -> (int[@local_opt]) -> bool = "%lessthan" external ( > ) : (int[@local_opt]) -> (int[@local_opt]) -> bool = "%greaterthan" external ( <= ) : (int[@local_opt]) -> (int[@local_opt]) -> bool = "%lessequal" external ( >= ) : (int[@local_opt]) -> (int[@local_opt]) -> bool = "%greaterequal" external compare : (int[@local_opt]) -> (int[@local_opt]) -> int = "%compare" external equal : (int[@local_opt]) -> (int[@local_opt]) -> bool = "%equal" let ascending (x : int) y = compare x y let descending (x : int) y = compare y x let max (x : int) y = Bool0.select (x >= y) x y let min (x : int) y = Bool0.select (x <= y) x y end include Int_replace_polymorphic_compare module Int32_replace_polymorphic_compare = struct let ( < ) (x : Stdlib.Int32.t) y = Poly.( < ) x y let ( <= ) (x : Stdlib.Int32.t) y = Poly.( <= ) x y let ( <> ) (x : Stdlib.Int32.t) y = Poly.( <> ) x y let ( = ) (x : Stdlib.Int32.t) y = Poly.( = ) x y let ( > ) (x : Stdlib.Int32.t) y = Poly.( > ) x y let ( >= ) (x : Stdlib.Int32.t) y = Poly.( >= ) x y let ascending (x : Stdlib.Int32.t) y = Poly.ascending x y let descending (x : Stdlib.Int32.t) y = Poly.descending x y let compare (x : Stdlib.Int32.t) y = Poly.compare x y let equal (x : Stdlib.Int32.t) y = Poly.equal x y let max (x : Stdlib.Int32.t) y = Bool0.select (x >= y) x y let min (x : Stdlib.Int32.t) y = Bool0.select (x <= y) x y end module Int64_replace_polymorphic_compare = struct (* Declared as externals so that the compiler skips the caml_apply_X wrapping even when compiling without cross library inlining. *) external ( = ) : (Stdlib.Int64.t[@local_opt]) -> (Stdlib.Int64.t[@local_opt]) -> bool = "%equal" external ( <> ) : (Stdlib.Int64.t[@local_opt]) -> (Stdlib.Int64.t[@local_opt]) -> bool = "%notequal" external ( < ) : (Stdlib.Int64.t[@local_opt]) -> (Stdlib.Int64.t[@local_opt]) -> bool = "%lessthan" external ( > ) : (Stdlib.Int64.t[@local_opt]) -> (Stdlib.Int64.t[@local_opt]) -> bool = "%greaterthan" external ( <= ) : (Stdlib.Int64.t[@local_opt]) -> (Stdlib.Int64.t[@local_opt]) -> bool = "%lessequal" external ( >= ) : (Stdlib.Int64.t[@local_opt]) -> (Stdlib.Int64.t[@local_opt]) -> bool = "%greaterequal" external compare : (Stdlib.Int64.t[@local_opt]) -> (Stdlib.Int64.t[@local_opt]) -> int = "%compare" external equal : (Stdlib.Int64.t[@local_opt]) -> (Stdlib.Int64.t[@local_opt]) -> bool = "%equal" let ascending (x : Stdlib.Int64.t) y = Poly.ascending x y let descending (x : Stdlib.Int64.t) y = Poly.descending x y let max (x : Stdlib.Int64.t) y = Bool0.select (x >= y) x y let min (x : Stdlib.Int64.t) y = Bool0.select (x <= y) x y end module Nativeint_replace_polymorphic_compare = struct let ( < ) (x : Stdlib.Nativeint.t) y = Poly.( < ) x y let ( <= ) (x : Stdlib.Nativeint.t) y = Poly.( <= ) x y let ( <> ) (x : Stdlib.Nativeint.t) y = Poly.( <> ) x y let ( = ) (x : Stdlib.Nativeint.t) y = Poly.( = ) x y let ( > ) (x : Stdlib.Nativeint.t) y = Poly.( > ) x y let ( >= ) (x : Stdlib.Nativeint.t) y = Poly.( >= ) x y let ascending (x : Stdlib.Nativeint.t) y = Poly.ascending x y let descending (x : Stdlib.Nativeint.t) y = Poly.descending x y let compare (x : Stdlib.Nativeint.t) y = Poly.compare x y let equal (x : Stdlib.Nativeint.t) y = Poly.equal x y let max (x : Stdlib.Nativeint.t) y = Bool0.select (x >= y) x y let min (x : Stdlib.Nativeint.t) y = Bool0.select (x <= y) x y end module Bool_replace_polymorphic_compare = struct let ( < ) (x : bool) y = Poly.( < ) x y let ( <= ) (x : bool) y = Poly.( <= ) x y let ( <> ) (x : bool) y = Poly.( <> ) x y let ( = ) (x : bool) y = Poly.( = ) x y let ( > ) (x : bool) y = Poly.( > ) x y let ( >= ) (x : bool) y = Poly.( >= ) x y let ascending (x : bool) y = Poly.ascending x y let descending (x : bool) y = Poly.descending x y let compare (x : bool) y = Poly.compare x y let equal (x : bool) y = Poly.equal x y let max (x : bool) y = Bool0.select (x >= y) x y let min (x : bool) y = Bool0.select (x <= y) x y end module Char_replace_polymorphic_compare = struct let ( < ) (x : char) y = Poly.( < ) x y let ( <= ) (x : char) y = Poly.( <= ) x y let ( <> ) (x : char) y = Poly.( <> ) x y let ( = ) (x : char) y = Poly.( = ) x y let ( > ) (x : char) y = Poly.( > ) x y let ( >= ) (x : char) y = Poly.( >= ) x y let ascending (x : char) y = Poly.ascending x y let descending (x : char) y = Poly.descending x y let compare (x : char) y = Poly.compare x y let equal (x : char) y = Poly.equal x y let max (x : char) y = Bool0.select (x >= y) x y let min (x : char) y = Bool0.select (x <= y) x y end module Uchar_replace_polymorphic_compare = struct let i x = Stdlib.Uchar.to_int x let ( < ) (x : Stdlib.Uchar.t) y = Int_replace_polymorphic_compare.( < ) (i x) (i y) let ( <= ) (x : Stdlib.Uchar.t) y = Int_replace_polymorphic_compare.( <= ) (i x) (i y) let ( <> ) (x : Stdlib.Uchar.t) y = Int_replace_polymorphic_compare.( <> ) (i x) (i y) let ( = ) (x : Stdlib.Uchar.t) y = Int_replace_polymorphic_compare.( = ) (i x) (i y) let ( > ) (x : Stdlib.Uchar.t) y = Int_replace_polymorphic_compare.( > ) (i x) (i y) let ( >= ) (x : Stdlib.Uchar.t) y = Int_replace_polymorphic_compare.( >= ) (i x) (i y) let ascending (x : Stdlib.Uchar.t) y = Int_replace_polymorphic_compare.ascending (i x) (i y) ;; let descending (x : Stdlib.Uchar.t) y = Int_replace_polymorphic_compare.descending (i x) (i y) ;; let compare (x : Stdlib.Uchar.t) y = Int_replace_polymorphic_compare.compare (i x) (i y) let equal (x : Stdlib.Uchar.t) y = Int_replace_polymorphic_compare.equal (i x) (i y) let max (x : Stdlib.Uchar.t) y = Bool0.select (x >= y) x y let min (x : Stdlib.Uchar.t) y = Bool0.select (x <= y) x y end module Float_replace_polymorphic_compare = struct let ( < ) (x : float) y = Poly.( < ) x y let ( <= ) (x : float) y = Poly.( <= ) x y let ( <> ) (x : float) y = Poly.( <> ) x y let ( = ) (x : float) y = Poly.( = ) x y let ( > ) (x : float) y = Poly.( > ) x y let ( >= ) (x : float) y = Poly.( >= ) x y let ascending (x : float) y = Poly.ascending x y let descending (x : float) y = Poly.descending x y let compare (x : float) y = Poly.compare x y let equal (x : float) y = Poly.equal x y let max (x : float) y = Bool0.select (x >= y) x y let min (x : float) y = Bool0.select (x <= y) x y end module String_replace_polymorphic_compare = struct let ( < ) (x : string) y = Poly.( < ) x y let ( <= ) (x : string) y = Poly.( <= ) x y let ( <> ) (x : string) y = Poly.( <> ) x y let ( = ) (x : string) y = Poly.( = ) x y let ( > ) (x : string) y = Poly.( > ) x y let ( >= ) (x : string) y = Poly.( >= ) x y let ascending (x : string) y = Poly.ascending x y let descending (x : string) y = Poly.descending x y let compare (x : string) y = Poly.compare x y let equal (x : string) y = Poly.equal x y let max (x : string) y = Bool0.select (x >= y) x y let min (x : string) y = Bool0.select (x <= y) x y end module Bytes_replace_polymorphic_compare = struct let ( < ) (x : bytes) y = Poly.( < ) x y let ( <= ) (x : bytes) y = Poly.( <= ) x y let ( <> ) (x : bytes) y = Poly.( <> ) x y let ( = ) (x : bytes) y = Poly.( = ) x y let ( > ) (x : bytes) y = Poly.( > ) x y let ( >= ) (x : bytes) y = Poly.( >= ) x y let ascending (x : bytes) y = Poly.ascending x y let descending (x : bytes) y = Poly.descending x y let compare (x : bytes) y = Poly.compare x y let equal (x : bytes) y = Poly.equal x y let max (x : bytes) y = Bool0.select (x >= y) x y let min (x : bytes) y = Bool0.select (x <= y) x y end (* This needs to be defined as an external so that the compiler can specialize it as a direct set or caml_modify *) external ( := ) : ('a ref[@local_opt]) -> 'a -> unit = "%setfield0" (* These need to be defined as an external otherwise the compiler won't unbox references *) external ( ! ) : ('a ref[@local_opt]) -> 'a = "%field0" external ref : 'a -> ('a ref[@local_opt]) = "%makemutable" let ( @ ) = Stdlib.( @ ) let ( ^ ) = Stdlib.( ^ ) let ( ~- ) = Stdlib.( ~- ) let ( ~-. ) = Stdlib.( ~-. ) let ( asr ) = Stdlib.( asr ) let ( land ) = Stdlib.( land ) let lnot = Stdlib.lnot let ( lor ) = Stdlib.( lor ) let ( lsl ) = Stdlib.( lsl ) let ( lsr ) = Stdlib.( lsr ) let ( lxor ) = Stdlib.( lxor ) let ( mod ) = Stdlib.( mod ) let abs = Stdlib.abs let failwith = Stdlib.failwith let fst = Stdlib.fst let invalid_arg = Stdlib.invalid_arg let snd = Stdlib.snd (* [raise] needs to be defined as an external as the compiler automatically replaces '%raise' by '%reraise' when appropriate. *) external raise : exn -> _ = "%raise" let phys_equal = Stdlib.( == ) external decr : (int ref[@local_opt]) -> unit = "%decr" external incr : (int ref[@local_opt]) -> unit = "%incr" (* used by sexp_conv, which float0 depends on through option *) let float_of_string = Stdlib.float_of_string (* [am_testing] is used in a few places to behave differently when in testing mode, such as in [random.ml]. [am_testing] is implemented using [Base_am_testing], a weak C/js primitive that returns [false], but when linking an inline-test-runner executable, is overridden by another primitive that returns [true]. *) external am_testing : unit -> bool = "Base_am_testing" let am_testing = am_testing () base-0.16.3/src/index.mld000066400000000000000000000132711446274340700151260ustar00rootroot00000000000000{0 Base} {b {{!Base} The full API is browsable here}}. Base is a standard library for OCaml. It provides a standard set of general-purpose modules that are well tested, performant, and fully portable across any environment that can run OCaml code. Unlike other standard library projects, Base is meant to be used as a wholesale replacement of the standard library distributed with the OCaml compiler. In particular, it makes different choices and doesn't re-export features that are not fully portable such as I/O, which are left to other libraries. Note that an API for OCaml's channel-based I/O can be found in the {{!module:Stdio}[Stdio]} library. {1 Relationship to Core} - {b {!Base}}: Minimal stdlib replacement. Portable and lightweight and intended to be highly stable. - {b {!Core}}: Extension of Base. More fully featured, with more code and dependencies, and APIs that evolve more quickly. Portable, and works on Javascript. {1 Using the OCaml standard library with Base} Base is intended as a full stdlib replacement. As a result, after an [open Base], all the modules, values, types, etc., coming from the OCaml standard library that one normally gets in the default environment are deprecated. In order to access these values, one must use the [Stdlib] library, which re-exports them all through the toplevel name {{!module:Stdlib}[Stdlib]}: [Stdlib.String], [Stdlib.print_string], ... The new modules and values made available by Base are documented {{!Base} here}. {1 Differences between Base and the OCaml standard library} Programmers who are used to the OCaml standard library should read through this section to understand major differences between the two libraries that one should be aware of when switching to Base. {2 Comparison operators} The comparison operators exposed by the OCaml standard library are polymorphic: {[ val compare : 'a -> 'a -> int val ( <= ) : 'a -> 'a -> bool (* ... *) ]} What they implement is structural comparison of the runtime representation of values. Since these are often error-prone, i.e., they don't correspond to what the user expects, they are not exposed directly by Base. To use polymorphic comparison with Base, one should use the {{!Base.Polymorphic_compare}[Polymorphic_compare]} module. The default comparison operators exposed by Base are the integer ones, just like the default arithmetic operators are the integer ones. The recommended way to compare arbitrary complex data structures is to use the specific [compare] functions. For instance: {[ List.compare String.compare x y ]} The [ppx_compare] rewriter offers an alternative way to write this: {[ [%compare: string list] x y ]} {1 Base and ppx code generators} Base uses a few ppx code generators to implement: - reliable and customizable comparison of OCaml values; - reliable and customizable hash of OCaml values; and - conversions between OCaml values and s-expression. However, it doesn't need these code generators to build. Instead, it uses ppx as a code verification tool during development. It works in a very similar fashion to {{: https://github.com/janestreet/ppx_expect} expect tests}. Whenever you see this in the code source: {[ type t = ... [@@deriving_inline sexp_of] let sexp_of_t = ... [@@@end] ]} the code between the [[@@deriving_inline]] and the [[@@@end]] is generated code. The generated code is currently quite big and hard to read, however we are working on making it look like human-written code. You can put the following elisp code in your [~/.emacs] file to hide these blocks: {v (defun deriving-inline-forward-sexp (&optional arg) (search-forward-regexp "\\[@@@end\\]") nil nil arg) (defun setup-hide-deriving-inline () (inline) (hs-minor-mode t) (let ((hs-hide-comments-when-hiding-all nil)) (hs-hide-all))) (require 'hideshow) (add-to-list 'hs-special-modes-alist '(tuareg-mode "\\[@@deriving_inline[^]]*\\]" "\\[@@@end\\]" nil deriving-inline-forward-sexp nil)) (add-hook 'tuareg-mode-hook 'setup-hide-deriving-inline) v} Things are not yet set up in the git repository to make it convenient to change types and update the generated code, but they will be set up soon. {1 Base coding rules} There are a few coding rules across the code base that are enforced by lint tools. These rules are: {ul {- Opening the [Stdlib] module is not allowed. Inside Base, the OCaml stdlib is shadowed and accessible through the [Stdlib] module. We forbid opening [Stdlib] so that we know exactly where things come from.} {- [Stdlib.Foo] modules cannot be aliased, one must use [Stdlib.Foo] explicitly. This is to avoid having to remember a list of aliases at the beginning of each file.} {- For some modules that are both in the OCaml stdlib and Base, such as [String], we define a module [String0] for common functions that cannot be defined directly in [Base.String] to avoid creating a circular dependency. Except for [String] itself, other modules are not allowed to use [Stdlib.String] and must use either [String] or [String0] instead.} {- Indentation is exactly the one of [ocp-indent].} {- A few other coding style rules enforced by {{: https://github.com/janestreet/ppx_js_style} ppx_js_style}.} } The Base specific coding rules are checked by [ppx_base_lint], in the [lint] subfolder. The indentation rules are checked by a wrapper around [ocp-indent] and the coding style rules are checked by [ppx_js_style]. These checks are currently not run by [dune], but it will soon get a [-dev] flag to run them automatically. {1 Roadmap} Base is still under active development and there are several missing feature that are yet to be added. Consult the {{:https://github.com/janestreet/base/blob/master/ROADMAP.md}roadmap} to see what is happening. base-0.16.3/src/indexed_container.ml000066400000000000000000000101371446274340700173330ustar00rootroot00000000000000open! Import module Array = Array0 include Indexed_container_intf let with_return = With_return.with_return let iteri ~fold t ~f = ignore (fold t ~init:0 ~f:(fun i x -> f i x; i + 1) : int) ;; let foldi ~fold t ~init ~f = let i = ref 0 in fold t ~init ~f:(fun acc v -> let acc = f !i acc v in i := !i + 1; acc) [@nontail] ;; let counti ~foldi t ~f = foldi t ~init:0 ~f:(fun i n a -> if f i a then n + 1 else n) [@nontail] ;; let existsi ~iteri c ~f = with_return (fun r -> iteri c ~f:(fun i x -> if f i x then r.return true); false) [@nontail] ;; let for_alli ~iteri c ~f = with_return (fun r -> iteri c ~f:(fun i x -> if not (f i x) then r.return false); true) [@nontail] ;; let find_mapi ~iteri t ~f = with_return (fun r -> iteri t ~f:(fun i x -> match f i x with | None -> () | Some _ as res -> r.return res); None) [@nontail] ;; let findi ~iteri c ~f = with_return (fun r -> iteri c ~f:(fun i x -> if f i x then r.return (Some (i, x))); None) [@nontail] ;; (* Allows [Make_gen] to share a [Container.Generic] implementation with, e.g., [Container.Make_gen_with_creators]. *) module Make_gen_with_container (T : Make_gen_arg) (C : Container.Generic with type ('a, 'phantom) t := ('a, 'phantom) T.t and type 'a elt := 'a T.elt) : Generic with type ('a, 'phantom) t := ('a, 'phantom) T.t and type 'a elt := 'a T.elt = struct include C let iteri = match T.iteri with | `Custom iteri -> iteri | `Define_using_fold -> fun t ~f -> iteri ~fold t ~f ;; let foldi = match T.foldi with | `Custom foldi -> foldi | `Define_using_fold -> fun t ~init ~f -> foldi ~fold t ~init ~f ;; let counti t ~f = counti ~foldi t ~f let existsi t ~f = existsi ~iteri t ~f let for_alli t ~f = for_alli ~iteri t ~f let find_mapi t ~f = find_mapi ~iteri t ~f let findi t ~f = findi ~iteri t ~f end module Make_gen (T : Make_gen_arg) : Generic with type ('a, 'phantom) t := ('a, 'phantom) T.t and type 'a elt := 'a T.elt = struct module C = Container.Make_gen (T) include C include Make_gen_with_container (T) (C) end module Make (T : Make_arg) = struct include Make_gen (struct include T type ('a, _) t = 'a T.t type 'a elt = 'a end) end module Make0 (T : Make0_arg) = struct include Make_gen (struct include T type (_, _) t = T.t type 'a elt = T.Elt.t end) let mem t x = mem t x ~equal:T.Elt.equal end module Make_gen_with_creators (T : Make_gen_with_creators_arg) : Generic_with_creators with type ('a, 'phantom) t := ('a, 'phantom) T.t and type 'a elt := 'a T.elt and type ('a, 'phantom) concat := ('a, 'phantom) T.concat = struct module C = Container.Make_gen_with_creators (T) include C include Make_gen_with_container (T) (C) let derived_init n ~f = of_array (Array.init n ~f) let init = match T.init with | `Custom init -> init | `Define_using_of_array -> derived_init ;; let derived_concat_mapi t ~f = concat (T.concat_of_array (Array.mapi (to_array t) ~f)) let concat_mapi = match T.concat_mapi with | `Custom concat_mapi -> concat_mapi | `Define_using_concat -> derived_concat_mapi ;; let filter_mapi t ~f = concat_mapi t ~f:(fun i x -> match f i x with | None -> of_array [||] | Some y -> of_array [| y |]) [@nontail] ;; let mapi t ~f = filter_mapi t ~f:(fun i x -> Some (f i x)) [@nontail] let filteri t ~f = filter_mapi t ~f:(fun i x -> if f i x then Some x else None) [@nontail] ;; end module Make_with_creators (T : Make_with_creators_arg) = struct include Make_gen_with_creators (struct include T type ('a, _) t = 'a T.t type 'a elt = 'a type ('a, _) concat = 'a T.t let concat_of_array = of_array end) end module Make0_with_creators (T : Make0_with_creators_arg) = struct include Make_gen_with_creators (struct include T type (_, _) t = T.t type 'a elt = T.Elt.t type ('a, _) concat = 'a list let concat_of_array = Array.to_list end) let mem t x = mem t x ~equal:T.Elt.equal end base-0.16.3/src/indexed_container.mli000066400000000000000000000001001446274340700174710ustar00rootroot00000000000000include Indexed_container_intf.Indexed_container (** @inline *) base-0.16.3/src/indexed_container_intf.ml000066400000000000000000000207511446274340700203560ustar00rootroot00000000000000 type ('t, 'a, 'accum) fold = 't -> init:'accum -> f:(('accum -> 'a -> 'accum)[@local]) -> 'accum type ('t, 'a, 'accum) foldi = 't -> init:'accum -> f:((int -> 'accum -> 'a -> 'accum)[@local]) -> 'accum type ('t, 'a) iteri = 't -> f:((int -> 'a -> unit)[@local]) -> unit module type S0 = sig include Container.S0 (** These are all like their equivalents in [Container] except that an index starting at 0 is added as the first argument to [f]. *) val foldi : (t, elt, _) foldi val iteri : (t, elt) iteri val existsi : t -> f:((int -> elt -> bool)[@local]) -> bool val for_alli : t -> f:((int -> elt -> bool)[@local]) -> bool val counti : t -> f:((int -> elt -> bool)[@local]) -> int val findi : t -> f:((int -> elt -> bool)[@local]) -> (int * elt) option val find_mapi : t -> f:((int -> elt -> 'a option)[@local]) -> 'a option end module type S1 = sig include Container.S1 (** These are all like their equivalents in [Container] except that an index starting at 0 is added as the first argument to [f]. *) val foldi : ('a t, 'a, _) foldi val iteri : ('a t, 'a) iteri val existsi : 'a t -> f:((int -> 'a -> bool)[@local]) -> bool val for_alli : 'a t -> f:((int -> 'a -> bool)[@local]) -> bool val counti : 'a t -> f:((int -> 'a -> bool)[@local]) -> int val findi : 'a t -> f:((int -> 'a -> bool)[@local]) -> (int * 'a) option val find_mapi : 'a t -> f:((int -> 'a -> 'b option)[@local]) -> 'b option end module type Generic = sig include Container.Generic (** These are all like their equivalents in [Container] except that an index starting at 0 is added as the first argument to [f]. *) val foldi : (('a, _) t, 'a elt, _) foldi val iteri : (('a, _) t, 'a elt) iteri val existsi : ('a, _) t -> f:((int -> 'a elt -> bool)[@local]) -> bool val for_alli : ('a, _) t -> f:((int -> 'a elt -> bool)[@local]) -> bool val counti : ('a, _) t -> f:((int -> 'a elt -> bool)[@local]) -> int val findi : ('a, _) t -> f:((int -> 'a elt -> bool)[@local]) -> (int * 'a elt) option val find_mapi : ('a, _) t -> f:((int -> 'a elt -> 'b option)[@local]) -> 'b option end module type S0_with_creators = sig include Container.S0_with_creators include S0 with type t := t and type elt := elt (** [init n ~f] is equivalent to [of_list [f 0; f 1; ...; f (n-1)]]. It raises an exception if [n < 0]. *) val init : int -> f:((int -> elt)[@local]) -> t (** [mapi] is like map. Additionally, it passes in the index of each element as the first argument to the mapped function. *) val mapi : t -> f:((int -> elt -> elt)[@local]) -> t val filteri : t -> f:((int -> elt -> bool)[@local]) -> t (** filter_mapi is like [filter_map]. Additionally, it passes in the index of each element as the first argument to the mapped function. *) val filter_mapi : t -> f:((int -> elt -> elt option)[@local]) -> t (** [concat_mapi t ~f] is like concat_map. Additionally, it passes the index as an argument. *) val concat_mapi : t -> f:((int -> elt -> t)[@local]) -> t end module type S1_with_creators = sig include Container.S1_with_creators include S1 with type 'a t := 'a t (** [init n ~f] is equivalent to [of_list [f 0; f 1; ...; f (n-1)]]. It raises an exception if [n < 0]. *) val init : int -> f:((int -> 'a)[@local]) -> 'a t (** [mapi] is like map. Additionally, it passes in the index of each element as the first argument to the mapped function. *) val mapi : 'a t -> f:((int -> 'a -> 'b)[@local]) -> 'b t val filteri : 'a t -> f:((int -> 'a -> bool)[@local]) -> 'a t (** filter_mapi is like [filter_map]. Additionally, it passes in the index of each element as the first argument to the mapped function. *) val filter_mapi : 'a t -> f:((int -> 'a -> 'b option)[@local]) -> 'b t (** [concat_mapi t ~f] is like concat_map. Additionally, it passes the index as an argument. *) val concat_mapi : 'a t -> f:((int -> 'a -> 'b t)[@local]) -> 'b t end module type Generic_with_creators = sig include Container.Generic_with_creators include Generic with type 'a elt := 'a elt and type ('a, 'phantom) t := ('a, 'phantom) t val init : int -> f:((int -> 'a elt)[@local]) -> ('a, _) t val mapi : ('a, 'p) t -> f:((int -> 'a elt -> 'b elt)[@local]) -> ('b, 'p) t val filteri : ('a, 'p) t -> f:((int -> 'a elt -> bool)[@local]) -> ('a, 'p) t val filter_mapi : ('a, 'p) t -> f:((int -> 'a elt -> 'b elt option)[@local]) -> ('b, 'p) t val concat_mapi : ('a, 'p) t -> f:((int -> 'a elt -> ('b, 'p) t)[@local]) -> ('b, 'p) t end module type Make_gen_arg = sig include Container_intf.Make_gen_arg val iteri : [ `Define_using_fold | `Custom of (('a, _) t, 'a elt) iteri ] val foldi : [ `Define_using_fold | `Custom of (('a, _) t, 'a elt, _) foldi ] end module type Make_arg = sig include Container_intf.Make_arg include Make_gen_arg with type ('a, _) t := 'a t and type 'a elt := 'a end module type Make0_arg = sig include Container_intf.Make0_arg include Make_gen_arg with type ('a, _) t := t and type 'a elt := Elt.t end module type Make_common_with_creators_arg = sig include Container_intf.Make_common_with_creators_arg include Make_gen_arg with type ('a, 'p) t := ('a, 'p) t and type 'a elt := 'a elt val init : [ `Define_using_of_array | `Custom of int -> f:((int -> 'a elt)[@local]) -> ('a, _) t ] val concat_mapi : [ `Define_using_concat | `Custom of ('a, _) t -> f:((int -> 'a elt -> ('b, _) t)[@local]) -> ('b, _) t ] end module type Make_gen_with_creators_arg = sig include Container_intf.Make_gen_with_creators_arg include Make_common_with_creators_arg with type ('a, 'p) t := ('a, 'p) t and type 'a elt := 'a elt and type ('a, 'p) concat := ('a, 'p) concat end module type Make_with_creators_arg = sig include Container_intf.Make_with_creators_arg include Make_common_with_creators_arg with type ('a, _) t := 'a t and type 'a elt := 'a and type ('a, _) concat := 'a t end module type Make0_with_creators_arg = sig include Container_intf.Make0_with_creators_arg include Make_common_with_creators_arg with type ('a, _) t := t and type 'a elt := Elt.t and type ('a, _) concat := 'a list end module type Derived = sig (** Generic definitions of [foldi] and [iteri] in terms of [fold]. E.g., [iteri ~fold t ~f = ignore (fold t ~init:0 ~f:((fun i x -> f i x; i + 1)[@local]))]. *) val foldi : fold:('t, 'a, 'acc) fold -> ('t, 'a, 'acc) foldi val iteri : fold:('t, 'a, int) fold -> ('t, 'a) iteri (** Generic definitions of indexed container operations in terms of [foldi]. *) val counti : foldi:('t, 'a, int) foldi -> 't -> f:((int -> 'a -> bool)[@local]) -> int (** Generic definitions of indexed container operations in terms of [iteri]. *) val existsi : iteri:('t, 'a) iteri -> 't -> f:((int -> 'a -> bool)[@local]) -> bool val for_alli : iteri:('t, 'a) iteri -> 't -> f:((int -> 'a -> bool)[@local]) -> bool val findi : iteri:('t, 'a) iteri -> 't -> f:((int -> 'a -> bool)[@local]) -> (int * 'a) option val find_mapi : iteri:('t, 'a) iteri -> 't -> f:((int -> 'a -> 'b option)[@local]) -> 'b option end module type Indexed_container = sig (** Provides generic signatures for containers that support indexed iteration ([iteri], [foldi], ...). In principle, any container that has [iter] can also implement [iteri], but the idea is that [Indexed_container_intf] should be included only for containers that have a meaningful underlying ordering. *) module type Derived = Derived module type Generic = Generic module type Generic_with_creators = Generic_with_creators module type S0 = S0 module type S0_with_creators = S0_with_creators module type S1 = S1 module type S1_with_creators = S1_with_creators include Derived module Make (T : Make_arg) : S1 with type 'a t := 'a T.t module Make0 (T : Make0_arg) : S0 with type t := T.t and type elt := T.Elt.t module Make_gen (T : Make_gen_arg) : Generic with type ('a, 'phantom) t := ('a, 'phantom) T.t and type 'a elt := 'a T.elt module Make_with_creators (T : Make_with_creators_arg) : S1_with_creators with type 'a t := 'a T.t module Make0_with_creators (T : Make0_with_creators_arg) : S0_with_creators with type t := T.t and type elt := T.Elt.t module Make_gen_with_creators (T : Make_gen_with_creators_arg) : Generic_with_creators with type ('a, 'phantom) t := ('a, 'phantom) T.t and type 'a elt := 'a T.elt and type ('a, 'phantom) concat := ('a, 'phantom) T.concat end base-0.16.3/src/info.ml000066400000000000000000000217721446274340700146130ustar00rootroot00000000000000(* This module is trying to minimize dependencies on modules in Core, so as to allow [Info], [Error], and [Or_error] to be used in as many places as possible. Please avoid adding new dependencies. *) open! Import include Info_intf module Char = Char0 module String = String0 module Message = struct type t = | Could_not_construct of Sexp.t | String of string | Exn of exn | Sexp of Sexp.t | Tag_sexp of string * Sexp.t * Source_code_position0.t option | Tag_t of string * t | Tag_arg of string * Sexp.t * t | Of_list of int option * t list | With_backtrace of t * string (* backtrace *) [@@deriving_inline sexp_of] let rec sexp_of_t = (function | Could_not_construct arg0__001_ -> let res0__002_ = Sexp.sexp_of_t arg0__001_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Could_not_construct"; res0__002_ ] | String arg0__003_ -> let res0__004_ = sexp_of_string arg0__003_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "String"; res0__004_ ] | Exn arg0__005_ -> let res0__006_ = sexp_of_exn arg0__005_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Exn"; res0__006_ ] | Sexp arg0__007_ -> let res0__008_ = Sexp.sexp_of_t arg0__007_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Sexp"; res0__008_ ] | Tag_sexp (arg0__009_, arg1__010_, arg2__011_) -> let res0__012_ = sexp_of_string arg0__009_ and res1__013_ = Sexp.sexp_of_t arg1__010_ and res2__014_ = sexp_of_option Source_code_position0.sexp_of_t arg2__011_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Tag_sexp"; res0__012_; res1__013_; res2__014_ ] | Tag_t (arg0__015_, arg1__016_) -> let res0__017_ = sexp_of_string arg0__015_ and res1__018_ = sexp_of_t arg1__016_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Tag_t"; res0__017_; res1__018_ ] | Tag_arg (arg0__019_, arg1__020_, arg2__021_) -> let res0__022_ = sexp_of_string arg0__019_ and res1__023_ = Sexp.sexp_of_t arg1__020_ and res2__024_ = sexp_of_t arg2__021_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Tag_arg"; res0__022_; res1__023_; res2__024_ ] | Of_list (arg0__025_, arg1__026_) -> let res0__027_ = sexp_of_option sexp_of_int arg0__025_ and res1__028_ = sexp_of_list sexp_of_t arg1__026_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Of_list"; res0__027_; res1__028_ ] | With_backtrace (arg0__029_, arg1__030_) -> let res0__031_ = sexp_of_t arg0__029_ and res1__032_ = sexp_of_string arg1__030_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "With_backtrace"; res0__031_; res1__032_ ] : t -> Sexplib0.Sexp.t) ;; [@@@end] let rec to_strings_hum t ac = (* We use [Sexp.to_string_mach], despite the fact that we are implementing [to_strings_hum], because we want the info to fit on a single line, and once we've had to resort to sexps, the message is going to start not looking so pretty anyway. *) match t with | Could_not_construct sexp -> "could not construct info: " :: Sexp.to_string_mach sexp :: ac | String string -> string :: ac | Exn exn -> Sexp.to_string_mach (Exn.sexp_of_t exn) :: ac | Sexp sexp -> Sexp.to_string_mach sexp :: ac | Tag_sexp (tag, sexp, _) -> tag :: ": " :: Sexp.to_string_mach sexp :: ac | Tag_t (tag, t) -> tag :: ": " :: to_strings_hum t ac | Tag_arg (tag, sexp, t) -> let body = Sexp.to_string_mach sexp :: ": " :: to_strings_hum t ac in if String.length tag = 0 then body else tag :: ": " :: body | With_backtrace (t, backtrace) -> to_strings_hum t ("\nBacktrace:\n" :: backtrace :: ac) | Of_list (trunc_after, ts) -> let ts = match trunc_after with | None -> ts | Some max -> let n = List.length ts in if n <= max then ts else List.take ts max @ [ String (Printf.sprintf "and %d more info" (n - max)) ] in List.fold (List.rev ts) ~init:ac ~f:(fun ac t -> to_strings_hum t (if List.is_empty ac then ac else "; " :: ac)) ;; let to_string_hum_deprecated t = String.concat (to_strings_hum t []) (* Like [String.split_lines], but less optimized and doesn't handle [\r\n]. Avoids a dependency cycle. Improves on naive [String.split_on_char] by removing empty final line. *) let split_lines string = let string = let len = String.length string in if len > 0 && Char.equal '\n' (String.get string (len - 1)) then String.sub string ~pos:0 ~len:(len - 1) else string in String.split_on_char string ~sep:'\n' ;; let rec to_sexps_hum t ac = match t with | Could_not_construct _ as t -> sexp_of_t t :: ac | String string -> Atom string :: ac | Exn exn -> Exn.sexp_of_t exn :: ac | Sexp sexp -> sexp :: ac | Tag_sexp (tag, sexp, here) -> List (Atom tag :: sexp :: (match here with | None -> [] | Some here -> [ Source_code_position0.sexp_of_t here ])) :: ac | Tag_t (tag, t) -> List (Atom tag :: to_sexps_hum t []) :: ac | Tag_arg (tag, sexp, t) -> let body = sexp :: to_sexps_hum t [] in if String.length tag = 0 then List body :: ac else List (Atom tag :: body) :: ac | With_backtrace (t, backtrace) -> Sexp.List [ to_sexp_hum t; sexp_of_list sexp_of_string (split_lines backtrace) ] :: ac | Of_list (_, ts) -> List.fold (List.rev ts) ~init:ac ~f:(fun ac t -> to_sexps_hum t ac) and to_sexp_hum t = match to_sexps_hum t [] with | [ sexp ] -> sexp | sexps -> Sexp.List sexps ;; (* We use [protect] to guard against exceptions raised by user-supplied functions, so that failure to produce one part of an info doesn't interfere with other parts. *) let protect f = try f () with | exn -> Could_not_construct (Exn.sexp_of_t exn) ;; let of_info info = protect (fun () -> Lazy.force info) let to_info t = lazy t end open Message type t = Message.t Lazy.t let invariant _ = () let to_message = Message.of_info let of_message = Message.to_info (* It is OK to use [Message.to_sexp_hum], which is not stable, because [t_of_sexp] below can handle any sexp. *) let sexp_of_t t = Message.to_sexp_hum (to_message t) let t_of_sexp sexp = lazy (Message.Sexp sexp) let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Any "Info.t" } let compare t1 t2 = Sexp.compare (sexp_of_t t1) (sexp_of_t t2) let equal t1 t2 = Sexp.equal (sexp_of_t t1) (sexp_of_t t2) let hash_fold_t state t = Sexp.hash_fold_t state (sexp_of_t t) let hash t = Hash.run hash_fold_t t let to_string_hum t = match to_message t with | String s -> s | message -> Sexp.to_string_hum (Message.to_sexp_hum message) ;; let to_string_hum_deprecated t = Message.to_string_hum_deprecated (to_message t) let to_string_mach t = Sexp.to_string_mach (sexp_of_t t) let of_lazy l = lazy (protect (fun () -> String (Lazy.force l))) let of_lazy_sexp l = lazy (protect (fun () -> Sexp (Lazy.force l))) let of_lazy_t lazy_t = Lazy.join lazy_t let of_string message = Lazy.from_val (String message) let createf format = Printf.ksprintf of_string format let of_thunk f = lazy (protect (fun () -> String (f ()))) let create ?here ?strict tag x sexp_of_x = match strict with | None -> lazy (protect (fun () -> Tag_sexp (tag, sexp_of_x x, here))) | Some () -> of_message (Tag_sexp (tag, sexp_of_x x, here)) ;; let create_s sexp = Lazy.from_val (Sexp sexp) let tag t ~tag = lazy (Tag_t (tag, to_message t)) let tag_s_lazy t ~tag = lazy (protect (fun () -> Tag_arg ("", Lazy.force tag, to_message t))) ;; let tag_s t ~tag = tag_s_lazy t ~tag:(Lazy.from_val tag) let tag_arg t tag x sexp_of_x = lazy (protect (fun () -> Tag_arg (tag, sexp_of_x x, to_message t))) ;; let of_list ?trunc_after ts = lazy (Of_list (trunc_after, List.map ts ~f:to_message)) exception Exn of t let () = (* We install a custom exn-converter rather than use [exception Exn of t [@@deriving_inline sexp] ... [@@@end]] to eliminate the extra wrapping of "(Exn ...)". *) Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Exn] (function | Exn t -> sexp_of_t t | _ -> (* Reaching this branch indicates a bug in sexplib. *) assert false) ;; let to_exn t = if not (Lazy.is_val t) then Exn t else ( match Lazy.force t with | Message.Exn exn -> exn | _ -> Exn t) ;; let of_exn ?backtrace exn = let backtrace = match backtrace with | None -> None | Some `Get -> Some (Stdlib.Printexc.get_backtrace ()) | Some (`This s) -> Some s in match exn, backtrace with | Exn t, None -> t | Exn t, Some backtrace -> lazy (With_backtrace (to_message t, backtrace)) | _, None -> Lazy.from_val (Message.Exn exn) | _, Some backtrace -> lazy (With_backtrace (Sexp (Exn.sexp_of_t exn), backtrace)) ;; include Pretty_printer.Register_pp (struct type nonrec t = t let module_name = "Base.Info" let pp ppf t = Stdlib.Format.pp_print_string ppf (to_string_hum t) end) module Internal_repr = Message base-0.16.3/src/info.mli000066400000000000000000000000461446274340700147530ustar00rootroot00000000000000include Info_intf.Info (** @inline *) base-0.16.3/src/info_intf.ml000066400000000000000000000121431446274340700156230ustar00rootroot00000000000000(** [Info] is a library for lazily constructing human-readable information as a string or sexp, with a primary use being error messages. Using [Info] is often preferable to [sprintf] or manually constructing strings because you don't have to eagerly construct the string -- you only need to pay when you actually want to display the info, which for many applications is rare. Using [Info] is also better than creating custom exceptions because you have more control over the format. Info is intended to be constructed in the following style; for simple info, you write: {[Info.of_string "Unable to find file"]} Or for a more descriptive [Info] without attaching any content (but evaluating the result eagerly): {[Info.createf "Process %s exited with code %d" process exit_code]} For info where you want to attach some content, you would write: {[Info.create "Unable to find file" filename [%sexp_of: string]]} Or even, {[ Info.create "price too big" (price, [`Max max_price]) [%sexp_of: float * [`Max of float]] ]} Note that an [Info.t] can be created from any arbitrary sexp with [Info.t_of_sexp]. *) open! Import module type S = sig (** Serialization and comparison force the lazy message. *) type t [@@deriving_inline compare, equal, hash, sexp, sexp_grammar] include Ppx_compare_lib.Comparable.S with type t := t include Ppx_compare_lib.Equal.S with type t := t include Ppx_hash_lib.Hashable.S with type t := t include Sexplib0.Sexpable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] include Invariant_intf.S with type t := t (** [to_string_hum] forces the lazy message, which might be an expensive operation. [to_string_hum] usually produces a sexp; however, it is guaranteed that [to_string_hum (of_string s) = s]. If this string is going to go into a log file, you may find it useful to ensure that the string is only one line long. To do this, use [to_string_mach t]. *) val to_string_hum : t -> string (** [to_string_mach t] outputs [t] as a sexp on a single line. *) val to_string_mach : t -> string (** Old version (pre 109.61) of [to_string_hum] that some applications rely on. Calls should be replaced with [to_string_mach t], which outputs more parentheses and backslashes. *) val to_string_hum_deprecated : t -> string val of_string : string -> t (** Be careful that the body of the lazy or thunk does not access mutable data, since it will only be called at an undetermined later point. *) val of_lazy : string Lazy.t -> t val of_lazy_sexp : Sexp.t Lazy.t -> t val of_thunk : (unit -> string) -> t val of_lazy_t : t Lazy.t -> t (** For [create message a sexp_of_a], [sexp_of_a a] is lazily computed, when the info is converted to a sexp. So if [a] is mutated in the time between the call to [create] and the sexp conversion, those mutations will be reflected in the sexp. Use [~strict:()] to force [sexp_of_a a] to be computed immediately. *) val create : ?here:Source_code_position0.t -> ?strict:unit -> string -> 'a -> ('a -> Sexp.t) -> t val create_s : Sexp.t -> t (** Constructs a [t] containing only a string from a format. This eagerly constructs the string. *) val createf : ('a, unit, string, t) format4 -> 'a (** Adds a string to the front. *) val tag : t -> tag:string -> t (** Adds a sexp to the front. *) val tag_s : t -> tag:Sexp.t -> t (** Adds a lazy sexp to the front. *) val tag_s_lazy : t -> tag:Sexp.t Lazy.t -> t (** Adds a string and some other data in the form of an s-expression at the front. *) val tag_arg : t -> string -> 'a -> ('a -> Sexp.t) -> t (** Combines multiple infos into one. *) val of_list : ?trunc_after:int -> t list -> t (** [of_exn] and [to_exn] are primarily used with [Error], but their definitions have to be here because they refer to the underlying representation. [~backtrace:`Get] attaches the backtrace for the most recent exception. The same caveats as for [Printexc.print_backtrace] apply. [~backtrace:(`This s)] attaches the backtrace [s]. The default is no backtrace. *) val of_exn : ?backtrace:[ `Get | `This of string ] -> exn -> t val to_exn : t -> exn val pp : Formatter.t -> t -> unit module Internal_repr : sig type info = t (** The internal representation. It is exposed so that we can write efficient serializers outside of this module. *) type t = | Could_not_construct of Sexp.t | String of string | Exn of exn | Sexp of Sexp.t | Tag_sexp of string * Sexp.t * Source_code_position0.t option | Tag_t of string * t | Tag_arg of string * Sexp.t * t | Of_list of int option * t list | With_backtrace of t * string (** The second argument is the backtrace *) [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] val of_info : info -> t val to_info : t -> info end with type info := t end module type Info = sig module type S = S include S (** @inline *) end base-0.16.3/src/int.ml000066400000000000000000000224251446274340700144460ustar00rootroot00000000000000open! Import include Int_intf include Int0 module T = struct type t = int [@@deriving_inline globalize, hash, sexp, sexp_grammar] let (globalize : (t[@ocaml.local]) -> t) = (globalize_int : (t[@ocaml.local]) -> t) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = hash_fold_int and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = hash_int in fun x -> func x ;; let t_of_sexp = (int_of_sexp : Sexplib0.Sexp.t -> t) let sexp_of_t = (sexp_of_int : t -> Sexplib0.Sexp.t) let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = int_sexp_grammar [@@@end] let hashable : t Hashable.t = { hash; compare; sexp_of_t } let compare x y = Int_replace_polymorphic_compare.compare x y let of_string s = try of_string s with | _ -> Printf.failwithf "Int.of_string: %S" s () ;; let to_string = to_string end let num_bits = Int_conversions.num_bits_int let float_lower_bound = Float0.lower_bound_for_int num_bits let float_upper_bound = Float0.upper_bound_for_int num_bits let to_float = Stdlib.float_of_int let of_float_unchecked = Stdlib.int_of_float let of_float f = if Float_replace_polymorphic_compare.( >= ) f float_lower_bound && Float_replace_polymorphic_compare.( <= ) f float_upper_bound then Stdlib.int_of_float f else Printf.invalid_argf "Int.of_float: argument (%f) is out of range or NaN" (Float0.box f) () ;; let zero = 0 let one = 1 let minus_one = -1 include T include Comparator.Make (T) include Comparable.With_zero (struct include T let zero = zero end) module Conv = Int_conversions include Conv.Make (T) include Conv.Make_hex (struct open Int_replace_polymorphic_compare type t = int [@@deriving_inline compare, hash] let compare = (compare_int : t -> t -> int) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = hash_fold_int and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = hash_int in fun x -> func x ;; [@@@end] let zero = zero let neg = ( ~- ) let ( < ) = ( < ) let to_string i = Printf.sprintf "%x" i let of_string s = Stdlib.Scanf.sscanf s "%x" Fn.id let module_name = "Base.Int.Hex" end) include Pretty_printer.Register (struct type nonrec t = t let to_string = to_string let module_name = "Base.Int" end) (* Open replace_polymorphic_compare after including functor instantiations so they do not shadow its definitions. This is here so that efficient versions of the comparison functions are available within this module. *) open! Int_replace_polymorphic_compare let invariant (_ : t) = () let between t ~low ~high = low <= t && t <= high let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max let clamp_exn t ~min ~max = assert (min <= max); clamp_unchecked t ~min ~max ;; let clamp t ~min ~max = if min > max then Or_error.error_s (Sexp.message "clamp requires [min <= max]" [ "min", T.sexp_of_t min; "max", T.sexp_of_t max ]) else Ok (clamp_unchecked t ~min ~max) ;; external to_int32_trunc : (t[@local_opt]) -> (int32[@local_opt]) = "%int32_of_int" external of_int32_trunc : (int32[@local_opt]) -> t = "%int32_to_int" external of_int64_trunc : (int64[@local_opt]) -> t = "%int64_to_int" external of_nativeint_trunc : (nativeint[@local_opt]) -> t = "%nativeint_to_int" let pred i = i - 1 let succ i = i + 1 let to_int i = i let to_int_exn = to_int let of_int i = i let of_int_exn = of_int let max_value = Stdlib.max_int let min_value = Stdlib.min_int let max_value_30_bits = 0x3FFF_FFFF let of_int32 = Conv.int32_to_int let of_int32_exn = Conv.int32_to_int_exn let to_int32 = Conv.int_to_int32 let to_int32_exn = Conv.int_to_int32_exn let of_int64 = Conv.int64_to_int let of_int64_exn = Conv.int64_to_int_exn let to_int64 = Conv.int_to_int64 let of_nativeint = Conv.nativeint_to_int let of_nativeint_exn = Conv.nativeint_to_int_exn let to_nativeint = Conv.int_to_nativeint let to_nativeint_exn = to_nativeint let abs x = abs x (* note that rem is not same as % *) let rem a b = a mod b let incr = Stdlib.incr let decr = Stdlib.decr let shift_right a b = a asr b let shift_right_logical a b = a lsr b let shift_left a b = a lsl b let bit_not a = lnot a let bit_or a b = a lor b let bit_and a b = a land b let bit_xor a b = a lxor b let pow = Int_math.Private.int_pow let ( ** ) b e = pow b e module Pow2 = struct open! Import let raise_s = Error.raise_s let non_positive_argument () = Printf.invalid_argf "argument must be strictly positive" () ;; (** "ceiling power of 2" - Least power of 2 greater than or equal to x. *) let ceil_pow2 x = if x <= 0 then non_positive_argument (); let x = x - 1 in let x = x lor (x lsr 1) in let x = x lor (x lsr 2) in let x = x lor (x lsr 4) in let x = x lor (x lsr 8) in let x = x lor (x lsr 16) in (* The next line is superfluous on 32-bit architectures, but it's faster to do it anyway than to branch *) let x = x lor (x lsr 32) in x + 1 ;; (** "floor power of 2" - Largest power of 2 less than or equal to x. *) let floor_pow2 x = if x <= 0 then non_positive_argument (); let x = x lor (x lsr 1) in let x = x lor (x lsr 2) in let x = x lor (x lsr 4) in let x = x lor (x lsr 8) in let x = x lor (x lsr 16) in (* The next line is superfluous on 32-bit architectures, but it's faster to do it anyway than to branch *) let x = x lor (x lsr 32) in x - (x lsr 1) ;; let is_pow2 x = if x <= 0 then non_positive_argument (); x land (x - 1) = 0 ;; (* C stubs for int clz and ctz to use the CLZ/BSR/CTZ/BSF instruction where possible *) external clz : (* Note that we pass the tagged int here. See int_math_stubs.c for details on why this is correct. *) int -> (int[@untagged]) = "Base_int_math_int_clz" "Base_int_math_int_clz_untagged" [@@noalloc] external ctz : (int[@untagged]) -> (int[@untagged]) = "Base_int_math_int_ctz" "Base_int_math_int_ctz_untagged" [@@noalloc] (** Hacker's Delight Second Edition p106 *) let floor_log2 i = if i <= 0 then raise_s (Sexp.message "[Int.floor_log2] got invalid input" [ "", sexp_of_int i ]); num_bits - 1 - clz i ;; let ceil_log2 i = if i <= 0 then raise_s (Sexp.message "[Int.ceil_log2] got invalid input" [ "", sexp_of_int i ]); if i = 1 then 0 else num_bits - clz (i - 1) ;; end include Pow2 let sign = Sign.of_int let popcount = Popcount.int_popcount module Pre_O = struct external ( + ) : (t[@local_opt]) -> (t[@local_opt]) -> t = "%addint" external ( - ) : (t[@local_opt]) -> (t[@local_opt]) -> t = "%subint" external ( * ) : (t[@local_opt]) -> (t[@local_opt]) -> t = "%mulint" external ( / ) : (t[@local_opt]) -> (t[@local_opt]) -> t = "%divint" external ( ~- ) : (t[@local_opt]) -> t = "%negint" let ( ** ) = ( ** ) include Int_replace_polymorphic_compare let abs = abs external neg : (t[@local_opt]) -> t = "%negint" let zero = zero let of_int_exn = of_int_exn end module O = struct include Pre_O module F = Int_math.Make (struct type nonrec t = t include Pre_O let rem = rem let to_float = to_float let of_float = of_float let of_string = T.of_string let to_string = T.to_string end) include F external bswap16 : (int[@local_opt]) -> int = "%bswap16" (* These inlined versions of (%), (/%), and (//) perform better than their functorized counterparts in [F] (see benchmarks below). The reason these functions are inlined in [Int] but not in any of the other integer modules is that they existed in [Int] and [Int] alone prior to the introduction of the [Int_math.Make] functor, and we didn't want to degrade their performance. We won't pre-emptively do the same for new functions, unless someone cares, on a case by case fashion. *) let ( % ) x y = if y <= zero then Printf.invalid_argf "%s %% %s in core_int.ml: modulus should be positive" (to_string x) (to_string y) (); let rval = rem x y in if rval < zero then rval + y else rval ;; let ( /% ) x y = if y <= zero then Printf.invalid_argf "%s /%% %s in core_int.ml: divisor should be positive" (to_string x) (to_string y) (); if x < zero then ((x + one) / y) - one else x / y ;; let ( // ) x y = to_float x /. to_float y external ( land ) : (int[@local_opt]) -> (int[@local_opt]) -> int = "%andint" external ( lor ) : (int[@local_opt]) -> (int[@local_opt]) -> int = "%orint" external ( lxor ) : (int[@local_opt]) -> (int[@local_opt]) -> int = "%xorint" let lnot = lnot external ( lsl ) : (int[@local_opt]) -> (int[@local_opt]) -> int = "%lslint" external ( lsr ) : (int[@local_opt]) -> (int[@local_opt]) -> int = "%lsrint" external ( asr ) : (int[@local_opt]) -> (int[@local_opt]) -> int = "%asrint" end include O (* [Int] and [Int.O] agree value-wise *) module Private = struct module O_F = O.F end (* Include type-specific [Replace_polymorphic_compare] at the end, after including functor application that could shadow its definitions. This is here so that efficient versions of the comparison functions are exported by this module. *) include Int_replace_polymorphic_compare base-0.16.3/src/int.mli000066400000000000000000000000441446274340700146100ustar00rootroot00000000000000include Int_intf.Int (** @inline *) base-0.16.3/src/int0.ml000066400000000000000000000016751446274340700145320ustar00rootroot00000000000000(* [Int0] defines integer functions that are primitives or can be simply defined in terms of [Stdlib]. [Int0] is intended to completely express the part of [Stdlib] that [Base] uses for integers -- no other file in Base other than int0.ml should use these functions directly through [Stdlib]. [Int0] has few dependencies, and so is available early in Base's build order. All Base files that need to use ints and come before [Base.Int] in build order should do: {[ module Int = Int0 ]} Defining [module Int = Int0] is also necessary because it prevents ocamldep from mistakenly causing a file to depend on [Base.Int]. *) let to_string = Stdlib.string_of_int let of_string = Stdlib.int_of_string let of_string_opt = Stdlib.int_of_string_opt let to_float = Stdlib.float_of_int let of_float = Stdlib.int_of_float let max_value = Stdlib.max_int let min_value = Stdlib.min_int let succ = Stdlib.succ let pred = Stdlib.pred base-0.16.3/src/int32.ml000066400000000000000000000172321446274340700146130ustar00rootroot00000000000000open! Import open! Stdlib.Int32 module T = struct type t = int32 [@@deriving_inline globalize, hash, sexp, sexp_grammar] let (globalize : (t[@ocaml.local]) -> t) = (globalize_int32 : (t[@ocaml.local]) -> t) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = hash_fold_int32 and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = hash_int32 in fun x -> func x ;; let t_of_sexp = (int32_of_sexp : Sexplib0.Sexp.t -> t) let sexp_of_t = (sexp_of_int32 : t -> Sexplib0.Sexp.t) let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = int32_sexp_grammar [@@@end] let hashable : t Hashable.t = { hash; compare; sexp_of_t } let compare (x : t) y = compare x y let to_string = to_string let of_string = of_string let of_string_opt = of_string_opt end include T include Comparator.Make (T) let num_bits = 32 let float_lower_bound = Float0.lower_bound_for_int num_bits let float_upper_bound = Float0.upper_bound_for_int num_bits let float_of_bits = float_of_bits let bits_of_float = bits_of_float let shift_right_logical = shift_right_logical let shift_right = shift_right let shift_left = shift_left let bit_not = lognot let bit_xor = logxor let bit_or = logor let bit_and = logand let min_value = min_int let max_value = max_int let abs = abs let pred = pred let succ = succ let rem = rem let neg = neg let minus_one = minus_one let one = one let zero = zero let compare = compare let to_float = to_float let of_float_unchecked = of_float let of_float f = if Float_replace_polymorphic_compare.( >= ) f float_lower_bound && Float_replace_polymorphic_compare.( <= ) f float_upper_bound then of_float f else Printf.invalid_argf "Int32.of_float: argument (%f) is out of range or NaN" (Float0.box f) () ;; include Comparable.With_zero (struct include T let zero = zero end) module Infix_compare = struct open Poly let ( >= ) (x : t) y = x >= y let ( <= ) (x : t) y = x <= y let ( = ) (x : t) y = x = y let ( > ) (x : t) y = x > y let ( < ) (x : t) y = x < y let ( <> ) (x : t) y = x <> y end module Compare = struct include Infix_compare let compare = compare let ascending = compare let descending x y = compare y x let min (x : t) y = if x < y then x else y let max (x : t) y = if x > y then x else y let equal (x : t) y = x = y let between t ~low ~high = low <= t && t <= high let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max let clamp_exn t ~min ~max = assert (min <= max); clamp_unchecked t ~min ~max ;; let clamp t ~min ~max = if min > max then Or_error.error_s (Sexp.message "clamp requires [min <= max]" [ "min", T.sexp_of_t min; "max", T.sexp_of_t max ]) else Ok (clamp_unchecked t ~min ~max) ;; end include Compare let invariant (_ : t) = () let ( / ) = div let ( * ) = mul let ( - ) = sub let ( + ) = add let ( ~- ) = neg let incr r = r := !r + one let decr r = r := !r - one let of_int32 t = t let of_int32_exn = of_int32 let to_int32 t = t let to_int32_exn = to_int32 let popcount = Popcount.int32_popcount module Conv = Int_conversions let of_int = Conv.int_to_int32 let of_int_exn = Conv.int_to_int32_exn let of_int_trunc = Conv.int_to_int32_trunc let to_int = Conv.int32_to_int let to_int_exn = Conv.int32_to_int_exn let to_int_trunc = Conv.int32_to_int_trunc let of_int64 = Conv.int64_to_int32 let of_int64_exn = Conv.int64_to_int32_exn let of_int64_trunc = Conv.int64_to_int32_trunc let to_int64 = Conv.int32_to_int64 let of_nativeint = Conv.nativeint_to_int32 let of_nativeint_exn = Conv.nativeint_to_int32_exn let of_nativeint_trunc = Conv.nativeint_to_int32_trunc let to_nativeint = Conv.int32_to_nativeint let to_nativeint_exn = to_nativeint let pow b e = of_int_exn (Int_math.Private.int_pow (to_int_exn b) (to_int_exn e)) let ( ** ) b e = pow b e external bswap32 : (t[@local_opt]) -> (t[@local_opt]) = "%bswap_int32" let bswap16 x = Stdlib.Int32.shift_right_logical (bswap32 x) 16 module Pow2 = struct open! Import open Int32_replace_polymorphic_compare let raise_s = Error.raise_s let non_positive_argument () = Printf.invalid_argf "argument must be strictly positive" () ;; let ( lor ) = Stdlib.Int32.logor let ( lsr ) = Stdlib.Int32.shift_right_logical let ( land ) = Stdlib.Int32.logand (** "ceiling power of 2" - Least power of 2 greater than or equal to x. *) let ceil_pow2 x = if x <= Stdlib.Int32.zero then non_positive_argument (); let x = Stdlib.Int32.pred x in let x = x lor (x lsr 1) in let x = x lor (x lsr 2) in let x = x lor (x lsr 4) in let x = x lor (x lsr 8) in let x = x lor (x lsr 16) in Stdlib.Int32.succ x ;; (** "floor power of 2" - Largest power of 2 less than or equal to x. *) let floor_pow2 x = if x <= Stdlib.Int32.zero then non_positive_argument (); let x = x lor (x lsr 1) in let x = x lor (x lsr 2) in let x = x lor (x lsr 4) in let x = x lor (x lsr 8) in let x = x lor (x lsr 16) in Stdlib.Int32.sub x (x lsr 1) ;; let is_pow2 x = if x <= Stdlib.Int32.zero then non_positive_argument (); x land Stdlib.Int32.pred x = Stdlib.Int32.zero ;; (* C stubs for int32 clz and ctz to use the CLZ/BSR/CTZ/BSF instruction where possible *) external clz : (int32[@unboxed]) -> (int[@untagged]) = "Base_int_math_int32_clz" "Base_int_math_int32_clz_unboxed" [@@noalloc] external ctz : (int32[@unboxed]) -> (int[@untagged]) = "Base_int_math_int32_ctz" "Base_int_math_int32_ctz_unboxed" [@@noalloc] (** Hacker's Delight Second Edition p106 *) let floor_log2 i = if i <= Stdlib.Int32.zero then raise_s (Sexp.message "[Int32.floor_log2] got invalid input" [ "", sexp_of_int32 i ]); num_bits - 1 - clz i ;; (** Hacker's Delight Second Edition p106 *) let ceil_log2 i = if i <= Stdlib.Int32.zero then raise_s (Sexp.message "[Int32.ceil_log2] got invalid input" [ "", sexp_of_int32 i ]); (* The [i = 1] check is needed because clz(0) is undefined *) if Stdlib.Int32.equal i Stdlib.Int32.one then 0 else num_bits - clz (Stdlib.Int32.pred i) ;; end include Pow2 include Conv.Make (T) include Conv.Make_hex (struct type t = int32 [@@deriving_inline compare, hash] let compare = (compare_int32 : t -> t -> int) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = hash_fold_int32 and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = hash_int32 in fun x -> func x ;; [@@@end] let zero = zero let neg = ( ~- ) let ( < ) = ( < ) let to_string i = Printf.sprintf "%lx" i let of_string s = Stdlib.Scanf.sscanf s "%lx" Fn.id let module_name = "Base.Int32.Hex" end) include Pretty_printer.Register (struct type nonrec t = t let to_string = to_string let module_name = "Base.Int32" end) module Pre_O = struct let ( + ) = ( + ) let ( - ) = ( - ) let ( * ) = ( * ) let ( / ) = ( / ) let ( ~- ) = ( ~- ) let ( ** ) = ( ** ) include (Compare : Comparisons.Infix with type t := t) let abs = abs let neg = neg let zero = zero let of_int_exn = of_int_exn end module O = struct include Pre_O include Int_math.Make (struct type nonrec t = t include Pre_O let rem = rem let to_float = to_float let of_float = of_float let of_string = T.of_string let to_string = T.to_string end) let ( land ) = bit_and let ( lor ) = bit_or let ( lxor ) = bit_xor let lnot = bit_not let ( lsl ) = shift_left let ( asr ) = shift_right let ( lsr ) = shift_right_logical end include O (* [Int32] and [Int32.O] agree value-wise *) base-0.16.3/src/int32.mli000066400000000000000000000044071446274340700147640ustar00rootroot00000000000000(** An int of exactly 32 bits, regardless of the machine. Side note: There's not much reason to want an int of at least 32 bits (i.e., 32 on 32-bit machines and 63 on 64-bit machines) because [Int63] is basically just as efficient. Overflow issues are {i not} generally considered and explicitly handled. This may be more of an issue for 32-bit ints than 64-bit ints. [Int32.t] is boxed on both 32-bit and 64-bit machines. *) open! Import type t = int32 [@@deriving_inline globalize] val globalize : (t[@ocaml.local]) -> t [@@@end] include Int_intf.S with type t := t (** {2 Conversion functions} *) val of_int : int -> t option val to_int : t -> int option val of_int32 : int32 -> t val to_int32 : t -> int32 val of_nativeint : nativeint -> t option val to_nativeint : t -> nativeint val of_int64 : int64 -> t option (** {3 Truncating conversions} These functions return the least-significant bits of the input. In cases where optional conversions return [Some x], truncating conversions return [x]. *) val of_int_trunc : int -> t val to_int_trunc : t -> int val of_nativeint_trunc : nativeint -> t val of_int64_trunc : int64 -> t (** {3 Low-level float conversions} *) (** Rounds a regular 64-bit OCaml float to a 32-bit IEEE-754 "single" float, and returns its bit representation. We make no promises about the exact rounding behavior, or what happens in case of over- or underflow. *) val bits_of_float : float -> t (** Creates a 32-bit IEEE-754 "single" float from the given bits, and converts it to a regular 64-bit OCaml float. *) val float_of_bits : t -> float (** {2 Byte swap operations} See {{!modtype:Int.Int_without_module_types}[Int]'s byte swap section} for a description of Base's approach to exposing byte swap primitives. When compiling for 64-bit machines, if signedness of the output value does not matter, use byteswap functions for [int64], if possible, for better performance. As of writing, 32-bit byte swap operations on 64-bit machines have extra overhead for moving to 32-bit registers and sign-extending values when returning to 64-bit registers. The x86 instruction sequence that demonstrates the overhead is in [base/bench/bench_int.ml] *) val bswap16 : t -> t val bswap32 : t -> t base-0.16.3/src/int63.ml000066400000000000000000000126641446274340700146230ustar00rootroot00000000000000open! Import let raise_s = Error.raise_s module Repr = Int63_emul.Repr (* In a world where the compiler would understand [@@immediate64] attributes on type declarations, this module is how one would produce a [type t] with this attribute. *) module Immediate64 : sig module type Non_immediate = sig type t end module type Immediate = sig type t [@@immediate] end module Make (Immediate : Immediate) (Non_immediate : Non_immediate) : sig type t [@@immediate64] type 'a repr = | Immediate : Immediate.t repr | Non_immediate : Non_immediate.t repr val repr : t repr end end = struct module type Non_immediate = sig type t end module type Immediate = sig type t [@@immediate] end module Make (Immediate : Immediate) (Non_immediate : Non_immediate) = struct type t [@@immediate64] type 'a repr = | Immediate : Immediate.t repr | Non_immediate : Non_immediate.t repr external transparent_magic : ('a[@local_opt]) -> ('b[@local_opt]) = "%identity" let repr = (* [Obj.magic] involves opaqueness under Flambda 2 which will inhibit availability of functions defined in this module for later inlining (e.g. into float.ml). As such we explicitly use %identity here. *) match Word_size.word_size with | W64 -> (transparent_magic Immediate : t repr) | W32 -> (transparent_magic Non_immediate : t repr) ;; end [@@inline always] end include Immediate64.Make (Int) (Int63_emul) module Backend = struct module type S = sig type t include Int_intf.S with type t := t val of_int : int -> t val to_int : t -> int option val to_int_trunc : t -> int val of_int32 : int32 -> t val to_int32 : t -> Int32.t option val to_int32_trunc : t -> Int32.t val of_int64 : Int64.t -> t option val of_int64_trunc : Int64.t -> t val of_nativeint : nativeint -> t option val to_nativeint : t -> nativeint option val of_nativeint_trunc : nativeint -> t val to_nativeint_trunc : t -> nativeint val of_float_unchecked : float -> t val repr : (t, t) Int63_emul.Repr.t val bswap16 : t -> t val bswap32 : t -> t val bswap48 : t -> t end with type t := t module Native = struct include Int let to_int x = Some x let to_int_trunc x = x (* [of_int32_exn] is a safe operation on platforms with 64-bit word sizes. *) let of_int32 = of_int32_exn let to_nativeint_trunc x = to_nativeint x let to_nativeint x = Some (to_nativeint x) let repr = Int63_emul.Repr.Int let bswap32 t = Int64.to_int_trunc (Int64.bswap32 (Int64.of_int t)) let bswap48 t = Int64.to_int_trunc (Int64.bswap48 (Int64.of_int t)) end let impl : (module S) = match repr with | Immediate -> (module Native : S) | Non_immediate -> (module Int63_emul : S) ;; end include (val Backend.impl : Backend.S) module Overflow_exn = struct let ( + ) t u = let sum = t + u in if bit_or (bit_xor t u) (bit_xor t (bit_not sum)) < zero then sum else raise_s (Sexp.message "( + ) overflow" [ "t", sexp_of_t t; "u", sexp_of_t u; "sum", sexp_of_t sum ]) ;; let ( - ) t u = let diff = t - u in let pos_diff = t > u in if t <> u && Bool.( <> ) pos_diff (is_positive diff) then raise_s (Sexp.message "( - ) overflow" [ "t", sexp_of_t t; "u", sexp_of_t u; "diff", sexp_of_t diff ]) else diff ;; let negative_one = of_int (-1) let div_would_overflow t u = t = min_value && u = negative_one let ( * ) t u = let product = t * u in if u <> zero && (div_would_overflow product u || product / u <> t) then raise_s (Sexp.message "( * ) overflow" [ "t", sexp_of_t t; "u", sexp_of_t u; "product", sexp_of_t product ]) else product ;; let ( / ) t u = if div_would_overflow t u then raise_s (Sexp.message "( / ) overflow" [ "t", sexp_of_t t; "u", sexp_of_t u; "product", sexp_of_t (t / u) ]) else t / u ;; let abs t = if t = min_value then failwith "abs overflow" else abs t let neg t = if t = min_value then failwith "neg overflow" else neg t end let () = assert (Int.( = ) num_bits 63) let random_of_int ?(state = Random.State.default) bound = of_int (Random.State.int state (to_int_exn bound)) ;; let random_of_int64 ?(state = Random.State.default) bound = of_int64_exn (Random.State.int64 state (to_int64 bound)) ;; let random = match Word_size.word_size with | W64 -> random_of_int | W32 -> random_of_int64 ;; let random_incl_of_int ?(state = Random.State.default) lo hi = of_int (Random.State.int_incl state (to_int_exn lo) (to_int_exn hi)) ;; let random_incl_of_int64 ?(state = Random.State.default) lo hi = of_int64_exn (Random.State.int64_incl state (to_int64 lo) (to_int64 hi)) ;; let random_incl = match Word_size.word_size with | W64 -> random_incl_of_int | W32 -> random_incl_of_int64 ;; let floor_log2 t = match Word_size.word_size with | W64 -> t |> to_int_exn |> Int.floor_log2 | W32 -> if t <= zero then raise_s (Sexp.message "[Int.floor_log2] got invalid input" [ "", sexp_of_t t ]); let floor_log2 = ref (Int.( - ) num_bits 2) in while equal zero (bit_and t (shift_left one !floor_log2)) do floor_log2 := Int.( - ) !floor_log2 1 done; !floor_log2 ;; module Private = struct module Repr = Repr let repr = repr module Emul = Int63_emul end base-0.16.3/src/int63.mli000066400000000000000000000063001446274340700147620ustar00rootroot00000000000000(** 63-bit integers. The size of Int63 is always 63 bits. On a 64-bit platform it is just an int (63-bits), and on a 32-bit platform it is an int64 wrapped to respect the semantics of 63-bit integers. Because [Int63] has different representations on 32-bit and 64-bit platforms, marshalling [Int63] will not work between 32-bit and 64-bit platforms -- [unmarshal] will segfault. *) open! Import (** The [@@immediate64] attribute is to indicate that [t] is implemented by a type that is immediate only on 64 bit platforms. It is currently ignored by the compiler, however we are hoping that one day it will be taken into account so that the compiler can omit [caml_modify] when dealing with mutable data structures holding [Int63.t] values. *) type t [@@immediate64] include Int_intf.S with type t := t (** {2 Arithmetic with overflow} Unlike the usual operations, these never overflow, preferring instead to raise. *) module Overflow_exn : sig val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t val abs : t -> t val neg : t -> t end (** {2 Conversion functions} *) val of_int : int -> t val to_int : t -> int option val of_int32 : Int32.t -> t val to_int32 : t -> Int32.t option val of_int64 : Int64.t -> t option val of_nativeint : nativeint -> t option val to_nativeint : t -> nativeint option (** {3 Truncating conversions} These functions return the least-significant bits of the input. In cases where optional conversions return [Some x], truncating conversions return [x]. *) val to_int_trunc : t -> int val to_int32_trunc : t -> Int32.t val of_int64_trunc : Int64.t -> t val of_nativeint_trunc : nativeint -> t val to_nativeint_trunc : t -> nativeint (** {2 Byteswap functions} See {{!modtype:Int.Int_without_module_types}[Int]'s byte swap section} for a description of Base's approach to exposing byte swap primitives. *) val bswap16 : t -> t val bswap32 : t -> t val bswap48 : t -> t (** {2 Random generation} *) (** [random ~state bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0. The default [~state] is [Random.State.default]. *) val random : ?state:Random.State.t -> t -> t (** [random_incl ~state lo hi] returns a random integer between [lo] (inclusive) and [hi] (inclusive). Raises if [lo > hi]. The default [~state] is [Random.State.default]. *) val random_incl : ?state:Random.State.t -> t -> t -> t (** [floor_log2 x] returns the floor of log-base-2 of [x], and raises if [x <= 0]. *) val floor_log2 : t -> int (**/**) (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig (** [val repr] states how [Int63.t] is represented, i.e., as an [int] or an [int64], and can be used for building [Int63] operations that behave differently depending on the representation (e.g., see core_int63.ml). *) module Repr : sig type ('underlying_type, 'intermediate_type) t = | Int : (int, int) t | Int64 : (int64, Int63_emul.t) t end val repr : (t, t) Repr.t module Emul = Int63_emul end base-0.16.3/src/int63_emul.ml000066400000000000000000000317211446274340700156400ustar00rootroot00000000000000(* A 63bit integer is a 64bit integer with its bits shifted to the left and its lowest bit set to 0. This is the same kind of encoding as OCaml int on 64bit architecture. The only difference being the lowest bit (immediate bit) set to 1. *) open! Import include Int64_replace_polymorphic_compare module T0 = struct module T = struct type t = int64 [@@deriving_inline compare, globalize, hash, sexp, sexp_grammar] let compare = (compare_int64 : t -> t -> int) let (globalize : (t[@ocaml.local]) -> t) = (globalize_int64 : (t[@ocaml.local]) -> t) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = hash_fold_int64 and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = hash_int64 in fun x -> func x ;; let t_of_sexp = (int64_of_sexp : Sexplib0.Sexp.t -> t) let sexp_of_t = (sexp_of_int64 : t -> Sexplib0.Sexp.t) let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = int64_sexp_grammar [@@@end] let hashable : t Hashable.t = { hash; compare; sexp_of_t } end include T include Comparator.Make (T) end module Conv = Int_conversions module W : sig include module type of struct include T0 end type t = int64 val wrap_exn : Stdlib.Int64.t -> t val wrap_modulo : Stdlib.Int64.t -> t val unwrap : t -> Stdlib.Int64.t (** Returns a non-negative int64 that is equal to the input int63 modulo 2^63. *) val unwrap_unsigned : t -> Stdlib.Int64.t val invariant : t -> unit val add : t -> t -> t val sub : t -> t -> t val neg : t -> t val abs : t -> t val succ : t -> t val pred : t -> t val mul : t -> t -> t val pow : t -> t -> t val div : t -> t -> t val rem : t -> t -> t val popcount : t -> int val bit_not : t -> t val bit_xor : t -> t -> t val bit_or : t -> t -> t val bit_and : t -> t -> t val shift_left : t -> int -> t val shift_right : t -> int -> t val shift_right_logical : t -> int -> t val min_value : t val max_value : t val to_int64 : t -> Stdlib.Int64.t val of_int64 : Stdlib.Int64.t -> t option val of_int64_exn : Stdlib.Int64.t -> t val of_int64_trunc : Stdlib.Int64.t -> t val compare : t -> t -> int val ceil_pow2 : t -> t val floor_pow2 : t -> t val ceil_log2 : t -> int val floor_log2 : t -> int val is_pow2 : t -> bool val clz : t -> int val ctz : t -> int end = struct include T0 type t = int64 let wrap_exn x = (* Raises if the int64 value does not fit on int63. *) Conv.int64_fit_on_int63_exn x; Stdlib.Int64.mul x 2L ;; let wrap x = if Conv.int64_is_representable_as_int63 x then Some (Stdlib.Int64.mul x 2L) else None ;; let wrap_modulo x = Stdlib.Int64.mul x 2L let unwrap x = Stdlib.Int64.shift_right x 1 let unwrap_unsigned x = Stdlib.Int64.shift_right_logical x 1 (* This does not use wrap or unwrap to avoid generating exceptions in the case of overflows. This is to preserve the semantics of int type on 64 bit architecture. *) let f2 f a b = Stdlib.Int64.mul (f (Stdlib.Int64.shift_right a 1) (Stdlib.Int64.shift_right b 1)) 2L ;; let mask = 0xffff_ffff_ffff_fffeL let m x = Stdlib.Int64.logand x mask let invariant t = assert (m t = t) let add x y = Stdlib.Int64.add x y let sub x y = Stdlib.Int64.sub x y let neg x = Stdlib.Int64.neg x let abs x = Stdlib.Int64.abs x let one = wrap_exn 1L let succ a = add a one let pred a = sub a one let min_value = m Stdlib.Int64.min_int let max_value = m Stdlib.Int64.max_int let bit_not x = m (Stdlib.Int64.lognot x) let bit_and = Stdlib.Int64.logand let bit_xor = Stdlib.Int64.logxor let bit_or = Stdlib.Int64.logor let shift_left x i = Stdlib.Int64.shift_left x i let shift_right x i = m (Stdlib.Int64.shift_right x i) let shift_right_logical x i = m (Stdlib.Int64.shift_right_logical x i) let pow = f2 Int_math.Private.int63_pow_on_int64 let mul a b = Stdlib.Int64.mul a (Stdlib.Int64.shift_right b 1) let div a b = wrap_modulo (Stdlib.Int64.div a b) let rem a b = Stdlib.Int64.rem a b let popcount x = Popcount.int64_popcount x let to_int64 t = unwrap t let of_int64 t = wrap t let of_int64_exn t = wrap_exn t let of_int64_trunc t = wrap_modulo t let t_of_sexp x = wrap_exn (int64_of_sexp x) let sexp_of_t x = sexp_of_int64 (unwrap x) let compare (x : t) y = compare x y let is_pow2 x = Int64.is_pow2 (unwrap x) let clz x = (* We run Int64.clz directly on the wrapped int63 value. This is correct because the bits of the int63_emul are left-aligned in the Int64. *) Int64.clz x ;; let ctz x = Int64.ctz (unwrap x) let floor_pow2 x = Int64.floor_pow2 (unwrap x) |> wrap_exn let ceil_pow2 x = Int64.floor_pow2 (unwrap x) |> wrap_exn let floor_log2 x = Int64.floor_log2 (unwrap x) let ceil_log2 x = Int64.ceil_log2 (unwrap x) end open W module T = struct type t = W.t [@@deriving_inline globalize, hash, sexp, sexp_grammar] let (globalize : (t[@ocaml.local]) -> t) = (W.globalize : (t[@ocaml.local]) -> t) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = W.hash_fold_t and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = W.hash in fun x -> func x ;; let t_of_sexp = (W.t_of_sexp : Sexplib0.Sexp.t -> t) let sexp_of_t = (W.sexp_of_t : t -> Sexplib0.Sexp.t) let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = W.t_sexp_grammar [@@@end] type comparator_witness = W.comparator_witness let comparator = W.comparator let compare = W.compare let invariant = W.invariant (* We don't expect [hash] to follow the behavior of int in 64bit architecture *) let _ = hash let hash (x : t) = Stdlib.Hashtbl.hash x let hashable : t Hashable.t = { hash; compare; sexp_of_t } let invalid_str x = Printf.failwithf "Int63.of_string: invalid input %S" x () (* "sign" refers to whether the number starts with a '-' "signedness = false" means the rest of the number is parsed as unsigned and then cast to signed with wrap-around modulo 2^i "signedness = true" means no such craziness happens The terminology and the logic is due to the code in byterun/ints.c in ocaml 4.03 ([parse_sign_and_base] function). Signedness equals true for plain decimal number (e.g. 1235, -6789) Signedness equals false in the following cases: - [0xffff], [-0xffff] (hexadecimal representation) - [0b0101], [-0b0101] (binary representation) - [0o1237], [-0o1237] (octal representation) - [0u9812], [-0u9812] (unsigned decimal representation - available from OCaml 4.03) *) let sign_and_signedness x = let len = String.length x in let open Int_replace_polymorphic_compare in let pos, sign = if 0 < len then ( match x.[0] with | '-' -> 1, `Neg | '+' -> 1, `Pos | _ -> 0, `Pos) else 0, `Pos in if pos + 2 < len then ( let c1 = x.[pos] in let c2 = x.[pos + 1] in match c1, c2 with | '0', '0' .. '9' -> sign, true | '0', _ -> sign, false | _ -> sign, true) else sign, true ;; let to_string x = Stdlib.Int64.to_string (unwrap x) let of_string_raw str = let sign, signedness = sign_and_signedness str in if signedness then of_int64_exn (Stdlib.Int64.of_string str) else ( let pos_str = match sign with | `Neg -> String.sub str ~pos:1 ~len:(String.length str - 1) | `Pos -> str in let int64 = Stdlib.Int64.of_string pos_str in (* unsigned 63-bit int must parse as a positive signed 64-bit int *) if Int64_replace_polymorphic_compare.( < ) int64 0L then invalid_str str; let int63 = wrap_modulo int64 in match sign with | `Neg -> neg int63 | `Pos -> int63) ;; let of_string str = try of_string_raw str with | _ -> invalid_str str ;; let of_string_opt str = match of_string_raw str with | t -> Some t | exception _ -> None ;; let bswap16 t = wrap_modulo (Int64.bswap16 (unwrap t)) let bswap32 t = wrap_modulo (Int64.bswap32 (unwrap t)) let bswap48 t = wrap_modulo (Int64.bswap48 (unwrap t)) end include T let num_bits = 63 let float_lower_bound = Float0.lower_bound_for_int num_bits let float_upper_bound = Float0.upper_bound_for_int num_bits let shift_right_logical = shift_right_logical let shift_right = shift_right let shift_left = shift_left let bit_not = bit_not let bit_xor = bit_xor let bit_or = bit_or let bit_and = bit_and let popcount = popcount let abs = abs let pred = pred let succ = succ let pow = pow let rem = rem let neg = neg let max_value = max_value let min_value = min_value let minus_one = wrap_exn Stdlib.Int64.minus_one let one = wrap_exn Stdlib.Int64.one let zero = wrap_exn Stdlib.Int64.zero let is_pow2 = is_pow2 let floor_pow2 = floor_pow2 let ceil_pow2 = ceil_pow2 let floor_log2 = floor_log2 let ceil_log2 = ceil_log2 let clz = clz let ctz = ctz let to_float x = Stdlib.Int64.to_float (unwrap x) let of_float_unchecked x = wrap_modulo (Stdlib.Int64.of_float x) let of_float t = let open Float_replace_polymorphic_compare in if t >= float_lower_bound && t <= float_upper_bound then wrap_modulo (Stdlib.Int64.of_float t) else Printf.invalid_argf "Int63.of_float: argument (%f) is out of range or NaN" (Float0.box t) () ;; let of_int64 = of_int64 let of_int64_exn = of_int64_exn let of_int64_trunc = of_int64_trunc let to_int64 = to_int64 include Comparable.With_zero (struct include T let zero = zero end) let between t ~low ~high = low <= t && t <= high let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max let clamp_exn t ~min ~max = assert (min <= max); clamp_unchecked t ~min ~max ;; let clamp t ~min ~max = if min > max then Or_error.error_s (Sexp.message "clamp requires [min <= max]" [ "min", T.sexp_of_t min; "max", T.sexp_of_t max ]) else Ok (clamp_unchecked t ~min ~max) ;; let ( / ) = div let ( * ) = mul let ( - ) = sub let ( + ) = add let ( ~- ) = neg let ( ** ) b e = pow b e let incr r = r := !r + one let decr r = r := !r - one (* We can reuse conversion function from/to int64 here. *) let of_int x = wrap_exn (Conv.int_to_int64 x) let of_int_exn x = of_int x let to_int x = Conv.int64_to_int (unwrap x) let to_int_exn x = Conv.int64_to_int_exn (unwrap x) let to_int_trunc x = Conv.int64_to_int_trunc (unwrap x) let of_int32 x = wrap_exn (Conv.int32_to_int64 x) let of_int32_exn x = of_int32 x let to_int32 x = Conv.int64_to_int32 (unwrap x) let to_int32_exn x = Conv.int64_to_int32_exn (unwrap x) let to_int32_trunc x = Conv.int64_to_int32_trunc (unwrap x) let of_nativeint x = of_int64 (Conv.nativeint_to_int64 x) let of_nativeint_exn x = wrap_exn (Conv.nativeint_to_int64 x) let of_nativeint_trunc x = of_int64_trunc (Conv.nativeint_to_int64 x) let to_nativeint x = Conv.int64_to_nativeint (unwrap x) let to_nativeint_exn x = Conv.int64_to_nativeint_exn (unwrap x) let to_nativeint_trunc x = Conv.int64_to_nativeint_trunc (unwrap x) include Conv.Make (T) include Conv.Make_hex (struct type t = T.t [@@deriving_inline compare, hash] let compare = (T.compare : t -> t -> int) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = T.hash_fold_t and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = T.hash in fun x -> func x ;; [@@@end] let zero = zero let neg = ( ~- ) let ( < ) = ( < ) let to_string i = (* the use of [unwrap_unsigned] here is important for the case of [min_value] *) Printf.sprintf "%Lx" (unwrap_unsigned i) ;; let of_string s = of_string ("0x" ^ s) let module_name = "Base.Int63.Hex" end) include Pretty_printer.Register (struct type nonrec t = t let to_string x = to_string x let module_name = "Base.Int63" end) module Pre_O = struct let ( + ) = ( + ) let ( - ) = ( - ) let ( * ) = ( * ) let ( / ) = ( / ) let ( ~- ) = ( ~- ) let ( ** ) = ( ** ) include (Int64_replace_polymorphic_compare : Comparisons.Infix with type t := t) let abs = abs let neg = neg let zero = zero let of_int_exn = of_int_exn end module O = struct include Pre_O include Int_math.Make (struct type nonrec t = t include Pre_O let rem = rem let to_float = to_float let of_float = of_float let of_string = T.of_string let to_string = T.to_string end) let ( land ) = bit_and let ( lor ) = bit_or let ( lxor ) = bit_xor let lnot = bit_not let ( lsl ) = shift_left let ( asr ) = shift_right let ( lsr ) = shift_right_logical end include O (* [Int63] and [Int63.O] agree value-wise *) module Repr = struct type emulated = t type ('underlying_type, 'intermediate_type) t = | Int : (int, int) t | Int64 : (int64, emulated) t end let repr = Repr.Int64 (* Include type-specific [Replace_polymorphic_compare] at the end, after including functor application that could shadow its definitions. This is here so that efficient versions of the comparison functions are exported by this module. *) include Int64_replace_polymorphic_compare base-0.16.3/src/int63_emul.mli000066400000000000000000000020611446274340700160040ustar00rootroot00000000000000(** [Int63_emul] implements 63-bit integers using the [int64] type. It is is used to implement [Int63] on 32-bit platforms; see [Int63_backends.Emulated]. *) open! Import type t [@@deriving_inline globalize] val globalize : (t[@ocaml.local]) -> t [@@@end] include Int_intf.S with type t := t val of_int : int -> t val to_int : t -> int option val to_int_trunc : t -> int val of_int32 : int32 -> t val to_int32 : t -> Int32.t option val to_int32_trunc : t -> Int32.t val of_int64 : Int64.t -> t option val of_int64_trunc : Int64.t -> t val of_nativeint : nativeint -> t option val to_nativeint : t -> nativeint option val of_nativeint_trunc : nativeint -> t val to_nativeint_trunc : t -> nativeint val bswap16 : t -> t val bswap32 : t -> t val bswap48 : t -> t (*_ exported for Core *) module W : sig val wrap_exn : int64 -> t val unwrap : t -> int64 end module Repr : sig type emulated = t type ('underlying_type, 'intermediate_type) t = | Int : (int, int) t | Int64 : (int64, emulated) t end with type emulated := t val repr : (t, t) Repr.t base-0.16.3/src/int64.ml000066400000000000000000000216631446274340700146230ustar00rootroot00000000000000open! Import open! Stdlib.Int64 module T = struct type t = int64 [@@deriving_inline globalize, hash, sexp, sexp_grammar] let (globalize : (t[@ocaml.local]) -> t) = (globalize_int64 : (t[@ocaml.local]) -> t) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = hash_fold_int64 and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = hash_int64 in fun x -> func x ;; let t_of_sexp = (int64_of_sexp : Sexplib0.Sexp.t -> t) let sexp_of_t = (sexp_of_int64 : t -> Sexplib0.Sexp.t) let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = int64_sexp_grammar [@@@end] let hashable : t Hashable.t = { hash; compare; sexp_of_t } let compare = Int64_replace_polymorphic_compare.compare let to_string = to_string let of_string = of_string let of_string_opt = of_string_opt end include T include Comparator.Make (T) let num_bits = 64 let float_lower_bound = Float0.lower_bound_for_int num_bits let float_upper_bound = Float0.upper_bound_for_int num_bits let float_of_bits = float_of_bits let bits_of_float = bits_of_float let shift_right_logical = shift_right_logical let shift_right = shift_right let shift_left = shift_left let bit_not = lognot let bit_xor = logxor let bit_or = logor let bit_and = logand let min_value = min_int let max_value = max_int let abs = abs let pred = pred let succ = succ let pow = Int_math.Private.int64_pow let rem = rem let neg = neg let minus_one = minus_one let one = one let zero = zero let to_float = to_float let of_float_unchecked = Stdlib.Int64.of_float let of_float f = if Float_replace_polymorphic_compare.( >= ) f float_lower_bound && Float_replace_polymorphic_compare.( <= ) f float_upper_bound then Stdlib.Int64.of_float f else Printf.invalid_argf "Int64.of_float: argument (%f) is out of range or NaN" (Float0.box f) () ;; let ( ** ) b e = pow b e external bswap64 : (t[@local_opt]) -> (t[@local_opt]) = "%bswap_int64" let[@inline always] bswap16 x = Stdlib.Int64.shift_right_logical (bswap64 x) 48 let[@inline always] bswap32 x = (* This is strictly better than coercing to an int32 to perform byteswap. Coercing from an int32 will add unnecessary shift operations to sign extend the number appropriately. *) Stdlib.Int64.shift_right_logical (bswap64 x) 32 ;; let[@inline always] bswap48 x = Stdlib.Int64.shift_right_logical (bswap64 x) 16 include Comparable.With_zero (struct include T let zero = zero end) (* Open replace_polymorphic_compare after including functor instantiations so they do not shadow its definitions. This is here so that efficient versions of the comparison functions are available within this module. *) open Int64_replace_polymorphic_compare let invariant (_ : t) = () let between t ~low ~high = low <= t && t <= high let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max let clamp_exn t ~min ~max = assert (min <= max); clamp_unchecked t ~min ~max ;; let clamp t ~min ~max = if min > max then Or_error.error_s (Sexp.message "clamp requires [min <= max]" [ "min", T.sexp_of_t min; "max", T.sexp_of_t max ]) else Ok (clamp_unchecked t ~min ~max) ;; let incr r = r := add !r one let decr r = r := sub !r one external of_int64 : (t[@local_opt]) -> (t[@local_opt]) = "%identity" let of_int64_exn = of_int64 let to_int64 t = t let popcount = Popcount.int64_popcount module Conv = Int_conversions external to_int_trunc : (t[@local_opt]) -> int = "%int64_to_int" external to_int32_trunc : (int64[@local_opt]) -> (int32[@local_opt]) = "%int64_to_int32" external to_nativeint_trunc : (int64[@local_opt]) -> (nativeint[@local_opt]) = "%int64_to_nativeint" external of_int : (int[@local_opt]) -> (int64[@local_opt]) = "%int64_of_int" external of_int32 : (int32[@local_opt]) -> (int64[@local_opt]) = "%int64_of_int32" let of_int_exn = of_int let to_int = Conv.int64_to_int let to_int_exn = Conv.int64_to_int_exn let of_int32_exn = of_int32 let to_int32 = Conv.int64_to_int32 let to_int32_exn = Conv.int64_to_int32_exn let of_nativeint = Conv.nativeint_to_int64 let of_nativeint_exn = of_nativeint let to_nativeint = Conv.int64_to_nativeint let to_nativeint_exn = Conv.int64_to_nativeint_exn module Pow2 = struct open! Import open Int64_replace_polymorphic_compare let raise_s = Error.raise_s let non_positive_argument () = Printf.invalid_argf "argument must be strictly positive" () ;; let ( lor ) = Stdlib.Int64.logor let ( lsr ) = Stdlib.Int64.shift_right_logical let ( land ) = Stdlib.Int64.logand (** "ceiling power of 2" - Least power of 2 greater than or equal to x. *) let ceil_pow2 x = if x <= Stdlib.Int64.zero then non_positive_argument (); let x = Stdlib.Int64.pred x in let x = x lor (x lsr 1) in let x = x lor (x lsr 2) in let x = x lor (x lsr 4) in let x = x lor (x lsr 8) in let x = x lor (x lsr 16) in let x = x lor (x lsr 32) in Stdlib.Int64.succ x ;; (** "floor power of 2" - Largest power of 2 less than or equal to x. *) let floor_pow2 x = if x <= Stdlib.Int64.zero then non_positive_argument (); let x = x lor (x lsr 1) in let x = x lor (x lsr 2) in let x = x lor (x lsr 4) in let x = x lor (x lsr 8) in let x = x lor (x lsr 16) in let x = x lor (x lsr 32) in Stdlib.Int64.sub x (x lsr 1) ;; let is_pow2 x = if x <= Stdlib.Int64.zero then non_positive_argument (); x land Stdlib.Int64.pred x = Stdlib.Int64.zero ;; (* C stubs for int clz and ctz to use the CLZ/BSR/CTZ/BSF instruction where possible *) external clz : (int64[@unboxed]) -> (int[@untagged]) = "Base_int_math_int64_clz" "Base_int_math_int64_clz_unboxed" [@@noalloc] external ctz : (int64[@unboxed]) -> (int[@untagged]) = "Base_int_math_int64_ctz" "Base_int_math_int64_ctz_unboxed" [@@noalloc] (** Hacker's Delight Second Edition p106 *) let floor_log2 i = if i <= Stdlib.Int64.zero then raise_s (Sexp.message "[Int64.floor_log2] got invalid input" [ "", sexp_of_int64 i ]); num_bits - 1 - clz i ;; (** Hacker's Delight Second Edition p106 *) let ceil_log2 i = if Poly.( <= ) i Stdlib.Int64.zero then raise_s (Sexp.message "[Int64.ceil_log2] got invalid input" [ "", sexp_of_int64 i ]); if Stdlib.Int64.equal i Stdlib.Int64.one then 0 else num_bits - clz (Stdlib.Int64.pred i) ;; end include Pow2 include Conv.Make (T) include Conv.Make_hex (struct type t = int64 [@@deriving_inline compare, hash] let compare = (compare_int64 : t -> t -> int) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = hash_fold_int64 and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = hash_int64 in fun x -> func x ;; [@@@end] let zero = zero let neg = neg let ( < ) = ( < ) let to_string i = Printf.sprintf "%Lx" i let of_string s = Stdlib.Scanf.sscanf s "%Lx" Fn.id let module_name = "Base.Int64.Hex" end) include Pretty_printer.Register (struct type nonrec t = t let to_string = to_string let module_name = "Base.Int64" end) module Pre_O = struct external ( + ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_add" external ( - ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_sub" external ( * ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_mul" external ( / ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_div" external ( ~- ) : (t[@local_opt]) -> (t[@local_opt]) = "%int64_neg" let ( ** ) = ( ** ) include Int64_replace_polymorphic_compare let abs = abs external neg : (t[@local_opt]) -> (t[@local_opt]) = "%int64_neg" let zero = zero let of_int_exn = of_int_exn end module O = struct include Pre_O include Int_math.Make (struct type nonrec t = t include Pre_O let rem = rem let to_float = to_float let of_float = of_float let of_string = T.of_string let to_string = T.to_string end) external ( land ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_and" external ( lor ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_or" external ( lxor ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_xor" let lnot = bit_not external ( lsl ) : (t[@local_opt]) -> (int[@local_opt]) -> (t[@local_opt]) = "%int64_lsl" external ( asr ) : (t[@local_opt]) -> (int[@local_opt]) -> (t[@local_opt]) = "%int64_asr" external ( lsr ) : (t[@local_opt]) -> (int[@local_opt]) -> (t[@local_opt]) = "%int64_lsr" end include O (* [Int64] and [Int64.O] agree value-wise *) (* Include type-specific [Replace_polymorphic_compare] at the end, after including functor application that could shadow its definitions. This is here so that efficient versions of the comparison functions are exported by this module. *) include Int64_replace_polymorphic_compare base-0.16.3/src/int64.mli000066400000000000000000000076371446274340700150010ustar00rootroot00000000000000(** 64-bit integers. *) open! Import type t = int64 [@@deriving_inline globalize] val globalize : (t[@ocaml.local]) -> t [@@@end] include Int_intf.S with type t := t module O : sig (*_ Declared as externals so that the compiler skips the caml_apply_X wrapping even when compiling without cross library inlining. *) external ( + ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_add" external ( - ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_sub" external ( * ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_mul" external ( / ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_div" external ( ~- ) : (t[@local_opt]) -> (t[@local_opt]) = "%int64_neg" val ( ** ) : t -> t -> t external ( = ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%equal" external ( <> ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%notequal" external ( < ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%lessthan" external ( > ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%greaterthan" external ( <= ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%lessequal" external ( >= ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%greaterequal" external ( land ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_and" external ( lor ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_or" external ( lxor ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_xor" val lnot : t -> t val abs : t -> t external neg : t -> t = "%int64_neg" val zero : t val ( % ) : t -> t -> t val ( /% ) : t -> t -> t val ( // ) : t -> t -> float external ( lsl ) : (t[@local_opt]) -> (int[@local_opt]) -> (t[@local_opt]) = "%int64_lsl" external ( asr ) : (t[@local_opt]) -> (int[@local_opt]) -> (t[@local_opt]) = "%int64_asr" external ( lsr ) : (t[@local_opt]) -> (int[@local_opt]) -> (t[@local_opt]) = "%int64_lsr" end include module type of O (** {2 Conversion functions} *) (*_ Declared as externals so that the compiler skips the caml_apply_X wrapping even when compiling without cross library inlining. *) external of_int : (int[@local_opt]) -> (t[@local_opt]) = "%int64_of_int" external of_int32 : (int32[@local_opt]) -> (t[@local_opt]) = "%int64_of_int32" external of_int64 : (t[@local_opt]) -> (t[@local_opt]) = "%identity" val to_int : t -> int option val to_int32 : t -> int32 option val of_nativeint : nativeint -> t val to_nativeint : t -> nativeint option (** {3 Truncating conversions} These functions return the least-significant bits of the input. In cases where optional conversions return [Some x], truncating conversions return [x]. *) (*_ Declared as externals so that the compiler skips the caml_apply_X wrapping even when compiling without cross library inlining. *) external to_int_trunc : (t[@local_opt]) -> int = "%int64_to_int" external to_int32_trunc : (int64[@local_opt]) -> (int32[@local_opt]) = "%int64_to_int32" external to_nativeint_trunc : (int64[@local_opt]) -> (nativeint[@local_opt]) = "%int64_to_nativeint" (** {3 Low-level float conversions} *) val bits_of_float : float -> t val float_of_bits : t -> float (** {2 Byte swap operations} See {{!modtype:Int.Int_without_module_types}[Int]'s byte swap section} for a description of Base's approach to exposing byte swap primitives. As of writing, these operations do not sign extend unnecessarily on 64 bit machines, unlike their int32 counterparts, and hence, are more performant. See the {!Int32} module for more details of the overhead entailed by the int32 byteswap functions. *) val bswap16 : t -> t val bswap32 : t -> t val bswap48 : t -> t (*_ Declared as an external so that the compiler skips the caml_apply_X wrapping even when compiling without cross library inlining. *) external bswap64 : (t[@local_opt]) -> (t[@local_opt]) = "%bswap_int64" base-0.16.3/src/int_conversions.ml000066400000000000000000000241751446274340700171020ustar00rootroot00000000000000open! Import module Int = Int0 module Sys = Sys0 let convert_failure x a b to_string = Printf.failwithf "conversion from %s to %s failed: %s is out of range" a b (to_string x) () [@@cold] [@@inline never] [@@local never] [@@specialise never] ;; let num_bits_int = Sys.int_size_in_bits let num_bits_int32 = 32 let num_bits_int64 = 64 let num_bits_nativeint = Word_size.num_bits Word_size.word_size let () = assert (num_bits_int = 63 || num_bits_int = 31 || num_bits_int = 32) let min_int32 = Stdlib.Int32.min_int let max_int32 = Stdlib.Int32.max_int let min_int64 = Stdlib.Int64.min_int let max_int64 = Stdlib.Int64.max_int let min_nativeint = Stdlib.Nativeint.min_int let max_nativeint = Stdlib.Nativeint.max_int let int_to_string = Stdlib.string_of_int let int32_to_string = Stdlib.Int32.to_string let int64_to_string = Stdlib.Int64.to_string let nativeint_to_string = Stdlib.Nativeint.to_string (* int <-> int32 *) let int_to_int32_failure x = convert_failure x "int" "int32" int_to_string let int32_to_int_failure x = convert_failure x "int32" "int" int32_to_string let int32_to_int_trunc = Stdlib.Int32.to_int let int_to_int32_trunc = Stdlib.Int32.of_int let int_is_representable_as_int32 = if num_bits_int <= num_bits_int32 then fun _ -> true else ( let min = int32_to_int_trunc min_int32 in let max = int32_to_int_trunc max_int32 in fun x -> compare_int min x <= 0 && compare_int x max <= 0) ;; let int32_is_representable_as_int = if num_bits_int32 <= num_bits_int then fun _ -> true else ( let min = int_to_int32_trunc Int.min_value in let max = int_to_int32_trunc Int.max_value in fun x -> compare_int32 min x <= 0 && compare_int32 x max <= 0) ;; let int_to_int32 x = if int_is_representable_as_int32 x then Some (int_to_int32_trunc x) else None ;; let int32_to_int x = if int32_is_representable_as_int x then Some (int32_to_int_trunc x) else None ;; let int_to_int32_exn x = if int_is_representable_as_int32 x then int_to_int32_trunc x else int_to_int32_failure x ;; let int32_to_int_exn x = if int32_is_representable_as_int x then int32_to_int_trunc x else int32_to_int_failure x ;; (* int <-> int64 *) let int64_to_int_failure x = convert_failure x "int64" "int" int64_to_string let () = assert (num_bits_int < num_bits_int64) let int_to_int64 = Stdlib.Int64.of_int let int64_to_int_trunc = Stdlib.Int64.to_int let int64_is_representable_as_int = let min = int_to_int64 Int.min_value in let max = int_to_int64 Int.max_value in fun x -> compare_int64 min x <= 0 && compare_int64 x max <= 0 ;; let int64_to_int x = if int64_is_representable_as_int x then Some (int64_to_int_trunc x) else None ;; let int64_to_int_exn x = if int64_is_representable_as_int x then int64_to_int_trunc x else int64_to_int_failure x ;; (* int <-> nativeint *) let nativeint_to_int_failure x = convert_failure x "nativeint" "int" nativeint_to_string let () = assert (num_bits_int <= num_bits_nativeint) let int_to_nativeint = Stdlib.Nativeint.of_int let nativeint_to_int_trunc = Stdlib.Nativeint.to_int let nativeint_is_representable_as_int = if num_bits_nativeint <= num_bits_int then fun _ -> true else ( let min = int_to_nativeint Int.min_value in let max = int_to_nativeint Int.max_value in fun x -> compare_nativeint min x <= 0 && compare_nativeint x max <= 0) ;; let nativeint_to_int x = if nativeint_is_representable_as_int x then Some (nativeint_to_int_trunc x) else None ;; let nativeint_to_int_exn x = if nativeint_is_representable_as_int x then nativeint_to_int_trunc x else nativeint_to_int_failure x ;; (* int32 <-> int64 *) let int64_to_int32_failure x = convert_failure x "int64" "int32" int64_to_string let () = assert (num_bits_int32 < num_bits_int64) let int32_to_int64 = Stdlib.Int64.of_int32 let int64_to_int32_trunc = Stdlib.Int64.to_int32 let int64_is_representable_as_int32 = let min = int32_to_int64 min_int32 in let max = int32_to_int64 max_int32 in fun x -> compare_int64 min x <= 0 && compare_int64 x max <= 0 ;; let int64_to_int32 x = if int64_is_representable_as_int32 x then Some (int64_to_int32_trunc x) else None ;; let int64_to_int32_exn x = if int64_is_representable_as_int32 x then int64_to_int32_trunc x else int64_to_int32_failure x ;; (* int32 <-> nativeint *) let nativeint_to_int32_failure x = convert_failure x "nativeint" "int32" nativeint_to_string ;; let () = assert (num_bits_int32 <= num_bits_nativeint) let int32_to_nativeint = Stdlib.Nativeint.of_int32 let nativeint_to_int32_trunc = Stdlib.Nativeint.to_int32 let nativeint_is_representable_as_int32 = if num_bits_nativeint <= num_bits_int32 then fun _ -> true else ( let min = int32_to_nativeint min_int32 in let max = int32_to_nativeint max_int32 in fun x -> compare_nativeint min x <= 0 && compare_nativeint x max <= 0) ;; let nativeint_to_int32 x = if nativeint_is_representable_as_int32 x then Some (nativeint_to_int32_trunc x) else None ;; let nativeint_to_int32_exn x = if nativeint_is_representable_as_int32 x then nativeint_to_int32_trunc x else nativeint_to_int32_failure x ;; (* int64 <-> nativeint *) let int64_to_nativeint_failure x = convert_failure x "int64" "nativeint" int64_to_string let () = assert (num_bits_int64 >= num_bits_nativeint) let int64_to_nativeint_trunc = Stdlib.Int64.to_nativeint let nativeint_to_int64 = Stdlib.Int64.of_nativeint let int64_is_representable_as_nativeint = if num_bits_int64 <= num_bits_nativeint then fun _ -> true else ( let min = nativeint_to_int64 min_nativeint in let max = nativeint_to_int64 max_nativeint in fun x -> compare_int64 min x <= 0 && compare_int64 x max <= 0) ;; let int64_to_nativeint x = if int64_is_representable_as_nativeint x then Some (int64_to_nativeint_trunc x) else None ;; let int64_to_nativeint_exn x = if int64_is_representable_as_nativeint x then int64_to_nativeint_trunc x else int64_to_nativeint_failure x ;; (* int64 <-> int63 *) let int64_to_int63_failure x = convert_failure x "int64" "int63" int64_to_string let int64_is_representable_as_int63 = let min = Stdlib.Int64.shift_right min_int64 1 in let max = Stdlib.Int64.shift_right max_int64 1 in fun x -> compare_int64 min x <= 0 && compare_int64 x max <= 0 ;; let int64_fit_on_int63_exn x = if int64_is_representable_as_int63 x then () else int64_to_int63_failure x ;; (* string conversions *) let insert_delimiter_every input ~delimiter ~chars_per_delimiter = let input_length = String.length input in if input_length <= chars_per_delimiter then input else ( let has_sign = match input.[0] with | '+' | '-' -> true | _ -> false in let num_digits = if has_sign then input_length - 1 else input_length in let num_delimiters = (num_digits - 1) / chars_per_delimiter in let output_length = input_length + num_delimiters in let output = Bytes.create output_length in let input_pos = ref (input_length - 1) in let output_pos = ref (output_length - 1) in let num_chars_until_delimiter = ref chars_per_delimiter in let first_digit_pos = if has_sign then 1 else 0 in while !input_pos >= first_digit_pos do if !num_chars_until_delimiter = 0 then ( Bytes.set output !output_pos delimiter; decr output_pos; num_chars_until_delimiter := chars_per_delimiter); Bytes.set output !output_pos input.[!input_pos]; decr input_pos; decr output_pos; decr num_chars_until_delimiter done; if has_sign then Bytes.set output 0 input.[0]; Bytes.unsafe_to_string ~no_mutation_while_string_reachable:output) ;; let insert_delimiter input ~delimiter = insert_delimiter_every input ~delimiter ~chars_per_delimiter:3 ;; let insert_underscores input = insert_delimiter input ~delimiter:'_' let sexp_of_int_style = Sexp.of_int_style module Make (I : sig type t val to_string : t -> string end) = struct open I let chars_per_delimiter = 3 let to_string_hum ?(delimiter = '_') t = insert_delimiter_every (to_string t) ~delimiter ~chars_per_delimiter ;; let sexp_of_t t = let s = to_string t in Sexp.Atom (match !sexp_of_int_style with | `Underscores -> insert_delimiter_every s ~chars_per_delimiter ~delimiter:'_' | `No_underscores -> s) ;; end module Make_hex (I : sig type t [@@deriving_inline compare, hash] include Ppx_compare_lib.Comparable.S with type t := t include Ppx_hash_lib.Hashable.S with type t := t [@@@end] val to_string : t -> string val of_string : string -> t val zero : t val ( < ) : t -> t -> bool val neg : t -> t val module_name : string end) = struct module T_hex = struct type t = I.t [@@deriving_inline compare, hash] let compare = (I.compare : t -> t -> int) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = I.hash_fold_t and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = I.hash in fun x -> func x ;; [@@@end] let chars_per_delimiter = 4 let to_string' ?delimiter t = let make_suffix = match delimiter with | None -> I.to_string | Some delimiter -> fun t -> insert_delimiter_every (I.to_string t) ~delimiter ~chars_per_delimiter in if I.( < ) t I.zero then "-0x" ^ make_suffix (I.neg t) else "0x" ^ make_suffix t ;; let to_string t = to_string' t ?delimiter:None let to_string_hum ?(delimiter = '_') t = to_string' t ~delimiter let invalid str = Printf.failwithf "%s.of_string: invalid input %S" I.module_name str () ;; let of_string_with_delimiter str = I.of_string (String.filter str ~f:(fun c -> Char.( <> ) c '_')) ;; let of_string str = let module L = Hex_lexer in let lex = Stdlib.Lexing.from_string str in let result = Option.try_with (fun () -> L.parse_hex lex) in if lex.lex_curr_pos = lex.lex_buffer_len then ( match result with | None -> invalid str | Some (Neg body) -> I.neg (of_string_with_delimiter body) | Some (Pos body) -> of_string_with_delimiter body) else invalid str ;; end module Hex = struct include T_hex include Sexpable.Of_stringable (T_hex) end end base-0.16.3/src/int_conversions.mli000066400000000000000000000077221446274340700172520ustar00rootroot00000000000000(** Conversions between various integer types *) open! Import (** Ocaml has the following integer types, with the following bit widths on 32-bit and 64-bit architectures. {v arch arch type 32b 64b ---------------------- int 31 63 (32 when compiled to JavaScript) nativeint 32 64 int32 32 32 int64 64 64 v} In both cases, the following inequalities hold: {[ width(int) < width(nativeint) && width(int32) <= width(nativeint) <= width(int64) ]} The conversion functions come in one of two flavors. If width(foo) <= width(bar) on both 32-bit and 64-bit architectures, then we have {[ val foo_to_bar : foo -> bar ]} otherwise we have {[ val foo_to_bar : foo -> bar option val foo_to_bar_exn : foo -> bar ]} *) val int_to_int32 : int -> int32 option val int_to_int32_exn : int -> int32 val int_to_int32_trunc : int -> int32 val int_to_int64 : int -> int64 val int_to_nativeint : int -> nativeint val int32_to_int : int32 -> int option val int32_to_int_exn : int32 -> int val int32_to_int_trunc : int32 -> int val int32_to_int64 : int32 -> int64 val int32_to_nativeint : int32 -> nativeint val int64_to_int : int64 -> int option val int64_to_int_exn : int64 -> int val int64_to_int_trunc : int64 -> int val int64_to_int32 : int64 -> int32 option val int64_to_int32_exn : int64 -> int32 val int64_to_int32_trunc : int64 -> int32 val int64_to_nativeint : int64 -> nativeint option val int64_to_nativeint_exn : int64 -> nativeint val int64_to_nativeint_trunc : int64 -> nativeint val int64_fit_on_int63_exn : int64 -> unit val int64_is_representable_as_int63 : int64 -> bool val nativeint_to_int : nativeint -> int option val nativeint_to_int_exn : nativeint -> int val nativeint_to_int_trunc : nativeint -> int val nativeint_to_int32 : nativeint -> int32 option val nativeint_to_int32_exn : nativeint -> int32 val nativeint_to_int32_trunc : nativeint -> int32 val nativeint_to_int64 : nativeint -> int64 val num_bits_int : int val num_bits_int32 : int val num_bits_int64 : int val num_bits_nativeint : int (** human-friendly string (and possibly sexp) conversions *) module Make (I : sig type t val to_string : t -> string end) : sig val to_string_hum : ?delimiter:char (** defaults to ['_'] *) -> I.t -> string val sexp_of_t : I.t -> Sexp.t end (** in the output, [to_string], [of_string], [sexp_of_t], and [t_of_sexp] convert between [t] and signed hexadecimal with an optional "0x" or "0X" prefix. *) module Make_hex (I : sig type t [@@deriving_inline compare, hash] include Ppx_compare_lib.Comparable.S with type t := t include Ppx_hash_lib.Hashable.S with type t := t [@@@end] (** [to_string] and [of_string] convert between [t] and unsigned, unprefixed hexadecimal. They must be able to handle all non-negative values and also [min_value]. [to_string min_value] must write a positive hex representation. *) val to_string : t -> string val of_string : string -> t val zero : t val ( < ) : t -> t -> bool val neg : t -> t val module_name : string end) : Int_intf.Hexable with type t := I.t (** global ref affecting whether the [sexp_of_t] returned by [Make] is consistent with the [to_string] input or the [to_string_hum] output *) val sexp_of_int_style : [ `No_underscores | `Underscores ] ref (** utility for defining to_string_hum on numeric types -- takes a string matching (-|+)?[0-9a-fA-F]+ and puts [delimiter] every [chars_per_delimiter] characters starting from the right. *) val insert_delimiter_every : string -> delimiter:char -> chars_per_delimiter:int -> string (** [insert_delimiter_every ~chars_per_delimiter:3] *) val insert_delimiter : string -> delimiter:char -> string (** [insert_delimiter ~delimiter:'_'] *) val insert_underscores : string -> string base-0.16.3/src/int_intf.ml000066400000000000000000000332751446274340700154730ustar00rootroot00000000000000(** An interface to use for int-like types, e.g., {{!Base.Int}[Int]} and {{!Base.Int64}[Int64]}. *) open! Import module type Round = sig type t (** [round] rounds an int to a multiple of a given [to_multiple_of] argument, according to a direction [dir], with default [dir] being [`Nearest]. [round] will raise if [to_multiple_of <= 0]. If the result overflows (too far positive or too far negative), [round] returns an incorrect result. {v | `Down | rounds toward Int.neg_infinity | | `Up | rounds toward Int.infinity | | `Nearest | rounds to the nearest multiple, or `Up in case of a tie | | `Zero | rounds toward zero | v} Here are some examples for [round ~to_multiple_of:10] for each direction: {v | `Down | {10 .. 19} --> 10 | { 0 ... 9} --> 0 | {-10 ... -1} --> -10 | | `Up | { 1 .. 10} --> 10 | {-9 ... 0} --> 0 | {-19 .. -10} --> -10 | | `Zero | {10 .. 19} --> 10 | {-9 ... 9} --> 0 | {-19 .. -10} --> -10 | | `Nearest | { 5 .. 14} --> 10 | {-5 ... 4} --> 0 | {-15 ... -6} --> -10 | v} For convenience and performance, there are variants of [round] with [dir] hard-coded. If you are writing performance-critical code you should use these. *) val round : ?dir:[ `Zero | `Nearest | `Up | `Down ] -> t -> to_multiple_of:t -> t val round_towards_zero : t -> to_multiple_of:t -> t val round_down : t -> to_multiple_of:t -> t val round_up : t -> to_multiple_of:t -> t val round_nearest : t -> to_multiple_of:t -> t end module type Hexable = sig type t module Hex : sig type nonrec t = t [@@deriving_inline sexp, sexp_grammar, compare, hash] include Sexplib0.Sexpable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t include Ppx_compare_lib.Comparable.S with type t := t include Ppx_hash_lib.Hashable.S with type t := t [@@@end] include Stringable.S with type t := t val to_string_hum : ?delimiter:char -> t -> string end end module type S_common = sig type t [@@deriving_inline sexp, sexp_grammar] include Sexplib0.Sexpable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] include Floatable.S with type t := t include Intable.S with type t := t include Identifiable.S with type t := t include Comparable.With_zero with type t := t include Invariant.S with type t := t include Hexable with type t := t val of_string_opt : string -> t option (** [delimiter] is an underscore by default. *) val to_string_hum : ?delimiter:char -> t -> string (** {2 Infix operators and constants} *) val zero : t val one : t val minus_one : t val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t (** Integer exponentiation *) val ( ** ) : t -> t -> t (** Negation *) val neg : t -> t val ( ~- ) : t -> t (** There are two pairs of integer division and remainder functions, [/%] and [%], and [/] and [rem]. They both satisfy the same equation relating the quotient and the remainder: {[ x = (x /% y) * y + (x % y); x = (x / y) * y + (rem x y); ]} The functions return the same values if [x] and [y] are positive. They all raise if [y = 0]. The functions differ if [x < 0] or [y < 0]. If [y < 0], then [%] and [/%] raise, whereas [/] and [rem] do not. [x % y] always returns a value between 0 and [y - 1], even when [x < 0]. On the other hand, [rem x y] returns a negative value if and only if [x < 0]; that value satisfies [abs (rem x y) <= abs y - 1]. *) val ( /% ) : t -> t -> t val ( % ) : t -> t -> t val ( / ) : t -> t -> t val rem : t -> t -> t (** Float division of integers. *) val ( // ) : t -> t -> float (** Same as [bit_and]. *) val ( land ) : t -> t -> t (** Same as [bit_or]. *) val ( lor ) : t -> t -> t (** Same as [bit_xor]. *) val ( lxor ) : t -> t -> t (** Same as [bit_not]. *) val lnot : t -> t (** Same as [shift_left]. *) val ( lsl ) : t -> int -> t (** Same as [shift_right]. *) val ( asr ) : t -> int -> t (** {2 Other common functions} *) include Round with type t := t (** Returns the absolute value of the argument. May be negative if the input is [min_value]. *) val abs : t -> t (** {2 Successor and predecessor functions} *) val succ : t -> t val pred : t -> t (** {2 Exponentiation} *) (** [pow base exponent] returns [base] raised to the power of [exponent]. It is OK if [base <= 0]. [pow] raises if [exponent < 0], or an integer overflow would occur. *) val pow : t -> t -> t (** {2 Bit-wise logical operations } *) (** These are identical to [land], [lor], etc. except they're not infix and have different names. *) val bit_and : t -> t -> t val bit_or : t -> t -> t val bit_xor : t -> t -> t val bit_not : t -> t (** Returns the number of 1 bits in the binary representation of the input. *) val popcount : t -> int (** {2 Bit-shifting operations } The results are unspecified for negative shifts and shifts [>= num_bits]. *) (** Shifts left, filling in with zeroes. *) val shift_left : t -> int -> t (** Shifts right, preserving the sign of the input. *) val shift_right : t -> int -> t (** {2 Increment and decrement functions for integer references } *) val decr : t ref -> unit val incr : t ref -> unit (** {2 Conversion functions to related integer types} *) val of_int32_exn : int32 -> t val to_int32_exn : t -> int32 val of_int64_exn : int64 -> t val to_int64 : t -> int64 val of_nativeint_exn : nativeint -> t val to_nativeint_exn : t -> nativeint (** [of_float_unchecked] truncates the given floating point number to an integer, rounding towards zero. The result is unspecified if the argument is nan or falls outside the range of representable integers. *) val of_float_unchecked : float -> t end module type Operators_unbounded = sig type t val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t val ( ~- ) : t -> t val ( ** ) : t -> t -> t include Comparisons.Infix with type t := t val abs : t -> t val neg : t -> t val zero : t val ( % ) : t -> t -> t val ( /% ) : t -> t -> t val ( // ) : t -> t -> float val ( land ) : t -> t -> t val ( lor ) : t -> t -> t val ( lxor ) : t -> t -> t val lnot : t -> t val ( lsl ) : t -> int -> t val ( asr ) : t -> int -> t end module type Operators = sig include Operators_unbounded val ( lsr ) : t -> int -> t end (** [S_unbounded] is a generic interface for unbounded integers, e.g. [Bignum.Bigint]. [S_unbounded] is a restriction of [S] (below) that omits values that depend on fixed-size integers. *) module type S_unbounded = sig include S_common (** @inline *) (** A sub-module designed to be opened to make working with ints more convenient. *) module O : Operators_unbounded with type t := t end (** [S] is a generic interface for fixed-size integers. *) module type S = sig include S_common (** @inline *) (** The number of bits available in this integer type. Note that the integer representations are signed. *) val num_bits : int (** The largest representable integer. *) val max_value : t (** The smallest representable integer. *) val min_value : t (** Same as [shift_right_logical]. *) val ( lsr ) : t -> int -> t (** Shifts right, filling in with zeroes, which will not preserve the sign of the input. *) val shift_right_logical : t -> int -> t (** [ceil_pow2 x] returns the smallest power of 2 that is greater than or equal to [x]. The implementation may only be called for [x > 0]. Example: [ceil_pow2 17 = 32] *) val ceil_pow2 : t -> t (** [floor_pow2 x] returns the largest power of 2 that is less than or equal to [x]. The implementation may only be called for [x > 0]. Example: [floor_pow2 17 = 16] *) val floor_pow2 : t -> t (** [ceil_log2 x] returns the ceiling of log-base-2 of [x], and raises if [x <= 0]. *) val ceil_log2 : t -> int (** [floor_log2 x] returns the floor of log-base-2 of [x], and raises if [x <= 0]. *) val floor_log2 : t -> int (** [is_pow2 x] returns true iff [x] is a power of 2. [is_pow2] raises if [x <= 0]. *) val is_pow2 : t -> bool (** Returns the number of leading zeros in the binary representation of the input, as an integer between 0 and one less than [num_bits]. The results are unspecified for [t = 0]. *) val clz : t -> int (** Returns the number of trailing zeros in the binary representation of the input, as an integer between 0 and one less than [num_bits]. The results are unspecified for [t = 0]. *) val ctz : t -> int (** A sub-module designed to be opened to make working with ints more convenient. *) module O : Operators with type t := t end module type Int_without_module_types = sig (** OCaml's native integer type. The number of bits in an integer is platform dependent, being 31-bits on a 32-bit platform, and 63-bits on a 64-bit platform. [int] is a signed integer type. [int]s are also subject to overflow, meaning that [Int.max_value + 1 = Int.min_value]. [int]s always fit in a machine word. *) type t = int [@@deriving_inline globalize] val globalize : (t[@ocaml.local]) -> t [@@@end] include S with type t := t (** @inline *) module O : sig (*_ Declared as externals so that the compiler skips the caml_apply_X wrapping even when compiling without cross library inlining. *) external ( + ) : (t[@local_opt]) -> (t[@local_opt]) -> t = "%addint" external ( - ) : (t[@local_opt]) -> (t[@local_opt]) -> t = "%subint" external ( * ) : (t[@local_opt]) -> (t[@local_opt]) -> t = "%mulint" external ( / ) : (t[@local_opt]) -> (t[@local_opt]) -> t = "%divint" external ( ~- ) : (t[@local_opt]) -> t = "%negint" val ( ** ) : t -> t -> t external ( = ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%equal" external ( <> ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%notequal" external ( < ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%lessthan" external ( > ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%greaterthan" external ( <= ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%lessequal" external ( >= ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%greaterequal" external ( land ) : (t[@local_opt]) -> (t[@local_opt]) -> t = "%andint" external ( lor ) : (t[@local_opt]) -> (t[@local_opt]) -> t = "%orint" external ( lxor ) : (t[@local_opt]) -> (t[@local_opt]) -> t = "%xorint" val lnot : t -> t val abs : t -> t external neg : (t[@local_opt]) -> t = "%negint" val zero : t val ( % ) : t -> t -> t val ( /% ) : t -> t -> t val ( // ) : t -> t -> float external ( lsl ) : (t[@local_opt]) -> (int[@local_opt]) -> t = "%lslint" external ( asr ) : (t[@local_opt]) -> (int[@local_opt]) -> t = "%asrint" external ( lsr ) : (t[@local_opt]) -> (int[@local_opt]) -> t = "%lsrint" end include module type of O (** [max_value_30_bits = 2^30 - 1]. It is useful for writing tests that work on both 64-bit and 32-bit platforms. *) val max_value_30_bits : t (** {2 Conversion functions} *) val of_int : int -> t val to_int : t -> int val of_int32 : int32 -> t option val to_int32 : t -> int32 option val of_int64 : int64 -> t option val of_nativeint : nativeint -> t option val to_nativeint : t -> nativeint (** {3 Truncating conversions} These functions return the least-significant bits of the input. In cases where optional conversions return [Some x], truncating conversions return [x]. *) (*_ Declared as externals so that the compiler skips the caml_apply_X wrapping even when compiling without cross library inlining. *) external to_int32_trunc : (t[@local_opt]) -> (int32[@local_opt]) = "%int32_of_int" external of_int32_trunc : (int32[@local_opt]) -> t = "%int32_to_int" external of_int64_trunc : (int64[@local_opt]) -> t = "%int64_to_int" external of_nativeint_trunc : (nativeint[@local_opt]) -> t = "%nativeint_to_int" (** {2 Byte swap operations} Byte swap operations reverse the order of bytes in an integer. For example, {!Int32.bswap32} reorders the bottom 32 bits (or 4 bytes), turning [0x1122_3344] to [0x4433_2211]. Byte swap functions exposed by Base use OCaml primitives to generate assembly instructions to perform the relevant byte swaps. For a more extensive list of byteswap functions, see {!Int32} and {!Int64}. *) (** Byte swaps bottom 16 bits (2 bytes). The values of the remaining bytes are undefined. *) external bswap16 : (int[@local_opt]) -> int = "%bswap16" (*_ Declared as an external so that the compiler skips the caml_apply_X wrapping even when compiling without cross library inlining. *) (**/**) (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig (*_ For ../bench/bench_int.ml *) module O_F : sig val ( % ) : int -> int -> int val ( /% ) : int -> int -> int val ( // ) : int -> int -> float end end end module type Int = sig include Int_without_module_types (** @inline *) (** {2 Module types specifying integer operations.} *) module type Hexable = Hexable module type Int_without_module_types = Int_without_module_types module type Operators = Operators module type Operators_unbounded = Operators_unbounded module type Round = Round module type S = S module type S_common = S_common module type S_unbounded = S_unbounded end base-0.16.3/src/int_math.ml000066400000000000000000000077311446274340700154620ustar00rootroot00000000000000open! Import let invalid_argf = Printf.invalid_argf let negative_exponent () = Printf.invalid_argf "exponent can not be negative" () let overflow () = Printf.invalid_argf "integer overflow in pow" () (* To implement [int64_pow], we use C code rather than OCaml to eliminate allocation. *) external int_math_int_pow : int -> int -> int = "Base_int_math_int_pow_stub" [@@noalloc] external int_math_int64_pow : int64 -> int64 -> int64 = "Base_int_math_int64_pow_stub" let int_pow base exponent = if exponent < 0 then negative_exponent (); if abs base > 1 && (exponent > 63 || abs base > Pow_overflow_bounds.int_positive_overflow_bounds.(exponent)) then overflow (); int_math_int_pow base exponent ;; module Int64_with_comparisons = struct include Stdlib.Int64 external ( < ) : (int64[@local_opt]) -> (int64[@local_opt]) -> bool = "%lessthan" external ( > ) : (int64[@local_opt]) -> (int64[@local_opt]) -> bool = "%greaterthan" external ( >= ) : (int64[@local_opt]) -> (int64[@local_opt]) -> bool = "%greaterequal" end (* we don't do [abs] in int64 case to avoid allocation *) let int64_pow base exponent = let open Int64_with_comparisons in if exponent < 0L then negative_exponent (); if (base > 1L || base < -1L) && (exponent > 63L || (base >= 0L && base > Pow_overflow_bounds.int64_positive_overflow_bounds.(to_int exponent)) || (base < 0L && base < Pow_overflow_bounds.int64_negative_overflow_bounds.(to_int exponent))) then overflow (); int_math_int64_pow base exponent ;; let int63_pow_on_int64 base exponent = let open Int64_with_comparisons in if exponent < 0L then negative_exponent (); if abs base > 1L && (exponent > 63L || abs base > Pow_overflow_bounds.int63_on_int64_positive_overflow_bounds.(to_int exponent) ) then overflow (); int_math_int64_pow base exponent ;; module type Make_arg = sig type t include Floatable.S with type t := t include Stringable.S with type t := t val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t val ( ~- ) : t -> t include Comparisons.Infix with type t := t val abs : t -> t val neg : t -> t val zero : t val of_int_exn : int -> t val rem : t -> t -> t end module Make (X : Make_arg) = struct open X let ( % ) x y = if y <= zero then invalid_argf "%s %% %s in core_int.ml: modulus should be positive" (to_string x) (to_string y) (); let rval = X.rem x y in if rval < zero then rval + y else rval ;; let one = of_int_exn 1 let ( /% ) x y = if y <= zero then invalid_argf "%s /%% %s in core_int.ml: divisor should be positive" (to_string x) (to_string y) (); if x < zero then ((x + one) / y) - one else x / y ;; (** float division of integers *) let ( // ) x y = to_float x /. to_float y let round_down i ~to_multiple_of:modulus = i - (i % modulus) let round_up i ~to_multiple_of:modulus = let remainder = i % modulus in if remainder = zero then i else i + modulus - remainder ;; let round_towards_zero i ~to_multiple_of = if i = zero then zero else if i > zero then round_down i ~to_multiple_of else round_up i ~to_multiple_of ;; let round_nearest i ~to_multiple_of:modulus = let remainder = i % modulus in let modulus_minus_remainder = modulus - remainder in if modulus_minus_remainder <= remainder then i + modulus_minus_remainder else i - remainder ;; let[@inline always] round ?(dir = `Nearest) i ~to_multiple_of = match dir with | `Nearest -> round_nearest i ~to_multiple_of | `Down -> round_down i ~to_multiple_of | `Up -> round_up i ~to_multiple_of | `Zero -> round_towards_zero i ~to_multiple_of ;; end module Private = struct let int_pow = int_pow let int64_pow = int64_pow let int63_pow_on_int64 = int63_pow_on_int64 module Pow_overflow_bounds = Pow_overflow_bounds end base-0.16.3/src/int_math.mli000066400000000000000000000023471446274340700156310ustar00rootroot00000000000000(** This module implements derived integer operations (e.g., modulo, rounding to multiples) based on other basic operations. *) open! Import module type Make_arg = sig type t include Floatable.S with type t := t include Stringable.S with type t := t val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t val ( ~- ) : t -> t include Comparisons.Infix with type t := t val abs : t -> t val neg : t -> t val zero : t val of_int_exn : int -> t val rem : t -> t -> t end (** Derived operations common to various integer modules. See {{!Base.Int.S_common}[Int.S_common]} for a description of the operations derived by this module. *) module Make (X : Make_arg) : sig val ( % ) : X.t -> X.t -> X.t val ( /% ) : X.t -> X.t -> X.t val ( // ) : X.t -> X.t -> float include Int_intf.Round with type t := X.t end (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig val int_pow : int -> int -> int val int64_pow : int64 -> int64 -> int64 val int63_pow_on_int64 : int64 -> int64 -> int64 module Pow_overflow_bounds = Pow_overflow_bounds end base-0.16.3/src/int_math_stubs.c000066400000000000000000000114401446274340700165040ustar00rootroot00000000000000#include #include #include #include #include #include #ifdef _MSC_VER #include #define __builtin_popcountll __popcnt64 #define __builtin_popcount __popcnt static int __inline __builtin_clz(uint32_t x) { int r = 0; _BitScanReverse(&r, x); return r; } static int __inline __builtin_clzll(uint64_t x) { int r = 0; #ifdef _WIN64 _BitScanReverse64(&r, x); #else if (!_BitScanReverse(&r, (uint32_t)x) && _BitScanReverse(&r, (uint32_t)(x >> 32))) { r += 32; } #endif return r; } static int __inline __builtin_ctz(uint32_t x) { int r = 0; _BitScanForward(&r, x); return r; } static int __inline __builtin_ctzll(uint64_t x) { int r = 0; #ifdef _WIN64 _BitScanForward64(&r, x); #else if (_BitScanForward(&r, (uint32_t)(x >> 32))) { r += 32; } else { _BitScanForward(&r, (uint32_t)x); } #endif return r; } #endif static int64_t int_pow(int64_t base, int64_t exponent) { int64_t ret = 1; int64_t mul[4]; mul[0] = 1; mul[1] = base; mul[3] = 1; while (exponent != 0) { mul[1] *= mul[3]; mul[2] = mul[1] * mul[1]; mul[3] = mul[2] * mul[1]; ret *= mul[exponent & 3]; exponent >>= 2; } return ret; } CAMLprim value Base_int_math_int_pow_stub(value base, value exponent) { return (Val_long(int_pow(Long_val(base), Long_val(exponent)))); } CAMLprim value Base_int_math_int64_pow_stub(value base, value exponent) { CAMLparam2(base, exponent); CAMLreturn(caml_copy_int64(int_pow(Int64_val(base), Int64_val(exponent)))); } /* This implementation is faster than [__builtin_popcount(v) - 1], even though * it seems more complicated. The [&] clears the shifted sign bit after * [Long_val] or [Int_val]. */ CAMLprim value Base_int_math_int_popcount(value v) { #ifdef ARCH_SIXTYFOUR return Val_int(__builtin_popcountll(Long_val(v) & ~((uint64_t)1 << 63))); #else return Val_int(__builtin_popcount(Int_val(v) & ~((uint32_t)1 << 31))); #endif } /* The specification of all below [clz] and [ctz] functions are undefined for [v * = 0]. */ /* * For an int [x] in the [2n + 1] representation: * * clz(x) = __builtin_clz(x >> 1) - 1 * * If [x] is negative, then the macro [Int_val] would perform a arithmetic * shift right, rather than a logical shift right, and sign extend the number. * Therefore * * __builtin_clz(Int_val(x)) * * would always be zero, so * * clz(x) = __builtin_clz(Int_val(x)) - 1 * * would always be -1. This is not what we want. * * The logical shift right adds a leading zero to the argument of * __builtin_clz, which the -1 accounts for. Rather than adding the leading * zero and subtracting, we can just compute the clz of the tagged * representation, and that should be equivalent, while also handing negative * inputs correctly (the result will now be 0). */ intnat Base_int_math_int_clz_untagged(value v) { #ifdef ARCH_SIXTYFOUR return __builtin_clzll(v); #else return __builtin_clz(v); #endif } CAMLprim value Base_int_math_int_clz(value v) { return Val_int(Base_int_math_int_clz_untagged(v)); } intnat Base_int_math_int32_clz_unboxed(int32_t v) { return __builtin_clz(v); } CAMLprim value Base_int_math_int32_clz(value v) { return Val_int(Base_int_math_int32_clz_unboxed(Int32_val(v))); } intnat Base_int_math_int64_clz_unboxed(int64_t v) { return __builtin_clzll(v); } CAMLprim value Base_int_math_int64_clz(value v) { return Val_int(Base_int_math_int64_clz_unboxed(Int64_val(v))); } intnat Base_int_math_nativeint_clz_unboxed(intnat v) { #ifdef ARCH_SIXTYFOUR return __builtin_clzll(v); #else return __builtin_clz(v); #endif } CAMLprim value Base_int_math_nativeint_clz(value v) { return Val_int(Base_int_math_nativeint_clz_unboxed(Nativeint_val(v))); } intnat Base_int_math_int_ctz_untagged(intnat v) { #ifdef ARCH_SIXTYFOUR return __builtin_ctzll(v); #else return __builtin_ctz(v); #endif } CAMLprim value Base_int_math_int_ctz(value v) { return Val_int(Base_int_math_int_ctz_untagged(Int_val(v))); } intnat Base_int_math_int32_ctz_unboxed(int32_t v) { return __builtin_ctz(v); } CAMLprim value Base_int_math_int32_ctz(value v) { return Val_int(Base_int_math_int32_ctz_unboxed(Int32_val(v))); } intnat Base_int_math_int64_ctz_unboxed(int64_t v) { return __builtin_ctzll(v); } CAMLprim value Base_int_math_int64_ctz(value v) { return Val_int(Base_int_math_int64_ctz_unboxed(Int64_val(v))); } intnat Base_int_math_nativeint_ctz_unboxed(intnat v) { #ifdef ARCH_SIXTYFOUR return __builtin_ctzll(v); #else return __builtin_ctz(v); #endif } CAMLprim value Base_int_math_nativeint_ctz(value v) { return Val_int(Base_int_math_nativeint_ctz_unboxed(Nativeint_val(v))); } CAMLprim CAMLweakdef value caml_csel_value(value v_cond, value v_true, value v_false) { return (Bool_val(v_cond) ? v_true : v_false); } base-0.16.3/src/intable.ml000066400000000000000000000002551446274340700152670ustar00rootroot00000000000000(** Functor that adds integer conversion functions to a module. *) open! Import module type S = sig type t val of_int_exn : int -> t val to_int_exn : t -> int end base-0.16.3/src/invariant.ml000066400000000000000000000010361446274340700156420ustar00rootroot00000000000000open! Import include Invariant_intf let raise_s = Error.raise_s let invariant here t sexp_of_t f : unit = try f () with | exn -> raise_s (Sexp.message "invariant failed" [ "", Source_code_position0.sexp_of_t here ; "exn", sexp_of_exn exn ; "", sexp_of_t t ]) ;; let check_field t f field = try f (Field.get field t) with | exn -> raise_s (Sexp.message "problem with field" [ "field", sexp_of_string (Field.name field); "exn", sexp_of_exn exn ]) ;; base-0.16.3/src/invariant.mli000066400000000000000000000000601446274340700160070ustar00rootroot00000000000000include Invariant_intf.Invariant (** @inline *) base-0.16.3/src/invariant_intf.ml000066400000000000000000000045761446274340700166760ustar00rootroot00000000000000open! Import type 'a t = 'a -> unit type 'a inv = 'a t module type S = sig type t val invariant : t inv end 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 module type Invariant = sig (** This module defines signatures that are to be included in other signatures to ensure a consistent interface to invariant-style functions. There is a signature ([S], [S1], [S2], [S3]) for each arity of type. Usage looks like: {[ type t include Invariant.S with type t := t ]} or {[ type 'a t include Invariant.S1 with type 'a t := 'a t ]} *) type nonrec 'a t = 'a t module type S = S module type S1 = S1 module type S2 = S2 module type S3 = S3 (** [invariant here t sexp_of_t f] runs [f ()], and if [f] raises, wraps the exception in an [Error.t] that states "invariant failed" and includes both the exception raised by [f], as well as [sexp_of_t t]. Idiomatic usage looks like: {[ invariant [%here] t [%sexp_of: t] (fun () -> ... check t's invariants ... ) ]} For polymorphic types: {[ let invariant check_a t = Invariant.invariant [%here] t [%sexp_of: _ t] (fun () -> ... ) ]} It's okay to use [ [%sexp_of: _ t] ] because the exceptions raised by [check_a] will show the parts that are opaque at top-level. *) val invariant : Source_code_position0.t -> 'a -> (('a -> Sexp.t)[@local]) -> ((unit -> unit)[@local]) -> unit (** [check_field] is used when checking invariants using [Fields.iter]. It wraps an exception raised when checking a field with the field's name. Idiomatic usage looks like: {[ type t = { foo : Foo.t; bar : Bar.t; } [@@deriving fields] let invariant t : unit = Invariant.invariant [%here] t [%sexp_of: t] (fun () -> let check f = Invariant.check_field t f in Fields.iter ~foo:(check Foo.invariant) ~bar:(check Bar.invariant)) ;; ]} *) val check_field : 'a -> 'b t -> ('a, 'b) Field.t -> unit end base-0.16.3/src/lazy.ml000066400000000000000000000022371446274340700146320ustar00rootroot00000000000000open! Import include Stdlib.Lazy type 'a t = 'a lazy_t [@@deriving_inline sexp, sexp_grammar] let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = lazy_t_of_sexp let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = sexp_of_lazy_t let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> lazy_t_sexp_grammar _'a_sexp_grammar ;; [@@@end] external force : ('a t[@local_opt]) -> 'a = "%lazy_force" let map t ~f = lazy (f (force t)) let compare compare_a t1 t2 = if phys_equal t1 t2 then 0 else compare_a (force t1) (force t2) ;; let equal equal_a t1 t2 = if phys_equal t1 t2 then true else equal_a (force t1) (force t2) let hash_fold_t = Hash.Builtin.hash_fold_lazy_t let peek t = if is_val t then Some (force t) else None include Monad.Make (struct type nonrec 'a t = 'a t let return x = from_val x let bind t ~f = lazy (force (f (force t))) let map = map let map = `Custom map end) module T_unforcing = struct type nonrec 'a t = 'a t let sexp_of_t sexp_of_a t = if is_val t then sexp_of_a (force t) else sexp_of_string "" ;; end base-0.16.3/src/lazy.mli000066400000000000000000000067621446274340700150120ustar00rootroot00000000000000 (** A value of type ['a Lazy.t] is a deferred computation, called a suspension, that has a result of type ['a]. The special expression syntax [lazy (expr)] makes a suspension of the computation of [expr], without computing [expr] itself yet. "Forcing" the suspension will then compute [expr] and return its result. Note: [lazy_t] is the built-in type constructor used by the compiler for the [lazy] keyword. You should not use it directly. Always use [Lazy.t] instead. Note: [Lazy.force] is not thread-safe. If you use this module in a multi-threaded program, you will need to add some locks. Note: if the program is compiled with the [-rectypes] option, ill-founded recursive definitions of the form [let rec x = lazy x] or [let rec x = lazy(lazy(...(lazy x)))] are accepted by the type-checker and lead, when forced, to ill-formed values that trigger infinite loops in the garbage collector and other parts of the run-time system. Without the [-rectypes] option, such ill-founded recursive definitions are rejected by the type-checker. *) open! Import type 'a t = 'a lazy_t [@@deriving_inline compare, equal, hash, sexp, sexp_grammar] include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t include Ppx_hash_lib.Hashable.S1 with type 'a t := 'a t include Sexplib0.Sexpable.S1 with type 'a t := 'a t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] include Monad.S with type 'a t := 'a t exception Undefined (** [force x] forces the suspension [x] and returns its result. If [x] has already been forced, [Lazy.force x] returns the same value again without recomputing it. If it raised an exception, the same exception is raised again. Raise [Undefined] if the forcing of [x] tries to force [x] itself recursively. *) external force : ('a t[@local_opt]) -> 'a = "%lazy_force" (** Like [force] except that [force_val x] does not use an exception handler, so it may be more efficient. However, if the computation of [x] raises an exception, it is unspecified whether [force_val x] raises the same exception or [Undefined]. *) val force_val : 'a t -> 'a (** [from_fun f] is the same as [lazy (f ())] but slightly more efficient if [f] is a variable. [from_fun] should only be used if the function [f] is already defined. In particular it is always less efficient to write [from_fun (fun () -> expr)] than [lazy expr]. *) val from_fun : (unit -> 'a) -> 'a t (** [from_val v] returns an already-forced suspension of [v] (where [v] can be any expression). Essentially, [from_val expr] is the same as [let var = expr in lazy var]. *) val from_val : 'a -> 'a t (** [is_val x] returns [true] if [x] has already been forced and did not raise an exception. *) val is_val : 'a t -> bool (** [peek x] returns None if [x] has never been forced or [Some v] if [x] was forced to value [v] *) val peek : 'a t -> 'a option (** This type offers a serialization function [sexp_of_t] that won't force its argument. Instead, it will serialize the ['a] if it is available, or just use a custom string indicating it is not forced. Note that this is not a round-trippable type, thus the type does not expose [of_sexp]. To be used in debug code, while tracking a Heisenbug, etc. *) module T_unforcing : sig type nonrec 'a t = 'a t [@@deriving_inline sexp_of] val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t [@@@end] end base-0.16.3/src/linked_queue.ml000066400000000000000000000061411446274340700163230ustar00rootroot00000000000000open! Import include Linked_queue0 let enqueue t x = Linked_queue0.push x t let dequeue t = if is_empty t then None else Some (Linked_queue0.pop t) let dequeue_exn = Linked_queue0.pop let dequeue_and_ignore_exn (type elt) (t : elt t) = ignore (dequeue_exn t : elt) let peek t = if is_empty t then None else Some (Linked_queue0.peek t) let peek_exn = Linked_queue0.peek module C = Indexed_container.Make (struct type nonrec 'a t = 'a t let fold = fold let iter = `Custom iter let length = `Custom length let foldi = `Define_using_fold let iteri = `Define_using_fold end) let count = C.count let exists = C.exists let find = C.find let find_map = C.find_map let fold_result = C.fold_result let fold_until = C.fold_until let for_all = C.for_all let max_elt = C.max_elt let mem = C.mem let min_elt = C.min_elt let sum = C.sum let to_list = C.to_list let counti = C.counti let existsi = C.existsi let find_mapi = C.find_mapi let findi = C.findi let foldi = C.foldi let for_alli = C.for_alli let iteri = C.iteri let transfer ~src ~dst = Linked_queue0.transfer src dst let concat_map t ~f = let res = create () in iter t ~f:(fun a -> List.iter (f a) ~f:(fun b -> enqueue res b)); res ;; let concat_mapi t ~f = let res = create () in iteri t ~f:(fun i a -> List.iter (f i a) ~f:(fun b -> enqueue res b)); res ;; let filter_map t ~f = let res = create () in iter t ~f:(fun a -> match f a with | None -> () | Some b -> enqueue res b); res ;; let filter_mapi t ~f = let res = create () in iteri t ~f:(fun i a -> match f i a with | None -> () | Some b -> enqueue res b); res ;; let filter t ~f = let res = create () in iter t ~f:(fun a -> if f a then enqueue res a); res ;; let filteri t ~f = let res = create () in iteri t ~f:(fun i a -> if f i a then enqueue res a); res ;; let map t ~f = let res = create () in iter t ~f:(fun a -> enqueue res (f a)); res ;; let mapi t ~f = let res = create () in iteri t ~f:(fun i a -> enqueue res (f i a)); res ;; let filter_inplace q ~f = let q' = filter q ~f in clear q; transfer ~src:q' ~dst:q ;; let filteri_inplace q ~f = let q' = filteri q ~f in clear q; transfer ~src:q' ~dst:q ;; let enqueue_all t list = List.iter list ~f:(fun x -> enqueue t x) let of_list list = let t = create () in List.iter list ~f:(fun x -> enqueue t x); t ;; let of_array array = let t = create () in Array.iter array ~f:(fun x -> enqueue t x); t ;; let init len ~f = let t = create () in for i = 0 to len - 1 do enqueue t (f i) done; t ;; let to_array t = match length t with | 0 -> [||] | len -> let arr = Array.create ~len (peek_exn t) in let i = ref 0 in iter t ~f:(fun v -> arr.(!i) <- v; incr i); arr ;; let t_of_sexp a_of_sexp sexp = of_list (list_of_sexp a_of_sexp sexp) let sexp_of_t sexp_of_a t = sexp_of_list sexp_of_a (to_list t) let t_sexp_grammar (type a) (grammar : a Sexplib0.Sexp_grammar.t) : a t Sexplib0.Sexp_grammar.t = Sexplib0.Sexp_grammar.coerce (List.t_sexp_grammar grammar) ;; let singleton a = let t = create () in enqueue t a; t ;; base-0.16.3/src/linked_queue.mli000066400000000000000000000010111446274340700164630ustar00rootroot00000000000000(** This module is a Base-style wrapper around OCaml's standard [Queue] module. *) open! Import include Queue_intf.S with type 'a t = 'a Stdlib.Queue.t (** @inline *) (** [create ()] returns an empty queue. *) val create : unit -> _ t (** [transfer ~src ~dst] adds all of the elements of [src] to the end of [dst], then clears [src]. It is equivalent to the sequence: {[ iter ~src ~f:(enqueue dst); clear src ]} but runs in constant time. *) val transfer : src:'a t -> dst:'a t -> unit base-0.16.3/src/linked_queue0.ml000066400000000000000000000013631446274340700164040ustar00rootroot00000000000000open! Import0 type 'a t = 'a Stdlib.Queue.t let create = Stdlib.Queue.create let clear = Stdlib.Queue.clear let copy = Stdlib.Queue.copy let is_empty = Stdlib.Queue.is_empty let length = Stdlib.Queue.length let peek = Stdlib.Queue.peek let pop = Stdlib.Queue.pop let push = Stdlib.Queue.push let transfer = Stdlib.Queue.transfer let iter t ~f:((f : _ -> _) [@local]) = let caml_iter : (('a -> unit)[@local]) -> 'a t -> unit = Stdlib.Obj.magic (Stdlib.Queue.iter : ('a -> unit) -> 'a t -> unit) in caml_iter f t ;; let fold t ~init ~f:((f : _ -> _ -> _) [@local]) = let caml_fold : (('b -> 'a -> 'b)[@local]) -> 'b -> 'a t -> 'b = Stdlib.Obj.magic (Stdlib.Queue.fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b) in caml_fold f init t ;; base-0.16.3/src/list.ml000066400000000000000000001105501446274340700146240ustar00rootroot00000000000000open! Import module Array = Array0 module Either = Either0 include List1 (* This itself includes [List0]. *) let invalid_argf = Printf.invalid_argf module T = struct type 'a t = 'a list [@@deriving_inline globalize, sexp, sexp_grammar] let globalize : 'a. (('a[@ocaml.local]) -> 'a) -> ('a t[@ocaml.local]) -> 'a t = fun (type a__001_) : (((a__001_[@ocaml.local]) -> a__001_) -> (a__001_ t[@ocaml.local]) -> a__001_ t) -> globalize_list ;; let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = list_of_sexp let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = sexp_of_list let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> list_sexp_grammar _'a_sexp_grammar ;; [@@@end] end module Or_unequal_lengths = struct type 'a t = | Ok of 'a | Unequal_lengths [@@deriving_inline compare, sexp_of] let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = fun _cmp__a a__010_ b__011_ -> if Stdlib.( == ) a__010_ b__011_ then 0 else ( match a__010_, b__011_ with | Ok _a__012_, Ok _b__013_ -> _cmp__a _a__012_ _b__013_ | Ok _, _ -> -1 | _, Ok _ -> 1 | Unequal_lengths, Unequal_lengths -> 0) ;; let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = fun (type a__017_) : ((a__017_ -> Sexplib0.Sexp.t) -> a__017_ t -> Sexplib0.Sexp.t) -> fun _of_a__014_ -> function | Ok arg0__015_ -> let res0__016_ = _of_a__014_ arg0__015_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Ok"; res0__016_ ] | Unequal_lengths -> Sexplib0.Sexp.Atom "Unequal_lengths" ;; [@@@end] end include T let invariant f t = iter t ~f let of_list t = t let range' ~compare ~stride ?(start = `inclusive) ?(stop = `exclusive) start_i stop_i = let next_i = stride start_i in let order x y = Ordering.of_int (compare x y) in let raise_stride_cannot_return_same_value () = invalid_arg "List.range': stride function cannot return the same value" in let initial_stride_order = match order start_i next_i with | Equal -> raise_stride_cannot_return_same_value () | Less -> `Less | Greater -> `Greater in let rec loop i accum = let i_to_stop_order = order i stop_i in match i_to_stop_order, initial_stride_order with | Less, `Less | Greater, `Greater -> (* haven't yet reached [stop_i]. Continue. *) let next_i = stride i in (match order i next_i, initial_stride_order with | Equal, _ -> raise_stride_cannot_return_same_value () | Less, `Greater | Greater, `Less -> invalid_arg "List.range': stride function cannot change direction" | Less, `Less | Greater, `Greater -> loop next_i (i :: accum)) | Less, `Greater | Greater, `Less -> (* stepped past [stop_i]. Finished. *) accum | Equal, _ -> (* reached [stop_i]. Finished. *) (match stop with | `inclusive -> i :: accum | `exclusive -> accum) in let start_i = match start with | `inclusive -> start_i | `exclusive -> next_i in rev (loop start_i []) ;; let range ?(stride = 1) ?(start = `inclusive) ?(stop = `exclusive) start_i stop_i = if stride = 0 then invalid_arg "List.range: stride must be non-zero"; range' ~compare ~stride:(fun x -> x + stride) ~start ~stop start_i stop_i ;; let hd t = match t with | [] -> None | x :: _ -> Some x ;; let tl t = match t with | [] -> None | _ :: t' -> Some t' ;; let nth t n = if n < 0 then None else ( let rec nth_aux t n = match t with | [] -> None | a :: t -> if n = 0 then Some a else nth_aux t (n - 1) in nth_aux t n) ;; let nth_exn t n = match nth t n with | None -> invalid_argf "List.nth_exn %d called on list of length %d" n (length t) () | Some a -> a ;; let unordered_append l1 l2 = match l1, l2 with | [], l | l, [] -> l | _ -> rev_append l1 l2 ;; module Check_length2 = struct type ('a, 'b) t = | Same_length of int | Unequal_lengths of { shared_length : int ; tail_of_a : 'a list ; tail_of_b : 'b list } (* In the [Unequal_lengths] case, at least one of the tails will be non-empty. *) let of_lists l1 l2 = let rec loop a b shared_length = match a, b with | [], [] -> Same_length shared_length | _ :: a, _ :: b -> loop a b (shared_length + 1) | [], _ | _, [] -> Unequal_lengths { shared_length; tail_of_a = a; tail_of_b = b } in loop l1 l2 0 ;; end let check_length2_exn name l1 l2 = match Check_length2.of_lists l1 l2 with | Same_length _ -> () | Unequal_lengths { shared_length; tail_of_a; tail_of_b } -> invalid_argf "length mismatch in %s: %d <> %d" name (shared_length + length tail_of_a) (shared_length + length tail_of_b) () ;; let check_length2 l1 l2 ~f = match Check_length2.of_lists l1 l2 with | Same_length _ -> Or_unequal_lengths.Ok (f l1 l2) | Unequal_lengths _ -> Unequal_lengths ;; module Check_length3 = struct type ('a, 'b, 'c) t = | Same_length of int | Unequal_lengths of { shared_length : int ; tail_of_a : 'a list ; tail_of_b : 'b list ; tail_of_c : 'c list } (* In the [Unequal_lengths] case, at least one of the tails will be non-empty. *) let of_lists l1 l2 l3 = let rec loop a b c shared_length = match a, b, c with | [], [], [] -> Same_length shared_length | _ :: a, _ :: b, _ :: c -> loop a b c (shared_length + 1) | [], _, _ | _, [], _ | _, _, [] -> Unequal_lengths { shared_length; tail_of_a = a; tail_of_b = b; tail_of_c = c } in loop l1 l2 l3 0 ;; end let check_length3_exn name l1 l2 l3 = match Check_length3.of_lists l1 l2 l3 with | Same_length _ -> () | Unequal_lengths { shared_length; tail_of_a; tail_of_b; tail_of_c } -> let n1 = shared_length + length tail_of_a in let n2 = shared_length + length tail_of_b in let n3 = shared_length + length tail_of_c in invalid_argf "length mismatch in %s: %d <> %d || %d <> %d" name n1 n2 n2 n3 () ;; let check_length3 l1 l2 l3 ~f = match Check_length3.of_lists l1 l2 l3 with | Same_length _ -> Or_unequal_lengths.Ok (f l1 l2 l3) | Unequal_lengths _ -> Unequal_lengths ;; let iter2 l1 l2 ~f = check_length2 l1 l2 ~f:(iter2_ok ~f) [@nontail] let iter2_exn l1 l2 ~f = check_length2_exn "iter2_exn" l1 l2; iter2_ok l1 l2 ~f ;; let rev_map2 l1 l2 ~f = check_length2 l1 l2 ~f:(rev_map2_ok ~f) [@nontail] let rev_map2_exn l1 l2 ~f = check_length2_exn "rev_map2_exn" l1 l2; rev_map2_ok l1 l2 ~f ;; let fold2 l1 l2 ~init ~f = check_length2 l1 l2 ~f:(fold2_ok ~init ~f) [@nontail] let fold2_exn l1 l2 ~init ~f = check_length2_exn "fold2_exn" l1 l2; fold2_ok l1 l2 ~init ~f ;; let fold_right2 l1 l2 ~f ~init = check_length2 l1 l2 ~f:(fold_right2_ok ~f ~init) [@nontail] ;; let fold_right2_exn l1 l2 ~f ~init = check_length2_exn "fold_right2_exn" l1 l2; fold_right2_ok l1 l2 ~f ~init ;; let for_all2 l1 l2 ~f = check_length2 l1 l2 ~f:(for_all2_ok ~f) [@nontail] let for_all2_exn l1 l2 ~f = check_length2_exn "for_all2_exn" l1 l2; for_all2_ok l1 l2 ~f ;; let exists2 l1 l2 ~f = check_length2 l1 l2 ~f:(exists2_ok ~f) [@nontail] let exists2_exn l1 l2 ~f = check_length2_exn "exists2_exn" l1 l2; exists2_ok l1 l2 ~f ;; let mem t a ~equal = let rec loop equal a = function | [] -> false | b :: bs -> equal a b || loop equal a bs in loop equal a t ;; (* This is a copy of the code from the standard library, with an extra eta-expansion to avoid creating partial closures (showed up for [filter]) in profiling). *) let rev_filter t ~f = let rec find ~f accu = function | [] -> accu | x :: l -> if f x then find ~f (x :: accu) l else find ~f accu l in find ~f [] t ;; let filter t ~f = rev (rev_filter t ~f) let find_map t ~f = let rec loop = function | [] -> None | x :: l -> (match f x with | None -> loop l | Some _ as r -> r) in loop t [@nontail] ;; let find_map_exn = let not_found = Not_found_s (Atom "List.find_map_exn: not found") in let find_map_exn t ~f = match find_map t ~f with | None -> raise not_found | Some x -> x in (* named to preserve symbol in compiled binary *) find_map_exn ;; let find t ~f = let rec loop = function | [] -> None | x :: l -> if f x then Some x else loop l in loop t [@nontail] ;; let find_exn = let not_found = Not_found_s (Atom "List.find_exn: not found") in let rec find_exn t ~f = match t with | [] -> raise not_found | x :: t -> if f x then x else find_exn t ~f in (* named to preserve symbol in compiled binary *) find_exn ;; let findi t ~f = let rec loop i t = match t with | [] -> None | x :: l -> if f i x then Some (i, x) else loop (i + 1) l in loop 0 t [@nontail] ;; let findi_exn = let not_found = Not_found_s (Atom "List.findi_exn: not found") in let findi_exn t ~f = match findi t ~f with | None -> raise not_found | Some x -> x in findi_exn ;; let find_mapi t ~f = let rec loop i t = match t with | [] -> None | x :: l -> (match f i x with | Some _ as result -> result | None -> loop (i + 1) l) in loop 0 t [@nontail] ;; let find_mapi_exn = let not_found = Not_found_s (Atom "List.find_mapi_exn: not found") in let find_mapi_exn t ~f = match find_mapi t ~f with | None -> raise not_found | Some x -> x in (* named to preserve symbol in compiled binary *) find_mapi_exn ;; let for_alli t ~f = let rec loop i t = match t with | [] -> true | hd :: tl -> f i hd && loop (i + 1) tl in loop 0 t [@nontail] ;; let existsi t ~f = let rec loop i t = match t with | [] -> false | hd :: tl -> f i hd || loop (i + 1) tl in loop 0 t [@nontail] ;; (** For the container interface. *) let fold_left = fold let of_array = Array.to_list let to_array = Array.of_list let to_list t = t let max_non_tailcall = match Sys.backend_type with | Sys.Native | Sys.Bytecode -> 1_000 (* We don't know the size of the stack, better be safe and assume it's small. This number was taken from ocaml#stdlib/list.ml which is also equal to the default limit of recursive call in the js_of_ocaml compiler before switching to trampoline. *) | Sys.Other _ -> 50 ;; (** Tail recursive versions of standard [List] module *) let tail_append l1 l2 = rev_append (rev l1) l2 (* There are a few optimized list operations here, including append and map. There are basically two optimizations in play: loop unrolling, and dynamic switching between stack and heap allocation. The loop-unrolling is straightforward, we just unroll 5 levels of the loop. This makes each iteration faster, and also reduces the number of stack frames consumed per list element. The dynamic switching is done by counting the number of stack frames, and then switching to the "slow" implementation when we exceed a given limit. This means that short lists use the fast stack-allocation method, and long lists use a slower one that doesn't require stack space. *) let rec count_append l1 l2 count = match l2 with | [] -> l1 | _ -> (match l1 with | [] -> l2 | [ x1 ] -> x1 :: l2 | [ x1; x2 ] -> x1 :: x2 :: l2 | [ x1; x2; x3 ] -> x1 :: x2 :: x3 :: l2 | [ x1; x2; x3; x4 ] -> x1 :: x2 :: x3 :: x4 :: l2 | x1 :: x2 :: x3 :: x4 :: x5 :: tl -> x1 :: x2 :: x3 :: x4 :: x5 :: (if count > max_non_tailcall then tail_append tl l2 else count_append tl l2 (count + 1))) ;; let append l1 l2 = count_append l1 l2 0 (* An ordinary tail recursive map builds up an intermediate (reversed) representation, with one heap allocated object per element. The following implementation instead chunks 9 objects into one heap allocated object, reducing allocation and performance costs accordingly. Note that the very end of the list is done by the stdlib's map function. *) let tail_map xs ~f:(f [@local]) = let rec rise ys = function | [] -> ys | (y0, y1, y2, y3, y4, y5, y6, y7, y8) :: bs -> rise (y0 :: y1 :: y2 :: y3 :: y4 :: y5 :: y6 :: y7 :: y8 :: ys) bs in let rec dive bs = function | x0 :: x1 :: x2 :: x3 :: x4 :: x5 :: x6 :: x7 :: x8 :: xs -> let y0 = f x0 in let y1 = f x1 in let y2 = f x2 in let y3 = f x3 in let y4 = f x4 in let y5 = f x5 in let y6 = f x6 in let y7 = f x7 in let y8 = f x8 in dive ((y0, y1, y2, y3, y4, y5, y6, y7, y8) :: bs) xs | xs -> rise (nontail_map ~f xs) bs in let res = dive [] xs in res ;; let rec count_map ~f:(f [@local]) l ctr = match l with | [] -> [] | [ x1 ] -> let f1 = f x1 in [ f1 ] | [ x1; x2 ] -> let f1 = f x1 in let f2 = f x2 in [ f1; f2 ] | [ x1; x2; x3 ] -> let f1 = f x1 in let f2 = f x2 in let f3 = f x3 in [ f1; f2; f3 ] | [ x1; x2; x3; x4 ] -> let f1 = f x1 in let f2 = f x2 in let f3 = f x3 in let f4 = f x4 in [ f1; f2; f3; f4 ] | x1 :: x2 :: x3 :: x4 :: x5 :: tl -> let f1 = f x1 in let f2 = f x2 in let f3 = f x3 in let f4 = f x4 in let f5 = f x5 in f1 :: f2 :: f3 :: f4 :: f5 :: (if ctr > max_non_tailcall then tail_map ~f tl else count_map ~f tl (ctr + 1)) ;; let map l ~f = count_map ~f l 0 let folding_map t ~init ~f = let acc = ref init in map t ~f:(fun x -> let new_acc, y = f !acc x in acc := new_acc; y) [@nontail] ;; let fold_map t ~init ~f = let acc = ref init in let result = map t ~f:(fun x -> let new_acc, y = f !acc x in acc := new_acc; y) in !acc, result ;; let ( >>| ) l f = map l ~f let map2_ok l1 l2 ~f = rev (rev_map2_ok l1 l2 ~f) let map2 l1 l2 ~f = check_length2 l1 l2 ~f:(map2_ok ~f) [@nontail] let map2_exn l1 l2 ~f = check_length2_exn "map2_exn" l1 l2; map2_ok l1 l2 ~f ;; let rev_map3_ok l1 l2 l3 ~f = let rec loop l1 l2 l3 ac = match l1, l2, l3 with | [], [], [] -> ac | x1 :: l1, x2 :: l2, x3 :: l3 -> loop l1 l2 l3 (f x1 x2 x3 :: ac) | _ -> assert false in loop l1 l2 l3 [] [@nontail] ;; let rev_map3 l1 l2 l3 ~f = check_length3 l1 l2 l3 ~f:(rev_map3_ok ~f) [@nontail] let rev_map3_exn l1 l2 l3 ~f = check_length3_exn "rev_map3_exn" l1 l2 l3; rev_map3_ok l1 l2 l3 ~f ;; let map3_ok l1 l2 l3 ~f = rev (rev_map3_ok l1 l2 l3 ~f) let map3 l1 l2 l3 ~f = check_length3 l1 l2 l3 ~f:(map3_ok ~f) [@nontail] let map3_exn l1 l2 l3 ~f = check_length3_exn "map3_exn" l1 l2 l3; map3_ok l1 l2 l3 ~f ;; let rec rev_map_append l1 l2 ~f = match l1 with | [] -> l2 | h :: t -> rev_map_append ~f t (f h :: l2) ;; let unzip list = let rec loop list l1 l2 = match list with | [] -> l1, l2 | (x, y) :: tl -> loop tl (x :: l1) (y :: l2) in loop (rev list) [] [] ;; let unzip3 list = let rec loop list l1 l2 l3 = match list with | [] -> l1, l2, l3 | (x, y, z) :: tl -> loop tl (x :: l1) (y :: l2) (z :: l3) in loop (rev list) [] [] [] ;; let zip_exn l1 l2 = try map2_ok ~f:(fun a b -> a, b) l1 l2 with | _ -> invalid_argf "length mismatch in zip_exn: %d <> %d" (length l1) (length l2) () ;; let zip l1 l2 = map2 ~f:(fun a b -> a, b) l1 l2 (** Additional list operations *) let rev_mapi l ~f = let rec loop i acc = function | [] -> acc | h :: t -> loop (i + 1) (f i h :: acc) t in loop 0 [] l [@nontail] ;; let mapi l ~f = rev (rev_mapi l ~f) let folding_mapi t ~init ~f = let acc = ref init in mapi t ~f:(fun i x -> let new_acc, y = f i !acc x in acc := new_acc; y) [@nontail] ;; let fold_mapi t ~init ~f = let acc = ref init in let result = mapi t ~f:(fun i x -> let new_acc, y = f i !acc x in acc := new_acc; y) in !acc, result ;; let iteri l ~f = ignore (fold l ~init:0 ~f:(fun i x -> f i x; i + 1) : int) ;; let foldi t ~init ~f = snd (fold t ~init:(0, init) ~f:(fun (i, acc) v -> i + 1, f i acc v)) ;; let filteri l ~f = rev (foldi l ~f:(fun pos acc x -> if f pos x then x :: acc else acc) ~init:[]) ;; let reduce l ~f = match l with | [] -> None | hd :: tl -> Some (fold ~init:hd ~f tl) ;; let reduce_exn l ~f = match reduce l ~f with | None -> invalid_arg "List.reduce_exn" | Some v -> v ;; let reduce_balanced l ~f = (* Call the "size" of a value the number of list elements that have been combined into it via calls to [f]. We proceed by using [f] to combine elements in the accumulator of the same size until we can't combine any more, then getting a new element from the input list and repeating. With this strategy, in the accumulator: - we only ever have elements of sizes a power of two - we never have more than one element of each size - the sum of all the element sizes is equal to the number of elements consumed These conditions enforce that list of elements of each size is precisely the binary expansion of the number of elements consumed: if you've consumed 13 = 0b1101 elements, you have one element of size 8, one of size 4, and one of size 1. Hence when a new element comes along, the number of combinings you need to do is the number of trailing 1s in the binary expansion of [num], the number of elements that have already gone into the accumulator. The accumulator is in ascending order of size, so the next element to combine with is always the head of the list. *) let rec step_accum num acc x = if num land 1 = 0 then x :: acc else ( match acc with | [] -> assert false (* New elements from later in the input list go on the front of the accumulator, so the accumulator is in reverse order wrt the original list order, hence [f y x] instead of [f x y]. *) | y :: ys -> step_accum (num asr 1) ys (f y x)) in (* Experimentally, inlining [foldi] and unrolling this loop a few times can reduce runtime down to a third and allocation to 1/16th or so in the microbenchmarks below. However, in most use cases [f] is likely to be expensive (otherwise why do you care about the order of reduction?) so the overhead of this function itself doesn't really matter. If you come up with a use-case where it does, then that's something you might want to try: see hg log -pr 49ef065f429d. *) match foldi l ~init:[] ~f:step_accum with | [] -> None | x :: xs -> Some (fold xs ~init:x ~f:(fun x y -> f y x)) ;; let reduce_balanced_exn l ~f = match reduce_balanced l ~f with | None -> invalid_arg "List.reduce_balanced_exn" | Some v -> v ;; let groupi l ~break = let groups = foldi l ~init:[] ~f:(fun i acc x -> match acc with | [] -> [ [ x ] ] | current_group :: tl -> if break i (hd_exn current_group) x then [ x ] :: current_group :: tl (* start new group *) else (x :: current_group) :: tl) (* extend current group *) in match groups with | [] -> [] | l -> rev_map l ~f:rev ;; let group l ~break = groupi l ~break:(fun _ x y -> break x y) [@nontail] let sort_and_group l ~compare = l |> stable_sort ~compare |> group ~break:(fun x y -> compare x y <> 0) ;; let concat_map l ~f:(f [@local]) = let rec aux acc = function | [] -> rev acc | hd :: tl -> aux (rev_append (f hd) acc) tl in let res = aux [] l in res ;; let concat_mapi l ~f = let rec aux cont acc = function | [] -> rev acc | hd :: tl -> aux (cont + 1) (rev_append (f cont hd) acc) tl in aux 0 [] l [@nontail] ;; let merge l1 l2 ~compare = let rec loop acc l1 l2 = match l1, l2 with | [], l2 -> rev_append acc l2 | l1, [] -> rev_append acc l1 | h1 :: t1, h2 :: t2 -> if compare h1 h2 <= 0 then loop (h1 :: acc) t1 l2 else loop (h2 :: acc) l1 t2 in loop [] l1 l2 [@nontail] ;; module Cartesian_product = struct (* We are explicit about what we export from functors so that we don't accidentally rebind more efficient list-specific functions. *) let bind = concat_map let map = map let map2 a b ~f = concat_map a ~f:(fun x -> map b ~f:(fun y -> f x y)) let return x = [ x ] let ( >>| ) = ( >>| ) let ( >>= ) t (f [@local]) = bind t ~f open struct module Applicative = Applicative.Make_using_map2 (struct type 'a t = 'a list let return = return let map = `Custom map let map2 = map2 end) module Monad = Monad.Make (struct type 'a t = 'a list let return = return let map = `Custom map let bind = bind end) end let all = Monad.all let all_unit = Monad.all_unit let ignore_m = Monad.ignore_m let join = Monad.join module Monad_infix = struct let ( >>| ) = ( >>| ) let ( >>= ) = ( >>= ) end let apply = Applicative.apply let both = Applicative.both let map3 = Applicative.map3 let ( <*> ) = Applicative.( <*> ) let ( *> ) = Applicative.( *> ) let ( <* ) = Applicative.( <* ) module Applicative_infix = struct let ( >>| ) = ( >>| ) let ( <*> ) = Applicative.( <*> ) let ( *> ) = Applicative.( *> ) let ( <* ) = Applicative.( <* ) end module Let_syntax = struct let return = return let ( >>| ) = ( >>| ) let ( >>= ) = ( >>= ) module Let_syntax = struct let return = return let bind = bind let map = map let both = both module Open_on_rhs = struct end end end end include (Cartesian_product : Monad.S_local with type 'a t := 'a t) (** returns final element of list *) let rec last_exn list = match list with | [ x ] -> x | _ :: tl -> last_exn tl | [] -> invalid_arg "List.last" ;; (** optionally returns final element of list *) let rec last list = match list with | [ x ] -> Some x | _ :: tl -> last tl | [] -> None ;; let rec is_prefix list ~prefix ~equal = match prefix with | [] -> true | hd :: tl -> (match list with | [] -> false | hd' :: tl' -> equal hd hd' && is_prefix tl' ~prefix:tl ~equal) ;; let find_consecutive_duplicate t ~equal = match t with | [] -> None | a1 :: t -> let rec loop a1 t = match t with | [] -> None | a2 :: t -> if equal a1 a2 then Some (a1, a2) else loop a2 t in loop a1 t [@nontail] ;; (* returns list without adjacent duplicates *) let remove_consecutive_duplicates ?(which_to_keep = `Last) list ~equal = let rec loop to_keep accum = function | [] -> to_keep :: accum | hd :: tl -> if equal hd to_keep then ( let to_keep = match which_to_keep with | `First -> to_keep | `Last -> hd in loop to_keep accum tl) else loop hd (to_keep :: accum) tl in match list with | [] -> [] | hd :: tl -> rev (loop hd [] tl) ;; (** returns sorted version of list with duplicates removed *) let dedup_and_sort list ~compare = match list with | [] | [ _ ] -> list (* performance hack *) | _ -> let equal x x' = compare x x' = 0 in let sorted = sort ~compare list in remove_consecutive_duplicates ~equal sorted [@nontail] ;; let find_a_dup l ~compare = let sorted = sort l ~compare in let rec loop l = match l with | [] | [ _ ] -> None | hd1 :: (hd2 :: _ as tl) -> if compare hd1 hd2 = 0 then Some hd1 else loop tl in loop sorted [@nontail] ;; let contains_dup lst ~compare = match find_a_dup lst ~compare with | Some _ -> true | None -> false ;; let find_all_dups l ~compare = (* We add this reversal, so we can skip a [rev] at the end. We could skip [rev] anyway since we don not give any ordering guarantees, but it is nice to get results in natural order. *) let compare a b = compare b a in let sorted = sort ~compare l in (* Walk the list and record the first of each consecutive run of identical elements *) let rec loop sorted prev ~already_recorded acc = match sorted with | [] -> acc | hd :: tl -> if compare prev hd <> 0 then loop tl hd ~already_recorded:false acc else if already_recorded then loop tl hd ~already_recorded:true acc else loop tl hd ~already_recorded:true (hd :: acc) in match sorted with | [] -> [] | hd :: tl -> loop tl hd ~already_recorded:false [] [@nontail] ;; let rec all_equal_to t v ~equal = match t with | [] -> true | x :: xs -> equal x v && all_equal_to xs v ~equal ;; let all_equal t ~equal = match t with | [] -> None | x :: xs -> if all_equal_to xs x ~equal then Some x else None ;; let count t ~f = Container.count ~fold t ~f let sum m t ~f = Container.sum ~fold m t ~f let min_elt t ~compare = Container.min_elt ~fold t ~compare let max_elt t ~compare = Container.max_elt ~fold t ~compare let counti t ~f = foldi t ~init:0 ~f:(fun idx count a -> if f idx a then count + 1 else count) [@nontail] ;; let init n ~f = if n < 0 then invalid_argf "List.init %d" n (); let rec loop i accum = assert (i >= 0); if i = 0 then accum else loop (i - 1) (f (i - 1) :: accum) in loop n [] [@nontail] ;; let rev_filter_map l ~f = let rec loop l accum = match l with | [] -> accum | hd :: tl -> (match f hd with | Some x -> loop tl (x :: accum) | None -> loop tl accum) in loop l [] [@nontail] ;; let filter_map l ~f = rev (rev_filter_map l ~f) let rev_filter_mapi l ~f = let rec loop i l accum = match l with | [] -> accum | hd :: tl -> (match f i hd with | Some x -> loop (i + 1) tl (x :: accum) | None -> loop (i + 1) tl accum) in loop 0 l [] [@nontail] ;; let filter_mapi l ~f = rev (rev_filter_mapi l ~f) let filter_opt l = filter_map l ~f:Fn.id let partition3_map t ~f = let rec loop t fst snd trd = match t with | [] -> rev fst, rev snd, rev trd | x :: t -> (match f x with | `Fst y -> loop t (y :: fst) snd trd | `Snd y -> loop t fst (y :: snd) trd | `Trd y -> loop t fst snd (y :: trd)) in loop t [] [] [] [@nontail] ;; let partition_tf t ~f = let f x : _ Either.t = if f x then First x else Second x in partition_map t ~f [@nontail] ;; let partition_result t = partition_map t ~f:Result.to_either module Assoc = struct type 'a key = ('a[@tag Sexplib0.Sexp_grammar.assoc_key_tag = List []]) [@@deriving_inline sexp, sexp_grammar] let key_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a key = fun _of_a__018_ -> _of_a__018_ ;; let sexp_of_key : 'a. ('a -> Sexplib0.Sexp.t) -> 'a key -> Sexplib0.Sexp.t = fun _of_a__020_ -> _of_a__020_ ;; let key_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a key Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Tagged { key = Sexplib0.Sexp_grammar.assoc_key_tag ; value = List [] ; grammar = _'a_sexp_grammar.untyped } } ;; [@@@end] type 'a value = ('a[@tag Sexplib0.Sexp_grammar.assoc_value_tag = List []]) [@@deriving_inline sexp, sexp_grammar] let value_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a value = fun _of_a__021_ -> _of_a__021_ ;; let sexp_of_value : 'a. ('a -> Sexplib0.Sexp.t) -> 'a value -> Sexplib0.Sexp.t = fun _of_a__023_ -> _of_a__023_ ;; let value_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a value Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Tagged { key = Sexplib0.Sexp_grammar.assoc_value_tag ; value = List [] ; grammar = _'a_sexp_grammar.untyped } } ;; [@@@end] type ('a, 'b) t = (('a key * 'b value) list[@tag Sexplib0.Sexp_grammar.assoc_tag = List []]) [@@deriving_inline sexp, sexp_grammar] let t_of_sexp : 'a 'b. (Sexplib0.Sexp.t -> 'a) -> (Sexplib0.Sexp.t -> 'b) -> Sexplib0.Sexp.t -> ('a, 'b) t = let error_source__032_ = "list.ml.Assoc.t" in fun _of_a__024_ _of_b__025_ x__033_ -> list_of_sexp (function | Sexplib0.Sexp.List [ arg0__027_; arg1__028_ ] -> let res0__029_ = key_of_sexp _of_a__024_ arg0__027_ and res1__030_ = value_of_sexp _of_b__025_ arg1__028_ in res0__029_, res1__030_ | sexp__031_ -> Sexplib0.Sexp_conv_error.tuple_of_size_n_expected error_source__032_ 2 sexp__031_) x__033_ ;; let sexp_of_t : 'a 'b. ('a -> Sexplib0.Sexp.t) -> ('b -> Sexplib0.Sexp.t) -> ('a, 'b) t -> Sexplib0.Sexp.t = fun _of_a__034_ _of_b__035_ x__040_ -> sexp_of_list (fun (arg0__036_, arg1__037_) -> let res0__038_ = sexp_of_key _of_a__034_ arg0__036_ and res1__039_ = sexp_of_value _of_b__035_ arg1__037_ in Sexplib0.Sexp.List [ res0__038_; res1__039_ ]) x__040_ ;; let t_sexp_grammar : 'a 'b. 'a Sexplib0.Sexp_grammar.t -> 'b Sexplib0.Sexp_grammar.t -> ('a, 'b) t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar _'b_sexp_grammar -> { untyped = Tagged { key = Sexplib0.Sexp_grammar.assoc_tag ; value = List [] ; grammar = (list_sexp_grammar { untyped = List (Cons ( (key_sexp_grammar _'a_sexp_grammar).untyped , Cons ((value_sexp_grammar _'b_sexp_grammar).untyped, Empty) )) }) .untyped } } ;; [@@@end] let pair_of_group = function | [] -> assert false | (k, _) :: _ as list -> k, map list ~f:snd ;; let group alist ~equal = group alist ~break:(fun (x, _) (y, _) -> not (equal x y)) |> map ~f:pair_of_group ;; let sort_and_group alist ~compare = sort_and_group alist ~compare:(fun (x, _) (y, _) -> compare x y) |> map ~f:pair_of_group ;; let find t ~equal key = match find t ~f:(fun (key', _) -> equal key key') with | None -> None | Some x -> Some (snd x) ;; let find_exn = let not_found = Not_found_s (Atom "List.Assoc.find_exn: not found") in let find_exn t ~equal key = match find t key ~equal with | None -> raise not_found | Some value -> value in (* named to preserve symbol in compiled binary *) find_exn ;; let mem t ~equal key = match find t ~equal key with | None -> false | Some _ -> true ;; let remove t ~equal key = filter t ~f:(fun (key', _) -> not (equal key key')) [@nontail] let add t ~equal key value = (* the remove doesn't change the map semantics, but keeps the list small *) (key, value) :: remove t ~equal key ;; let inverse t = map t ~f:(fun (x, y) -> y, x) let map t ~f = map t ~f:(fun (key, value) -> key, f value) [@nontail] end let sub l ~pos ~len = (* We use [pos > length l - len] rather than [pos + len > length l] to avoid the possibility of overflow. *) if pos < 0 || len < 0 || pos > length l - len then invalid_arg "List.sub"; rev (foldi l ~init:[] ~f:(fun i acc el -> if i >= pos && i < pos + len then el :: acc else acc)) ;; let split_n t_orig n = if n <= 0 then [], t_orig else ( let rec loop n t accum = if n = 0 then rev accum, t else ( match t with | [] -> t_orig, [] (* in this case, t_orig = rev accum *) | hd :: tl -> loop (n - 1) tl (hd :: accum)) in loop n t_orig []) ;; (* copied from [split_n] to avoid allocating a tuple *) let take t_orig n = if n <= 0 then [] else ( let rec loop n t accum = if n = 0 then rev accum else ( match t with | [] -> t_orig | hd :: tl -> loop (n - 1) tl (hd :: accum)) in loop n t_orig []) ;; let rec drop t n = match t with | _ :: tl when n > 0 -> drop tl (n - 1) | t -> t ;; let chunks_of l ~length = if length <= 0 then invalid_argf "List.chunks_of: Expected length > 0, got %d" length (); let rec aux of_length acc l = match l with | [] -> rev acc | _ :: _ -> let sublist, l = split_n l length in aux of_length (sublist :: acc) l in aux length [] l ;; let split_while xs ~f = let rec loop acc = function | hd :: tl when f hd -> loop (hd :: acc) tl | t -> rev acc, t in loop [] xs [@nontail] ;; (* copied from [split_while] to avoid allocating a tuple *) let take_while xs ~f = let rec loop acc = function | hd :: tl when f hd -> loop (hd :: acc) tl | _ -> rev acc in loop [] xs [@nontail] ;; let rec drop_while t ~f = match t with | hd :: tl when f hd -> drop_while tl ~f | t -> t ;; let drop_last t = match rev t with | [] -> None | _ :: lst -> Some (rev lst) ;; let drop_last_exn t = match drop_last t with | None -> failwith "List.drop_last_exn: empty list" | Some lst -> lst ;; let cartesian_product list1 list2 = if is_empty list2 then [] else ( let rec loop l1 l2 accum = match l1 with | [] -> accum | hd :: tl -> loop tl l2 (rev_append (map ~f:(fun x -> hd, x) l2) accum) in rev (loop list1 list2 [])) ;; let concat l = fold_right l ~init:[] ~f:append let concat_no_order l = fold l ~init:[] ~f:(fun acc l -> rev_append l acc) let cons x l = x :: l let is_sorted l ~compare = let rec loop l = match l with | [] | [ _ ] -> true | x1 :: (x2 :: _ as rest) -> compare x1 x2 <= 0 && loop rest in loop l [@nontail] ;; let is_sorted_strictly l ~compare = let rec loop l = match l with | [] | [ _ ] -> true | x1 :: (x2 :: _ as rest) -> compare x1 x2 < 0 && loop rest in loop l [@nontail] ;; module Infix = struct let ( @ ) = append end let permute ?(random_state = Random.State.default) list = match list with (* special cases to speed things up in trivial cases *) | [] | [ _ ] -> list | [ x; y ] -> if Random.State.bool random_state then [ y; x ] else list | _ -> let arr = Array.of_list list in Array_permute.permute arr ~random_state; Array.to_list arr ;; let random_element_exn ?(random_state = Random.State.default) list = if is_empty list then failwith "List.random_element_exn: empty list" else nth_exn list (Random.State.int random_state (length list)) ;; let random_element ?(random_state = Random.State.default) list = try Some (random_element_exn ~random_state list) with | _ -> None ;; let rec compare cmp a b = match a, b with | [], [] -> 0 | [], _ -> -1 | _, [] -> 1 | x :: xs, y :: ys -> let n = cmp x y in if n = 0 then compare cmp xs ys else n ;; let hash_fold_t = hash_fold_list let equal_local ((equal : _ -> _ -> _) [@local]) t1 t2 = let rec loop ~equal t1 t2 = match t1, t2 with | [], [] -> true | x1 :: t1, x2 :: t2 -> equal x1 x2 && loop ~equal t1 t2 | _ -> false in loop ~equal t1 t2 ;; let equal : 'a. ('a -> 'a -> bool) -> 'a t -> 'a t -> bool = fun f x y -> equal_local f x y ;; let transpose = let rec split_off_first_column t column_acc trimmed found_empty = match t with | [] -> column_acc, trimmed, found_empty | [] :: tl -> split_off_first_column tl column_acc trimmed true | (x :: xs) :: tl -> split_off_first_column tl (x :: column_acc) (xs :: trimmed) found_empty in let split_off_first_column rows = split_off_first_column rows [] [] false in let rec loop rows columns do_rev = match split_off_first_column rows with | [], [], _ -> Some (rev columns) | column, trimmed_rows, found_empty -> if found_empty then None else ( let column = if do_rev then rev column else column in loop trimmed_rows (column :: columns) (not do_rev)) in fun t -> loop t [] true ;; exception Transpose_got_lists_of_different_lengths of int list [@@deriving_inline sexp] let () = Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Transpose_got_lists_of_different_lengths] (function | Transpose_got_lists_of_different_lengths arg0__041_ -> let res0__042_ = sexp_of_list sexp_of_int arg0__041_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "list.ml.Transpose_got_lists_of_different_lengths" ; res0__042_ ] | _ -> assert false) ;; [@@@end] let transpose_exn l = match transpose l with | Some l -> l | None -> raise (Transpose_got_lists_of_different_lengths (map l ~f:length)) ;; let intersperse t ~sep = match t with | [] -> [] | x :: xs -> x :: fold_right xs ~init:[] ~f:(fun y acc -> sep :: y :: acc) ;; let fold_result t ~init ~f = Container.fold_result ~fold ~init ~f t let fold_until t ~init ~f ~finish = Container.fold_until ~fold ~init ~f t ~finish let is_suffix list ~suffix ~equal:((equal_elt : _ -> _ -> _) [@local]) = let list_len = length list in let suffix_len = length suffix in list_len >= suffix_len && equal_local equal_elt (drop list (list_len - suffix_len)) suffix ;; base-0.16.3/src/list.mli000066400000000000000000000513261446274340700150020ustar00rootroot00000000000000(** Immutable, singly-linked lists, giving fast access to the front of the list, and slow (i.e., O(n)) access to the back of the list. The comparison functions on lists are lexicographic. *) open! Import type 'a t = 'a list [@@deriving_inline compare, globalize, hash, sexp, sexp_grammar] include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t val globalize : (('a[@ocaml.local]) -> 'a) -> ('a t[@ocaml.local]) -> 'a t include Ppx_hash_lib.Hashable.S1 with type 'a t := 'a t include Sexplib0.Sexpable.S1 with type 'a t := 'a t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] include Indexed_container.S1_with_creators with type 'a t := 'a t include Invariant_intf.S1 with type 'a t := 'a t (** Implements cartesian-product behavior for [map] and [bind]. **) module Cartesian_product : sig include Applicative.S with type 'a t := 'a t include Monad.S_local with type 'a t := 'a t end (** The monad portion of [Cartesian_product] is re-exported at top level. *) include Monad.S_local with type 'a t := 'a t (** [Or_unequal_lengths] is used for functions that take multiple lists and that only make sense if all the lists have the same length, e.g., [iter2], [map3]. Such functions check the list lengths prior to doing anything else, and return [Unequal_lengths] if not all the lists have the same length. *) module Or_unequal_lengths : sig type 'a t = | Ok of 'a | Unequal_lengths [@@deriving_inline compare, sexp_of] include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t [@@@end] end val nth : 'a t -> int -> 'a option (** Return the [n]-th element of the given list. The first element (head of the list) is at position 0. Raise if the list is too short or [n] is negative. *) val nth_exn : 'a t -> int -> 'a (** List reversal. *) val rev : 'a t -> 'a t (** [rev_append l1 l2] reverses [l1] and concatenates it to [l2]. This is equivalent to [(]{!List.rev}[ l1) @ l2], but [rev_append] is more efficient. *) val rev_append : 'a t -> 'a t -> 'a t (** [unordered_append l1 l2] has the same elements as [l1 @ l2], but in some unspecified order. Generally takes time proportional to length of first list, but is O(1) if either list is empty. *) val unordered_append : 'a t -> 'a t -> 'a t (** [rev_map l ~f] gives the same result as {!List.rev}[ (]{!ListLabels.map}[ f l)], but is more efficient. *) val rev_map : 'a t -> f:(('a -> 'b)[@local]) -> 'b t (** [iter2 [a1; ...; an] [b1; ...; bn] ~f] calls in turn [f a1 b1; ...; f an bn]. The exn version will raise if the two lists have different lengths. *) val iter2_exn : 'a t -> 'b t -> f:(('a -> 'b -> unit)[@local]) -> unit val iter2 : 'a t -> 'b t -> f:(('a -> 'b -> unit)[@local]) -> unit Or_unequal_lengths.t (** [rev_map2_exn l1 l2 ~f] gives the same result as [List.rev (List.map2_exn l1 l2 ~f)], but is more efficient. *) val rev_map2_exn : 'a t -> 'b t -> f:(('a -> 'b -> 'c)[@local]) -> 'c t val rev_map2 : 'a t -> 'b t -> f:(('a -> 'b -> 'c)[@local]) -> 'c t Or_unequal_lengths.t (** [fold2 ~f ~init:a [b1; ...; bn] [c1; ...; cn]] is [f (... (f (f a b1 c1) b2 c2) ...) bn cn]. The exn version will raise if the two lists have different lengths. *) val fold2_exn : 'a t -> 'b t -> init:'acc -> f:(('acc -> 'a -> 'b -> 'acc)[@local]) -> 'acc val fold2 : 'a t -> 'b t -> init:'acc -> f:(('acc -> 'a -> 'b -> 'acc)[@local]) -> 'acc Or_unequal_lengths.t (** [fold_right2 ~f [a1; ...; an] [b1; ...; bn] ~init:c] is [f a1 b1 (f a2 b2 (... (f an bn c) ...))]. The exn version will raise if the two lists have different lengths. *) val fold_right2_exn : 'a t -> 'b t -> f:(('a -> 'b -> 'acc -> 'acc)[@local]) -> init:'acc -> 'acc val fold_right2 : 'a t -> 'b t -> f:(('a -> 'b -> 'acc -> 'acc)[@local]) -> init:'acc -> 'acc Or_unequal_lengths.t (** Like {!List.for_all}, but for a two-argument predicate. The exn version will raise if the two lists have different lengths. *) val for_all2_exn : 'a t -> 'b t -> f:(('a -> 'b -> bool)[@local]) -> bool val for_all2 : 'a t -> 'b t -> f:(('a -> 'b -> bool)[@local]) -> bool Or_unequal_lengths.t (** Like {!List.exists}, but for a two-argument predicate. The exn version will raise if the two lists have different lengths. *) val exists2_exn : 'a t -> 'b t -> f:(('a -> 'b -> bool)[@local]) -> bool val exists2 : 'a t -> 'b t -> f:(('a -> 'b -> bool)[@local]) -> bool Or_unequal_lengths.t (** Like [filter], but reverses the order of the input list. *) val rev_filter : 'a t -> f:(('a -> bool)[@local]) -> 'a t val partition3_map : 'a t -> f:(('a -> [ `Fst of 'b | `Snd of 'c | `Trd of 'd ])[@local]) -> 'b t * 'c t * 'd t (** [partition_result l] returns a pair of lists [(l1, l2)], where [l1] is the list of all [Ok] elements in [l] and [l2] is the list of all [Error] elements. The order of elements in the input list is preserved. *) val partition_result : ('ok, 'error) Result.t t -> 'ok t * 'error t (** [split_n \[e1; ...; em\] n] is [(\[e1; ...; en\], \[en+1; ...; em\])]. - If [n > m], [(\[e1; ...; em\], \[\])] is returned. - If [n < 0], [(\[\], \[e1; ...; em\])] is returned. *) val split_n : 'a t -> int -> 'a t * 'a t (** Sort a list in increasing order according to a comparison function. The comparison function must return 0 if its arguments compare as equal, a positive integer if the first is greater, and a negative integer if the first is smaller (see [Array.sort] for a complete specification). For example, {!Poly.compare} is a suitable comparison function. The current implementation uses Merge Sort. It runs in linear heap space and logarithmic stack space. Presently, the sort is stable, meaning that two equal elements in the input will be in the same order in the output. *) val sort : 'a t -> compare:('a -> 'a -> int) -> 'a t (** Like [sort], but guaranteed to be stable. *) val stable_sort : 'a t -> compare:('a -> 'a -> int) -> 'a t (** Merges two lists: assuming that [l1] and [l2] are sorted according to the comparison function [compare], [merge compare l1 l2] will return a sorted list containing all the elements of [l1] and [l2]. If several elements compare equal, the elements of [l1] will be before the elements of [l2]. *) val merge : 'a t -> 'a t -> compare:(('a -> 'a -> int)[@local]) -> 'a t val hd : 'a t -> 'a option val tl : 'a t -> 'a t option (** Returns the first element of the given list. Raises if the list is empty. *) val hd_exn : 'a t -> 'a (** Returns the given list without its first element. Raises if the list is empty. *) val tl_exn : 'a t -> 'a t (** Like [find_exn], but passes the index as an argument. *) val findi_exn : 'a t -> f:((int -> 'a -> bool)[@local]) -> int * 'a (** [find_exn t ~f] returns the first element of [t] that satisfies [f]. It raises [Stdlib.Not_found] or [Not_found_s] if there is no such element. *) val find_exn : 'a t -> f:(('a -> bool)[@local]) -> 'a (** Returns the first evaluation of [f] that returns [Some]. Raises [Stdlib.Not_found] or [Not_found_s] if [f] always returns [None]. *) val find_map_exn : 'a t -> f:(('a -> 'b option)[@local]) -> 'b (** Like [find_map_exn], but passes the index as an argument. *) val find_mapi_exn : 'a t -> f:((int -> 'a -> 'b option)[@local]) -> 'b (** [folding_map] is a version of [map] that threads an accumulator through calls to [f]. *) val folding_map : 'a t -> init:'acc -> f:(('acc -> 'a -> 'acc * 'b)[@local]) -> 'b t val folding_mapi : 'a t -> init:'acc -> f:((int -> 'acc -> 'a -> 'acc * 'b)[@local]) -> 'b t (** [fold_map] is a combination of [fold] and [map] that threads an accumulator through calls to [f]. *) val fold_map : 'a t -> init:'acc -> f:(('acc -> 'a -> 'acc * 'b)[@local]) -> 'acc * 'b t val fold_mapi : 'a t -> init:'acc -> f:((int -> 'acc -> 'a -> 'acc * 'b)[@local]) -> 'acc * 'b t (** [map2 [a1; ...; an] [b1; ...; bn] ~f] is [[f a1 b1; ...; f an bn]]. The exn version will raise if the two lists have different lengths. *) val map2_exn : 'a t -> 'b t -> f:(('a -> 'b -> 'c)[@local]) -> 'c t val map2 : 'a t -> 'b t -> f:(('a -> 'b -> 'c)[@local]) -> 'c t Or_unequal_lengths.t (** Analogous to [rev_map2]. *) val rev_map3_exn : 'a t -> 'b t -> 'c t -> f:(('a -> 'b -> 'c -> 'd)[@local]) -> 'd t val rev_map3 : 'a t -> 'b t -> 'c t -> f:(('a -> 'b -> 'c -> 'd)[@local]) -> 'd t Or_unequal_lengths.t (** Analogous to [map2]. *) val map3_exn : 'a t -> 'b t -> 'c t -> f:(('a -> 'b -> 'c -> 'd)[@local]) -> 'd t val map3 : 'a t -> 'b t -> 'c t -> f:(('a -> 'b -> 'c -> 'd)[@local]) -> 'd t Or_unequal_lengths.t (** [rev_map_append l1 l2 ~f] reverses [l1] mapping [f] over each element, and appends the result to the front of [l2]. *) val rev_map_append : 'a t -> 'b t -> f:(('a -> 'b)[@local]) -> 'b t (** [fold_right [a1; ...; an] ~f ~init:b] is [f a1 (f a2 (... (f an b) ...))]. *) val fold_right : 'a t -> f:(('a -> 'acc -> 'acc)[@local]) -> init:'acc -> 'acc (** [fold_left] is the same as {!Container.S1.fold}, and one should always use [fold] rather than [fold_left], except in functors that are parameterized over a more general signature where this equivalence does not hold. *) val fold_left : 'a t -> init:'acc -> f:(('acc -> 'a -> 'acc)[@local]) -> 'acc (** Transform a list of pairs into a pair of lists: [unzip [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])]. *) val unzip : ('a * 'b) t -> 'a t * 'b t val unzip3 : ('a * 'b * 'c) t -> 'a t * 'b t * 'c t (** Transform a pair of lists into an (optional) list of pairs: [zip [a1; ...; an] [b1; ...; bn]] is [[(a1,b1); ...; (an,bn)]]. Returns [Unequal_lengths] if the two lists have different lengths. *) val zip : 'a t -> 'b t -> ('a * 'b) t Or_unequal_lengths.t val zip_exn : 'a t -> 'b t -> ('a * 'b) t val rev_mapi : 'a t -> f:((int -> 'a -> 'b)[@local]) -> 'b t (** [reduce_exn [a1; ...; an] ~f] is [f (... (f (f a1 a2) a3) ...) an]. It fails on the empty list. Tail recursive. *) val reduce_exn : 'a t -> f:(('a -> 'a -> 'a)[@local]) -> 'a val reduce : 'a t -> f:(('a -> 'a -> 'a)[@local]) -> 'a option (** [reduce_balanced] returns the same value as [reduce] when [f] is associative, but differs in that the tree of nested applications of [f] has logarithmic depth. This is useful when your ['a] grows in size as you reduce it and [f] becomes more expensive with bigger inputs. For example, [reduce_balanced ~f:(^)] takes [n*log(n)] time, while [reduce ~f:(^)] takes quadratic time. *) val reduce_balanced : 'a t -> f:(('a -> 'a -> 'a)[@local]) -> 'a option val reduce_balanced_exn : 'a t -> f:(('a -> 'a -> 'a)[@local]) -> 'a (** [group l ~break] returns a list of lists (i.e., groups) whose concatenation is equal to the original list. Each group is broken where [break] returns true on a pair of successive elements. Example: {[ group ~break:(<>) ['M';'i';'s';'s';'i';'s';'s';'i';'p';'p';'i'] -> [['M'];['i'];['s';'s'];['i'];['s';'s'];['i'];['p';'p'];['i']] ]} *) val group : 'a t -> break:(('a -> 'a -> bool)[@local]) -> 'a t t (** This is just like [group], except that you get the index in the original list of the current element along with the two elements. Example, group the chars of ["Mississippi"] into triples: {[ groupi ~break:(fun i _ _ -> i mod 3 = 0) ['M';'i';'s';'s';'i';'s';'s';'i';'p';'p';'i'] -> [['M'; 'i'; 's']; ['s'; 'i'; 's']; ['s'; 'i'; 'p']; ['p'; 'i']] ]} *) val groupi : 'a t -> break:((int -> 'a -> 'a -> bool)[@local]) -> 'a t t (** Group equal elements into the same buckets. Sorting is stable. *) val sort_and_group : 'a t -> compare:('a -> 'a -> int) -> 'a t t (** [chunks_of l ~length] returns a list of lists whose concatenation is equal to the original list. Every list has [length] elements, except for possibly the last list, which may have fewer. [chunks_of] raises if [length <= 0]. *) val chunks_of : 'a t -> length:int -> 'a t t (** The final element of a list. The [_exn] version raises on the empty list. *) val last : 'a t -> 'a option val last_exn : 'a t -> 'a (** [is_prefix xs ~prefix] returns [true] if [xs] starts with [prefix]. *) val is_prefix : 'a t -> prefix:'a t -> equal:(('a -> 'a -> bool)[@local]) -> bool (** [is_suffix xs ~suffix] returns [true] if [xs] ends with [suffix]. *) val is_suffix : 'a t -> suffix:'a t -> equal:(('a -> 'a -> bool)[@local]) -> bool (** [find_consecutive_duplicate t ~equal] returns the first pair of consecutive elements [(a1, a2)] in [t] such that [equal a1 a2]. They are returned in the same order as they appear in [t]. [equal] need not be an equivalence relation; it is simply used as a predicate on consecutive elements. *) val find_consecutive_duplicate : 'a t -> equal:(('a -> 'a -> bool)[@local]) -> ('a * 'a) option (** Returns the given list with consecutive duplicates removed. The relative order of the other elements is unaffected. The element kept from a run of duplicates is determined by [which_to_keep]. *) val remove_consecutive_duplicates : ?which_to_keep:[ `First | `Last ] (** default = `Last *) -> 'a t -> equal:(('a -> 'a -> bool)[@local]) -> 'a t (** Returns the given list with duplicates removed and in sorted order. *) val dedup_and_sort : 'a t -> compare:('a -> 'a -> int) -> 'a t (** [find_a_dup] returns a duplicate from the list (with no guarantees about which duplicate you get), or [None] if there are no dups. *) val find_a_dup : 'a t -> compare:('a -> 'a -> int) -> 'a option (** Returns true if there are any two elements in the list which are the same. O(n log n) time complexity. *) val contains_dup : 'a t -> compare:('a -> 'a -> int) -> bool (** [find_all_dups] returns a list of all elements that occur more than once, with no guarantees about order. O(n log n) time complexity. *) val find_all_dups : 'a t -> compare:('a -> 'a -> int) -> 'a list (** [all_equal] returns a single element of the list that is equal to all other elements, or [None] if no such element exists. *) val all_equal : 'a t -> equal:(('a -> 'a -> bool)[@local]) -> 'a option (** [range ?stride ?start ?stop start_i stop_i] is the list of integers from [start_i] to [stop_i], stepping by [stride]. If [stride] < 0 then we need [start_i] > [stop_i] for the result to be nonempty (or [start_i] = [stop_i] in the case where both bounds are inclusive). *) val range : ?stride:int (** default = 1 *) -> ?start:[ `inclusive | `exclusive ] (** default = `inclusive *) -> ?stop:[ `inclusive | `exclusive ] (** default = `exclusive *) -> int -> int -> int t (** [range'] is analogous to [range] for general start/stop/stride types. [range'] raises if [stride x] returns [x] or if the direction that [stride x] moves [x] changes from one call to the next. *) val range' : compare:(('a -> 'a -> int)[@local]) -> stride:(('a -> 'a)[@local]) -> ?start:[ `inclusive | `exclusive ] (** default = `inclusive *) -> ?stop:[ `inclusive | `exclusive ] (** default = `exclusive *) -> 'a -> 'a -> 'a t (** [rev_filter_map l ~f] is the reversed sublist of [l] containing only elements for which [f] returns [Some e]. *) val rev_filter_map : 'a t -> f:(('a -> 'b option)[@local]) -> 'b t (** rev_filter_mapi is just like [rev_filter_map], but it also passes in the index of each element as the first argument to the mapped function. Tail-recursive. *) val rev_filter_mapi : 'a t -> f:((int -> 'a -> 'b option)[@local]) -> 'b t (** [filter_opt l] is the sublist of [l] containing only elements which are [Some e]. In other words, [filter_opt l] = [filter_map ~f:Fn.id l]. *) val filter_opt : 'a option t -> 'a t (** Interpret a list of (key, value) pairs as a map in which only the first occurrence of a key affects the semantics, i.e.: {[List.Assoc.xxx alist ...args... ]} is always the same as (or at least sort of isomorphic to): {[ Map.xxx (alist |> Map.of_alist_multi |> Map.map ~f:List.hd) ...args... ]} *) module Assoc : sig type ('a, 'b) t = ('a * 'b) list [@@deriving_inline sexp, sexp_grammar] include Sexplib0.Sexpable.S2 with type ('a, 'b) t := ('a, 'b) t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'b Sexplib0.Sexp_grammar.t -> ('a, 'b) t Sexplib0.Sexp_grammar.t [@@@end] val add : ('a, 'b) t -> equal:(('a -> 'a -> bool)[@local]) -> 'a -> 'b -> ('a, 'b) t val find : ('a, 'b) t -> equal:(('a -> 'a -> bool)[@local]) -> 'a -> 'b option val find_exn : ('a, 'b) t -> equal:(('a -> 'a -> bool)[@local]) -> 'a -> 'b val mem : ('a, 'b) t -> equal:(('a -> 'a -> bool)[@local]) -> 'a -> bool val remove : ('a, 'b) t -> equal:(('a -> 'a -> bool)[@local]) -> 'a -> ('a, 'b) t val map : ('a, 'b) t -> f:(('b -> 'c)[@local]) -> ('a, 'c) t (** Bijectivity is not guaranteed because we allow a key to appear more than once. *) val inverse : ('a, 'b) t -> ('b, 'a) t (** Converts an association list with potential consecutive duplicate keys into an association list of (non-empty) lists with no (consecutive) duplicate keys. Any non-consecutive duplicate keys in the input will remain in the output. *) val group : ('a * 'b) list -> equal:(('a -> 'a -> bool)[@local]) -> ('a, 'b list) t (** Converts an association list with potential duplicate keys into an association list of (non-empty) lists with no duplicate keys. *) val sort_and_group : ('a * 'b) list -> compare:('a -> 'a -> int) -> ('a, 'b list) t end (** [sub pos len l] is the [len]-element sublist of [l], starting at [pos]. *) val sub : 'a t -> pos:int -> len:int -> 'a t (** [take l n] returns the first [n] elements of [l], or all of [l] if [n > length l]. [take l n = fst (split_n l n)]. *) val take : 'a t -> int -> 'a t (** [drop l n] returns [l] without the first [n] elements, or the empty list if [n > length l]. [drop l n] is equivalent to [snd (split_n l n)]. *) val drop : 'a t -> int -> 'a t (** [take_while l ~f] returns the longest prefix of [l] for which [f] is [true]. *) val take_while : 'a t -> f:(('a -> bool)[@local]) -> 'a t (** [drop_while l ~f] drops the longest prefix of [l] for which [f] is [true]. *) val drop_while : 'a t -> f:(('a -> bool)[@local]) -> 'a t (** [split_while xs ~f = (take_while xs ~f, drop_while xs ~f)]. *) val split_while : 'a t -> f:(('a -> bool)[@local]) -> 'a t * 'a t (** [drop_last l] drops the last element of [l], returning [None] if [l] is [empty]. *) val drop_last : 'a t -> 'a t option val drop_last_exn : 'a t -> 'a t (** Like [concat], but faster and without preserving any ordering (i.e., for lists that are essentially viewed as multi-sets). *) val concat_no_order : 'a t t -> 'a t val cons : 'a -> 'a t -> 'a t (** Returns a list with all possible pairs -- if the input lists have length [len1] and [len2], the resulting list will have length [len1 * len2]. *) val cartesian_product : 'a t -> 'b t -> ('a * 'b) t (** [permute ?random_state t] returns a permutation of [t]. [permute] side-effects [random_state] by repeated calls to [Random.State.int]. If [random_state] is not supplied, [permute] uses [Random.State.default]. *) val permute : ?random_state:Random.State.t -> 'a t -> 'a t (** [random_element ?random_state t] is [None] if [t] is empty, else it is [Some x] for some [x] chosen uniformly at random from [t]. [random_element] side-effects [random_state] by calling [Random.State.int]. If [random_state] is not supplied, [random_element] uses [Random.State.default]. *) val random_element : ?random_state:Random.State.t -> 'a t -> 'a option val random_element_exn : ?random_state:Random.State.t -> 'a t -> 'a (** [is_sorted t ~compare] returns [true] iff for all adjacent [a1; a2] in [t], [compare a1 a2 <= 0]. [is_sorted_strictly] is similar, except it uses [<] instead of [<=]. *) val is_sorted : 'a t -> compare:(('a -> 'a -> int)[@local]) -> bool val is_sorted_strictly : 'a t -> compare:(('a -> 'a -> int)[@local]) -> bool val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool module Infix : sig val ( @ ) : 'a t -> 'a t -> 'a t end (** [transpose m] transposes the rows and columns of the matrix [m], considered as either a row of column lists or (dually) a column of row lists. Example: {[transpose [[1;2;3];[4;5;6]] = [[1;4];[2;5];[3;6]]]} On non-empty rectangular matrices, [transpose] is an involution (i.e., [transpose (transpose m) = m]). Transpose returns [None] when called on lists of lists with non-uniform lengths. *) val transpose : 'a t t -> 'a t t option (** [transpose_exn] transposes the rows and columns of its argument, throwing an exception if the list is not rectangular. *) val transpose_exn : 'a t t -> 'a t t (** [intersperse xs ~sep] places [sep] between adjacent elements of [xs]. For example, [intersperse [1;2;3] ~sep:0 = [1;0;2;0;3]]. *) val intersperse : 'a t -> sep:'a -> 'a t base-0.16.3/src/list0.ml000066400000000000000000000066011446274340700147050ustar00rootroot00000000000000(* [List0] defines list functions that are primitives or can be simply defined in terms of [Stdlib.List]. [List0] is intended to completely express the part of [Stdlib.List] that [Base] uses -- no other file in Base other than list0.ml should use [Stdlib.List]. [List0] has few dependencies, and so is available early in Base's build order. All Base files that need to use lists and come before [Base.List] in build order should do [module List = List0]. Defining [module List = List0] is also necessary because it prevents ocamldep from mistakenly causing a file to depend on [Base.List]. *) open! Import0 let hd_exn = Stdlib.List.hd let length = Stdlib.List.length let rev_append = Stdlib.List.rev_append let tl_exn = Stdlib.List.tl let unzip = Stdlib.List.split (* Some of these are eta expanded in order to permute parameter order to follow Base conventions. *) let rec exists t ~f:(f [@local]) = match t with | [] -> false | x :: xs -> if f x then true else exists xs ~f ;; let rec exists2_ok l1 l2 ~f:((f : _ -> _ -> _) [@local]) = match l1, l2 with | [], [] -> false | a1 :: l1, a2 :: l2 -> f a1 a2 || exists2_ok l1 l2 ~f | _, _ -> invalid_arg "List.exists2" ;; let rec fold t ~init ~f:((f : _ -> _ -> _) [@local]) = match t with | [] -> init | a :: l -> fold l ~init:(f init a) ~f ;; let rec fold2_ok l1 l2 ~init ~f:((f : _ -> _ -> _ -> _) [@local]) = match l1, l2 with | [], [] -> init | a1 :: l1, a2 :: l2 -> fold2_ok l1 l2 ~f ~init:(f init a1 a2) | _, _ -> invalid_arg "List.fold_left2" ;; let for_all t ~f:(f [@local]) = not (exists t ~f:(fun x -> not (f x))) let rec for_all2_ok l1 l2 ~f:((f : _ -> _ -> _) [@local]) = match l1, l2 with | [], [] -> true | a1 :: l1, a2 :: l2 -> f a1 a2 && for_all2_ok l1 l2 ~f | _, _ -> invalid_arg "List.for_all2" ;; let rec iter t ~f:((f : _ -> _) [@local]) = match t with | [] -> () | a :: l -> f a; iter l ~f ;; let rec iter2_ok l1 l2 ~f:((f : _ -> _ -> unit) [@local]) = match l1, l2 with | [], [] -> () | a1 :: l1, a2 :: l2 -> f a1 a2; iter2_ok l1 l2 ~f | _, _ -> invalid_arg "List.iter2" ;; let rec nontail_map t ~f:(f [@local]) = match t with | [] -> [] | x :: xs -> let y = f x in y :: nontail_map xs ~f ;; let nontail_mapi t ~f = Stdlib.List.mapi t ~f let partition t ~f = Stdlib.List.partition t ~f let rev_map = let rec rmap_f f accu = function | [] -> accu | a :: l -> rmap_f f (f a :: accu) l in fun l ~f:(f [@local]) -> rmap_f f [] l ;; let rev_map2_ok = let rec rmap2_f f accu l1 l2 = match l1, l2 with | [], [] -> accu | a1 :: l1, a2 :: l2 -> rmap2_f f (f a1 a2 :: accu) l1 l2 | _, _ -> invalid_arg "List.rev_map2" in fun l1 l2 ~f:((f : _ -> _ -> _) [@local]) -> rmap2_f f [] l1 l2 ;; let sort l ~compare = Stdlib.List.sort l ~cmp:compare let stable_sort l ~compare = Stdlib.List.stable_sort l ~cmp:compare let rev = function | ([] | [ _ ]) as res -> res | x :: y :: rest -> rev_append rest [ y; x ] ;; let fold_right l ~f:((f : _ -> _ -> _) [@local]) ~init = match l with | [] -> init (* avoid the allocation of [~f] below *) | _ -> fold ~f:(fun a b -> f b a) ~init (rev l) [@nontail] ;; let fold_right2_ok l1 l2 ~f:((f : _ -> _ -> _ -> _) [@local]) ~init = match l1, l2 with | [], [] -> init (* avoid the allocation of [~f] below *) | _, _ -> fold2_ok ~f:(fun a b c -> f b c a) ~init (rev l1) (rev l2) [@nontail] ;; base-0.16.3/src/list1.ml000066400000000000000000000005631446274340700147070ustar00rootroot00000000000000open! Import include List0 let is_empty = function | [] -> true | _ -> false ;; let partition_map t ~f:(f [@local]) = let rec loop t fst snd = match t with | [] -> rev fst, rev snd | x :: t -> (match (f x : _ Either0.t) with | First y -> loop t (y :: fst) snd | Second y -> loop t fst (y :: snd)) in loop t [] [] [@nontail] ;; base-0.16.3/src/map.ml000066400000000000000000003115511446274340700144320ustar00rootroot00000000000000(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Apache 2.0 license. See ../THIRD-PARTY.txt *) (* for details. *) (* *) (***********************************************************************) open! Import module List = List0 include Map_intf module Finished_or_unfinished = struct include Map_intf.Finished_or_unfinished (* These two functions are tested in [test_map.ml] to make sure our use of [Stdlib.Obj.magic] is correct and safe. *) let of_continue_or_stop : Continue_or_stop.t -> t = Stdlib.Obj.magic let to_continue_or_stop : t -> Continue_or_stop.t = Stdlib.Obj.magic end module Merge_element = struct include Map_intf.Merge_element let left = function | `Right _ -> None | `Left left | `Both (left, _) -> Some left ;; let right = function | `Left _ -> None | `Right right | `Both (_, right) -> Some right ;; let left_value t ~default = match t with | `Right _ -> default | `Left left | `Both (left, _) -> left ;; let right_value t ~default = match t with | `Left _ -> default | `Right right | `Both (_, right) -> right ;; let values t ~left_default ~right_default = match t with | `Left left -> left, right_default | `Right right -> left_default, right | `Both (left, right) -> left, right ;; end let with_return = With_return.with_return exception Duplicate [@@deriving_inline sexp] let () = Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Duplicate] (function | Duplicate -> Sexplib0.Sexp.Atom "map.ml.Duplicate" | _ -> assert false) ;; [@@@end] (* [With_length.t] allows us to store length information on the stack while keeping the tree global. This saves up to O(log n) blocks of heap allocation. *) module With_length : sig type 'a t = private { tree : 'a [@global] ; length : int [@global] } val with_length : 'a -> int -> ('a t[@local]) val with_length_global : 'a -> int -> 'a t val globalize : ('a t[@local]) -> 'a t end = struct type 'a t = { tree : 'a [@global] ; length : int [@global] } let with_length tree length = { tree; length } let with_length_global tree length = { tree; length } let globalize ({ tree; length } [@local]) = { tree; length } end open With_length module Tree0 = struct type ('k, 'v) t = | Empty | Leaf of 'k * 'v | Node of ('k, 'v) t * 'k * 'v * ('k, 'v) t * int type ('k, 'v) tree = ('k, 'v) t let height = function | Empty -> 0 | Leaf _ -> 1 | Node (_, _, _, _, h) -> h ;; let invariants = let in_range lower upper compare_key k = (match lower with | None -> true | Some lower -> compare_key lower k < 0) && match upper with | None -> true | Some upper -> compare_key k upper < 0 in let rec loop lower upper compare_key t = match t with | Empty -> true | Leaf (k, _) -> in_range lower upper compare_key k | Node (l, k, _, r, h) -> let hl = height l and hr = height r in abs (hl - hr) <= 2 && h = max hl hr + 1 && in_range lower upper compare_key k && loop lower (Some k) compare_key l && loop (Some k) upper compare_key r in fun t ~compare_key -> loop None None compare_key t ;; (* precondition: |height(l) - height(r)| <= 2 *) let create l x d r = let hl = height l and hr = height r in if hl = 0 && hr = 0 then Leaf (x, d) else Node (l, x, d, r, if hl >= hr then hl + 1 else hr + 1) ;; let singleton key data = Leaf (key, data) (* We must call [f] with increasing indexes, because the bin_prot reader in Core.Map needs it. *) let of_increasing_iterator_unchecked ~len ~f = let rec loop n ~f i : (_, _) t = match n with | 0 -> Empty | 1 -> let k, v = f i in Leaf (k, v) | 2 -> let kl, vl = f i in let k, v = f (i + 1) in Node (Leaf (kl, vl), k, v, Empty, 2) | 3 -> let kl, vl = f i in let k, v = f (i + 1) in let kr, vr = f (i + 2) in Node (Leaf (kl, vl), k, v, Leaf (kr, vr), 2) | n -> let left_length = n lsr 1 in let right_length = n - left_length - 1 in let left = loop left_length ~f i in let k, v = f (i + left_length) in let right = loop right_length ~f (i + left_length + 1) in create left k v right in loop len ~f 0 ;; let of_sorted_array_unchecked array ~compare_key = let array_length = Array.length array in let next = if array_length < 2 || let k0, _ = array.(0) in let k1, _ = array.(1) in compare_key k0 k1 < 0 then fun i -> array.(i) else fun i -> array.(array_length - 1 - i) in (with_length (of_increasing_iterator_unchecked ~len:array_length ~f:next) array_length) ;; let of_sorted_array array ~compare_key = match array with | [||] | [| _ |] -> Result.Ok (of_sorted_array_unchecked array ~compare_key |> globalize) | _ -> with_return (fun r -> let increasing = match compare_key (fst array.(0)) (fst array.(1)) with | 0 -> r.return (Or_error.error_string "of_sorted_array: duplicated elements") | i -> i < 0 in for i = 1 to Array.length array - 2 do match compare_key (fst array.(i)) (fst array.(i + 1)) with | 0 -> r.return (Or_error.error_string "of_sorted_array: duplicated elements") | i -> if Poly.( <> ) (i < 0) increasing then r.return (Or_error.error_string "of_sorted_array: elements are not ordered") done; Result.Ok (of_sorted_array_unchecked array ~compare_key |> globalize)) ;; (* precondition: |height(l) - height(r)| <= 3 *) let bal l x d r = let hl = height l in let hr = height r in if hl > hr + 2 then ( match l with | Empty -> invalid_arg "Map.bal" | Leaf _ -> assert false (* height(Leaf) = 1 && 1 is not larger than hr + 2 *) | Node (ll, lv, ld, lr, _) -> if height ll >= height lr then create ll lv ld (create lr x d r) else ( match lr with | Empty -> invalid_arg "Map.bal" | Leaf (lrv, lrd) -> create (create ll lv ld Empty) lrv lrd (create Empty x d r) | Node (lrl, lrv, lrd, lrr, _) -> create (create ll lv ld lrl) lrv lrd (create lrr x d r))) else if hr > hl + 2 then ( match r with | Empty -> invalid_arg "Map.bal" | Leaf _ -> assert false (* height(Leaf) = 1 && 1 is not larger than hl + 2 *) | Node (rl, rv, rd, rr, _) -> if height rr >= height rl then create (create l x d rl) rv rd rr else ( match rl with | Empty -> invalid_arg "Map.bal" | Leaf (rlv, rld) -> create (create l x d Empty) rlv rld (create Empty rv rd rr) | Node (rll, rlv, rld, rlr, _) -> create (create l x d rll) rlv rld (create rlr rv rd rr))) else create l x d r ;; let empty = Empty let is_empty = function | Empty -> true | _ -> false ;; let raise_key_already_present ~key ~sexp_of_key = Error.raise_s (Sexp.message "[Map.add_exn] got key already present" [ "key", key |> sexp_of_key ]) ;; module Add_or_set = struct type t = | Add_exn_internal | Add_exn | Set end let rec find_and_add_or_set t ~length ~key:x ~data ~compare_key ~sexp_of_key ~(add_or_set : Add_or_set.t) = match t with | Empty -> (with_length (Leaf (x, data)) (length + 1)) | Leaf (v, d) -> let c = compare_key x v in if c = 0 then ( match add_or_set with | Add_exn_internal -> (Exn.raise_without_backtrace Duplicate) | Add_exn -> (raise_key_already_present ~key:x ~sexp_of_key) | Set -> (with_length (Leaf (x, data)) length)) else if c < 0 then (with_length (Node (Leaf (x, data), v, d, Empty, 2)) (length + 1)) else (with_length (Node (Empty, v, d, Leaf (x, data), 2)) (length + 1)) | Node (l, v, d, r, h) -> let c = compare_key x v in if c = 0 then ( match add_or_set with | Add_exn_internal -> (Exn.raise_without_backtrace Duplicate) | Add_exn -> (raise_key_already_present ~key:x ~sexp_of_key) | Set -> (with_length (Node (l, x, data, r, h)) length)) else if c < 0 then ( let { tree = l; length } = find_and_add_or_set ~length ~key:x ~data l ~compare_key ~sexp_of_key ~add_or_set in (with_length (bal l v d r) length)) else ( let { tree = r; length } = find_and_add_or_set ~length ~key:x ~data r ~compare_key ~sexp_of_key ~add_or_set in (with_length (bal l v d r) length)) ;; (* specialization of [set'] for the case when [key] is less than all the existing keys *) let rec set_min key data t = match t with | Empty -> Leaf (key, data) | Leaf (v, d) -> Node (Leaf (key, data), v, d, Empty, 2) | Node (l, v, d, r, _) -> let l = set_min key data l in bal l v d r ;; (* specialization of [set'] for the case when [key] is greater than all the existing keys *) let rec set_max t key data = match t with | Empty -> Leaf (key, data) | Leaf (v, d) -> Node (Empty, v, d, Leaf (key, data), 2) | Node (l, v, d, r, _) -> let r = set_max r key data in bal l v d r ;; let add_exn t ~length ~key ~data ~compare_key ~sexp_of_key = (find_and_add_or_set t ~length ~key ~data ~compare_key ~sexp_of_key ~add_or_set:Add_exn) ;; let add_exn_internal t ~length ~key ~data ~compare_key ~sexp_of_key = (find_and_add_or_set t ~length ~key ~data ~compare_key ~sexp_of_key ~add_or_set:Add_exn_internal) ;; let set t ~length ~key ~data ~compare_key = (find_and_add_or_set t ~length ~key ~data ~compare_key ~sexp_of_key:(fun _ -> List []) ~add_or_set:Set) ;; let set' t key data ~compare_key = (set t ~length:0 ~key ~data ~compare_key).tree module Build_increasing = struct module Fragment = struct type nonrec ('k, 'v) t = { left_subtree : ('k, 'v) t ; key : 'k ; data : 'v } let singleton_to_tree_exn = function | { left_subtree = Empty; key; data } -> singleton key data | _ -> failwith "Map.singleton_to_tree_exn: not a singleton" ;; let singleton ~key ~data = { left_subtree = Empty; key; data } (* precondition: |height(l.left_subtree) - height(r)| <= 2, max_key(l) < min_key(r) *) let collapse l r = create l.left_subtree l.key l.data r (* precondition: |height(l.left_subtree) - height(r.left_subtree)| <= 2, max_key(l) < min_key(r) *) let join l r = { r with left_subtree = collapse l r.left_subtree } let max_key t = t.key end (** Build trees from singletons in a balanced way by using skew binary encoding. Each level contains trees of the same height, consecutive levels have consecutive heights. There are no gaps. The first level are single keys. *) type ('k, 'v) t = | Zero of unit (* [unit] to make pattern matching faster *) | One of ('k, 'v) t * ('k, 'v) Fragment.t | Two of ('k, 'v) t * ('k, 'v) Fragment.t * ('k, 'v) Fragment.t let empty = Zero () let add_unchecked = let rec go t x = match t with | Zero () -> One (t, x) | One (t, y) -> Two (t, y, x) | Two (t, z, y) -> One (go t (Fragment.join z y), x) in fun t ~key ~data -> go t (Fragment.singleton ~key ~data) ;; let to_tree_unchecked = let rec go t r = match t with | Zero () -> r | One (t, l) -> go t (Fragment.collapse l r) | Two (t, ll, l) -> go t (Fragment.collapse (Fragment.join ll l) r) in function | Zero () -> Empty | One (t, r) -> go t (Fragment.singleton_to_tree_exn r) | Two (t, l, r) -> go (One (t, l)) (Fragment.singleton_to_tree_exn r) ;; let max_key = function | Zero () -> None | One (_, r) | Two (_, _, r) -> Some (Fragment.max_key r) ;; end let of_increasing_sequence seq ~compare_key = with_return (fun { return } -> let { tree = builder; length } = Sequence.fold seq ~init:(with_length_global Build_increasing.empty 0) ~f:(fun { tree = builder; length } (key, data) -> match Build_increasing.max_key builder with | Some prev_key when compare_key prev_key key >= 0 -> return (Or_error.error_string "of_increasing_sequence: non-increasing key") | _ -> with_length_global (Build_increasing.add_unchecked builder ~key ~data) (length + 1)) in Ok (with_length_global (Build_increasing.to_tree_unchecked builder) length)) ;; (* Like [bal] but allows any difference in height between [l] and [r]. O(|height l - height r|) *) let rec join l k d r = match l, r with | Empty, _ -> set_min k d r | _, Empty -> set_max l k d | Leaf (lk, ld), _ -> set_min lk ld (set_min k d r) | _, Leaf (rk, rd) -> set_max (set_max l k d) rk rd | Node (ll, lk, ld, lr, lh), Node (rl, rk, rd, rr, rh) -> (* [bal] requires height difference <= 3. *) if lh > rh + 3 (* [height lr >= height r], therefore [height (join lr k d r ...)] is [height rl + 1] or [height rl] therefore the height difference with [ll] will be <= 3 *) then bal ll lk ld (join lr k d r) else if rh > lh + 3 then bal (join l k d rl) rk rd rr else bal l k d r ;; let[@inline] rec split_gen t x ~compare_key = match t with | Empty -> Empty, None, Empty | Leaf (k, d) -> let cmp = compare_key k in if cmp = 0 then Empty, Some (k, d), Empty else if cmp < 0 then Empty, None, t else t, None, Empty | Node (l, k, d, r, _) -> let cmp = compare_key k in if cmp = 0 then l, Some (k, d), r else if cmp < 0 then ( let ll, maybe, lr = split_gen l x ~compare_key in ll, maybe, join lr k d r) else ( let rl, maybe, rr = split_gen r x ~compare_key in join l k d rl, maybe, rr) ;; let split t x ~compare_key = split_gen t x ~compare_key:(fun y -> compare_key x y) (* This function does not really reinsert [x], but just arranges so that [split] produces the equivalent tree in the first place. *) let split_and_reinsert_boundary t ~into x ~compare_key = let left, boundary_opt, right = split_gen t x ~compare_key: (match into with | `Left -> fun y -> (match compare_key x y with | 0 -> 1 | res -> res) | `Right -> fun y -> (match compare_key x y with | 0 -> -1 | res -> res)) in assert (Option.is_none boundary_opt); left, right ;; let split_range t ~(lower_bound : 'a Maybe_bound.t) ~(upper_bound : 'a Maybe_bound.t) ~compare_key = if Maybe_bound.bounds_crossed ~compare:compare_key ~lower:lower_bound ~upper:upper_bound then empty, empty, empty else ( let left, mid_and_right = match lower_bound with | Unbounded -> empty, t | Incl lb -> split_and_reinsert_boundary ~into:`Right t lb ~compare_key | Excl lb -> split_and_reinsert_boundary ~into:`Left t lb ~compare_key in let mid, right = match upper_bound with | Unbounded -> mid_and_right, empty | Incl lb -> split_and_reinsert_boundary ~into:`Left mid_and_right lb ~compare_key | Excl lb -> split_and_reinsert_boundary ~into:`Right mid_and_right lb ~compare_key in left, mid, right) ;; let rec find t x ~compare_key = match t with | Empty -> None | Leaf (v, d) -> if compare_key x v = 0 then Some d else None | Node (l, v, d, r, _) -> let c = compare_key x v in if c = 0 then Some d else find (if c < 0 then l else r) x ~compare_key ;; let add_multi t ~length ~key ~data ~compare_key = let data = data :: Option.value (find t key ~compare_key) ~default:[] in (set ~length ~key ~data t ~compare_key) ;; let find_multi t x ~compare_key = match find t x ~compare_key with | None -> [] | Some l -> l ;; let find_exn = let if_not_found key ~sexp_of_key = raise (Not_found_s (List [ Atom "Map.find_exn: not found"; sexp_of_key key ])) in let rec find_exn t x ~compare_key ~sexp_of_key = match t with | Empty -> if_not_found x ~sexp_of_key | Leaf (v, d) -> if compare_key x v = 0 then d else if_not_found x ~sexp_of_key | Node (l, v, d, r, _) -> let c = compare_key x v in if c = 0 then d else find_exn (if c < 0 then l else r) x ~compare_key ~sexp_of_key in (* named to preserve symbol in compiled binary *) find_exn ;; let mem t x ~compare_key = Option.is_some (find t x ~compare_key) let rec min_elt = function | Empty -> None | Leaf (k, d) -> Some (k, d) | Node (Empty, k, d, _, _) -> Some (k, d) | Node (l, _, _, _, _) -> min_elt l ;; exception Map_min_elt_exn_of_empty_map [@@deriving_inline sexp] let () = Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Map_min_elt_exn_of_empty_map] (function | Map_min_elt_exn_of_empty_map -> Sexplib0.Sexp.Atom "map.ml.Tree0.Map_min_elt_exn_of_empty_map" | _ -> assert false) ;; [@@@end] exception Map_max_elt_exn_of_empty_map [@@deriving_inline sexp] let () = Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Map_max_elt_exn_of_empty_map] (function | Map_max_elt_exn_of_empty_map -> Sexplib0.Sexp.Atom "map.ml.Tree0.Map_max_elt_exn_of_empty_map" | _ -> assert false) ;; [@@@end] let min_elt_exn t = match min_elt t with | None -> raise Map_min_elt_exn_of_empty_map | Some v -> v ;; let rec max_elt = function | Empty -> None | Leaf (k, d) -> Some (k, d) | Node (_, k, d, Empty, _) -> Some (k, d) | Node (_, _, _, r, _) -> max_elt r ;; let max_elt_exn t = match max_elt t with | None -> raise Map_max_elt_exn_of_empty_map | Some v -> v ;; let rec remove_min_elt t = match t with | Empty -> invalid_arg "Map.remove_min_elt" | Leaf _ -> Empty | Node (Empty, _, _, r, _) -> r | Node (l, x, d, r, _) -> bal (remove_min_elt l) x d r ;; let append ~lower_part ~upper_part ~compare_key = match max_elt lower_part, min_elt upper_part with | None, _ -> `Ok upper_part | _, None -> `Ok lower_part | Some (max_lower, _), Some (min_upper, v) when compare_key max_lower min_upper < 0 -> let upper_part_without_min = remove_min_elt upper_part in `Ok (join lower_part min_upper v upper_part_without_min) | _ -> `Overlapping_key_ranges ;; let fold_range_inclusive = (* This assumes that min <= max, which is checked by the outer function. *) let rec go t ~min ~max ~init ~f ~compare_key = match t with | Empty -> init | Leaf (k, d) -> if compare_key k min < 0 || compare_key k max > 0 then (* k < min || k > max *) init else f ~key:k ~data:d init | Node (l, k, d, r, _) -> let c_min = compare_key k min in if c_min < 0 then (* if k < min, then this node and its left branch are outside our range *) go r ~min ~max ~init ~f ~compare_key else if c_min = 0 then (* if k = min, then this node's left branch is outside our range *) go r ~min ~max ~init:(f ~key:k ~data:d init) ~f ~compare_key else ( (* k > min *) let z = go l ~min ~max ~init ~f ~compare_key in let c_max = compare_key k max in (* if k > max, we're done *) if c_max > 0 then z else ( let z = f ~key:k ~data:d z in (* if k = max, then we fold in this one last value and we're done *) if c_max = 0 then z else go r ~min ~max ~init:z ~f ~compare_key)) in fun t ~min ~max ~init ~f ~compare_key -> if compare_key min max <= 0 then go t ~min ~max ~init ~f ~compare_key else init ;; let range_to_alist t ~min ~max ~compare_key = List.rev (fold_range_inclusive t ~min ~max ~init:[] ~f:(fun ~key ~data l -> (key, data) :: l) ~compare_key) ;; (* preconditions: - all elements in t1 are less than elements in t2 - |height(t1) - height(t2)| <= 2 *) let concat_unchecked t1 t2 = match t1, t2 with | Empty, t -> t | t, Empty -> t | _, _ -> let x, d = min_elt_exn t2 in bal t1 x d (remove_min_elt t2) ;; (* similar to [concat_unchecked], and balances trees of arbitrary height differences *) let concat_and_balance_unchecked t1 t2 = match t1, t2 with | Empty, t -> t | t, Empty -> t | _, _ -> let x, d = min_elt_exn t2 in join t1 x d (remove_min_elt t2) ;; exception Remove_no_op let remove t x ~length ~compare_key = let rec remove_loop t x ~length ~compare_key = match t with | Empty -> (Exn.raise_without_backtrace Remove_no_op) | Leaf (v, _) -> if compare_key x v = 0 then (with_length Empty (length - 1)) else (Exn.raise_without_backtrace Remove_no_op) | Node (l, v, d, r, _) -> let c = compare_key x v in if c = 0 then (with_length (concat_unchecked l r) (length - 1)) else if c < 0 then ( let { tree = l; length } = remove_loop l x ~length ~compare_key in (with_length (bal l v d r) length)) else ( let { tree = r; length } = remove_loop r x ~length ~compare_key in (with_length (bal l v d r) length)) in try (remove_loop t x ~length ~compare_key) with | Remove_no_op -> (with_length t length) ;; (* Use exception to avoid tree-rebuild in no-op case *) exception Change_no_op let change t key ~f ~length ~compare_key = let rec change_core t key f = match t with | Empty -> (match f None with | None -> (* equivalent to returning: Empty *) (Exn.raise_without_backtrace Change_no_op) | Some data -> (with_length (Leaf (key, data)) (length + 1))) | Leaf (v, d) -> let c = compare_key key v in if c = 0 then ( match f (Some d) with | None -> (with_length Empty (length - 1)) | Some d' -> (with_length (Leaf (v, d')) length)) else if c < 0 then ( let { tree = l; length } = change_core Empty key f in (with_length (bal l v d Empty) length)) else ( let { tree = r; length } = change_core Empty key f in (with_length (bal Empty v d r) length)) | Node (l, v, d, r, h) -> let c = compare_key key v in if c = 0 then ( match f (Some d) with | None -> (with_length (concat_unchecked l r) (length - 1)) | Some data -> (with_length (Node (l, key, data, r, h)) length)) else if c < 0 then ( let { tree = l; length } = change_core l key f in (with_length (bal l v d r) length)) else ( let { tree = r; length } = change_core r key f in (with_length (bal l v d r) length)) in try (change_core t key f) with | Change_no_op -> (with_length t length) ;; let update t key ~f ~length ~compare_key = let rec update_core t key f = match t with | Empty -> let data = f None in (with_length (Leaf (key, data)) (length + 1)) | Leaf (v, d) -> let c = compare_key key v in if c = 0 then ( let d' = f (Some d) in (with_length (Leaf (v, d')) length)) else if c < 0 then ( let { tree = l; length } = update_core Empty key f in (with_length (bal l v d Empty) length)) else ( let { tree = r; length } = update_core Empty key f in (with_length (bal Empty v d r) length)) | Node (l, v, d, r, h) -> let c = compare_key key v in if c = 0 then ( let data = f (Some d) in (with_length (Node (l, key, data, r, h)) length)) else if c < 0 then ( let { tree = l; length } = update_core l key f in (with_length (bal l v d r) length)) else ( let { tree = r; length } = update_core r key f in (with_length (bal l v d r) length)) in (update_core t key f) ;; let remove_multi t key ~length ~compare_key = (change t key ~length ~compare_key ~f:(function | None | Some ([] | [ _ ]) -> None | Some (_ :: (_ :: _ as non_empty_tail)) -> Some non_empty_tail)) ;; let rec iter_keys t ~f = match t with | Empty -> () | Leaf (v, _) -> f v | Node (l, v, _, r, _) -> iter_keys ~f l; f v; iter_keys ~f r ;; let rec iter t ~f = match t with | Empty -> () | Leaf (_, d) -> f d | Node (l, _, d, r, _) -> iter ~f l; f d; iter ~f r ;; let rec iteri t ~f = match t with | Empty -> () | Leaf (v, d) -> f ~key:v ~data:d | Node (l, v, d, r, _) -> iteri ~f l; f ~key:v ~data:d; iteri ~f r ;; let iteri_until = let rec iteri_until_loop t ~f : Continue_or_stop.t = match t with | Empty -> Continue | Leaf (v, d) -> f ~key:v ~data:d | Node (l, v, d, r, _) -> (match iteri_until_loop ~f l with | Stop -> Stop | Continue -> (match f ~key:v ~data:d with | Stop -> Stop | Continue -> iteri_until_loop ~f r)) in fun t ~f -> Finished_or_unfinished.of_continue_or_stop (iteri_until_loop t ~f) ;; let rec map t ~f = match t with | Empty -> Empty | Leaf (v, d) -> Leaf (v, f d) | Node (l, v, d, r, h) -> let l' = map ~f l in let d' = f d in let r' = map ~f r in Node (l', v, d', r', h) ;; let rec mapi t ~f = match t with | Empty -> Empty | Leaf (v, d) -> Leaf (v, f ~key:v ~data:d) | Node (l, v, d, r, h) -> let l' = mapi ~f l in let d' = f ~key:v ~data:d in let r' = mapi ~f r in Node (l', v, d', r', h) ;; let rec fold t ~init:accu ~f = match t with | Empty -> accu | Leaf (v, d) -> f ~key:v ~data:d accu | Node (l, v, d, r, _) -> fold ~f r ~init:(f ~key:v ~data:d (fold ~f l ~init:accu)) ;; let fold_until t ~init ~f ~finish = let rec fold_until_loop t ~acc ~f : (_, _) Container.Continue_or_stop.t = match t with | Empty -> Continue acc | Leaf (v, d) -> f ~key:v ~data:d acc | Node (l, v, d, r, _) -> (match fold_until_loop l ~acc ~f with | Stop final -> Stop final | Continue acc -> (match f ~key:v ~data:d acc with | Stop final -> Stop final | Continue acc -> fold_until_loop r ~acc ~f)) in match fold_until_loop t ~acc:init ~f with | Continue acc -> finish acc [@nontail] | Stop stop -> stop ;; let rec fold_right t ~init:accu ~f = match t with | Empty -> accu | Leaf (v, d) -> f ~key:v ~data:d accu | Node (l, v, d, r, _) -> fold_right ~f l ~init:(f ~key:v ~data:d (fold_right ~f r ~init:accu)) ;; let rec filter_mapi t ~f ~len = match t with | Empty -> Empty | Leaf (v, d) -> (match f ~key:v ~data:d with | Some new_data -> Leaf (v, new_data) | None -> decr len; Empty) | Node (l, v, d, r, _) -> let l' = filter_mapi l ~f ~len in let new_data = f ~key:v ~data:d in let r' = filter_mapi r ~f ~len in (match new_data with | Some new_data -> join l' v new_data r' | None -> decr len; concat_and_balance_unchecked l' r') ;; let rec filteri t ~f ~len = match t with | Empty -> Empty | Leaf (v, d) -> (match f ~key:v ~data:d with | true -> t | false -> decr len; Empty) | Node (l, v, d, r, _) -> let l' = filteri l ~f ~len in let keep_data = f ~key:v ~data:d in let r' = filteri r ~f ~len in if phys_equal l l' && keep_data && phys_equal r r' then t else ( match keep_data with | true -> join l' v d r' | false -> decr len; concat_and_balance_unchecked l' r') ;; let filter t ~f ~len = filteri t ~len ~f:(fun ~key:_ ~data -> f data) [@nontail] let filter_keys t ~f ~len = filteri t ~len ~f:(fun ~key ~data:_ -> f key) [@nontail] let filter_map t ~f ~len = filter_mapi t ~len ~f:(fun ~key:_ ~data -> f data) [@nontail] let partition_mapi t ~f = let t1, t2 = fold t ~init:(Build_increasing.empty, Build_increasing.empty) ~f:(fun ~key ~data (t1, t2) -> match (f ~key ~data : _ Either.t) with | First x -> Build_increasing.add_unchecked t1 ~key ~data:x, t2 | Second y -> t1, Build_increasing.add_unchecked t2 ~key ~data:y) in Build_increasing.to_tree_unchecked t1, Build_increasing.to_tree_unchecked t2 ;; let partition_map t ~f = partition_mapi t ~f:(fun ~key:_ ~data -> f data) [@nontail] let partitioni_tf t ~f = let rec loop t ~f = match t with | Empty -> Empty, Empty | Leaf (v, d) -> (match f ~key:v ~data:d with | true -> t, Empty | false -> Empty, t) | Node (l, v, d, r, _) -> let l't, l'f = loop l ~f in let keep_data_t = f ~key:v ~data:d in let r't, r'f = loop r ~f in let mk l' keep_data r' = if phys_equal l l' && keep_data && phys_equal r r' then t else ( match keep_data with | true -> join l' v d r' | false -> concat_and_balance_unchecked l' r') in mk l't keep_data_t r't, mk l'f (not keep_data_t) r'f in loop t ~f ;; let partition_tf t ~f = partitioni_tf t ~f:(fun ~key:_ ~data -> f data) [@nontail] module Enum = struct type increasing type decreasing type ('k, 'v, 'direction) t = | End | More of 'k * 'v * ('k, 'v) tree * ('k, 'v, 'direction) t let rec cons t (e : (_, _, increasing) t) : (_, _, increasing) t = match t with | Empty -> e | Leaf (v, d) -> More (v, d, Empty, e) | Node (l, v, d, r, _) -> cons l (More (v, d, r, e)) ;; let rec cons_right t (e : (_, _, decreasing) t) : (_, _, decreasing) t = match t with | Empty -> e | Leaf (v, d) -> More (v, d, Empty, e) | Node (l, v, d, r, _) -> cons_right r (More (v, d, l, e)) ;; let of_tree tree : (_, _, increasing) t = cons tree End let of_tree_right tree : (_, _, decreasing) t = cons_right tree End let starting_at_increasing t key compare : (_, _, increasing) t = let rec loop t e = match t with | Empty -> e | Leaf (v, d) -> loop (Node (Empty, v, d, Empty, 1)) e | Node (_, v, _, r, _) when compare v key < 0 -> loop r e | Node (l, v, d, r, _) -> loop l (More (v, d, r, e)) in loop t End ;; let starting_at_decreasing t key compare : (_, _, decreasing) t = let rec loop t e = match t with | Empty -> e | Leaf (v, d) -> loop (Node (Empty, v, d, Empty, 1)) e | Node (l, v, _, _, _) when compare v key > 0 -> loop l e | Node (l, v, d, r, _) -> loop r (More (v, d, l, e)) in loop t End ;; let step_deeper_exn tree e = match tree with | Empty -> assert false | Leaf (v, d) -> Empty, More (v, d, Empty, e) | Node (l, v, d, r, _) -> l, More (v, d, r, e) ;; (* [drop_phys_equal_prefix tree1 acc1 tree2 acc2] drops the largest physically-equal prefix of tree1 and tree2 that they share, and then prepends the remaining data into acc1 and acc2, respectively. This can be asymptotically faster than [cons] even if it skips a small proportion of the tree because [cons] is always O(log(n)) in the size of the tree, while this function is O(log(n/m)) where [m] is the size of the part of the tree that is skipped. *) let rec drop_phys_equal_prefix tree1 acc1 tree2 acc2 = if phys_equal tree1 tree2 then acc1, acc2 else ( let h2 = height tree2 in let h1 = height tree1 in if h2 = h1 then ( let tree1, acc1 = step_deeper_exn tree1 acc1 in let tree2, acc2 = step_deeper_exn tree2 acc2 in drop_phys_equal_prefix tree1 acc1 tree2 acc2) else if h2 > h1 then ( let tree2, acc2 = step_deeper_exn tree2 acc2 in drop_phys_equal_prefix tree1 acc1 tree2 acc2) else ( let tree1, acc1 = step_deeper_exn tree1 acc1 in drop_phys_equal_prefix tree1 acc1 tree2 acc2)) ;; let compare compare_key compare_data t1 t2 = let rec loop t1 t2 = match t1, t2 with | End, End -> 0 | End, _ -> -1 | _, End -> 1 | More (v1, d1, r1, e1), More (v2, d2, r2, e2) -> let c = compare_key v1 v2 in if c <> 0 then c else ( let c = compare_data d1 d2 in if c <> 0 then c else ( let e1, e2 = drop_phys_equal_prefix r1 e1 r2 e2 in loop e1 e2)) in loop t1 t2 ;; let equal compare_key data_equal t1 t2 = let rec loop t1 t2 = match t1, t2 with | End, End -> true | End, _ | _, End -> false | More (v1, d1, r1, e1), More (v2, d2, r2, e2) -> compare_key v1 v2 = 0 && data_equal d1 d2 && let e1, e2 = drop_phys_equal_prefix r1 e1 r2 e2 in loop e1 e2 in loop t1 t2 ;; let rec fold ~init ~f = function | End -> init | More (key, data, tree, enum) -> let next = f ~key ~data init in fold (cons tree enum) ~init:next ~f ;; let fold2 compare_key t1 t2 ~init ~f = let rec loop t1 t2 curr = match t1, t2 with | End, End -> curr | End, _ -> fold t2 ~init:curr ~f:(fun ~key ~data acc -> f ~key ~data:(`Right data) acc) [@nontail ] | _, End -> fold t1 ~init:curr ~f:(fun ~key ~data acc -> f ~key ~data:(`Left data) acc) [@nontail ] | More (k1, v1, tree1, enum1), More (k2, v2, tree2, enum2) -> let compare_result = compare_key k1 k2 in if compare_result = 0 then ( let next = f ~key:k1 ~data:(`Both (v1, v2)) curr in loop (cons tree1 enum1) (cons tree2 enum2) next) else if compare_result < 0 then ( let next = f ~key:k1 ~data:(`Left v1) curr in loop (cons tree1 enum1) t2 next) else ( let next = f ~key:k2 ~data:(`Right v2) curr in loop t1 (cons tree2 enum2) next) in loop t1 t2 init [@nontail] ;; let symmetric_diff t1 t2 ~compare_key ~data_equal = let step state = match state with | End, End -> Sequence.Step.Done | End, More (key, data, tree, enum) -> Sequence.Step.Yield { value = key, `Right data; state = End, cons tree enum } | More (key, data, tree, enum), End -> Sequence.Step.Yield { value = key, `Left data; state = cons tree enum, End } | (More (k1, v1, tree1, enum1) as left), (More (k2, v2, tree2, enum2) as right) -> let compare_result = compare_key k1 k2 in if compare_result = 0 then ( let next_state = drop_phys_equal_prefix tree1 enum1 tree2 enum2 in if data_equal v1 v2 then Sequence.Step.Skip { state = next_state } else Sequence.Step.Yield { value = k1, `Unequal (v1, v2); state = next_state }) else if compare_result < 0 then Sequence.Step.Yield { value = k1, `Left v1; state = cons tree1 enum1, right } else Sequence.Step.Yield { value = k2, `Right v2; state = left, cons tree2 enum2 } in Sequence.unfold_step ~init:(drop_phys_equal_prefix t1 End t2 End) ~f:step ;; let fold_symmetric_diff t1 t2 ~compare_key ~data_equal ~init ~f = let add acc k v = f acc (k, `Right v) in let remove acc k v = f acc (k, `Left v) in let rec loop left right acc = match left, right with | End, enum -> fold enum ~init:acc ~f:(fun ~key ~data acc -> add acc key data) [@nontail] | enum, End -> fold enum ~init:acc ~f:(fun ~key ~data acc -> remove acc key data) [@nontail] | (More (k1, v1, tree1, enum1) as left), (More (k2, v2, tree2, enum2) as right) -> let compare_result = compare_key k1 k2 in if compare_result = 0 then ( let acc = if data_equal v1 v2 then acc else f acc (k1, `Unequal (v1, v2)) in let enum1, enum2 = drop_phys_equal_prefix tree1 enum1 tree2 enum2 in loop enum1 enum2 acc) else if compare_result < 0 then ( let acc = remove acc k1 v1 in loop (cons tree1 enum1) right acc) else ( let acc = add acc k2 v2 in loop left (cons tree2 enum2) acc) in let left, right = drop_phys_equal_prefix t1 End t2 End in loop left right init [@nontail] ;; end let to_sequence_increasing comparator ~from_key t = let next enum = match enum with | Enum.End -> Sequence.Step.Done | Enum.More (k, v, t, e) -> Sequence.Step.Yield { value = k, v; state = Enum.cons t e } in let init = match from_key with | None -> Enum.of_tree t | Some key -> Enum.starting_at_increasing t key comparator.Comparator.compare in Sequence.unfold_step ~init ~f:next ;; let to_sequence_decreasing comparator ~from_key t = let next enum = match enum with | Enum.End -> Sequence.Step.Done | Enum.More (k, v, t, e) -> Sequence.Step.Yield { value = k, v; state = Enum.cons_right t e } in let init = match from_key with | None -> Enum.of_tree_right t | Some key -> Enum.starting_at_decreasing t key comparator.Comparator.compare in Sequence.unfold_step ~init ~f:next ;; let to_sequence comparator ?(order = `Increasing_key) ?keys_greater_or_equal_to ?keys_less_or_equal_to t = let inclusive_bound side t bound = let compare_key = comparator.Comparator.compare in let l, maybe, r = split t bound ~compare_key in let t = side (l, r) in match maybe with | None -> t | Some (key, data) -> set' t key data ~compare_key in match order with | `Increasing_key -> let t = Option.fold keys_less_or_equal_to ~init:t ~f:(inclusive_bound fst) in to_sequence_increasing comparator ~from_key:keys_greater_or_equal_to t | `Decreasing_key -> let t = Option.fold keys_greater_or_equal_to ~init:t ~f:(inclusive_bound snd) in to_sequence_decreasing comparator ~from_key:keys_less_or_equal_to t ;; let compare compare_key compare_data t1 t2 = let e1, e2 = Enum.drop_phys_equal_prefix t1 End t2 End in Enum.compare compare_key compare_data e1 e2 ;; let equal compare_key compare_data t1 t2 = let e1, e2 = Enum.drop_phys_equal_prefix t1 End t2 End in Enum.equal compare_key compare_data e1 e2 ;; let iter2 t1 t2 ~f ~compare_key = Enum.fold2 compare_key (Enum.of_tree t1) (Enum.of_tree t2) ~init:() ~f:(fun ~key ~data () -> f ~key ~data) [@nontail] ;; let fold2 t1 t2 ~init ~f ~compare_key = Enum.fold2 compare_key (Enum.of_tree t1) (Enum.of_tree t2) ~f ~init ;; let symmetric_diff = Enum.symmetric_diff let fold_symmetric_diff t1 t2 ~compare_key ~data_equal ~init ~f = (* [Enum.fold_diffs] is a correct implementation of this function, but is considerably slower, as we have to allocate quite a lot of state to track enumeration of a tree. Avoid if we can. *) let slow x y ~init = Enum.fold_symmetric_diff x y ~compare_key ~data_equal ~f ~init in let add acc k v = f acc (k, `Right v) in let remove acc k v = f acc (k, `Left v) in let delta acc k v v' = if data_equal v v' then acc else f acc (k, `Unequal (v, v')) in (* If two trees have the same structure at the root (and the same key, if they're [Node]s) we can trivially diff each subpart in obvious ways. *) let rec loop t t' acc = if phys_equal t t' then acc else ( match t, t' with | Empty, new_vals -> fold new_vals ~init:acc ~f:(fun ~key ~data acc -> add acc key data) [@nontail] | old_vals, Empty -> fold old_vals ~init:acc ~f:(fun ~key ~data acc -> remove acc key data) [@nontail] | Leaf (k, v), Leaf (k', v') -> (match compare_key k k' with | x when x = 0 -> delta acc k v v' | x when x < 0 -> let acc = remove acc k v in add acc k' v' | _ (* when x > 0 *) -> let acc = add acc k' v' in remove acc k v) | Node (l, k, v, r, _), Node (l', k', v', r', _) when compare_key k k' = 0 -> let acc = loop l l' acc in let acc = delta acc k v v' in loop r r' acc (* Our roots aren't the same key. Fallback to the slow mode. Trees with small diffs will only do this on very small parts of the tree (hopefully - if the overall root is rebalanced, we'll eat the whole cost, unfortunately.) *) | Node _, Node _ | Node _, Leaf _ | Leaf _, Node _ -> slow t t' ~init:acc) in loop t1 t2 init [@nontail] ;; let rec length = function | Empty -> 0 | Leaf _ -> 1 | Node (l, _, _, r, _) -> length l + length r + 1 ;; let hash_fold_t_ignoring_structure hash_fold_key hash_fold_data state t = fold t ~init:(hash_fold_int state (length t)) ~f:(fun ~key ~data state -> hash_fold_data (hash_fold_key state key) data) ;; let keys t = fold_right ~f:(fun ~key ~data:_ list -> key :: list) t ~init:[] let data t = fold_right ~f:(fun ~key:_ ~data list -> data :: list) t ~init:[] module type Foldable = sig val name : string type 'a t val fold : 'a t -> init:'acc -> f:(('acc -> 'a -> 'acc)[@local]) -> 'acc end let[@inline always] of_foldable' ~fold foldable ~init ~f ~compare_key = (fold [@inlined hint]) foldable ~init:(with_length_global empty 0) ~f:(fun { tree = accum; length } (key, data) -> let prev_data = match find accum key ~compare_key with | None -> init | Some prev -> prev in let data = f prev_data data in (set accum ~length ~key ~data ~compare_key |> globalize) [@nontail]) [@nontail] ;; module Of_foldable (M : Foldable) = struct let of_foldable_fold foldable ~init ~f ~compare_key = of_foldable' ~fold:M.fold foldable ~init ~f ~compare_key ;; let of_foldable_reduce foldable ~f ~compare_key = M.fold foldable ~init:(with_length_global empty 0) ~f:(fun { tree = accum; length } (key, data) -> let new_data = match find accum key ~compare_key with | None -> data | Some prev -> f prev data in (set accum ~length ~key ~data:new_data ~compare_key |> globalize) [@nontail]) [@nontail ] ;; let of_foldable foldable ~compare_key = with_return (fun r -> let map = M.fold foldable ~init:(with_length_global empty 0) ~f:(fun { tree = t; length } (key, data) -> let ({ tree = _; length = length' } as acc) = set ~length ~key ~data t ~compare_key in if length = length' then r.return (`Duplicate_key key) else globalize acc [@nontail]) in `Ok map) ;; let of_foldable_or_error foldable ~comparator = match of_foldable foldable ~compare_key:comparator.Comparator.compare with | `Ok x -> Result.Ok x | `Duplicate_key key -> Or_error.error ("Map.of_" ^ M.name ^ "_or_error: duplicate key") key comparator.sexp_of_t ;; let of_foldable_exn foldable ~comparator = match of_foldable foldable ~compare_key:comparator.Comparator.compare with | `Ok x -> x | `Duplicate_key key -> Error.create ("Map.of_" ^ M.name ^ "_exn: duplicate key") key comparator.sexp_of_t |> Error.raise ;; (* Reverse the input, then fold from left to right. The resulting map uses the first instance of each key from the input list. The relative ordering of elements in each output list is the same as in the input list. *) let of_foldable_multi foldable ~compare_key = let alist = M.fold foldable ~init:[] ~f:(fun l x -> x :: l) in of_foldable' alist ~fold:List.fold ~init:[] ~f:(fun l x -> x :: l) ~compare_key ;; end module Of_alist = Of_foldable (struct let name = "alist" type 'a t = 'a list let fold = List.fold end) let of_alist_fold = Of_alist.of_foldable_fold let of_alist_reduce = Of_alist.of_foldable_reduce let of_alist = Of_alist.of_foldable let of_alist_or_error = Of_alist.of_foldable_or_error let of_alist_exn = Of_alist.of_foldable_exn let of_alist_multi = Of_alist.of_foldable_multi module Of_sequence = Of_foldable (struct let name = "sequence" type 'a t = 'a Sequence.t let fold = Sequence.fold end) let of_sequence_fold = Of_sequence.of_foldable_fold let of_sequence_reduce = Of_sequence.of_foldable_reduce let of_sequence = Of_sequence.of_foldable let of_sequence_or_error = Of_sequence.of_foldable_or_error let of_sequence_exn = Of_sequence.of_foldable_exn let of_sequence_multi = Of_sequence.of_foldable_multi let of_list_with_key list ~get_key ~compare_key = with_return (fun r -> let map = List.fold list ~init:(with_length_global empty 0) ~f:(fun { tree = t; length } data -> let key = get_key data in let ({ tree = _; length = new_length } as acc) = set ~length ~key ~data t ~compare_key in if length = new_length then r.return (`Duplicate_key key) else globalize acc [@nontail]) in `Ok map) [@nontail] ;; let of_list_with_key_or_error list ~get_key ~comparator = match of_list_with_key list ~get_key ~compare_key:comparator.Comparator.compare with | `Ok x -> Result.Ok x | `Duplicate_key key -> Or_error.error "Map.of_list_with_key_or_error: duplicate key" key comparator.sexp_of_t ;; let of_list_with_key_exn list ~get_key ~comparator = match of_list_with_key list ~get_key ~compare_key:comparator.Comparator.compare with | `Ok x -> x | `Duplicate_key key -> Error.create "Map.of_list_with_key_exn: duplicate key" key comparator.sexp_of_t |> Error.raise ;; let of_list_with_key_multi list ~get_key ~compare_key = let list = List.rev list in List.fold list ~init:(with_length_global empty 0) ~f:(fun { tree = t; length } data -> let key = get_key data in (update t key ~length ~compare_key ~f:(fun option -> let list = Option.value option ~default:[] in data :: list) |> globalize) [@nontail]) [@nontail] ;; let for_all t ~f = with_return (fun r -> iter t ~f:(fun data -> if not (f data) then r.return false); true) [@nontail] ;; let for_alli t ~f = with_return (fun r -> iteri t ~f:(fun ~key ~data -> if not (f ~key ~data) then r.return false); true) [@nontail] ;; let exists t ~f = with_return (fun r -> iter t ~f:(fun data -> if f data then r.return true); false) [@nontail] ;; let existsi t ~f = with_return (fun r -> iteri t ~f:(fun ~key ~data -> if f ~key ~data then r.return true); false) [@nontail] ;; let count t ~f = fold t ~init:0 ~f:(fun ~key:_ ~data acc -> if f data then acc + 1 else acc) [@nontail] ;; let counti t ~f = fold t ~init:0 ~f:(fun ~key ~data acc -> if f ~key ~data then acc + 1 else acc) [@nontail ] ;; let to_alist ?(key_order = `Increasing) t = match key_order with | `Increasing -> fold_right t ~init:[] ~f:(fun ~key ~data x -> (key, data) :: x) | `Decreasing -> fold t ~init:[] ~f:(fun ~key ~data x -> (key, data) :: x) ;; let merge t1 t2 ~f ~compare_key = let elts = Uniform_array.unsafe_create_uninitialized ~len:(length t1 + length t2) in let i = ref 0 in iter2 t1 t2 ~compare_key ~f:(fun ~key ~data:values -> match f ~key values with | Some value -> Uniform_array.set elts !i (key, value); incr i | None -> ()); let len = !i in let get i = Uniform_array.get elts i in let tree = of_increasing_iterator_unchecked ~len ~f:get in (with_length tree len) ;; let merge_skewed = let merge_large_first length_large t_large t_small ~call ~combine ~compare_key = fold t_small ~init:(with_length_global t_large length_large) ~f:(fun ~key ~data:data' { tree = t; length } -> (update t key ~length ~compare_key ~f:(function | None -> data' | Some data -> call combine ~key data data') |> globalize) [@nontail]) [@nontail] in let call f ~key x y = f ~key x y in let swap f ~key x y = f ~key y x in fun t1 t2 ~length1 ~length2 ~combine ~compare_key -> if length2 <= length1 then merge_large_first length1 t1 t2 ~call ~combine ~compare_key else merge_large_first length2 t2 t1 ~call:swap ~combine ~compare_key ;; module Closest_key_impl = struct (* [marker] and [repackage] allow us to create "logical" options without actually allocating any options. Passing [Found key value] to a function is equivalent to passing [Some (key, value)]; passing [Missing () ()] is equivalent to passing [None]. *) type ('k, 'v, 'k_opt, 'v_opt) marker = | Missing : ('k, 'v, unit, unit) marker | Found : ('k, 'v, 'k, 'v) marker let repackage (type k v k_opt v_opt) (marker : (k, v, k_opt, v_opt) marker) (k : k_opt) (v : v_opt) : (k * v) option = match marker with | Missing -> None | Found -> Some (k, v) ;; (* The type signature is explicit here to allow polymorphic recursion. *) let rec loop : 'k 'v 'k_opt 'v_opt. ('k, 'v) tree -> [ `Greater_or_equal_to | `Greater_than | `Less_or_equal_to | `Less_than ] -> 'k -> compare_key:('k -> 'k -> int) -> ('k, 'v, 'k_opt, 'v_opt) marker -> 'k_opt -> 'v_opt -> ('k * 'v) option = fun t dir k ~compare_key found_marker found_key found_value -> match t with | Empty -> repackage found_marker found_key found_value | Leaf (k', v') -> let c = compare_key k' k in if match dir with | `Greater_or_equal_to -> c >= 0 | `Greater_than -> c > 0 | `Less_or_equal_to -> c <= 0 | `Less_than -> c < 0 then Some (k', v') else repackage found_marker found_key found_value | Node (l, k', v', r, _) -> let c = compare_key k' k in if c = 0 then ( (* This is a base case (no recursive call). *) match dir with | `Greater_or_equal_to | `Less_or_equal_to -> Some (k', v') | `Greater_than -> if is_empty r then repackage found_marker found_key found_value else min_elt r | `Less_than -> if is_empty l then repackage found_marker found_key found_value else max_elt l) else ( (* We are guaranteed here that k' <> k. *) (* This is the only recursive case. *) match dir with | `Greater_or_equal_to | `Greater_than -> if c > 0 then loop l dir k ~compare_key Found k' v' else loop r dir k ~compare_key found_marker found_key found_value | `Less_or_equal_to | `Less_than -> if c < 0 then loop r dir k ~compare_key Found k' v' else loop l dir k ~compare_key found_marker found_key found_value) ;; let closest_key t dir k ~compare_key = loop t dir k ~compare_key Missing () () end let closest_key = Closest_key_impl.closest_key let rec rank t k ~compare_key = match t with | Empty -> None | Leaf (k', _) -> if compare_key k' k = 0 then Some 0 else None | Node (l, k', _, r, _) -> let c = compare_key k' k in if c = 0 then Some (length l) else if c > 0 then rank l k ~compare_key else Option.map (rank r k ~compare_key) ~f:(fun rank -> rank + 1 + length l) ;; (* this could be implemented using [Sequence] interface but the following implementation allocates only 2 words and doesn't require write-barrier *) let rec nth' num_to_search = function | Empty -> None | Leaf (k, v) -> if !num_to_search = 0 then Some (k, v) else ( decr num_to_search; None) | Node (l, k, v, r, _) -> (match nth' num_to_search l with | Some _ as some -> some | None -> if !num_to_search = 0 then Some (k, v) else ( decr num_to_search; nth' num_to_search r)) ;; let nth t n = nth' (ref n) t let rec find_first_satisfying t ~f = match t with | Empty -> None | Leaf (k, v) -> if f ~key:k ~data:v then Some (k, v) else None | Node (l, k, v, r, _) -> if f ~key:k ~data:v then ( match find_first_satisfying l ~f with | None -> Some (k, v) | Some _ as x -> x) else find_first_satisfying r ~f ;; let rec find_last_satisfying t ~f = match t with | Empty -> None | Leaf (k, v) -> if f ~key:k ~data:v then Some (k, v) else None | Node (l, k, v, r, _) -> if f ~key:k ~data:v then ( match find_last_satisfying r ~f with | None -> Some (k, v) | Some _ as x -> x) else find_last_satisfying l ~f ;; let binary_search t ~compare how v = match how with | `Last_strictly_less_than -> find_last_satisfying t ~f:(fun ~key ~data -> compare ~key ~data v < 0) [@nontail] | `Last_less_than_or_equal_to -> find_last_satisfying t ~f:(fun ~key ~data -> compare ~key ~data v <= 0) [@nontail] | `First_equal_to -> (match find_first_satisfying t ~f:(fun ~key ~data -> compare ~key ~data v >= 0) with | Some (key, data) as pair when compare ~key ~data v = 0 -> pair | None | Some _ -> None) | `Last_equal_to -> (match find_last_satisfying t ~f:(fun ~key ~data -> compare ~key ~data v <= 0) with | Some (key, data) as pair when compare ~key ~data v = 0 -> pair | None | Some _ -> None) | `First_greater_than_or_equal_to -> find_first_satisfying t ~f:(fun ~key ~data -> compare ~key ~data v >= 0) [@nontail] | `First_strictly_greater_than -> find_first_satisfying t ~f:(fun ~key ~data -> compare ~key ~data v > 0) [@nontail] ;; let binary_search_segmented t ~segment_of how = let is_left ~key ~data = match segment_of ~key ~data with | `Left -> true | `Right -> false in let is_right ~key ~data = not (is_left ~key ~data) in match how with | `Last_on_left -> find_last_satisfying t ~f:is_left [@nontail] | `First_on_right -> find_first_satisfying t ~f:is_right [@nontail] ;; (* [binary_search_one_sided_bound] finds the key in [t] which satisfies [maybe_bound] and the relevant one of [if_exclusive] or [if_inclusive], as judged by [compare]. *) let binary_search_one_sided_bound t maybe_bound ~compare ~if_exclusive ~if_inclusive = let find_bound t how bound ~compare : _ Maybe_bound.t option = match binary_search t how bound ~compare with | Some (bound, _) -> Some (Incl bound) | None -> None in match (maybe_bound : _ Maybe_bound.t) with | Excl bound -> find_bound t if_exclusive bound ~compare | Incl bound -> find_bound t if_inclusive bound ~compare | Unbounded -> Some Unbounded ;; (* [binary_search_two_sided_bounds] finds the (not necessarily distinct) keys in [t] which most closely approach (but do not cross) [lower_bound] and [upper_bound], as judged by [compare]. It returns [None] if no keys in [t] are within that range. *) let binary_search_two_sided_bounds t ~compare ~lower_bound ~upper_bound = let find_lower_bound t maybe_bound ~compare = binary_search_one_sided_bound t maybe_bound ~compare ~if_exclusive:`First_strictly_greater_than ~if_inclusive:`First_greater_than_or_equal_to in let find_upper_bound t maybe_bound ~compare = binary_search_one_sided_bound t maybe_bound ~compare ~if_exclusive:`Last_strictly_less_than ~if_inclusive:`Last_less_than_or_equal_to in match find_lower_bound t lower_bound ~compare with | None -> None | Some lower_bound -> (match find_upper_bound t upper_bound ~compare with | None -> None | Some upper_bound -> Some (lower_bound, upper_bound)) ;; type ('k, 'v) acc = { mutable bad_key : 'k option ; mutable map_length : ('k, 'v) t With_length.t } let of_iteri ~iteri ~compare_key = let acc = { bad_key = None; map_length = with_length_global empty 0 } in iteri ~f:(fun ~key ~data -> let { tree = map; length } = acc.map_length in let ({ tree = _; length = length' } as pair) = set ~length ~key ~data map ~compare_key in if length = length' && Option.is_none acc.bad_key then acc.bad_key <- Some key else acc.map_length <- globalize pair); match acc.bad_key with | None -> `Ok acc.map_length | Some key -> `Duplicate_key key ;; let of_iteri_exn ~iteri ~(comparator : _ Comparator.t) = match of_iteri ~iteri ~compare_key:comparator.compare with | `Ok v -> v | `Duplicate_key key -> Error.create "Map.of_iteri_exn: duplicate key" key comparator.sexp_of_t |> Error.raise ;; let t_of_sexp_direct key_of_sexp value_of_sexp sexp ~(comparator : _ Comparator.t) = let alist = list_of_sexp (pair_of_sexp key_of_sexp value_of_sexp) sexp in let compare_key = comparator.compare in match of_alist alist ~compare_key with | `Ok v -> v | `Duplicate_key k -> (* find the sexp of a duplicate key, so the error is narrowed to a key and not the whole map *) let alist_sexps = list_of_sexp (pair_of_sexp Fn.id Fn.id) sexp in let found_first_k = ref false in List.iter2_ok alist alist_sexps ~f:(fun (k2, _) (k2_sexp, _) -> if compare_key k k2 = 0 then if !found_first_k then of_sexp_error "Map.t_of_sexp_direct: duplicate key" k2_sexp else found_first_k := true); assert false ;; let sexp_of_t sexp_of_key sexp_of_value t = let f ~key ~data acc = Sexp.List [ sexp_of_key key; sexp_of_value data ] :: acc in Sexp.List (fold_right ~f t ~init:[]) ;; let combine_errors t ~sexp_of_key = let oks, errors = partition_map t ~f:Result.to_either in if is_empty errors then Ok oks else Or_error.error_s (sexp_of_t sexp_of_key Error.sexp_of_t errors) ;; let map_keys t1 ~f ~comparator:({ compare = compare_key; sexp_of_t = sexp_of_key } : _ Comparator.t) = with_return (fun { return } -> `Ok (fold t1 ~init:(with_length_global empty 0) ~f:(fun ~key ~data { tree = t2; length } -> let key = f key in try add_exn_internal t2 ~length ~key ~data ~compare_key ~sexp_of_key |> globalize with | Duplicate -> return (`Duplicate_key key)))) [@nontail] ;; let map_keys_exn t ~f ~comparator = match map_keys t ~f ~comparator with | `Ok result -> result | `Duplicate_key key -> let sexp_of_key = comparator.Comparator.sexp_of_t in Error.raise_s (Sexp.message "Map.map_keys_exn: duplicate key" [ "key", key |> sexp_of_key ]) ;; let transpose_keys ~outer_comparator ~inner_comparator outer_t = fold outer_t ~init:(with_length_global empty 0) ~f:(fun ~key:outer_key ~data:inner_t acc -> fold inner_t ~init:acc ~f:(fun ~key:inner_key ~data { tree = acc; length = acc_len } -> (update acc inner_key ~length:acc_len ~compare_key:inner_comparator.Comparator.compare ~f:(function | None -> with_length_global (singleton outer_key data) 1 | Some { tree = elt; length = elt_len } -> (set elt ~key:outer_key ~data ~length:elt_len ~compare_key:outer_comparator.Comparator.compare |> globalize) [@nontail]) |> globalize) [@nontail])) ;; module Make_applicative_traversals (A : Applicative.Lazy_applicative) = struct let rec mapi t ~f = match t with | Empty -> A.return Empty | Leaf (v, d) -> A.map (f ~key:v ~data:d) ~f:(fun new_data -> Leaf (v, new_data)) | Node (l, v, d, r, h) -> let l' = A.of_thunk (fun () -> mapi ~f l) in let d' = f ~key:v ~data:d in let r' = A.of_thunk (fun () -> mapi ~f r) in A.map3 l' d' r' ~f:(fun l' d' r' -> Node (l', v, d', r', h)) ;; (* In theory the computation of length on-the-fly is not necessary here because it can be done by wrapping the applicative [A] with length-computing logic. However, introducing an applicative transformer like that makes the map benchmarks in async_kernel/bench/src/bench_deferred_map.ml noticeably slower. *) let filter_mapi t ~f = let rec tree_filter_mapi t ~f = match t with | Empty -> A.return (with_length_global Empty 0) | Leaf (v, d) -> A.map (f ~key:v ~data:d) ~f:(function | Some new_data -> with_length_global (Leaf (v, new_data)) 1 | None -> with_length_global Empty 0) | Node (l, v, d, r, _) -> A.map3 (A.of_thunk (fun () -> tree_filter_mapi l ~f)) (f ~key:v ~data:d) (A.of_thunk (fun () -> tree_filter_mapi r ~f)) ~f: (fun { tree = l'; length = l_len } new_data { tree = r'; length = r_len } -> match new_data with | Some new_data -> with_length_global (join l' v new_data r') (l_len + r_len + 1) | None -> with_length_global (concat_and_balance_unchecked l' r') (l_len + r_len)) in tree_filter_mapi t ~f ;; end end type ('k, 'v, 'comparator) t = { (* [comparator] is the first field so that polymorphic equality fails on a map due to the functional value in the comparator. Note that this does not affect polymorphic [compare]: that still produces nonsense. *) comparator : ('k, 'comparator) Comparator.t ; tree : ('k, 'v) Tree0.t ; length : int } type ('k, 'v, 'comparator) tree = ('k, 'v) Tree0.t let compare_key t = t.comparator.Comparator.compare let like { tree = _; length = _; comparator } ({ tree; length } : _ With_length.t) = { tree; length; comparator } ;; let like_maybe_no_op ({ tree = old_tree; length = _; comparator } as old_t) ({ tree; length } : _ With_length.t) = if phys_equal old_tree tree then old_t else { tree; length; comparator } ;; let with_same_length { tree = _; comparator; length } tree = { tree; comparator; length } let of_like_tree t tree = { tree; comparator = t.comparator; length = Tree0.length tree } let of_like_tree_maybe_no_op t tree = if phys_equal t.tree tree then t else { tree; comparator = t.comparator; length = Tree0.length tree } ;; let of_tree ~comparator tree = { tree; comparator; length = Tree0.length tree } (* Exposing this function would make it very easy for the invariants of this module to be broken. *) let of_tree_unsafe ~comparator ~length tree = { tree; comparator; length } module Accessors = struct let comparator t = t.comparator let to_tree t = t.tree let invariants t = Tree0.invariants t.tree ~compare_key:(compare_key t) && Tree0.length t.tree = t.length ;; let is_empty t = Tree0.is_empty t.tree let length t = t.length let set t ~key ~data = like t (Tree0.set t.tree ~length:t.length ~key ~data ~compare_key:(compare_key t)) [@nontail] ;; let add_exn t ~key ~data = like t (Tree0.add_exn t.tree ~length:t.length ~key ~data ~compare_key:(compare_key t) ~sexp_of_key:t.comparator.sexp_of_t) [@nontail] ;; let add_exn_internal t ~key ~data = like t (Tree0.add_exn_internal t.tree ~length:t.length ~key ~data ~compare_key:(compare_key t) ~sexp_of_key:t.comparator.sexp_of_t) [@nontail] ;; let add t ~key ~data = match add_exn_internal t ~key ~data with | result -> `Ok result | exception Duplicate -> `Duplicate ;; let add_multi t ~key ~data = like t (Tree0.add_multi t.tree ~length:t.length ~key ~data ~compare_key:(compare_key t)) [@nontail] ;; let remove_multi t key = like t (Tree0.remove_multi t.tree ~length:t.length key ~compare_key:(compare_key t)) [@nontail] ;; let find_multi t key = Tree0.find_multi t.tree key ~compare_key:(compare_key t) let change t key ~f = like t (Tree0.change t.tree key ~f ~length:t.length ~compare_key:(compare_key t)) [@nontail] ;; let update t key ~f = like t (Tree0.update t.tree key ~f ~length:t.length ~compare_key:(compare_key t)) [@nontail] ;; let find_exn t key = Tree0.find_exn t.tree key ~compare_key:(compare_key t) ~sexp_of_key:t.comparator.sexp_of_t ;; let find t key = Tree0.find t.tree key ~compare_key:(compare_key t) let remove t key = like_maybe_no_op t (Tree0.remove t.tree key ~length:t.length ~compare_key:(compare_key t)) [@nontail] ;; let mem t key = Tree0.mem t.tree key ~compare_key:(compare_key t) let iter_keys t ~f = Tree0.iter_keys t.tree ~f let iter t ~f = Tree0.iter t.tree ~f let iteri t ~f = Tree0.iteri t.tree ~f let iteri_until t ~f = Tree0.iteri_until t.tree ~f let iter2 t1 t2 ~f = Tree0.iter2 t1.tree t2.tree ~f ~compare_key:(compare_key t1) let map t ~f = with_same_length t (Tree0.map t.tree ~f) let mapi t ~f = with_same_length t (Tree0.mapi t.tree ~f) let fold t ~init ~f = Tree0.fold t.tree ~f ~init let fold_until t ~init ~f ~finish = Tree0.fold_until t.tree ~init ~f ~finish let fold_right t ~init ~f = Tree0.fold_right t.tree ~f ~init let fold2 t1 t2 ~init ~f = Tree0.fold2 t1.tree t2.tree ~init ~f ~compare_key:(compare_key t1) ;; let filter_keys t ~f = let len = (ref t.length) in let tree = Tree0.filter_keys t.tree ~f ~len in like_maybe_no_op t (with_length tree !len) [@nontail] ;; let filter t ~f = let len = (ref t.length) in let tree = Tree0.filter t.tree ~f ~len in like_maybe_no_op t (with_length tree !len) [@nontail] ;; let filteri t ~f = let len = (ref t.length) in let tree = Tree0.filteri t.tree ~f ~len in like_maybe_no_op t (with_length tree !len) [@nontail] ;; let filter_map t ~f = let len = (ref t.length) in let tree = Tree0.filter_map t.tree ~f ~len in like t (with_length tree !len) [@nontail] ;; let filter_mapi t ~f = let len = (ref t.length) in let tree = Tree0.filter_mapi t.tree ~f ~len in like t (with_length tree !len) [@nontail] ;; let of_like_tree2 t (t1, t2) = of_like_tree t t1, of_like_tree t t2 let of_like_tree2_maybe_no_op t (t1, t2) = of_like_tree_maybe_no_op t t1, of_like_tree_maybe_no_op t t2 ;; let partition_mapi t ~f = of_like_tree2 t (Tree0.partition_mapi t.tree ~f) let partition_map t ~f = of_like_tree2 t (Tree0.partition_map t.tree ~f) let partitioni_tf t ~f = of_like_tree2_maybe_no_op t (Tree0.partitioni_tf t.tree ~f) let partition_tf t ~f = of_like_tree2_maybe_no_op t (Tree0.partition_tf t.tree ~f) let combine_errors t = Or_error.map ~f:(of_like_tree t) (Tree0.combine_errors t.tree ~sexp_of_key:t.comparator.sexp_of_t) ;; let compare_direct compare_data t1 t2 = Tree0.compare (compare_key t1) compare_data t1.tree t2.tree ;; let equal compare_data t1 t2 = Tree0.equal (compare_key t1) compare_data t1.tree t2.tree let keys t = Tree0.keys t.tree let data t = Tree0.data t.tree let to_alist ?key_order t = Tree0.to_alist ?key_order t.tree let symmetric_diff t1 t2 ~data_equal = Tree0.symmetric_diff t1.tree t2.tree ~compare_key:(compare_key t1) ~data_equal ;; let fold_symmetric_diff t1 t2 ~data_equal ~init ~f = Tree0.fold_symmetric_diff t1.tree t2.tree ~compare_key:(compare_key t1) ~data_equal ~init ~f ;; let merge t1 t2 ~f = like t1 (Tree0.merge t1.tree t2.tree ~f ~compare_key:(compare_key t1)) [@nontail] ;; let merge_skewed t1 t2 ~combine = (* This is only a no-op in the case where at least one of the maps is empty. *) like_maybe_no_op (if t2.length <= t1.length then t1 else t2) (Tree0.merge_skewed t1.tree t2.tree ~length1:t1.length ~length2:t2.length ~combine ~compare_key:(compare_key t1)) ;; let min_elt t = Tree0.min_elt t.tree let min_elt_exn t = Tree0.min_elt_exn t.tree let max_elt t = Tree0.max_elt t.tree let max_elt_exn t = Tree0.max_elt_exn t.tree let for_all t ~f = Tree0.for_all t.tree ~f let for_alli t ~f = Tree0.for_alli t.tree ~f let exists t ~f = Tree0.exists t.tree ~f let existsi t ~f = Tree0.existsi t.tree ~f let count t ~f = Tree0.count t.tree ~f let counti t ~f = Tree0.counti t.tree ~f let split t k = let l, maybe, r = Tree0.split t.tree k ~compare_key:(compare_key t) in let comparator = comparator t in (* Try to traverse the least amount possible to calculate the length, using height as a heuristic. *) let both_len = if Option.is_some maybe then t.length - 1 else t.length in if Tree0.height l < Tree0.height r then ( let l = of_tree l ~comparator in l, maybe, of_tree_unsafe r ~comparator ~length:(both_len - length l)) else ( let r = of_tree r ~comparator in of_tree_unsafe l ~comparator ~length:(both_len - length r), maybe, r) ;; let split_and_reinsert_boundary t ~into k = let l, r = Tree0.split_and_reinsert_boundary t.tree ~into k ~compare_key:(compare_key t) in let comparator = comparator t in (* Try to traverse the least amount possible to calculate the length, using height as a heuristic. *) if Tree0.height l < Tree0.height r then ( let l = of_tree l ~comparator in l, of_tree_unsafe r ~comparator ~length:(t.length - length l)) else ( let r = of_tree r ~comparator in of_tree_unsafe l ~comparator ~length:(t.length - length r), r) ;; let split_le_gt t k = split_and_reinsert_boundary t ~into:`Left k let split_lt_ge t k = split_and_reinsert_boundary t ~into:`Right k let subrange t ~lower_bound ~upper_bound = let left, mid, right = Tree0.split_range t.tree ~lower_bound ~upper_bound ~compare_key:(compare_key t) in (* Try to traverse the least amount possible to calculate the length, using height as a heuristic. *) let outer_joined_height = let h_l = Tree0.height left and h_r = Tree0.height right in if h_l = h_r then h_l + 1 else max h_l h_r in if outer_joined_height < Tree0.height mid then ( let mid_length = t.length - (Tree0.length left + Tree0.length right) in of_tree_unsafe mid ~comparator:(comparator t) ~length:mid_length) else of_tree mid ~comparator:(comparator t) ;; let append ~lower_part ~upper_part = match Tree0.append ~compare_key:(compare_key lower_part) ~lower_part:lower_part.tree ~upper_part:upper_part.tree with | `Ok tree -> `Ok (of_tree_unsafe tree ~comparator:(comparator lower_part) ~length:(lower_part.length + upper_part.length)) | `Overlapping_key_ranges -> `Overlapping_key_ranges ;; let fold_range_inclusive t ~min ~max ~init ~f = Tree0.fold_range_inclusive t.tree ~min ~max ~init ~f ~compare_key:(compare_key t) ;; let range_to_alist t ~min ~max = Tree0.range_to_alist t.tree ~min ~max ~compare_key:(compare_key t) ;; let closest_key t dir key = Tree0.closest_key t.tree dir key ~compare_key:(compare_key t) ;; let nth t n = Tree0.nth t.tree n let nth_exn t n = Option.value_exn (nth t n) let rank t key = Tree0.rank t.tree key ~compare_key:(compare_key t) let sexp_of_t sexp_of_k sexp_of_v _ t = Tree0.sexp_of_t sexp_of_k sexp_of_v t.tree let to_sequence ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t = Tree0.to_sequence t.comparator ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t.tree ;; let binary_search t ~compare how v = Tree0.binary_search t.tree ~compare how v let binary_search_segmented t ~segment_of how = Tree0.binary_search_segmented t.tree ~segment_of how ;; let hash_fold_direct hash_fold_key hash_fold_data state t = Tree0.hash_fold_t_ignoring_structure hash_fold_key hash_fold_data state t.tree ;; let binary_search_subrange t ~compare ~lower_bound ~upper_bound = match Tree0.binary_search_two_sided_bounds t.tree ~compare ~lower_bound ~upper_bound with | Some (lower_bound, upper_bound) -> subrange t ~lower_bound ~upper_bound | None -> like_maybe_no_op t (with_length Tree0.Empty 0) [@nontail] ;; module Make_applicative_traversals (A : Applicative.Lazy_applicative) = struct module Tree_traversals = Tree0.Make_applicative_traversals (A) let mapi t ~f = A.map (Tree_traversals.mapi t.tree ~f) ~f:(fun new_tree -> with_same_length t new_tree) ;; let filter_mapi t ~f = A.map (Tree_traversals.filter_mapi t.tree ~f) ~f:(fun new_tree_with_length -> like t new_tree_with_length) ;; end end (* [0] is used as the [length] argument everywhere in this module, since trees do not have their lengths stored at the root, unlike maps. The values are discarded always. *) module Tree = struct type ('k, 'v, 'comparator) t = ('k, 'v, 'comparator) tree let empty_without_value_restriction = Tree0.empty let empty ~comparator:_ = empty_without_value_restriction let of_tree ~comparator:_ tree = tree let singleton ~comparator:_ k v = Tree0.singleton k v let of_sorted_array_unchecked ~comparator array = (Tree0.of_sorted_array_unchecked array ~compare_key:comparator.Comparator.compare) .tree ;; let of_sorted_array ~comparator array = Tree0.of_sorted_array array ~compare_key:comparator.Comparator.compare |> Or_error.map ~f:(fun (x : ('k, 'v) Tree0.t With_length.t) -> x.tree) ;; let of_alist ~comparator alist = match Tree0.of_alist alist ~compare_key:comparator.Comparator.compare with | `Duplicate_key _ as d -> d | `Ok { tree; length = _ } -> `Ok tree ;; let of_alist_or_error ~comparator alist = Tree0.of_alist_or_error alist ~comparator |> Or_error.map ~f:(fun (x : ('k, 'v) Tree0.t With_length.t) -> x.tree) ;; let of_alist_exn ~comparator alist = (Tree0.of_alist_exn alist ~comparator).tree let of_alist_multi ~comparator alist = (Tree0.of_alist_multi alist ~compare_key:comparator.Comparator.compare).tree ;; let of_alist_fold ~comparator alist ~init ~f = (Tree0.of_alist_fold alist ~init ~f ~compare_key:comparator.Comparator.compare).tree ;; let of_alist_reduce ~comparator alist ~f = (Tree0.of_alist_reduce alist ~f ~compare_key:comparator.Comparator.compare).tree ;; let of_iteri ~comparator ~iteri = match Tree0.of_iteri ~iteri ~compare_key:comparator.Comparator.compare with | `Ok { tree; length = _ } -> `Ok tree | `Duplicate_key _ as d -> d ;; let of_iteri_exn ~comparator ~iteri = (Tree0.of_iteri_exn ~iteri ~comparator).tree let of_increasing_iterator_unchecked ~comparator:_required_by_intf ~len ~f = Tree0.of_increasing_iterator_unchecked ~len ~f ;; let of_increasing_sequence ~comparator seq = Or_error.map ~f:(fun (x : ('k, 'v) Tree0.t With_length.t) -> x.tree) (Tree0.of_increasing_sequence seq ~compare_key:comparator.Comparator.compare) ;; let of_sequence ~comparator seq = match Tree0.of_sequence seq ~compare_key:comparator.Comparator.compare with | `Duplicate_key _ as d -> d | `Ok { tree; length = _ } -> `Ok tree ;; let of_sequence_or_error ~comparator seq = Tree0.of_sequence_or_error seq ~comparator |> Or_error.map ~f:(fun (x : ('k, 'v) Tree0.t With_length.t) -> x.tree) ;; let of_sequence_exn ~comparator seq = (Tree0.of_sequence_exn seq ~comparator).tree let of_sequence_multi ~comparator seq = (Tree0.of_sequence_multi seq ~compare_key:comparator.Comparator.compare).tree ;; let of_sequence_fold ~comparator seq ~init ~f = (Tree0.of_sequence_fold seq ~init ~f ~compare_key:comparator.Comparator.compare).tree ;; let of_sequence_reduce ~comparator seq ~f = (Tree0.of_sequence_reduce seq ~f ~compare_key:comparator.Comparator.compare).tree ;; let of_list_with_key ~comparator list ~get_key = match Tree0.of_list_with_key list ~get_key ~compare_key:comparator.Comparator.compare with | `Duplicate_key _ as d -> d | `Ok { tree; length = _ } -> `Ok tree ;; let of_list_with_key_or_error ~comparator list ~get_key = Tree0.of_list_with_key_or_error list ~get_key ~comparator |> Or_error.map ~f:(fun (x : ('k, 'v) Tree0.t With_length.t) -> x.tree) ;; let of_list_with_key_exn ~comparator list ~get_key = (Tree0.of_list_with_key_exn list ~get_key ~comparator).tree ;; let of_list_with_key_multi ~comparator list ~get_key = (Tree0.of_list_with_key_multi list ~get_key ~compare_key:comparator.Comparator.compare) .tree ;; let to_tree t = t let invariants ~comparator t = Tree0.invariants t ~compare_key:comparator.Comparator.compare ;; let is_empty t = Tree0.is_empty t let length t = Tree0.length t let set ~comparator t ~key ~data = (Tree0.set t ~key ~data ~length:0 ~compare_key:comparator.Comparator.compare).tree ;; let add_exn ~comparator t ~key ~data = (Tree0.add_exn t ~key ~data ~length:0 ~compare_key:comparator.Comparator.compare ~sexp_of_key:comparator.sexp_of_t) .tree ;; let add_exn_internal ~comparator t ~key ~data = (Tree0.add_exn_internal t ~key ~data ~length:0 ~compare_key:comparator.Comparator.compare ~sexp_of_key:comparator.sexp_of_t) .tree ;; let add ~comparator t ~key ~data = try `Ok (add_exn_internal t ~comparator ~key ~data) with | _ -> `Duplicate ;; let add_multi ~comparator t ~key ~data = (Tree0.add_multi t ~key ~data ~length:0 ~compare_key:comparator.Comparator.compare) .tree ;; let remove_multi ~comparator t key = (Tree0.remove_multi t key ~length:0 ~compare_key:comparator.Comparator.compare).tree ;; let find_multi ~comparator t key = Tree0.find_multi t key ~compare_key:comparator.Comparator.compare ;; let change ~comparator t key ~f = (Tree0.change t key ~f ~length:0 ~compare_key:comparator.Comparator.compare).tree ;; let update ~comparator t key ~f = change ~comparator t key ~f:(fun data -> Some (f data)) [@nontail] ;; let find_exn ~comparator t key = Tree0.find_exn t key ~compare_key:comparator.Comparator.compare ~sexp_of_key:comparator.Comparator.sexp_of_t ;; let find ~comparator t key = Tree0.find t key ~compare_key:comparator.Comparator.compare let remove ~comparator t key = (Tree0.remove t key ~length:0 ~compare_key:comparator.Comparator.compare).tree ;; let mem ~comparator t key = Tree0.mem t key ~compare_key:comparator.Comparator.compare let iter_keys t ~f = Tree0.iter_keys t ~f let iter t ~f = Tree0.iter t ~f let iteri t ~f = Tree0.iteri t ~f let iteri_until t ~f = Tree0.iteri_until t ~f let iter2 ~comparator t1 t2 ~f = Tree0.iter2 t1 t2 ~f ~compare_key:comparator.Comparator.compare ;; let map t ~f = Tree0.map t ~f let mapi t ~f = Tree0.mapi t ~f let fold t ~init ~f = Tree0.fold t ~f ~init let fold_until t ~init ~f ~finish = Tree0.fold_until t ~f ~init ~finish let fold_right t ~init ~f = Tree0.fold_right t ~f ~init let fold2 ~comparator t1 t2 ~init ~f = Tree0.fold2 t1 t2 ~init ~f ~compare_key:comparator.Comparator.compare ;; let filter_keys t ~f = Tree0.filter_keys t ~f ~len:( (ref 0)) [@nontail] let filter t ~f = Tree0.filter t ~f ~len:( (ref 0)) [@nontail] let filteri t ~f = Tree0.filteri t ~f ~len:( (ref 0)) [@nontail] let filter_map t ~f = Tree0.filter_map t ~f ~len:( (ref 0)) [@nontail] let filter_mapi t ~f = Tree0.filter_mapi t ~f ~len:( (ref 0)) [@nontail] let partition_mapi t ~f = Tree0.partition_mapi t ~f let partition_map t ~f = Tree0.partition_map t ~f let partitioni_tf t ~f = Tree0.partitioni_tf t ~f let partition_tf t ~f = Tree0.partition_tf t ~f let combine_errors ~comparator t = Tree0.combine_errors t ~sexp_of_key:comparator.Comparator.sexp_of_t ;; let compare_direct ~comparator compare_data t1 t2 = Tree0.compare comparator.Comparator.compare compare_data t1 t2 ;; let equal ~comparator compare_data t1 t2 = Tree0.equal comparator.Comparator.compare compare_data t1 t2 ;; let keys t = Tree0.keys t let data t = Tree0.data t let to_alist ?key_order t = Tree0.to_alist ?key_order t let symmetric_diff ~comparator t1 t2 ~data_equal = Tree0.symmetric_diff t1 t2 ~compare_key:comparator.Comparator.compare ~data_equal ;; let fold_symmetric_diff ~comparator t1 t2 ~data_equal ~init ~f = Tree0.fold_symmetric_diff t1 t2 ~compare_key:comparator.Comparator.compare ~data_equal ~init ~f ;; let merge ~comparator t1 t2 ~f = (Tree0.merge t1 t2 ~f ~compare_key:comparator.Comparator.compare).tree ;; let merge_skewed ~comparator t1 t2 ~combine = (* Length computation makes this significantly slower than [merge_skewed] on a map with a [length] field, but does preserve amount of allocation. *) (Tree0.merge_skewed t1 t2 ~length1:(length t1) ~length2:(length t2) ~combine ~compare_key:comparator.Comparator.compare) .tree ;; let min_elt t = Tree0.min_elt t let min_elt_exn t = Tree0.min_elt_exn t let max_elt t = Tree0.max_elt t let max_elt_exn t = Tree0.max_elt_exn t let for_all t ~f = Tree0.for_all t ~f let for_alli t ~f = Tree0.for_alli t ~f let exists t ~f = Tree0.exists t ~f let existsi t ~f = Tree0.existsi t ~f let count t ~f = Tree0.count t ~f let counti t ~f = Tree0.counti t ~f let split ~comparator t k = Tree0.split t k ~compare_key:comparator.Comparator.compare let split_le_gt ~comparator t k = Tree0.split_and_reinsert_boundary t ~into:`Left k ~compare_key:comparator.Comparator.compare ;; let split_lt_ge ~comparator t k = Tree0.split_and_reinsert_boundary t ~into:`Right k ~compare_key:comparator.Comparator.compare ;; let append ~comparator ~lower_part ~upper_part = Tree0.append ~lower_part ~upper_part ~compare_key:comparator.Comparator.compare ;; let subrange ~comparator t ~lower_bound ~upper_bound = let _, ret, _ = Tree0.split_range t ~lower_bound ~upper_bound ~compare_key:comparator.Comparator.compare in ret ;; let fold_range_inclusive ~comparator t ~min ~max ~init ~f = Tree0.fold_range_inclusive t ~min ~max ~init ~f ~compare_key:comparator.Comparator.compare ;; let range_to_alist ~comparator t ~min ~max = Tree0.range_to_alist t ~min ~max ~compare_key:comparator.Comparator.compare ;; let closest_key ~comparator t dir key = Tree0.closest_key t dir key ~compare_key:comparator.Comparator.compare ;; let nth t n = Tree0.nth t n let nth_exn t n = Option.value_exn (nth t n) let rank ~comparator t key = Tree0.rank t key ~compare_key:comparator.Comparator.compare let sexp_of_t sexp_of_k sexp_of_v _ t = Tree0.sexp_of_t sexp_of_k sexp_of_v t let t_of_sexp_direct ~comparator k_of_sexp v_of_sexp sexp = (Tree0.t_of_sexp_direct k_of_sexp v_of_sexp sexp ~comparator).tree ;; let to_sequence ~comparator ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t = Tree0.to_sequence comparator ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t ;; let binary_search ~comparator:_ t ~compare how v = Tree0.binary_search t ~compare how v let binary_search_segmented ~comparator:_ t ~segment_of how = Tree0.binary_search_segmented t ~segment_of how ;; let binary_search_subrange ~comparator t ~compare ~lower_bound ~upper_bound = match Tree0.binary_search_two_sided_bounds t ~compare ~lower_bound ~upper_bound with | Some (lower_bound, upper_bound) -> subrange ~comparator t ~lower_bound ~upper_bound | None -> Empty ;; module Make_applicative_traversals (A : Applicative.Lazy_applicative) = struct module Tree0_traversals = Tree0.Make_applicative_traversals (A) let mapi t ~f = Tree0_traversals.mapi t ~f let filter_mapi t ~f = A.map (Tree0_traversals.filter_mapi t ~f) ~f:(fun (x : ('k, 'v) Tree0.t With_length.t) -> x.tree) ;; end let map_keys ~comparator t ~f = match Tree0.map_keys ~comparator t ~f with | `Ok { tree = t; length = _ } -> `Ok t | `Duplicate_key _ as dup -> dup ;; let map_keys_exn ~comparator t ~f = (Tree0.map_keys_exn ~comparator t ~f).tree (* This calling convention of [~comparator ~comparator] is confusing. It is required because [access_options] and [create_options] both demand a [~comparator] argument in [Map.Using_comparator.Tree]. Making it less confusing would require some unnecessary complexity in signatures. Better to just live with an undesirable interface in a function that will probably never be called directly. *) let transpose_keys ~comparator:outer_comparator ~comparator:inner_comparator t = (Tree0.transpose_keys ~outer_comparator ~inner_comparator t).tree |> map ~f:(fun (x : ('k, 'v) Tree0.t With_length.t) -> x.tree) ;; module Build_increasing = struct type ('k, 'v, 'w) t = ('k, 'v) Tree0.Build_increasing.t let empty = Tree0.Build_increasing.empty let add_exn t ~comparator ~key ~data = match Tree0.Build_increasing.max_key t with | Some prev_key when comparator.Comparator.compare prev_key key >= 0 -> Error.raise_s (Sexp.Atom "Map.Build_increasing.add: non-increasing key") | _ -> Tree0.Build_increasing.add_unchecked t ~key ~data ;; let to_tree t = Tree0.Build_increasing.to_tree_unchecked t end end module Using_comparator = struct type nonrec ('k, 'v, 'cmp) t = ('k, 'v, 'cmp) t include Accessors let empty ~comparator = { tree = Tree0.empty; comparator; length = 0 } let singleton ~comparator k v = { comparator; tree = Tree0.singleton k v; length = 1 } let of_tree0 ~comparator ({ tree; length } : _ With_length.t) = { comparator; tree; length } ;; let of_tree ~comparator tree = of_tree0 ~comparator (with_length tree (Tree0.length tree)) [@nontail] ;; let to_tree = to_tree let of_sorted_array_unchecked ~comparator array = of_tree0 ~comparator (Tree0.of_sorted_array_unchecked array ~compare_key:comparator.Comparator.compare) [@nontail] ;; let of_sorted_array ~comparator array = Or_error.map (Tree0.of_sorted_array array ~compare_key:comparator.Comparator.compare) ~f:(fun tree -> of_tree0 ~comparator tree) ;; let of_alist ~comparator alist = match Tree0.of_alist alist ~compare_key:comparator.Comparator.compare with | `Ok { tree; length } -> `Ok { comparator; tree; length } | `Duplicate_key _ as z -> z ;; let of_alist_or_error ~comparator alist = Result.map (Tree0.of_alist_or_error alist ~comparator) ~f:(fun tree -> of_tree0 ~comparator tree) ;; let of_alist_exn ~comparator alist = of_tree0 ~comparator (Tree0.of_alist_exn alist ~comparator) ;; let of_alist_multi ~comparator alist = of_tree0 ~comparator (Tree0.of_alist_multi alist ~compare_key:comparator.Comparator.compare) ;; let of_alist_fold ~comparator alist ~init ~f = of_tree0 ~comparator (Tree0.of_alist_fold alist ~init ~f ~compare_key:comparator.Comparator.compare) ;; let of_alist_reduce ~comparator alist ~f = of_tree0 ~comparator (Tree0.of_alist_reduce alist ~f ~compare_key:comparator.Comparator.compare) ;; let of_iteri ~comparator ~iteri = match Tree0.of_iteri ~compare_key:comparator.Comparator.compare ~iteri with | `Ok tree_length -> `Ok (of_tree0 ~comparator tree_length) | `Duplicate_key _ as z -> z ;; let of_iteri_exn ~comparator ~iteri = of_tree0 ~comparator (Tree0.of_iteri_exn ~comparator ~iteri) ;; let of_increasing_iterator_unchecked ~comparator ~len ~f = of_tree0 ~comparator (with_length (Tree0.of_increasing_iterator_unchecked ~len ~f) len) [@nontail] ;; let of_increasing_sequence ~comparator seq = Or_error.map ~f:(fun x -> of_tree0 ~comparator x) (Tree0.of_increasing_sequence seq ~compare_key:comparator.Comparator.compare) ;; let of_sequence ~comparator seq = match Tree0.of_sequence seq ~compare_key:comparator.Comparator.compare with | `Ok { tree; length } -> `Ok { comparator; tree; length } | `Duplicate_key _ as z -> z ;; let of_sequence_or_error ~comparator seq = Result.map (Tree0.of_sequence_or_error seq ~comparator) ~f:(fun tree -> of_tree0 ~comparator tree) ;; let of_sequence_exn ~comparator seq = of_tree0 ~comparator (Tree0.of_sequence_exn seq ~comparator) ;; let of_sequence_multi ~comparator seq = of_tree0 ~comparator (Tree0.of_sequence_multi seq ~compare_key:comparator.Comparator.compare) ;; let of_sequence_fold ~comparator seq ~init ~f = of_tree0 ~comparator (Tree0.of_sequence_fold seq ~init ~f ~compare_key:comparator.Comparator.compare) ;; let of_sequence_reduce ~comparator seq ~f = of_tree0 ~comparator (Tree0.of_sequence_reduce seq ~f ~compare_key:comparator.Comparator.compare) ;; let of_list_with_key ~comparator list ~get_key = match Tree0.of_list_with_key list ~get_key ~compare_key:comparator.Comparator.compare with | `Ok { tree; length } -> `Ok { comparator; tree; length } | `Duplicate_key _ as z -> z ;; let of_list_with_key_or_error ~comparator list ~get_key = Result.map (Tree0.of_list_with_key_or_error list ~get_key ~comparator) ~f:(fun tree -> of_tree0 ~comparator tree) ;; let of_list_with_key_exn ~comparator list ~get_key = of_tree0 ~comparator (Tree0.of_list_with_key_exn list ~get_key ~comparator) ;; let of_list_with_key_multi ~comparator list ~get_key = Tree0.of_list_with_key_multi list ~get_key ~compare_key:comparator.Comparator.compare |> of_tree0 ~comparator ;; let t_of_sexp_direct ~comparator k_of_sexp v_of_sexp sexp = of_tree0 ~comparator (Tree0.t_of_sexp_direct k_of_sexp v_of_sexp sexp ~comparator) ;; let map_keys ~comparator t ~f = match Tree0.map_keys t.tree ~f ~comparator with | `Ok pair -> `Ok (of_tree0 ~comparator pair) | `Duplicate_key _ as dup -> dup ;; let map_keys_exn ~comparator t ~f = of_tree0 ~comparator (Tree0.map_keys_exn t.tree ~f ~comparator) ;; let transpose_keys ~comparator:inner_comparator t = let outer_comparator = t.comparator in Tree0.transpose_keys ~outer_comparator ~inner_comparator (Tree0.map t.tree ~f:to_tree) |> of_tree0 ~comparator:inner_comparator |> map ~f:(fun x -> of_tree0 ~comparator:outer_comparator x) ;; module Empty_without_value_restriction (K : Comparator.S1) = struct let empty = { tree = Tree0.empty; comparator = K.comparator; length = 0 } end module Tree = Tree end include Accessors type ('k, 'cmp) comparator = (module Comparator.S with type t = 'k and type comparator_witness = 'cmp) let comparator_s (type k cmp) t : (k, cmp) comparator = (module struct type t = k type comparator_witness = cmp let comparator = t.comparator end) ;; let to_comparator (type k cmp) ((module M) : (k, cmp) comparator) = M.comparator let of_tree (type k cmp) ((module M) : (k, cmp) comparator) tree = of_tree ~comparator:M.comparator tree ;; let empty m = Using_comparator.empty ~comparator:(to_comparator m) let singleton m a = Using_comparator.singleton ~comparator:(to_comparator m) a let of_alist m a = Using_comparator.of_alist ~comparator:(to_comparator m) a let of_alist_or_error m a = Using_comparator.of_alist_or_error ~comparator:(to_comparator m) a ;; let of_alist_exn m a = Using_comparator.of_alist_exn ~comparator:(to_comparator m) a let of_alist_multi m a = Using_comparator.of_alist_multi ~comparator:(to_comparator m) a let of_alist_fold m a ~init ~f = Using_comparator.of_alist_fold ~comparator:(to_comparator m) a ~init ~f ;; let of_alist_reduce m a ~f = Using_comparator.of_alist_reduce ~comparator:(to_comparator m) a ~f ;; let of_sorted_array_unchecked m a = Using_comparator.of_sorted_array_unchecked ~comparator:(to_comparator m) a ;; let of_sorted_array m a = Using_comparator.of_sorted_array ~comparator:(to_comparator m) a let of_iteri m ~iteri = Using_comparator.of_iteri ~iteri ~comparator:(to_comparator m) let of_iteri_exn m ~iteri = Using_comparator.of_iteri_exn ~iteri ~comparator:(to_comparator m) ;; let of_increasing_iterator_unchecked m ~len ~f = Using_comparator.of_increasing_iterator_unchecked ~len ~f ~comparator:(to_comparator m) ;; let of_increasing_sequence m seq = Using_comparator.of_increasing_sequence ~comparator:(to_comparator m) seq ;; let of_sequence m s = Using_comparator.of_sequence ~comparator:(to_comparator m) s let of_sequence_or_error m s = Using_comparator.of_sequence_or_error ~comparator:(to_comparator m) s ;; let of_sequence_exn m s = Using_comparator.of_sequence_exn ~comparator:(to_comparator m) s let of_sequence_multi m s = Using_comparator.of_sequence_multi ~comparator:(to_comparator m) s ;; let of_sequence_fold m s ~init ~f = Using_comparator.of_sequence_fold ~comparator:(to_comparator m) s ~init ~f ;; let of_sequence_reduce m s ~f = Using_comparator.of_sequence_reduce ~comparator:(to_comparator m) s ~f ;; let of_list_with_key m l ~get_key = Using_comparator.of_list_with_key ~comparator:(to_comparator m) l ~get_key ;; let of_list_with_key_or_error m l ~get_key = Using_comparator.of_list_with_key_or_error ~comparator:(to_comparator m) l ~get_key ;; let of_list_with_key_exn m l ~get_key = Using_comparator.of_list_with_key_exn ~comparator:(to_comparator m) l ~get_key ;; let of_list_with_key_multi m l ~get_key = Using_comparator.of_list_with_key_multi ~comparator:(to_comparator m) l ~get_key ;; let map_keys m t ~f = Using_comparator.map_keys ~comparator:(to_comparator m) t ~f let map_keys_exn m t ~f = Using_comparator.map_keys_exn ~comparator:(to_comparator m) t ~f let transpose_keys m t = Using_comparator.transpose_keys ~comparator:(to_comparator m) t module M (K : sig type t type comparator_witness end) = struct type nonrec 'v t = (K.t, 'v, K.comparator_witness) t end module type Sexp_of_m = sig type t [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end module type M_of_sexp = sig type t [@@deriving_inline of_sexp] val t_of_sexp : Sexplib0.Sexp.t -> t [@@@end] include Comparator.S with type t := t end module type M_sexp_grammar = sig type t [@@deriving_inline sexp_grammar] val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] end module type Compare_m = sig end module type Equal_m = sig end module type Hash_fold_m = Hasher.S let sexp_of_m__t (type k) (module K : Sexp_of_m with type t = k) sexp_of_v t = sexp_of_t K.sexp_of_t sexp_of_v (fun _ -> Sexp.Atom "_") t ;; let m__t_of_sexp (type k cmp) (module K : M_of_sexp with type t = k and type comparator_witness = cmp) v_of_sexp sexp = Using_comparator.t_of_sexp_direct ~comparator:K.comparator K.t_of_sexp v_of_sexp sexp ;; let m__t_sexp_grammar (type k) (module K : M_sexp_grammar with type t = k) (v_grammar : _ Sexplib0.Sexp_grammar.t) : _ Sexplib0.Sexp_grammar.t = { untyped = Tagged { key = Sexplib0.Sexp_grammar.assoc_tag ; value = List [] ; grammar = List (Many (List (Cons ( Tagged { key = Sexplib0.Sexp_grammar.assoc_key_tag ; value = List [] ; grammar = K.t_sexp_grammar.untyped } , Cons ( Tagged { key = Sexplib0.Sexp_grammar.assoc_value_tag ; value = List [] ; grammar = v_grammar.untyped } , Empty ) )))) } } ;; let compare_m__t (module _ : Compare_m) compare_v t1 t2 = compare_direct compare_v t1 t2 let equal_m__t (module _ : Equal_m) equal_v t1 t2 = equal equal_v t1 t2 let hash_fold_m__t (type k) (module K : Hash_fold_m with type t = k) hash_fold_v state = hash_fold_direct K.hash_fold_t hash_fold_v state ;; module Poly = struct type nonrec ('k, 'v) t = ('k, 'v, Comparator.Poly.comparator_witness) t type nonrec ('k, 'v) tree = ('k, 'v) Tree0.t type comparator_witness = Comparator.Poly.comparator_witness include Accessors let comparator = Comparator.Poly.comparator let of_tree tree = { tree; comparator; length = Tree0.length tree } include Using_comparator.Empty_without_value_restriction (Comparator.Poly) let singleton a = Using_comparator.singleton ~comparator a let of_alist a = Using_comparator.of_alist ~comparator a let of_alist_or_error a = Using_comparator.of_alist_or_error ~comparator a let of_alist_exn a = Using_comparator.of_alist_exn ~comparator a let of_alist_multi a = Using_comparator.of_alist_multi ~comparator a let of_alist_fold a ~init ~f = Using_comparator.of_alist_fold ~comparator a ~init ~f let of_alist_reduce a ~f = Using_comparator.of_alist_reduce ~comparator a ~f let of_sorted_array_unchecked a = Using_comparator.of_sorted_array_unchecked ~comparator a ;; let of_sorted_array a = Using_comparator.of_sorted_array ~comparator a let of_iteri ~iteri = Using_comparator.of_iteri ~iteri ~comparator let of_iteri_exn ~iteri = Using_comparator.of_iteri_exn ~iteri ~comparator let of_increasing_iterator_unchecked ~len ~f = Using_comparator.of_increasing_iterator_unchecked ~len ~f ~comparator ;; let of_increasing_sequence seq = Using_comparator.of_increasing_sequence ~comparator seq let of_sequence s = Using_comparator.of_sequence ~comparator s let of_sequence_or_error s = Using_comparator.of_sequence_or_error ~comparator s let of_sequence_exn s = Using_comparator.of_sequence_exn ~comparator s let of_sequence_multi s = Using_comparator.of_sequence_multi ~comparator s let of_sequence_fold s ~init ~f = Using_comparator.of_sequence_fold ~comparator s ~init ~f ;; let of_sequence_reduce s ~f = Using_comparator.of_sequence_reduce ~comparator s ~f let of_list_with_key l ~get_key = Using_comparator.of_list_with_key ~comparator l ~get_key ;; let of_list_with_key_or_error l ~get_key = Using_comparator.of_list_with_key_or_error ~comparator l ~get_key ;; let of_list_with_key_exn l ~get_key = Using_comparator.of_list_with_key_exn ~comparator l ~get_key ;; let of_list_with_key_multi l ~get_key = Using_comparator.of_list_with_key_multi ~comparator l ~get_key ;; let map_keys t ~f = Using_comparator.map_keys ~comparator t ~f let map_keys_exn t ~f = Using_comparator.map_keys_exn ~comparator t ~f let transpose_keys t = Using_comparator.transpose_keys ~comparator t end base-0.16.3/src/map.mli000066400000000000000000000000441446274340700145730ustar00rootroot00000000000000include Map_intf.Map (** @inline *) base-0.16.3/src/map_intf.ml000066400000000000000000002054601446274340700154530ustar00rootroot00000000000000open! Import open! T module Or_duplicate = struct type 'a t = [ `Ok of 'a | `Duplicate ] [@@deriving_inline compare, equal, sexp_of] let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = fun _cmp__a a__001_ b__002_ -> if Stdlib.( == ) a__001_ b__002_ then 0 else ( match a__001_, b__002_ with | `Ok _left__003_, `Ok _right__004_ -> _cmp__a _left__003_ _right__004_ | `Duplicate, `Duplicate -> 0 | x, y -> Stdlib.compare x y) ;; let equal : 'a. ('a -> 'a -> bool) -> 'a t -> 'a t -> bool = fun _cmp__a a__005_ b__006_ -> if Stdlib.( == ) a__005_ b__006_ then true else ( match a__005_, b__006_ with | `Ok _left__007_, `Ok _right__008_ -> _cmp__a _left__007_ _right__008_ | `Duplicate, `Duplicate -> true | x, y -> Stdlib.( = ) x y) ;; let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = fun _of_a__009_ -> function | `Ok v__010_ -> Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Ok"; _of_a__009_ v__010_ ] | `Duplicate -> Sexplib0.Sexp.Atom "Duplicate" ;; [@@@end] end module Without_comparator = struct type ('key, 'cmp, 'z) t = 'z end module With_comparator = struct type ('key, 'cmp, 'z) t = comparator:('key, 'cmp) Comparator.t -> 'z end module With_first_class_module = struct type ('key, 'cmp, 'z) t = ('key, 'cmp) Comparator.Module.t -> 'z end module Symmetric_diff_element = struct type ('k, 'v) t = 'k * [ `Left of 'v | `Right of 'v | `Unequal of 'v * 'v ] [@@deriving_inline compare, equal, sexp, sexp_grammar] let compare : 'k 'v. ('k -> 'k -> int) -> ('v -> 'v -> int) -> ('k, 'v) t -> ('k, 'v) t -> int = fun _cmp__k _cmp__v a__011_ b__012_ -> let t__013_, t__014_ = a__011_ in let t__015_, t__016_ = b__012_ in match _cmp__k t__013_ t__015_ with | 0 -> if Stdlib.( == ) t__014_ t__016_ then 0 else ( match t__014_, t__016_ with | `Left _left__017_, `Left _right__018_ -> _cmp__v _left__017_ _right__018_ | `Right _left__019_, `Right _right__020_ -> _cmp__v _left__019_ _right__020_ | `Unequal _left__021_, `Unequal _right__022_ -> let t__023_, t__024_ = _left__021_ in let t__025_, t__026_ = _right__022_ in (match _cmp__v t__023_ t__025_ with | 0 -> _cmp__v t__024_ t__026_ | n -> n) | x, y -> Stdlib.compare x y) | n -> n ;; let equal : 'k 'v. ('k -> 'k -> bool) -> ('v -> 'v -> bool) -> ('k, 'v) t -> ('k, 'v) t -> bool = fun _cmp__k _cmp__v a__027_ b__028_ -> let t__029_, t__030_ = a__027_ in let t__031_, t__032_ = b__028_ in Stdlib.( && ) (_cmp__k t__029_ t__031_) (if Stdlib.( == ) t__030_ t__032_ then true else ( match t__030_, t__032_ with | `Left _left__033_, `Left _right__034_ -> _cmp__v _left__033_ _right__034_ | `Right _left__035_, `Right _right__036_ -> _cmp__v _left__035_ _right__036_ | `Unequal _left__037_, `Unequal _right__038_ -> let t__039_, t__040_ = _left__037_ in let t__041_, t__042_ = _right__038_ in Stdlib.( && ) (_cmp__v t__039_ t__041_) (_cmp__v t__040_ t__042_) | x, y -> Stdlib.( = ) x y)) ;; let t_of_sexp : 'k 'v. (Sexplib0.Sexp.t -> 'k) -> (Sexplib0.Sexp.t -> 'v) -> Sexplib0.Sexp.t -> ('k, 'v) t = let error_source__057_ = "map_intf.ml.Symmetric_diff_element.t" in fun _of_k__043_ _of_v__044_ -> function | Sexplib0.Sexp.List [ arg0__067_; arg1__068_ ] -> let res0__069_ = _of_k__043_ arg0__067_ and res1__070_ = let sexp__066_ = arg1__068_ in try match sexp__066_ with | Sexplib0.Sexp.Atom atom__047_ as _sexp__049_ -> (match atom__047_ with | "Left" -> Sexplib0.Sexp_conv_error.ptag_takes_args error_source__057_ _sexp__049_ | "Right" -> Sexplib0.Sexp_conv_error.ptag_takes_args error_source__057_ _sexp__049_ | "Unequal" -> Sexplib0.Sexp_conv_error.ptag_takes_args error_source__057_ _sexp__049_ | _ -> Sexplib0.Sexp_conv_error.no_variant_match ()) | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom atom__047_ :: sexp_args__050_) as _sexp__049_ -> (match atom__047_ with | "Left" as _tag__063_ -> (match sexp_args__050_ with | [ arg0__064_ ] -> let res0__065_ = _of_v__044_ arg0__064_ in `Left res0__065_ | _ -> Sexplib0.Sexp_conv_error.ptag_incorrect_n_args error_source__057_ _tag__063_ _sexp__049_) | "Right" as _tag__060_ -> (match sexp_args__050_ with | [ arg0__061_ ] -> let res0__062_ = _of_v__044_ arg0__061_ in `Right res0__062_ | _ -> Sexplib0.Sexp_conv_error.ptag_incorrect_n_args error_source__057_ _tag__060_ _sexp__049_) | "Unequal" as _tag__051_ -> (match sexp_args__050_ with | [ arg0__058_ ] -> let res0__059_ = match arg0__058_ with | Sexplib0.Sexp.List [ arg0__052_; arg1__053_ ] -> let res0__054_ = _of_v__044_ arg0__052_ and res1__055_ = _of_v__044_ arg1__053_ in res0__054_, res1__055_ | sexp__056_ -> Sexplib0.Sexp_conv_error.tuple_of_size_n_expected error_source__057_ 2 sexp__056_ in `Unequal res0__059_ | _ -> Sexplib0.Sexp_conv_error.ptag_incorrect_n_args error_source__057_ _tag__051_ _sexp__049_) | _ -> Sexplib0.Sexp_conv_error.no_variant_match ()) | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__048_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_poly_var error_source__057_ sexp__048_ | Sexplib0.Sexp.List [] as sexp__048_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_poly_var error_source__057_ sexp__048_ with | Sexplib0.Sexp_conv_error.No_variant_match -> Sexplib0.Sexp_conv_error.no_matching_variant_found error_source__057_ sexp__066_ in res0__069_, res1__070_ | sexp__071_ -> Sexplib0.Sexp_conv_error.tuple_of_size_n_expected error_source__057_ 2 sexp__071_ ;; let sexp_of_t : 'k 'v. ('k -> Sexplib0.Sexp.t) -> ('v -> Sexplib0.Sexp.t) -> ('k, 'v) t -> Sexplib0.Sexp.t = fun _of_k__072_ _of_v__073_ (arg0__081_, arg1__082_) -> let res0__083_ = _of_k__072_ arg0__081_ and res1__084_ = match arg1__082_ with | `Left v__074_ -> Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Left"; _of_v__073_ v__074_ ] | `Right v__075_ -> Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Right"; _of_v__073_ v__075_ ] | `Unequal v__076_ -> Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Unequal" ; (let arg0__077_, arg1__078_ = v__076_ in let res0__079_ = _of_v__073_ arg0__077_ and res1__080_ = _of_v__073_ arg1__078_ in Sexplib0.Sexp.List [ res0__079_; res1__080_ ]) ] in Sexplib0.Sexp.List [ res0__083_; res1__084_ ] ;; let t_sexp_grammar : 'k 'v. 'k Sexplib0.Sexp_grammar.t -> 'v Sexplib0.Sexp_grammar.t -> ('k, 'v) t Sexplib0.Sexp_grammar.t = fun _'k_sexp_grammar _'v_sexp_grammar -> { untyped = List (Cons ( _'k_sexp_grammar.untyped , Cons ( Variant { case_sensitivity = Case_sensitive ; clauses = [ No_tag { name = "Left" ; clause_kind = List_clause { args = Cons (_'v_sexp_grammar.untyped, Empty) } } ; No_tag { name = "Right" ; clause_kind = List_clause { args = Cons (_'v_sexp_grammar.untyped, Empty) } } ; No_tag { name = "Unequal" ; clause_kind = List_clause { args = Cons ( List (Cons ( _'v_sexp_grammar.untyped , Cons (_'v_sexp_grammar.untyped, Empty) )) , Empty ) } } ] } , Empty ) )) } ;; [@@@end] end module Merge_element = struct type ('left, 'right) t = [ `Left of 'left | `Right of 'right | `Both of 'left * 'right ] [@@deriving_inline compare, equal, sexp_of] let compare : 'left 'right. ('left -> 'left -> int) -> ('right -> 'right -> int) -> ('left, 'right) t -> ('left, 'right) t -> int = fun _cmp__left _cmp__right a__085_ b__086_ -> if Stdlib.( == ) a__085_ b__086_ then 0 else ( match a__085_, b__086_ with | `Left _left__087_, `Left _right__088_ -> _cmp__left _left__087_ _right__088_ | `Right _left__089_, `Right _right__090_ -> _cmp__right _left__089_ _right__090_ | `Both _left__091_, `Both _right__092_ -> let t__093_, t__094_ = _left__091_ in let t__095_, t__096_ = _right__092_ in (match _cmp__left t__093_ t__095_ with | 0 -> _cmp__right t__094_ t__096_ | n -> n) | x, y -> Stdlib.compare x y) ;; let equal : 'left 'right. ('left -> 'left -> bool) -> ('right -> 'right -> bool) -> ('left, 'right) t -> ('left, 'right) t -> bool = fun _cmp__left _cmp__right a__097_ b__098_ -> if Stdlib.( == ) a__097_ b__098_ then true else ( match a__097_, b__098_ with | `Left _left__099_, `Left _right__100_ -> _cmp__left _left__099_ _right__100_ | `Right _left__101_, `Right _right__102_ -> _cmp__right _left__101_ _right__102_ | `Both _left__103_, `Both _right__104_ -> let t__105_, t__106_ = _left__103_ in let t__107_, t__108_ = _right__104_ in Stdlib.( && ) (_cmp__left t__105_ t__107_) (_cmp__right t__106_ t__108_) | x, y -> Stdlib.( = ) x y) ;; let sexp_of_t : 'left 'right. ('left -> Sexplib0.Sexp.t) -> ('right -> Sexplib0.Sexp.t) -> ('left, 'right) t -> Sexplib0.Sexp.t = fun _of_left__109_ _of_right__110_ -> function | `Left v__111_ -> Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Left"; _of_left__109_ v__111_ ] | `Right v__112_ -> Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Right"; _of_right__110_ v__112_ ] | `Both v__113_ -> Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Both" ; (let arg0__114_, arg1__115_ = v__113_ in let res0__116_ = _of_left__109_ arg0__114_ and res1__117_ = _of_right__110_ arg1__115_ in Sexplib0.Sexp.List [ res0__116_; res1__117_ ]) ] ;; [@@@end] end (** @canonical Base.Map.Continue_or_stop *) module Continue_or_stop = struct type t = | Continue | Stop [@@deriving_inline compare, enumerate, equal, sexp_of] let compare = (Stdlib.compare : t -> t -> int) let all = ([ Continue; Stop ] : t list) let equal = (Stdlib.( = ) : t -> t -> bool) let sexp_of_t = (function | Continue -> Sexplib0.Sexp.Atom "Continue" | Stop -> Sexplib0.Sexp.Atom "Stop" : t -> Sexplib0.Sexp.t) ;; [@@@end] end (** @canonical Base.Map.Finished_or_unfinished *) module Finished_or_unfinished = struct type t = | Finished | Unfinished [@@deriving_inline compare, enumerate, equal, sexp_of] let compare = (Stdlib.compare : t -> t -> int) let all = ([ Finished; Unfinished ] : t list) let equal = (Stdlib.( = ) : t -> t -> bool) let sexp_of_t = (function | Finished -> Sexplib0.Sexp.Atom "Finished" | Unfinished -> Sexplib0.Sexp.Atom "Unfinished" : t -> Sexplib0.Sexp.t) ;; [@@@end] end module type Accessors_generic = sig type ('a, 'b, 'cmp) t type ('a, 'b, 'cmp) tree type 'a key type 'cmp cmp type ('a, 'cmp, 'z) access_options val invariants : ('k, 'cmp, ('k, 'v, 'cmp) t -> bool) access_options val is_empty : (_, _, _) t -> bool val length : (_, _, _) t -> int val add : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> key:'k key -> data:'v -> ('k, 'v, 'cmp) t Or_duplicate.t ) access_options val add_exn : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> key:'k key -> data:'v -> ('k, 'v, 'cmp) t ) access_options val set : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> key:'k key -> data:'v -> ('k, 'v, 'cmp) t ) access_options val add_multi : ( 'k , 'cmp , ('k, 'v list, 'cmp) t -> key:'k key -> data:'v -> ('k, 'v list, 'cmp) t ) access_options val remove_multi : ('k, 'cmp, ('k, 'v list, 'cmp) t -> 'k key -> ('k, 'v list, 'cmp) t) access_options val find_multi : ('k, 'cmp, ('k, 'v list, 'cmp) t -> 'k key -> 'v list) access_options val change : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> 'k key -> f:(('v option -> 'v option)[@local]) -> ('k, 'v, 'cmp) t ) access_options val update : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> 'k key -> f:(('v option -> 'v)[@local]) -> ('k, 'v, 'cmp) t ) access_options val find : ('k, 'cmp, ('k, 'v, 'cmp) t -> 'k key -> 'v option) access_options val find_exn : ('k, 'cmp, ('k, 'v, 'cmp) t -> 'k key -> 'v) access_options val remove : ('k, 'cmp, ('k, 'v, 'cmp) t -> 'k key -> ('k, 'v, 'cmp) t) access_options val mem : ('k, 'cmp, ('k, _, 'cmp) t -> 'k key -> bool) access_options val iter_keys : ('k, _, _) t -> f:(('k key -> unit)[@local]) -> unit val iter : (_, 'v, _) t -> f:(('v -> unit)[@local]) -> unit val iteri : ('k, 'v, _) t -> f:((key:'k key -> data:'v -> unit)[@local]) -> unit val iteri_until : ('k, 'v, _) t -> f:((key:'k key -> data:'v -> Continue_or_stop.t)[@local]) -> Finished_or_unfinished.t val iter2 : ( 'k , 'cmp , ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t -> f:((key:'k key -> data:('v1, 'v2) Merge_element.t -> unit)[@local]) -> unit ) access_options val map : ('k, 'v1, 'cmp) t -> f:(('v1 -> 'v2)[@local]) -> ('k, 'v2, 'cmp) t val mapi : ('k, 'v1, 'cmp) t -> f:((key:'k key -> data:'v1 -> 'v2)[@local]) -> ('k, 'v2, 'cmp) t val fold : ('k, 'v, _) t -> init:'acc -> f:((key:'k key -> data:'v -> 'acc -> 'acc)[@local]) -> 'acc val fold_until : ('k, 'v, _) t -> init:'acc -> f: ((key:'k key -> data:'v -> 'acc -> ('acc, 'final) Container.Continue_or_stop.t) [@local]) -> finish:(('acc -> 'final)[@local]) -> 'final val fold_right : ('k, 'v, _) t -> init:'acc -> f:((key:'k key -> data:'v -> 'acc -> 'acc)[@local]) -> 'acc val fold2 : ( 'k , 'cmp , ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t -> init:'acc -> f:((key:'k key -> data:('v1, 'v2) Merge_element.t -> 'acc -> 'acc)[@local]) -> 'acc ) access_options val filter_keys : ('k, 'v, 'cmp) t -> f:(('k key -> bool)[@local]) -> ('k, 'v, 'cmp) t val filter : ('k, 'v, 'cmp) t -> f:(('v -> bool)[@local]) -> ('k, 'v, 'cmp) t val filteri : ('k, 'v, 'cmp) t -> f:((key:'k key -> data:'v -> bool)[@local]) -> ('k, 'v, 'cmp) t val filter_map : ('k, 'v1, 'cmp) t -> f:(('v1 -> 'v2 option)[@local]) -> ('k, 'v2, 'cmp) t val filter_mapi : ('k, 'v1, 'cmp) t -> f:((key:'k key -> data:'v1 -> 'v2 option)[@local]) -> ('k, 'v2, 'cmp) t val partition_mapi : ('k, 'v1, 'cmp) t -> f:((key:'k key -> data:'v1 -> ('v2, 'v3) Either.t)[@local]) -> ('k, 'v2, 'cmp) t * ('k, 'v3, 'cmp) t val partition_map : ('k, 'v1, 'cmp) t -> f:(('v1 -> ('v2, 'v3) Either.t)[@local]) -> ('k, 'v2, 'cmp) t * ('k, 'v3, 'cmp) t val partitioni_tf : ('k, 'v, 'cmp) t -> f:((key:'k key -> data:'v -> bool)[@local]) -> ('k, 'v, 'cmp) t * ('k, 'v, 'cmp) t val partition_tf : ('k, 'v, 'cmp) t -> f:(('v -> bool)[@local]) -> ('k, 'v, 'cmp) t * ('k, 'v, 'cmp) t val combine_errors : ( 'k , 'cmp , ('k, 'v Or_error.t, 'cmp) t -> ('k, 'v, 'cmp) t Or_error.t ) access_options val compare_direct : ( 'k , 'cmp , ('v -> 'v -> int) -> ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> int ) access_options val equal : ( 'k , 'cmp , ('v -> 'v -> bool) -> ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> bool ) access_options val keys : ('k, _, _) t -> 'k key list val data : (_, 'v, _) t -> 'v list val to_alist : ?key_order:[ `Increasing | `Decreasing ] -> ('k, 'v, _) t -> ('k key * 'v) list val merge : ( 'k , 'cmp , ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t -> f:((key:'k key -> ('v1, 'v2) Merge_element.t -> 'v3 option)[@local]) -> ('k, 'v3, 'cmp) t ) access_options val merge_skewed : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> combine:((key:'k key -> 'v -> 'v -> 'v)[@local]) -> ('k, 'v, 'cmp) t ) access_options val symmetric_diff : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> data_equal:('v -> 'v -> bool) -> ('k key, 'v) Symmetric_diff_element.t Sequence.t ) access_options val fold_symmetric_diff : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> data_equal:(('v -> 'v -> bool)[@local]) -> init:'acc -> f:(('acc -> ('k key, 'v) Symmetric_diff_element.t -> 'acc)[@local]) -> 'acc ) access_options val min_elt : ('k, 'v, _) t -> ('k key * 'v) option val min_elt_exn : ('k, 'v, _) t -> 'k key * 'v val max_elt : ('k, 'v, _) t -> ('k key * 'v) option val max_elt_exn : ('k, 'v, _) t -> 'k key * 'v val for_all : ('k, 'v, _) t -> f:(('v -> bool)[@local]) -> bool val for_alli : ('k, 'v, _) t -> f:((key:'k key -> data:'v -> bool)[@local]) -> bool val exists : ('k, 'v, _) t -> f:(('v -> bool)[@local]) -> bool val existsi : ('k, 'v, _) t -> f:((key:'k key -> data:'v -> bool)[@local]) -> bool val count : ('k, 'v, _) t -> f:(('v -> bool)[@local]) -> int val counti : ('k, 'v, _) t -> f:((key:'k key -> data:'v -> bool)[@local]) -> int val split : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> 'k key -> ('k, 'v, 'cmp) t * ('k key * 'v) option * ('k, 'v, 'cmp) t ) access_options val split_le_gt : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> 'k key -> ('k, 'v, 'cmp) t * ('k, 'v, 'cmp) t ) access_options val split_lt_ge : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> 'k key -> ('k, 'v, 'cmp) t * ('k, 'v, 'cmp) t ) access_options val append : ( 'k , 'cmp , lower_part:('k, 'v, 'cmp) t -> upper_part:('k, 'v, 'cmp) t -> [ `Ok of ('k, 'v, 'cmp) t | `Overlapping_key_ranges ] ) access_options val subrange : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> lower_bound:'k key Maybe_bound.t -> upper_bound:'k key Maybe_bound.t -> ('k, 'v, 'cmp) t ) access_options val fold_range_inclusive : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> min:'k key -> max:'k key -> init:'acc -> f:((key:'k key -> data:'v -> 'acc -> 'acc)[@local]) -> 'acc ) access_options val range_to_alist : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> min:'k key -> max:'k key -> ('k key * 'v) list ) access_options val closest_key : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> [ `Greater_or_equal_to | `Greater_than | `Less_or_equal_to | `Less_than ] -> 'k key -> ('k key * 'v) option ) access_options val nth : ('k, 'v, 'cmp) t -> int -> ('k key * 'v) option val nth_exn : ('k, 'v, 'cmp) t -> int -> 'k key * 'v val rank : ('k, 'cmp, ('k, _, 'cmp) t -> 'k key -> int option) access_options val to_tree : ('k, 'v, 'cmp) t -> ('k key, 'v, 'cmp) tree val to_sequence : ( 'k , 'cmp , ?order:[ `Increasing_key | `Decreasing_key ] -> ?keys_greater_or_equal_to:'k key -> ?keys_less_or_equal_to:'k key -> ('k, 'v, 'cmp) t -> ('k key * 'v) Sequence.t ) access_options val binary_search : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> compare:((key:'k key -> data:'v -> 'key -> int)[@local]) -> Binary_searchable.Which_target_by_key.t -> 'key -> ('k key * 'v) option ) access_options val binary_search_segmented : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> segment_of:((key:'k key -> data:'v -> [ `Left | `Right ])[@local]) -> Binary_searchable.Which_target_by_segment.t -> ('k key * 'v) option ) access_options val binary_search_subrange : ( 'k , 'cmp , ('k, 'v, 'cmp) t -> compare:((key:'k key -> data:'v -> 'bound -> int)[@local]) -> lower_bound:'bound Maybe_bound.t -> upper_bound:'bound Maybe_bound.t -> ('k, 'v, 'cmp) t ) access_options module Make_applicative_traversals (A : Applicative.Lazy_applicative) : sig val mapi : ('k, 'v1, 'cmp) t -> f:(key:'k key -> data:'v1 -> 'v2 A.t) -> ('k, 'v2, 'cmp) t A.t val filter_mapi : ('k, 'v1, 'cmp) t -> f:(key:'k key -> data:'v1 -> 'v2 option A.t) -> ('k, 'v2, 'cmp) t A.t end end module type Creators_generic = sig type ('k, 'v, 'cmp) t type ('k, 'v, 'cmp) tree type 'k key type ('a, 'cmp, 'z) create_options type ('a, 'cmp, 'z) access_options type 'cmp cmp val empty : ('k, 'cmp, ('k, _, 'cmp) t) create_options val singleton : ('k, 'cmp, 'k key -> 'v -> ('k, 'v, 'cmp) t) create_options val map_keys : ( 'k2 , 'cmp2 , ('k1, 'v, 'cmp1) t -> f:(('k1 key -> 'k2 key)[@local]) -> [ `Ok of ('k2, 'v, 'cmp2) t | `Duplicate_key of 'k2 key ] ) create_options val map_keys_exn : ( 'k2 , 'cmp2 , ('k1, 'v, 'cmp1) t -> f:(('k1 key -> 'k2 key)[@local]) -> ('k2, 'v, 'cmp2) t ) create_options val transpose_keys : ( 'k1 , 'cmp1 , ( 'k2 , 'cmp2 , ('k1, ('k2, 'a, 'cmp2) t, 'cmp1) t -> ('k2, ('k1, 'a, 'cmp1) t, 'cmp2) t ) create_options ) access_options val of_sorted_array : ('k, 'cmp, ('k key * 'v) array -> ('k, 'v, 'cmp) t Or_error.t) create_options val of_sorted_array_unchecked : ('k, 'cmp, ('k key * 'v) array -> ('k, 'v, 'cmp) t) create_options val of_increasing_iterator_unchecked : ( 'k , 'cmp , len:int -> f:((int -> 'k key * 'v)[@local]) -> ('k, 'v, 'cmp) t ) create_options val of_alist : ( 'k , 'cmp , ('k key * 'v) list -> [ `Ok of ('k, 'v, 'cmp) t | `Duplicate_key of 'k key ] ) create_options val of_alist_or_error : ('k, 'cmp, ('k key * 'v) list -> ('k, 'v, 'cmp) t Or_error.t) create_options val of_alist_exn : ('k, 'cmp, ('k key * 'v) list -> ('k, 'v, 'cmp) t) create_options val of_alist_multi : ('k, 'cmp, ('k key * 'v) list -> ('k, 'v list, 'cmp) t) create_options val of_alist_fold : ( 'k , 'cmp , ('k key * 'v1) list -> init:'v2 -> f:(('v2 -> 'v1 -> 'v2)[@local]) -> ('k, 'v2, 'cmp) t ) create_options val of_alist_reduce : ( 'k , 'cmp , ('k key * 'v) list -> f:(('v -> 'v -> 'v)[@local]) -> ('k, 'v, 'cmp) t ) create_options val of_increasing_sequence : ('k, 'cmp, ('k key * 'v) Sequence.t -> ('k, 'v, 'cmp) t Or_error.t) create_options val of_sequence : ( 'k , 'cmp , ('k key * 'v) Sequence.t -> [ `Ok of ('k, 'v, 'cmp) t | `Duplicate_key of 'k key ] ) create_options val of_sequence_or_error : ('k, 'cmp, ('k key * 'v) Sequence.t -> ('k, 'v, 'cmp) t Or_error.t) create_options val of_sequence_exn : ('k, 'cmp, ('k key * 'v) Sequence.t -> ('k, 'v, 'cmp) t) create_options val of_sequence_multi : ('k, 'cmp, ('k key * 'v) Sequence.t -> ('k, 'v list, 'cmp) t) create_options val of_sequence_fold : ( 'k , 'cmp , ('k key * 'v1) Sequence.t -> init:'v2 -> f:(('v2 -> 'v1 -> 'v2)[@local]) -> ('k, 'v2, 'cmp) t ) create_options val of_sequence_reduce : ( 'k , 'cmp , ('k key * 'v) Sequence.t -> f:(('v -> 'v -> 'v)[@local]) -> ('k, 'v, 'cmp) t ) create_options val of_list_with_key : ( 'k , 'cmp , 'v list -> get_key:(('v -> 'k key)[@local]) -> [ `Ok of ('k, 'v, 'cmp) t | `Duplicate_key of 'k key ] ) create_options val of_list_with_key_or_error : ( 'k , 'cmp , 'v list -> get_key:(('v -> 'k key)[@local]) -> ('k, 'v, 'cmp) t Or_error.t ) create_options val of_list_with_key_exn : ( 'k , 'cmp , 'v list -> get_key:(('v -> 'k key)[@local]) -> ('k, 'v, 'cmp) t ) create_options val of_list_with_key_multi : ( 'k , 'cmp , 'v list -> get_key:(('v -> 'k key)[@local]) -> ('k, 'v list, 'cmp) t ) create_options val of_iteri : ( 'k , 'cmp , iteri:((f:((key:'k key -> data:'v -> unit)[@local]) -> unit)[@local]) -> [ `Ok of ('k, 'v, 'cmp) t | `Duplicate_key of 'k key ] ) create_options val of_iteri_exn : ( 'k , 'cmp , iteri:((f:((key:'k key -> data:'v -> unit)[@local]) -> unit)[@local]) -> ('k, 'v, 'cmp) t ) create_options val of_tree : ('k, 'cmp, ('k key, 'v, 'cmp) tree -> ('k, 'v, 'cmp) t) create_options end module type Creators_and_accessors_generic = sig type ('a, 'b, 'c) t type ('a, 'b, 'c) tree type 'a key type 'a cmp type ('a, 'b, 'c) create_options type ('a, 'b, 'c) access_options include Creators_generic with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) tree with type 'a key := 'a key with type 'a cmp := 'a cmp with type ('a, 'b, 'c) create_options := ('a, 'b, 'c) create_options with type ('a, 'b, 'c) access_options := ('a, 'b, 'c) access_options include Accessors_generic with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) tree with type 'a key := 'a key with type 'a cmp := 'a cmp with type ('a, 'b, 'c) access_options := ('a, 'b, 'c) access_options end module type S_poly = sig type ('a, 'b) t type ('a, 'b) tree type comparator_witness include Creators_and_accessors_generic with type ('a, 'b, 'c) t := ('a, 'b) t with type ('a, 'b, 'c) tree := ('a, 'b) tree with type 'k key := 'k with type 'c cmp := comparator_witness with type ('a, 'b, 'c) create_options := ('a, 'b, 'c) Without_comparator.t with type ('a, 'b, 'c) access_options := ('a, 'b, 'c) Without_comparator.t end module type For_deriving = sig type ('a, 'b, 'c) t module type Sexp_of_m = sig type t [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end module type M_of_sexp = sig type t [@@deriving_inline of_sexp] val t_of_sexp : Sexplib0.Sexp.t -> t [@@@end] include Comparator.S with type t := t end module type M_sexp_grammar = sig type t [@@deriving_inline sexp_grammar] val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] end module type Compare_m = sig end module type Equal_m = sig end module type Hash_fold_m = Hasher.S val sexp_of_m__t : (module Sexp_of_m with type t = 'k) -> ('v -> Sexp.t) -> ('k, 'v, 'cmp) t -> Sexp.t val m__t_of_sexp : (module M_of_sexp with type t = 'k and type comparator_witness = 'cmp) -> (Sexp.t -> 'v) -> Sexp.t -> ('k, 'v, 'cmp) t val m__t_sexp_grammar : (module M_sexp_grammar with type t = 'k) -> 'v Sexplib0.Sexp_grammar.t -> ('k, 'v, 'cmp) t Sexplib0.Sexp_grammar.t val compare_m__t : (module Compare_m) -> ('v -> 'v -> int) -> ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> int val equal_m__t : (module Equal_m) -> ('v -> 'v -> bool) -> ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> bool val hash_fold_m__t : (module Hash_fold_m with type t = 'k) -> (Hash.state -> 'v -> Hash.state) -> Hash.state -> ('k, 'v, _) t -> Hash.state end module type Map = sig (** [Map] is a functional data structure (balanced binary tree) implementing finite maps over a totally-ordered domain, called a "key". *) type (!'key, +!'value, !'cmp) t module Or_duplicate = Or_duplicate module Continue_or_stop = Continue_or_stop module Finished_or_unfinished : sig type t = Finished_or_unfinished.t = | Finished | Unfinished [@@deriving_inline compare, enumerate, equal, sexp_of] include Ppx_compare_lib.Comparable.S with type t := t include Ppx_enumerate_lib.Enumerable.S with type t := t include Ppx_compare_lib.Equal.S with type t := t val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] (** Maps [Continue] to [Finished] and [Stop] to [Unfinished]. *) val of_continue_or_stop : Continue_or_stop.t -> t (** Maps [Finished] to [Continue] and [Unfinished] to [Stop]. *) val to_continue_or_stop : t -> Continue_or_stop.t end module Merge_element : sig type ('left, 'right) t = [ `Left of 'left | `Right of 'right | `Both of 'left * 'right ] [@@deriving_inline compare, equal, sexp_of] val compare : ('left -> 'left -> int) -> ('right -> 'right -> int) -> ('left, 'right) t -> ('left, 'right) t -> int val equal : ('left -> 'left -> bool) -> ('right -> 'right -> bool) -> ('left, 'right) t -> ('left, 'right) t -> bool val sexp_of_t : ('left -> Sexplib0.Sexp.t) -> ('right -> Sexplib0.Sexp.t) -> ('left, 'right) t -> Sexplib0.Sexp.t [@@@end] val left : ('left, _) t -> 'left option val right : (_, 'right) t -> 'right option val left_value : ('left, _) t -> default:'left -> 'left val right_value : (_, 'right) t -> default:'right -> 'right val values : ('left, 'right) t -> left_default:'left -> right_default:'right -> 'left * 'right end type ('k, 'cmp) comparator = ('k, 'cmp) Comparator.Module.t [@@deprecated "[since 2021-12] use [Comparator.Module.t] instead"] (** Test if the invariants of the internal AVL search tree hold. *) val invariants : (_, _, _) t -> bool (** Returns a first-class module that can be used to build other map/set/etc. with the same notion of comparison. *) val comparator_s : ('a, _, 'cmp) t -> ('a, 'cmp) Comparator.Module.t val comparator : ('a, _, 'cmp) t -> ('a, 'cmp) Comparator.t (** The empty map. *) val empty : ('a, 'cmp) Comparator.Module.t -> ('a, 'b, 'cmp) t (** A map with one (key, data) pair. *) val singleton : ('a, 'cmp) Comparator.Module.t -> 'a -> 'b -> ('a, 'b, 'cmp) t (** Creates a map from an association list with unique keys. *) val of_alist : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) list -> [ `Ok of ('a, 'b, 'cmp) t | `Duplicate_key of 'a ] (** Creates a map from an association list with unique keys, returning an error if duplicate ['a] keys are found. *) val of_alist_or_error : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) list -> ('a, 'b, 'cmp) t Or_error.t (** Creates a map from an association list with unique keys, raising an exception if duplicate ['a] keys are found. *) val of_alist_exn : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) list -> ('a, 'b, 'cmp) t (** Creates a map from an association list with possibly repeated keys. The values in the map for a given key appear in the same order as they did in the association list. *) val of_alist_multi : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) list -> ('a, 'b list, 'cmp) t (** Combines an association list into a map, folding together bound values with common keys. The accumulator is per-key. Example: {[ # let map = String.Map.of_alist_fold [ "a", 1; "a", 10; "b", 2; "b", 20; "b", 200 ] ~init:Int.Set.empty ~f:Set.add in print_s [%sexp (map : Int.Set.t String.Map.t)];; ((a (1 10)) (b (2 20 200))) - : unit = () ]} *) val of_alist_fold : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) list -> init:'c -> f:(('c -> 'b -> 'c)[@local]) -> ('a, 'c, 'cmp) t (** Combines an association list into a map, reducing together bound values with common keys. *) val of_alist_reduce : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) list -> f:(('b -> 'b -> 'b)[@local]) -> ('a, 'b, 'cmp) t (** [of_iteri ~iteri] behaves like [of_alist], except that instead of taking a concrete data structure, it takes an iteration function. For instance, to convert a string table into a map: [of_iteri (module String) ~f:(Hashtbl.iteri table)]. It is faster than adding the elements one by one. *) val of_iteri : ('a, 'cmp) Comparator.Module.t -> iteri:((f:((key:'a -> data:'b -> unit)[@local]) -> unit)[@local]) -> [ `Ok of ('a, 'b, 'cmp) t | `Duplicate_key of 'a ] (** Like [of_iteri] except that it raises an exception if duplicate ['a] keys are found. *) val of_iteri_exn : ('a, 'cmp) Comparator.Module.t -> iteri:((f:((key:'a -> data:'b -> unit)[@local]) -> unit)[@local]) -> ('a, 'b, 'cmp) t (** Creates a map from a sorted array of key-data pairs. The input array must be sorted (either in ascending or descending order), as given by the relevant comparator, and must not contain duplicate keys. If either of these conditions does not hold, an error is returned. *) val of_sorted_array : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) array -> ('a, 'b, 'cmp) t Or_error.t (** Like [of_sorted_array] except that it returns a map with broken invariants when an [Error] would have been returned. *) val of_sorted_array_unchecked : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) array -> ('a, 'b, 'cmp) t (** [of_increasing_iterator_unchecked c ~len ~f] behaves like [of_sorted_array_unchecked c (Array.init len ~f)], with the additional restriction that a decreasing order is not supported. The advantage is not requiring you to allocate an intermediate array. [f] will be called with 0, 1, ... [len - 1], in order. *) val of_increasing_iterator_unchecked : ('a, 'cmp) Comparator.Module.t -> len:int -> f:((int -> 'a * 'b)[@local]) -> ('a, 'b, 'cmp) t (** [of_increasing_sequence c seq] behaves like [of_sorted_array c (Sequence.to_array seq)], but does not allocate the intermediate array. The sequence will be folded over once, and the additional time complexity is {e O(n)}. *) val of_increasing_sequence : ('k, 'cmp) Comparator.Module.t -> ('k * 'v) Sequence.t -> ('k, 'v, 'cmp) t Or_error.t (** Creates a map from an association sequence with unique keys. [of_sequence c seq] behaves like [of_alist c (Sequence.to_list seq)] but does not allocate the intermediate list. If your sequence is increasing, use [of_increasing_sequence]. *) val of_sequence : ('k, 'cmp) Comparator.Module.t -> ('k * 'v) Sequence.t -> [ `Ok of ('k, 'v, 'cmp) t | `Duplicate_key of 'k ] (** Creates a map from an association sequence with unique keys, returning an error if duplicate ['a] keys are found. [of_sequence_or_error c seq] behaves like [of_alist_or_error c (Sequence.to_list seq)] but does not allocate the intermediate list. *) val of_sequence_or_error : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) Sequence.t -> ('a, 'b, 'cmp) t Or_error.t (** Creates a map from an association sequence with unique keys, raising an exception if duplicate ['a] keys are found. [of_sequence_exn c seq] behaves like [of_alist_exn c (Sequence.to_list seq)] but does not allocate the intermediate list. *) val of_sequence_exn : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) Sequence.t -> ('a, 'b, 'cmp) t (** Creates a map from an association sequence with possibly repeated keys. The values in the map for a given key appear in the same order as they did in the association list. [of_sequence_multi c seq] behaves like [of_alist_exn c (Sequence.to_list seq)] but does not allocate the intermediate list. *) val of_sequence_multi : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) Sequence.t -> ('a, 'b list, 'cmp) t (** Combines an association sequence into a map, folding together bound values with common keys. [of_sequence_fold c seq ~init ~f] behaves like [of_alist_fold c (Sequence.to_list seq) ~init ~f] but does not allocate the intermediate list. *) val of_sequence_fold : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) Sequence.t -> init:'c -> f:(('c -> 'b -> 'c)[@local]) -> ('a, 'c, 'cmp) t (** Combines an association sequence into a map, reducing together bound values with common keys. [of_sequence_reduce c seq ~f] behaves like [of_alist_reduce c (Sequence.to_list seq) ~f] but does not allocate the intermediate list. *) val of_sequence_reduce : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) Sequence.t -> f:(('b -> 'b -> 'b)[@local]) -> ('a, 'b, 'cmp) t (** Constructs a map from a list of values, where [get_key] extracts a key from a value. *) val of_list_with_key : ('k, 'cmp) Comparator.Module.t -> 'v list -> get_key:(('v -> 'k)[@local]) -> [ `Ok of ('k, 'v, 'cmp) t | `Duplicate_key of 'k ] (** Like [of_list_with_key]; returns [Error] on duplicate key. *) val of_list_with_key_or_error : ('k, 'cmp) Comparator.Module.t -> 'v list -> get_key:(('v -> 'k)[@local]) -> ('k, 'v, 'cmp) t Or_error.t (** Like [of_list_with_key]; raises on duplicate key. *) val of_list_with_key_exn : ('k, 'cmp) Comparator.Module.t -> 'v list -> get_key:(('v -> 'k)[@local]) -> ('k, 'v, 'cmp) t (** Like [of_list_with_key]; produces lists of all values associated with each key. *) val of_list_with_key_multi : ('k, 'cmp) Comparator.Module.t -> 'v list -> get_key:(('v -> 'k)[@local]) -> ('k, 'v list, 'cmp) t (** Tests whether a map is empty. *) val is_empty : (_, _, _) t -> bool (** [length map] returns the number of elements in [map]. O(1), but [Tree.length] is O(n). *) val length : (_, _, _) t -> int (** Returns a new map with the specified new binding; if the key was already bound, its previous binding disappears. *) val set : ('k, 'v, 'cmp) t -> key:'k -> data:'v -> ('k, 'v, 'cmp) t (** [add t ~key ~data] adds a new entry to [t] mapping [key] to [data] and returns [`Ok] with the new map, or if [key] is already present in [t], returns [`Duplicate]. *) val add : ('k, 'v, 'cmp) t -> key:'k -> data:'v -> ('k, 'v, 'cmp) t Or_duplicate.t val add_exn : ('k, 'v, 'cmp) t -> key:'k -> data:'v -> ('k, 'v, 'cmp) t (** If [key] is not present then add a singleton list, otherwise, cons data onto the head of the existing list. *) val add_multi : ('k, 'v list, 'cmp) t -> key:'k -> data:'v -> ('k, 'v list, 'cmp) t (** If the key is present, then remove its head element; if the result is empty, remove the key. *) val remove_multi : ('k, 'v list, 'cmp) t -> 'k -> ('k, 'v list, 'cmp) t (** Returns the value bound to the given key, or the empty list if there is none. *) val find_multi : ('k, 'v list, 'cmp) t -> 'k -> 'v list (** [change t key ~f] returns a new map [m] that is the same as [t] on all keys except for [key], and whose value for [key] is defined by [f], i.e., [find m key = f (find t key)]. *) val change : ('k, 'v, 'cmp) t -> 'k -> f:(('v option -> 'v option)[@local]) -> ('k, 'v, 'cmp) t (** [update t key ~f] is [change t key ~f:(fun o -> Some (f o))]. *) val update : ('k, 'v, 'cmp) t -> 'k -> f:(('v option -> 'v)[@local]) -> ('k, 'v, 'cmp) t (** Returns [Some value] bound to the given key, or [None] if none exists. *) val find : ('k, 'v, 'cmp) t -> 'k -> 'v option (** Returns the value bound to the given key, raising [Stdlib.Not_found] or [Not_found_s] if none exists. *) val find_exn : ('k, 'v, 'cmp) t -> 'k -> 'v (** Returns a new map with any binding for the key in question removed. *) val remove : ('k, 'v, 'cmp) t -> 'k -> ('k, 'v, 'cmp) t (** [mem map key] tests whether [map] contains a binding for [key]. *) val mem : ('k, _, 'cmp) t -> 'k -> bool val iter_keys : ('k, _, _) t -> f:(('k -> unit)[@local]) -> unit val iter : (_, 'v, _) t -> f:(('v -> unit)[@local]) -> unit val iteri : ('k, 'v, _) t -> f:((key:'k -> data:'v -> unit)[@local]) -> unit (** Iterates until the first time [f] returns [Stop]. If [f] returns [Stop], the final result is [Unfinished]. Otherwise, the final result is [Finished]. *) val iteri_until : ('k, 'v, _) t -> f:((key:'k -> data:'v -> Continue_or_stop.t)[@local]) -> Finished_or_unfinished.t (** Iterates two maps side by side. The complexity of this function is O(M + N). If two inputs are [[(0, a); (1, a)]] and [[(1, b); (2, b)]], [f] will be called with [[(0, `Left a); (1, `Both (a, b)); (2, `Right b)]]. *) val iter2 : ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t -> f:((key:'k -> data:('v1, 'v2) Merge_element.t -> unit)[@local]) -> unit (** Returns a new map with bound values replaced by [f] applied to the bound values.*) val map : ('k, 'v1, 'cmp) t -> f:(('v1 -> 'v2)[@local]) -> ('k, 'v2, 'cmp) t (** Like [map], but the passed function takes both [key] and [data] as arguments. *) val mapi : ('k, 'v1, 'cmp) t -> f:((key:'k -> data:'v1 -> 'v2)[@local]) -> ('k, 'v2, 'cmp) t (** Convert map with keys of type ['k2] to a map with keys of type ['k2] using [f]. *) val map_keys : ('k2, 'cmp2) Comparator.Module.t -> ('k1, 'v, 'cmp1) t -> f:(('k1 -> 'k2)[@local]) -> [ `Ok of ('k2, 'v, 'cmp2) t | `Duplicate_key of 'k2 ] (** Like [map_keys], but raises on duplicate key. *) val map_keys_exn : ('k2, 'cmp2) Comparator.Module.t -> ('k1, 'v, 'cmp1) t -> f:(('k1 -> 'k2)[@local]) -> ('k2, 'v, 'cmp2) t (** Folds over keys and data in the map in increasing order of [key]. *) val fold : ('k, 'v, _) t -> init:'acc -> f:((key:'k -> data:'v -> 'acc -> 'acc)[@local]) -> 'acc (** Folds over keys and data in the map in increasing order of [key], until the first time that [f] returns [Stop _]. If [f] returns [Stop final], this function returns immediately with the value [final]. If [f] never returns [Stop _], and the final call to [f] returns [Continue last], this function returns [finish last]. *) val fold_until : ('k, 'v, _) t -> init:'acc -> f: ((key:'k -> data:'v -> 'acc -> ('acc, 'final) Container.Continue_or_stop.t) [@local]) -> finish:(('acc -> 'final)[@local]) -> 'final (** Folds over keys and data in the map in decreasing order of [key]. *) val fold_right : ('k, 'v, _) t -> init:'acc -> f:((key:'k -> data:'v -> 'acc -> 'acc)[@local]) -> 'acc (** Folds over two maps side by side, like [iter2]. *) val fold2 : ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t -> init:'acc -> f:((key:'k -> data:('v1, 'v2) Merge_element.t -> 'acc -> 'acc)[@local]) -> 'acc (** [filter], [filteri], [filter_keys], [filter_map], and [filter_mapi] run in O(n) time. [filter], [filteri], [filter_keys], [partition_tf] and [partitioni_tf] keep a lot of sharing between their result and the original map. Dropping or keeping a run of [k] consecutive elements costs [O(log(k))] extra memory. Keeping the entire map costs no extra memory at all: [filter ~f:(fun _ -> true)] returns the original map. *) val filter_keys : ('k, 'v, 'cmp) t -> f:(('k -> bool)[@local]) -> ('k, 'v, 'cmp) t val filter : ('k, 'v, 'cmp) t -> f:(('v -> bool)[@local]) -> ('k, 'v, 'cmp) t val filteri : ('k, 'v, 'cmp) t -> f:((key:'k -> data:'v -> bool)[@local]) -> ('k, 'v, 'cmp) t (** Returns a new map with bound values filtered by [f] applied to the bound values. *) val filter_map : ('k, 'v1, 'cmp) t -> f:(('v1 -> 'v2 option)[@local]) -> ('k, 'v2, 'cmp) t (** Like [filter_map], but the passed function takes both [key] and [data] as arguments. *) val filter_mapi : ('k, 'v1, 'cmp) t -> f:((key:'k -> data:'v1 -> 'v2 option)[@local]) -> ('k, 'v2, 'cmp) t (** [partition_mapi t ~f] returns two new [t]s, with each key in [t] appearing in exactly one of the resulting maps depending on its mapping in [f]. *) val partition_mapi : ('k, 'v1, 'cmp) t -> f:((key:'k -> data:'v1 -> ('v2, 'v3) Either.t)[@local]) -> ('k, 'v2, 'cmp) t * ('k, 'v3, 'cmp) t (** [partition_map t ~f = partition_mapi t ~f:(fun ~key:_ ~data -> f data)] *) val partition_map : ('k, 'v1, 'cmp) t -> f:(('v1 -> ('v2, 'v3) Either.t)[@local]) -> ('k, 'v2, 'cmp) t * ('k, 'v3, 'cmp) t (** {[ partitioni_tf t ~f = partition_mapi t ~f:(fun ~key ~data -> if f ~key ~data then First data else Second data) ]} *) val partitioni_tf : ('k, 'v, 'cmp) t -> f:((key:'k -> data:'v -> bool)[@local]) -> ('k, 'v, 'cmp) t * ('k, 'v, 'cmp) t (** [partition_tf t ~f = partitioni_tf t ~f:(fun ~key:_ ~data -> f data)] *) val partition_tf : ('k, 'v, 'cmp) t -> f:(('v -> bool)[@local]) -> ('k, 'v, 'cmp) t * ('k, 'v, 'cmp) t (** Produces [Ok] of a map including all keys if all data is [Ok], or an [Error] including all errors otherwise. *) val combine_errors : ('k, 'v Or_error.t, 'cmp) t -> ('k, 'v, 'cmp) t Or_error.t (** Returns a total ordering between maps. The first argument is a total ordering used to compare data associated with equal keys in the two maps. *) val compare_direct : ('v -> 'v -> int) -> ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> int (** Hash function: a building block to use when hashing data structures containing maps in them. [hash_fold_direct hash_fold_key] is compatible with [compare_direct] iff [hash_fold_key] is compatible with [(comparator m).compare] of the map [m] being hashed. *) val hash_fold_direct : 'k Hash.folder -> 'v Hash.folder -> ('k, 'v, 'cmp) t Hash.folder (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, that is, contain the same keys and associate each key with the same value. [cmp] is the equality predicate used to compare the values associated with the keys. *) val equal : ('v -> 'v -> bool) -> ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> bool (** Returns a list of the keys in the given map. *) val keys : ('k, _, _) t -> 'k list (** Returns a list of the data in the given map. *) val data : (_, 'v, _) t -> 'v list (** Creates an association list from the given map. *) val to_alist : ?key_order:[ `Increasing | `Decreasing ] (** default is [`Increasing] *) -> ('k, 'v, _) t -> ('k * 'v) list (** {2 Additional operations on maps} *) (** Merges two maps. The runtime is O(length(t1) + length(t2)). You shouldn't use this function to merge a list of maps; consider using [merge_skewed] instead. *) val merge : ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t -> f:((key:'k -> ('v1, 'v2) Merge_element.t -> 'v3 option)[@local]) -> ('k, 'v3, 'cmp) t (** A special case of [merge], [merge_skewed t1 t2] is a map containing all the bindings of [t1] and [t2]. Bindings that appear in both [t1] and [t2] are combined into a single value using the [combine] function. In a call [combine ~key v1 v2], the value [v1] comes from [t1] and [v2] from [t2]. The runtime of [merge_skewed] is [O(min(l1, l2) * log(max(l1, l2)))], where [l1] is the length of [t1] and [l2] the length of [t2]. This is likely to be faster than [merge] when one of the maps is a lot smaller, or when you merge a list of maps. *) val merge_skewed : ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> combine:((key:'k -> 'v -> 'v -> 'v)[@local]) -> ('k, 'v, 'cmp) t module Symmetric_diff_element : sig type ('k, 'v) t = 'k * [ `Left of 'v | `Right of 'v | `Unequal of 'v * 'v ] [@@deriving_inline compare, equal, sexp, sexp_grammar] include Ppx_compare_lib.Comparable.S2 with type ('k, 'v) t := ('k, 'v) t include Ppx_compare_lib.Equal.S2 with type ('k, 'v) t := ('k, 'v) t include Sexplib0.Sexpable.S2 with type ('k, 'v) t := ('k, 'v) t val t_sexp_grammar : 'k Sexplib0.Sexp_grammar.t -> 'v Sexplib0.Sexp_grammar.t -> ('k, 'v) t Sexplib0.Sexp_grammar.t [@@@end] end (** [symmetric_diff t1 t2 ~data_equal] returns a list of changes between [t1] and [t2]. It is intended to be efficient in the case where [t1] and [t2] share a large amount of structure. The keys in the output sequence will be in sorted order. It is assumed that [data_equal] is at least as equating as physical equality: that [phys_equal x y] implies [data_equal x y]. Otherwise, [symmetric_diff] may behave in unexpected ways. For example, with [~data_equal:(fun _ _ -> false)] it is NOT necessarily the case the resulting change sequence will contain an element [(k, `Unequal _)] for every key [k] shared by both maps. Warning: Float equality violates this property! [phys_equal Float.nan Float.nan] is true, but [Float.(=) Float.nan Float.nan] is false. *) val symmetric_diff : ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> data_equal:('v -> 'v -> bool) -> ('k, 'v) Symmetric_diff_element.t Sequence.t (** [fold_symmetric_diff t1 t2 ~data_equal] folds across an implicit sequence of changes between [t1] and [t2], in sorted order by keys. Equivalent to [Sequence.fold (symmetric_diff t1 t2 ~data_equal)], and more efficient. *) val fold_symmetric_diff : ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> data_equal:(('v -> 'v -> bool)[@local]) -> init:'acc -> f:(('acc -> ('k, 'v) Symmetric_diff_element.t -> 'acc)[@local]) -> 'acc (** [min_elt map] returns [Some (key, data)] pair corresponding to the minimum key in [map], or [None] if empty. *) val min_elt : ('k, 'v, _) t -> ('k * 'v) option val min_elt_exn : ('k, 'v, _) t -> 'k * 'v (** [max_elt map] returns [Some (key, data)] pair corresponding to the maximum key in [map], or [None] if [map] is empty. *) val max_elt : ('k, 'v, _) t -> ('k * 'v) option val max_elt_exn : ('k, 'v, _) t -> 'k * 'v (** Swap the inner and outer keys of nested maps. If [transpose_keys m a = b], then [find_exn (find_exn a i) j = find_exn (find_exn b j) i]. *) val transpose_keys : ('k2, 'cmp2) Comparator.Module.t -> ('k1, ('k2, 'v, 'cmp2) t, 'cmp1) t -> ('k2, ('k1, 'v, 'cmp1) t, 'cmp2) t (** These functions have the same semantics as similar functions in [List]. *) val for_all : ('k, 'v, _) t -> f:(('v -> bool)[@local]) -> bool val for_alli : ('k, 'v, _) t -> f:((key:'k -> data:'v -> bool)[@local]) -> bool val exists : ('k, 'v, _) t -> f:(('v -> bool)[@local]) -> bool val existsi : ('k, 'v, _) t -> f:((key:'k -> data:'v -> bool)[@local]) -> bool val count : ('k, 'v, _) t -> f:(('v -> bool)[@local]) -> int val counti : ('k, 'v, _) t -> f:((key:'k -> data:'v -> bool)[@local]) -> int (** [split t key] returns a map of keys strictly less than [key], the mapping of [key] if any, and a map of keys strictly greater than [key]. Runtime is O(m + log n), where n is the size of the input map and m is the size of the smaller of the two output maps. The O(m) term is due to the need to calculate the length of the output maps. *) val split : ('k, 'v, 'cmp) t -> 'k -> ('k, 'v, 'cmp) t * ('k * 'v) option * ('k, 'v, 'cmp) t (** [split_le_gt t key] returns a map of keys that are less or equal to [key] and a map of keys strictly greater than [key]. Runtime is O(m + log n), where n is the size of the input map and m is the size of the smaller of the two output maps. The O(m) term is due to the need to calculate the length of the output maps. *) val split_le_gt : ('k, 'v, 'cmp) t -> 'k -> ('k, 'v, 'cmp) t * ('k, 'v, 'cmp) t (** [split_lt_ge t key] returns a map of keys strictly less than [key] and a map of keys that are greater or equal to [key]. Runtime is O(m + log n), where n is the size of the input map and m is the size of the smaller of the two output maps. The O(m) term is due to the need to calculate the length of the output maps. *) val split_lt_ge : ('k, 'v, 'cmp) t -> 'k -> ('k, 'v, 'cmp) t * ('k, 'v, 'cmp) t (** [append ~lower_part ~upper_part] returns [`Ok map] where [map] contains all the [(key, value)] pairs from the two input maps if all the keys from [lower_part] are less than all the keys from [upper_part]. Otherwise it returns [`Overlapping_key_ranges]. Runtime is O(log n) where n is the size of the larger input map. This can be significantly faster than [Map.merge] or repeated [Map.add]. {[ assert (match Map.append ~lower_part ~upper_part with | `Ok whole_map -> Map.to_alist whole_map = List.append (to_alist lower_part) (to_alist upper_part) | `Overlapping_key_ranges -> true); ]} *) val append : lower_part:('k, 'v, 'cmp) t -> upper_part:('k, 'v, 'cmp) t -> [ `Ok of ('k, 'v, 'cmp) t | `Overlapping_key_ranges ] (** [subrange t ~lower_bound ~upper_bound] returns a map containing all the entries from [t] whose keys lie inside the interval indicated by [~lower_bound] and [~upper_bound]. If this interval is empty, an empty map is returned. Runtime is O(m + log n), where n is the size of the input map and m is the size of the output map. The O(m) term is due to the need to calculate the length of the output map. *) val subrange : ('k, 'v, 'cmp) t -> lower_bound:'k Maybe_bound.t -> upper_bound:'k Maybe_bound.t -> ('k, 'v, 'cmp) t (** [fold_range_inclusive t ~min ~max ~init ~f] folds [f] (with initial value [~init]) over all keys (and their associated values) that are in the range [[min, max]] (inclusive). *) val fold_range_inclusive : ('k, 'v, 'cmp) t -> min:'k -> max:'k -> init:'acc -> f:((key:'k -> data:'v -> 'acc -> 'acc)[@local]) -> 'acc (** [range_to_alist t ~min ~max] returns an associative list of the elements whose keys lie in [[min, max]] (inclusive), with the smallest key being at the head of the list. *) val range_to_alist : ('k, 'v, 'cmp) t -> min:'k -> max:'k -> ('k * 'v) list (** [closest_key t dir k] returns the [(key, value)] pair in [t] with [key] closest to [k] that satisfies the given inequality bound. For example, [closest_key t `Less_than k] would be the pair with the closest key to [k] where [key < k]. [to_sequence] can be used to get the same results as [closest_key]. It is less efficient for individual lookups but more efficient for finding many elements starting at some value. *) val closest_key : ('k, 'v, 'cmp) t -> [ `Greater_or_equal_to | `Greater_than | `Less_or_equal_to | `Less_than ] -> 'k -> ('k * 'v) option (** [nth t n] finds the (key, value) pair of rank n (i.e., such that there are exactly n keys strictly less than the found key), if one exists. O(log(length t) + n) time. *) val nth : ('k, 'v, _) t -> int -> ('k * 'v) option val nth_exn : ('k, 'v, _) t -> int -> 'k * 'v (** [rank t k] If [k] is in [t], returns the number of keys strictly less than [k] in [t], and [None] otherwise. *) val rank : ('k, 'v, 'cmp) t -> 'k -> int option (** [to_sequence ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t] gives a sequence of key-value pairs between [keys_less_or_equal_to] and [keys_greater_or_equal_to] inclusive, presented in [order]. If [keys_greater_or_equal_to > keys_less_or_equal_to], the sequence is empty. When neither [keys_greater_or_equal_to] nor [keys_less_or_equal_to] are provided, the cost is O(log n) up front and amortized O(1) to produce each element. If either is provided (and is used by the order parameter provided), then the the cost is O(n) up front, and amortized O(1) to produce each element. *) val to_sequence : ?order:[ `Increasing_key (** default *) | `Decreasing_key ] -> ?keys_greater_or_equal_to:'k -> ?keys_less_or_equal_to:'k -> ('k, 'v, 'cmp) t -> ('k * 'v) Sequence.t (** [binary_search t ~compare which elt] returns the [(key, value)] pair in [t] specified by [compare] and [which], if one exists. [t] must be sorted in increasing order according to [compare], where [compare] and [elt] divide [t] into three (possibly empty) segments: {v | < elt | = elt | > elt | v} [binary_search] returns an element on the boundary of segments as specified by [which]. See the diagram below next to the [which] variants. [binary_search] does not check that [compare] orders [t], and behavior is unspecified if [compare] doesn't order [t]. Behavior is also unspecified if [compare] mutates [t]. *) val binary_search : ('k, 'v, 'cmp) t -> compare:((key:'k -> data:'v -> 'key -> int)[@local]) -> [ `Last_strictly_less_than (** {v | < elt X | v} *) | `Last_less_than_or_equal_to (** {v | <= elt X | v} *) | `Last_equal_to (** {v | = elt X | v} *) | `First_equal_to (** {v | X = elt | v} *) | `First_greater_than_or_equal_to (** {v | X >= elt | v} *) | `First_strictly_greater_than (** {v | X > elt | v} *) ] -> 'key -> ('k * 'v) option (** [binary_search_segmented t ~segment_of which] takes a [segment_of] function that divides [t] into two (possibly empty) segments: {v | segment_of elt = `Left | segment_of elt = `Right | v} [binary_search_segmented] returns the [(key, value)] pair on the boundary of the segments as specified by [which]: [`Last_on_left] yields the last element of the left segment, while [`First_on_right] yields the first element of the right segment. It returns [None] if the segment is empty. [binary_search_segmented] does not check that [segment_of] segments [t] as in the diagram, and behavior is unspecified if [segment_of] doesn't segment [t]. Behavior is also unspecified if [segment_of] mutates [t]. *) val binary_search_segmented : ('k, 'v, 'cmp) t -> segment_of:((key:'k -> data:'v -> [ `Left | `Right ])[@local]) -> [ `Last_on_left | `First_on_right ] -> ('k * 'v) option (** [binary_search_subrange] takes a [compare] function that divides [t] into three (possibly empty) segments with respect to [lower_bound] and [upper_bound]: {v | Below_lower_bound | In_range | Above_upper_bound | v} and returns a map of the [In_range] segment. Runtime is O(log m + n) where [m] is the length of the input map and [n] is the length of the output. The linear term in [n] is to compute the length of the output. Behavior is undefined if [compare] does not segment [t] as shown above, or if [compare] mutates its inputs. *) val binary_search_subrange : ('k, 'v, 'cmp) t -> compare:((key:'k -> data:'v -> 'bound -> int)[@local]) -> lower_bound:'bound Maybe_bound.t -> upper_bound:'bound Maybe_bound.t -> ('k, 'v, 'cmp) t (** Creates traversals to reconstruct a map within an applicative. Uses [Lazy_applicative] so that the map can be traversed within the applicative, rather than needing to be traversed all at once, outside the applicative. *) module Make_applicative_traversals (A : Applicative.Lazy_applicative) : sig val mapi : ('k, 'v1, 'cmp) t -> f:(key:'k -> data:'v1 -> 'v2 A.t) -> ('k, 'v2, 'cmp) t A.t val filter_mapi : ('k, 'v1, 'cmp) t -> f:(key:'k -> data:'v1 -> 'v2 option A.t) -> ('k, 'v2, 'cmp) t A.t end (** [M] is meant to be used in combination with OCaml applicative functor types: {[ type string_to_int_map = int Map.M(String).t ]} which stands for: {[ type string_to_int_map = (String.t, int, String.comparator_witness) Map.t ]} The point is that [int Map.M(String).t] supports deriving, whereas the second syntax doesn't (because there is no such thing as, say, [String.sexp_of_comparator_witness] -- instead you would want to pass the comparator directly). In addition, when using [@@deriving], the requirements on the key module are only those needed to satisfy what you are trying to derive on the map itself. Say you write: {[ type t = int Map.M(X).t [@@deriving hash] ]} then this will be well typed exactly if [X] contains at least: - a type [t] with no parameters - a comparator witness - a [hash_fold_t] function with the right type *) module M (K : sig type t type comparator_witness end) : sig type nonrec 'v t = (K.t, 'v, K.comparator_witness) t end include For_deriving with type ('key, 'value, 'cmp) t := ('key, 'value, 'cmp) t (** [Using_comparator] is a similar interface as the toplevel of [Map], except the functions take a [~comparator:('k, 'cmp) Comparator.t], whereas the functions at the toplevel of [Map] take a [('k, 'cmp) comparator]. *) module Using_comparator : sig type nonrec ('k, +'v, 'cmp) t = ('k, 'v, 'cmp) t [@@deriving_inline sexp_of] val sexp_of_t : ('k -> Sexplib0.Sexp.t) -> ('v -> Sexplib0.Sexp.t) -> ('cmp -> Sexplib0.Sexp.t) -> ('k, 'v, 'cmp) t -> Sexplib0.Sexp.t [@@@end] val t_of_sexp_direct : comparator:('k, 'cmp) Comparator.t -> (Sexp.t -> 'k) -> (Sexp.t -> 'v) -> Sexp.t -> ('k, 'v, 'cmp) t module Tree : sig type (+'k, +'v, 'cmp) t [@@deriving_inline sexp_of] val sexp_of_t : ('k -> Sexplib0.Sexp.t) -> ('v -> Sexplib0.Sexp.t) -> ('cmp -> Sexplib0.Sexp.t) -> ('k, 'v, 'cmp) t -> Sexplib0.Sexp.t [@@@end] val t_of_sexp_direct : comparator:('k, 'cmp) Comparator.t -> (Sexp.t -> 'k) -> (Sexp.t -> 'v) -> Sexp.t -> ('k, 'v, 'cmp) t include Creators_and_accessors_generic with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) t with type 'k key := 'k with type 'c cmp := 'c with type ('a, 'b, 'c) create_options := ('a, 'b, 'c) With_comparator.t with type ('a, 'b, 'c) access_options := ('a, 'b, 'c) With_comparator.t val empty_without_value_restriction : (_, _, _) t (** [Build_increasing] can be used to construct a map incrementally from a sequence that is known to be increasing. The total time complexity of constructing a map this way is O(n), which is more efficient than using [Map.add] by a logarithmic factor. This interface can be thought of as a dual of [to_sequence], but we don't have an equally neat idiom for the duals of sequences ([of_sequence] is much less general because it does not allow the sequence to be produced asynchronously). *) module Build_increasing : sig type ('a, 'b, 'c) tree := ('a, 'b, 'c) t type ('k, 'v, 'w) t val empty : ('k, 'v, 'w) t (** Time complexity of [add_exn] is amortized constant-time (if [t] is used linearly), with a worst-case O(log(n)) time. *) val add_exn : ('k, 'v, 'w) t -> comparator:('k, 'w) Comparator.t -> key:'k -> data:'v -> ('k, 'v, 'w) t (** Time complexity is O(log(n)). *) val to_tree : ('k, 'v, 'w) t -> ('k, 'v, 'w) tree end end include Creators_and_accessors_generic with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Tree.t with type 'k key := 'k with type 'c cmp := 'c with type ('a, 'b, 'c) access_options := ('a, 'b, 'c) Without_comparator.t with type ('a, 'b, 'c) create_options := ('a, 'b, 'c) With_comparator.t val comparator : ('a, _, 'cmp) t -> ('a, 'cmp) Comparator.t val hash_fold_direct : 'k Hash.folder -> 'v Hash.folder -> ('k, 'v, 'cmp) t Hash.folder (** To get around the value restriction, apply the functor and include it. You can see an example of this in the [Poly] submodule below. *) module Empty_without_value_restriction (K : Comparator.S1) : sig val empty : ('a K.t, 'v, K.comparator_witness) t end end (** A polymorphic Map. *) module Poly : S_poly with type ('key, +'value) t = ('key, 'value, Comparator.Poly.comparator_witness) t and type ('key, +'value) tree = ('key, 'value, Comparator.Poly.comparator_witness) Using_comparator.Tree.t and type comparator_witness = Comparator.Poly.comparator_witness (** Create a map from a tree using the given comparator. *) val of_tree : ('k, 'cmp) Comparator.Module.t -> ('k, 'v, 'cmp) Using_comparator.Tree.t -> ('k, 'v, 'cmp) t (** Extract a tree from a map. *) val to_tree : ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) Using_comparator.Tree.t (** {2 Modules and module types for extending [Map]} For use in extensions of Base, like [Core]. *) module With_comparator = With_comparator module With_first_class_module = With_first_class_module module Without_comparator = Without_comparator module type For_deriving = For_deriving module type S_poly = S_poly module type Accessors_generic = Accessors_generic module type Creators_and_accessors_generic = Creators_and_accessors_generic module type Creators_generic = Creators_generic end base-0.16.3/src/maybe_bound.ml000066400000000000000000000201101446274340700161250ustar00rootroot00000000000000open! Import type 'a t = | Incl of 'a | Excl of 'a | Unbounded [@@deriving_inline enumerate, sexp, sexp_grammar] let all : 'a. 'a list -> 'a t list = fun _all_of_a -> Ppx_enumerate_lib.List.append (let rec map l acc = match l with | [] -> Ppx_enumerate_lib.List.rev acc | enumerate__001_ :: l -> map l (Incl enumerate__001_ :: acc) in map _all_of_a []) (Ppx_enumerate_lib.List.append (let rec map l acc = match l with | [] -> Ppx_enumerate_lib.List.rev acc | enumerate__002_ :: l -> map l (Excl enumerate__002_ :: acc) in map _all_of_a []) [ Unbounded ]) ;; let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = fun (type a__018_) : ((Sexplib0.Sexp.t -> a__018_) -> Sexplib0.Sexp.t -> a__018_ t) -> let error_source__006_ = "maybe_bound.ml.t" in fun _of_a__003_ -> function | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom (("incl" | "Incl") as _tag__009_) :: sexp_args__010_) as _sexp__008_ -> (match sexp_args__010_ with | [ arg0__011_ ] -> let res0__012_ = _of_a__003_ arg0__011_ in Incl res0__012_ | _ -> Sexplib0.Sexp_conv_error.stag_incorrect_n_args error_source__006_ _tag__009_ _sexp__008_) | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom (("excl" | "Excl") as _tag__014_) :: sexp_args__015_) as _sexp__013_ -> (match sexp_args__015_ with | [ arg0__016_ ] -> let res0__017_ = _of_a__003_ arg0__016_ in Excl res0__017_ | _ -> Sexplib0.Sexp_conv_error.stag_incorrect_n_args error_source__006_ _tag__014_ _sexp__013_) | Sexplib0.Sexp.Atom ("unbounded" | "Unbounded") -> Unbounded | Sexplib0.Sexp.Atom ("incl" | "Incl") as sexp__007_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__006_ sexp__007_ | Sexplib0.Sexp.Atom ("excl" | "Excl") as sexp__007_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__006_ sexp__007_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("unbounded" | "Unbounded") :: _) as sexp__007_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__006_ sexp__007_ | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__005_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__006_ sexp__005_ | Sexplib0.Sexp.List [] as sexp__005_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__006_ sexp__005_ | sexp__005_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__006_ sexp__005_ ;; let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = fun (type a__024_) : ((a__024_ -> Sexplib0.Sexp.t) -> a__024_ t -> Sexplib0.Sexp.t) -> fun _of_a__019_ -> function | Incl arg0__020_ -> let res0__021_ = _of_a__019_ arg0__020_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Incl"; res0__021_ ] | Excl arg0__022_ -> let res0__023_ = _of_a__019_ arg0__022_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Excl"; res0__023_ ] | Unbounded -> Sexplib0.Sexp.Atom "Unbounded" ;; let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "Incl" ; clause_kind = List_clause { args = Cons (_'a_sexp_grammar.untyped, Empty) } } ; No_tag { name = "Excl" ; clause_kind = List_clause { args = Cons (_'a_sexp_grammar.untyped, Empty) } } ; No_tag { name = "Unbounded"; clause_kind = Atom_clause } ] } } ;; [@@@end] type interval_comparison = | Below_lower_bound | In_range | Above_upper_bound [@@deriving_inline sexp, sexp_grammar, compare, hash] let interval_comparison_of_sexp = (let error_source__027_ = "maybe_bound.ml.interval_comparison" in function | Sexplib0.Sexp.Atom ("below_lower_bound" | "Below_lower_bound") -> Below_lower_bound | Sexplib0.Sexp.Atom ("in_range" | "In_range") -> In_range | Sexplib0.Sexp.Atom ("above_upper_bound" | "Above_upper_bound") -> Above_upper_bound | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("below_lower_bound" | "Below_lower_bound") :: _) as sexp__028_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__027_ sexp__028_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("in_range" | "In_range") :: _) as sexp__028_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__027_ sexp__028_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("above_upper_bound" | "Above_upper_bound") :: _) as sexp__028_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__027_ sexp__028_ | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__026_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__027_ sexp__026_ | Sexplib0.Sexp.List [] as sexp__026_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__027_ sexp__026_ | sexp__026_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__027_ sexp__026_ : Sexplib0.Sexp.t -> interval_comparison) ;; let sexp_of_interval_comparison = (function | Below_lower_bound -> Sexplib0.Sexp.Atom "Below_lower_bound" | In_range -> Sexplib0.Sexp.Atom "In_range" | Above_upper_bound -> Sexplib0.Sexp.Atom "Above_upper_bound" : interval_comparison -> Sexplib0.Sexp.t) ;; let (interval_comparison_sexp_grammar : interval_comparison Sexplib0.Sexp_grammar.t) = { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "Below_lower_bound"; clause_kind = Atom_clause } ; No_tag { name = "In_range"; clause_kind = Atom_clause } ; No_tag { name = "Above_upper_bound"; clause_kind = Atom_clause } ] } } ;; let compare_interval_comparison = (Stdlib.compare : interval_comparison -> interval_comparison -> int) ;; let (hash_fold_interval_comparison : Ppx_hash_lib.Std.Hash.state -> interval_comparison -> Ppx_hash_lib.Std.Hash.state) = (fun hsv arg -> match arg with | Below_lower_bound -> Ppx_hash_lib.Std.Hash.fold_int hsv 0 | In_range -> Ppx_hash_lib.Std.Hash.fold_int hsv 1 | Above_upper_bound -> Ppx_hash_lib.Std.Hash.fold_int hsv 2 : Ppx_hash_lib.Std.Hash.state -> interval_comparison -> Ppx_hash_lib.Std.Hash.state) ;; let (hash_interval_comparison : interval_comparison -> Ppx_hash_lib.Std.Hash.hash_value) = let func arg = Ppx_hash_lib.Std.Hash.get_hash_value (let hsv = Ppx_hash_lib.Std.Hash.create () in hash_fold_interval_comparison hsv arg) in fun x -> func x ;; [@@@end] let map t ~f = match t with | Incl incl -> Incl (f incl) | Excl excl -> Excl (f excl) | Unbounded -> Unbounded ;; let is_lower_bound t ~of_:a ~compare = match t with | Incl incl -> compare incl a <= 0 | Excl excl -> compare excl a < 0 | Unbounded -> true ;; let is_upper_bound t ~of_:a ~compare = match t with | Incl incl -> compare a incl <= 0 | Excl excl -> compare a excl < 0 | Unbounded -> true ;; let bounds_crossed ~lower ~upper ~compare = match lower with | Unbounded -> false | Incl lower | Excl lower -> (match upper with | Unbounded -> false | Incl upper | Excl upper -> compare lower upper > 0) ;; let check_interval_exn ~lower ~upper ~compare = if bounds_crossed ~lower ~upper ~compare then failwith "Maybe_bound.compare_to_interval_exn: lower bound > upper bound" ;; let compare_to_interval_exn ~lower ~upper a ~compare = check_interval_exn ~lower ~upper ~compare; if not (is_lower_bound lower ~of_:a ~compare) then Below_lower_bound else if not (is_upper_bound upper ~of_:a ~compare) then Above_upper_bound else In_range ;; let interval_contains_exn ~lower ~upper a ~compare = match compare_to_interval_exn ~lower ~upper a ~compare with | In_range -> true | Below_lower_bound | Above_upper_bound -> false ;; base-0.16.3/src/maybe_bound.mli000066400000000000000000000037501446274340700163110ustar00rootroot00000000000000(** Used for specifying a bound (either upper or lower) as inclusive, exclusive, or unbounded. *) open! Import type 'a t = | Incl of 'a | Excl of 'a | Unbounded [@@deriving_inline enumerate, sexp, sexp_grammar] include Ppx_enumerate_lib.Enumerable.S1 with type 'a t := 'a t include Sexplib0.Sexpable.S1 with type 'a t := 'a t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] val map : 'a t -> f:(('a -> 'b)[@local]) -> 'b t val is_lower_bound : 'a t -> of_:'a -> compare:(('a -> 'a -> int)[@local]) -> bool val is_upper_bound : 'a t -> of_:'a -> compare:(('a -> 'a -> int)[@local]) -> bool (** [interval_contains_exn ~lower ~upper x ~compare] raises if [lower] and [upper] are crossed. *) val interval_contains_exn : lower:'a t -> upper:'a t -> 'a -> compare:(('a -> 'a -> int)[@local]) -> bool (** [bounds_crossed ~lower ~upper ~compare] returns true if [lower > upper]. It ignores whether the bounds are [Incl] or [Excl]. *) val bounds_crossed : lower:'a t -> upper:'a t -> compare:(('a -> 'a -> int)[@local]) -> bool type interval_comparison = | Below_lower_bound | In_range | Above_upper_bound [@@deriving_inline sexp, sexp_grammar, compare, hash] val sexp_of_interval_comparison : interval_comparison -> Sexplib0.Sexp.t val interval_comparison_of_sexp : Sexplib0.Sexp.t -> interval_comparison val interval_comparison_sexp_grammar : interval_comparison Sexplib0.Sexp_grammar.t val compare_interval_comparison : interval_comparison -> interval_comparison -> int val hash_fold_interval_comparison : Ppx_hash_lib.Std.Hash.state -> interval_comparison -> Ppx_hash_lib.Std.Hash.state val hash_interval_comparison : interval_comparison -> Ppx_hash_lib.Std.Hash.hash_value [@@@end] (** [compare_to_interval_exn ~lower ~upper x ~compare] raises if [lower] and [upper] are crossed. *) val compare_to_interval_exn : lower:'a t -> upper:'a t -> 'a -> compare:(('a -> 'a -> int)[@local]) -> interval_comparison base-0.16.3/src/monad.ml000066400000000000000000000155461446274340700147600ustar00rootroot00000000000000open! Import module List = List0 include Monad_intf module type Basic_general = sig type ('a, 'i, 'j, 'd, 'e) t val bind : ('a, 'i, 'j, 'd, 'e) t -> f:('a -> ('b, 'j, 'k, 'd, 'e) t) -> ('b, 'i, 'k, 'd, 'e) t val map : [ `Define_using_bind | `Custom of ('a, 'i, 'j, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'i, 'j, 'd, 'e) t ] val return : 'a -> ('a, 'i, 'i, 'd, 'e) t end module Make_general (M : Basic_general) = struct let bind = M.bind let return = M.return let map_via_bind ma ~f = M.bind ma ~f:(fun a -> M.return (f a)) let map = match M.map with | `Define_using_bind -> map_via_bind | `Custom x -> x ;; module Monad_infix = struct let ( >>= ) t f = bind t ~f let ( >>| ) t f = map t ~f end include Monad_infix module Let_syntax = struct let return = return include Monad_infix module Let_syntax = struct let return = return let bind = bind let map = map let both a b = a >>= fun a -> b >>| fun b -> a, b module Open_on_rhs = struct end end end let join t = t >>= fun t' -> t' let ignore_m t = map t ~f:(fun _ -> ()) let all = let rec loop vs = function | [] -> return (List.rev vs) | t :: ts -> t >>= fun v -> loop (v :: vs) ts in fun ts -> loop [] ts ;; let rec all_unit = function | [] -> return () | t :: ts -> t >>= fun () -> all_unit ts ;; end module Make_indexed (M : Basic_indexed) : S_indexed with type ('a, 'i, 'j) t := ('a, 'i, 'j) M.t = Make_general (struct include M type ('a, 'i, 'j, 'd, 'e) t = ('a, 'i, 'j) M.t end) module Make3 (M : Basic3) : S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) M.t = Make_general (struct include M type ('a, 'i, 'j, 'd, 'e) t = ('a, 'd, 'e) M.t end) module Make2 (M : Basic2) : S2 with type ('a, 'd) t := ('a, 'd) M.t = Make_general (struct include M type ('a, 'i, 'j, 'd, 'e) t = ('a, 'd) M.t end) module Make (M : Basic) : S with type 'a t := 'a M.t = Make_general (struct include M type ('a, 'i, 'j, 'd, 'e) t = 'a M.t end) module Make2_local (M : Basic2_local) = struct let bind = M.bind let return = M.return let map_via_bind ma ~f = let res = M.bind ma ~f:(fun a -> M.return (f a)) in res ;; let map = match M.map with | `Define_using_bind -> map_via_bind | `Custom x -> x ;; module Monad_infix = struct let ( >>= ) t f = bind t ~f let ( >>| ) t f = map t ~f end include Monad_infix module Let_syntax = struct let return = return include Monad_infix module Let_syntax = struct let return = return let bind = bind let map = map let both a b = let res = bind a ~f:(fun a -> let res = map b ~f:(fun b -> a, b) in res) in res ;; module Open_on_rhs = struct end end end let join t = t >>= Fn.id let ignore_m t = let res = map t ~f:(fun _ -> ()) in res ;; let all = let rec loop vs = function | [] -> return (List.rev vs) | t :: ts -> t >>= fun v -> loop (v :: vs) ts in fun ts -> loop [] ts ;; let rec all_unit = function | [] -> return () | t :: ts -> t >>= fun () -> all_unit ts ;; end module Make_local (M : Basic_local) : S_local with type 'a t := 'a M.t = Make2_local (struct include M type ('a, 'e) t = 'a M.t end) module Of_monad_general (Monad : sig type ('a, 'i, 'j, 'd, 'e) t val bind : ('a, 'i, 'j, 'd, 'e) t -> f:('a -> ('b, 'j, 'k, 'd, 'e) t) -> ('b, 'i, 'k, 'd, 'e) t val map : ('a, 'i, 'j, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'i, 'j, 'd, 'e) t val return : 'a -> ('a, 'i, 'i, 'd, 'e) t end) (M : sig type ('a, 'i, 'j, 'd, 'e) t val to_monad : ('a, 'i, 'j, 'd, 'e) t -> ('a, 'i, 'j, 'd, 'e) Monad.t val of_monad : ('a, 'i, 'j, 'd, 'e) Monad.t -> ('a, 'i, 'j, 'd, 'e) t end) = Make_general (struct type ('a, 'i, 'j, 'd, 'e) t = ('a, 'i, 'j, 'd, 'e) M.t let return a = M.of_monad (Monad.return a) let bind t ~f = M.of_monad (Monad.bind (M.to_monad t) ~f:(fun a -> M.to_monad (f a))) let map = `Custom (fun t ~f -> M.of_monad (Monad.map (M.to_monad t) ~f)) end) module Of_monad_indexed (Monad : S_indexed) (M : sig type ('a, 'i, 'j) t val to_monad : ('a, 'i, 'j) t -> ('a, 'i, 'j) Monad.t val of_monad : ('a, 'i, 'j) Monad.t -> ('a, 'i, 'j) t end) = Of_monad_general (struct include Monad type ('a, 'i, 'j, 'd, 'e) t = ('a, 'i, 'j) Monad.t end) (struct include M type ('a, 'i, 'j, 'd, 'e) t = ('a, 'i, 'j) M.t end) module Of_monad3 (Monad : S3) (M : sig type ('a, 'b, 'c) t val to_monad : ('a, 'b, 'c) t -> ('a, 'b, 'c) Monad.t val of_monad : ('a, 'b, 'c) Monad.t -> ('a, 'b, 'c) t end) = Of_monad_general (struct include Monad type ('a, 'i, 'j, 'd, 'e) t = ('a, 'd, 'e) Monad.t end) (struct include M type ('a, 'i, 'j, 'd, 'e) t = ('a, 'd, 'e) M.t end) module Of_monad2 (Monad : S2) (M : sig type ('a, 'b) t val to_monad : ('a, 'b) t -> ('a, 'b) Monad.t val of_monad : ('a, 'b) Monad.t -> ('a, 'b) t end) = Of_monad_general (struct include Monad type ('a, 'i, 'j, 'd, 'e) t = ('a, 'd) Monad.t end) (struct include M type ('a, 'i, 'j, 'd, 'e) t = ('a, 'd) M.t end) module Of_monad (Monad : S) (M : sig type 'a t val to_monad : 'a t -> 'a Monad.t val of_monad : 'a Monad.t -> 'a t end) = Of_monad_general (struct include Monad type ('a, 'i, 'j, 'd, 'e) t = 'a Monad.t end) (struct include M type ('a, 'i, 'j, 'd, 'e) t = 'a M.t end) module Ident = struct type 'a t = 'a let[@inline] bind a ~f = (f [@inlined hint]) a let[@inline] map a ~f = (f [@inlined hint]) a external return : ('a[@local_opt]) -> ('a[@local_opt]) = "%identity" module Monad_infix = struct let[@inline] ( >>| ) a f = map a ~f let[@inline] ( >>= ) a f = bind a ~f end include Monad_infix module Let_syntax = struct let return = return include Monad_infix module Let_syntax = struct let return = return let bind = bind let map = map let[@inline] both a b = a, b module Open_on_rhs = struct end end let return = return end external join : ('a[@local_opt]) -> ('a[@local_opt]) = "%identity" external ignore_m : (_[@local_opt]) -> unit = "%ignore" external all_unit : (unit list[@local_opt]) -> unit = "%ignore" external all : ('a list[@local_opt]) -> ('a list[@local_opt]) = "%identity" end base-0.16.3/src/monad.mli000066400000000000000000000000501446274340700151110ustar00rootroot00000000000000include Monad_intf.Monad (** @inline *) base-0.16.3/src/monad_intf.ml000066400000000000000000000401551446274340700157720ustar00rootroot00000000000000open! Import module type Basic_gen = sig type 'a t type ('a, 'b) f_labeled_fn val bind : 'a t -> ('a -> 'b t, 'b t) f_labeled_fn val return : 'a -> 'a t (** The following identities ought to hold (for some value of =): - [return x >>= f = f x] - [t >>= fun x -> return x = t] - [(t >>= f) >>= g = t >>= fun x -> (f x >>= g)] Note: [>>=] is the infix notation for [bind]) *) (** The [map] argument to [Monad.Make] says how to implement the monad's [map] function. [`Define_using_bind] means to define [map t ~f = bind t ~f:(fun a -> return (f a))]. [`Custom] overrides the default implementation, presumably with something more efficient. Some other functions returned by [Monad.Make] are defined in terms of [map], so passing in a more efficient [map] will improve their efficiency as well. *) val map : [ `Define_using_bind | `Custom of 'a t -> ('a -> 'b, 'b t) f_labeled_fn ] end module type Basic = Basic_gen with type ('a, 'b) f_labeled_fn := f:'a -> 'b module type Basic_local = Basic_gen with type ('a, 'b) f_labeled_fn := f:('a[@local]) -> 'b module type Infix_gen = sig type 'a t type ('a, 'b) fn (** [t >>= f] returns a computation that sequences the computations represented by two monad elements. The resulting computation first does [t] to yield a value [v], and then runs the computation returned by [f v]. *) val ( >>= ) : 'a t -> ('a -> 'b t, 'b t) fn (** [t >>| f] is [t >>= (fun a -> return (f a))]. *) val ( >>| ) : 'a t -> ('a -> 'b, 'b t) fn end module type Infix = Infix_gen with type ('a, 'b) fn := 'a -> 'b module type Infix_local = Infix_gen with type ('a, 'b) fn := ('a[@local]) -> 'b module type Syntax_gen = sig (** Opening a module of this type allows one to use the [%bind] and [%map] syntax extensions defined by ppx_let, and brings [return] into scope. *) type 'a t type ('a, 'b) fn type ('a, 'b) f_labeled_fn module Let_syntax : sig (** These are convenient to have in scope when programming with a monad: *) val return : 'a -> 'a t include Infix_gen with type 'a t := 'a t and type ('a, 'b) fn := ('a, 'b) fn module Let_syntax : sig val return : 'a -> 'a t val bind : 'a t -> ('a -> 'b t, 'b t) f_labeled_fn val map : 'a t -> ('a -> 'b, 'b t) f_labeled_fn val both : 'a t -> 'b t -> ('a * 'b) t module Open_on_rhs : sig end end end end module type Syntax = Syntax_gen with type ('a, 'b) fn := 'a -> 'b and type ('a, 'b) f_labeled_fn := f:'a -> 'b module type Syntax_local = Syntax_gen with type ('a, 'b) fn := ('a[@local]) -> 'b and type ('a, 'b) f_labeled_fn := f:('a[@local]) -> 'b module type S_without_syntax_gen = sig type 'a t type ('a, 'b) fn type ('a, 'b) f_labeled_fn include Infix_gen with type 'a t := 'a t and type ('a, 'b) fn := ('a, 'b) fn module Monad_infix : Infix_gen with type 'a t := 'a t and type ('a, 'b) fn := ('a, 'b) fn (** [bind t ~f] = [t >>= f] *) val bind : 'a t -> ('a -> 'b t, 'b t) f_labeled_fn (** [return v] returns the (trivial) computation that returns v. *) val return : 'a -> 'a t (** [map t ~f] is t >>| f. *) val map : 'a t -> ('a -> 'b, 'b t) f_labeled_fn (** [join t] is [t >>= (fun t' -> t')]. *) val join : 'a t t -> 'a t (** [ignore_m t] is [map t ~f:(fun _ -> ())]. [ignore_m] used to be called [ignore], but we decided that was a bad name, because it shadowed the widely used [Stdlib.ignore]. Some monads still do [let ignore = ignore_m] for historical reasons. *) val ignore_m : 'a t -> unit t val all : 'a t list -> 'a list t (** Like [all], but ensures that every monadic value in the list produces a unit value, all of which are discarded rather than being collected into a list. *) val all_unit : unit t list -> unit t end module type S_without_syntax = S_without_syntax_gen with type ('a, 'b) f_labeled_fn := f:'a -> 'b and type ('a, 'b) fn := 'a -> 'b module type S_without_syntax_local = S_without_syntax_gen with type ('a, 'b) f_labeled_fn := f:('a[@local]) -> 'b and type ('a, 'b) fn := ('a[@local]) -> 'b module type S = sig type 'a t include S_without_syntax with type 'a t := 'a t include Syntax with type 'a t := 'a t end module type S_local = sig type 'a t include S_without_syntax_local with type 'a t := 'a t include Syntax_local with type 'a t := 'a t end module type Basic2_gen = sig (** Multi parameter monad. The second parameter gets unified across all the computation. This is used to encode monads working on a multi parameter data structure like ([('a,'b) result]). *) type ('a, 'e) t type ('a, 'b) f_labeled_fn val bind : ('a, 'e) t -> ('a -> ('b, 'e) t, ('b, 'e) t) f_labeled_fn val map : [ `Define_using_bind | `Custom of ('a, 'e) t -> ('a -> 'b, ('b, 'e) t) f_labeled_fn ] val return : 'a -> ('a, _) t end module type Basic2 = Basic2_gen with type ('a, 'b) f_labeled_fn := f:'a -> 'b module type Basic2_local = Basic2_gen with type ('a, 'b) f_labeled_fn := f:('a[@local]) -> 'b module type Infix2_gen = sig (** Same as {!Infix}, except the monad type has two arguments. The second is always just passed through. *) type ('a, 'e) t type ('a, 'b) fn val ( >>= ) : ('a, 'e) t -> ('a -> ('b, 'e) t, ('b, 'e) t) fn val ( >>| ) : ('a, 'e) t -> ('a -> 'b, ('b, 'e) t) fn end module type Infix2 = Infix2_gen with type ('a, 'b) fn := 'a -> 'b module type Infix2_local = Infix2_gen with type ('a, 'b) fn := ('a[@local]) -> 'b module type Syntax2_gen = sig type ('a, 'e) t type ('a, 'b) fn type ('a, 'b) f_labeled_fn module Let_syntax : sig val return : 'a -> ('a, _) t include Infix2_gen with type ('a, 'e) t := ('a, 'e) t and type ('a, 'b) fn := ('a, 'b) fn module Let_syntax : sig val return : 'a -> ('a, _) t val bind : ('a, 'e) t -> ('a -> ('b, 'e) t, ('b, 'e) t) f_labeled_fn val map : ('a, 'e) t -> ('a -> 'b, ('b, 'e) t) f_labeled_fn val both : ('a, 'e) t -> ('b, 'e) t -> ('a * 'b, 'e) t module Open_on_rhs : sig end end end end module type Syntax2 = Syntax2_gen with type ('a, 'b) fn := 'a -> 'b and type ('a, 'b) f_labeled_fn := f:'a -> 'b module type Syntax2_local = Syntax2_gen with type ('a, 'b) fn := ('a[@local]) -> 'b and type ('a, 'b) f_labeled_fn := f:('a[@local]) -> 'b module type S2_gen = sig (** The same as {!S} except the monad type has two arguments. The second is always just passed through. *) type ('a, 'e) t type ('a, 'b) fn type ('a, 'b) f_labeled_fn include Infix2_gen with type ('a, 'e) t := ('a, 'e) t and type ('a, 'b) fn := ('a, 'b) fn include Syntax2_gen with type ('a, 'e) t := ('a, 'e) t and type ('a, 'b) fn := ('a, 'b) fn and type ('a, 'b) f_labeled_fn := ('a, 'b) f_labeled_fn module Monad_infix : Infix2_gen with type ('a, 'e) t := ('a, 'e) t and type ('a, 'b) fn := ('a, 'b) fn val bind : ('a, 'e) t -> ('a -> ('b, 'e) t, ('b, 'e) t) f_labeled_fn val return : 'a -> ('a, _) t val map : ('a, 'e) t -> ('a -> 'b, ('b, 'e) t) f_labeled_fn val join : (('a, 'e) t, 'e) t -> ('a, 'e) t val ignore_m : (_, 'e) t -> (unit, 'e) t val all : ('a, 'e) t list -> ('a list, 'e) t val all_unit : (unit, 'e) t list -> (unit, 'e) t end module type S2 = S2_gen with type ('a, 'b) fn := 'a -> 'b and type ('a, 'b) f_labeled_fn := f:'a -> 'b module type S2_local = S2_gen with type ('a, 'b) fn := ('a[@local]) -> 'b and type ('a, 'b) f_labeled_fn := f:('a[@local]) -> 'b module type Basic3 = sig (** Multi parameter monad. The second and third parameters get unified across all the computation. *) type ('a, 'd, 'e) t val bind : ('a, 'd, 'e) t -> f:('a -> ('b, 'd, 'e) t) -> ('b, 'd, 'e) t val map : [ `Define_using_bind | `Custom of ('a, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'd, 'e) t ] val return : 'a -> ('a, _, _) t end module type Infix3 = sig (** Same as Infix, except the monad type has three arguments. The second and third are always just passed through. *) type ('a, 'd, 'e) t val ( >>= ) : ('a, 'd, 'e) t -> ('a -> ('b, 'd, 'e) t) -> ('b, 'd, 'e) t val ( >>| ) : ('a, 'd, 'e) t -> ('a -> 'b) -> ('b, 'd, 'e) t end module type Syntax3 = sig type ('a, 'd, 'e) t module Let_syntax : sig val return : 'a -> ('a, _, _) t include Infix3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) t module Let_syntax : sig val return : 'a -> ('a, _, _) t val bind : ('a, 'd, 'e) t -> f:('a -> ('b, 'd, 'e) t) -> ('b, 'd, 'e) t val map : ('a, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'd, 'e) t val both : ('a, 'd, 'e) t -> ('b, 'd, 'e) t -> ('a * 'b, 'd, 'e) t module Open_on_rhs : sig end end end end module type S3 = sig (** The same as {!S} except the monad type has three arguments. The second and third are always just passed through. *) type ('a, 'd, 'e) t include Infix3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) t include Syntax3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) t module Monad_infix : Infix3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) t val bind : ('a, 'd, 'e) t -> f:('a -> ('b, 'd, 'e) t) -> ('b, 'd, 'e) t val return : 'a -> ('a, _, _) t val map : ('a, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'd, 'e) t val join : (('a, 'd, 'e) t, 'd, 'e) t -> ('a, 'd, 'e) t val ignore_m : (_, 'd, 'e) t -> (unit, 'd, 'e) t val all : ('a, 'd, 'e) t list -> ('a list, 'd, 'e) t val all_unit : (unit, 'd, 'e) t list -> (unit, 'd, 'e) t end module type Basic_indexed = sig (** Indexed monad, in the style of Atkey. The second and third parameters are composed across all computation. To see this more clearly, you can look at the type of bind: {[ val bind : ('a, 'i, 'j) t -> f:('a -> ('b, 'j, 'k) t) -> ('b, 'i, 'k) t ]} and isolate some of the type variables to see their individual behaviors: {[ val bind : 'a -> f:('a -> 'b ) -> 'b val bind : 'i, 'j -> 'j, 'k -> 'i, 'k ]} For more information on Atkey-style indexed monads, see: {v Parameterised Notions of Computation Robert Atkey http://bentnib.org/paramnotions-jfp.pdf v} *) type ('a, 'i, 'j) t val bind : ('a, 'i, 'j) t -> f:('a -> ('b, 'j, 'k) t) -> ('b, 'i, 'k) t val map : [ `Define_using_bind | `Custom of ('a, 'i, 'j) t -> f:('a -> 'b) -> ('b, 'i, 'j) t ] val return : 'a -> ('a, 'i, 'i) t end module type Infix_indexed = sig (** Same as {!Infix}, except the monad type has three arguments. The second and third are composed across all computation. *) type ('a, 'i, 'j) t val ( >>= ) : ('a, 'i, 'j) t -> ('a -> ('b, 'j, 'k) t) -> ('b, 'i, 'k) t val ( >>| ) : ('a, 'i, 'j) t -> ('a -> 'b) -> ('b, 'i, 'j) t end module type Syntax_indexed = sig type ('a, 'i, 'j) t module Let_syntax : sig val return : 'a -> ('a, 'i, 'i) t include Infix_indexed with type ('a, 'i, 'j) t := ('a, 'i, 'j) t module Let_syntax : sig val return : 'a -> ('a, 'i, 'i) t val bind : ('a, 'i, 'j) t -> f:('a -> ('b, 'j, 'k) t) -> ('b, 'i, 'k) t val map : ('a, 'i, 'j) t -> f:('a -> 'b) -> ('b, 'i, 'j) t val both : ('a, 'i, 'j) t -> ('b, 'j, 'k) t -> ('a * 'b, 'i, 'k) t module Open_on_rhs : sig end end end end module type S_indexed = sig (** The same as {!S} except the monad type has three arguments. The second and third are composed across all computation. *) type ('a, 'i, 'j) t include Infix_indexed with type ('a, 'i, 'j) t := ('a, 'i, 'j) t include Syntax_indexed with type ('a, 'i, 'j) t := ('a, 'i, 'j) t module Monad_infix : Infix_indexed with type ('a, 'i, 'j) t := ('a, 'i, 'j) t val bind : ('a, 'i, 'j) t -> f:('a -> ('b, 'j, 'k) t) -> ('b, 'i, 'k) t val return : 'a -> ('a, 'i, 'i) t val map : ('a, 'i, 'j) t -> f:('a -> 'b) -> ('b, 'i, 'j) t val join : (('a, 'j, 'k) t, 'i, 'j) t -> ('a, 'i, 'k) t val ignore_m : (_, 'i, 'j) t -> (unit, 'i, 'j) t val all : ('a, 'i, 'i) t list -> ('a list, 'i, 'i) t val all_unit : (unit, 'i, 'i) t list -> (unit, 'i, 'i) t end module S_to_S2 (X : S) : S2 with type ('a, 'e) t = 'a X.t = struct include X type ('a, 'e) t = 'a X.t end module S2_to_S3 (X : S2) : S3 with type ('a, 'd, 'e) t = ('a, 'd) X.t = struct include X type ('a, 'd, 'e) t = ('a, 'd) X.t end module S_to_S_indexed (X : S) : S_indexed with type ('a, 'i, 'j) t = 'a X.t = struct include X type ('a, 'i, 'j) t = 'a X.t end module S2_to_S (X : S2) : S with type 'a t = ('a, unit) X.t = struct include X type 'a t = ('a, unit) X.t end module S3_to_S2 (X : S3) : S2 with type ('a, 'e) t = ('a, 'e, unit) X.t = struct include X type ('a, 'e) t = ('a, 'e, unit) X.t end module S_indexed_to_S2 (X : S_indexed) : S2 with type ('a, 'e) t = ('a, 'e, 'e) X.t = struct include X type ('a, 'e) t = ('a, 'e, 'e) X.t end module type Monad = sig (** A monad is an abstraction of the concept of sequencing of computations. A value of type ['a monad] represents a computation that returns a value of type ['a]. *) module type Basic = Basic module type Basic2 = Basic2 module type Basic3 = Basic3 module type Basic_indexed = Basic_indexed module type Basic_local = Basic_local module type Basic2_local = Basic2_local module type Infix = Infix module type Infix2 = Infix2 module type Infix3 = Infix3 module type Infix_indexed = Infix_indexed module type Infix_local = Infix_local module type Infix2_local = Infix2_local module type Syntax = Syntax module type Syntax2 = Syntax2 module type Syntax3 = Syntax3 module type Syntax_indexed = Syntax_indexed module type Syntax_local = Syntax_local module type Syntax2_local = Syntax2_local module type S_without_syntax = S_without_syntax module type S_without_syntax_local = S_without_syntax_local module type S = S module type S2 = S2 module type S3 = S3 module type S_indexed = S_indexed module type S_local = S_local module type S2_local = S2_local module Make (X : Basic) : S with type 'a t := 'a X.t module Make2 (X : Basic2) : S2 with type ('a, 'e) t := ('a, 'e) X.t module Make3 (X : Basic3) : S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t module Make_indexed (X : Basic_indexed) : S_indexed with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t module Make_local (X : Basic_local) : S_local with type 'a t := 'a X.t module Make2_local (X : Basic2_local) : S2_local with type ('a, 'e) t := ('a, 'e) X.t (** Define a monad through an isomorphism with an existing monad. For example: {[ type 'a t = { value : 'a } include Monad.Of_monad (Monad.Ident) (struct type nonrec 'a t = 'a t let to_monad { value } = value let of_monad value = { value } end) ]} *) module Of_monad (Monad : S) (M : sig type 'a t val to_monad : 'a t -> 'a Monad.t val of_monad : 'a Monad.t -> 'a t end) : S with type 'a t := 'a M.t module Of_monad2 (Monad : S2) (M : sig type ('a, 'b) t val to_monad : ('a, 'b) t -> ('a, 'b) Monad.t val of_monad : ('a, 'b) Monad.t -> ('a, 'b) t end) : S2 with type ('a, 'b) t := ('a, 'b) M.t module Of_monad3 (Monad : S3) (M : sig type ('a, 'b, 'c) t val to_monad : ('a, 'b, 'c) t -> ('a, 'b, 'c) Monad.t val of_monad : ('a, 'b, 'c) Monad.t -> ('a, 'b, 'c) t end) : S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) M.t module Of_monad_indexed (Monad : S_indexed) (M : sig type ('a, 'i, 'j) t val to_monad : ('a, 'i, 'j) t -> ('a, 'i, 'j) Monad.t val of_monad : ('a, 'i, 'j) Monad.t -> ('a, 'i, 'j) t end) : S_indexed with type ('a, 'i, 'j) t := ('a, 'i, 'j) M.t (** An eager identity monad with functions heavily annotated with [@inlined] or [@inline hint]. The implementation is manually written, rather than being constructed by [Monad.Make]. This gives better inlining guarantees. *) module Ident : S_local with type 'a t = 'a end base-0.16.3/src/nativeint.ml000066400000000000000000000177561446274340700156700ustar00rootroot00000000000000open! Import open! Stdlib.Nativeint include Nativeint_replace_polymorphic_compare module T = struct type t = nativeint [@@deriving_inline globalize, hash, sexp, sexp_grammar] let (globalize : (t[@ocaml.local]) -> t) = (globalize_nativeint : (t[@ocaml.local]) -> t) ;; let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = hash_fold_nativeint and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = hash_nativeint in fun x -> func x ;; let t_of_sexp = (nativeint_of_sexp : Sexplib0.Sexp.t -> t) let sexp_of_t = (sexp_of_nativeint : t -> Sexplib0.Sexp.t) let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = nativeint_sexp_grammar [@@@end] let hashable : t Hashable.t = { hash; compare; sexp_of_t } let compare = Nativeint_replace_polymorphic_compare.compare let to_string = to_string let of_string = of_string let of_string_opt = of_string_opt end include T include Comparator.Make (T) include Comparable.With_zero (struct include T let zero = zero end) module Conv = Int_conversions include Conv.Make (T) include Conv.Make_hex (struct open Nativeint_replace_polymorphic_compare type t = nativeint [@@deriving_inline compare, hash] let compare = (compare_nativeint : t -> t -> int) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = hash_fold_nativeint and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = hash_nativeint in fun x -> func x ;; [@@@end] let zero = zero let neg = neg let ( < ) = ( < ) let to_string i = Printf.sprintf "%nx" i let of_string s = Stdlib.Scanf.sscanf s "%nx" Fn.id let module_name = "Base.Nativeint.Hex" end) include Pretty_printer.Register (struct type nonrec t = t let to_string = to_string let module_name = "Base.Nativeint" end) (* Open replace_polymorphic_compare after including functor instantiations so they do not shadow its definitions. This is here so that efficient versions of the comparison functions are available within this module. *) open! Nativeint_replace_polymorphic_compare let invariant (_ : t) = () let num_bits = Word_size.num_bits Word_size.word_size let float_lower_bound = Float0.lower_bound_for_int num_bits let float_upper_bound = Float0.upper_bound_for_int num_bits let shift_right_logical = shift_right_logical let shift_right = shift_right let shift_left = shift_left let bit_not = lognot let bit_xor = logxor let bit_or = logor let bit_and = logand let min_value = min_int let max_value = max_int let abs = abs let pred = pred let succ = succ let rem = rem let neg = neg let minus_one = minus_one let one = one let zero = zero let to_float = to_float let of_float_unchecked = of_float let of_float f = if Float_replace_polymorphic_compare.( >= ) f float_lower_bound && Float_replace_polymorphic_compare.( <= ) f float_upper_bound then of_float f else Printf.invalid_argf "Nativeint.of_float: argument (%f) is out of range or NaN" (Float0.box f) () ;; module Pow2 = struct open! Import open Nativeint_replace_polymorphic_compare let raise_s = Error.raise_s let non_positive_argument () = Printf.invalid_argf "argument must be strictly positive" () ;; let ( lor ) = Stdlib.Nativeint.logor let ( lsr ) = Stdlib.Nativeint.shift_right_logical let ( land ) = Stdlib.Nativeint.logand (** "ceiling power of 2" - Least power of 2 greater than or equal to x. *) let ceil_pow2 (x : nativeint) = if x <= 0n then non_positive_argument (); let x = Stdlib.Nativeint.pred x in let x = x lor (x lsr 1) in let x = x lor (x lsr 2) in let x = x lor (x lsr 4) in let x = x lor (x lsr 8) in let x = x lor (x lsr 16) in (* The next line is superfluous on 32-bit architectures, but it's faster to do it anyway than to branch *) let x = x lor (x lsr 32) in Stdlib.Nativeint.succ x ;; (** "floor power of 2" - Largest power of 2 less than or equal to x. *) let floor_pow2 x = if x <= 0n then non_positive_argument (); let x = x lor (x lsr 1) in let x = x lor (x lsr 2) in let x = x lor (x lsr 4) in let x = x lor (x lsr 8) in let x = x lor (x lsr 16) in let x = x lor (x lsr 32) in Stdlib.Nativeint.sub x (x lsr 1) ;; let is_pow2 x = if x <= 0n then non_positive_argument (); x land Stdlib.Nativeint.pred x = 0n ;; (* C stubs for nativeint clz and ctz to use the CLZ/BSR/CTZ/BSF instruction where possible *) external clz : (nativeint[@unboxed]) -> (int[@untagged]) = "Base_int_math_nativeint_clz" "Base_int_math_nativeint_clz_unboxed" [@@noalloc] external ctz : (nativeint[@unboxed]) -> (int[@untagged]) = "Base_int_math_nativeint_ctz" "Base_int_math_nativeint_ctz_unboxed" [@@noalloc] (** Hacker's Delight Second Edition p106 *) let floor_log2 i = if Poly.( <= ) i Stdlib.Nativeint.zero then raise_s (Sexp.message "[Nativeint.floor_log2] got invalid input" [ "", sexp_of_nativeint i ]); num_bits - 1 - clz i ;; (** Hacker's Delight Second Edition p106 *) let ceil_log2 i = if Poly.( <= ) i Stdlib.Nativeint.zero then raise_s (Sexp.message "[Nativeint.ceil_log2] got invalid input" [ "", sexp_of_nativeint i ]); if Stdlib.Nativeint.equal i Stdlib.Nativeint.one then 0 else num_bits - clz (Stdlib.Nativeint.pred i) ;; end include Pow2 let between t ~low ~high = low <= t && t <= high let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max let clamp_exn t ~min ~max = assert (min <= max); clamp_unchecked t ~min ~max ;; let clamp t ~min ~max = if min > max then Or_error.error_s (Sexp.message "clamp requires [min <= max]" [ "min", T.sexp_of_t min; "max", T.sexp_of_t max ]) else Ok (clamp_unchecked t ~min ~max) ;; let ( / ) = div let ( * ) = mul let ( - ) = sub let ( + ) = add let ( ~- ) = neg let incr r = r := !r + one let decr r = r := !r - one let of_nativeint t = t let of_nativeint_exn = of_nativeint let to_nativeint t = t let to_nativeint_exn = to_nativeint let popcount = Popcount.nativeint_popcount let of_int = Conv.int_to_nativeint let of_int_exn = of_int let to_int = Conv.nativeint_to_int let to_int_exn = Conv.nativeint_to_int_exn let to_int_trunc = Conv.nativeint_to_int_trunc let of_int32 = Conv.int32_to_nativeint let of_int32_exn = of_int32 let to_int32 = Conv.nativeint_to_int32 let to_int32_exn = Conv.nativeint_to_int32_exn let to_int32_trunc = Conv.nativeint_to_int32_trunc let of_int64 = Conv.int64_to_nativeint let of_int64_exn = Conv.int64_to_nativeint_exn let of_int64_trunc = Conv.int64_to_nativeint_trunc let to_int64 = Conv.nativeint_to_int64 let pow b e = of_int_exn (Int_math.Private.int_pow (to_int_exn b) (to_int_exn e)) let ( ** ) b e = pow b e module Pre_O = struct let ( + ) = ( + ) let ( - ) = ( - ) let ( * ) = ( * ) let ( / ) = ( / ) let ( ~- ) = ( ~- ) let ( ** ) = ( ** ) include (Nativeint_replace_polymorphic_compare : Comparisons.Infix with type t := t) let abs = abs let neg = neg let zero = zero let of_int_exn = of_int_exn end module O = struct include Pre_O include Int_math.Make (struct type nonrec t = t include Pre_O let rem = rem let to_float = to_float let of_float = of_float let of_string = T.of_string let to_string = T.to_string end) let ( land ) = bit_and let ( lor ) = bit_or let ( lxor ) = bit_xor let lnot = bit_not let ( lsl ) = shift_left let ( asr ) = shift_right let ( lsr ) = shift_right_logical end include O (* [Nativeint] and [Nativeint.O] agree value-wise *) (* Include type-specific [Replace_polymorphic_compare] at the end, after including functor application that could shadow its definitions. This is here so that efficient versions of the comparison functions are exported by this module. *) include Nativeint_replace_polymorphic_compare external bswap : (t[@local_opt]) -> (t[@local_opt]) = "%bswap_native" base-0.16.3/src/nativeint.mli000066400000000000000000000016321446274340700160230ustar00rootroot00000000000000(** Processor-native integers. *) open! Import type t = nativeint [@@deriving_inline globalize] val globalize : (t[@ocaml.local]) -> t [@@@end] include Int_intf.S with type t := t (** {2 Conversion functions} *) val of_int : int -> t val to_int : t -> int option val of_int32 : int32 -> t val to_int32 : t -> int32 option val of_nativeint : nativeint -> t val to_nativeint : t -> nativeint val of_int64 : int64 -> t option (** {3 Truncating conversions} These functions return the least-significant bits of the input. In cases where optional conversions return [Some x], truncating conversions return [x]. *) val to_int_trunc : t -> int val to_int32_trunc : t -> int32 val of_int64_trunc : int64 -> t (** {2 Byte swap functions} See {{!modtype:Int.Int_without_module_types}[Int]'s byte swap section} for a description of Base's approach to exposing byte swap primitives. *) val bswap : t -> t base-0.16.3/src/nothing.ml000066400000000000000000000012101446274340700153070ustar00rootroot00000000000000open! Import module T = struct type t = | let unreachable_code = function | (_ : t) -> . ;; let all = [] let hash_fold_t _ t = unreachable_code t let hash = unreachable_code let compare a _ = unreachable_code a let sexp_of_t = unreachable_code let t_of_sexp sexp = Sexplib0.Sexp_conv_error.empty_type "Base.Nothing.t" sexp let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Union [] } let to_string = unreachable_code let of_string (_ : string) = failwith "Base.Nothing.of_string: not supported" end include T include Identifiable.Make (struct include T let module_name = "Base.Nothing" end) base-0.16.3/src/nothing.mli000066400000000000000000000047741446274340700155020ustar00rootroot00000000000000(** An uninhabited type. This is useful when interfaces require that a type be specified, but the implementer knows this type will not be used in their implementation of the interface. For instance, [Async.Rpc.Pipe_rpc.t] is parameterized by an error type, but a user may want to define a Pipe RPC that can't fail. *) open! Import (** Having [[@@deriving enumerate]] may seem strange due to the fact that generated [val all : t list] is the empty list, so it seems like it could be of no use. This may be true if you always expect your type to be [Nothing.t], but [[@@deriving enumerate]] can be useful if you have a type which you expect to change over time. For example, you may have a program which has to interact with multiple servers which are possibly at different versions. It may be useful in this program to have a variant type which enumerates the ways in which the servers may differ. When all the servers are at the same version, you can change this type to [Nothing.t] and code which uses an enumeration of the type will continue to work correctly. This is a similar issue to the identifiability of [Nothing.t]. As discussed below, another case where [[@deriving enumerate]] could be useful is when this type is part of some larger type. *) type t = | [@@deriving_inline enumerate, sexp_grammar] include Ppx_enumerate_lib.Enumerable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] (** Because there are no values of type [Nothing.t], a piece of code that has a value of type [Nothing.t] must be unreachable. In such an unreachable piece of code, one can use [unreachable_code] to give the code whatever type one needs. For example: {[ let f (r : (int, Nothing.t) Result.t) : int = match r with | Ok i -> i | Error n -> Nothing.unreachable_code n ;; ]} Note that the compiler knows that [Nothing.t] is uninhabited, hence this will type without warning: {[ let f (Ok i : (int, Nothing.t) Result.t) = i ]} *) val unreachable_code : t -> _ (** It may seem weird that this is identifiable, but we're just trying to anticipate all the contexts in which people may need this. It would be a crying shame if you had some variant type involving [Nothing.t] that you wished to make identifiable, but were prevented for lack of [Identifiable.S] here. Obviously, [of_string] and [t_of_sexp] will raise an exception. *) include Identifiable.S with type t := t base-0.16.3/src/obj_array.ml000066400000000000000000000157251446274340700156310ustar00rootroot00000000000000open! Import module Int = Int0 module String = String0 module Array = Array0 (* We maintain the property that all values of type [t] do not have the tag [double_array_tag]. Some functions below assume this in order to avoid testing the tag, and will segfault if this property doesn't hold. *) type t = Stdlib.Obj.t array let invariant t = assert (Stdlib.Obj.tag (Stdlib.Obj.repr t) <> Stdlib.Obj.double_array_tag) ;; let length = Array.length (* would check for float arrays in 32 bit, but whatever *) let sexp_of_t t = Sexp.Atom (String.concat ~sep:"" [ "" ]) ;; let zero_obj = Stdlib.Obj.repr (0 : int) (* We call [Array.create] with a value that is not a float so that the array doesn't get tagged with [Double_array_tag]. *) let create_zero ~len = Array.create ~len zero_obj let empty = [||] type not_a_float = | Not_a_float_0 | Not_a_float_1 of int let _not_a_float_0 = Not_a_float_0 let _not_a_float_1 = Not_a_float_1 42 let get t i = (* Make the compiler believe [t] is an array not containing floats so it does not check if [t] is tagged with [Double_array_tag]. It is NOT ok to use [int array] since (if this function is inlined and the array contains in-heap boxed values) wrong register typing may result, leading to a failure to register necessary GC roots. *) Stdlib.Obj.repr (* [Sys.opaque_identity] is required on the array because this code breaks the usual assumptions about array kinds that the Flambda 2 optimiser can see. *) ((Sys.opaque_identity (Stdlib.Obj.magic (t : t) : not_a_float array)).(i) : not_a_float) ;; let[@inline always] unsafe_get t i = (* Make the compiler believe [t] is an array not containing floats so it does not check if [t] is tagged with [Double_array_tag]. *) Stdlib.Obj.repr (Array.unsafe_get (Sys.opaque_identity (Obj_local.magic (t : t) : not_a_float array)) i : not_a_float) ;; let[@inline always] unsafe_set_with_caml_modify t i obj = (* Same comment as [unsafe_get]. Sys.opaque_identity prevents the compiler from potentially wrongly guessing the type of the array based on the type of element, that is prevent the implication: (Obj.tag obj = Obj.double_tag) => (Obj.tag t = Obj.double_array_tag) which flambda has tried in the past (at least that's assuming the compiler respects Sys.opaque_identity, which is not always the case). *) Array.unsafe_set (Sys.opaque_identity (Obj_local.magic (t : t) : not_a_float array)) i (Stdlib.Obj.obj (Sys.opaque_identity obj) : not_a_float) ;; let[@inline always] set_with_caml_modify t i obj = (* same as unsafe_set_with_caml_modify but safe *) (Sys.opaque_identity (Stdlib.Obj.magic (t : t) : not_a_float array)).(i) <- (Stdlib.Obj.obj (Sys.opaque_identity obj) : not_a_float) ;; let[@inline always] unsafe_set_int_assuming_currently_int t i int = (* This skips [caml_modify], which is OK if both the old and new values are integers. *) Array.unsafe_set (Sys.opaque_identity (Obj_local.magic (t : t) : int array)) i (Sys.opaque_identity int) ;; (* For [set] and [unsafe_set], if a pointer is involved, we first do a physical-equality test to see if the pointer is changing. If not, we don't need to do the [set], which saves a call to [caml_modify]. We think this physical-equality test is worth it because it is very cheap (both values are already available from the [is_int] test) and because [caml_modify] is expensive. *) let set t i obj = (* We use [get] first but then we use [Array.unsafe_set] since we know that [i] is valid. *) let old_obj = get t i in if Stdlib.Obj.is_int old_obj && Stdlib.Obj.is_int obj then unsafe_set_int_assuming_currently_int t i (Stdlib.Obj.obj obj : int) else if not (phys_equal old_obj obj) then unsafe_set_with_caml_modify t i obj ;; let[@inline always] unsafe_set t i obj = let old_obj = unsafe_get t i in if Stdlib.Obj.is_int old_obj && Stdlib.Obj.is_int obj then unsafe_set_int_assuming_currently_int t i (Stdlib.Obj.obj obj : int) else if not (phys_equal old_obj obj) then unsafe_set_with_caml_modify t i obj ;; let[@inline always] unsafe_set_omit_phys_equal_check t i obj = let old_obj = unsafe_get t i in if Stdlib.Obj.is_int old_obj && Stdlib.Obj.is_int obj then unsafe_set_int_assuming_currently_int t i (Stdlib.Obj.obj obj : int) else unsafe_set_with_caml_modify t i obj ;; let swap t i j = let a = get t i in let b = get t j in unsafe_set t i b; unsafe_set t j a ;; let create ~len x = (* If we can, use [Array.create] directly. Even though [is_int] check is subsumed by the tag check, checking it is much faster, since it avoids a C function call. *) if Stdlib.Obj.is_int x || Stdlib.Obj.tag x <> Stdlib.Obj.double_tag then Array.create ~len x else ( (* Otherwise use [create_zero] and set the contents *) let t = create_zero ~len in let x = Sys.opaque_identity x in for i = 0 to len - 1 do unsafe_set_with_caml_modify t i x done; t) ;; let singleton obj = create ~len:1 obj (* Pre-condition: t.(i) is an integer. *) let unsafe_set_assuming_currently_int t i obj = if Stdlib.Obj.is_int obj then unsafe_set_int_assuming_currently_int t i (Stdlib.Obj.obj obj : int) else (* [t.(i)] is an integer and [obj] is not, so we do not need to check if they are equal. *) unsafe_set_with_caml_modify t i obj ;; let unsafe_set_int t i int = let old_obj = unsafe_get t i in if Stdlib.Obj.is_int old_obj then unsafe_set_int_assuming_currently_int t i int else unsafe_set_with_caml_modify t i (Stdlib.Obj.repr int) ;; let unsafe_clear_if_pointer t i = let old_obj = unsafe_get t i in if not (Stdlib.Obj.is_int old_obj) then unsafe_set_with_caml_modify t i (Stdlib.Obj.repr 0) ;; (** [unsafe_blit] is like [Array.blit], except it uses our own for-loop to avoid caml_modify when possible. Its performance is still not comparable to a memcpy. *) let unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len = (* When [phys_equal src dst], we need to check whether [dst_pos < src_pos] and have the for loop go in the right direction so that we don't overwrite data that we still need to read. When [not (phys_equal src dst)], doing this is harmless. From a memory-performance perspective, it doesn't matter whether one loops up or down. Constant-stride access, forward or backward, should be indistinguishable (at least on an intel i7). So, we don't do a check for [phys_equal src dst] and always loop up in that case. *) if dst_pos < src_pos then for i = 0 to len - 1 do unsafe_set dst (dst_pos + i) (unsafe_get src (src_pos + i)) done else for i = len - 1 downto 0 do unsafe_set dst (dst_pos + i) (unsafe_get src (src_pos + i)) done ;; include Blit.Make (struct type nonrec t = t let create = create_zero let length = length let unsafe_blit = unsafe_blit end) let copy src = let dst = create_zero ~len:(length src) in blito ~src ~dst (); dst ;; base-0.16.3/src/obj_array.mli000066400000000000000000000062211446274340700157710ustar00rootroot00000000000000(** This module is not exposed for external use, and is only here for the implementation of [Uniform_array] internally. [Obj.t Uniform_array.t] should be used in place of [Obj_array.t]. *) open! Import type t [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] include Blit.S with type t := t include Invariant.S with type t := t (** [create ~len x] returns an obj-array of length [len], all of whose indices have value [x]. *) val create : len:int -> Stdlib.Obj.t -> t (** [create_zero ~len] returns an obj-array of length [len], all of whose indices have value [Stdlib.Obj.repr 0]. *) val create_zero : len:int -> t (** [copy t] returns a new array with the same elements as [t]. *) val copy : t -> t val singleton : Stdlib.Obj.t -> t val empty : t val length : (t[@local]) -> int (** [get t i] and [unsafe_get t i] return the object at index [i]. [set t i o] and [unsafe_set t i o] set index [i] to [o]. In no case is the object copied. The [unsafe_*] variants omit the bounds check of [i]. *) val get : t -> int -> Stdlib.Obj.t val unsafe_get : (t[@local]) -> int -> Stdlib.Obj.t val set : t -> int -> Stdlib.Obj.t -> unit val unsafe_set : (t[@local]) -> int -> Stdlib.Obj.t -> unit val swap : t -> int -> int -> unit (** [set_with_caml_modify] simply sets the value in the array with no bells and whistles, unlike [set] which first reads the value to optimize immediate values and setting the index to its current value. This can be used when these optimizations are not useful, but the noise in generated code is annoying (and might have an impact on performance, although this is pure speculation). *) val set_with_caml_modify : t -> int -> Stdlib.Obj.t -> unit (** [unsafe_set_assuming_currently_int t i obj] sets index [i] of [t] to [obj], but only works correctly if [Stdlib.Obj.is_int (get t i)]. This precondition saves a dynamic check. [unsafe_set_int_assuming_currently_int] is similar, except the value being set is an int. [unsafe_set_int] is similar but does not assume anything about the target. *) val unsafe_set_assuming_currently_int : (t[@local]) -> int -> Stdlib.Obj.t -> unit val unsafe_set_int_assuming_currently_int : (t[@local]) -> int -> int -> unit val unsafe_set_int : t -> int -> int -> unit (** [unsafe_set_omit_phys_equal_check] is like [unsafe_set], except it doesn't do a [phys_equal] check to try to skip [caml_modify]. It is safe to call this even if the values are [phys_equal]. *) val unsafe_set_omit_phys_equal_check : t -> int -> Stdlib.Obj.t -> unit (** Same as [set_with_caml_modify], but without bounds checks. This is like [unsafe_set_omit_phys_equal_check] except it doesn't check whether the old value and the value being set are integers to try to skip [caml_modify]. *) val unsafe_set_with_caml_modify : (t[@local]) -> int -> Stdlib.Obj.t -> unit (** [unsafe_clear_if_pointer t i] prevents [t.(i)] from pointing to anything to prevent space leaks. It does this by setting [t.(i)] to [Stdlib.Obj.repr 0]. As a performance hack, it only does this when [not (Stdlib.Obj.is_int t.(i))]. *) val unsafe_clear_if_pointer : t -> int -> unit base-0.16.3/src/obj_local.ml000066400000000000000000000012031446274340700155670ustar00rootroot00000000000000open! Import type t = Stdlib.Obj.t type raw_data = Stdlib.Obj.raw_data external magic : (_[@local_opt]) -> (_[@local_opt]) = "%identity" external repr : (_[@local_opt]) -> (t[@local_opt]) = "%identity" external obj : (t[@local_opt]) -> (_[@local_opt]) = "%identity" (* The result doesn't need to be marked local because the data is copied into a fresh nativeint block regardless. *) external raw_field : (t[@local_opt]) -> int -> raw_data = "caml_obj_raw_field" external set_raw_field : (t[@local_opt]) -> int -> raw_data -> unit = "caml_obj_set_raw_field" external tag : (t[@local_opt]) -> int = "caml_obj_tag" [@@noalloc] base-0.16.3/src/obj_local.mli000066400000000000000000000011051446274340700157410ustar00rootroot00000000000000(** Versions of [Obj] functions that work with locals. *) open! Import type t = Stdlib.Obj.t type raw_data = Stdlib.Obj.raw_data external magic : (_[@local_opt]) -> (_[@local_opt]) = "%identity" external repr : (_[@local_opt]) -> (t[@local_opt]) = "%identity" external obj : (t[@local_opt]) -> (_[@local_opt]) = "%identity" external raw_field : (t[@local_opt]) -> int -> raw_data = "caml_obj_raw_field" external set_raw_field : (t[@local_opt]) -> int -> raw_data -> unit = "caml_obj_set_raw_field" external tag : (t[@local_opt]) -> int = "caml_obj_tag" [@@noalloc] base-0.16.3/src/option.ml000066400000000000000000000117331446274340700151640ustar00rootroot00000000000000open! Import include ( struct type 'a t = 'a option [@@deriving_inline compare, globalize, hash, sexp, sexp_grammar] let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = compare_option let globalize : 'a. (('a[@ocaml.local]) -> 'a) -> ('a t[@ocaml.local]) -> 'a t = fun (type a__005_) : (((a__005_[@ocaml.local]) -> a__005_) -> (a__005_ t[@ocaml.local]) -> a__005_ t) -> globalize_option ;; let hash_fold_t : 'a. (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) -> Ppx_hash_lib.Std.Hash.state -> 'a t -> Ppx_hash_lib.Std.Hash.state = hash_fold_option ;; let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = option_of_sexp ;; let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = sexp_of_option ;; let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> option_sexp_grammar _'a_sexp_grammar ;; [@@@end] end : sig type 'a t = 'a option [@@deriving_inline compare, globalize, hash, sexp, sexp_grammar] include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t val globalize : (('a[@ocaml.local]) -> 'a) -> ('a t[@ocaml.local]) -> 'a t include Ppx_hash_lib.Hashable.S1 with type 'a t := 'a t include Sexplib0.Sexpable.S1 with type 'a t := 'a t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] end) type 'a t = 'a option = | None | Some of 'a let is_none = function | None -> true | _ -> false ;; let is_some = function | Some _ -> true | _ -> false ;; let value_map o ~default ~f = match o with | Some x -> f x | None -> default ;; let iter o ~f = match o with | None -> () | Some a -> f a ;; let invariant f t = iter t ~f let call x ~f = match f with | None -> () | Some f -> f x ;; let value t ~default = match t with | None -> default | Some x -> x ;; let value_exn ?here ?error ?message t = match t with | Some x -> x | None -> let error = match here, error, message with | None, None, None -> Error.of_string "Option.value_exn None" | None, None, Some m -> Error.of_string m | None, Some e, None -> e | None, Some e, Some m -> Error.tag e ~tag:m | Some p, None, None -> Error.create "Option.value_exn" p Source_code_position0.sexp_of_t | Some p, None, Some m -> Error.create m p Source_code_position0.sexp_of_t | Some p, Some e, _ -> Error.create (value message ~default:"") (e, p) (sexp_of_pair Error.sexp_of_t Source_code_position0.sexp_of_t) in Error.raise error ;; let value_or_thunk o ~default = match o with | Some x -> x | None -> default () ;; let to_array t = match t with | None -> [||] | Some x -> [| x |] ;; let to_list t = match t with | None -> [] | Some x -> [ x ] ;; let min_elt t ~compare:_ = t let max_elt t ~compare:_ = t let sum (type a) (module M : Container.Summable with type t = a) t ~f = value_map t ~default:M.zero ~f ;; let for_all t ~f = match t with | None -> true | Some x -> f x ;; let exists t ~f = match t with | None -> false | Some x -> f x ;; let mem t a ~equal = match t with | None -> false | Some a' -> equal a a' ;; let length t = match t with | None -> 0 | Some _ -> 1 ;; let is_empty = is_none let fold t ~init ~f = match t with | None -> init | Some x -> f init x ;; let count t ~f = match t with | None -> 0 | Some a -> if f a then 1 else 0 ;; let find t ~f = match t with | None -> None | Some x -> if f x then t else None ;; let find_map t ~f = match t with | None -> None | Some a -> f a ;; let equal f t t' = match t, t' with | None, None -> true | Some x, Some x' -> f x x' | _ -> false ;; let some x = Some x let first_some x y = match x with | Some _ -> x | None -> y ;; let some_if cond x = if cond then Some x else None let merge a b ~f = match a, b with | None, x | x, None -> x | Some a, Some b -> Some (f a b) ;; let filter t ~f = match t with | Some v as o when f v -> o | _ -> None ;; let try_with f = match f () with | x -> Some x | exception _ -> None ;; let try_with_join f = match f () with | x -> x | exception _ -> None ;; let map t ~f = match t with | None -> None | Some a -> Some (f a) ;; module Monad_arg = struct type 'a t = 'a option let return x = Some x let map = `Custom map let bind o ~f = match o with | None -> None | Some x -> f x ;; end include Monad.Make_local (Monad_arg) module Applicative_arg = struct type 'a t = 'a option let return x = Some x let map = `Custom map let map2 x y ~f = match x, y with | None, _ | _, None -> None | Some x, Some y -> Some (f x y) ;; end include Applicative.Make_using_map2_local (Applicative_arg) let fold_result t ~init ~f = Container.fold_result ~fold ~init ~f t let fold_until t ~init ~f ~finish = Container.fold_until ~fold ~init ~f t ~finish base-0.16.3/src/option.mli000066400000000000000000000136271446274340700153410ustar00rootroot00000000000000(** The option type indicates whether a meaningful value is present. It is frequently used to represent success or failure, using [None] for failure. To be more descriptive about why a function failed, see the {!Or_error} module. Usage example from a utop session follows. Hash table lookups use the option type to indicate success or failure when looking up a key. {v # let h = Hashtbl.of_alist (module String) [ ("Bar", "Value") ];; val h : (string, string) Hashtbl.t = ;; - : (string, string) Hashtbl.t = # Hashtbl.find h "Foo";; - : string option = None # Hashtbl.find h "Bar";; - : string option = Some "Value" v} *) open! Import (** {2 Type and Interfaces} *) type 'a t = 'a option = | None | Some of 'a [@@deriving_inline compare, globalize, hash, sexp_grammar] include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t val globalize : (('a[@ocaml.local]) -> 'a) -> ('a t[@ocaml.local]) -> 'a t include Ppx_hash_lib.Hashable.S1 with type 'a t := 'a t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] include Equal.S1 with type 'a t := 'a t include Invariant.S1 with type 'a t := 'a t include Sexpable.S1 with type 'a t := 'a t (** {3 Applicative interface} Options form an applicative, where: {ul {- [return x = Some x] } {- [None <*> x = None] } {- [Some f <*> None = None] } {- [Some f <*> Some x = Some (f x)] }} *) include Applicative.S_local with type 'a t := 'a t (** {3 Monadic interface} Options form a monad, where: {ul {- [return x = Some x]} {- [(None >>= f) = None]} {- [(Some x >>= f) = f x]}} *) include Monad.S_local with type 'a t := 'a t (** {2 Extracting Underlying Values} *) (** Extracts the underlying value if present, otherwise returns [default]. *) val value : 'a t -> default:'a -> 'a (** Extracts the underlying value, or raises if there is no value present. The error raised can be augmented using the [~here], [~error], and [~message] optional arguments. *) val value_exn : ?here:Source_code_position0.t -> ?error:Error.t -> ?message:string -> 'a t -> 'a (** Extracts the underlying value and applies [f] to it if present, otherwise returns [default]. *) val value_map : 'a t -> default:'b -> f:(('a -> 'b)[@local]) -> 'b (** Extracts the underlying value if present, otherwise executes and returns the result of [default]. [default] is only executed if the underlying value is absent. *) val value_or_thunk : 'a t -> default:((unit -> 'a)[@local]) -> 'a (** On [None], returns [init]. On [Some x], returns [f init x]. *) val fold : 'a t -> init:'acc -> f:(('acc -> 'a -> 'acc)[@local]) -> 'acc (** Checks whether the provided element is there, using [equal]. *) val mem : 'a t -> 'a -> equal:(('a -> 'a -> bool)[@local]) -> bool val length : 'a t -> int val iter : 'a t -> f:(('a -> unit)[@local]) -> unit (** On [None], returns [false]. On [Some x], returns [f x]. *) val exists : 'a t -> f:(('a -> bool)[@local]) -> bool (** On [None], returns [true]. On [Some x], returns [f x]. *) val for_all : 'a t -> f:(('a -> bool)[@local]) -> bool (** [find t ~f] returns [t] if [t = Some x] and [f x = true]; otherwise, [find] returns [None]. *) val find : 'a t -> f:(('a -> bool)[@local]) -> 'a option (** On [None], returns [None]. On [Some x], returns [f x]. *) val find_map : 'a t -> f:(('a -> 'b option)[@local]) -> 'b option val to_list : 'a t -> 'a list val to_array : 'a t -> 'a array (** [call x f] runs an optional function [~f] on the argument. *) val call : 'a -> f:(('a -> unit) t[@local]) -> unit (** [merge a b ~f] merges together the values from [a] and [b] using [f]. If both [a] and [b] are [None], returns [None]. If only one is [Some], returns that one, and if both are [Some], returns [Some] of the result of applying [f] to the contents of [a] and [b]. *) val merge : 'a t -> 'a t -> f:(('a -> 'a -> 'a)[@local]) -> 'a t val filter : 'a t -> f:(('a -> bool)[@local]) -> 'a t (** {2 Constructors} *) (** [try_with f] returns [Some x] if [f] returns [x] and [None] if [f] raises an exception. See [Result.try_with] if you'd like to know which exception. *) val try_with : ((unit -> 'a)[@local]) -> 'a t (** [try_with_join f] returns the optional value returned by [f] if it exits normally, and [None] if [f] raises an exception. *) val try_with_join : ((unit -> 'a t)[@local]) -> 'a t (** Wraps the [Some] constructor as a function. *) val some : 'a -> 'a t (** [first_some t1 t2] returns [t1] if it has an underlying value, or [t2] otherwise. *) val first_some : 'a t -> 'a t -> 'a t (** [some_if b x] converts a value [x] to [Some x] if [b], and [None] otherwise. *) val some_if : bool -> 'a -> 'a t (** {2 Predicates} *) (** [is_none t] returns true iff [t = None]. *) val is_none : 'a t -> bool (** [is_some t] returns true iff [t = Some x]. *) val is_some : 'a t -> bool (**/**) val is_empty : 'a t -> bool [@@deprecated "[since 2019-07] Use [is_none] instead"] val fold_result : 'a t -> init:'acc -> f:(('acc -> 'a -> ('acc, 'e) Result.t)[@local]) -> ('acc, 'e) Result.t [@@deprecated "[since 2019-07] It is not a useful function"] val fold_until : 'a t -> init:'acc -> f:(('acc -> 'a -> ('acc, 'final) Container.Continue_or_stop.t)[@local]) -> finish:(('acc -> 'final)[@local]) -> 'final [@@deprecated "[since 2019-07] It is not a useful function"] val min_elt : 'a t -> compare:(('a -> 'a -> int)[@local]) -> 'a option [@@deprecated "[since 2019-07] Use [Fn.id] instead"] val max_elt : 'a t -> compare:(('a -> 'a -> int)[@local]) -> 'a option [@@deprecated "[since 2019-07] Use [Fn.id] instead"] val count : 'a t -> f:(('a -> bool)[@local]) -> int [@@deprecated "[since 2019-07] Use pattern matching instead"] val sum : (module Container.Summable with type t = 'sum) -> 'a t -> f:(('a -> 'sum)[@local]) -> 'sum [@@deprecated "[since 2019-07] Use [value_map ~default:Summable.zero ~f] instead"] base-0.16.3/src/option_array.ml000066400000000000000000000165131446274340700163630ustar00rootroot00000000000000open! Import (** ['a Cheap_option.t] is like ['a option], but it doesn't box [some _] values. There are several things that are unsafe about it: - [float t array] (or any array-backed container) is not memory-safe because float array optimization is incompatible with unboxed option optimization. You have to use [Uniform_array.t] instead of [array]. - Nested options (['a t t]) don't work. They are believed to be memory-safe, but not parametric. - A record with [float t]s in it should be safe, but it's only [t] being abstract that gives you safety. If the compiler was smart enough to peek through the module signature then it could decide to construct a float array instead. *) module Cheap_option = struct (* This is taken from core. Rather than expose it in the public interface of base, just keep a copy around here. *) let phys_same (type a b) (a : a) (b : b) = phys_equal a (Stdlib.Obj.magic b : a) module T0 : sig type 'a t val none : _ t val some : 'a -> 'a t val is_none : _ t -> bool val is_some : _ t -> bool val value_exn : 'a t -> 'a val value_unsafe : 'a t -> 'a val iter_some : 'a t -> f:(('a -> unit)[@local]) -> unit end = struct type +'a t (* Being a pointer, no one outside this module can construct a value that is [phys_same] as this one. It would be simpler to use this value as [none], but we use an immediate instead because it lets us avoid caml_modify when setting to [none], making certain benchmarks significantly faster (e.g. ../bench/array_queue.exe). this code is duplicated in Moption, and if we find yet another place where we want it we should reconsider making it shared. *) let none_substitute : _ t = Stdlib.Obj.obj (Stdlib.Obj.new_block Stdlib.Obj.abstract_tag 1) ;; let none : _ t = (* The number was produced by [< /dev/urandom tr -c -d '1234567890abcdef' | head -c 16]. The idea is that a random number will have lower probability to collide with anything than any number we can choose ourselves. We are using a polymorphic variant instead of an integer constant because there is a compiler bug where it wrongly assumes that the result of [if _ then c else y] is not a pointer if [c] is an integer compile-time constant. This is being fixed in https://github.com/ocaml/ocaml/pull/555. The "memory corruption" test below demonstrates the issue. *) Stdlib.Obj.magic `x6e8ee3478e1d7449 ;; let is_none x = phys_equal x none let is_some x = not (phys_equal x none) let some (type a) (x : a) : a t = if phys_same x none then none_substitute else Stdlib.Obj.magic x ;; let value_unsafe (type a) (x : a t) : a = if phys_equal x none_substitute then Stdlib.Obj.magic none else Stdlib.Obj.magic x ;; let value_exn x = if is_some x then value_unsafe x else failwith "Option_array.get_some_exn: the element is [None]" ;; let iter_some t ~f = if is_some t then f (value_unsafe t) end module T1 = struct include T0 let of_option = function | None -> none | Some x -> some x ;; let[@inline] to_option x = if is_some x then Some (value_unsafe x) else None let to_sexpable = to_option let of_sexpable = of_option let t_sexp_grammar (type a) (grammar : a Sexplib0.Sexp_grammar.t) : a t Sexplib0.Sexp_grammar.t = Sexplib0.Sexp_grammar.coerce (Option.t_sexp_grammar grammar) ;; end include T1 include Sexpable.Of_sexpable1 (Option) (T1) end type 'a t = 'a Cheap_option.t Uniform_array.t [@@deriving_inline sexp, sexp_grammar] let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = fun _of_a__001_ x__003_ -> Uniform_array.t_of_sexp (Cheap_option.t_of_sexp _of_a__001_) x__003_ ;; let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = fun _of_a__004_ x__005_ -> Uniform_array.sexp_of_t (Cheap_option.sexp_of_t _of_a__004_) x__005_ ;; let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> Uniform_array.t_sexp_grammar (Cheap_option.t_sexp_grammar _'a_sexp_grammar) ;; [@@@end] let empty = Uniform_array.empty let create ~len = Uniform_array.create ~len Cheap_option.none let init n ~f = Uniform_array.init n ~f:(fun i -> Cheap_option.of_option (f i)) [@nontail] let init_some n ~f = Uniform_array.init n ~f:(fun i -> Cheap_option.some (f i)) [@nontail] let length = Uniform_array.length let[@inline] get t i = Cheap_option.to_option (Uniform_array.get t i) let get_some_exn t i = Cheap_option.value_exn (Uniform_array.get t i) let is_none t i = Cheap_option.is_none (Uniform_array.get t i) let is_some t i = Cheap_option.is_some (Uniform_array.get t i) let set t i x = Uniform_array.set t i (Cheap_option.of_option x) let set_some t i x = Uniform_array.set t i (Cheap_option.some x) let set_none t i = Uniform_array.set t i Cheap_option.none let swap t i j = Uniform_array.swap t i j let unsafe_get t i = Cheap_option.to_option (Uniform_array.unsafe_get t i) let unsafe_get_some_exn t i = Cheap_option.value_exn (Uniform_array.unsafe_get t i) let unsafe_get_some_assuming_some t i = Cheap_option.value_unsafe (Uniform_array.unsafe_get t i) ;; let unsafe_is_some t i = Cheap_option.is_some (Uniform_array.unsafe_get t i) let unsafe_set t i x = Uniform_array.unsafe_set t i (Cheap_option.of_option x) let unsafe_set_some t i x = Uniform_array.unsafe_set t i (Cheap_option.some x) let unsafe_set_none t i = Uniform_array.unsafe_set t i Cheap_option.none let clear t = for i = 0 to length t - 1 do unsafe_set_none t i done ;; let iteri input ~f = for i = 0 to length input - 1 do f i (unsafe_get input i) done ;; let iter input ~f = iteri input ~f:(fun (_ : int) x -> f x) [@nontail] let foldi input ~init ~f = let acc = ref init in iteri input ~f:(fun i elem -> acc := f i !acc elem); !acc ;; let fold input ~init ~f = foldi input ~init ~f:(fun (_ : int) acc x -> f acc x) [@nontail] include Indexed_container.Make_gen (struct type nonrec ('a, _) t = 'a t type 'a elt = 'a option let fold = fold let foldi = `Custom foldi let iter = `Custom iter let iteri = `Custom iteri let length = `Custom length end) let length = Uniform_array.length let mapi input ~f = let output = create ~len:(length input) in iteri input ~f:(fun i elem -> unsafe_set output i (f i elem)); output ;; let map input ~f = mapi input ~f:(fun (_ : int) elem -> f elem) [@nontail] let map_some input ~f = let len = length input in let output = create ~len in let () = for i = 0 to len - 1 do let opt = Uniform_array.unsafe_get input i in Cheap_option.iter_some opt ~f:(fun x -> unsafe_set_some output i (f x)) done in output ;; let of_array array = init (Array.length array) ~f:(fun i -> Array.unsafe_get array i) let of_array_some array = init_some (Array.length array) ~f:(fun i -> Array.unsafe_get array i) ;; let to_array t = Array.init (length t) ~f:(fun i -> unsafe_get t i) include Blit.Make1_generic (struct type nonrec 'a t = 'a t let length = length let create_like ~len _ = create ~len let unsafe_blit = Uniform_array.unsafe_blit end) let copy = Uniform_array.copy module For_testing = struct module Unsafe_cheap_option = Cheap_option end base-0.16.3/src/option_array.mli000066400000000000000000000070671446274340700165400ustar00rootroot00000000000000(** ['a Option_array.t] is a compact representation of ['a option array]: it avoids allocating heap objects representing [Some x], usually representing them with [x] instead. It uses a special representation for [None] that's guaranteed to never collide with any representation of [Some x]. *) open! Import type 'a t [@@deriving_inline sexp, sexp_grammar] include Sexplib0.Sexpable.S1 with type 'a t := 'a t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] val empty : _ t (** Initially filled with all [None] *) val create : len:int -> _ t include Indexed_container.Generic with type ('a, _) t := 'a t and type 'a elt := 'a option val length : (_ t[@local]) -> int val init_some : int -> f:((int -> 'a)[@local]) -> 'a t val init : int -> f:((int -> 'a option)[@local]) -> 'a t val of_array : 'a option array -> 'a t val of_array_some : 'a array -> 'a t val to_array : 'a t -> 'a option Array.t (** [get t i] returns the element number [i] of array [t], raising if [i] is outside the range 0 to [length t - 1]. *) val get : 'a t -> int -> 'a option (** Raises if the element number [i] is [None]. *) val get_some_exn : 'a t -> int -> 'a (** [is_none t i = Option.is_none (get t i)] *) val is_none : _ t -> int -> bool (** [is_some t i = Option.is_some (get t i)] *) val is_some : _ t -> int -> bool (** These can cause arbitrary behavior when used for an out-of-bounds array access. *) val unsafe_get : 'a t -> int -> 'a option (** [unsafe_get_some_exn t i] is unsafe because it does not bounds check [i]. It does, however check whether the value at index [i] is none or some, and raises if it is none. *) val unsafe_get_some_exn : 'a t -> int -> 'a (** [unsafe_get_some_assuming_some t i] is unsafe both because it does not bounds check [i] and because it does not check whether the value at index [i] is none or some, assuming that it is some. *) val unsafe_get_some_assuming_some : 'a t -> int -> 'a val unsafe_is_some : _ t -> int -> bool (** [set t i x] modifies array [t] in place, replacing element number [i] with [x], raising if [i] is outside the range 0 to [length t - 1]. *) val set : 'a t -> int -> 'a option -> unit val set_some : 'a t -> int -> 'a -> unit val set_none : _ t -> int -> unit val swap : _ t -> int -> int -> unit (** Replaces all the elements of the array with [None]. *) val clear : _ t -> unit (** [map f [|a1; ...; an|]] applies function [f] to [a1], [a2], ..., [an], in order, and builds the option_array [[|f a1; ...; f an|]] with the results returned by [f]. *) val map : 'a t -> f:(('a option -> 'b option)[@local]) -> 'b t (** [map_some t ~f] is like [map], but [None] elements always map to [None] and [Some] always map to [Some]. *) val map_some : 'a t -> f:(('a -> 'b)[@local]) -> 'b t (** Unsafe versions of [set*]. Can cause arbitrary behaviour when used for an out-of-bounds array access. *) val unsafe_set : 'a t -> int -> 'a option -> unit val unsafe_set_some : 'a t -> int -> 'a -> unit val unsafe_set_none : _ t -> int -> unit include Blit.S1 with type 'a t := 'a t (** Makes a (shallow) copy of the array. *) val copy : 'a t -> 'a t (**/**) module For_testing : sig module Unsafe_cheap_option : sig type 'a t [@@deriving_inline sexp] include Sexplib0.Sexpable.S1 with type 'a t := 'a t [@@@end] val none : _ t val some : 'a -> 'a t val is_none : _ t -> bool val is_some : _ t -> bool val value_exn : 'a t -> 'a val value_unsafe : 'a t -> 'a val to_option : 'a t -> 'a Option.t val of_option : 'a Option.t -> 'a t end end base-0.16.3/src/or_error.ml000066400000000000000000000115471446274340700155100ustar00rootroot00000000000000open! Import type 'a t = ('a, Error.t) Result.t [@@deriving_inline compare, equal, hash, sexp, sexp_grammar] let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = fun _cmp__a a__001_ b__002_ -> Result.compare _cmp__a Error.compare a__001_ b__002_ ;; let equal : 'a. ('a -> 'a -> bool) -> 'a t -> 'a t -> bool = fun _cmp__a a__007_ b__008_ -> Result.equal _cmp__a Error.equal a__007_ b__008_ ;; let hash_fold_t : 'a. (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) -> Ppx_hash_lib.Std.Hash.state -> 'a t -> Ppx_hash_lib.Std.Hash.state = fun _hash_fold_a hsv arg -> Result.hash_fold_t _hash_fold_a Error.hash_fold_t hsv arg ;; let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = fun _of_a__013_ x__015_ -> Result.t_of_sexp _of_a__013_ Error.t_of_sexp x__015_ ;; let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = fun _of_a__016_ x__017_ -> Result.sexp_of_t _of_a__016_ Error.sexp_of_t x__017_ ;; let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> Result.t_sexp_grammar _'a_sexp_grammar Error.t_sexp_grammar ;; [@@@end] let ( >>= ) = Result.( >>= ) let ( >>| ) = Result.( >>| ) let bind = Result.bind let ignore_m = Result.ignore_m let join = Result.join let map = Result.map let return = Result.return module Monad_infix = Result.Monad_infix let invariant invariant_a t = match t with | Ok a -> invariant_a a | Error error -> Error.invariant error ;; let map2 a b ~f = match a, b with | Ok x, Ok y -> Ok (f x y) | Ok _, (Error _ as e) | (Error _ as e), Ok _ -> e | Error e1, Error e2 -> Error (Error.of_list [ e1; e2 ]) ;; module For_applicative = Applicative.Make_using_map2_local (struct type nonrec 'a t = 'a t let return = return let map = `Custom map let map2 = map2 end) let ( *> ) = For_applicative.( *> ) let ( <* ) = For_applicative.( <* ) let ( <*> ) = For_applicative.( <*> ) let apply = For_applicative.apply let both = For_applicative.both let map3 = For_applicative.map3 module Applicative_infix = For_applicative.Applicative_infix module Let_syntax = struct let return = return include Monad_infix module Let_syntax = struct let return = return let map = map let bind = bind let both = both (* from Applicative.Make *) module Open_on_rhs = struct end end end let ok = Result.ok let is_ok = Result.is_ok let is_error = Result.is_error let try_with ?(backtrace = false) f = try Ok (f ()) with | exn -> Error (Error.of_exn exn ?backtrace:(if backtrace then Some `Get else None)) ;; let try_with_join ?backtrace f = join (try_with ?backtrace f) let ok_exn = function | Ok x -> x | Error err -> Error.raise err ;; let of_exn ?backtrace exn = Error (Error.of_exn ?backtrace exn) let of_exn_result ?backtrace = function | Ok _ as z -> z | Error exn -> of_exn ?backtrace exn ;; let error ?here ?strict message a sexp_of_a = Error (Error.create ?here ?strict message a sexp_of_a) ;; let error_s sexp = Error (Error.create_s sexp) let error_string message = Error (Error.of_string message) let errorf format = Printf.ksprintf error_string format let tag t ~tag = Result.map_error t ~f:(Error.tag ~tag) let tag_s t ~tag = Result.map_error t ~f:(Error.tag_s ~tag) let tag_s_lazy t ~tag = Result.map_error t ~f:(Error.tag_s_lazy ~tag) let tag_arg t message a sexp_of_a = Result.map_error t ~f:(fun e -> Error.tag_arg e message a sexp_of_a) ;; let unimplemented s = error "unimplemented" s sexp_of_string let combine_internal list ~on_ok ~on_error = match Result.combine_errors list with | Ok x -> Ok (on_ok x) | Error errs -> Error (on_error errs) ;; let ignore_unit_list (_ : unit list) = () let error_of_list_if_necessary = function | [ e ] -> e | list -> Error.of_list list ;; let all list = combine_internal list ~on_ok:Fn.id ~on_error:error_of_list_if_necessary let all_unit list = combine_internal list ~on_ok:ignore_unit_list ~on_error:error_of_list_if_necessary ;; let combine_errors list = combine_internal list ~on_ok:Fn.id ~on_error:Error.of_list let combine_errors_unit list = combine_internal list ~on_ok:ignore_unit_list ~on_error:Error.of_list ;; let filter_ok_at_least_one l = let ok, errs = List.partition_map l ~f:Result.to_either in match ok with | [] -> Error (Error.of_list errs) | _ -> Ok ok ;; let find_ok l = match List.find_map l ~f:Result.ok with | Some x -> Ok x | None -> Error (Error.of_list (List.map l ~f:(function | Ok _ -> assert false | Error err -> err))) ;; let find_map_ok l ~f = With_return.with_return (fun { return } -> Error (Error.of_list (List.map l ~f:(fun elt -> match f elt with | Ok _ as x -> return x | Error err -> err)))) [@nontail] ;; let map = Result.map let iter = Result.iter let iter_error = Result.iter_error base-0.16.3/src/or_error.mli000066400000000000000000000126321446274340700156550ustar00rootroot00000000000000(** Type for tracking errors in an [Error.t]. This is a specialization of the [Result] type, where the [Error] constructor carries an [Error.t]. A common idiom is to wrap a function that is not implemented on all platforms, e.g., {[val do_something_linux_specific : (unit -> unit) Or_error.t]} *) open! Import (** Serialization and comparison of an [Error] force the error's lazy message. *) type 'a t = ('a, Error.t) Result.t [@@deriving_inline compare, equal, hash, sexp, sexp_grammar] include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t include Ppx_hash_lib.Hashable.S1 with type 'a t := 'a t include Sexplib0.Sexpable.S1 with type 'a t := 'a t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] (** [Applicative] functions don't have quite the same semantics as [Applicative.Of_Monad(Or_error)] would give -- [apply (Error e1) (Error e2)] returns the combination of [e1] and [e2], whereas it would only return [e1] if it were defined using [bind]. *) include Applicative.S_local with type 'a t := 'a t include Invariant.S1 with type 'a t := 'a t include Monad.S_local with type 'a t := 'a t val is_ok : _ t -> bool val is_error : _ t -> bool (** [try_with f] catches exceptions thrown by [f] and returns them in the [Result.t] as an [Error.t]. [try_with_join] is like [try_with], except that [f] can throw exceptions or return an [Error] directly, without ending up with a nested error; it is equivalent to [Result.join (try_with f)]. *) val try_with : ?backtrace:bool (** defaults to [false] *) -> ((unit -> 'a)[@local]) -> 'a t val try_with_join : ?backtrace:bool (** defaults to [false] *) -> ((unit -> 'a t)[@local]) -> 'a t (** [ok t] returns [None] if [t] is an [Error], and otherwise returns the contents of the [Ok] constructor. *) val ok : 'ok t -> 'ok option (** [ok_exn t] throws an exception if [t] is an [Error], and otherwise returns the contents of the [Ok] constructor. *) val ok_exn : 'a t -> 'a (** [of_exn ?backtrace exn] is [Error (Error.of_exn ?backtrace exn)]. *) val of_exn : ?backtrace:[ `Get | `This of string ] -> exn -> _ t (** [of_exn_result ?backtrace (Ok a) = Ok a] [of_exn_result ?backtrace (Error exn) = of_exn ?backtrace exn] *) val of_exn_result : ?backtrace:[ `Get | `This of string ] -> ('a, exn) Result.t -> 'a t (** [error] is a wrapper around [Error.create]: {[ error ?strict message a sexp_of_a = Error (Error.create ?strict message a sexp_of_a) ]} As with [Error.create], [sexp_of_a a] is lazily computed when the info is converted to a sexp. So, if [a] is mutated in the time between the call to [create] and the sexp conversion, those mutations will be reflected in the sexp. Use [~strict:()] to force [sexp_of_a a] to be computed immediately. *) val error : ?here:Source_code_position0.t -> ?strict:unit -> string -> 'a -> ('a -> Sexp.t) -> _ t val error_s : Sexp.t -> _ t (** [error_string message] is [Error (Error.of_string message)]. *) val error_string : string -> _ t (** [errorf format arg1 arg2 ...] is [Error (sprintf format arg1 arg2 ...)]. Note that it calculates the string eagerly, so when performance matters you may want to use [error] instead. *) val errorf : ('a, unit, string, _ t) format4 -> 'a (** [tag t ~tag] is [Result.map_error t ~f:(Error.tag ~tag)]. *) val tag : 'a t -> tag:string -> 'a t (** [tag_s] is like [tag] with a sexp tag. *) val tag_s : 'a t -> tag:Sexp.t -> 'a t (** [tag_s_lazy] is like [tag] with a lazy sexp tag. *) val tag_s_lazy : 'a t -> tag:Sexp.t Lazy.t -> 'a t (** [tag_arg] is like [tag], with a tag that has a sexpable argument. *) val tag_arg : 'a t -> string -> 'b -> ('b -> Sexp.t) -> 'a t (** For marking a given value as unimplemented. Typically combined with conditional compilation, where on some platforms the function is defined normally, and on some platforms it is defined as unimplemented. The supplied string should be the name of the function that is unimplemented. *) val unimplemented : string -> _ t val map : 'a t -> f:(('a -> 'b)[@local]) -> 'b t val iter : 'a t -> f:(('a -> unit)[@local]) -> unit val iter_error : _ t -> f:((Error.t -> unit)[@local]) -> unit (** [combine_errors ts] returns [Ok] if every element in [ts] is [Ok], else it returns [Error] with all the errors in [ts]. More precisely: - [combine_errors [Ok a1; ...; Ok an] = Ok [a1; ...; an]] - {[ combine_errors [...; Error e1; ...; Error en; ...] = Error (Error.of_list [e1; ...; en]) ]} *) val combine_errors : 'a t list -> 'a list t (** [combine_errors_unit ts] returns [Ok] if every element in [ts] is [Ok ()], else it returns [Error] with all the errors in [ts], like [combine_errors]. *) val combine_errors_unit : unit t list -> unit t (** [filter_ok_at_least_one ts] returns all values in [ts] that are [Ok] if there is at least one, otherwise it returns the same error as [combine_errors ts]. *) val filter_ok_at_least_one : 'a t list -> 'a list t (** [find_ok ts] returns the first value in [ts] that is [Ok], otherwise it returns the same error as [combine_errors ts]. *) val find_ok : 'a t list -> 'a t (** [find_map_ok l ~f] returns the first value in [l] for which [f] returns [Ok], otherwise it returns the same error as [combine_errors (List.map l ~f)]. *) val find_map_ok : 'a list -> f:(('a -> 'b t)[@local]) -> 'b t base-0.16.3/src/ordered_collection_common.ml000066400000000000000000000003251446274340700210560ustar00rootroot00000000000000open! Import include Ordered_collection_common0 let get_pos_len ?pos ?len () ~total_length = try Result.Ok (get_pos_len_exn () ?pos ?len ~total_length) with | Invalid_argument s -> Or_error.error_string s ;; base-0.16.3/src/ordered_collection_common.mli000066400000000000000000000004331446274340700212270ustar00rootroot00000000000000(** Functions for ordered collections. *) open! Import include module type of Ordered_collection_common0 (** @inline *) (** Like [get_pos_len_exn]. Returns an [Or_error.t]. *) val get_pos_len : ?pos:int -> ?len:int -> unit -> total_length:int -> (int * int) Or_error.t base-0.16.3/src/ordered_collection_common0.ml000066400000000000000000000027731446274340700211470ustar00rootroot00000000000000(* Split off to avoid a cyclic dependency with [Or_error]. *) open! Import let invalid_argf = Printf.invalid_argf let slow_check_pos_len_exn ~pos ~len ~total_length = if pos < 0 then invalid_argf "Negative position: %d" pos (); if len < 0 then invalid_argf "Negative length: %d" len (); (* We use [pos > total_length - len] rather than [pos + len > total_length] to avoid the possibility of overflow. *) if pos > total_length - len then invalid_argf "pos + len past end: %d + %d > %d" pos len total_length () [@@cold] [@@inline never] [@@local never] [@@specialise never] ;; let check_pos_len_exn ~pos ~len ~total_length = (* This is better than [slow_check_pos_len_exn] for two reasons: - much less inlined code - only one conditional jump The reason it works is that checking [< 0] is testing the highest order bit, so [a < 0 || b < 0] is the same as [a lor b < 0]. [pos + len] can overflow, so [pos > total_length - len] is not equivalent to [total_length - len - pos < 0], we need to test for [pos + len] overflow as well. *) let stop = pos + len in if pos lor len lor stop lor (total_length - stop) < 0 then slow_check_pos_len_exn ~pos ~len ~total_length [@@inline always] ;; let get_pos_len_exn ?(pos = 0) ?len () ~total_length = let len = match len with | Some i -> i | None -> total_length - pos in check_pos_len_exn ~pos ~len ~total_length; pos, len ;; module Private = struct let slow_check_pos_len_exn = slow_check_pos_len_exn end base-0.16.3/src/ordered_collection_common0.mli000066400000000000000000000027001446274340700213060ustar00rootroot00000000000000open! Import (** [get_pos_len_exn], and [check_pos_len_exn] are intended to be used by functions that take a sequence (array, string, bigstring, ...) and an optional [pos] and [len] specifying a subrange of the sequence. Such functions should call [get_pos_len] with the length of the sequence and the optional [pos] and [len], and it will return the [pos] and [len] specifying the range, where the default [pos] is zero and the default [len] is to go to the end of the sequence. It should be the case that: {[ pos >= 0 && len >= 0 && pos + len <= total_length ]} Note that this allows [pos = total_length] and [len = 0], i.e., an empty subrange at the end of the sequence. [get_pos_len_exn] returns [(pos', len')] specifying a subrange where: {v pos' = match pos with None -> 0 | Some i -> i len' = match len with None -> total_length - pos' | Some i -> i v} *) val get_pos_len_exn : ?pos:int -> ?len:int -> unit -> total_length:int -> int * int (** [check_pos_len_exn ~pos ~len ~total_length] raises unless [pos >= 0 && len >= 0 && pos + len <= total_length]. *) val check_pos_len_exn : pos:int -> len:int -> total_length:int -> unit (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig val slow_check_pos_len_exn : pos:int -> len:int -> total_length:int -> unit end base-0.16.3/src/ordering.ml000066400000000000000000000054031446274340700154620ustar00rootroot00000000000000open! Import type t = | Less | Equal | Greater [@@deriving_inline compare, hash, enumerate, sexp, sexp_grammar] let compare = (Stdlib.compare : t -> t -> int) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = (fun hsv arg -> match arg with | Less -> Ppx_hash_lib.Std.Hash.fold_int hsv 0 | Equal -> Ppx_hash_lib.Std.Hash.fold_int hsv 1 | Greater -> Ppx_hash_lib.Std.Hash.fold_int hsv 2 : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) ;; let (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func arg = Ppx_hash_lib.Std.Hash.get_hash_value (let hsv = Ppx_hash_lib.Std.Hash.create () in hash_fold_t hsv arg) in fun x -> func x ;; let all = ([ Less; Equal; Greater ] : t list) let t_of_sexp = (let error_source__005_ = "ordering.ml.t" in function | Sexplib0.Sexp.Atom ("less" | "Less") -> Less | Sexplib0.Sexp.Atom ("equal" | "Equal") -> Equal | Sexplib0.Sexp.Atom ("greater" | "Greater") -> Greater | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("less" | "Less") :: _) as sexp__006_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__005_ sexp__006_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("equal" | "Equal") :: _) as sexp__006_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__005_ sexp__006_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("greater" | "Greater") :: _) as sexp__006_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__005_ sexp__006_ | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__004_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__005_ sexp__004_ | Sexplib0.Sexp.List [] as sexp__004_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__005_ sexp__004_ | sexp__004_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__005_ sexp__004_ : Sexplib0.Sexp.t -> t) ;; let sexp_of_t = (function | Less -> Sexplib0.Sexp.Atom "Less" | Equal -> Sexplib0.Sexp.Atom "Equal" | Greater -> Sexplib0.Sexp.Atom "Greater" : t -> Sexplib0.Sexp.t) ;; let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "Less"; clause_kind = Atom_clause } ; No_tag { name = "Equal"; clause_kind = Atom_clause } ; No_tag { name = "Greater"; clause_kind = Atom_clause } ] } } ;; [@@@end] let equal a b = compare a b = 0 module Export = struct type _ordering = t = | Less | Equal | Greater end let of_int n = if n < 0 then Less else if n = 0 then Equal else Greater let to_int = function | Less -> -1 | Equal -> 0 | Greater -> 1 ;; base-0.16.3/src/ordering.mli000066400000000000000000000025311446274340700156320ustar00rootroot00000000000000(** [Ordering] is intended to make code that matches on the result of a comparison more concise and easier to read. For example, instead of writing: {[ let r = compare x y in if r < 0 then ... else if r = 0 then ... else ... ]} you could simply write: {[ match Ordering.of_int (compare x y) with | Less -> ... | Equal -> ... | Greater -> ... ]} *) open! Import type t = | Less | Equal | Greater [@@deriving_inline compare, hash, sexp, sexp_grammar] include Ppx_compare_lib.Comparable.S with type t := t include Ppx_hash_lib.Hashable.S with type t := t include Sexplib0.Sexpable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] (*_ Avoid [@@deriving_inline enumerate] due to circular dependency *) val all : t list include Equal.S with type t := t (** [of_int n] is: {v Less if n < 0 Equal if n = 0 Greater if n > 0 v} *) val of_int : int -> t (** [to_int t] is: {v Less -> -1 Equal -> 0 Greater -> 1 v} It can be useful when writing a comparison function to allow one to return [Ordering.t] values and transform them to [int]s later. *) val to_int : t -> int module Export : sig type _ordering = t = | Less | Equal | Greater end base-0.16.3/src/poly0.ml000066400000000000000000000022241446274340700147120ustar00rootroot00000000000000(** Primitives for polymorphic compare. *) (*_ Polymorphic compiler primitives can't be aliases as this doesn't play well with inlining. (If aliased without a type annotation, the compiler would implement them using the generic code doing a C call, and it's this code that would be inlined.) As a result we have to copy the [external ...] declaration here. *) external ( < ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%lessthan" external ( <= ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%lessequal" external ( <> ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%notequal" external ( = ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%equal" external ( > ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%greaterthan" external ( >= ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%greaterequal" external ascending : ('a[@local_opt]) -> ('a[@local_opt]) -> int = "%compare" external compare : ('a[@local_opt]) -> ('a[@local_opt]) -> int = "%compare" external equal : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%equal" let descending x y = compare y x let max x y = Bool0.select (x >= y) x y let min x y = Bool0.select (x <= y) x y base-0.16.3/src/poly0.mli000066400000000000000000000023251446274340700150650ustar00rootroot00000000000000(** A module containing the ad-hoc polymorphic comparison functions. Useful when you want to use polymorphic compare in some small scope of a file within which polymorphic compare has been hidden *) external compare : ('a[@local_opt]) -> ('a[@local_opt]) -> int = "%compare" (** [ascending] is identical to [compare]. [descending x y = ascending y x]. These are intended to be mnemonic when used like [List.sort ~compare:ascending] and [List.sort ~compare:descending], since they cause the list to be sorted in ascending or descending order, respectively. *) val ascending : 'a -> 'a -> int val descending : 'a -> 'a -> int external ( < ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%lessthan" external ( <= ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%lessequal" external ( <> ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%notequal" external ( = ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%equal" external ( > ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%greaterthan" external ( >= ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%greaterequal" external equal : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%equal" val min : 'a -> 'a -> 'a val max : 'a -> 'a -> 'a base-0.16.3/src/popcount.ml000066400000000000000000000031671446274340700155250ustar00rootroot00000000000000open! Import (* C stub for int popcount to use the POPCNT instruction where possible *) external int_popcount : int -> int = "Base_int_math_int_popcount" [@@noalloc] (* To maintain javascript compatibility and enable unboxing, we implement popcount in OCaml rather than use C stubs. Implementation adapted from: https://en.wikipedia.org/wiki/Hamming_weight#Efficient_implementation *) let int64_popcount = let open Stdlib.Int64 in let ( + ) = add in let ( - ) = sub in let ( * ) = mul in let ( lsr ) = shift_right_logical in let ( land ) = logand in let m1 = 0x5555555555555555L in (* 0b01010101... *) let m2 = 0x3333333333333333L in (* 0b00110011... *) let m4 = 0x0f0f0f0f0f0f0f0fL in (* 0b00001111... *) let h01 = 0x0101010101010101L in (* 1 bit set per byte *) fun [@inline] x -> (* gather the bit count for every pair of bits *) let x = x - ((x lsr 1) land m1) in (* gather the bit count for every 4 bits *) let x = (x land m2) + ((x lsr 2) land m2) in (* gather the bit count for every byte *) let x = (x + (x lsr 4)) land m4 in (* sum the bit counts in the top byte and shift it down *) to_int ((x * h01) lsr 56) ;; let int32_popcount = (* On 64-bit systems, this is faster than implementing using [int32] arithmetic. *) let mask = 0xffff_ffffL in fun [@inline] x -> int64_popcount (Stdlib.Int64.logand (Stdlib.Int64.of_int32 x) mask) ;; let nativeint_popcount = match Stdlib.Nativeint.size with | 32 -> fun [@inline] x -> int32_popcount (Stdlib.Nativeint.to_int32 x) | 64 -> fun [@inline] x -> int64_popcount (Stdlib.Int64.of_nativeint x) | _ -> assert false ;; base-0.16.3/src/popcount.mli000066400000000000000000000005251446274340700156710ustar00rootroot00000000000000(** This module exposes popcount functions (which count the number of ones in a bitstring) for the various integer types. Functions are exposed in their respective modules. *) open! Import val int_popcount : int -> int val int32_popcount : int32 -> int val int64_popcount : int64 -> int val nativeint_popcount : nativeint -> int base-0.16.3/src/pow_overflow_bounds.ml000066400000000000000000000110671446274340700177560ustar00rootroot00000000000000(* This file was autogenerated by ../generate/generate_pow_overflow_bounds.exe *) open! Import module Array = Array0 (* We have to use Int64.to_int_exn instead of int constants to make sure that file can be preprocessed on 32-bit machines. *) let overflow_bound_max_int32_value : int32 = 2147483647l let int32_positive_overflow_bounds : int32 array = [| 2147483647l ; 2147483647l ; 46340l ; 1290l ; 215l ; 73l ; 35l ; 21l ; 14l ; 10l ; 8l ; 7l ; 5l ; 5l ; 4l ; 4l ; 3l ; 3l ; 3l ; 3l ; 2l ; 2l ; 2l ; 2l ; 2l ; 2l ; 2l ; 2l ; 2l ; 2l ; 2l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l ; 1l |] let overflow_bound_max_int_value : int = (-1) lsr 1 let int_positive_overflow_bounds : int array = match Int_conversions.num_bits_int with | 32 -> Array.map int32_positive_overflow_bounds ~f:Stdlib.Int32.to_int | 63 -> [| Stdlib.Int64.to_int 4611686018427387903L ; Stdlib.Int64.to_int 4611686018427387903L ; Stdlib.Int64.to_int 2147483647L ; 1664510 ; 46340 ; 5404 ; 1290 ; 463 ; 215 ; 118 ; 73 ; 49 ; 35 ; 27 ; 21 ; 17 ; 14 ; 12 ; 10 ; 9 ; 8 ; 7 ; 7 ; 6 ; 5 ; 5 ; 5 ; 4 ; 4 ; 4 ; 4 ; 3 ; 3 ; 3 ; 3 ; 3 ; 3 ; 3 ; 3 ; 3 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 1 ; 1 |] | 31 -> [| 1073741823 ; 1073741823 ; 32767 ; 1023 ; 181 ; 63 ; 31 ; 19 ; 13 ; 10 ; 7 ; 6 ; 5 ; 4 ; 4 ; 3 ; 3 ; 3 ; 3 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 2 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 |] | _ -> assert false let overflow_bound_max_int63_on_int64_value : int64 = 4611686018427387903L let int63_on_int64_positive_overflow_bounds : int64 array = [| 4611686018427387903L ; 4611686018427387903L ; 2147483647L ; 1664510L ; 46340L ; 5404L ; 1290L ; 463L ; 215L ; 118L ; 73L ; 49L ; 35L ; 27L ; 21L ; 17L ; 14L ; 12L ; 10L ; 9L ; 8L ; 7L ; 7L ; 6L ; 5L ; 5L ; 5L ; 4L ; 4L ; 4L ; 4L ; 3L ; 3L ; 3L ; 3L ; 3L ; 3L ; 3L ; 3L ; 3L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 1L ; 1L |] let overflow_bound_max_int64_value : int64 = 9223372036854775807L let int64_positive_overflow_bounds : int64 array = [| 9223372036854775807L ; 9223372036854775807L ; 3037000499L ; 2097151L ; 55108L ; 6208L ; 1448L ; 511L ; 234L ; 127L ; 78L ; 52L ; 38L ; 28L ; 22L ; 18L ; 15L ; 13L ; 11L ; 9L ; 8L ; 7L ; 7L ; 6L ; 6L ; 5L ; 5L ; 5L ; 4L ; 4L ; 4L ; 4L ; 3L ; 3L ; 3L ; 3L ; 3L ; 3L ; 3L ; 3L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 2L ; 1L |] let int64_negative_overflow_bounds : int64 array = [| -9223372036854775807L ; -9223372036854775807L ; -3037000499L ; -2097151L ; -55108L ; -6208L ; -1448L ; -511L ; -234L ; -127L ; -78L ; -52L ; -38L ; -28L ; -22L ; -18L ; -15L ; -13L ; -11L ; -9L ; -8L ; -7L ; -7L ; -6L ; -6L ; -5L ; -5L ; -5L ; -4L ; -4L ; -4L ; -4L ; -3L ; -3L ; -3L ; -3L ; -3L ; -3L ; -3L ; -3L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -2L ; -1L |] base-0.16.3/src/pow_overflow_bounds.mli000066400000000000000000000006531446274340700201260ustar00rootroot00000000000000val overflow_bound_max_int32_value : int32 val int32_positive_overflow_bounds : int32 array val overflow_bound_max_int_value : int val int_positive_overflow_bounds : int array val overflow_bound_max_int63_on_int64_value : int64 val int63_on_int64_positive_overflow_bounds : int64 array val overflow_bound_max_int64_value : int64 val int64_positive_overflow_bounds : int64 array val int64_negative_overflow_bounds : int64 array base-0.16.3/src/ppx_compare_lib.ml000066400000000000000000000076241446274340700170230ustar00rootroot00000000000000open Import0 let compare_abstract ~type_name _ _ = Printf.ksprintf failwith "Compare called on the type %s, which is abstract in an implementation." type_name ;; let equal_abstract ~type_name _ _ = Printf.ksprintf failwith "Equal called on the type %s, which is abstract in an implementation." type_name ;; type 'a compare = 'a -> 'a -> int type 'a equal = 'a -> 'a -> bool module Comparable = struct module type S = sig type t val compare : t compare end module type S1 = sig type 'a t val compare : 'a compare -> 'a t compare end module type S2 = sig type ('a, 'b) t val compare : 'a compare -> 'b compare -> ('a, 'b) t compare end module type S3 = sig type ('a, 'b, 'c) t val compare : 'a compare -> 'b compare -> 'c compare -> ('a, 'b, 'c) t compare end end module Equal = struct module type S = sig type t val equal : t equal end module type S1 = sig type 'a t val equal : 'a equal -> 'a t equal end module type S2 = sig type ('a, 'b) t val equal : 'a equal -> 'b equal -> ('a, 'b) t equal end module type S3 = sig type ('a, 'b, 'c) t val equal : 'a equal -> 'b equal -> 'c equal -> ('a, 'b, 'c) t equal end end module Builtin = struct let compare_bool : bool compare = Poly.compare let compare_char : char compare = Poly.compare let compare_float : float compare = Poly.compare let compare_int : int compare = Poly.compare let compare_int32 : int32 compare = Poly.compare let compare_int64 : int64 compare = Poly.compare let compare_nativeint : nativeint compare = Poly.compare let compare_string : string compare = Poly.compare let compare_unit : unit compare = Poly.compare let compare_array compare_elt a b = if phys_equal a b then 0 else ( let len_a = Array0.length a in let len_b = Array0.length b in let ret = compare len_a len_b in if ret <> 0 then ret else ( let rec loop i = if i = len_a then 0 else ( let l = Array0.unsafe_get a i and r = Array0.unsafe_get b i in let res = compare_elt l r in if res <> 0 then res else loop (i + 1)) in loop 0)) ;; let rec compare_list compare_elt a b = match a, b with | [], [] -> 0 | [], _ -> -1 | _, [] -> 1 | x :: xs, y :: ys -> let res = compare_elt x y in if res <> 0 then res else compare_list compare_elt xs ys ;; let compare_option compare_elt a b = match a, b with | None, None -> 0 | None, Some _ -> -1 | Some _, None -> 1 | Some a, Some b -> compare_elt a b ;; let compare_ref compare_elt a b = compare_elt !a !b let equal_bool : bool equal = Poly.equal let equal_char : char equal = Poly.equal let equal_int : int equal = Poly.equal let equal_int32 : int32 equal = Poly.equal let equal_int64 : int64 equal = Poly.equal let equal_nativeint : nativeint equal = Poly.equal let equal_string : string equal = Poly.equal let equal_unit : unit equal = Poly.equal (* [Poly.equal] is IEEE compliant, which is not what we want here. *) let equal_float x y = equal_int (compare_float x y) 0 let equal_array equal_elt a b = phys_equal a b || let len_a = Array0.length a in let len_b = Array0.length b in equal len_a len_b && let rec loop i = i = len_a || let l = Array0.unsafe_get a i and r = Array0.unsafe_get b i in equal_elt l r && loop (i + 1) in loop 0 ;; let rec equal_list equal_elt a b = match a, b with | [], [] -> true | [], _ | _, [] -> false | x :: xs, y :: ys -> equal_elt x y && equal_list equal_elt xs ys ;; let equal_option equal_elt a b = match a, b with | None, None -> true | None, Some _ | Some _, None -> false | Some a, Some b -> equal_elt a b ;; let equal_ref equal_elt a b = equal_elt !a !b end base-0.16.3/src/ppx_compare_lib.mli000066400000000000000000000042231446274340700171640ustar00rootroot00000000000000(** Runtime support for auto-generated comparators. Users are not intended to use this module directly. *) type 'a compare = 'a -> 'a -> int type 'a equal = 'a -> 'a -> bool (** Raise when fully applied *) val compare_abstract : type_name:string -> _ compare val equal_abstract : type_name:string -> _ equal module Comparable : sig module type S = sig type t val compare : t compare end module type S1 = sig type 'a t val compare : 'a compare -> 'a t compare end module type S2 = sig type ('a, 'b) t val compare : 'a compare -> 'b compare -> ('a, 'b) t compare end module type S3 = sig type ('a, 'b, 'c) t val compare : 'a compare -> 'b compare -> 'c compare -> ('a, 'b, 'c) t compare end end module Equal : sig module type S = sig type t val equal : t equal end module type S1 = sig type 'a t val equal : 'a equal -> 'a t equal end module type S2 = sig type ('a, 'b) t val equal : 'a equal -> 'b equal -> ('a, 'b) t equal end module type S3 = sig type ('a, 'b, 'c) t val equal : 'a equal -> 'b equal -> 'c equal -> ('a, 'b, 'c) t equal end end module Builtin : sig val compare_bool : bool compare val compare_char : char compare val compare_float : float compare val compare_int : int compare val compare_int32 : int32 compare val compare_int64 : int64 compare val compare_nativeint : nativeint compare val compare_string : string compare val compare_unit : unit compare val compare_array : 'a compare -> 'a array compare val compare_list : 'a compare -> 'a list compare val compare_option : 'a compare -> 'a option compare val compare_ref : 'a compare -> 'a ref compare val equal_bool : bool equal val equal_char : char equal val equal_float : float equal val equal_int : int equal val equal_int32 : int32 equal val equal_int64 : int64 equal val equal_nativeint : nativeint equal val equal_string : string equal val equal_unit : unit equal val equal_array : 'a equal -> 'a array equal val equal_list : 'a equal -> 'a list equal val equal_option : 'a equal -> 'a option equal val equal_ref : 'a equal -> 'a ref equal end base-0.16.3/src/ppx_enumerate_lib.ml000066400000000000000000000006411446274340700173520ustar00rootroot00000000000000module List = List module Enumerable = struct module type S = sig type t val all : t list end module type S1 = sig type 'a t val all : 'a list -> 'a t list end module type S2 = sig type ('a, 'b) t val all : 'a list -> 'b list -> ('a, 'b) t list end module type S3 = sig type ('a, 'b, 'c) t val all : 'a list -> 'b list -> 'c list -> ('a, 'b, 'c) t list end end base-0.16.3/src/ppx_hash_lib.ml000066400000000000000000000013711446274340700163110ustar00rootroot00000000000000(** This module is for use by ppx_hash, and is thus not in the interface of Base. *) module Std = struct module Hash = Hash (** @canonical Base.Hash *) end type 'a hash_fold = Std.Hash.state -> 'a -> Std.Hash.state module Hashable = struct module type S = sig type t val hash_fold_t : t hash_fold val hash : t -> Std.Hash.hash_value end module type S1 = sig type 'a t val hash_fold_t : 'a hash_fold -> 'a t hash_fold end module type S2 = sig type ('a, 'b) t val hash_fold_t : 'a hash_fold -> 'b hash_fold -> ('a, 'b) t hash_fold end module type S3 = sig type ('a, 'b, 'c) t val hash_fold_t : 'a hash_fold -> 'b hash_fold -> 'c hash_fold -> ('a, 'b, 'c) t hash_fold end end base-0.16.3/src/pretty_printer.ml000066400000000000000000000010451446274340700167410ustar00rootroot00000000000000open! Import let r = ref [ "Base.Sexp.pp_hum" ] let all () = !r let register p = r := p :: !r module type S = sig type t val pp : Formatter.t -> t -> unit end module Register_pp (M : sig include S val module_name : string end) = struct include M let () = register (M.module_name ^ ".pp") end module Register (M : sig type t val module_name : string val to_string : t -> string end) = Register_pp (struct include M let pp formatter t = Stdlib.Format.pp_print_string formatter (M.to_string t) end) base-0.16.3/src/pretty_printer.mli000066400000000000000000000034231446274340700171140ustar00rootroot00000000000000(** A list of pretty printers for various types, for use in toplevels. [Pretty_printer] has a [string list ref] with the names of [pp] functions matching the interface: {[ val pp : Format.formatter -> t -> unit ]} The names are actually OCaml identifier names, e.g., "Base.Int.pp". Code for building toplevels evaluates the strings to yield the pretty printers and register them with the OCaml runtime. This module is only responsible for collecting the pretty-printers. Another mechanism is needed to register this collection with the "toploop" library for pretty-printing to actually happen. How to do that depends on how you build and deploy the OCaml toplevel. One common way to do it in vanilla toplevel is to call [#require "core.top"]. *) open! Import (** [all ()] returns all pretty printers that have been [register]ed. *) val all : unit -> string list (** Modules that provide a pretty printer will match [S]. *) module type S = sig type t val pp : Formatter.t -> t -> unit end (** [Register] builds a [pp] function from a [to_string] function, and adds the [module_name ^ ".pp"] to the list of pretty printers. The idea is to statically guarantee that one has the desired [pp] function at the same point where the [name] is added. *) module Register (M : sig type t val module_name : string val to_string : t -> string end) : S with type t := M.t (** [Register_pp] is like [Register], but allows a custom [pp] function rather than using [to_string]. *) module Register_pp (M : sig include S val module_name : string end) : S with type t := M.t (** [register name] adds [name] to the list of pretty printers. Use the [Register] functor if possible. *) val register : string -> unit base-0.16.3/src/printf.ml000066400000000000000000000004001446274340700151430ustar00rootroot00000000000000open! Import0 include Stdlib.Printf (** failwith, invalid_arg, and exit accepting printf's format. *) let[@inline never] failwithf fmt = ksprintf (fun s () -> failwith s) fmt let[@inline never] invalid_argf fmt = ksprintf (fun s () -> invalid_arg s) fmt base-0.16.3/src/printf.mli000066400000000000000000000157061446274340700153330ustar00rootroot00000000000000(** Functions for formatted output. [fprintf] and related functions format their arguments according to the given format string. The format string is a character string which contains two types of objects: plain characters, which are simply copied to the output channel, and conversion specifications, each of which causes conversion and printing of arguments. Conversion specifications have the following form: {[% [flags] [width] [.precision] type]} In short, a conversion specification consists in the [%] character, followed by optional modifiers and a type which is made of one or two characters. The types and their meanings are: - [d], [i]: convert an integer argument to signed decimal. - [u], [n], [l], [L], or [N]: convert an integer argument to unsigned decimal. Warning: [n], [l], [L], and [N] are used for [scanf], and should not be used for [printf]. - [x]: convert an integer argument to unsigned hexadecimal, using lowercase letters. - [X]: convert an integer argument to unsigned hexadecimal, using uppercase letters. - [o]: convert an integer argument to unsigned octal. - [s]: insert a string argument. - [S]: convert a string argument to OCaml syntax (double quotes, escapes). - [c]: insert a character argument. - [C]: convert a character argument to OCaml syntax (single quotes, escapes). - [f]: convert a floating-point argument to decimal notation, in the style [dddd.ddd]. - [F]: convert a floating-point argument to OCaml syntax ([dddd.] or [dddd.ddd] or [d.ddd e+-dd]). - [e] or [E]: convert a floating-point argument to decimal notation, in the style [d.ddd e+-dd] (mantissa and exponent). - [g] or [G]: convert a floating-point argument to decimal notation, in style [f] or [e], [E] (whichever is more compact). Moreover, any trailing zeros are removed from the fractional part of the result and the decimal-point character is removed if there is no fractional part remaining. - [h] or [H]: convert a floating-point argument to hexadecimal notation, in the style [0xh.hhhh e+-dd] (hexadecimal mantissa, exponent in decimal and denotes a power of 2). - [B]: convert a boolean argument to the string true or false - [b]: convert a boolean argument (deprecated; do not use in new programs). - [ld], [li], [lu], [lx], [lX], [lo]: convert an int32 argument to the format specified by the second letter (decimal, hexadecimal, etc). - [nd], [ni], [nu], [nx], [nX], [no]: convert a nativeint argument to the format specified by the second letter. - [Ld], [Li], [Lu], [Lx], [LX], [Lo]: convert an int64 argument to the format specified by the second letter. - [a]: user-defined printer. Take two arguments and apply the first one to outchan (the current output channel) and to the second argument. The first argument must therefore have type [out_channel -> 'b -> unit] and the second ['b]. The output produced by the function is inserted in the output of [fprintf] at the current point. - [t]: same as [%a], but take only one argument (with type [out_channel -> unit]) and apply it to [outchan]. - [{ fmt %}]: convert a format string argument to its type digest. The argument must have the same type as the internal format string [fmt]. - [( fmt %)]: format string substitution. Take a format string argument and substitute it to the internal format string fmt to print following arguments. The argument must have the same type as the internal format string fmt. - [!]: take no argument and flush the output. - [%]: take no argument and output one [%] character. - [@]: take no argument and output one [@] character. - [,]: take no argument and output nothing: a no-op delimiter for conversion specifications. The optional [flags] are: - [-]: left-justify the output (default is right justification). - [0]: for numerical conversions, pad with zeroes instead of spaces. - [+]: for signed numerical conversions, prefix number with a [+] sign if positive. - space: for signed numerical conversions, prefix number with a space if positive. - [#]: request an alternate formatting style for the hexadecimal and octal integer types ([x], [X], [o], [lx], [lX], [lo], [Lx], [LX], [Lo]). The optional [width] is an integer indicating the minimal width of the result. For instance, [%6d] prints an integer, prefixing it with spaces to fill at least 6 characters. The optional [precision] is a dot [.] followed by an integer indicating how many digits follow the decimal point in the [%f], [%e], and [%E] conversions. For instance, [%.4f] prints a [float] with 4 fractional digits. The integer in a [width] or [precision] can also be specified as [*], in which case an extra integer argument is taken to specify the corresponding [width] or [precision]. This integer argument precedes immediately the argument to print. For instance, [%.*f] prints a float with as many fractional digits as the value of the argument given before the float. *) open! Import0 (** Same as [fprintf], but does not print anything. Useful for ignoring some material when conditionally printing. *) val ifprintf : 'a -> ('r, 'a, 'c, unit) format4 -> 'r (** Same as [fprintf], but instead of printing on an output channel, returns a string. *) val sprintf : ('r, unit, string) format -> 'r (** Same as [fprintf], but instead of printing on an output channel, appends the formatted arguments to the given extensible buffer. *) val bprintf : Stdlib.Buffer.t -> ('r, Stdlib.Buffer.t, unit) format -> 'r (** Same as [sprintf], but instead of returning the string, passes it to the first argument. *) val ksprintf : (string -> 'a) -> ('r, unit, string, 'a) format4 -> 'r (** Same as [bprintf], but instead of returning immediately, passes the buffer, after printing, to its first argument. *) val kbprintf : (Stdlib.Buffer.t -> 'a) -> Stdlib.Buffer.t -> ('r, Stdlib.Buffer.t, unit, 'a) format4 -> 'r (** {6 Formatting error and exit functions} These functions have a polymorphic return type, since they do not return. Naively, this doesn't mix well with variadic functions: if you define, say, {[ let f fmt = ksprintf (fun s -> failwith s) fmt ]} then you find that [f "%d" : int -> 'a], as you'd expect, and [f "%d" 7 : 'a]. The problem with this is that ['a] unifies with (say) [int -> 'b], so [f "%d" 7 4] is not a type error -- the [4] is simply ignored. To mitigate this problem, these functions all take a final unit parameter. These rarely arise as formatting positional parameters (they can do with e.g. "%a", but not in a useful way) so they serve as an effective signpost for "end of formatting arguments". *) (** Raises [Failure]. *) val failwithf : ('r, unit, string, unit -> _) format4 -> 'r (** Raises [Invalid_arg]. *) val invalid_argf : ('r, unit, string, unit -> _) format4 -> 'r base-0.16.3/src/queue.ml000066400000000000000000000332021446274340700147730ustar00rootroot00000000000000open! Import (* [t] stores the [t.length] queue elements at consecutive increasing indices of [t.elts], mod the capacity of [t], which is [Option_array.length t.elts]. The capacity is required to be a power of two (user-requested capacities are rounded up to the nearest power), so that mod can quickly be computed using [land t.mask], where [t.mask = capacity t - 1]. So, queue element [i] is at [t.elts.( (t.front + i) land t.mask )]. [num_mutations] is used to detect modification during iteration. *) type 'a t = { mutable num_mutations : int ; mutable front : int ; mutable mask : int ; mutable length : int ; mutable elts : 'a Option_array.t } [@@deriving_inline sexp_of] let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = fun _of_a__001_ { num_mutations = num_mutations__003_ ; front = front__005_ ; mask = mask__007_ ; length = length__009_ ; elts = elts__011_ } -> let bnds__002_ = ([] : _ Stdlib.List.t) in let bnds__002_ = let arg__012_ = Option_array.sexp_of_t _of_a__001_ elts__011_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "elts"; arg__012_ ] :: bnds__002_ : _ Stdlib.List.t) in let bnds__002_ = let arg__010_ = sexp_of_int length__009_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "length"; arg__010_ ] :: bnds__002_ : _ Stdlib.List.t) in let bnds__002_ = let arg__008_ = sexp_of_int mask__007_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "mask"; arg__008_ ] :: bnds__002_ : _ Stdlib.List.t) in let bnds__002_ = let arg__006_ = sexp_of_int front__005_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "front"; arg__006_ ] :: bnds__002_ : _ Stdlib.List.t) in let bnds__002_ = let arg__004_ = sexp_of_int num_mutations__003_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "num_mutations"; arg__004_ ] :: bnds__002_ : _ Stdlib.List.t) in Sexplib0.Sexp.List bnds__002_ ;; [@@@end] module type S = Queue_intf.S let inc_num_mutations t = t.num_mutations <- t.num_mutations + 1 let capacity t = t.mask + 1 let elts_index t i = (t.front + i) land t.mask let unsafe_get t i = Option_array.unsafe_get_some_exn t.elts (elts_index t i) let unsafe_is_set t i = Option_array.unsafe_is_some t.elts (elts_index t i) let unsafe_set t i a = Option_array.unsafe_set_some t.elts (elts_index t i) a let unsafe_unset t i = Option_array.unsafe_set_none t.elts (elts_index t i) let check_index_exn t i = if i < 0 || i >= t.length then Error.raise_s (Sexp.message "Queue index out of bounds" [ "index", i |> Int.sexp_of_t; "length", t.length |> Int.sexp_of_t ]) ;; let get t i = check_index_exn t i; unsafe_get t i ;; let set t i a = check_index_exn t i; inc_num_mutations t; unsafe_set t i a ;; let is_empty t = t.length = 0 let length { length; _ } = length let ensure_no_mutation t num_mutations = if t.num_mutations <> num_mutations then Error.raise_s (Sexp.message "mutation of queue during iteration" [ "", t |> sexp_of_t (fun _ -> Sexp.Atom "_") ]) ;; let compare = let rec unsafe_compare_from compare_elt pos ~t1 ~t2 ~len1 ~len2 ~mut1 ~mut2 = match pos = len1, pos = len2 with | true, true -> 0 | true, false -> -1 | false, true -> 1 | false, false -> let x = compare_elt (unsafe_get t1 pos) (unsafe_get t2 pos) in ensure_no_mutation t1 mut1; ensure_no_mutation t2 mut2; (match x with | 0 -> unsafe_compare_from compare_elt (pos + 1) ~t1 ~t2 ~len1 ~len2 ~mut1 ~mut2 | n -> n) in fun compare_elt t1 t2 -> if phys_equal t1 t2 then 0 else unsafe_compare_from compare_elt 0 ~t1 ~t2 ~len1:t1.length ~len2:t2.length ~mut1:t1.num_mutations ~mut2:t2.num_mutations ;; let equal = let rec unsafe_equal_from equal_elt pos ~t1 ~t2 ~mut1 ~mut2 ~len = pos = len || let b = equal_elt (unsafe_get t1 pos) (unsafe_get t2 pos) in ensure_no_mutation t1 mut1; ensure_no_mutation t2 mut2; b && unsafe_equal_from equal_elt (pos + 1) ~t1 ~t2 ~mut1 ~mut2 ~len in fun equal_elt t1 t2 -> phys_equal t1 t2 || let len1 = t1.length in let len2 = t2.length in len1 = len2 && unsafe_equal_from equal_elt 0 ~t1 ~t2 ~len:len1 ~mut1:t1.num_mutations ~mut2:t2.num_mutations ;; let invariant invariant_a t = let { num_mutations; mask = _; elts; front; length } = t in assert (front >= 0); assert (front < capacity t); let capacity = capacity t in assert (capacity = Option_array.length elts); assert (capacity >= 1); assert (Int.is_pow2 capacity); assert (length >= 0); assert (length <= capacity); for i = 0 to capacity - 1 do if i < t.length then ( invariant_a (unsafe_get t i); ensure_no_mutation t num_mutations) else assert (not (unsafe_is_set t i)) done ;; let create (type a) ?capacity () : a t = let capacity = match capacity with | None -> 2 | Some capacity -> if capacity < 0 then Error.raise_s (Sexp.message "cannot have queue with negative capacity" [ "capacity", capacity |> Int.sexp_of_t ]) else if capacity = 0 then 1 else Int.ceil_pow2 capacity in { num_mutations = 0 ; front = 0 ; mask = capacity - 1 ; length = 0 ; elts = Option_array.create ~len:capacity } ;; let blit_to_array ~src dst = assert (src.length <= Option_array.length dst); let front_len = Int.min src.length (capacity src - src.front) in let rest_len = src.length - front_len in Option_array.blit ~len:front_len ~src:src.elts ~src_pos:src.front ~dst ~dst_pos:0; Option_array.blit ~len:rest_len ~src:src.elts ~src_pos:0 ~dst ~dst_pos:front_len ;; let set_capacity_internal t new_capacity = let dst = Option_array.create ~len:new_capacity in blit_to_array ~src:t dst; t.front <- 0; t.mask <- new_capacity - 1; t.elts <- dst ;; let set_capacity t desired_capacity = (* We allow arguments less than 1 to [set_capacity], but translate them to 1 to simplify the code that relies on the array length being a power of 2. *) inc_num_mutations t; let new_capacity = Int.ceil_pow2 (max 1 (max desired_capacity t.length)) in if new_capacity <> capacity t then set_capacity_internal t new_capacity ;; let enqueue t a = inc_num_mutations t; if t.length = capacity t then set_capacity_internal t (2 * t.length); unsafe_set t t.length a; t.length <- t.length + 1 ;; let dequeue_nonempty t = inc_num_mutations t; let elts = t.elts in let front = t.front in let res = Option_array.get_some_exn elts front in Option_array.set_none elts front; t.front <- elts_index t 1; t.length <- t.length - 1; res ;; let dequeue_exn t = if is_empty t then raise Stdlib.Queue.Empty else dequeue_nonempty t let dequeue t = if is_empty t then None else Some (dequeue_nonempty t) let dequeue_and_ignore_exn (type elt) (t : elt t) = ignore (dequeue_exn t : elt) let front_nonempty t = Option_array.unsafe_get_some_exn t.elts t.front let last_nonempty t = unsafe_get t (t.length - 1) let peek t = if is_empty t then None else Some (front_nonempty t) let peek_exn t = if is_empty t then raise Stdlib.Queue.Empty else front_nonempty t let last t = if is_empty t then None else Some (last_nonempty t) let last_exn t = if is_empty t then raise Stdlib.Queue.Empty else last_nonempty t let clear t = inc_num_mutations t; if t.length > 0 then ( for i = 0 to t.length - 1 do unsafe_unset t i done; t.length <- 0; t.front <- 0) ;; let blit_transfer ~src ~dst ?len () = inc_num_mutations src; inc_num_mutations dst; let len = match len with | None -> src.length | Some len -> if len < 0 then Error.raise_s (Sexp.message "Queue.blit_transfer: negative length" [ "length", len |> Int.sexp_of_t ]); min len src.length in if len > 0 then ( set_capacity dst (max (capacity dst) (dst.length + len)); let dst_start = dst.front + dst.length in for i = 0 to len - 1 do (* This is significantly faster than simply [enqueue dst (dequeue_nonempty src)] *) let src_i = (src.front + i) land src.mask in let dst_i = (dst_start + i) land dst.mask in Option_array.unsafe_set_some dst.elts dst_i (Option_array.unsafe_get_some_exn src.elts src_i); Option_array.unsafe_set_none src.elts src_i done; dst.length <- dst.length + len; src.front <- (src.front + len) land src.mask; src.length <- src.length - len) ;; let enqueue_all t l = (* Traversing the list up front to compute its length is probably (but not definitely) better than doubling the underlying array size several times for large queues. *) set_capacity t (Int.max (capacity t) (t.length + List.length l)); List.iter l ~f:(fun x -> enqueue t x) ;; let fold t ~init ~f = if t.length = 0 then init else ( let num_mutations = t.num_mutations in let r = ref init in for i = 0 to t.length - 1 do r := f !r (unsafe_get t i); ensure_no_mutation t num_mutations done; !r) ;; let foldi t ~init ~f = let i = ref 0 in fold t ~init ~f:(fun acc a -> let acc = f !i acc a in i := !i + 1; acc) [@nontail] ;; (* [iter] is implemented directly because implementing it in terms of [fold] is slower. *) let iter t ~f = let num_mutations = t.num_mutations in for i = 0 to t.length - 1 do f (unsafe_get t i); ensure_no_mutation t num_mutations done ;; let iteri t ~f = let num_mutations = t.num_mutations in for i = 0 to t.length - 1 do f i (unsafe_get t i); ensure_no_mutation t num_mutations done ;; let to_list t = let result = ref [] in for i = t.length - 1 downto 0 do result := unsafe_get t i :: !result done; !result ;; module C = Indexed_container.Make (struct type nonrec 'a t = 'a t let fold = fold let iter = `Custom iter let length = `Custom length let foldi = `Custom foldi let iteri = `Custom iteri end) let count = C.count let exists = C.exists let find = C.find let find_map = C.find_map let fold_result = C.fold_result let fold_until = C.fold_until let for_all = C.for_all let max_elt = C.max_elt let mem = C.mem let min_elt = C.min_elt let sum = C.sum let counti = C.counti let existsi = C.existsi let find_mapi = C.find_mapi let findi = C.findi let for_alli = C.for_alli (* For [concat_map], [filter_map], and [filter], we don't create [t_result] with [t]'s capacity because we have no idea how many elements [t_result] will ultimately hold. *) let concat_map t ~f = let t_result = create () in iter t ~f:(fun a -> List.iter (f a) ~f:(fun b -> enqueue t_result b)); t_result ;; let concat_mapi t ~f = let t_result = create () in iteri t ~f:(fun i a -> List.iter (f i a) ~f:(fun b -> enqueue t_result b)); t_result ;; let filter_map t ~f = let t_result = create () in iter t ~f:(fun a -> match f a with | None -> () | Some b -> enqueue t_result b); t_result ;; let filter_mapi t ~f = let t_result = create () in iteri t ~f:(fun i a -> match f i a with | None -> () | Some b -> enqueue t_result b); t_result ;; let filter t ~f = let t_result = create () in iter t ~f:(fun a -> if f a then enqueue t_result a); t_result ;; let filteri t ~f = let t_result = create () in iteri t ~f:(fun i a -> if f i a then enqueue t_result a); t_result ;; let filter_inplace t ~f = let t2 = filter t ~f in clear t; blit_transfer ~src:t2 ~dst:t () ;; let filteri_inplace t ~f = let t2 = filteri t ~f in clear t; blit_transfer ~src:t2 ~dst:t () ;; let copy src = let dst = create ~capacity:src.length () in blit_to_array ~src dst.elts; dst.length <- src.length; dst ;; let of_list l = (* Traversing the list up front to compute its length is probably (but not definitely) better than doubling the underlying array size several times for large queues. *) let t = create ~capacity:(List.length l) () in List.iter l ~f:(fun x -> enqueue t x); t ;; (* The queue [t] returned by [create] will have [t.length = 0], [t.front = 0], and [capacity t = Int.ceil_pow2 len]. So, we only have to set [t.length] to [len] after the blit to maintain all the invariants: [t.length] is equal to the number of elements in the queue, [t.front] is the array index of the first element in the queue, and [capacity t = Option_array.length t.elts]. *) let init len ~f = if len < 0 then Error.raise_s (Sexp.message "Queue.init: negative length" [ "length", len |> Int.sexp_of_t ]); let t = create ~capacity:len () in assert (Option_array.length t.elts >= len); for i = 0 to len - 1 do Option_array.unsafe_set_some t.elts i (f i) done; t.length <- len; t ;; let of_array a = init (Array.length a) ~f:(Array.unsafe_get a) let to_array t = Array.init t.length ~f:(fun i -> unsafe_get t i) let map ta ~f = let num_mutations = ta.num_mutations in let tb = create ~capacity:ta.length () in tb.length <- ta.length; for i = 0 to ta.length - 1 do let b = f (unsafe_get ta i) in ensure_no_mutation ta num_mutations; Option_array.unsafe_set_some tb.elts i b done; tb ;; let mapi t ~f = let i = ref 0 in map t ~f:(fun a -> let result = f !i a in i := !i + 1; result) [@nontail] ;; let singleton x = let t = create ~capacity:1 () in enqueue t x; t ;; let sexp_of_t sexp_of_a t = to_list t |> List.sexp_of_t sexp_of_a let t_of_sexp a_of_sexp sexp = List.t_of_sexp a_of_sexp sexp |> of_list let t_sexp_grammar (type a) (grammar : a Sexplib0.Sexp_grammar.t) : a t Sexplib0.Sexp_grammar.t = Sexplib0.Sexp_grammar.coerce (List.t_sexp_grammar grammar) ;; base-0.16.3/src/queue.mli000066400000000000000000000000501446274340700151370ustar00rootroot00000000000000include Queue_intf.Queue (** @inline *) base-0.16.3/src/queue_intf.ml000066400000000000000000000114221446274340700160130ustar00rootroot00000000000000open! Import (** An interface for queues that follows Base's conventions, as opposed to OCaml's standard [Queue] module. *) module type S = sig type 'a t [@@deriving_inline sexp, sexp_grammar] include Sexplib0.Sexpable.S1 with type 'a t := 'a t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] include Indexed_container.S1 with type 'a t := 'a t (** [singleton a] returns a queue with one element. *) val singleton : 'a -> 'a t (** [of_list list] returns a queue [t] with the elements of [list] in the same order as the elements of [list] (i.e. the first element of [t] is the first element of the list). *) val of_list : 'a list -> 'a t val of_array : 'a array -> 'a t (** [init n ~f] is equivalent to [of_list (List.init n ~f)]. *) val init : int -> f:((int -> 'a)[@local]) -> 'a t (** [enqueue t a] adds [a] to the end of [t].*) val enqueue : 'a t -> 'a -> unit (** [enqueue_all t list] adds all elements in [list] to [t] in order of [list]. *) val enqueue_all : 'a t -> 'a list -> unit (** [dequeue t] removes and returns the front element of [t], if any. *) val dequeue : 'a t -> 'a option val dequeue_exn : 'a t -> 'a (** [dequeue_and_ignore_exn t] removes the front element of [t], or raises if the queue is empty. *) val dequeue_and_ignore_exn : 'a t -> unit (** [peek t] returns but does not remove the front element of [t], if any. *) val peek : 'a t -> 'a option val peek_exn : 'a t -> 'a (** [clear t] discards all elements from [t]. *) val clear : _ t -> unit (** [copy t] returns a copy of [t]. *) val copy : 'a t -> 'a t val map : 'a t -> f:(('a -> 'b)[@local]) -> 'b t val mapi : 'a t -> f:((int -> 'a -> 'b)[@local]) -> 'b t (** Creates a new queue with elements equal to [List.concat_map ~f (to_list t)]. *) val concat_map : 'a t -> f:(('a -> 'b list)[@local]) -> 'b t val concat_mapi : 'a t -> f:((int -> 'a -> 'b list)[@local]) -> 'b t (** [filter_map] creates a new queue with elements equal to [List.filter_map ~f (to_list t)]. *) val filter_map : 'a t -> f:(('a -> 'b option)[@local]) -> 'b t val filter_mapi : 'a t -> f:((int -> 'a -> 'b option)[@local]) -> 'b t (** [filter] is like [filter_map], except with [List.filter]. *) val filter : 'a t -> f:(('a -> bool)[@local]) -> 'a t val filteri : 'a t -> f:((int -> 'a -> bool)[@local]) -> 'a t (** [filter_inplace t ~f] removes all elements of [t] that don't satisfy [f]. If [f] raises, [t] is unchanged. This is inplace in that it modifies [t]; however, it uses space linear in the final length of [t]. *) val filter_inplace : 'a t -> f:(('a -> bool)[@local]) -> unit val filteri_inplace : 'a t -> f:((int -> 'a -> bool)[@local]) -> unit end module type Queue = sig (** A queue implemented with an array. The implementation will grow the array as necessary. The array will never automatically be shrunk, but the size can be interrogated and set with [capacity] and [set_capacity]. Iteration functions ([iter], [fold], [map], [concat_map], [filter], [filter_map], [filter_inplace], and some functions from [Container.S1]) will raise if the queue is modified during iteration. Also see {!Linked_queue}, which has different performance characteristics. *) module type S = S type 'a t [@@deriving_inline compare] include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t [@@@end] include S with type 'a t := 'a t include Equal.S1 with type 'a t := 'a t include Invariant.S1 with type 'a t := 'a t (** Create an empty queue. *) val create : ?capacity:int (** default is [1]. *) -> unit -> _ t (** [last t] returns the most recently enqueued element in [t], if any. *) val last : 'a t -> 'a option val last_exn : 'a t -> 'a (** Transfers up to [len] elements from the front of [src] to the end of [dst], removing them from [src]. It is an error if [len < 0]. Aside from a call to [set_capacity dst] if needed, runs in O([len]) time *) val blit_transfer : src:'a t -> dst:'a t -> ?len:int (** default is [length src] *) -> unit -> unit (** [get t i] returns the [i]'th element in [t], where the 0'th element is at the front of [t] and the [length t - 1] element is at the back. *) val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> unit (** Returns the current length of the backing array. *) val capacity : _ t -> int (** [set_capacity t c] sets the capacity of [t]'s backing array to at least [max c (length t)]. If [t]'s capacity changes, then this involves allocating a new backing array and copying the queue elements over. [set_capacity] may decrease the capacity of [t], if [c < capacity t]. *) val set_capacity : _ t -> int -> unit end base-0.16.3/src/random.ml000066400000000000000000000225411446274340700151330ustar00rootroot00000000000000open! Import module Int = Int0 module Char = Char0 (* Unfortunately, because the standard library does not expose [Stdlib.Random.State.default], we have to construct our own. We then build the [Stdlib.Random.int], [Stdlib.Random.bool] functions and friends using that default state in exactly the same way as the standard library. One other trickiness is that we need access to the unexposed [Stdlib.Random.State.assign] function, which accesses the unexposed state representation. So, we copy the [State.repr] type definition and [assign] function to here from the standard library, and use [Obj.magic] to get access to the underlying implementation. *) (* Regression tests ought to be deterministic because that way anyone who breaks the test knows that it's their code that broke the test. If tests are nondeterministic, a test failure may instead happen because the test runner got unlucky and uncovered an existing bug in the code supposedly being "protected" by the test in question. *) let forbid_nondeterminism_in_tests ~allow_in_tests = if am_testing then ( match allow_in_tests with | Some true -> () | None | Some false -> failwith "initializing Random with a nondeterministic seed is forbidden in inline tests") ;; external random_seed : unit -> int array = "caml_sys_random_seed" let random_seed ?allow_in_tests () = forbid_nondeterminism_in_tests ~allow_in_tests; random_seed () ;; module State = struct (* We allow laziness only for the definition of [default], below, which may lazily call [make_self_init]. For all other purposes, we create and use [t] eagerly. *) type t = Stdlib.Random.State.t Lazy.t let bits t = Stdlib.Random.State.bits (Lazy.force t) let bool t = Stdlib.Random.State.bool (Lazy.force t) let int t x = Stdlib.Random.State.int (Lazy.force t) x let int32 t x = Stdlib.Random.State.int32 (Lazy.force t) x let int64 t x = Stdlib.Random.State.int64 (Lazy.force t) x let nativeint t x = Stdlib.Random.State.nativeint (Lazy.force t) x let make seed = Lazy.from_val (Stdlib.Random.State.make seed) let copy t = Lazy.from_val (Stdlib.Random.State.copy (Lazy.force t)) let char t = int t 256 |> Char.unsafe_of_int let ascii t = int t 128 |> Char.unsafe_of_int let make_self_init ?allow_in_tests () = forbid_nondeterminism_in_tests ~allow_in_tests; Lazy.from_val (Stdlib.Random.State.make_self_init ()) ;; let assign = Random_repr.assign let full_init t seed = assign t (make seed) let default = if am_testing then ( (* We define Base's default random state as a copy of OCaml's default random state. This means that programs that use Base.Random will see the same sequence of random bits as if they had used Stdlib.Random. However, because [get_state] returns a copy, Base.Random and OCaml.Random are not using the same state. If a program used both, each of them would go through the same sequence of random bits. To avoid that, we reset OCaml's random state to a different seed, giving it a different sequence. *) let t = Stdlib.Random.get_state () in Stdlib.Random.init 137; Lazy.from_val t) else lazy (* Outside of tests, we initialize random state nondeterministically and lazily. We force the random initialization to be lazy so that we do not pay any cost for it in programs that do not use randomness. *) (Lazy.force (make_self_init ())) ;; let int_on_64bits t bound = if bound <= 0x3FFFFFFF (* (1 lsl 30) - 1 *) then int t bound else Stdlib.Int64.to_int (int64 t (Stdlib.Int64.of_int bound)) ;; let int_on_32bits t bound = (* Not always true with the JavaScript backend. *) if bound <= 0x3FFFFFFF (* (1 lsl 30) - 1 *) then int t bound else Stdlib.Int32.to_int (int32 t (Stdlib.Int32.of_int bound)) ;; let int = match Word_size.word_size with | W64 -> int_on_64bits | W32 -> int_on_32bits ;; let full_range_int64 = let open Stdlib.Int64 in let bits state = of_int (bits state) in fun state -> logxor (bits state) (logxor (shift_left (bits state) 30) (shift_left (bits state) 60)) ;; let full_range_int32 = let open Stdlib.Int32 in let bits state = of_int (bits state) in fun state -> logxor (bits state) (shift_left (bits state) 30) ;; let full_range_int_on_64bits state = Stdlib.Int64.to_int (full_range_int64 state) let full_range_int_on_32bits state = Stdlib.Int32.to_int (full_range_int32 state) let full_range_int = match Word_size.word_size with | W64 -> full_range_int_on_64bits | W32 -> full_range_int_on_32bits ;; let full_range_nativeint_on_64bits state = Stdlib.Int64.to_nativeint (full_range_int64 state) ;; let full_range_nativeint_on_32bits state = Stdlib.Nativeint.of_int32 (full_range_int32 state) ;; let full_range_nativeint = match Word_size.word_size with | W64 -> full_range_nativeint_on_64bits | W32 -> full_range_nativeint_on_32bits ;; let raise_crossed_bounds name lower_bound upper_bound string_of_bound = Printf.failwithf "Random.%s: crossed bounds [%s > %s]" name (string_of_bound lower_bound) (string_of_bound upper_bound) () [@@cold] [@@inline never] [@@local never] [@@specialise never] ;; let int_incl = let rec in_range state lo hi = let int = full_range_int state in if int >= lo && int <= hi then int else in_range state lo hi in fun state lo hi -> if lo > hi then raise_crossed_bounds "int" lo hi Int.to_string; let diff = hi - lo in if diff = Int.max_value then lo + (full_range_int state land Int.max_value) else if diff >= 0 then lo + int state (Int.succ diff) else in_range state lo hi ;; let int32_incl = let open Int32_replace_polymorphic_compare in let rec in_range state lo hi = let int = full_range_int32 state in if int >= lo && int <= hi then int else in_range state lo hi in let open Stdlib.Int32 in fun state lo hi -> if lo > hi then raise_crossed_bounds "int32" lo hi to_string; let diff = sub hi lo in if diff = max_int then add lo (logand (full_range_int32 state) max_int) else if diff >= 0l then add lo (int32 state (succ diff)) else in_range state lo hi ;; let nativeint_incl = let open Nativeint_replace_polymorphic_compare in let rec in_range state lo hi = let int = full_range_nativeint state in if int >= lo && int <= hi then int else in_range state lo hi in let open Stdlib.Nativeint in fun state lo hi -> if lo > hi then raise_crossed_bounds "nativeint" lo hi to_string; let diff = sub hi lo in if diff = max_int then add lo (logand (full_range_nativeint state) max_int) else if diff >= 0n then add lo (nativeint state (succ diff)) else in_range state lo hi ;; let int64_incl = let open Int64_replace_polymorphic_compare in let rec in_range state lo hi = let int = full_range_int64 state in if int >= lo && int <= hi then int else in_range state lo hi in let open Stdlib.Int64 in fun state lo hi -> if lo > hi then raise_crossed_bounds "int64" lo hi to_string; let diff = sub hi lo in if diff = max_int then add lo (logand (full_range_int64 state) max_int) else if diff >= 0L then add lo (int64 state (succ diff)) else in_range state lo hi ;; (* Return a uniformly random float in [0, 1). *) let rec rawfloat state = let open Float_replace_polymorphic_compare in let scale = 0x1p-30 in (* 2^-30 *) let r1 = Stdlib.float_of_int (bits state) in let r2 = Stdlib.float_of_int (bits state) in let result = ((r1 *. scale) +. r2) *. scale in (* With very small probability, result can round up to 1.0, so in that case, we just try again. *) if result < 1.0 then result else rawfloat state ;; let float state hi = rawfloat state *. hi let float_range state lo hi = let open Float_replace_polymorphic_compare in if lo > hi then raise_crossed_bounds "float" lo hi Stdlib.string_of_float; lo +. float state (hi -. lo) ;; end let default = Random_repr.make_default State.default let bits () = State.bits (Random_repr.get_state default) let int x = State.int (Random_repr.get_state default) x let int32 x = State.int32 (Random_repr.get_state default) x let nativeint x = State.nativeint (Random_repr.get_state default) x let int64 x = State.int64 (Random_repr.get_state default) x let float x = State.float (Random_repr.get_state default) x let int_incl x y = State.int_incl (Random_repr.get_state default) x y let int32_incl x y = State.int32_incl (Random_repr.get_state default) x y let nativeint_incl x y = State.nativeint_incl (Random_repr.get_state default) x y let int64_incl x y = State.int64_incl (Random_repr.get_state default) x y let float_range x y = State.float_range (Random_repr.get_state default) x y let bool () = State.bool (Random_repr.get_state default) let char () = State.char (Random_repr.get_state default) let ascii () = State.ascii (Random_repr.get_state default) let full_init seed = State.full_init (Random_repr.get_state default) seed let init seed = full_init [| seed |] let self_init ?allow_in_tests () = full_init (random_seed ?allow_in_tests ()) let set_state s = State.assign (Random_repr.get_state default) s base-0.16.3/src/random.mli000066400000000000000000000127601446274340700153060ustar00rootroot00000000000000(** Pseudo-random number generation. This is a wrapper of the standard library's [Random] library, though it does not share state with that library. *) (*_ (***********************************************************************) (* *) (* Objective Caml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Apache 2.0 license. See ../THIRD-PARTY.txt *) (* for details. *) (* *) (***********************************************************************) *) open! Import (** {6 Basic functions} *) (** Note that all of these "basic" functions mutate a global random state. *) (** Initialize the generator, using the argument as a seed. The same seed will always yield the same sequence of numbers. *) val init : int -> unit (** Same as {!Random.init} but takes more data as seed. *) val full_init : int array -> unit (** Initialize the generator with a more-or-less random seed chosen in a system-dependent way. By default, [self_init] is disallowed in inline tests, as it's often used for no good reason and it just creates nondeterministic failures for everyone. Passing [~allow_in_tests:true] removes this restriction in case you legitimately want nondeterministic values, like in [Filename.temp_dir]. *) val self_init : ?allow_in_tests:bool -> unit -> unit (** Return 30 random bits in a nonnegative integer. @before 3.12.0 used a different algorithm (affects all the following functions) *) val bits : unit -> int (** [Random.int bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0. *) val int : int -> int (** [Random.int32 bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0. *) val int32 : int32 -> int32 (** [Random.nativeint bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0. *) val nativeint : nativeint -> nativeint (** [Random.int64 bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0. *) val int64 : int64 -> int64 (** [Random.float bound] returns a random floating-point number between 0 (inclusive) and [bound] (exclusive). If [bound] is negative, the result is negative or zero. If [bound] is 0, the result is 0. *) val float : float -> float (** Produces a random value between the given inclusive bounds. Raises if bounds are given in decreasing order. *) val int_incl : int -> int -> int val int32_incl : int32 -> int32 -> int32 val nativeint_incl : nativeint -> nativeint -> nativeint val int64_incl : int64 -> int64 -> int64 (** Produces a value between the given bounds (inclusive and exclusive, respectively). Raises if bounds are given in decreasing order. *) val float_range : float -> float -> float (** [Random.bool ()] returns [true] or [false] with probability 0.5 each. *) val bool : unit -> bool (** Return a uniformly-chosen {!char}. *) val char : unit -> char (** Return a uniformly-chosen {!char} in the ASCII range. *) val ascii : unit -> char (** {6 Advanced functions} *) (** The functions from module [State] manipulate the current state of the random generator explicitly. This allows using one or several deterministic PRNGs, even in a multi-threaded program, without interference from other parts of the program. Note that [Random.get_state] from the standard library is not exposed, because it misleadingly makes a copy of random state, which is not typically the desired outcome for accessing the shared state. Obtaining multiple generators with good independence properties is nontrivial; see the [Splittable_random] library for that. *) module State : sig type t (** This gives access to the default random state, allowing user code to share (and thereby mutate) the random state used by the main functions in [Random]. *) val default : t (** Creates a new state and initializes it with the given seed. *) val make : int array -> t (** Creates a new state and initializes it with a system-dependent low-entropy seed. *) val make_self_init : ?allow_in_tests:bool -> unit -> t val copy : t -> t (** These functions are the same as the basic functions, except that they use (and update) the given PRNG state instead of the default one. *) val bits : t -> int val int : t -> int -> int val int32 : t -> int32 -> int32 val nativeint : t -> nativeint -> nativeint val int64 : t -> int64 -> int64 val float : t -> float -> float val int_incl : t -> int -> int -> int val int32_incl : t -> int32 -> int32 -> int32 val nativeint_incl : t -> nativeint -> nativeint -> nativeint val int64_incl : t -> int64 -> int64 -> int64 val float_range : t -> float -> float -> float val bool : t -> bool val char : t -> char val ascii : t -> char end (** Sets the state of the generator used by the basic functions. *) val set_state : State.t -> unit base-0.16.3/src/ref.ml000066400000000000000000000046771446274340700144410ustar00rootroot00000000000000open! Import include ( struct type 'a t = 'a ref [@@deriving_inline compare, equal, globalize, sexp, sexp_grammar] let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = compare_ref let equal : 'a. ('a -> 'a -> bool) -> 'a t -> 'a t -> bool = equal_ref let globalize : 'a. (('a[@ocaml.local]) -> 'a) -> ('a t[@ocaml.local]) -> 'a t = fun (type a__009_) : (((a__009_[@ocaml.local]) -> a__009_) -> (a__009_ t[@ocaml.local]) -> a__009_ t) -> globalize_ref ;; let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = ref_of_sexp let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = sexp_of_ref let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> ref_sexp_grammar _'a_sexp_grammar ;; [@@@end] end : sig type 'a t = 'a ref [@@deriving_inline compare, equal, globalize, sexp, sexp_grammar] include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t val globalize : (('a[@ocaml.local]) -> 'a) -> ('a t[@ocaml.local]) -> 'a t include Sexplib0.Sexpable.S1 with type 'a t := 'a t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] end) (* In the definition of [t], we do not have [[@@deriving compare, sexp]] because in general, syntax extensions tend to use the implementation when available rather than using the alias. Here that would lead to use the record representation [ { mutable contents : 'a } ] which would result in different (and unwanted) behavior. *) type 'a t = 'a ref = { mutable contents : 'a } external create : 'a -> ('a t[@local_opt]) = "%makemutable" external ( ! ) : ('a t[@local_opt]) -> 'a = "%field0" external ( := ) : ('a t[@local_opt]) -> 'a -> unit = "%setfield0" let swap t1 t2 = let tmp = !t1 in t1 := !t2; t2 := tmp ;; let replace t f = t := f !t let set_temporarily t a ~f = let restore_to = !t in t := a; Exn.protect ~f ~finally:(fun () -> t := restore_to) ;; module And_value = struct type t = T : 'a ref * 'a -> t [@@deriving sexp_of] let set (T (r, a)) = r := a let sets ts = List.iter ts ~f:set let snapshot (T (r, _)) = T (r, !r) let snapshots ts = List.map ts ~f:snapshot end let sets_temporarily and_values ~f = let restore_to = And_value.snapshots and_values in And_value.sets and_values; Exn.protect ~f ~finally:(fun () -> And_value.sets restore_to) ;; base-0.16.3/src/ref.mli000066400000000000000000000035121446274340700145750ustar00rootroot00000000000000(** Module for the type [ref], mutable indirection cells [r] containing a value of type ['a], accessed with [!r] and set by [r := a]. *) open! Import type 'a t = 'a Stdlib.ref = { mutable contents : 'a } [@@deriving_inline compare, equal, globalize, sexp, sexp_grammar] include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t val globalize : (('a[@ocaml.local]) -> 'a) -> ('a t[@ocaml.local]) -> 'a t include Sexplib0.Sexpable.S1 with type 'a t := 'a t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] (*_ defined as externals to avoid breaking the inliner *) external create : 'a -> ('a t[@local_opt]) = "%makemutable" external ( ! ) : ('a t[@local_opt]) -> 'a = "%field0" external ( := ) : ('a t[@local_opt]) -> 'a -> unit = "%setfield0" (** [swap t1 t2] swaps the values in [t1] and [t2]. *) val swap : 'a t -> 'a t -> unit (** [replace t f] is [t := f !t] *) val replace : 'a t -> (('a -> 'a)[@local]) -> unit (** [set_temporarily t a ~f] sets [t] to [a], calls [f ()], and then restores [t] to its value prior to [set_temporarily] being called, whether [f] returns or raises. *) val set_temporarily : 'a t -> 'a -> f:((unit -> 'b)[@local]) -> 'b module And_value : sig type t = T : 'a ref * 'a -> t [@@deriving sexp_of] (** [set (T (r, x))] is equivalent to [r := x]. *) val set : t -> unit (** [sets ts = List.iter ts ~f:set] *) val sets : t list -> unit (** [snapshot (T (r, _))] returns [T (r, !r)]. *) val snapshot : t -> t end (** [sets_temporarily [ ...; T (ti, ai); ... ] ~f] sets each [ti] to [ai], calls [f ()], and then restores all [ti] to their value prior to [sets_temporarily] being called, whether [f] returns or raises. *) val sets_temporarily : And_value.t list -> f:((unit -> 'a)[@local]) -> 'a base-0.16.3/src/result.ml000066400000000000000000000160561446274340700151750ustar00rootroot00000000000000open! Import module Either = Either0 type ('a, 'b) t = ('a, 'b) Stdlib.result = | Ok of 'a | Error of 'b [@@deriving_inline sexp, sexp_grammar, compare, equal, hash] let t_of_sexp : 'a 'b. (Sexplib0.Sexp.t -> 'a) -> (Sexplib0.Sexp.t -> 'b) -> Sexplib0.Sexp.t -> ('a, 'b) t = fun (type a__017_ b__018_) : ((Sexplib0.Sexp.t -> a__017_) -> (Sexplib0.Sexp.t -> b__018_) -> Sexplib0.Sexp.t -> (a__017_, b__018_) t) -> let error_source__005_ = "result.ml.t" in fun _of_a__001_ _of_b__002_ -> function | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom (("ok" | "Ok") as _tag__008_) :: sexp_args__009_) as _sexp__007_ -> (match sexp_args__009_ with | [ arg0__010_ ] -> let res0__011_ = _of_a__001_ arg0__010_ in Ok res0__011_ | _ -> Sexplib0.Sexp_conv_error.stag_incorrect_n_args error_source__005_ _tag__008_ _sexp__007_) | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom (("error" | "Error") as _tag__013_) :: sexp_args__014_) as _sexp__012_ -> (match sexp_args__014_ with | [ arg0__015_ ] -> let res0__016_ = _of_b__002_ arg0__015_ in Error res0__016_ | _ -> Sexplib0.Sexp_conv_error.stag_incorrect_n_args error_source__005_ _tag__013_ _sexp__012_) | Sexplib0.Sexp.Atom ("ok" | "Ok") as sexp__006_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__005_ sexp__006_ | Sexplib0.Sexp.Atom ("error" | "Error") as sexp__006_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__005_ sexp__006_ | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__004_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__005_ sexp__004_ | Sexplib0.Sexp.List [] as sexp__004_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__005_ sexp__004_ | sexp__004_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__005_ sexp__004_ ;; let sexp_of_t : 'a 'b. ('a -> Sexplib0.Sexp.t) -> ('b -> Sexplib0.Sexp.t) -> ('a, 'b) t -> Sexplib0.Sexp.t = fun (type a__025_ b__026_) : ((a__025_ -> Sexplib0.Sexp.t) -> (b__026_ -> Sexplib0.Sexp.t) -> (a__025_, b__026_) t -> Sexplib0.Sexp.t) -> fun _of_a__019_ _of_b__020_ -> function | Ok arg0__021_ -> let res0__022_ = _of_a__019_ arg0__021_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Ok"; res0__022_ ] | Error arg0__023_ -> let res0__024_ = _of_b__020_ arg0__023_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Error"; res0__024_ ] ;; let t_sexp_grammar : 'a 'b. 'a Sexplib0.Sexp_grammar.t -> 'b Sexplib0.Sexp_grammar.t -> ('a, 'b) t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar _'b_sexp_grammar -> { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "Ok" ; clause_kind = List_clause { args = Cons (_'a_sexp_grammar.untyped, Empty) } } ; No_tag { name = "Error" ; clause_kind = List_clause { args = Cons (_'b_sexp_grammar.untyped, Empty) } } ] } } ;; let compare : 'a 'b. ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int = fun _cmp__a _cmp__b a__027_ b__028_ -> if Stdlib.( == ) a__027_ b__028_ then 0 else ( match a__027_, b__028_ with | Ok _a__029_, Ok _b__030_ -> _cmp__a _a__029_ _b__030_ | Ok _, _ -> -1 | _, Ok _ -> 1 | Error _a__031_, Error _b__032_ -> _cmp__b _a__031_ _b__032_) ;; let equal : 'a 'b. ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t -> bool = fun _cmp__a _cmp__b a__033_ b__034_ -> if Stdlib.( == ) a__033_ b__034_ then true else ( match a__033_, b__034_ with | Ok _a__035_, Ok _b__036_ -> _cmp__a _a__035_ _b__036_ | Ok _, _ -> false | _, Ok _ -> false | Error _a__037_, Error _b__038_ -> _cmp__b _a__037_ _b__038_) ;; let hash_fold_t : type a b. (Ppx_hash_lib.Std.Hash.state -> a -> Ppx_hash_lib.Std.Hash.state) -> (Ppx_hash_lib.Std.Hash.state -> b -> Ppx_hash_lib.Std.Hash.state) -> Ppx_hash_lib.Std.Hash.state -> (a, b) t -> Ppx_hash_lib.Std.Hash.state = fun _hash_fold_a _hash_fold_b hsv arg -> match arg with | Ok _a0 -> let hsv = Ppx_hash_lib.Std.Hash.fold_int hsv 0 in let hsv = hsv in _hash_fold_a hsv _a0 | Error _a0 -> let hsv = Ppx_hash_lib.Std.Hash.fold_int hsv 1 in let hsv = hsv in _hash_fold_b hsv _a0 ;; [@@@end] let globalize = globalize_result include Monad.Make2_local (struct type nonrec ('a, 'b) t = ('a, 'b) t let bind x ~f = match x with | Error _ as x -> x | Ok x -> f x ;; let map x ~f = match x with | Error _ as x -> x | Ok x -> Ok (f x) ;; let map = `Custom map let return x = Ok x end) let invariant check_ok check_error t = match t with | Ok ok -> check_ok ok | Error error -> check_error error ;; let fail x = Error x let failf format = Printf.ksprintf fail format let map_error t ~f = match t with | Ok _ as x -> x | Error x -> Error (f x) ;; module Error = Monad.Make2_local (struct type nonrec ('a, 'b) t = ('b, 'a) t let bind x ~f = match x with | Ok _ as ok -> ok | Error e -> f e ;; let map = `Custom map_error let return e = Error e end) let is_ok = function | Ok _ -> true | Error _ -> false ;; let is_error = function | Ok _ -> false | Error _ -> true ;; let ok = function | Ok x -> Some x | Error _ -> None ;; let error = function | Ok _ -> None | Error x -> Some x ;; let of_option opt ~error = match opt with | Some x -> Ok x | None -> Error error ;; let iter v ~f = match v with | Ok x -> f x | Error _ -> () ;; let iter_error v ~f = match v with | Ok _ -> () | Error x -> f x ;; let to_either : _ t -> _ Either.t = function | Ok x -> First x | Error x -> Second x ;; let of_either : _ Either.t -> _ t = function | First x -> Ok x | Second x -> Error x ;; let ok_if_true bool ~error = if bool then Ok () else Error error let try_with f = try Ok (f ()) with | exn -> Error exn ;; let ok_exn = function | Ok x -> x | Error exn -> raise exn ;; let ok_or_failwith = function | Ok x -> x | Error str -> failwith str ;; module Export = struct type ('ok, 'err) _result = ('ok, 'err) t = | Ok of 'ok | Error of 'err let is_error = is_error let is_ok = is_ok end let combine t1 t2 ~ok ~err = match t1, t2 with | Ok _, Error e | Error e, Ok _ -> Error e | Ok ok1, Ok ok2 -> Ok (ok ok1 ok2) | Error err1, Error err2 -> Error (err err1 err2) ;; let combine_errors l = let ok, errs = List1.partition_map l ~f:to_either in match errs with | [] -> Ok ok | _ :: _ -> Error errs ;; let combine_errors_unit l = map (combine_errors l) ~f:(fun (_ : unit list) -> ()) (* deprecated binding for export only *) let ok_fst = to_either base-0.16.3/src/result.mli000066400000000000000000000071421446274340700153420ustar00rootroot00000000000000(** [Result] is often used to handle error messages. *) open! Import (** ['ok] is the return type, and ['err] is often an error message string. {[ type nat = Zero | Succ of nat let pred = function | Succ n -> Ok n | Zero -> Error "Zero does not have a predecessor" ]} The return type of [pred] could be [nat option], but [(nat, string) Result.t] gives more control over the error message. *) type ('ok, 'err) t = ('ok, 'err) Stdlib.result = | Ok of 'ok | Error of 'err [@@deriving_inline sexp, sexp_grammar, compare, equal, globalize, hash] include Sexplib0.Sexpable.S2 with type ('ok, 'err) t := ('ok, 'err) t val t_sexp_grammar : 'ok Sexplib0.Sexp_grammar.t -> 'err Sexplib0.Sexp_grammar.t -> ('ok, 'err) t Sexplib0.Sexp_grammar.t include Ppx_compare_lib.Comparable.S2 with type ('ok, 'err) t := ('ok, 'err) t include Ppx_compare_lib.Equal.S2 with type ('ok, 'err) t := ('ok, 'err) t val globalize : (('ok[@ocaml.local]) -> 'ok) -> (('err[@ocaml.local]) -> 'err) -> (('ok, 'err) t[@ocaml.local]) -> ('ok, 'err) t include Ppx_hash_lib.Hashable.S2 with type ('ok, 'err) t := ('ok, 'err) t [@@@end] include Monad.S2_local with type ('a, 'err) t := ('a, 'err) t module Error : Monad.S2_local with type ('err, 'a) t := ('a, 'err) t include Invariant_intf.S2 with type ('ok, 'err) t := ('ok, 'err) t val fail : 'err -> (_, 'err) t (** e.g., [failf "Couldn't find bloogle %s" (Bloogle.to_string b)]. *) val failf : ('a, unit, string, (_, string) t) format4 -> 'a val is_ok : (_, _) t -> bool val is_error : (_, _) t -> bool val ok : ('ok, _) t -> 'ok option val ok_exn : ('ok, exn) t -> 'ok val ok_or_failwith : ('ok, string) t -> 'ok val error : (_, 'err) t -> 'err option val of_option : 'ok option -> error:'err -> ('ok, 'err) t val iter : ('ok, _) t -> f:(('ok -> unit)[@local]) -> unit val iter_error : (_, 'err) t -> f:(('err -> unit)[@local]) -> unit val map : ('ok, 'err) t -> f:(('ok -> 'c)[@local]) -> ('c, 'err) t val map_error : ('ok, 'err) t -> f:(('err -> 'c)[@local]) -> ('ok, 'c) t (** Returns [Ok] if both are [Ok] and [Error] otherwise. *) val combine : ('ok1, 'err) t -> ('ok2, 'err) t -> ok:(('ok1 -> 'ok2 -> 'ok3)[@local]) -> err:(('err -> 'err -> 'err)[@local]) -> ('ok3, 'err) t (** [combine_errors ts] returns [Ok] if every element in [ts] is [Ok], else it returns [Error] with all the errors in [ts]. This is similar to [all] from [Monad.S2], with the difference that [all] only returns the first error. *) val combine_errors : ('ok, 'err) t list -> ('ok list, 'err list) t (** [combine_errors_unit] returns [Ok] if every element in [ts] is [Ok ()], else it returns [Error] with all the errors in [ts], like [combine_errors]. *) val combine_errors_unit : (unit, 'err) t list -> (unit, 'err list) t (** [to_either] is useful with [List.partition_map]. For example: {[ let ints, exns = List.partition_map ["1"; "two"; "three"; "4"] ~f:(fun string -> Result.to_either (Result.try_with (fun () -> Int.of_string string))) ]} *) val to_either : ('ok, 'err) t -> ('ok, 'err) Either0.t val of_either : ('ok, 'err) Either0.t -> ('ok, 'err) t val ok_fst : ('ok, 'err) t -> ('ok, 'err) Either0.t [@@deprecated "[since 2020-01] Use [to_either] instead."] (** [ok_if_true] returns [Ok ()] if [bool] is true, and [Error error] if it is false. *) val ok_if_true : bool -> error:'err -> (unit, 'err) t val try_with : ((unit -> 'a)[@local]) -> ('a, exn) t module Export : sig type ('ok, 'err) _result = ('ok, 'err) t = | Ok of 'ok | Error of 'err val is_ok : (_, _) t -> bool val is_error : (_, _) t -> bool end base-0.16.3/src/runtime.js000066400000000000000000000132561446274340700153450ustar00rootroot00000000000000//Provides: Base_int_math_int_popcount const function Base_int_math_int_popcount(v) { v = v - ((v >>> 1) & 0x55555555); v = (v & 0x33333333) + ((v >>> 2) & 0x33333333); return ((v + (v >>> 4) & 0xF0F0F0F) * 0x1010101) >>> 24; } //Provides: Base_clear_caml_backtrace_pos const function Base_clear_caml_backtrace_pos(x) { return 0; } //Provides: Base_caml_exn_is_most_recent_exn const function Base_caml_exn_is_most_recent_exn(x) { return 1; } //Provides: Base_int_math_int32_clz const function Base_int_math_int32_clz(x) { var n = 32; var y; y = x >>16; if (y != 0) { n = n -16; x = y; } y = x >> 8; if (y != 0) { n = n - 8; x = y; } y = x >> 4; if (y != 0) { n = n - 4; x = y; } y = x >> 2; if (y != 0) { n = n - 2; x = y; } y = x >> 1; if (y != 0) return n - 2; return n - x; } //Provides: Base_int_math_int_clz const //Requires: Base_int_math_int32_clz function Base_int_math_int_clz(x) { return Base_int_math_int32_clz(x); } //Provides: Base_int_math_nativeint_clz const //Requires: Base_int_math_int32_clz function Base_int_math_nativeint_clz(x) { return Base_int_math_int32_clz(x); } //Provides: Base_int_math_int64_clz const //Requires: caml_int64_shift_right_unsigned, caml_int64_is_zero, caml_int64_to_int32 function Base_int_math_int64_clz(x) { var n = 64; var y; y = caml_int64_shift_right_unsigned(x, 32); if (!caml_int64_is_zero(y)) { n = n -32; x = y; } y = caml_int64_shift_right_unsigned(x, 16); if (!caml_int64_is_zero(y)) { n = n -16; x = y; } y = caml_int64_shift_right_unsigned(x, 8); if (!caml_int64_is_zero(y)) { n = n - 8; x = y; } y = caml_int64_shift_right_unsigned(x, 4); if (!caml_int64_is_zero(y)) { n = n - 4; x = y; } y = caml_int64_shift_right_unsigned(x, 2); if (!caml_int64_is_zero(y)) { n = n - 2; x = y; } y = caml_int64_shift_right_unsigned(x, 1); if (!caml_int64_is_zero(y)) return n - 2; return n - caml_int64_to_int32(x); } //Provides: Base_int_math_int32_ctz const function Base_int_math_int32_ctz(x) { if (x === 0) { return 32; } var n = 1; if ( (x & 0x0000FFFF) === 0) { n = n + 16; x = x >> 16; } if ( (x & 0x000000FF) === 0) { n = n + 8; x = x >> 8; } if ( (x & 0x0000000F) === 0) { n = n + 4; x = x >> 4; } if ( (x & 0x00000003) === 0) { n = n + 2; x = x >> 2; } return n - (x & 1); } //Provides: Base_int_math_int_ctz const //Requires: Base_int_math_int32_ctz function Base_int_math_int_ctz(x) { return Base_int_math_int32_ctz(x); } //Provides: Base_int_math_nativeint_ctz const //Requires: Base_int_math_int32_ctz function Base_int_math_nativeint_ctz(x) { return Base_int_math_int32_ctz(x); } //Provides: Base_int_math_int64_ctz const //Requires: caml_int64_shift_right_unsigned, caml_int64_is_zero, caml_int64_to_int32 //Requires: caml_int64_and, caml_int64_of_int32, caml_int64_create_lo_mi_hi function Base_int_math_int64_ctz(x) { if (caml_int64_is_zero(x)) { return 64; } var n = 1; function is_zero (x) { return caml_int64_is_zero(x); } function land (x,y) { return caml_int64_and(x, y); } function small_int64(x) { return caml_int64_create_lo_mi_hi(x,0,0); } if (is_zero(land(x, caml_int64_create_lo_mi_hi(0xFFFFFF, 0x0000FF, 0x0000)))) { n = n + 32; x = caml_int64_shift_right_unsigned(x, 32); } if (is_zero(land(x, small_int64(0x00FFFF)))) { n = n + 16; x = caml_int64_shift_right_unsigned(x, 16); } if (is_zero(land(x, small_int64(0x0000FF)))) { n = n + 8; x = caml_int64_shift_right_unsigned(x, 8); } if (is_zero(land(x, small_int64(0x00000F)))) { n = n + 4; x = caml_int64_shift_right_unsigned(x, 4); } if (is_zero(land(x, small_int64(0x000003)))) { n = n + 2; x = caml_int64_shift_right_unsigned(x, 2); } return n - (caml_int64_to_int32(caml_int64_and(x, small_int64(0x000001)))); } //Provides: Base_int_math_int_pow_stub const function Base_int_math_int_pow_stub(base, exponent) { var one = 1; var mul = [one, base, one, one]; var res = one; while (!exponent==0) { mul[1] = (mul[1] * mul[3]) | 0; mul[2] = (mul[1] * mul[1]) | 0; mul[3] = (mul[2] * mul[1]) | 0; res = (res * mul[exponent & 3]) | 0; exponent = exponent >> 2; } return res; } //Provides: Base_int_math_int64_pow_stub const //Requires: caml_int64_mul, caml_int64_is_zero, caml_int64_shift_right_unsigned //Requires: caml_int64_create_lo_hi, caml_int64_lo32 function Base_int_math_int64_pow_stub(base, exponent) { var one = caml_int64_create_lo_hi(1,0); var mul = [one, base, one, one]; var res = one; while (!caml_int64_is_zero(exponent)) { mul[1] = caml_int64_mul(mul[1], mul[3]); mul[2] = caml_int64_mul(mul[1], mul[1]); mul[3] = caml_int64_mul(mul[2], mul[1]); res = caml_int64_mul(res, mul[caml_int64_lo32(exponent) & 3]); exponent = caml_int64_shift_right_unsigned(exponent, 2); } return res; } //Provides: Base_hash_string mutable //Requires: caml_hash function Base_hash_string(s) { return caml_hash(1,1,0,s) } //Provides: Base_hash_double const //Requires: caml_hash function Base_hash_double(d) { return caml_hash(1,1,0,d); } //Provides: Base_am_testing const //Weakdef function Base_am_testing(x) { return 0; } //Provides: caml_csel_value function caml_csel_value(v_cond, v_true, v_false) { if (v_cond) return v_true; else return v_false; } //Provides: Base_unsafe_create_local_bytes //Requires: caml_create_bytes function Base_unsafe_create_local_bytes(v_len) { // This does a redundant bounds check and (since this is // javascript) doesn't allocate locally, but that's fine. return caml_create_bytes(v_len); } //Provides: caml_make_local_vect //Requires: caml_make_vect function caml_make_local_vect(v_len, v_elt) { // In javascript there's no local allocation. return caml_make_vect (v_len, v_elt); } base-0.16.3/src/select-random-repr/000077500000000000000000000000001446274340700170205ustar00rootroot00000000000000base-0.16.3/src/select-random-repr/dune000066400000000000000000000000001446274340700176640ustar00rootroot00000000000000base-0.16.3/src/select-random-repr/select.ml000066400000000000000000000025751446274340700206420ustar00rootroot00000000000000let () = let ver, output = match Sys.argv with | [| _; "-ocaml-version"; v; "-o"; fn |] -> Scanf.sscanf v "%d.%d" (fun major minor -> major, minor), fn | _ -> failwith "bad command line arguments" in let oc = open_out output in if ver >= (5, 0) then Printf.fprintf oc {| module Repr = struct open Stdlib.Bigarray type t = (int64, int64_elt, c_layout) Array1.t let of_state : Stdlib.Random.State.t -> t = Stdlib.Obj.magic end let assign dst src = let dst = Repr.of_state (Lazy.force dst) in let src = Repr.of_state (Lazy.force src) in Stdlib.Bigarray.Array1.blit src dst let make_default default = let split_from_parent v = Stdlib.Lazy.map_val Stdlib.Random.State.split v in Stdlib.Domain.DLS.new_key ~split_from_parent (fun () -> default) let get_state random_key = Stdlib.Domain.DLS.get random_key |} else Printf.fprintf oc {| module Array = Array0 module Repr = struct type t = { st : int array ; mutable idx : int } let of_state : Stdlib.Random.State.t -> t = Stdlib.Obj.magic end let assign t1 t2 = let t1 = Repr.of_state (Lazy.force t1) in let t2 = Repr.of_state (Lazy.force t2) in Array.blit ~src:t2.st ~src_pos:0 ~dst:t1.st ~dst_pos:0 ~len:(Array.length t1.st); t1.idx <- t2.idx let make_default default = default let[@inline always] get_state state = state |}; close_out oc ;; base-0.16.3/src/select-random-repr/select.mli000066400000000000000000000000551446274340700210020ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/src/sequence.ml000066400000000000000000001174531446274340700154720ustar00rootroot00000000000000open! Import open Container_intf.Export module Array = Array0 module List = List1 module Step = struct (* 'a is an item in the sequence, 's is the state that will produce the remainder of the sequence *) type ('a, 's) t = | Done | Skip of { state : 's } | Yield of { value : 'a ; state : 's } [@@deriving_inline sexp_of] let sexp_of_t : 'a 's. ('a -> Sexplib0.Sexp.t) -> ('s -> Sexplib0.Sexp.t) -> ('a, 's) t -> Sexplib0.Sexp.t = fun (type a__011_ s__012_) : ((a__011_ -> Sexplib0.Sexp.t) -> (s__012_ -> Sexplib0.Sexp.t) -> (a__011_, s__012_) t -> Sexplib0.Sexp.t) -> fun _of_a__001_ _of_s__002_ -> function | Done -> Sexplib0.Sexp.Atom "Done" | Skip { state = state__004_ } -> let bnds__003_ = ([] : _ Stdlib.List.t) in let bnds__003_ = let arg__005_ = _of_s__002_ state__004_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "state"; arg__005_ ] :: bnds__003_ : _ Stdlib.List.t) in Sexplib0.Sexp.List (Sexplib0.Sexp.Atom "Skip" :: bnds__003_) | Yield { value = value__007_; state = state__009_ } -> let bnds__006_ = ([] : _ Stdlib.List.t) in let bnds__006_ = let arg__010_ = _of_s__002_ state__009_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "state"; arg__010_ ] :: bnds__006_ : _ Stdlib.List.t) in let bnds__006_ = let arg__008_ = _of_a__001_ value__007_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "value"; arg__008_ ] :: bnds__006_ : _ Stdlib.List.t) in Sexplib0.Sexp.List (Sexplib0.Sexp.Atom "Yield" :: bnds__006_) ;; [@@@end] end open Step (* 'a is an item in the sequence, 's is the state that will produce the remainder of the sequence *) type +_ t = | Sequence : { state : 's ; next : 's -> ('a, 's) Step.t } -> 'a t module Expert = struct let next_step (Sequence { state = s; next = f }) = match f s with | Done -> Done | Skip { state = s } -> Skip { state = Sequence { state = s; next = f } } | Yield { value = a; state = s } -> Yield { value = a; state = Sequence { state = s; next = f } } ;; let delayed_fold_step s ~init ~f ~finish = let rec loop s next finish f acc = match next s with | Done -> finish acc | Skip { state = s } -> f acc None ~k:(loop s next finish f) | Yield { value = a; state = s } -> f acc (Some a) ~k:(loop s next finish f) in match s with | Sequence { state = s; next } -> loop s next finish f init ;; end let unfold_step ~init ~f = Sequence { state = init; next = f } let unfold ~init ~f = unfold_step ~init ~f:(fun s -> match f s with | None -> Step.Done | Some (a, s) -> Step.Yield { value = a; state = s }) ;; let unfold_with s ~init ~f = match s with | Sequence { state = s; next } -> Sequence { state = init, s ; next = (fun (seed, s) -> match next s with | Done -> Done | Skip { state = s } -> Skip { state = seed, s } | Yield { value = a; state = s } -> (match f seed a with | Done -> Done | Skip { state = seed } -> Skip { state = seed, s } | Yield { value = a; state = seed } -> Yield { value = a; state = seed, s })) } ;; let unfold_with_and_finish s ~init ~running_step ~inner_finished ~finishing_step = match s with | Sequence { state = s; next } -> Sequence { state = `Inner_running (init, s) ; next = (fun state -> match state with | `Inner_running (state, inner_state) -> (match next inner_state with | Done -> Skip { state = `Inner_finished (inner_finished state) } | Skip { state = inner_state } -> Skip { state = `Inner_running (state, inner_state) } | Yield { value = x; state = inner_state } -> (match running_step state x with | Done -> Done | Skip { state } -> Skip { state = `Inner_running (state, inner_state) } | Yield { value = y; state } -> Yield { value = y; state = `Inner_running (state, inner_state) })) | `Inner_finished state -> (match finishing_step state with | Done -> Done | Skip { state } -> Skip { state = `Inner_finished state } | Yield { value = y; state } -> Yield { value = y; state = `Inner_finished state })) } ;; let of_list l = unfold_step ~init:l ~f:(function | [] -> Done | x :: l -> Yield { value = x; state = l }) ;; let fold t ~init ~f = let rec loop seed v next f = match next seed with | Done -> v | Skip { state = s } -> loop s v next f | Yield { value = a; state = s } -> loop s (f v a) next f in match t with | Sequence { state = seed; next } -> loop seed init next f ;; let to_list_rev t = fold t ~init:[] ~f:(fun l x -> x :: l) let to_list (Sequence { state = s; next }) = let safe_to_list t = List.rev (to_list_rev t) in let rec to_list s next i = if i = 0 then safe_to_list (Sequence { state = s; next }) else ( match next s with | Done -> [] | Skip { state = s } -> to_list s next i | Yield { value = a; state = s } -> a :: to_list s next (i - 1)) in to_list s next 500 ;; let sexp_of_t sexp_of_a t = sexp_of_list sexp_of_a (to_list t) let range ?(stride = 1) ?(start = `inclusive) ?(stop = `exclusive) start_v stop_v = let step = match stop with | `inclusive when stride >= 0 -> fun i -> if i > stop_v then Done else Yield { value = i; state = i + stride } | `inclusive -> fun i -> if i < stop_v then Done else Yield { value = i; state = i + stride } | `exclusive when stride >= 0 -> fun i -> if i >= stop_v then Done else Yield { value = i; state = i + stride } | `exclusive -> fun i -> if i <= stop_v then Done else Yield { value = i; state = i + stride } in let init = match start with | `inclusive -> start_v | `exclusive -> start_v + stride in unfold_step ~init ~f:step ;; let of_lazy t_lazy = unfold_step ~init:t_lazy ~f:(fun t_lazy -> let (Sequence { state = s; next }) = Lazy.force t_lazy in match next s with | Done -> Done | Skip { state = s } -> Skip { state = (let v = Sequence { state = s; next } in lazy v) } | Yield { value = x; state = s } -> Yield { value = x ; state = (let v = Sequence { state = s; next } in lazy v) }) ;; let map t ~f = match t with | Sequence { state = seed; next } -> Sequence { state = seed ; next = (fun seed -> match next seed with | Done -> Done | Skip { state = s } -> Skip { state = s } | Yield { value = a; state = s } -> Yield { value = f a; state = s }) } ;; let mapi t ~f = match t with | Sequence { state = s; next } -> Sequence { state = 0, s ; next = (fun (i, s) -> match next s with | Done -> Done | Skip { state = s } -> Skip { state = i, s } | Yield { value = a; state = s } -> Yield { value = f i a; state = i + 1, s }) } ;; let folding_map t ~init ~f = unfold_with t ~init ~f:(fun acc x -> let acc, x = f acc x in Yield { value = x; state = acc }) ;; let folding_mapi t ~init ~f = unfold_with t ~init:(0, init) ~f:(fun (i, acc) x -> let acc, x = f i acc x in Yield { value = x; state = i + 1, acc }) ;; let filter t ~f = match t with | Sequence { state = seed; next } -> Sequence { state = seed ; next = (fun seed -> match next seed with | Done -> Done | Skip { state = s } -> Skip { state = s } | Yield { value = a; state = s } when f a -> Yield { value = a; state = s } | Yield { value = _; state = s } -> Skip { state = s }) } ;; let filteri t ~f = map ~f:snd (filter (mapi t ~f:(fun i s -> i, s)) ~f:(fun (i, s) -> f i s)) ;; let length t = let rec loop i s next = match next s with | Done -> i | Skip { state = s } -> loop i s next | Yield { value = _; state = s } -> loop (i + 1) s next in match t with | Sequence { state = seed; next } -> loop 0 seed next ;; let to_list_rev_with_length t = fold t ~init:([], 0) ~f:(fun (l, i) x -> x :: l, i + 1) let to_array t = let l, len = to_list_rev_with_length t in match l with | [] -> [||] | x :: l -> let a = Array.create ~len x in let rec loop i l = match l with | [] -> assert (i = -1) | x :: l -> a.(i) <- x; loop (i - 1) l in loop (len - 2) l; a ;; let find t ~f = let rec loop s next f = match next s with | Done -> None | Yield { value = a; state = _ } when f a -> Some a | Yield { value = _; state = s } | Skip { state = s } -> loop s next f in match t with | Sequence { state = seed; next } -> loop seed next f ;; let find_map t ~f = let rec loop s next f = match next s with | Done -> None | Yield { value = a; state = s } -> (match f a with | None -> loop s next f | some_b -> some_b) | Skip { state = s } -> loop s next f in match t with | Sequence { state = seed; next } -> loop seed next f ;; let find_mapi t ~f = let rec loop s next f i = match next s with | Done -> None | Yield { value = a; state = s } -> (match f i a with | None -> loop s next f (i + 1) | some_b -> some_b) | Skip { state = s } -> loop s next f i in match t with | Sequence { state = seed; next } -> loop seed next f 0 ;; let for_all t ~f = let rec loop s next f = match next s with | Done -> true | Yield { value = a; state = _ } when not (f a) -> false | Yield { value = _; state = s } | Skip { state = s } -> loop s next f in match t with | Sequence { state = seed; next } -> loop seed next f ;; let for_alli t ~f = let rec loop s next f i = match next s with | Done -> true | Yield { value = a; state = _ } when not (f i a) -> false | Yield { value = _; state = s } -> loop s next f (i + 1) | Skip { state = s } -> loop s next f i in match t with | Sequence { state = seed; next } -> loop seed next f 0 ;; let exists t ~f = let rec loop s next f = match next s with | Done -> false | Yield { value = a; state = _ } when f a -> true | Yield { value = _; state = s } | Skip { state = s } -> loop s next f in match t with | Sequence { state = seed; next } -> loop seed next f ;; let existsi t ~f = let rec loop s next f i = match next s with | Done -> false | Yield { value = a; state = _ } when f i a -> true | Yield { value = _; state = s } -> loop s next f (i + 1) | Skip { state = s } -> loop s next f i in match t with | Sequence { state = seed; next } -> loop seed next f 0 ;; let iter t ~f = let rec loop seed next f = match next seed with | Done -> () | Skip { state = s } -> loop s next f | Yield { value = a; state = s } -> f a; loop s next f in match t with | Sequence { state = seed; next } -> loop seed next f ;; let is_empty t = let rec loop s next = match next s with | Done -> true | Skip { state = s } -> loop s next | Yield _ -> false in match t with | Sequence { state = seed; next } -> loop seed next ;; let mem t a ~equal = let rec loop s next a = match next s with | Done -> false | Yield { value = b; state = _ } when equal a b -> true | Yield { value = _; state = s } | Skip { state = s } -> loop s next a in match t with | Sequence { state = seed; next } -> loop seed next a [@nontail] ;; let empty = Sequence { state = (); next = (fun () -> Done) } let bind t ~f = unfold_step ~f:(function | Sequence { state = seed; next }, rest -> (match next seed with | Done -> (match rest with | Sequence { state = seed; next } -> (match next seed with | Done -> Done | Skip { state = s } -> Skip { state = empty, Sequence { state = s; next } } | Yield { value = a; state = s } -> Skip { state = f a, Sequence { state = s; next } })) | Skip { state = s } -> Skip { state = Sequence { state = s; next }, rest } | Yield { value = a; state = s } -> Yield { value = a; state = Sequence { state = s; next }, rest })) ~init:(empty, t) ;; let return x = unfold_step ~init:(Some x) ~f:(function | None -> Done | Some x -> Yield { value = x; state = None }) ;; include Monad.Make (struct type nonrec 'a t = 'a t let map = `Custom map let bind = bind let return = return end) let nth s n = if n < 0 then None else ( let rec loop i s next = match next s with | Done -> None | Skip { state = s } -> loop i s next | Yield { value = a; state = s } -> if phys_equal i 0 then Some a else loop (i - 1) s next in match s with | Sequence { state = s; next } -> loop n s next) ;; let nth_exn s n = if n < 0 then invalid_arg "Sequence.nth" else ( match nth s n with | None -> failwith "Sequence.nth" | Some x -> x) ;; module Merge_with_duplicates_element = struct type ('a, 'b) t = | Left of 'a | Right of 'b | Both of 'a * 'b [@@deriving_inline compare, hash, sexp, sexp_grammar] let compare : 'a 'b. ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int = fun _cmp__a _cmp__b a__013_ b__014_ -> if Stdlib.( == ) a__013_ b__014_ then 0 else ( match a__013_, b__014_ with | Left _a__015_, Left _b__016_ -> _cmp__a _a__015_ _b__016_ | Left _, _ -> -1 | _, Left _ -> 1 | Right _a__017_, Right _b__018_ -> _cmp__b _a__017_ _b__018_ | Right _, _ -> -1 | _, Right _ -> 1 | Both (_a__019_, _a__021_), Both (_b__020_, _b__022_) -> (match _cmp__a _a__019_ _b__020_ with | 0 -> _cmp__b _a__021_ _b__022_ | n -> n)) ;; let hash_fold_t : type a b. (Ppx_hash_lib.Std.Hash.state -> a -> Ppx_hash_lib.Std.Hash.state) -> (Ppx_hash_lib.Std.Hash.state -> b -> Ppx_hash_lib.Std.Hash.state) -> Ppx_hash_lib.Std.Hash.state -> (a, b) t -> Ppx_hash_lib.Std.Hash.state = fun _hash_fold_a _hash_fold_b hsv arg -> match arg with | Left _a0 -> let hsv = Ppx_hash_lib.Std.Hash.fold_int hsv 0 in let hsv = hsv in _hash_fold_a hsv _a0 | Right _a0 -> let hsv = Ppx_hash_lib.Std.Hash.fold_int hsv 1 in let hsv = hsv in _hash_fold_b hsv _a0 | Both (_a0, _a1) -> let hsv = Ppx_hash_lib.Std.Hash.fold_int hsv 2 in let hsv = let hsv = hsv in _hash_fold_a hsv _a0 in _hash_fold_b hsv _a1 ;; let t_of_sexp : 'a 'b. (Sexplib0.Sexp.t -> 'a) -> (Sexplib0.Sexp.t -> 'b) -> Sexplib0.Sexp.t -> ('a, 'b) t = fun (type a__046_ b__047_) : ((Sexplib0.Sexp.t -> a__046_) -> (Sexplib0.Sexp.t -> b__047_) -> Sexplib0.Sexp.t -> (a__046_, b__047_) t) -> let error_source__027_ = "sequence.ml.Merge_with_duplicates_element.t" in fun _of_a__023_ _of_b__024_ -> function | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom (("left" | "Left") as _tag__030_) :: sexp_args__031_) as _sexp__029_ -> (match sexp_args__031_ with | [ arg0__032_ ] -> let res0__033_ = _of_a__023_ arg0__032_ in Left res0__033_ | _ -> Sexplib0.Sexp_conv_error.stag_incorrect_n_args error_source__027_ _tag__030_ _sexp__029_) | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom (("right" | "Right") as _tag__035_) :: sexp_args__036_) as _sexp__034_ -> (match sexp_args__036_ with | [ arg0__037_ ] -> let res0__038_ = _of_b__024_ arg0__037_ in Right res0__038_ | _ -> Sexplib0.Sexp_conv_error.stag_incorrect_n_args error_source__027_ _tag__035_ _sexp__034_) | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom (("both" | "Both") as _tag__040_) :: sexp_args__041_) as _sexp__039_ -> (match sexp_args__041_ with | [ arg0__042_; arg1__043_ ] -> let res0__044_ = _of_a__023_ arg0__042_ and res1__045_ = _of_b__024_ arg1__043_ in Both (res0__044_, res1__045_) | _ -> Sexplib0.Sexp_conv_error.stag_incorrect_n_args error_source__027_ _tag__040_ _sexp__039_) | Sexplib0.Sexp.Atom ("left" | "Left") as sexp__028_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__027_ sexp__028_ | Sexplib0.Sexp.Atom ("right" | "Right") as sexp__028_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__027_ sexp__028_ | Sexplib0.Sexp.Atom ("both" | "Both") as sexp__028_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__027_ sexp__028_ | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__026_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__027_ sexp__026_ | Sexplib0.Sexp.List [] as sexp__026_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__027_ sexp__026_ | sexp__026_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__027_ sexp__026_ ;; let sexp_of_t : 'a 'b. ('a -> Sexplib0.Sexp.t) -> ('b -> Sexplib0.Sexp.t) -> ('a, 'b) t -> Sexplib0.Sexp.t = fun (type a__058_ b__059_) : ((a__058_ -> Sexplib0.Sexp.t) -> (b__059_ -> Sexplib0.Sexp.t) -> (a__058_, b__059_) t -> Sexplib0.Sexp.t) -> fun _of_a__048_ _of_b__049_ -> function | Left arg0__050_ -> let res0__051_ = _of_a__048_ arg0__050_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Left"; res0__051_ ] | Right arg0__052_ -> let res0__053_ = _of_b__049_ arg0__052_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Right"; res0__053_ ] | Both (arg0__054_, arg1__055_) -> let res0__056_ = _of_a__048_ arg0__054_ and res1__057_ = _of_b__049_ arg1__055_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Both"; res0__056_; res1__057_ ] ;; let t_sexp_grammar : 'a 'b. 'a Sexplib0.Sexp_grammar.t -> 'b Sexplib0.Sexp_grammar.t -> ('a, 'b) t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar _'b_sexp_grammar -> { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "Left" ; clause_kind = List_clause { args = Cons (_'a_sexp_grammar.untyped, Empty) } } ; No_tag { name = "Right" ; clause_kind = List_clause { args = Cons (_'b_sexp_grammar.untyped, Empty) } } ; No_tag { name = "Both" ; clause_kind = List_clause { args = Cons ( _'a_sexp_grammar.untyped , Cons (_'b_sexp_grammar.untyped, Empty) ) } } ] } } ;; [@@@end] end let merge_with_duplicates (Sequence { state = s1; next = next1 }) (Sequence { state = s2; next = next2 }) ~compare = let unshadowed_compare = compare in let open Merge_with_duplicates_element in let next = function | Skip { state = s1 }, s2 -> Skip { state = next1 s1, s2 } | s1, Skip { state = s2 } -> Skip { state = s1, next2 s2 } | (Yield { value = a; state = s1' } as s1), (Yield { value = b; state = s2' } as s2) -> let comparison = unshadowed_compare a b in if comparison < 0 then Yield { value = Left a; state = Skip { state = s1' }, s2 } else if comparison = 0 then Yield { value = Both (a, b); state = Skip { state = s1' }, Skip { state = s2' } } else Yield { value = Right b; state = s1, Skip { state = s2' } } | Done, Done -> Done | Yield { value = a; state = s1 }, Done -> Yield { value = Left a; state = Skip { state = s1 }, Done } | Done, Yield { value = b; state = s2 } -> Yield { value = Right b; state = Done, Skip { state = s2 } } in Sequence { state = Skip { state = s1 }, Skip { state = s2 }; next } ;; let merge_deduped_and_sorted s1 s2 ~compare = map (merge_with_duplicates s1 s2 ~compare) ~f:(function | Left x | Right x | Both (x, _) -> x) ;; let (merge [@deprecated "[since 2021-07] For identical behavior, use \ [Sequence.merge_deduped_and_sorted], but consider using \ [Sequence.merge_sorted] instead."]) = merge_deduped_and_sorted ;; let merge_sorted (Sequence { state = s1; next = next1 }) (Sequence { state = s2; next = next2 }) ~compare = let next = function | Skip { state = s1 }, s2 -> Skip { state = next1 s1, s2 } | s1, Skip { state = s2 } -> Skip { state = s1, next2 s2 } | (Yield { value = a; state = s1' } as s1), (Yield { value = b; state = s2' } as s2) -> let comparison = compare a b in if comparison <= 0 then Yield { value = a; state = Skip { state = s1' }, s2 } else Yield { value = b; state = s1, Skip { state = s2' } } | Done, Done -> Done | Yield { value = a; state = s1 }, Done -> Yield { value = a; state = Skip { state = s1 }, Done } | Done, Yield { value = b; state = s2 } -> Yield { value = b; state = Done, Skip { state = s2 } } in Sequence { state = Skip { state = s1 }, Skip { state = s2 }; next } ;; let hd s = let rec loop s next = match next s with | Done -> None | Skip { state = s } -> loop s next | Yield { value = a; state = _ } -> Some a in match s with | Sequence { state = s; next } -> loop s next ;; let hd_exn s = match hd s with | None -> failwith "hd_exn" | Some a -> a ;; let tl s = let rec loop s next = match next s with | Done -> None | Skip { state = s } -> loop s next | Yield { value = _; state = a } -> Some a in match s with | Sequence { state = s; next } -> (match loop s next with | None -> None | Some s -> Some (Sequence { state = s; next })) ;; let tl_eagerly_exn s = match tl s with | None -> failwith "Sequence.tl_exn" | Some s -> s ;; let lift_identity next s = match next s with | Done -> Done | Skip { state = s } -> Skip { state = `Identity s } | Yield { value = a; state = s } -> Yield { value = a; state = `Identity s } ;; let next s = let rec loop s next = match next s with | Done -> None | Skip { state = s } -> loop s next | Yield { value = a; state = s } -> Some (a, Sequence { state = s; next }) in match s with | Sequence { state = s; next } -> loop s next ;; let filter_opt s = match s with | Sequence { state = s; next } -> Sequence { state = s ; next = (fun s -> match next s with | Done -> Done | Skip { state = s } -> Skip { state = s } | Yield { value = None; state = s } -> Skip { state = s } | Yield { value = Some a; state = s } -> Yield { value = a; state = s }) } ;; let filter_map s ~f = filter_opt (map s ~f) let filter_mapi s ~f = filter_map (mapi s ~f:(fun i s -> i, s)) ~f:(fun (i, s) -> f i s) let split_n s n = let rec loop s i accum next = if i <= 0 then List.rev accum, Sequence { state = s; next } else ( match next s with | Done -> List.rev accum, empty | Skip { state = s } -> loop s i accum next | Yield { value = a; state = s } -> loop s (i - 1) (a :: accum) next) in match s with | Sequence { state = s; next } -> loop s n [] next ;; let chunks_exn t n = if n <= 0 then invalid_arg "Sequence.chunks_exn" else unfold_step ~init:t ~f:(fun t -> match split_n t n with | [], _empty -> Done | (_ :: _ as xs), t -> Yield { value = xs; state = t }) ;; let findi t ~f = let rec loop s next i f = match next s with | Done -> None | Yield { value = a; state = _ } when f i a -> Some (i, a) | Yield { value = _; state = s } | Skip { state = s } -> loop s next (i + 1) f in match t with | Sequence { state = seed; next } -> loop seed next 0 f ;; let find_exn s ~f = match find s ~f with | None -> failwith "Sequence.find_exn" | Some x -> x ;; let append s1 s2 = match s1, s2 with | Sequence { state = s1; next = next1 }, Sequence { state = s2; next = next2 } -> Sequence { state = `First_list s1 ; next = (function | `First_list s1 -> (match next1 s1 with | Done -> Skip { state = `Second_list s2 } | Skip { state = s1 } -> Skip { state = `First_list s1 } | Yield { value = a; state = s1 } -> Yield { value = a; state = `First_list s1 }) | `Second_list s2 -> (match next2 s2 with | Done -> Done | Skip { state = s2 } -> Skip { state = `Second_list s2 } | Yield { value = a; state = s2 } -> Yield { value = a; state = `Second_list s2 })) } ;; let concat_map s ~f = bind s ~f let concat s = concat_map s ~f:Fn.id let concat_mapi s ~f = concat_map (mapi s ~f:(fun i s -> i, s)) ~f:(fun (i, s) -> f i s) let zip (Sequence { state = s1; next = next1 }) (Sequence { state = s2; next = next2 }) = let next = function | Yield { value = a; state = s1 }, Yield { value = b; state = s2 } -> Yield { value = a, b; state = Skip { state = s1 }, Skip { state = s2 } } | Done, _ | _, Done -> Done | Skip { state = s1 }, s2 -> Skip { state = next1 s1, s2 } | s1, Skip { state = s2 } -> Skip { state = s1, next2 s2 } in Sequence { state = Skip { state = s1 }, Skip { state = s2 }; next } ;; let zip_full (Sequence { state = s1; next = next1 }) (Sequence { state = s2; next = next2 }) = let next = function | Yield { value = a; state = s1 }, Yield { value = b; state = s2 } -> Yield { value = `Both (a, b); state = Skip { state = s1 }, Skip { state = s2 } } | Done, Done -> Done | Skip { state = s1 }, s2 -> Skip { state = next1 s1, s2 } | s1, Skip { state = s2 } -> Skip { state = s1, next2 s2 } | Done, Yield { value = b; state = s2 } -> Yield { value = `Right b; state = Done, next2 s2 } | Yield { value = a; state = s1 }, Done -> Yield { value = `Left a; state = next1 s1, Done } in Sequence { state = Skip { state = s1 }, Skip { state = s2 }; next } ;; let bounded_length (Sequence { state = seed; next }) ~at_most = let rec loop i seed next = if i > at_most then `Greater else ( match next seed with | Done -> `Is i | Skip { state = seed } -> loop i seed next | Yield { value = _; state = seed } -> loop (i + 1) seed next) in loop 0 seed next ;; let length_is_bounded_by ?(min = -1) ?max t = let length_is_at_least (Sequence { state = s; next }) = let rec loop s acc = if acc >= min then true else ( match next s with | Done -> false | Skip { state = s } -> loop s acc | Yield { value = _; state = s } -> loop s (acc + 1)) in loop s 0 in match max with | None -> length_is_at_least t | Some max -> (match bounded_length t ~at_most:max with | `Is len when len >= min -> true | _ -> false) ;; let iteri s ~f = iter (mapi s ~f:(fun i s -> i, s)) ~f:(fun (i, s) -> f i s) [@nontail] let foldi s ~init ~f = fold ~init (mapi s ~f:(fun i s -> i, s)) ~f:(fun acc (i, s) -> f i acc s) [@nontail] ;; let reduce s ~f = match next s with | None -> None | Some (a, s) -> Some (fold s ~init:a ~f) ;; let reduce_exn s ~f = match reduce s ~f with | None -> failwith "Sequence.reduce_exn" | Some res -> res ;; let group (Sequence { state = s; next }) ~break = unfold_step ~init:(Some ([], s)) ~f:(function | None -> Done | Some (acc, s) -> (match acc, next s with | _, Skip { state = s } -> Skip { state = Some (acc, s) } | [], Done -> Done | acc, Done -> Yield { value = List.rev acc; state = None } | [], Yield { value = cur; state = s } -> Skip { state = Some ([ cur ], s) } | (prev :: _ as acc), Yield { value = cur; state = s } -> if break prev cur then Yield { value = List.rev acc; state = Some ([ cur ], s) } else Skip { state = Some (cur :: acc, s) })) ;; let find_consecutive_duplicate (Sequence { state = s; next }) ~equal = let rec loop last_elt s = match next s with | Done -> None | Skip { state = s } -> loop last_elt s | Yield { value = a; state = s } -> (match last_elt with | Some b when equal a b -> Some (b, a) | None | Some _ -> loop (Some a) s) in loop None s [@nontail] ;; let remove_consecutive_duplicates s ~equal = unfold_with s ~init:None ~f:(fun prev a -> match prev with | Some b when equal a b -> Skip { state = Some a } | None | Some _ -> Yield { value = a; state = Some a }) ;; let count s ~f = fold s ~init:0 ~f:(fun acc elt -> acc + Bool.to_int (f elt)) [@nontail] let counti t ~f = foldi t ~init:0 ~f:(fun i acc elt -> acc + Bool.to_int (f i elt)) [@nontail] ;; let sum m t ~f = Container.sum ~fold m t ~f let min_elt t ~compare = Container.min_elt ~fold t ~compare let max_elt t ~compare = Container.max_elt ~fold t ~compare let init n ~f = unfold_step ~init:0 ~f:(fun i -> if i >= n then Done else Yield { value = f i; state = i + 1 }) ;; let sub s ~pos ~len = if pos < 0 || len < 0 then failwith "Sequence.sub"; match s with | Sequence { state = s; next } -> Sequence { state = 0, s ; next = (fun (i, s) -> if i - pos >= len then Done else ( match next s with | Done -> Done | Skip { state = s } -> Skip { state = i, s } | Yield { value = a; state = s } when i >= pos -> Yield { value = a; state = i + 1, s } | Yield { value = _; state = s } -> Skip { state = i + 1, s })) } ;; let take s len = if len < 0 then failwith "Sequence.take"; match s with | Sequence { state = s; next } -> Sequence { state = 0, s ; next = (fun (i, s) -> if i >= len then Done else ( match next s with | Done -> Done | Skip { state = s } -> Skip { state = i, s } | Yield { value = a; state = s } -> Yield { value = a; state = i + 1, s })) } ;; let drop s len = if len < 0 then failwith "Sequence.drop"; match s with | Sequence { state = s; next } -> Sequence { state = 0, s ; next = (fun (i, s) -> match next s with | Done -> Done | Skip { state = s } -> Skip { state = i, s } | Yield { value = a; state = s } when i >= len -> Yield { value = a; state = i + 1, s } | Yield { value = _; state = s } -> Skip { state = i + 1, s }) } ;; let take_while s ~f = match s with | Sequence { state = s; next } -> Sequence { state = s ; next = (fun s -> match next s with | Done -> Done | Skip { state = s } -> Skip { state = s } | Yield { value = a; state = s } when f a -> Yield { value = a; state = s } | Yield { value = _; state = _ } -> Done) } ;; let drop_while s ~f = match s with | Sequence { state = s; next } -> Sequence { state = `Dropping s ; next = (function | `Dropping s -> (match next s with | Done -> Done | Skip { state = s } -> Skip { state = `Dropping s } | Yield { value = a; state = s } when f a -> Skip { state = `Dropping s } | Yield { value = a; state = s } -> Yield { value = a; state = `Identity s }) | `Identity s -> lift_identity next s) } ;; let shift_right s x = match s with | Sequence { state = seed; next } -> Sequence { state = `Consing (seed, x) ; next = (function | `Consing (seed, x) -> Yield { value = x; state = `Identity seed } | `Identity s -> lift_identity next s) } ;; let shift_right_with_list s l = append (of_list l) s let shift_left = drop module Infix = struct let ( @ ) = append end let intersperse s ~sep = match s with | Sequence { state = s; next } -> Sequence { state = `Init s ; next = (function | `Init s -> (match next s with | Done -> Done | Skip { state = s } -> Skip { state = `Init s } | Yield { value = a; state = s } -> Yield { value = a; state = `Running s }) | `Running s -> (match next s with | Done -> Done | Skip { state = s } -> Skip { state = `Running s } | Yield { value = a; state = s } -> Yield { value = sep; state = `Putting (a, s) }) | `Putting (a, s) -> Yield { value = a; state = `Running s }) } ;; let repeat x = unfold_step ~init:x ~f:(fun x -> Yield { value = x; state = x }) let cycle_list_exn xs = if List.is_empty xs then invalid_arg "Sequence.cycle_list_exn"; let s = of_list xs in concat_map ~f:(fun () -> s) (repeat ()) ;; let cartesian_product sa sb = concat_map sa ~f:(fun a -> zip (repeat a) sb) let singleton x = return x let delayed_fold s ~init ~f ~finish = Expert.delayed_fold_step s ~init ~finish ~f:(fun acc option ~k -> match option with | None -> k acc | Some a -> f acc a ~k) ;; let fold_m ~bind ~return t ~init ~f = Expert.delayed_fold_step t ~init ~f:(fun acc option ~k -> match option with | None -> bind (return acc) ~f:k | Some a -> bind (f acc a) ~f:k) ~finish:return ;; let iter_m ~bind ~return t ~f = Expert.delayed_fold_step t ~init:() ~f:(fun () option ~k -> match option with | None -> bind (return ()) ~f:k | Some a -> bind (f a) ~f:k) ~finish:return ;; let fold_until s ~init ~f ~finish = let rec loop s next f acc = match next s with | Done -> finish acc | Skip { state = s } -> loop s next f acc | Yield { value = a; state = s } -> (match (f acc a : ('a, 'b) Continue_or_stop.t) with | Stop x -> x | Continue acc -> loop s next f acc) in match s with | Sequence { state = s; next } -> loop s next f init [@nontail] ;; let fold_result s ~init ~f = let rec loop s next f acc = match next s with | Done -> Result.return acc | Skip { state = s } -> loop s next f acc | Yield { value = a; state = s } -> (match (f acc a : (_, _) Result.t) with | Error _ as e -> e | Ok acc -> loop s next f acc) in match s with | Sequence { state = s; next } -> loop s next f init ;; let force_eagerly t = of_list (to_list t) let memoize (type a) (Sequence { state = s; next }) = let module M = struct type t = T of (a, t) Step.t Lazy.t end in let rec memoize s = M.T (lazy (find_step s)) and find_step s = match next s with | Done -> Done | Skip { state = s } -> find_step s | Yield { value = a; state = s } -> Yield { value = a; state = memoize s } in Sequence { state = memoize s; next = (fun (M.T l) -> Lazy.force l) } ;; let drop_eagerly s len = let rec loop i ~len s next = if i >= len then Sequence { state = s; next } else ( match next s with | Done -> empty | Skip { state = s } -> loop i ~len s next | Yield { value = _; state = s } -> loop (i + 1) ~len s next) in match s with | Sequence { state = s; next } -> loop 0 ~len s next ;; let drop_while_option (Sequence { state = s; next }) ~f = let rec loop s = match next s with | Done -> None | Skip { state = s } -> loop s | Yield { value = x; state = s } -> if f x then loop s else Some (x, Sequence { state = s; next }) in loop s [@nontail] ;; let compare compare_a t1 t2 = With_return.with_return (fun r -> iter (zip_full t1 t2) ~f:(function | `Left _ -> r.return 1 | `Right _ -> r.return (-1) | `Both (v1, v2) -> let c = compare_a v1 v2 in if c <> 0 then r.return c); 0) ;; let equal equal_a t1 t2 = for_all (zip_full t1 t2) ~f:(function | `Both (a1, a2) -> equal_a a1 a2 | `Left _ | `Right _ -> false) ;; let round_robin list = let next (todo_stack, done_stack) = match todo_stack with | Sequence { state = s; next = f } :: todo_stack -> (match f s with | Yield { value = x; state = s } -> Yield { value = x ; state = todo_stack, Sequence { state = s; next = f } :: done_stack } | Skip { state = s } -> Skip { state = Sequence { state = s; next = f } :: todo_stack, done_stack } | Done -> Skip { state = todo_stack, done_stack }) | [] -> if List.is_empty done_stack then Done else Skip { state = List.rev done_stack, [] } in let state = list, [] in Sequence { state; next } ;; let interleave (Sequence { state = s1; next = f1 }) = let next (todo_stack, done_stack, s1) = match todo_stack with | Sequence { state = s2; next = f2 } :: todo_stack -> (match f2 s2 with | Yield { value = x; state = s2 } -> Yield { value = x ; state = todo_stack, Sequence { state = s2; next = f2 } :: done_stack, s1 } | Skip { state = s2 } -> Skip { state = todo_stack, Sequence { state = s2; next = f2 } :: done_stack, s1 } | Done -> Skip { state = todo_stack, done_stack, s1 }) | [] -> (match f1 s1, done_stack with | Yield { value = t; state = s1 }, _ -> Skip { state = List.rev (t :: done_stack), [], s1 } | Skip { state = s1 }, _ -> Skip { state = List.rev done_stack, [], s1 } | Done, _ :: _ -> Skip { state = List.rev done_stack, [], s1 } | Done, [] -> Done) in let state = [], [], s1 in Sequence { state; next } ;; let interleaved_cartesian_product s1 s2 = map s1 ~f:(fun x1 -> map s2 ~f:(fun x2 -> x1, x2)) |> interleave ;; let of_seq (seq : _ Stdlib.Seq.t) = unfold_step ~init:seq ~f:(fun seq -> match seq () with | Nil -> Done | Cons (hd, tl) -> Yield { value = hd; state = tl }) ;; let to_seq (Sequence { state; next }) = let rec loop state = match next state with | Done -> Stdlib.Seq.Nil | Skip { state } -> loop state | Yield { value = hd; state } -> Stdlib.Seq.Cons (hd, fun () -> loop state) in fun () -> loop state ;; module Generator = struct type 'elt steps = Wrap of ('elt, unit -> 'elt steps) Step.t let unwrap (Wrap step) = step module T = struct type ('a, 'elt) t = ('a -> 'elt steps) -> 'elt steps let return x k = k x let bind m ~f k = m (fun a -> let m' = f a in m' k) ;; let map m ~f k = m (fun a -> k (f a)) let map = `Custom map end include T include Monad.Make2 (T) let yield e k = Wrap (Yield { value = e; state = k }) let to_steps t = t (fun () -> Wrap Done) let of_sequence sequence = delayed_fold sequence ~init:() ~f:(fun () x ~k f -> Wrap (Yield { value = x; state = (fun () -> k () f) })) ~finish:return ;; let run t = let init () = to_steps t in let f thunk = unwrap (thunk ()) in unfold_step ~init ~f ;; end base-0.16.3/src/sequence.mli000066400000000000000000000506141446274340700156360ustar00rootroot00000000000000(** A sequence of elements that can be produced one at a time, on demand, normally with no sharing. The elements are computed on demand, possibly repeating work if they are demanded multiple times. A sequence can be built by unfolding from some initial state, which will in practice often be other containers. Most functions constructing a sequence will not immediately compute any elements of the sequence. These functions will always return in O(1), but traversing the resulting sequence may be more expensive. The most they will do immediately is generate a new internal state and a new step function. Functions that transform existing sequences sometimes have to reconstruct some suffix of the input sequence, even if it is unmodified. For example, calling [drop 1] will return a sequence with a slightly larger state and whose elements all cost slightly more to traverse. Because this is sometimes undesirable (for example, applying [drop 1] n times will cost O(n) per element traversed in the result), there are also more eager versions of many functions (whose names are suffixed with [_eagerly]) that do more work up front. A function has the [_eagerly] suffix iff it matches both of these conditions: - It might consume an element from an input [t] before returning. - It only returns a [t] (not paired with something else, not wrapped in an [option], etc.). If it returns anything other than a [t] and it has at least one [t] input, it's probably demanding elements from the input [t] anyway. Only [*_exn] functions can raise exceptions, except if the function underlying the sequence (the [f] passed to [unfold]) raises, in which case the exception will cascade. *) open! Import type +'a t [@@deriving_inline sexp_of] val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t [@@@end] type 'a sequence := 'a t include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t include Indexed_container.S1 with type 'a t := 'a t include Monad.S with type 'a t := 'a t (** [empty] is a sequence with no elements. *) val empty : _ t (** [next] returns the next element of a sequence and the next tail if the sequence is not finished. *) val next : 'a t -> ('a * 'a t) option (** A [Step] describes the next step of the sequence construction. [Done] indicates the sequence is finished. [Skip] indicates the sequence continues with another state without producing the next element yet. [Yield] outputs an element and introduces a new state. Modifying ['s] doesn't violate any {e internal} invariants, but it may violate some undocumented expectations. For example, one might expect that producing an element from the same point in the sequence would always give the same value, but if the state can mutate, that is not so. *) module Step : sig type ('a, 's) t = | Done | Skip of { state : 's } | Yield of { value : 'a ; state : 's } [@@deriving_inline sexp_of] val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> ('s -> Sexplib0.Sexp.t) -> ('a, 's) t -> Sexplib0.Sexp.t [@@@end] end (** [unfold_step ~init ~f] constructs a sequence by giving an initial state [init] and a function [f] explaining how to continue the next step from a given state. *) val unfold_step : init:'s -> f:('s -> ('a, 's) Step.t) -> 'a t (** [unfold ~init f] is a simplified version of [unfold_step] that does not allow [Skip]. *) val unfold : init:'s -> f:('s -> ('a * 's) option) -> 'a t (** [unfold_with t ~init ~f] folds a state through the sequence [t] to create a new sequence *) val unfold_with : 'a t -> init:'s -> f:('s -> 'a -> ('b, 's) Step.t) -> 'b t (** [unfold_with_and_finish t ~init ~running_step ~inner_finished ~finishing_step] folds a state through [t] to create a new sequence (like [unfold_with t ~init ~f:running_step]), and then continues the new sequence by unfolding the final state (like [unfold_step ~init:(inner_finished final_state) ~f:finishing_step]). *) val unfold_with_and_finish : 'a t -> init:'s_a -> running_step:('s_a -> 'a -> ('b, 's_a) Step.t) -> inner_finished:('s_a -> 's_b) -> finishing_step:('s_b -> ('b, 's_b) Step.t) -> 'b t (** Returns the nth element. *) val nth : 'a t -> int -> 'a option val nth_exn : 'a t -> int -> 'a (** [folding_map] is a version of [map] that threads an accumulator through calls to [f]. *) val folding_map : 'a t -> init:'acc -> f:('acc -> 'a -> 'acc * 'b) -> 'b t val folding_mapi : 'a t -> init:'acc -> f:(int -> 'acc -> 'a -> 'acc * 'b) -> 'b t val mapi : 'a t -> f:(int -> 'a -> 'b) -> 'b t val filteri : 'a t -> f:(int -> 'a -> bool) -> 'a t val filter : 'a t -> f:('a -> bool) -> 'a t (** If [t1] and [t2] are each sorted without duplicates, [merge_deduped_and_sorted t1 t2 ~compare] merges [t1] and [t2] into a sorted sequence without duplicates. Whenever identical elements are found in both [t1] and [t2], the one from [t1] is used and the one from [t2] is discarded. The behavior is undefined if the inputs aren't sorted or contain duplicates. *) val merge_deduped_and_sorted : 'a t -> 'a t -> compare:('a -> 'a -> int) -> 'a t val merge : 'a t -> 'a t -> compare:('a -> 'a -> int) -> 'a t [@@deprecated "[since 2021-07] For identical behavior, use [Sequence.merge_deduped_and_sorted], \ but consider using [Sequence.merge_sorted] instead."] (** If [t1] and [t2] are each sorted, [merge_sorted t1 t2 ~compare] merges [t1] and [t2] into a sorted sequence. Whenever identical elements are found in both [t1] and [t2], the one from [t1] is used first. The behavior is undefined if the inputs aren't sorted. *) val merge_sorted : 'a t -> 'a t -> compare:('a -> 'a -> int) -> 'a t module Merge_with_duplicates_element : sig type ('a, 'b) t = | Left of 'a | Right of 'b | Both of 'a * 'b [@@deriving_inline compare, hash, sexp, sexp_grammar] include Ppx_compare_lib.Comparable.S2 with type ('a, 'b) t := ('a, 'b) t include Ppx_hash_lib.Hashable.S2 with type ('a, 'b) t := ('a, 'b) t include Sexplib0.Sexpable.S2 with type ('a, 'b) t := ('a, 'b) t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'b Sexplib0.Sexp_grammar.t -> ('a, 'b) t Sexplib0.Sexp_grammar.t [@@@end] end (** [merge_with_duplicates_element t1 t2 ~compare] is like [merge], except that for each element it indicates which input(s) the element comes from, using [Merge_with_duplicates_element]. *) val merge_with_duplicates : 'a t -> 'b t -> compare:('a -> 'b -> int) -> ('a, 'b) Merge_with_duplicates_element.t t val hd : 'a t -> 'a option val hd_exn : 'a t -> 'a (** [tl t] and [tl_eagerly_exn t] immediately evaluates the first element of [t] and returns the unevaluated tail. *) val tl : 'a t -> 'a t option val tl_eagerly_exn : 'a t -> 'a t (** [find_exn t ~f] returns the first element of [t] that satisfies [f]. It raises if there is no such element. *) val find_exn : 'a t -> f:(('a -> bool)[@local]) -> 'a (** Like [for_all], but passes the index as an argument. *) val for_alli : 'a t -> f:((int -> 'a -> bool)[@local]) -> bool (** [append t1 t2] first produces the elements of [t1], then produces the elements of [t2]. *) val append : 'a t -> 'a t -> 'a t (** [concat tt] produces the elements of each inner sequence sequentially. If any inner sequences are infinite, elements of subsequent inner sequences will not be reached. *) val concat : 'a t t -> 'a t (** [concat_map t ~f] is [concat (map t ~f)].*) val concat_map : 'a t -> f:('a -> 'b t) -> 'b t (** [concat_mapi t ~f] is like concat_map, but passes the index as an argument. *) val concat_mapi : 'a t -> f:(int -> 'a -> 'b t) -> 'b t (** [interleave tt] produces each element of the inner sequences of [tt] eventually, even if any or all of the inner sequences are infinite. The elements of each inner sequence are produced in order with respect to that inner sequence. The manner of interleaving among the separate inner sequences is deterministic but unspecified. *) val interleave : 'a t t -> 'a t (** [round_robin list] is like [interleave (of_list list)], except that the manner of interleaving among the inner sequences is guaranteed to be round-robin. The input sequences may be of different lengths; an empty sequence is dropped from subsequent rounds of interleaving. *) val round_robin : 'a t list -> 'a t (** Transforms a pair of sequences into a sequence of pairs. The length of the returned sequence is the length of the shorter input. The remaining elements of the longer input are discarded. WARNING: Unlike [List.zip], this will not error out if the two input sequences are of different lengths, because [zip] may have already returned some elements by the time this becomes apparent. *) val zip : 'a t -> 'b t -> ('a * 'b) t (** [zip_full] is like [zip], but if one sequence ends before the other, then it keeps producing elements from the other sequence until it has ended as well. *) val zip_full : 'a t -> 'b t -> [ `Left of 'a | `Both of 'a * 'b | `Right of 'b ] t (** [reduce_exn f [a1; ...; an]] is [f (... (f (f a1 a2) a3) ...) an]. It fails on the empty sequence. *) val reduce_exn : 'a t -> f:(('a -> 'a -> 'a)[@local]) -> 'a val reduce : 'a t -> f:(('a -> 'a -> 'a)[@local]) -> 'a option (** [group l ~break] returns a sequence of lists (i.e., groups) whose concatenation is equal to the original sequence. Each group is broken where [break] returns true on a pair of successive elements. Example: {[ group ~break:(<>) (of_list ['M';'i';'s';'s';'i';'s';'s';'i';'p';'p';'i']) -> of_list [['M'];['i'];['s';'s'];['i'];['s';'s'];['i'];['p';'p'];['i']] ]} *) val group : 'a t -> break:('a -> 'a -> bool) -> 'a list t (** [find_consecutive_duplicate t ~equal] returns the first pair of consecutive elements [(a1, a2)] in [t] such that [equal a1 a2]. They are returned in the same order as they appear in [t]. *) val find_consecutive_duplicate : 'a t -> equal:(('a -> 'a -> bool)[@local]) -> ('a * 'a) option (** The same sequence with consecutive duplicates removed. The relative order of the other elements is unaffected. *) val remove_consecutive_duplicates : 'a t -> equal:('a -> 'a -> bool) -> 'a t (** [range ?stride ?start ?stop start_i stop_i] is the sequence of integers from [start_i] to [stop_i], stepping by [stride]. If [stride] < 0 then we need [start_i] > [stop_i] for the result to be nonempty (or [start_i] >= [stop_i] in the case where both bounds are inclusive). *) val range : ?stride:int (** default is [1] *) -> ?start:[ `inclusive | `exclusive ] (** default is [`inclusive] *) -> ?stop:[ `inclusive | `exclusive ] (** default is [`exclusive] *) -> int -> int -> int t (** [init n ~f] is [[(f 0); (f 1); ...; (f (n-1))]]. It is an error if [n < 0]. *) val init : int -> f:(int -> 'a) -> 'a t (** [filter_map t ~f] produce mapped elements of [t] which are not [None]. *) val filter_map : 'a t -> f:('a -> 'b option) -> 'b t (** [filter_mapi] is just like [filter_map], but it also passes in the index of each element to [f]. *) val filter_mapi : 'a t -> f:(int -> 'a -> 'b option) -> 'b t (** [filter_opt t] produces the elements of [t] which are not [None]. [filter_opt t] = [filter_map t ~f:Fn.id]. *) val filter_opt : 'a option t -> 'a t (** [sub t ~pos ~len] is the [len]-element subsequence of [t], starting at [pos]. If the sequence is shorter than [pos + len], it returns [ t[pos] ... t[l-1] ], where [l] is the length of the sequence. *) val sub : 'a t -> pos:int -> len:int -> 'a t (** [take t n] produces the first [n] elements of [t]. *) val take : 'a t -> int -> 'a t (** [drop t n] produces all elements of [t] except the first [n] elements. If there are fewer than [n] elements in [t], there is no error; the resulting sequence simply produces no elements. Usually you will probably want to use [drop_eagerly] because it can be significantly cheaper. *) val drop : 'a t -> int -> 'a t (** [drop_eagerly t n] immediately consumes the first [n] elements of [t] and returns the unevaluated tail of [t]. *) val drop_eagerly : 'a t -> int -> 'a t (** [take_while t ~f] produces the longest prefix of [t] for which [f] applied to each element is [true]. *) val take_while : 'a t -> f:('a -> bool) -> 'a t (** [drop_while t ~f] produces the suffix of [t] beginning with the first element of [t] for which [f] is [false]. Usually you will probably want to use [drop_while_option] because it can be significantly cheaper. *) val drop_while : 'a t -> f:('a -> bool) -> 'a t (** [drop_while_option t ~f] immediately consumes the elements from [t] until the predicate [f] fails and returns the first element that failed along with the unevaluated tail of [t]. The first element is returned separately because the alternatives would mean forcing the consumer to evaluate the first element again (if the previous state of the sequence is returned) or take on extra cost for each element (if the element is added to the final state of the sequence using [shift_right]). *) val drop_while_option : 'a t -> f:(('a -> bool)[@local]) -> ('a * 'a t) option (** [split_n t n] immediately consumes the first [n] elements of [t] and returns the consumed prefix, as a list, along with the unevaluated tail of [t]. *) val split_n : 'a t -> int -> 'a list * 'a t (** [chunks_exn t n] produces lists of elements of [t], up to [n] elements at a time. The last list may contain fewer than [n] elements. No list contains zero elements. If [n] is not positive, it raises. *) val chunks_exn : 'a t -> int -> 'a list t (** [shift_right t a] produces [a] and then produces each element of [t]. *) val shift_right : 'a t -> 'a -> 'a t (** [shift_right_with_list t l] produces the elements of [l], then produces the elements of [t]. It is better to call [shift_right_with_list] with a list of size n than [shift_right] n times; the former will require O(1) work per element produced and the latter O(n) work per element produced. *) val shift_right_with_list : 'a t -> 'a list -> 'a t (** [shift_left t n] is a synonym for [drop t n].*) val shift_left : 'a t -> int -> 'a t module Infix : sig val ( @ ) : 'a t -> 'a t -> 'a t end (** Returns a sequence with all possible pairs. The stepper function of the second sequence passed as argument may be applied to the same state multiple times, so be careful using [cartesian_product] with expensive or side-effecting functions. If the second sequence is infinite, some values in the first sequence may not be reached. *) val cartesian_product : 'a t -> 'b t -> ('a * 'b) t (** Returns a sequence that eventually reaches every possible pair of elements of the inputs, even if either or both are infinite. The step function of both inputs may be applied to the same state repeatedly, so be careful using [interleaved_cartesian_product] with expensive or side-effecting functions. *) val interleaved_cartesian_product : 'a t -> 'b t -> ('a * 'b) t (** [intersperse xs ~sep] produces [sep] between adjacent elements of [xs], e.g., [intersperse [1;2;3] ~sep:0 = [1;0;2;0;3]]. *) val intersperse : 'a t -> sep:'a -> 'a t (** [cycle_list_exn xs] repeats the elements of [xs] forever. If [xs] is empty, it raises. *) val cycle_list_exn : 'a list -> 'a t (** [repeat a] repeats [a] forever. *) val repeat : 'a -> 'a t (** [singleton a] produces [a] exactly once. *) val singleton : 'a -> 'a t (** [delayed_fold] allows to do an on-demand fold, while maintaining a state. It is possible to exit early by not calling [k] in [f]. It is also possible to call [k] multiple times. This results in the rest of the sequence being folded over multiple times, independently. Note that [delayed_fold], when targeting JavaScript, can result in stack overflow as JavaScript doesn't generally have tail call optimization. *) val delayed_fold : 'a t -> init:'s -> f:('s -> 'a -> k:('s -> 'r) -> 'r) (** [k] stands for "continuation" *) -> finish:('s -> 'r) -> 'r (** [fold_m] is a monad-friendly version of [fold]. Supply it with the monad's [return] and [bind], and it will chain them through the computation. *) val fold_m : bind:('acc_m -> f:('acc -> 'acc_m) -> 'acc_m) -> return:('acc -> 'acc_m) -> 'elt t -> init:'acc -> f:('acc -> 'elt -> 'acc_m) -> 'acc_m (** [iter_m] is a monad-friendly version of [iter]. Supply it with the monad's [return] and [bind], and it will chain them through the computation. *) val iter_m : bind:('unit_m -> f:(unit -> 'unit_m) -> 'unit_m) -> return:(unit -> 'unit_m) -> 'elt t -> f:('elt -> 'unit_m) -> 'unit_m (** [to_list_rev t] returns a list of the elements of [t], in reverse order. It is faster than [to_list]. *) val to_list_rev : 'a t -> 'a list val of_list : 'a list -> 'a t (** [of_lazy t_lazy] produces a sequence that forces [t_lazy] the first time it needs to compute an element. *) val of_lazy : 'a t Lazy.t -> 'a t (** [memoize t] produces each element of [t], but also memoizes them so that if you consume the same element multiple times it is only computed once. It's a non-eager version of [force_eagerly]. *) val memoize : 'a t -> 'a t (** [force_eagerly t] precomputes the sequence. It is behaviorally equivalent to [of_list (to_list t)], but may at some point have a more efficient implementation. It's an eager version of [memoize]. *) val force_eagerly : 'a t -> 'a t (** [bounded_length ~at_most t] returns [`Is len] if [len = length t <= at_most], and otherwise returns [`Greater]. Walks through only as much of the sequence as necessary. Always returns [`Greater] if [at_most < 0]. *) val bounded_length : _ t -> at_most:int -> [ `Is of int | `Greater ] (** [length_is_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. Walks through only as much of the sequence as necessary. *) val length_is_bounded_by : ?min:int -> ?max:int -> _ t -> bool val of_seq : 'a Stdlib.Seq.t -> 'a t val to_seq : 'a t -> 'a Stdlib.Seq.t (** [Generator] is a monadic interface to generate sequences in a direct style, similar to Python's generators. Here are some examples: {[ open Generator let rec traverse_list = function | [] -> return () | x :: xs -> yield x >>= fun () -> traverse_list xs let traverse_option = function | None -> return () | Some x -> yield x let traverse_array arr = let n = Array.length arr in let rec loop i = if i >= n then return () else yield arr.(i) >>= fun () -> loop (i + 1) in loop 0 let rec traverse_bst = function | Node.Empty -> return () | Node.Branch (left, value, right) -> traverse_bst left >>= fun () -> yield value >>= fun () -> traverse_bst right let sequence_of_list x = Generator.run (traverse_list x) let sequence_of_option x = Generator.run (traverse_option x) let sequence_of_array x = Generator.run (traverse_array x) let sequence_of_bst x = Generator.run (traverse_bst x) ]} *) module Generator : sig include Monad.S2 val yield : 'elt -> (unit, 'elt) t val of_sequence : 'elt sequence -> (unit, 'elt) t val run : (unit, 'elt) t -> 'elt sequence end (** The functions in [Expert] expose internal structure which is normally meant to be hidden. For example, at least when [f] is purely functional, it is not intended for client code to distinguish between {[ List.filter xs ~f |> Sequence.of_list ]} and {[ Sequence.of_list xs |> Sequence.filter ~f ]} But sometimes for operational reasons it still makes sense to distinguish them. For example, being able to handle [Skip]s explicitly allows breaking up some computationally expensive sequences into smaller chunks of work. *) module Expert : sig (** [next_step] returns the next step in a sequence's construction. It is like [next], but it also allows observing [Skip] steps. *) val next_step : 'a t -> ('a, 'a t) Step.t (** [delayed_fold_step] is liked [delayed_fold], but [f] takes an option where [None] represents a [Skip] step. *) val delayed_fold_step : 'a t -> init:'s -> f:('s -> 'a option -> k:('s -> 'r) -> 'r) (** [k] stands for "continuation" *) -> finish:('s -> 'r) -> 'r end base-0.16.3/src/set.ml000066400000000000000000001423071446274340700144510ustar00rootroot00000000000000(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Apache 2.0 license. See ../THIRD-PARTY.txt *) (* for details. *) (* *) (***********************************************************************) (* Sets over ordered types *) open! Import include Set_intf let with_return = With_return.with_return module Tree0 = struct type 'a t = | Empty (* (Leaf x) is the same as (Node (Empty, x, Empty, 1, 1)) but uses less space. *) | Leaf of 'a (* first int is height, second is sub-tree size *) | Node of 'a t * 'a * 'a t * int * int type 'a tree = 'a t (* Sets are represented by balanced binary trees (the heights of the children differ by at most 2. *) let height = function | Empty -> 0 | Leaf _ -> 1 | Node (_, _, _, h, _) -> h ;; let length = function | Empty -> 0 | Leaf _ -> 1 | Node (_, _, _, _, s) -> s ;; let invariants = let in_range lower upper compare_elt v = (match lower with | None -> true | Some lower -> compare_elt lower v < 0) && match upper with | None -> true | Some upper -> compare_elt v upper < 0 in let rec loop lower upper compare_elt t = match t with | Empty -> true | Leaf v -> in_range lower upper compare_elt v | Node (l, v, r, h, n) -> let hl = height l and hr = height r in abs (hl - hr) <= 2 && h = max hl hr + 1 && n = length l + length r + 1 && in_range lower upper compare_elt v && loop lower (Some v) compare_elt l && loop (Some v) upper compare_elt r in fun t ~compare_elt -> loop None None compare_elt t ;; let is_empty = function | Empty -> true | Leaf _ | Node _ -> false ;; (* Creates a new node with left son l, value v and right son r. We must have all elements of l < v < all elements of r. l and r must be balanced and | height l - height r | <= 2. Inline expansion of height for better speed. *) let create l v r = let hl = match l with | Empty -> 0 | Leaf _ -> 1 | Node (_, _, _, h, _) -> h in let hr = match r with | Empty -> 0 | Leaf _ -> 1 | Node (_, _, _, h, _) -> h in let h = if hl >= hr then hl + 1 else hr + 1 in if h = 1 then Leaf v else ( let sl = match l with | Empty -> 0 | Leaf _ -> 1 | Node (_, _, _, _, s) -> s in let sr = match r with | Empty -> 0 | Leaf _ -> 1 | Node (_, _, _, _, s) -> s in Node (l, v, r, h, sl + sr + 1)) ;; (* We must call [f] with increasing indexes, because the bin_prot reader in Core.Set needs it. *) let of_increasing_iterator_unchecked ~len ~f = let rec loop n ~f i = match n with | 0 -> Empty | 1 -> let k = f i in Leaf k | 2 -> let kl = f i in let k = f (i + 1) in create (Leaf kl) k Empty | 3 -> let kl = f i in let k = f (i + 1) in let kr = f (i + 2) in create (Leaf kl) k (Leaf kr) | n -> let left_length = n lsr 1 in let right_length = n - left_length - 1 in let left = loop left_length ~f i in let k = f (i + left_length) in let right = loop right_length ~f (i + left_length + 1) in create left k right in loop len ~f 0 ;; let of_sorted_array_unchecked array ~compare_elt = let array_length = Array.length array in let next = (* We don't check if the array is sorted or keys are duplicated, because that checking is slower than the whole [of_sorted_array] function *) if array_length < 2 || compare_elt array.(0) array.(1) < 0 then fun i -> array.(i) else fun i -> array.(array_length - 1 - i) in of_increasing_iterator_unchecked ~len:array_length ~f:next ;; let of_sorted_array array ~compare_elt = match array with | [||] | [| _ |] -> Result.Ok (of_sorted_array_unchecked array ~compare_elt) | _ -> with_return (fun r -> let increasing = match compare_elt array.(0) array.(1) with | 0 -> r.return (Or_error.error_string "of_sorted_array: duplicated elements") | i -> i < 0 in for i = 1 to Array.length array - 2 do match compare_elt array.(i) array.(i + 1) with | 0 -> r.return (Or_error.error_string "of_sorted_array: duplicated elements") | i -> if Poly.( <> ) (i < 0) increasing then r.return (Or_error.error_string "of_sorted_array: elements are not ordered") done; Result.Ok (of_sorted_array_unchecked array ~compare_elt)) ;; (* Same as create, but performs one step of rebalancing if necessary. Assumes l and r balanced and | height l - height r | <= 3. Inline expansion of create for better speed in the most frequent case where no rebalancing is required. *) let bal l v r = let hl = match l with | Empty -> 0 | Leaf _ -> 1 | Node (_, _, _, h, _) -> h in let hr = match r with | Empty -> 0 | Leaf _ -> 1 | Node (_, _, _, h, _) -> h in if hl > hr + 2 then ( match l with | Empty -> assert false | Leaf _ -> assert false (* because h(l)>h(r)+2 and h(leaf)=1 *) | Node (ll, lv, lr, _, _) -> if height ll >= height lr then create ll lv (create lr v r) else ( match lr with | Empty -> assert false | Leaf lrv -> assert (is_empty ll); create (create ll lv Empty) lrv (create Empty v r) | Node (lrl, lrv, lrr, _, _) -> create (create ll lv lrl) lrv (create lrr v r))) else if hr > hl + 2 then ( match r with | Empty -> assert false | Leaf _ -> assert false (* because h(r)>h(l)+2 and h(leaf)=1 *) | Node (rl, rv, rr, _, _) -> if height rr >= height rl then create (create l v rl) rv rr else ( match rl with | Empty -> assert false | Leaf rlv -> assert (is_empty rr); create (create l v Empty) rlv (create Empty rv rr) | Node (rll, rlv, rlr, _, _) -> create (create l v rll) rlv (create rlr rv rr))) else ( let h = if hl >= hr then hl + 1 else hr + 1 in let sl = match l with | Empty -> 0 | Leaf _ -> 1 | Node (_, _, _, _, s) -> s in let sr = match r with | Empty -> 0 | Leaf _ -> 1 | Node (_, _, _, _, s) -> s in if h = 1 then Leaf v else Node (l, v, r, h, sl + sr + 1)) ;; (* Insertion of one element *) exception Same let add t x ~compare_elt = let rec aux = function | Empty -> Leaf x | Leaf v -> let c = compare_elt x v in if c = 0 then Exn.raise_without_backtrace Same else if c < 0 then create (Leaf x) v Empty else create Empty v (Leaf x) | Node (l, v, r, _, _) -> let c = compare_elt x v in if c = 0 then Exn.raise_without_backtrace Same else if c < 0 then bal (aux l) v r else bal l v (aux r) in try aux t with | Same -> t ;; (* specialization of [add] that assumes that [x] is less than all existing elements *) let rec add_min x t = match t with | Empty -> Leaf x | Leaf _ -> Node (Empty, x, t, 2, 2) | Node (l, v, r, _, _) -> bal (add_min x l) v r ;; (* specialization of [add] that assumes that [x] is greater than all existing elements *) let rec add_max t x = match t with | Empty -> Leaf x | Leaf _ -> Node (t, x, Empty, 2, 2) | Node (l, v, r, _, _) -> bal l v (add_max r x) ;; (* Same as create and bal, but no assumptions are made on the relative heights of l and r. *) let rec join l v r = match l, r with | Empty, _ -> add_min v r | _, Empty -> add_max l v | Leaf lv, _ -> add_min lv (add_min v r) | _, Leaf rv -> add_max (add_max l v) rv | Node (ll, lv, lr, lh, _), Node (rl, rv, rr, rh, _) -> if lh > rh + 2 then bal ll lv (join lr v r) else if rh > lh + 2 then bal (join l v rl) rv rr else create l v r ;; (* Smallest and greatest element of a set *) let rec min_elt = function | Empty -> None | Leaf v | Node (Empty, v, _, _, _) -> Some v | Node (l, _, _, _, _) -> min_elt l ;; exception Set_min_elt_exn_of_empty_set [@@deriving_inline sexp] let () = Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Set_min_elt_exn_of_empty_set] (function | Set_min_elt_exn_of_empty_set -> Sexplib0.Sexp.Atom "set.ml.Tree0.Set_min_elt_exn_of_empty_set" | _ -> assert false) ;; [@@@end] exception Set_max_elt_exn_of_empty_set [@@deriving_inline sexp] let () = Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Set_max_elt_exn_of_empty_set] (function | Set_max_elt_exn_of_empty_set -> Sexplib0.Sexp.Atom "set.ml.Tree0.Set_max_elt_exn_of_empty_set" | _ -> assert false) ;; [@@@end] let min_elt_exn t = match min_elt t with | None -> raise Set_min_elt_exn_of_empty_set | Some v -> v ;; let fold_until t ~init ~f ~finish = let rec fold_until_helper ~f t acc = match t with | Empty -> Container.Continue_or_stop.Continue acc | Leaf value -> f acc value [@nontail] | Node (left, value, right, _, _) -> (match fold_until_helper ~f left acc with | Stop _a as x -> x | Continue acc -> (match f acc value with | Stop _a as x -> x | Continue a -> fold_until_helper ~f right a)) in match fold_until_helper ~f t init with | Continue x -> finish x [@nontail] | Stop x -> x ;; let rec max_elt = function | Empty -> None | Leaf v | Node (_, v, Empty, _, _) -> Some v | Node (_, _, r, _, _) -> max_elt r ;; let max_elt_exn t = match max_elt t with | None -> raise Set_max_elt_exn_of_empty_set | Some v -> v ;; (* Remove the smallest element of the given set *) let rec remove_min_elt = function | Empty -> invalid_arg "Set.remove_min_elt" | Leaf _ -> Empty | Node (Empty, _, r, _, _) -> r | Node (l, v, r, _, _) -> bal (remove_min_elt l) v r ;; (* Merge two trees l and r into one. All elements of l must precede the elements of r. Assume | height l - height r | <= 2. *) let merge t1 t2 = match t1, t2 with | Empty, t -> t | t, Empty -> t | _, _ -> bal t1 (min_elt_exn t2) (remove_min_elt t2) ;; (* Merge two trees l and r into one. All elements of l must precede the elements of r. No assumption on the heights of l and r. *) let concat t1 t2 = match t1, t2 with | Empty, t | t, Empty -> t | _, _ -> join t1 (min_elt_exn t2) (remove_min_elt t2) ;; let split t x ~compare_elt = let rec split t = match t with | Empty -> Empty, None, Empty | Leaf v -> let c = compare_elt x v in if c = 0 then Empty, Some v, Empty else if c < 0 then Empty, None, Leaf v else Leaf v, None, Empty | Node (l, v, r, _, _) -> let c = compare_elt x v in if c = 0 then l, Some v, r else if c < 0 then ( let ll, maybe_elt, rl = split l in ll, maybe_elt, join rl v r) else ( let lr, maybe_elt, rr = split r in join l v lr, maybe_elt, rr) in split t ;; let rec split_le_gt t x ~compare_elt = match t with | Empty -> Empty, Empty | Leaf v -> if compare_elt x v >= 0 then Leaf v, Empty else Empty, Leaf v | Node (l, v, r, _, _) -> let c = compare_elt x v in if c = 0 then add_max l v, r else if c < 0 then ( let ll, rl = split_le_gt l x ~compare_elt in ll, join rl v r) else ( let lr, rr = split_le_gt r x ~compare_elt in join l v lr, rr) ;; let rec split_lt_ge t x ~compare_elt = match t with | Empty -> Empty, Empty | Leaf v -> if compare_elt x v > 0 then Leaf v, Empty else Empty, Leaf v | Node (l, v, r, _, _) -> let c = compare_elt x v in if c = 0 then l, add_min v r else if c < 0 then ( let ll, rl = split_lt_ge l x ~compare_elt in ll, join rl v r) else ( let lr, rr = split_lt_ge r x ~compare_elt in join l v lr, rr) ;; (* Implementation of the set operations *) let empty = Empty let rec mem t x ~compare_elt = match t with | Empty -> false | Leaf v -> let c = compare_elt x v in c = 0 | Node (l, v, r, _, _) -> let c = compare_elt x v in c = 0 || mem (if c < 0 then l else r) x ~compare_elt ;; let singleton x = Leaf x let remove t x ~compare_elt = let rec aux t = match t with | Empty -> Exn.raise_without_backtrace Same | Leaf v -> if compare_elt x v = 0 then Empty else Exn.raise_without_backtrace Same | Node (l, v, r, _, _) -> let c = compare_elt x v in if c = 0 then merge l r else if c < 0 then bal (aux l) v r else bal l v (aux r) in try aux t with | Same -> t ;; let remove_index t i ~compare_elt:_ = let rec aux t i = match t with | Empty -> Exn.raise_without_backtrace Same | Leaf _ -> if i = 0 then Empty else Exn.raise_without_backtrace Same | Node (l, v, r, _, _) -> let l_size = length l in let c = Poly.compare i l_size in if c = 0 then merge l r else if c < 0 then bal (aux l i) v r else bal l v (aux r (i - l_size - 1)) in try aux t i with | Same -> t ;; let union s1 s2 ~compare_elt = let rec union s1 s2 = if phys_equal s1 s2 then s1 else ( match s1, s2 with | Empty, t | t, Empty -> t | Leaf v1, _ -> union (Node (Empty, v1, Empty, 1, 1)) s2 | _, Leaf v2 -> union s1 (Node (Empty, v2, Empty, 1, 1)) | Node (l1, v1, r1, h1, _), Node (l2, v2, r2, h2, _) -> if h1 >= h2 then if h2 = 1 then add s1 v2 ~compare_elt else ( let l2, _, r2 = split s2 v1 ~compare_elt in join (union l1 l2) v1 (union r1 r2)) else if h1 = 1 then add s2 v1 ~compare_elt else ( let l1, _, r1 = split s1 v2 ~compare_elt in join (union l1 l2) v2 (union r1 r2))) in union s1 s2 ;; let union_list ~comparator ~to_tree xs = let compare_elt = comparator.Comparator.compare in List.fold xs ~init:empty ~f:(fun ac x -> union ac (to_tree x) ~compare_elt) ;; let inter s1 s2 ~compare_elt = let rec inter s1 s2 = if phys_equal s1 s2 then s1 else ( match s1, s2 with | Empty, _ | _, Empty -> Empty | (Leaf elt as singleton), other_set | other_set, (Leaf elt as singleton) -> if mem other_set elt ~compare_elt then singleton else Empty | Node (l1, v1, r1, _, _), t2 -> (match split t2 v1 ~compare_elt with | l2, None, r2 -> concat (inter l1 l2) (inter r1 r2) | l2, Some v1, r2 -> join (inter l1 l2) v1 (inter r1 r2))) in inter s1 s2 ;; let diff s1 s2 ~compare_elt = let rec diff s1 s2 = if phys_equal s1 s2 then Empty else ( match s1, s2 with | Empty, _ -> Empty | t1, Empty -> t1 | Leaf v1, t2 -> diff (Node (Empty, v1, Empty, 1, 1)) t2 | Node (l1, v1, r1, _, _), t2 -> (match split t2 v1 ~compare_elt with | l2, None, r2 -> join (diff l1 l2) v1 (diff r1 r2) | l2, Some _, r2 -> concat (diff l1 l2) (diff r1 r2))) in diff s1 s2 ;; module Enum = struct type increasing type decreasing type ('a, 'direction) t = | End | More of 'a * 'a tree * ('a, 'direction) t let rec cons s (e : (_, increasing) t) : (_, increasing) t = match s with | Empty -> e | Leaf v -> More (v, Empty, e) | Node (l, v, r, _, _) -> cons l (More (v, r, e)) ;; let rec cons_right s (e : (_, decreasing) t) : (_, decreasing) t = match s with | Empty -> e | Leaf v -> More (v, Empty, e) | Node (l, v, r, _, _) -> cons_right r (More (v, l, e)) ;; let of_set s : (_, increasing) t = cons s End let of_set_right s : (_, decreasing) t = cons_right s End let starting_at_increasing t key compare : (_, increasing) t = let rec loop t e = match t with | Empty -> e | Leaf v -> loop (Node (Empty, v, Empty, 1, 1)) e | Node (_, v, r, _, _) when compare v key < 0 -> loop r e | Node (l, v, r, _, _) -> loop l (More (v, r, e)) in loop t End ;; let starting_at_decreasing t key compare : (_, decreasing) t = let rec loop t e = match t with | Empty -> e | Leaf v -> loop (Node (Empty, v, Empty, 1, 1)) e | Node (l, v, _, _, _) when compare v key > 0 -> loop l e | Node (l, v, r, _, _) -> loop r (More (v, l, e)) in loop t End ;; let compare compare_elt e1 e2 = let rec loop e1 e2 = match e1, e2 with | End, End -> 0 | End, _ -> -1 | _, End -> 1 | More (v1, r1, e1), More (v2, r2, e2) -> let c = compare_elt v1 v2 in if c <> 0 then c else if phys_equal r1 r2 then loop e1 e2 else loop (cons r1 e1) (cons r2 e2) in loop e1 e2 ;; let rec iter ~f = function | End -> () | More (a, tree, enum) -> f a; iter (cons tree enum) ~f ;; let iter2 compare_elt t1 t2 ~f = let rec loop t1 t2 = match t1, t2 with | End, End -> () | End, _ -> iter t2 ~f:(fun a -> f (`Right a)) [@nontail] | _, End -> iter t1 ~f:(fun a -> f (`Left a)) [@nontail] | More (a1, tree1, enum1), More (a2, tree2, enum2) -> let compare_result = compare_elt a1 a2 in if compare_result = 0 then ( f (`Both (a1, a2)); loop (cons tree1 enum1) (cons tree2 enum2)) else if compare_result < 0 then ( f (`Left a1); loop (cons tree1 enum1) t2) else ( f (`Right a2); loop t1 (cons tree2 enum2)) in loop t1 t2 [@nontail] ;; let symmetric_diff t1 t2 ~compare_elt = let step state : ((_, _) Either.t, _) Sequence.Step.t = match state with | End, End -> Done | End, More (elt, tree, enum) -> Yield { value = Second elt; state = End, cons tree enum } | More (elt, tree, enum), End -> Yield { value = First elt; state = cons tree enum, End } | (More (a1, tree1, enum1) as left), (More (a2, tree2, enum2) as right) -> let compare_result = compare_elt a1 a2 in if compare_result = 0 then ( let next_state = if phys_equal tree1 tree2 then enum1, enum2 else cons tree1 enum1, cons tree2 enum2 in Skip { state = next_state }) else if compare_result < 0 then Yield { value = First a1; state = cons tree1 enum1, right } else Yield { value = Second a2; state = left, cons tree2 enum2 } in Sequence.unfold_step ~init:(of_set t1, of_set t2) ~f:step ;; end let to_sequence_increasing comparator ~from_elt t = let next enum = match enum with | Enum.End -> Sequence.Step.Done | Enum.More (k, t, e) -> Sequence.Step.Yield { value = k; state = Enum.cons t e } in let init = match from_elt with | None -> Enum.of_set t | Some key -> Enum.starting_at_increasing t key comparator.Comparator.compare in Sequence.unfold_step ~init ~f:next ;; let to_sequence_decreasing comparator ~from_elt t = let next enum = match enum with | Enum.End -> Sequence.Step.Done | Enum.More (k, t, e) -> Sequence.Step.Yield { value = k; state = Enum.cons_right t e } in let init = match from_elt with | None -> Enum.of_set_right t | Some key -> Enum.starting_at_decreasing t key comparator.Comparator.compare in Sequence.unfold_step ~init ~f:next ;; let to_sequence comparator ?(order = `Increasing) ?greater_or_equal_to ?less_or_equal_to t = let inclusive_bound side t bound = let compare_elt = comparator.Comparator.compare in let l, maybe, r = split t bound ~compare_elt in let t = side (l, r) in match maybe with | None -> t | Some elt -> add t elt ~compare_elt in match order with | `Increasing -> let t = Option.fold less_or_equal_to ~init:t ~f:(inclusive_bound fst) in to_sequence_increasing comparator ~from_elt:greater_or_equal_to t | `Decreasing -> let t = Option.fold greater_or_equal_to ~init:t ~f:(inclusive_bound snd) in to_sequence_decreasing comparator ~from_elt:less_or_equal_to t ;; let rec find_first_satisfying t ~f = match t with | Empty -> None | Leaf v -> if f v then Some v else None | Node (l, v, r, _, _) -> if f v then ( match find_first_satisfying l ~f with | None -> Some v | Some _ as x -> x) else find_first_satisfying r ~f ;; let rec find_last_satisfying t ~f = match t with | Empty -> None | Leaf v -> if f v then Some v else None | Node (l, v, r, _, _) -> if f v then ( match find_last_satisfying r ~f with | None -> Some v | Some _ as x -> x) else find_last_satisfying l ~f ;; let binary_search t ~compare how v = match how with | `Last_strictly_less_than -> find_last_satisfying t ~f:(fun x -> compare x v < 0) [@nontail] | `Last_less_than_or_equal_to -> find_last_satisfying t ~f:(fun x -> compare x v <= 0) [@nontail] | `First_equal_to -> (match find_first_satisfying t ~f:(fun x -> compare x v >= 0) with | Some x as elt when compare x v = 0 -> elt | None | Some _ -> None) | `Last_equal_to -> (match find_last_satisfying t ~f:(fun x -> compare x v <= 0) with | Some x as elt when compare x v = 0 -> elt | None | Some _ -> None) | `First_greater_than_or_equal_to -> find_first_satisfying t ~f:(fun x -> compare x v >= 0) [@nontail] | `First_strictly_greater_than -> find_first_satisfying t ~f:(fun x -> compare x v > 0) [@nontail] ;; let binary_search_segmented t ~segment_of how = let is_left x = match segment_of x with | `Left -> true | `Right -> false in let is_right x = not (is_left x) in match how with | `Last_on_left -> find_last_satisfying t ~f:is_left [@nontail] | `First_on_right -> find_first_satisfying t ~f:is_right [@nontail] ;; let merge_to_sequence comparator ?(order = `Increasing) ?greater_or_equal_to ?less_or_equal_to t t' = Sequence.merge_with_duplicates (to_sequence comparator ~order ?greater_or_equal_to ?less_or_equal_to t) (to_sequence comparator ~order ?greater_or_equal_to ?less_or_equal_to t') ~compare: (match order with | `Increasing -> comparator.compare | `Decreasing -> Fn.flip comparator.compare) ;; let compare compare_elt s1 s2 = Enum.compare compare_elt (Enum.of_set s1) (Enum.of_set s2) ;; let iter2 s1 s2 ~compare_elt ~f = Enum.iter2 compare_elt (Enum.of_set s1) (Enum.of_set s2) ~f ;; let equal s1 s2 ~compare_elt = compare compare_elt s1 s2 = 0 let is_subset s1 ~of_:s2 ~compare_elt = let rec is_subset s1 ~of_:s2 = match s1, s2 with | Empty, _ -> true | _, Empty -> false | Leaf v1, t2 -> mem t2 v1 ~compare_elt | Node (l1, v1, r1, _, _), Leaf v2 -> (match l1, r1 with | Empty, Empty -> (* This case shouldn't occur in practice because we should have constructed a Leaf rather than a Node with two Empty subtrees *) compare_elt v1 v2 = 0 | _, _ -> false) | Node (l1, v1, r1, _, _), (Node (l2, v2, r2, _, _) as t2) -> let c = compare_elt v1 v2 in if c = 0 then phys_equal s1 s2 || (is_subset l1 ~of_:l2 && is_subset r1 ~of_:r2) (* Note that height and size don't matter here. *) else if c < 0 then is_subset (Node (l1, v1, Empty, 0, 0)) ~of_:l2 && is_subset r1 ~of_:t2 else is_subset (Node (Empty, v1, r1, 0, 0)) ~of_:r2 && is_subset l1 ~of_:t2 in is_subset s1 ~of_:s2 ;; let rec are_disjoint s1 s2 ~compare_elt = match s1, s2 with | Empty, _ | _, Empty -> true | Leaf elt, other_set | other_set, Leaf elt -> not (mem other_set elt ~compare_elt) | Node (l1, v1, r1, _, _), t2 -> if phys_equal s1 s2 then false else ( match split t2 v1 ~compare_elt with | l2, None, r2 -> are_disjoint l1 l2 ~compare_elt && are_disjoint r1 r2 ~compare_elt | _, Some _, _ -> false) ;; let iter t ~f = let rec iter = function | Empty -> () | Leaf v -> f v | Node (l, v, r, _, _) -> iter l; f v; iter r in iter t [@nontail] ;; let symmetric_diff = Enum.symmetric_diff let rec fold s ~init:accu ~f = match s with | Empty -> accu | Leaf v -> f accu v | Node (l, v, r, _, _) -> fold ~f r ~init:(f (fold ~f l ~init:accu) v) ;; let hash_fold_t_ignoring_structure hash_fold_elem state t = fold t ~init:(hash_fold_int state (length t)) ~f:hash_fold_elem ;; let count t ~f = Container.count ~fold t ~f let sum m t ~f = Container.sum ~fold m t ~f let rec fold_right s ~init:accu ~f = match s with | Empty -> accu | Leaf v -> f v accu | Node (l, v, r, _, _) -> fold_right ~f l ~init:(f v (fold_right ~f r ~init:accu)) ;; let rec for_all t ~f:p = match t with | Empty -> true | Leaf v -> p v | Node (l, v, r, _, _) -> p v && for_all ~f:p l && for_all ~f:p r ;; let rec exists t ~f:p = match t with | Empty -> false | Leaf v -> p v | Node (l, v, r, _, _) -> p v || exists ~f:p l || exists ~f:p r ;; let filter s ~f:p = let rec filt = function | Empty -> Empty | Leaf v as t -> if p v then t else Empty | Node (l, v, r, _, _) as t -> let l' = filt l in let keep_v = p v in let r' = filt r in if keep_v && phys_equal l l' && phys_equal r r' then t else if keep_v then join l' v r' else concat l' r' in filt s [@nontail] ;; let filter_map s ~f:p ~compare_elt = let rec filt accu = function | Empty -> accu | Leaf v -> (match p v with | None -> accu | Some v -> add accu v ~compare_elt) | Node (l, v, r, _, _) -> filt (filt (match p v with | None -> accu | Some v -> add accu v ~compare_elt) l) r in filt Empty s [@nontail] ;; let partition_tf s ~f:p = let rec loop = function | Empty -> Empty, Empty | Leaf v as t -> if p v then t, Empty else Empty, t | Node (l, v, r, _, _) as t -> let l't, l'f = loop l in let keep_v_t = p v in let r't, r'f = loop r in let mk keep_v l' r' = if keep_v && phys_equal l l' && phys_equal r r' then t else if keep_v then join l' v r' else concat l' r' in mk keep_v_t l't r't, mk (not keep_v_t) l'f r'f in loop s [@nontail] ;; let rec elements_aux accu = function | Empty -> accu | Leaf v -> v :: accu | Node (l, v, r, _, _) -> elements_aux (v :: elements_aux accu r) l ;; let elements s = elements_aux [] s let choose t = match t with | Empty -> None | Leaf v -> Some v | Node (_, v, _, _, _) -> Some v ;; let choose_exn = let not_found = Not_found_s (Atom "Set.choose_exn: empty set") in let choose_exn t = match choose t with | None -> raise not_found | Some v -> v in (* named to preserve symbol in compiled binary *) choose_exn ;; let of_list lst ~compare_elt = List.fold lst ~init:empty ~f:(fun t x -> add t x ~compare_elt) ;; let of_sequence sequence ~compare_elt = Sequence.fold sequence ~init:empty ~f:(fun t x -> add t x ~compare_elt) ;; let to_list s = elements s let of_array a ~compare_elt = Array.fold a ~init:empty ~f:(fun t x -> add t x ~compare_elt) ;; (* faster but equivalent to [Array.of_list (to_list t)] *) let to_array = function | Empty -> [||] | Leaf v -> [| v |] | Node (l, v, r, _, s) -> let res = Array.create ~len:s v in let pos_ref = ref 0 in let rec loop = function (* Invariant: on entry and on exit to [loop], !pos_ref is the next available cell in the array. *) | Empty -> () | Leaf v -> res.(!pos_ref) <- v; incr pos_ref | Node (l, v, r, _, _) -> loop l; res.(!pos_ref) <- v; incr pos_ref; loop r in loop l; (* res.(!pos_ref) is already initialized (by Array.create ~len:above). *) incr pos_ref; loop r; res ;; let map t ~f ~compare_elt = fold t ~init:empty ~f:(fun t x -> add t (f x) ~compare_elt) [@nontail] ;; let group_by set ~equiv = let rec loop set equiv_classes = if is_empty set then equiv_classes else ( let x = choose_exn set in let equiv_x, not_equiv_x = partition_tf set ~f:(fun elt -> phys_equal x elt || equiv x elt) in loop not_equiv_x (equiv_x :: equiv_classes)) in loop set [] [@nontail] ;; let rec find t ~f = match t with | Empty -> None | Leaf v -> if f v then Some v else None | Node (l, v, r, _, _) -> if f v then Some v else ( match find l ~f with | None -> find r ~f | Some _ as r -> r) ;; let rec find_map t ~f = match t with | Empty -> None | Leaf v -> f v | Node (l, v, r, _, _) -> (match f v with | Some _ as r -> r | None -> (match find_map l ~f with | None -> find_map r ~f | Some _ as r -> r)) ;; let find_exn t ~f = match find t ~f with | None -> failwith "Set.find_exn failed to find a matching element" | Some e -> e ;; let rec nth t i = match t with | Empty -> None | Leaf v -> if i = 0 then Some v else None | Node (l, v, r, _, s) -> if i >= s then None else ( let l_size = length l in let c = Poly.compare i l_size in if c < 0 then nth l i else if c = 0 then Some v else nth r (i - l_size - 1)) ;; let stable_dedup_list xs ~compare_elt = let rec loop xs leftovers already_seen = match xs with | [] -> List.rev leftovers | hd :: tl -> if mem already_seen hd ~compare_elt then loop tl leftovers already_seen else loop tl (hd :: leftovers) (add already_seen hd ~compare_elt) in loop xs [] empty ;; let t_of_sexp_direct a_of_sexp sexp ~compare_elt = match sexp with | Sexp.List lst -> let elt_lst = List.map lst ~f:a_of_sexp in let set = of_list elt_lst ~compare_elt in if length set = List.length lst then set else ( let set = ref empty in List.iter2_exn lst elt_lst ~f:(fun el_sexp el -> if mem !set el ~compare_elt then of_sexp_error "Set.t_of_sexp: duplicate element in set" el_sexp else set := add !set el ~compare_elt); assert false) | sexp -> of_sexp_error "Set.t_of_sexp: list needed" sexp ;; let sexp_of_t sexp_of_a t = Sexp.List (fold_right t ~init:[] ~f:(fun el acc -> sexp_of_a el :: acc)) ;; module Named = struct let is_subset (subset : _ Named.t) ~of_:(superset : _ Named.t) ~sexp_of_elt ~compare_elt = let invalid_elements = diff subset.set superset.set ~compare_elt in if is_empty invalid_elements then Ok () else ( let invalid_elements_sexp = sexp_of_t sexp_of_elt invalid_elements in Or_error.error_s (Sexp.message (subset.name ^ " is not a subset of " ^ superset.name) [ "invalid_elements", invalid_elements_sexp ])) ;; let equal s1 s2 ~sexp_of_elt ~compare_elt = Or_error.combine_errors_unit [ is_subset s1 ~of_:s2 ~sexp_of_elt ~compare_elt ; is_subset s2 ~of_:s1 ~sexp_of_elt ~compare_elt ] ;; end end type ('a, 'comparator) t = { (* [comparator] is the first field so that polymorphic equality fails on a map due to the functional value in the comparator. Note that this does not affect polymorphic [compare]: that still produces nonsense. *) comparator : ('a, 'comparator) Comparator.t ; tree : 'a Tree0.t } type ('a, 'comparator) tree = 'a Tree0.t let like { tree = _; comparator } tree = { tree; comparator } let like_maybe_no_op ({ tree = old_tree; comparator } as old_t) tree = if phys_equal old_tree tree then old_t else { tree; comparator } ;; let compare_elt t = t.comparator.Comparator.compare module Accessors = struct let comparator t = t.comparator let comparator_s (type k cmp) t : (k, cmp) Comparator.Module.t = (module struct type t = k type comparator_witness = cmp let comparator = t.comparator end) ;; let invariants t = Tree0.invariants t.tree ~compare_elt:(compare_elt t) let length t = Tree0.length t.tree let is_empty t = Tree0.is_empty t.tree let elements t = Tree0.elements t.tree let min_elt t = Tree0.min_elt t.tree let min_elt_exn t = Tree0.min_elt_exn t.tree let max_elt t = Tree0.max_elt t.tree let max_elt_exn t = Tree0.max_elt_exn t.tree let choose t = Tree0.choose t.tree let choose_exn t = Tree0.choose_exn t.tree let to_list t = Tree0.to_list t.tree let to_array t = Tree0.to_array t.tree let fold t ~init ~f = Tree0.fold t.tree ~init ~f let fold_until t ~init ~f ~finish = Tree0.fold_until t.tree ~init ~f ~finish let fold_right t ~init ~f = Tree0.fold_right t.tree ~init ~f let fold_result t ~init ~f = Container.fold_result ~fold ~init ~f t let iter t ~f = Tree0.iter t.tree ~f let iter2 a b ~f = Tree0.iter2 a.tree b.tree ~f ~compare_elt:(compare_elt a) let exists t ~f = Tree0.exists t.tree ~f let for_all t ~f = Tree0.for_all t.tree ~f let count t ~f = Tree0.count t.tree ~f let sum m t ~f = Tree0.sum m t.tree ~f let find t ~f = Tree0.find t.tree ~f let find_exn t ~f = Tree0.find_exn t.tree ~f let find_map t ~f = Tree0.find_map t.tree ~f let mem t a = Tree0.mem t.tree a ~compare_elt:(compare_elt t) let filter t ~f = like_maybe_no_op t (Tree0.filter t.tree ~f) let add t a = like t (Tree0.add t.tree a ~compare_elt:(compare_elt t)) let remove t a = like t (Tree0.remove t.tree a ~compare_elt:(compare_elt t)) let union t1 t2 = like t1 (Tree0.union t1.tree t2.tree ~compare_elt:(compare_elt t1)) let inter t1 t2 = like t1 (Tree0.inter t1.tree t2.tree ~compare_elt:(compare_elt t1)) let diff t1 t2 = like t1 (Tree0.diff t1.tree t2.tree ~compare_elt:(compare_elt t1)) let symmetric_diff t1 t2 = Tree0.symmetric_diff t1.tree t2.tree ~compare_elt:(compare_elt t1) ;; let compare_direct t1 t2 = Tree0.compare (compare_elt t1) t1.tree t2.tree let equal t1 t2 = Tree0.equal t1.tree t2.tree ~compare_elt:(compare_elt t1) let is_subset t ~of_ = Tree0.is_subset t.tree ~of_:of_.tree ~compare_elt:(compare_elt t) let are_disjoint t1 t2 = Tree0.are_disjoint t1.tree t2.tree ~compare_elt:(compare_elt t1) ;; module Named = struct let to_named_tree (named : (_, _) t Named.t) = { named with set = named.set.tree } let is_subset subset ~of_:superset = Tree0.Named.is_subset (to_named_tree subset) ~of_:(to_named_tree superset) ~compare_elt:(compare_elt subset.set) ~sexp_of_elt:subset.set.comparator.sexp_of_t ;; let equal t1 t2 = Or_error.combine_errors_unit [ is_subset t1 ~of_:t2; is_subset t2 ~of_:t1 ] ;; include Named end let partition_tf t ~f = let tree_t, tree_f = Tree0.partition_tf t.tree ~f in like_maybe_no_op t tree_t, like_maybe_no_op t tree_f ;; let split t a = let tree1, b, tree2 = Tree0.split t.tree a ~compare_elt:(compare_elt t) in like t tree1, b, like t tree2 ;; let split_le_gt t a = let tree1, tree2 = Tree0.split_le_gt t.tree a ~compare_elt:(compare_elt t) in like t tree1, like t tree2 ;; let split_lt_ge t a = let tree1, tree2 = Tree0.split_lt_ge t.tree a ~compare_elt:(compare_elt t) in like t tree1, like t tree2 ;; let group_by t ~equiv = List.map (Tree0.group_by t.tree ~equiv) ~f:(like t) let nth t i = Tree0.nth t.tree i let remove_index t i = like t (Tree0.remove_index t.tree i ~compare_elt:(compare_elt t)) let sexp_of_t sexp_of_a _ t = Tree0.sexp_of_t sexp_of_a t.tree let to_sequence ?order ?greater_or_equal_to ?less_or_equal_to t = Tree0.to_sequence t.comparator ?order ?greater_or_equal_to ?less_or_equal_to t.tree ;; let binary_search t ~compare how v = Tree0.binary_search t.tree ~compare how v let binary_search_segmented t ~segment_of how = Tree0.binary_search_segmented t.tree ~segment_of how ;; let merge_to_sequence ?order ?greater_or_equal_to ?less_or_equal_to t t' = Tree0.merge_to_sequence t.comparator ?order ?greater_or_equal_to ?less_or_equal_to t.tree t'.tree ;; let hash_fold_direct hash_fold_key state t = Tree0.hash_fold_t_ignoring_structure hash_fold_key state t.tree ;; end include Accessors let compare _ _ t1 t2 = compare_direct t1 t2 module Tree = struct type ('a, 'comparator) t = ('a, 'comparator) tree let ce comparator = comparator.Comparator.compare let t_of_sexp_direct ~comparator a_of_sexp sexp = Tree0.t_of_sexp_direct ~compare_elt:(ce comparator) a_of_sexp sexp ;; let empty_without_value_restriction = Tree0.empty let empty ~comparator:_ = empty_without_value_restriction let singleton ~comparator:_ e = Tree0.singleton e let length t = Tree0.length t let invariants ~comparator t = Tree0.invariants t ~compare_elt:(ce comparator) let is_empty t = Tree0.is_empty t let elements t = Tree0.elements t let min_elt t = Tree0.min_elt t let min_elt_exn t = Tree0.min_elt_exn t let max_elt t = Tree0.max_elt t let max_elt_exn t = Tree0.max_elt_exn t let choose t = Tree0.choose t let choose_exn t = Tree0.choose_exn t let to_list t = Tree0.to_list t let to_array t = Tree0.to_array t let iter t ~f = Tree0.iter t ~f let exists t ~f = Tree0.exists t ~f let for_all t ~f = Tree0.for_all t ~f let count t ~f = Tree0.count t ~f let sum m t ~f = Tree0.sum m t ~f let find t ~f = Tree0.find t ~f let find_exn t ~f = Tree0.find_exn t ~f let find_map t ~f = Tree0.find_map t ~f let fold t ~init ~f = Tree0.fold t ~init ~f let fold_until t ~init ~f ~finish = Tree0.fold_until t ~init ~f ~finish let fold_right t ~init ~f = Tree0.fold_right t ~init ~f let map ~comparator t ~f = Tree0.map t ~f ~compare_elt:(ce comparator) let filter t ~f = Tree0.filter t ~f let filter_map ~comparator t ~f = Tree0.filter_map t ~f ~compare_elt:(ce comparator) let partition_tf t ~f = Tree0.partition_tf t ~f let iter2 ~comparator a b ~f = Tree0.iter2 a b ~f ~compare_elt:(ce comparator) let mem ~comparator t a = Tree0.mem t a ~compare_elt:(ce comparator) let add ~comparator t a = Tree0.add t a ~compare_elt:(ce comparator) let remove ~comparator t a = Tree0.remove t a ~compare_elt:(ce comparator) let union ~comparator t1 t2 = Tree0.union t1 t2 ~compare_elt:(ce comparator) let inter ~comparator t1 t2 = Tree0.inter t1 t2 ~compare_elt:(ce comparator) let diff ~comparator t1 t2 = Tree0.diff t1 t2 ~compare_elt:(ce comparator) let symmetric_diff ~comparator t1 t2 = Tree0.symmetric_diff t1 t2 ~compare_elt:(ce comparator) ;; let compare_direct ~comparator t1 t2 = Tree0.compare (ce comparator) t1 t2 let equal ~comparator t1 t2 = Tree0.equal t1 t2 ~compare_elt:(ce comparator) let is_subset ~comparator t ~of_ = Tree0.is_subset t ~of_ ~compare_elt:(ce comparator) let are_disjoint ~comparator t1 t2 = Tree0.are_disjoint t1 t2 ~compare_elt:(ce comparator) ;; let of_list ~comparator l = Tree0.of_list l ~compare_elt:(ce comparator) let of_sequence ~comparator s = Tree0.of_sequence s ~compare_elt:(ce comparator) let of_array ~comparator a = Tree0.of_array a ~compare_elt:(ce comparator) let of_sorted_array_unchecked ~comparator a = Tree0.of_sorted_array_unchecked a ~compare_elt:(ce comparator) ;; let of_increasing_iterator_unchecked ~comparator:_ ~len ~f = Tree0.of_increasing_iterator_unchecked ~len ~f ;; let of_sorted_array ~comparator a = Tree0.of_sorted_array a ~compare_elt:(ce comparator) let union_list ~comparator l = Tree0.union_list l ~to_tree:Fn.id ~comparator let stable_dedup_list ~comparator xs = Tree0.stable_dedup_list xs ~compare_elt:(ce comparator) ;; let group_by t ~equiv = Tree0.group_by t ~equiv let split ~comparator t a = Tree0.split t a ~compare_elt:(ce comparator) let split_le_gt ~comparator t a = Tree0.split_le_gt t a ~compare_elt:(ce comparator) let split_lt_ge ~comparator t a = Tree0.split_lt_ge t a ~compare_elt:(ce comparator) let nth t i = Tree0.nth t i let remove_index ~comparator t i = Tree0.remove_index t i ~compare_elt:(ce comparator) let sexp_of_t sexp_of_a _ t = Tree0.sexp_of_t sexp_of_a t let to_tree t = t let of_tree ~comparator:_ t = t let to_sequence ~comparator ?order ?greater_or_equal_to ?less_or_equal_to t = Tree0.to_sequence comparator ?order ?greater_or_equal_to ?less_or_equal_to t ;; let binary_search ~comparator:_ t ~compare how v = Tree0.binary_search t ~compare how v let binary_search_segmented ~comparator:_ t ~segment_of how = Tree0.binary_search_segmented t ~segment_of how ;; let merge_to_sequence ~comparator ?order ?greater_or_equal_to ?less_or_equal_to t t' = Tree0.merge_to_sequence comparator ?order ?greater_or_equal_to ?less_or_equal_to t t' ;; let fold_result t ~init ~f = Container.fold_result ~fold ~init ~f t module Named = struct include Tree0.Named let is_subset ~comparator t1 ~of_:t2 = Tree0.Named.is_subset t1 ~of_:t2 ~compare_elt:(ce comparator) ~sexp_of_elt:comparator.Comparator.sexp_of_t ;; let equal ~comparator t1 t2 = Tree0.Named.equal t1 t2 ~compare_elt:(ce comparator) ~sexp_of_elt:comparator.Comparator.sexp_of_t ;; end end module Using_comparator = struct type nonrec ('elt, 'cmp) t = ('elt, 'cmp) t include Accessors let to_tree t = t.tree let of_tree ~comparator tree = { comparator; tree } let t_of_sexp_direct ~comparator a_of_sexp sexp = of_tree ~comparator (Tree0.t_of_sexp_direct ~compare_elt:comparator.compare a_of_sexp sexp) ;; let empty ~comparator = { comparator; tree = Tree0.empty } module Empty_without_value_restriction (Elt : Comparator.S1) = struct let empty = { comparator = Elt.comparator; tree = Tree0.empty } end let singleton ~comparator e = { comparator; tree = Tree0.singleton e } let union_list ~comparator l = of_tree ~comparator (Tree0.union_list ~comparator ~to_tree l) ;; let of_sorted_array_unchecked ~comparator array = let tree = Tree0.of_sorted_array_unchecked array ~compare_elt:comparator.Comparator.compare in { comparator; tree } ;; let of_increasing_iterator_unchecked ~comparator ~len ~f = of_tree ~comparator (Tree0.of_increasing_iterator_unchecked ~len ~f) ;; let of_sorted_array ~comparator array = Or_error.Monad_infix.( Tree0.of_sorted_array array ~compare_elt:comparator.Comparator.compare >>| fun tree -> { comparator; tree }) ;; let of_list ~comparator l = { comparator; tree = Tree0.of_list l ~compare_elt:comparator.Comparator.compare } ;; let of_sequence ~comparator s = { comparator; tree = Tree0.of_sequence s ~compare_elt:comparator.Comparator.compare } ;; let of_array ~comparator a = { comparator; tree = Tree0.of_array a ~compare_elt:comparator.Comparator.compare } ;; let stable_dedup_list ~comparator xs = Tree0.stable_dedup_list xs ~compare_elt:comparator.Comparator.compare ;; let map ~comparator t ~f = { comparator; tree = Tree0.map t.tree ~f ~compare_elt:comparator.Comparator.compare } ;; let filter_map ~comparator t ~f = { comparator ; tree = Tree0.filter_map t.tree ~f ~compare_elt:comparator.Comparator.compare } ;; module Tree = Tree end type ('elt, 'cmp) comparator = (module Comparator.S with type t = 'elt and type comparator_witness = 'cmp) let to_comparator (type elt cmp) ((module M) : (elt, cmp) comparator) = M.comparator let empty m = Using_comparator.empty ~comparator:(to_comparator m) let singleton m a = Using_comparator.singleton ~comparator:(to_comparator m) a let union_list m a = Using_comparator.union_list ~comparator:(to_comparator m) a let of_sorted_array_unchecked m a = Using_comparator.of_sorted_array_unchecked ~comparator:(to_comparator m) a ;; let of_increasing_iterator_unchecked m ~len ~f = Using_comparator.of_increasing_iterator_unchecked ~comparator:(to_comparator m) ~len ~f ;; let of_sorted_array m a = Using_comparator.of_sorted_array ~comparator:(to_comparator m) a let of_list m a = Using_comparator.of_list ~comparator:(to_comparator m) a let of_sequence m a = Using_comparator.of_sequence ~comparator:(to_comparator m) a let of_array m a = Using_comparator.of_array ~comparator:(to_comparator m) a let stable_dedup_list m a = Using_comparator.stable_dedup_list ~comparator:(to_comparator m) a ;; let map m a ~f = Using_comparator.map ~comparator:(to_comparator m) a ~f let filter_map m a ~f = Using_comparator.filter_map ~comparator:(to_comparator m) a ~f let to_tree = Using_comparator.to_tree let of_tree m t = Using_comparator.of_tree ~comparator:(to_comparator m) t module M (Elt : sig type t type comparator_witness end) = struct type nonrec t = (Elt.t, Elt.comparator_witness) t end module type Sexp_of_m = sig type t [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end module type M_of_sexp = sig type t [@@deriving_inline of_sexp] val t_of_sexp : Sexplib0.Sexp.t -> t [@@@end] include Comparator.S with type t := t end module type M_sexp_grammar = sig type t [@@deriving_inline sexp_grammar] val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] end module type Compare_m = sig end module type Equal_m = sig end module type Hash_fold_m = Hasher.S let sexp_of_m__t (type elt) (module Elt : Sexp_of_m with type t = elt) t = sexp_of_t Elt.sexp_of_t (fun _ -> Sexp.Atom "_") t ;; let m__t_of_sexp (type elt cmp) (module Elt : M_of_sexp with type t = elt and type comparator_witness = cmp) sexp = Using_comparator.t_of_sexp_direct ~comparator:Elt.comparator Elt.t_of_sexp sexp ;; let m__t_sexp_grammar (type elt) (module Elt : M_sexp_grammar with type t = elt) : (elt, _) t Sexplib0.Sexp_grammar.t = Sexplib0.Sexp_grammar.coerce (list_sexp_grammar Elt.t_sexp_grammar) ;; let compare_m__t (module _ : Compare_m) t1 t2 = compare_direct t1 t2 let equal_m__t (module _ : Equal_m) t1 t2 = equal t1 t2 let hash_fold_m__t (type elt) (module Elt : Hash_fold_m with type t = elt) state = hash_fold_direct Elt.hash_fold_t state ;; let hash_m__t folder t = let state = hash_fold_m__t folder (Hash.create ()) t in Hash.get_hash_value state ;; module Poly = struct type comparator_witness = Comparator.Poly.comparator_witness type nonrec ('elt, 'cmp) set = ('elt, comparator_witness) t type nonrec 'elt t = ('elt, comparator_witness) t type nonrec 'elt tree = ('elt, comparator_witness) tree include Accessors let comparator = Comparator.Poly.comparator include Using_comparator.Empty_without_value_restriction (Comparator.Poly) let singleton a = Using_comparator.singleton ~comparator a let union_list a = Using_comparator.union_list ~comparator a let of_sorted_array_unchecked a = Using_comparator.of_sorted_array_unchecked ~comparator a ;; let of_increasing_iterator_unchecked ~len ~f = Using_comparator.of_increasing_iterator_unchecked ~comparator ~len ~f ;; let of_sorted_array a = Using_comparator.of_sorted_array ~comparator a let of_list a = Using_comparator.of_list ~comparator a let of_sequence a = Using_comparator.of_sequence ~comparator a let of_array a = Using_comparator.of_array ~comparator a let stable_dedup_list a = Using_comparator.stable_dedup_list ~comparator a let map a ~f = Using_comparator.map ~comparator a ~f let filter_map a ~f = Using_comparator.filter_map ~comparator a ~f let of_tree tree = { comparator; tree } let to_tree t = t.tree end base-0.16.3/src/set.mli000066400000000000000000000000441446274340700146110ustar00rootroot00000000000000include Set_intf.Set (** @inline *) base-0.16.3/src/set_intf.ml000066400000000000000000000751311446274340700154710ustar00rootroot00000000000000open! Import open! T module type Elt_plain = sig type t [@@deriving_inline compare, sexp_of] include Ppx_compare_lib.Comparable.S with type t := t val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end module Without_comparator = Map_intf.Without_comparator module With_comparator = Map_intf.With_comparator module With_first_class_module = Map_intf.With_first_class_module module Merge_to_sequence_element = Sequence.Merge_with_duplicates_element module Named = struct type 'a t = { set : 'a ; name : string } end module type Accessors_generic = sig include Container.Generic type ('a, 'cmp) tree (** The [access_options] type is used to make [Accessors_generic] flexible as to whether a comparator is required to be passed to certain functions. *) type ('a, 'cmp, 'z) access_options type 'cmp cmp val invariants : ('a, 'cmp, ('a, 'cmp) t -> bool) access_options (** override [Container]'s [mem] *) val mem : ('a, 'cmp, ('a, 'cmp) t -> 'a elt -> bool) access_options val add : ('a, 'cmp, ('a, 'cmp) t -> 'a elt -> ('a, 'cmp) t) access_options val remove : ('a, 'cmp, ('a, 'cmp) t -> 'a elt -> ('a, 'cmp) t) access_options val union : ('a, 'cmp, ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t) access_options val inter : ('a, 'cmp, ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t) access_options val diff : ('a, 'cmp, ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t) access_options val symmetric_diff : ( 'a , 'cmp , ('a, 'cmp) t -> ('a, 'cmp) t -> ('a elt, 'a elt) Either.t Sequence.t ) access_options val compare_direct : ('a, 'cmp, ('a, 'cmp) t -> ('a, 'cmp) t -> int) access_options val equal : ('a, 'cmp, ('a, 'cmp) t -> ('a, 'cmp) t -> bool) access_options val is_subset : ('a, 'cmp, ('a, 'cmp) t -> of_:('a, 'cmp) t -> bool) access_options val are_disjoint : ('a, 'cmp, ('a, 'cmp) t -> ('a, 'cmp) t -> bool) access_options module Named : sig val is_subset : ( 'a , 'cmp , ('a, 'cmp) t Named.t -> of_:('a, 'cmp) t Named.t -> unit Or_error.t ) access_options val equal : ( 'a , 'cmp , ('a, 'cmp) t Named.t -> ('a, 'cmp) t Named.t -> unit Or_error.t ) access_options end val fold_until : ('a, _) t -> init:'acc -> f:(('acc -> 'a elt -> ('acc, 'final) Container.Continue_or_stop.t)[@local]) -> finish:(('acc -> 'final)[@local]) -> 'final val fold_right : ('a, _) t -> init:'acc -> f:(('a elt -> 'acc -> 'acc)[@local]) -> 'acc val iter2 : ( 'a , 'cmp , ('a, 'cmp) t -> ('a, 'cmp) t -> f: (([ `Left of 'a elt | `Right of 'a elt | `Both of 'a elt * 'a elt ] -> unit) [@local]) -> unit ) access_options val filter : ('a, 'cmp) t -> f:(('a elt -> bool)[@local]) -> ('a, 'cmp) t val partition_tf : ('a, 'cmp) t -> f:(('a elt -> bool)[@local]) -> ('a, 'cmp) t * ('a, 'cmp) t val elements : ('a, _) t -> 'a elt list val min_elt : ('a, _) t -> 'a elt option val min_elt_exn : ('a, _) t -> 'a elt val max_elt : ('a, _) t -> 'a elt option val max_elt_exn : ('a, _) t -> 'a elt val choose : ('a, _) t -> 'a elt option val choose_exn : ('a, _) t -> 'a elt val split : ( 'a , 'cmp , ('a, 'cmp) t -> 'a elt -> ('a, 'cmp) t * 'a elt option * ('a, 'cmp) t ) access_options val split_le_gt : ('a, 'cmp, ('a, 'cmp) t -> 'a elt -> ('a, 'cmp) t * ('a, 'cmp) t) access_options val split_lt_ge : ('a, 'cmp, ('a, 'cmp) t -> 'a elt -> ('a, 'cmp) t * ('a, 'cmp) t) access_options val group_by : ('a, 'cmp) t -> equiv:(('a elt -> 'a elt -> bool)[@local]) -> ('a, 'cmp) t list val find_exn : ('a, _) t -> f:(('a elt -> bool)[@local]) -> 'a elt val nth : ('a, _) t -> int -> 'a elt option val remove_index : ('a, 'cmp, ('a, 'cmp) t -> int -> ('a, 'cmp) t) access_options val to_tree : ('a, 'cmp) t -> ('a elt, 'cmp cmp) tree val to_sequence : ( 'a , 'cmp , ?order:[ `Increasing | `Decreasing ] -> ?greater_or_equal_to:'a elt -> ?less_or_equal_to:'a elt -> ('a, 'cmp) t -> 'a elt Sequence.t ) access_options val binary_search : ( 'a , 'cmp , ('a, 'cmp) t -> compare:(('a elt -> 'key -> int)[@local]) -> Binary_searchable.Which_target_by_key.t -> 'key -> 'a elt option ) access_options val binary_search_segmented : ( 'a , 'cmp , ('a, 'cmp) t -> segment_of:(('a elt -> [ `Left | `Right ])[@local]) -> Binary_searchable.Which_target_by_segment.t -> 'a elt option ) access_options val merge_to_sequence : ( 'a , 'cmp , ?order:[ `Increasing | `Decreasing ] -> ?greater_or_equal_to:'a elt -> ?less_or_equal_to:'a elt -> ('a, 'cmp) t -> ('a, 'cmp) t -> ('a elt, 'a elt) Merge_to_sequence_element.t Sequence.t ) access_options end module type Creators_generic = sig type ('a, 'cmp) t type ('a, 'cmp) set type ('a, 'cmp) tree type 'a elt type ('a, 'cmp, 'z) create_options type 'cmp cmp val empty : ('a, 'cmp, ('a, 'cmp) t) create_options val singleton : ('a, 'cmp, 'a elt -> ('a, 'cmp) t) create_options val union_list : ('a, 'cmp, ('a, 'cmp) t list -> ('a, 'cmp) t) create_options val of_list : ('a, 'cmp, 'a elt list -> ('a, 'cmp) t) create_options val of_sequence : ('a, 'cmp, 'a elt Sequence.t -> ('a, 'cmp) t) create_options val of_array : ('a, 'cmp, 'a elt array -> ('a, 'cmp) t) create_options val of_sorted_array : ('a, 'cmp, 'a elt array -> ('a, 'cmp) t Or_error.t) create_options val of_sorted_array_unchecked : ('a, 'cmp, 'a elt array -> ('a, 'cmp) t) create_options val of_increasing_iterator_unchecked : ('a, 'cmp, len:int -> f:((int -> 'a elt)[@local]) -> ('a, 'cmp) t) create_options val stable_dedup_list : ('a, _, 'a elt list -> 'a elt list) create_options (** The types of [map] and [filter_map] are subtle. The input set, [('a, _) set], reflects the fact that these functions take a set of *any* type, with any comparator, while the output set, [('b, 'cmp) t], reflects that the output set has the particular ['cmp] of the creation function. The comparator can come in one of three ways, depending on which set module is used - [Set.map] -- comparator comes as an argument - [Set.Poly.map] -- comparator is polymorphic comparison - [Foo.Set.map] -- comparator is [Foo.comparator] *) val map : ('b, 'cmp, ('a, _) set -> f:(('a -> 'b elt)[@local]) -> ('b, 'cmp) t) create_options val filter_map : ( 'b , 'cmp , ('a, _) set -> f:(('a -> 'b elt option)[@local]) -> ('b, 'cmp) t ) create_options val of_tree : ('a, 'cmp, ('a elt, 'cmp cmp) tree -> ('a, 'cmp) t) create_options end module type Creators_and_accessors_generic = sig type ('elt, 'cmp) t type ('elt, 'cmp) tree type 'elt elt type 'cmp cmp include Accessors_generic with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) tree with type 'a elt := 'a elt with type 'cmp cmp := 'cmp cmp include Creators_generic with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) tree with type 'a elt := 'a elt with type 'cmp cmp := 'cmp cmp end module type S_poly = sig type 'elt t type 'elt tree type comparator_witness include Creators_and_accessors_generic with type ('elt, 'cmp) t := 'elt t with type ('elt, 'cmp) tree := 'elt tree with type 'a elt := 'a with type 'c cmp := comparator_witness with type ('a, 'b, 'c) create_options := ('a, 'b, 'c) Without_comparator.t with type ('a, 'b, 'c) access_options := ('a, 'b, 'c) Without_comparator.t end module type For_deriving = sig type ('a, 'b) t module type Sexp_of_m = sig type t [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end module type M_of_sexp = sig type t [@@deriving_inline of_sexp] val t_of_sexp : Sexplib0.Sexp.t -> t [@@@end] include Comparator.S with type t := t end module type M_sexp_grammar = sig type t [@@deriving_inline sexp_grammar] val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] end module type Compare_m = sig end module type Equal_m = sig end module type Hash_fold_m = Hasher.S val sexp_of_m__t : (module Sexp_of_m with type t = 'elt) -> ('elt, 'cmp) t -> Sexp.t val m__t_of_sexp : (module M_of_sexp with type t = 'elt and type comparator_witness = 'cmp) -> Sexp.t -> ('elt, 'cmp) t val m__t_sexp_grammar : (module M_sexp_grammar with type t = 'elt) -> ('elt, 'cmp) t Sexplib0.Sexp_grammar.t val compare_m__t : (module Compare_m) -> ('elt, 'cmp) t -> ('elt, 'cmp) t -> int val equal_m__t : (module Equal_m) -> ('elt, 'cmp) t -> ('elt, 'cmp) t -> bool val hash_fold_m__t : (module Hash_fold_m with type t = 'elt) -> Hash.state -> ('elt, _) t -> Hash.state val hash_m__t : (module Hash_fold_m with type t = 'elt) -> ('elt, _) t -> int end module type Set = sig (** Sets based on {!Comparator.S}. Creators require a comparator argument to be passed in, whereas accessors use the comparator provided by the input set. *) (** The type of a set. The first type parameter identifies the type of the element, and the second identifies the comparator, which determines the comparison function that is used for ordering elements in this set. Many operations (e.g., {!union}), require that they be passed sets with the same element type and the same comparator type. *) type (!'elt, !'cmp) t [@@deriving_inline compare] include Ppx_compare_lib.Comparable.S2 with type (!'elt, !'cmp) t := ('elt, 'cmp) t [@@@end] type ('k, 'cmp) comparator = ('k, 'cmp) Comparator.Module.t [@@deprecated "[since 2021-12] use [Comparator.Module.t] instead"] (** Tests internal invariants of the set data structure. Returns true on success. *) val invariants : (_, _) t -> bool (** Returns a first-class module that can be used to build other map/set/etc with the same notion of comparison. *) val comparator_s : ('a, 'cmp) t -> ('a, 'cmp) Comparator.Module.t val comparator : ('a, 'cmp) t -> ('a, 'cmp) Comparator.t (** Creates an empty set based on the provided comparator. *) val empty : ('a, 'cmp) Comparator.Module.t -> ('a, 'cmp) t (** Creates a set based on the provided comparator that contains only the provided element. *) val singleton : ('a, 'cmp) Comparator.Module.t -> 'a -> ('a, 'cmp) t (** Returns the cardinality of the set. [O(1)]. *) val length : (_, _) t -> int (** [is_empty t] is [true] iff [t] is empty. [O(1)]. *) val is_empty : (_, _) t -> bool (** [mem t a] returns [true] iff [a] is in [t]. [O(log n)]. *) val mem : ('a, _) t -> 'a -> bool (** [add t a] returns a new set with [a] added to [t], or returns [t] if [mem t a]. [O(log n)]. *) val add : ('a, 'cmp) t -> 'a -> ('a, 'cmp) t (** [remove t a] returns a new set with [a] removed from [t] if [mem t a], or returns [t] otherwise. [O(log n)]. *) val remove : ('a, 'cmp) t -> 'a -> ('a, 'cmp) t (** [union t1 t2] returns the union of the two sets. [O(length t1 + length t2)]. *) val union : ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t (** [union c list] returns the union of all the sets in [list]. The [comparator] argument is required for the case where [list] is empty. [O(max(List.length list, n log n))], where [n] is the sum of sizes of the input sets. *) val union_list : ('a, 'cmp) Comparator.Module.t -> ('a, 'cmp) t list -> ('a, 'cmp) t (** [inter t1 t2] computes the intersection of sets [t1] and [t2]. [O(length t1 + length t2)]. *) val inter : ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t (** [diff t1 t2] computes the set difference [t1 - t2], i.e., the set containing all elements in [t1] that are not in [t2]. [O(length t1 + length t2)]. *) val diff : ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t (** [symmetric_diff t1 t2] returns a sequence of changes between [t1] and [t2]. It is intended to be efficient in the case where [t1] and [t2] share a large amount of structure. *) val symmetric_diff : ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'a) Either.t Sequence.t (** [compare_direct t1 t2] compares the sets [t1] and [t2]. It returns the same result as [compare], but unlike compare, doesn't require arguments to be passed in for the type parameters of the set. [O(length t1 + length t2)]. *) val compare_direct : ('a, 'cmp) t -> ('a, 'cmp) t -> int (** Hash function: a building block to use when hashing data structures containing sets in them. [hash_fold_direct hash_fold_key] is compatible with [compare_direct] iff [hash_fold_key] is compatible with [(comparator s).compare] of the set [s] being hashed. *) val hash_fold_direct : 'a Hash.folder -> ('a, 'cmp) t Hash.folder (** [equal t1 t2] returns [true] iff the two sets have the same elements. [O(length t1 + length t2)] *) val equal : ('a, 'cmp) t -> ('a, 'cmp) t -> bool (** [exists t ~f] returns [true] iff there exists an [a] in [t] for which [f a]. [O(n)], but returns as soon as it finds an [a] for which [f a]. *) val exists : ('a, _) t -> f:(('a -> bool)[@local]) -> bool (** [for_all t ~f] returns [true] iff for all [a] in [t], [f a]. [O(n)], but returns as soon as it finds an [a] for which [not (f a)]. *) val for_all : ('a, _) t -> f:(('a -> bool)[@local]) -> bool (** [count t] returns the number of elements of [t] for which [f] returns [true]. [O(n)]. *) val count : ('a, _) t -> f:(('a -> bool)[@local]) -> int (** [sum t] returns the sum of [f t] for each [t] in the set. [O(n)]. *) val sum : (module Container.Summable with type t = 'sum) -> ('a, _) t -> f:(('a -> 'sum)[@local]) -> 'sum (** [find t f] returns an element of [t] for which [f] returns true, with no guarantee as to which element is returned. [O(n)], but returns as soon as a suitable element is found. *) val find : ('a, _) t -> f:(('a -> bool)[@local]) -> 'a option (** [find_map t f] returns [b] for some [a] in [t] for which [f a = Some b]. If no such [a] exists, then [find] returns [None]. [O(n)], but returns as soon as a suitable element is found. *) val find_map : ('a, _) t -> f:(('a -> 'b option)[@local]) -> 'b option (** Like [find], but throws an exception on failure. *) val find_exn : ('a, _) t -> f:(('a -> bool)[@local]) -> 'a (** [nth t i] returns the [i]th smallest element of [t], in [O(log n)] time. The smallest element has [i = 0]. Returns [None] if [i < 0] or [i >= length t]. *) val nth : ('a, _) t -> int -> 'a option (** [remove_index t i] returns a version of [t] with the [i]th smallest element removed, in [O(log n)] time. The smallest element has [i = 0]. Returns [t] if [i < 0] or [i >= length t]. *) val remove_index : ('a, 'cmp) t -> int -> ('a, 'cmp) t (** [is_subset t1 ~of_:t2] returns true iff [t1] is a subset of [t2]. *) val is_subset : ('a, 'cmp) t -> of_:('a, 'cmp) t -> bool (** [are_disjoint t1 t2] returns [true] iff [is_empty (inter t1 t2)], but is more efficient. *) val are_disjoint : ('a, 'cmp) t -> ('a, 'cmp) t -> bool (** [Named] allows the validation of subset and equality relationships between sets. A [Named.t] is a record of a set and a name, where the name is used in error messages, and [Named.is_subset] and [Named.equal] validate subset and equality relationships respectively. The error message for, e.g., {[ Named.is_subset { set = set1; name = "set1" } ~of_:{set = set2; name = "set2" } ]} looks like {v ("set1 is not a subset of set2" (invalid_elements (...elements of set1 - set2...))) v} so [name] should be a noun phrase that doesn't sound awkward in the above error message. Even though it adds verbosity, choosing [name]s that start with the phrase "the set of" often makes the error message sound more natural. *) module Named : sig type ('a, 'cmp) set := ('a, 'cmp) t type 'a t = 'a Named.t = { set : 'a ; name : string } (** [is_subset t1 ~of_:t2] returns [Ok ()] if [t1] is a subset of [t2] and a human-readable error otherwise. *) val is_subset : ('a, 'cmp) set t -> of_:('a, 'cmp) set t -> unit Or_error.t (** [equal t1 t2] returns [Ok ()] if [t1] is equal to [t2] and a human-readable error otherwise. *) val equal : ('a, 'cmp) set t -> ('a, 'cmp) set t -> unit Or_error.t end (** The list or array given to [of_list] and [of_array] need not be sorted. *) val of_list : ('a, 'cmp) Comparator.Module.t -> 'a list -> ('a, 'cmp) t val of_sequence : ('a, 'cmp) Comparator.Module.t -> 'a Sequence.t -> ('a, 'cmp) t val of_array : ('a, 'cmp) Comparator.Module.t -> 'a array -> ('a, 'cmp) t (** [to_list] and [to_array] produce sequences sorted in ascending order according to the comparator. *) val to_list : ('a, _) t -> 'a list val to_array : ('a, _) t -> 'a array (** Create set from sorted array. The input must be sorted (either in ascending or descending order as given by the comparator) and contain no duplicates, otherwise the result is an error. The complexity of this function is [O(n)]. *) val of_sorted_array : ('a, 'cmp) Comparator.Module.t -> 'a array -> ('a, 'cmp) t Or_error.t (** Similar to [of_sorted_array], but without checking the input array. *) val of_sorted_array_unchecked : ('a, 'cmp) Comparator.Module.t -> 'a array -> ('a, 'cmp) t (** [of_increasing_iterator_unchecked c ~len ~f] behaves like [of_sorted_array_unchecked c (Array.init len ~f)], with the additional restriction that a decreasing order is not supported. The advantage is not requiring you to allocate an intermediate array. [f] will be called with 0, 1, ... [len - 1], in order. *) val of_increasing_iterator_unchecked : ('a, 'cmp) Comparator.Module.t -> len:int -> f:((int -> 'a)[@local]) -> ('a, 'cmp) t (** [stable_dedup_list] is here rather than in the [List] module because the implementation relies crucially on sets, and because doing so allows one to avoid uses of polymorphic comparison by instantiating the functor at a different implementation of [Comparator] and using the resulting [stable_dedup_list]. *) val stable_dedup_list : ('a, _) Comparator.Module.t -> 'a list -> 'a list (** [map c t ~f] returns a new set created by applying [f] to every element in [t]. The returned set is based on the provided [comparator]. [O(n log n)]. *) val map : ('b, 'cmp) Comparator.Module.t -> ('a, _) t -> f:(('a -> 'b)[@local]) -> ('b, 'cmp) t (** Like {!map}, except elements for which [f] returns [None] will be dropped. *) val filter_map : ('b, 'cmp) Comparator.Module.t -> ('a, _) t -> f:(('a -> 'b option)[@local]) -> ('b, 'cmp) t (** [filter t ~f] returns the subset of [t] for which [f] evaluates to true. [O(n log n)]. *) val filter : ('a, 'cmp) t -> f:(('a -> bool)[@local]) -> ('a, 'cmp) t (** [fold t ~init ~f] folds over the elements of the set from smallest to largest. *) val fold : ('a, _) t -> init:'acc -> f:(('acc -> 'a -> 'acc)[@local]) -> 'acc (** [fold_result ~init ~f] folds over the elements of the set from smallest to largest, short circuiting the fold if [f accum x] is an [Error _] *) val fold_result : ('a, _) t -> init:'acc -> f:(('acc -> 'a -> ('acc, 'e) Result.t)[@local]) -> ('acc, 'e) Result.t (** [fold_until t ~init ~f] is a short-circuiting version of [fold]. If [f] returns [Stop _] the computation ceases and results in that value. If [f] returns [Continue _], the fold will proceed. *) val fold_until : ('a, _) t -> init:'acc -> f:(('acc -> 'a -> ('acc, 'final) Container.Continue_or_stop.t)[@local]) -> finish:(('acc -> 'final)[@local]) -> 'final (** Like {!fold}, except that it goes from the largest to the smallest element. *) val fold_right : ('a, _) t -> init:'acc -> f:(('a -> 'acc -> 'acc)[@local]) -> 'acc (** [iter t ~f] calls [f] on every element of [t], going in order from the smallest to largest. *) val iter : ('a, _) t -> f:(('a -> unit)[@local]) -> unit (** Iterate two sets side by side. Complexity is [O(m+n)] where [m] and [n] are the sizes of the two input sets. As an example, with the inputs [0; 1] and [1; 2], [f] will be called with [`Left 0]; [`Both (1, 1)]; and [`Right 2]. *) val iter2 : ('a, 'cmp) t -> ('a, 'cmp) t -> f:(([ `Left of 'a | `Right of 'a | `Both of 'a * 'a ] -> unit)[@local]) -> unit (** if [a, b = partition_tf set ~f] then [a] is the elements on which [f] produced [true], and [b] is the elements on which [f] produces [false]. *) val partition_tf : ('a, 'cmp) t -> f:(('a -> bool)[@local]) -> ('a, 'cmp) t * ('a, 'cmp) t (** Same as {!to_list}. *) val elements : ('a, _) t -> 'a list (** Returns the smallest element of the set. [O(log n)]. *) val min_elt : ('a, _) t -> 'a option (** Like {!min_elt}, but throws an exception when given an empty set. *) val min_elt_exn : ('a, _) t -> 'a (** Returns the largest element of the set. [O(log n)]. *) val max_elt : ('a, _) t -> 'a option (** Like {!max_elt}, but throws an exception when given an empty set. *) val max_elt_exn : ('a, _) t -> 'a (** returns an arbitrary element, or [None] if the set is empty. *) val choose : ('a, _) t -> 'a option (** Like {!choose}, but throws an exception on an empty set. *) val choose_exn : ('a, _) t -> 'a (** [split t x] produces a triple [(t1, maybe_x, t2)]. [t1] is the set of elements strictly less than [x], [maybe_x] is the member (if any) of [t] which compares equal to [x], [t2] is the set of elements strictly larger than [x]. *) val split : ('a, 'cmp) t -> 'a -> ('a, 'cmp) t * 'a option * ('a, 'cmp) t (** [split_le_gt t x] produces a pair [(t1, t2)]. [t1] is the set of elements less than or equal to [x], [t2] is the set of elements strictly greater than [x]. *) val split_le_gt : ('a, 'cmp) t -> 'a -> ('a, 'cmp) t * ('a, 'cmp) t (** [split_lt_ge t x] produces a pair [(t1, t2)]. [t1] is the set of elements strictly less than [x], [t2] is the set of elements greater than or equal to [x]. *) val split_lt_ge : ('a, 'cmp) t -> 'a -> ('a, 'cmp) t * ('a, 'cmp) t (** if [equiv] is an equivalence predicate, then [group_by set ~equiv] produces a list of equivalence classes (i.e., a set-theoretic quotient). E.g., {[ let chars = Set.of_list ['A'; 'a'; 'b'; 'c'] in let equiv c c' = Char.equal (Char.uppercase c) (Char.uppercase c') in group_by chars ~equiv ]} produces: {[ [Set.of_list ['A';'a']; Set.singleton 'b'; Set.singleton 'c'] ]} [group_by] runs in O(n^2) time, so if you have a comparison function, it's usually much faster to use [Set.of_list]. *) val group_by : ('a, 'cmp) t -> equiv:(('a -> 'a -> bool)[@local]) -> ('a, 'cmp) t list (** [to_sequence t] converts the set [t] to a sequence of the elements between [greater_or_equal_to] and [less_or_equal_to] inclusive in the order indicated by [order]. If [greater_or_equal_to > less_or_equal_to] the sequence is empty. Cost is O(log n) up front and amortized O(1) for each element produced. *) val to_sequence : ?order:[ `Increasing (** default *) | `Decreasing ] -> ?greater_or_equal_to:'a -> ?less_or_equal_to:'a -> ('a, 'cmp) t -> 'a Sequence.t (** [binary_search t ~compare which elt] returns the element in [t] specified by [compare] and [which], if one exists. [t] must be sorted in increasing order according to [compare], where [compare] and [elt] divide [t] into three (possibly empty) segments: {v | < elt | = elt | > elt | v} [binary_search] returns an element on the boundary of segments as specified by [which]. See the diagram below next to the [which] variants. [binary_search] does not check that [compare] orders [t], and behavior is unspecified if [compare] doesn't order [t]. Behavior is also unspecified if [compare] mutates [t]. *) val binary_search : ('a, 'cmp) t -> compare:(('a -> 'key -> int)[@local]) -> [ `Last_strictly_less_than (** {v | < elt X | v} *) | `Last_less_than_or_equal_to (** {v | <= elt X | v} *) | `Last_equal_to (** {v | = elt X | v} *) | `First_equal_to (** {v | X = elt | v} *) | `First_greater_than_or_equal_to (** {v | X >= elt | v} *) | `First_strictly_greater_than (** {v | X > elt | v} *) ] -> 'key -> 'a option (** [binary_search_segmented t ~segment_of which] takes a [segment_of] function that divides [t] into two (possibly empty) segments: {v | segment_of elt = `Left | segment_of elt = `Right | v} [binary_search_segmented] returns the element on the boundary of the segments as specified by [which]: [`Last_on_left] yields the last element of the left segment, while [`First_on_right] yields the first element of the right segment. It returns [None] if the segment is empty. [binary_search_segmented] does not check that [segment_of] segments [t] as in the diagram, and behavior is unspecified if [segment_of] doesn't segment [t]. Behavior is also unspecified if [segment_of] mutates [t]. *) val binary_search_segmented : ('a, 'cmp) t -> segment_of:(('a -> [ `Left | `Right ])[@local]) -> [ `Last_on_left | `First_on_right ] -> 'a option (** Produces the elements of the two sets between [greater_or_equal_to] and [less_or_equal_to] in [order], noting whether each element appears in the left set, the right set, or both. In the both case, both elements are returned, in case the caller can distinguish between elements that are equal to the sets' comparator. Runs in O(length t + length t'). *) module Merge_to_sequence_element : sig type ('a, 'b) t = ('a, 'b) Sequence.Merge_with_duplicates_element.t = | Left of 'a | Right of 'b | Both of 'a * 'b [@@deriving_inline compare, sexp] include Ppx_compare_lib.Comparable.S2 with type ('a, 'b) t := ('a, 'b) t include Sexplib0.Sexpable.S2 with type ('a, 'b) t := ('a, 'b) t [@@@end] end val merge_to_sequence : ?order:[ `Increasing (** default *) | `Decreasing ] -> ?greater_or_equal_to:'a -> ?less_or_equal_to:'a -> ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'a) Merge_to_sequence_element.t Sequence.t (** [M] is meant to be used in combination with OCaml applicative functor types: {[ type string_set = Set.M(String).t ]} which stands for: {[ type string_set = (String.t, String.comparator_witness) Set.t ]} The point is that [Set.M(String).t] supports deriving, whereas the second syntax doesn't (because there is no such thing as, say, String.sexp_of_comparator_witness, instead you would want to pass the comparator directly). *) module M (Elt : sig type t type comparator_witness end) : sig type nonrec t = (Elt.t, Elt.comparator_witness) t end include For_deriving with type ('a, 'b) t := ('a, 'b) t (** A polymorphic Set. *) module Poly : S_poly with type 'elt t = ('elt, Comparator.Poly.comparator_witness) t (** Using comparator is a similar interface as the toplevel of [Set], except the functions take a [~comparator:('elt, 'cmp) Comparator.t] where the functions at the toplevel of [Set] takes a [('elt, 'cmp) comparator]. *) module Using_comparator : sig type nonrec ('elt, 'cmp) t = ('elt, 'cmp) t [@@deriving_inline sexp_of] val sexp_of_t : ('elt -> Sexplib0.Sexp.t) -> ('cmp -> Sexplib0.Sexp.t) -> ('elt, 'cmp) t -> Sexplib0.Sexp.t [@@@end] val t_of_sexp_direct : comparator:('elt, 'cmp) Comparator.t -> (Sexp.t -> 'elt) -> Sexp.t -> ('elt, 'cmp) t module Tree : sig (** A [Tree.t] contains just the tree data structure that a set is based on, without including the comparator. Accordingly, any operation on a [Tree.t] must also take as an argument the corresponding comparator. *) type ('a, 'cmp) t [@@deriving_inline sexp_of] val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> ('cmp -> Sexplib0.Sexp.t) -> ('a, 'cmp) t -> Sexplib0.Sexp.t [@@@end] val t_of_sexp_direct : comparator:('elt, 'cmp) Comparator.t -> (Sexp.t -> 'elt) -> Sexp.t -> ('elt, 'cmp) t include Creators_and_accessors_generic with type ('a, 'b) set := ('a, 'b) t with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) t with type 'a elt := 'a with type 'c cmp := 'c with type ('a, 'b, 'c) create_options := ('a, 'b, 'c) With_comparator.t with type ('a, 'b, 'c) access_options := ('a, 'b, 'c) With_comparator.t val empty_without_value_restriction : (_, _) t end include Creators_and_accessors_generic with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) Tree.t with type ('a, 'b) set := ('a, 'b) t with type 'a elt := 'a with type 'c cmp := 'c with type ('a, 'b, 'c) access_options := ('a, 'b, 'c) Without_comparator.t with type ('a, 'b, 'c) create_options := ('a, 'b, 'c) With_comparator.t val comparator_s : ('a, 'cmp) t -> ('a, 'cmp) Comparator.Module.t val comparator : ('a, 'cmp) t -> ('a, 'cmp) Comparator.t val hash_fold_direct : 'elt Hash.folder -> ('elt, 'cmp) t Hash.folder module Empty_without_value_restriction (Elt : Comparator.S1) : sig val empty : ('a Elt.t, Elt.comparator_witness) t end end val to_tree : ('a, 'cmp) t -> ('a, 'cmp) Using_comparator.Tree.t val of_tree : ('a, 'cmp) Comparator.Module.t -> ('a, 'cmp) Using_comparator.Tree.t -> ('a, 'cmp) t (** {2 Modules and module types for extending [Set]} For use in extensions of Base, like [Core]. *) module With_comparator = With_comparator module With_first_class_module = With_first_class_module module Without_comparator = Without_comparator module type For_deriving = For_deriving module type S_poly = S_poly module type Accessors_generic = Accessors_generic module type Creators_generic = Creators_generic module type Creators_and_accessors_generic = Creators_and_accessors_generic module type Elt_plain = Elt_plain end base-0.16.3/src/sexp.ml000066400000000000000000000025471446274340700146360ustar00rootroot00000000000000open Hash.Builtin open Ppx_compare_lib.Builtin include Sexplib0.Sexp (** Type of S-expressions *) type t = Sexplib0.Sexp.t = | Atom of string | List of t list [@@deriving_inline compare, hash] let rec compare = (fun a__001_ b__002_ -> if Stdlib.( == ) a__001_ b__002_ then 0 else ( match a__001_, b__002_ with | Atom _a__003_, Atom _b__004_ -> compare_string _a__003_ _b__004_ | Atom _, _ -> -1 | _, Atom _ -> 1 | List _a__005_, List _b__006_ -> compare_list compare _a__005_ _b__006_) : t -> t -> int) ;; let rec (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = (fun hsv arg -> match arg with | Atom _a0 -> let hsv = Ppx_hash_lib.Std.Hash.fold_int hsv 0 in let hsv = hsv in hash_fold_string hsv _a0 | List _a0 -> let hsv = Ppx_hash_lib.Std.Hash.fold_int hsv 1 in let hsv = hsv in hash_fold_list hash_fold_t hsv _a0 : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func arg = Ppx_hash_lib.Std.Hash.get_hash_value (let hsv = Ppx_hash_lib.Std.Hash.create () in hash_fold_t hsv arg) in fun x -> func x ;; [@@@end] let t_sexp_grammar = Sexplib0.Sexp_conv.sexp_t_sexp_grammar let of_string = () let invariant (_ : t) = () base-0.16.3/src/sexp.mli000066400000000000000000000012441446274340700150000ustar00rootroot00000000000000(** Type of S-expressions *) type t = Sexplib0.Sexp.t = | Atom of string | List of t list [@@deriving_inline hash] include Ppx_hash_lib.Hashable.S with type t := t [@@@end] include module type of Sexplib0.Sexp with type t := Sexplib0.Sexp.t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t val invariant : t -> unit (** Base has never had an [of_string] function. We expose a deprecated [of_string] here so that people can find it (e.g. with merlin), and learn what we recommend. This [of_string] has type [unit] because we don't want it to be accidentally used. *) val of_string : unit [@@deprecated "[since 2018-02] Use [Parsexp.Single.parse_string_exn]"] base-0.16.3/src/sexp_with_comparable.ml000066400000000000000000000000541446274340700200450ustar00rootroot00000000000000include Sexp include Comparable.Make (Sexp) base-0.16.3/src/sexp_with_comparable.mli000066400000000000000000000003241446274340700202160ustar00rootroot00000000000000(*_ This module is separated from Sexp to avoid circular dependencies as many things use s-expressions *) (** @inline *) include module type of struct include Sexp end include Comparable.S with type t := t base-0.16.3/src/sexpable.ml000066400000000000000000000055521446274340700154610ustar00rootroot00000000000000open! Import include Sexplib0.Sexpable module Of_sexpable (Sexpable : S) (M : sig type t val to_sexpable : t -> Sexpable.t val of_sexpable : Sexpable.t -> t end) : S with type t := M.t = struct let t_of_sexp sexp = let s = Sexpable.t_of_sexp sexp in try M.of_sexpable s with | exn -> of_sexp_error_exn exn sexp ;; let sexp_of_t t = Sexpable.sexp_of_t (M.to_sexpable t) end module Of_sexpable1 (Sexpable : S1) (M : sig type 'a t val to_sexpable : 'a t -> 'a Sexpable.t val of_sexpable : 'a Sexpable.t -> 'a t end) : S1 with type 'a t := 'a M.t = struct let t_of_sexp a_of_sexp sexp = let s = Sexpable.t_of_sexp a_of_sexp sexp in try M.of_sexpable s with | exn -> of_sexp_error_exn exn sexp ;; let sexp_of_t sexp_of_a t = Sexpable.sexp_of_t sexp_of_a (M.to_sexpable t) end module Of_sexpable2 (Sexpable : S2) (M : sig type ('a, 'b) t val to_sexpable : ('a, 'b) t -> ('a, 'b) Sexpable.t val of_sexpable : ('a, 'b) Sexpable.t -> ('a, 'b) t end) : S2 with type ('a, 'b) t := ('a, 'b) M.t = struct let t_of_sexp a_of_sexp b_of_sexp sexp = let s = Sexpable.t_of_sexp a_of_sexp b_of_sexp sexp in try M.of_sexpable s with | exn -> of_sexp_error_exn exn sexp ;; let sexp_of_t sexp_of_a sexp_of_b t = Sexpable.sexp_of_t sexp_of_a sexp_of_b (M.to_sexpable t) ;; end module Of_sexpable3 (Sexpable : S3) (M : sig type ('a, 'b, 'c) t val to_sexpable : ('a, 'b, 'c) t -> ('a, 'b, 'c) Sexpable.t val of_sexpable : ('a, 'b, 'c) Sexpable.t -> ('a, 'b, 'c) t end) : S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) M.t = struct let t_of_sexp a_of_sexp b_of_sexp c_of_sexp sexp = let s = Sexpable.t_of_sexp a_of_sexp b_of_sexp c_of_sexp sexp in try M.of_sexpable s with | exn -> of_sexp_error_exn exn sexp ;; let sexp_of_t sexp_of_a sexp_of_b sexp_of_c t = Sexpable.sexp_of_t sexp_of_a sexp_of_b sexp_of_c (M.to_sexpable t) ;; end module Of_stringable (M : Stringable.S) : sig type t [@@deriving_inline sexp_grammar] val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] include S with type t := t end with type t := M.t = struct let t_of_sexp sexp = match sexp with | Sexp.Atom s -> (try M.of_string s with | exn -> of_sexp_error_exn exn sexp) | Sexp.List _ -> of_sexp_error "Sexpable.Of_stringable.t_of_sexp expected an atom, but got a list" sexp ;; let sexp_of_t t = Sexp.Atom (M.to_string t) let t_sexp_grammar : M.t Sexplib0.Sexp_grammar.t = Sexplib0.Sexp_grammar.coerce string_sexp_grammar ;; end base-0.16.3/src/sexpable.mli000066400000000000000000000033571446274340700156330ustar00rootroot00000000000000(** Provides functors for making modules sexpable when you want the sexp representation of one type to be the same as that for some other isomorphic type. *) open! Import open! Sexplib0.Sexpable module Of_sexpable (Sexpable : S) (M : sig type t val to_sexpable : t -> Sexpable.t val of_sexpable : Sexpable.t -> t end) : S with type t := M.t module Of_sexpable1 (Sexpable : S1) (M : sig type 'a t val to_sexpable : 'a t -> 'a Sexpable.t val of_sexpable : 'a Sexpable.t -> 'a t end) : S1 with type 'a t := 'a M.t module Of_sexpable2 (Sexpable : S2) (M : sig type ('a, 'b) t val to_sexpable : ('a, 'b) t -> ('a, 'b) Sexpable.t val of_sexpable : ('a, 'b) Sexpable.t -> ('a, 'b) t end) : S2 with type ('a, 'b) t := ('a, 'b) M.t module Of_sexpable3 (Sexpable : S3) (M : sig type ('a, 'b, 'c) t val to_sexpable : ('a, 'b, 'c) t -> ('a, 'b, 'c) Sexpable.t val of_sexpable : ('a, 'b, 'c) Sexpable.t -> ('a, 'b, 'c) t end) : S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) M.t module Of_stringable (M : Stringable.S) : sig type t [@@deriving_inline sexp_grammar] val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] include S with type t := t end with type t := M.t (** New code should use the [[@@deriving sexp]] syntax directly. These module types ([S], [S1], [S2], and [S3]) are exported for backwards compatibility only. *) include module type of Sexplib0.Sexpable (** @inline *) base-0.16.3/src/sign.ml000066400000000000000000000015661446274340700146170ustar00rootroot00000000000000open! Import include Sign0 include Identifiable.Make (Sign0) (* Open [Replace_polymorphic_compare] after including functor applications so they do not shadow its definitions. This is here so that efficient versions of the comparison functions are available within this module. *) open! Replace_polymorphic_compare let to_string_hum = function | Neg -> "negative" | Zero -> "zero" | Pos -> "positive" ;; let to_float = function | Neg -> -1. | Zero -> 0. | Pos -> 1. ;; let flip = function | Neg -> Pos | Zero -> Zero | Pos -> Neg ;; let ( * ) t t' = of_int (to_int t * to_int t') (* Include type-specific [Replace_polymorphic_compare at the end, after any functor applications that could shadow its definitions. This is here so that efficient versions of the comparison functions are exported by this module. *) include Replace_polymorphic_compare base-0.16.3/src/sign.mli000066400000000000000000000015631446274340700147650ustar00rootroot00000000000000(** A type for representing the sign of a numeric value. *) open! Import type t = Sign0.t = | Neg | Zero | Pos [@@deriving_inline enumerate, sexp_grammar] include Ppx_enumerate_lib.Enumerable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] (** This provides [to_string]/[of_string], sexp conversion, Map, Hashtbl, etc. *) include Identifiable.S with type t := t (** Returns the human-readable strings "positive", "negative", "zero". *) val to_string_hum : t -> string val of_int : int -> t (** Map [Neg/Zero/Pos] to [-1/0/1] respectively. *) val to_int : t -> int (** Map [Neg/Zero/Pos] to [-1./0./1.] respectively. (There is no [of_float] here, but see {!Float.sign_exn}.) *) val to_float : t -> float (** Map [Neg/Zero/Pos] to [Pos/Zero/Neg] respectively. *) val flip : t -> t (** [Neg * Neg = Pos], etc. *) val ( * ) : t -> t -> t base-0.16.3/src/sign0.ml000066400000000000000000000066251446274340700147000ustar00rootroot00000000000000(* This is broken off to avoid circular dependency between Sign and Comparable. *) open! Import type t = | Neg | Zero | Pos [@@deriving_inline sexp, sexp_grammar, compare, hash, enumerate] let t_of_sexp = (let error_source__003_ = "sign0.ml.t" in function | Sexplib0.Sexp.Atom ("neg" | "Neg") -> Neg | Sexplib0.Sexp.Atom ("zero" | "Zero") -> Zero | Sexplib0.Sexp.Atom ("pos" | "Pos") -> Pos | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("neg" | "Neg") :: _) as sexp__004_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__003_ sexp__004_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("zero" | "Zero") :: _) as sexp__004_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__003_ sexp__004_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("pos" | "Pos") :: _) as sexp__004_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__003_ sexp__004_ | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__002_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__003_ sexp__002_ | Sexplib0.Sexp.List [] as sexp__002_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__003_ sexp__002_ | sexp__002_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__003_ sexp__002_ : Sexplib0.Sexp.t -> t) ;; let sexp_of_t = (function | Neg -> Sexplib0.Sexp.Atom "Neg" | Zero -> Sexplib0.Sexp.Atom "Zero" | Pos -> Sexplib0.Sexp.Atom "Pos" : t -> Sexplib0.Sexp.t) ;; let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "Neg"; clause_kind = Atom_clause } ; No_tag { name = "Zero"; clause_kind = Atom_clause } ; No_tag { name = "Pos"; clause_kind = Atom_clause } ] } } ;; let compare = (Stdlib.compare : t -> t -> int) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = (fun hsv arg -> match arg with | Neg -> Ppx_hash_lib.Std.Hash.fold_int hsv 0 | Zero -> Ppx_hash_lib.Std.Hash.fold_int hsv 1 | Pos -> Ppx_hash_lib.Std.Hash.fold_int hsv 2 : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) ;; let (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func arg = Ppx_hash_lib.Std.Hash.get_hash_value (let hsv = Ppx_hash_lib.Std.Hash.create () in hash_fold_t hsv arg) in fun x -> func x ;; let all = ([ Neg; Zero; Pos ] : t list) [@@@end] module Replace_polymorphic_compare = struct let ( < ) (x : t) y = Poly.( < ) x y let ( <= ) (x : t) y = Poly.( <= ) x y let ( <> ) (x : t) y = Poly.( <> ) x y let ( = ) (x : t) y = Poly.( = ) x y let ( > ) (x : t) y = Poly.( > ) x y let ( >= ) (x : t) y = Poly.( >= ) x y let ascending (x : t) y = Poly.ascending x y let descending (x : t) y = Poly.descending x y let compare (x : t) y = Poly.compare x y let equal (x : t) y = Poly.equal x y let max (x : t) y = if x >= y then x else y let min (x : t) y = if x <= y then x else y end let of_string s = t_of_sexp (sexp_of_string s) let to_string t = string_of_sexp (sexp_of_t t) let to_int = function | Neg -> -1 | Zero -> 0 | Pos -> 1 ;; let _ = hash (* Ignore the hash function produced by [@@deriving_inline hash] *) let hash = to_int let module_name = "Base.Sign" let of_int n = if n < 0 then Neg else if n = 0 then Zero else Pos base-0.16.3/src/sign_or_nan.ml000066400000000000000000000115341446274340700161470ustar00rootroot00000000000000open! Import module T = struct type t = | Neg | Zero | Pos | Nan [@@deriving_inline sexp, sexp_grammar, compare, hash, enumerate] let t_of_sexp = (let error_source__003_ = "sign_or_nan.ml.T.t" in function | Sexplib0.Sexp.Atom ("neg" | "Neg") -> Neg | Sexplib0.Sexp.Atom ("zero" | "Zero") -> Zero | Sexplib0.Sexp.Atom ("pos" | "Pos") -> Pos | Sexplib0.Sexp.Atom ("nan" | "Nan") -> Nan | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("neg" | "Neg") :: _) as sexp__004_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__003_ sexp__004_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("zero" | "Zero") :: _) as sexp__004_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__003_ sexp__004_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("pos" | "Pos") :: _) as sexp__004_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__003_ sexp__004_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("nan" | "Nan") :: _) as sexp__004_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__003_ sexp__004_ | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__002_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__003_ sexp__002_ | Sexplib0.Sexp.List [] as sexp__002_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__003_ sexp__002_ | sexp__002_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__003_ sexp__002_ : Sexplib0.Sexp.t -> t) ;; let sexp_of_t = (function | Neg -> Sexplib0.Sexp.Atom "Neg" | Zero -> Sexplib0.Sexp.Atom "Zero" | Pos -> Sexplib0.Sexp.Atom "Pos" | Nan -> Sexplib0.Sexp.Atom "Nan" : t -> Sexplib0.Sexp.t) ;; let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "Neg"; clause_kind = Atom_clause } ; No_tag { name = "Zero"; clause_kind = Atom_clause } ; No_tag { name = "Pos"; clause_kind = Atom_clause } ; No_tag { name = "Nan"; clause_kind = Atom_clause } ] } } ;; let compare = (Stdlib.compare : t -> t -> int) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = (fun hsv arg -> match arg with | Neg -> Ppx_hash_lib.Std.Hash.fold_int hsv 0 | Zero -> Ppx_hash_lib.Std.Hash.fold_int hsv 1 | Pos -> Ppx_hash_lib.Std.Hash.fold_int hsv 2 | Nan -> Ppx_hash_lib.Std.Hash.fold_int hsv 3 : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) ;; let (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func arg = Ppx_hash_lib.Std.Hash.get_hash_value (let hsv = Ppx_hash_lib.Std.Hash.create () in hash_fold_t hsv arg) in fun x -> func x ;; let all = ([ Neg; Zero; Pos; Nan ] : t list) [@@@end] let of_string s = t_of_sexp (sexp_of_string s) let to_string t = string_of_sexp (sexp_of_t t) let module_name = "Base.Sign_or_nan" end module Replace_polymorphic_compare = struct let ( < ) (x : T.t) y = Poly.( < ) x y let ( <= ) (x : T.t) y = Poly.( <= ) x y let ( <> ) (x : T.t) y = Poly.( <> ) x y let ( = ) (x : T.t) y = Poly.( = ) x y let ( > ) (x : T.t) y = Poly.( > ) x y let ( >= ) (x : T.t) y = Poly.( >= ) x y let ascending (x : T.t) y = Poly.ascending x y let descending (x : T.t) y = Poly.descending x y let compare (x : T.t) y = Poly.compare x y let equal (x : T.t) y = Poly.equal x y let max (x : T.t) y = if x >= y then x else y let min (x : T.t) y = if x <= y then x else y end include T include Identifiable.Make (T) (* Open [Replace_polymorphic_compare] after including functor applications so they do not shadow its definitions. This is here so that efficient versions of the comparison functions are available within this module. *) open! Replace_polymorphic_compare let of_sign = function | Sign.Neg -> Neg | Sign.Zero -> Zero | Sign.Pos -> Pos ;; let to_sign_exn = function | Neg -> Sign.Neg | Zero -> Sign.Zero | Pos -> Sign.Pos | Nan -> invalid_arg "Base.Sign_or_nan.to_sign_exn: Nan" ;; let of_int n = of_sign (Sign.of_int n) let to_int_exn t = Sign.to_int (to_sign_exn t) let flip = function | Neg -> Pos | Zero -> Zero | Pos -> Neg | Nan -> Nan ;; let ( * ) t t' = match t, t' with | Nan, _ | _, Nan -> Nan | _ -> of_sign (Sign.( * ) (to_sign_exn t) (to_sign_exn t')) ;; let to_string_hum = function | Neg -> "negative" | Zero -> "zero" | Pos -> "positive" | Nan -> "not-a-number" ;; (* Include [Replace_polymorphic_compare] at the end, after any functor applications that could shadow its definitions. This is here so that efficient versions of the comparison functions are exported by this module. *) include Replace_polymorphic_compare base-0.16.3/src/sign_or_nan.mli000066400000000000000000000017121446274340700163150ustar00rootroot00000000000000(** An extension to [Sign] with a [Nan] constructor, for representing the sign of float-like numeric values. *) open! Import type t = | Neg | Zero | Pos | Nan [@@deriving_inline enumerate, sexp_grammar] include Ppx_enumerate_lib.Enumerable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] (** This provides [to_string]/[of_string], sexp conversion, Map, Hashtbl, etc. *) include Identifiable.S with type t := t (** Returns the human-readable strings "positive", "negative", "zero", "not-a-number". *) val to_string_hum : t -> string val of_int : int -> t (** Map [Neg/Zero/Pos] to [-1/0/1] respectively. [Nan] raises. *) val to_int_exn : t -> int val of_sign : Sign.t -> t (** [Nan] raises. *) val to_sign_exn : t -> Sign.t (** Map [Neg/Zero/Pos/Nan] to [Pos/Zero/Neg/Nan] respectively. *) val flip : t -> t (** [Neg * Neg = Pos], etc. If either argument is [Nan] then the result is [Nan]. *) val ( * ) : t -> t -> t base-0.16.3/src/source_code_position.ml000066400000000000000000000010711446274340700200640ustar00rootroot00000000000000open! Import (* This is lifted out of [M] because [Source_code_position0] exports [String0] as [String], which does not export a hash function. *) let hash_override { Stdlib.Lexing.pos_fname; pos_lnum; pos_bol; pos_cnum } = String.hash pos_fname lxor Int.hash pos_lnum lxor Int.hash pos_bol lxor Int.hash pos_cnum ;; module M = struct include Source_code_position0 let hash = hash_override end include M include Comparable.Make_using_comparator (M) let of_pos (pos_fname, pos_lnum, pos_cnum, _) = { pos_fname; pos_lnum; pos_cnum; pos_bol = 0 } ;; base-0.16.3/src/source_code_position.mli000066400000000000000000000014761446274340700202460ustar00rootroot00000000000000(** One typically obtains a [Source_code_position.t] using a [[%here]] expression, which is implemented by the [ppx_here] preprocessor. *) open! Import (** See INRIA's OCaml documentation for a description of these fields. [sexp_of_t] uses the form ["FILE:LINE:COL"], and does not have a corresponding [of_sexp]. *) type t = Stdlib.Lexing.position = { pos_fname : string ; pos_lnum : int ; pos_bol : int ; pos_cnum : int } [@@deriving_inline hash, sexp_of] include Ppx_hash_lib.Hashable.S with type t := t val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] include Comparable.S with type t := t (** [to_string t] converts [t] to the form ["FILE:LINE:COL"]. *) val to_string : t -> string (** [of_pos Stdlib.__POS__] is like [[%here]] but without using ppx. *) val of_pos : string * int * int * int -> t base-0.16.3/src/source_code_position0.ml000066400000000000000000000056531446274340700201560ustar00rootroot00000000000000open! Import module Int = Int0 module String = String0 module T = struct type t = Stdlib.Lexing.position = { pos_fname : string ; pos_lnum : int ; pos_bol : int ; pos_cnum : int } [@@deriving_inline compare, hash, sexp_of] let compare = (fun a__001_ b__002_ -> if Stdlib.( == ) a__001_ b__002_ then 0 else ( match compare_string a__001_.pos_fname b__002_.pos_fname with | 0 -> (match compare_int a__001_.pos_lnum b__002_.pos_lnum with | 0 -> (match compare_int a__001_.pos_bol b__002_.pos_bol with | 0 -> compare_int a__001_.pos_cnum b__002_.pos_cnum | n -> n) | n -> n) | n -> n) : t -> t -> int) ;; let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = fun hsv arg -> let hsv = let hsv = let hsv = let hsv = hsv in hash_fold_string hsv arg.pos_fname in hash_fold_int hsv arg.pos_lnum in hash_fold_int hsv arg.pos_bol in hash_fold_int hsv arg.pos_cnum ;; let (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func arg = Ppx_hash_lib.Std.Hash.get_hash_value (let hsv = Ppx_hash_lib.Std.Hash.create () in hash_fold_t hsv arg) in fun x -> func x ;; let sexp_of_t = (fun { pos_fname = pos_fname__004_ ; pos_lnum = pos_lnum__006_ ; pos_bol = pos_bol__008_ ; pos_cnum = pos_cnum__010_ } -> let bnds__003_ = ([] : _ Stdlib.List.t) in let bnds__003_ = let arg__011_ = sexp_of_int pos_cnum__010_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "pos_cnum"; arg__011_ ] :: bnds__003_ : _ Stdlib.List.t) in let bnds__003_ = let arg__009_ = sexp_of_int pos_bol__008_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "pos_bol"; arg__009_ ] :: bnds__003_ : _ Stdlib.List.t) in let bnds__003_ = let arg__007_ = sexp_of_int pos_lnum__006_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "pos_lnum"; arg__007_ ] :: bnds__003_ : _ Stdlib.List.t) in let bnds__003_ = let arg__005_ = sexp_of_string pos_fname__004_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "pos_fname"; arg__005_ ] :: bnds__003_ : _ Stdlib.List.t) in Sexplib0.Sexp.List bnds__003_ : t -> Sexplib0.Sexp.t) ;; [@@@end] end include T include Comparator.Make (T) (* This is the same function as Ppx_here.lift_position_as_string. *) let make_location_string ~pos_fname ~pos_lnum ~pos_cnum ~pos_bol = String.concat [ pos_fname; ":"; Int.to_string pos_lnum; ":"; Int.to_string (pos_cnum - pos_bol) ] ;; let to_string { Stdlib.Lexing.pos_fname; pos_lnum; pos_cnum; pos_bol } = make_location_string ~pos_fname ~pos_lnum ~pos_cnum ~pos_bol ;; let sexp_of_t t = Sexp.Atom (to_string t) base-0.16.3/src/stack.ml000066400000000000000000000135021446274340700147550ustar00rootroot00000000000000open! Import include Stack_intf let raise_s = Error.raise_s (* This implementation is similar to [Deque] in that it uses an array of ['a] and a mutable [int] to indicate what in the array is used. We choose to implement [Stack] directly rather than on top of [Deque] for performance reasons. E.g. a simple microbenchmark shows that push/pop is about 20% faster. *) type 'a t = { mutable length : int ; mutable elts : 'a Option_array.t } [@@deriving_inline sexp_of] let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = fun _of_a__001_ { length = length__003_; elts = elts__005_ } -> let bnds__002_ = ([] : _ Stdlib.List.t) in let bnds__002_ = let arg__006_ = Option_array.sexp_of_t _of_a__001_ elts__005_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "elts"; arg__006_ ] :: bnds__002_ : _ Stdlib.List.t) in let bnds__002_ = let arg__004_ = sexp_of_int length__003_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "length"; arg__004_ ] :: bnds__002_ : _ Stdlib.List.t) in Sexplib0.Sexp.List bnds__002_ ;; [@@@end] let sexp_of_t_internal = sexp_of_t let sexp_of_t = `Rebound_later let _ = sexp_of_t let capacity t = Option_array.length t.elts let invariant invariant_a ({ length; elts } as t) : unit = try assert (0 <= length && length <= Option_array.length elts); for i = 0 to length - 1 do invariant_a (Option_array.get_some_exn elts i) done; (* We maintain the invariant that unused elements are unset to avoid a space leak. *) for i = length to Option_array.length elts - 1 do assert (not (Option_array.is_some elts i)) done with | exn -> raise_s (Sexp.message "Stack.invariant failed" [ "exn", exn |> Exn.sexp_of_t; "stack", t |> sexp_of_t_internal sexp_of_opaque ]) ;; let create (type a) () : a t = { length = 0; elts = Option_array.empty } let length t = t.length let is_empty t = length t = 0 (* The order in which elements are visited has been chosen so as to be backwards compatible with [Stdlib.Stack] *) let fold t ~init ~f = let r = ref init in for i = t.length - 1 downto 0 do r := f !r (Option_array.get_some_exn t.elts i) done; !r ;; let iter t ~f = for i = t.length - 1 downto 0 do f (Option_array.get_some_exn t.elts i) done ;; module C = Container.Make (struct type nonrec 'a t = 'a t let fold = fold let iter = `Custom iter let length = `Custom length end) let mem = C.mem let exists = C.exists let for_all = C.for_all let count = C.count let sum = C.sum let find = C.find let find_map = C.find_map let to_list = C.to_list let to_array = C.to_array let min_elt = C.min_elt let max_elt = C.max_elt let fold_result = C.fold_result let fold_until = C.fold_until let of_list (type a) (l : a list) = if List.is_empty l then create () else ( let length = List.length l in let elts = Option_array.create ~len:(2 * length) in let r = ref l in for i = length - 1 downto 0 do match !r with | [] -> assert false | a :: l -> Option_array.set_some elts i a; r := l done; { length; elts }) ;; let sexp_of_t sexp_of_a t = List.sexp_of_t sexp_of_a (to_list t) let t_of_sexp a_of_sexp sexp = of_list (List.t_of_sexp a_of_sexp sexp) let t_sexp_grammar (type a) (grammar : a Sexplib0.Sexp_grammar.t) : a t Sexplib0.Sexp_grammar.t = Sexplib0.Sexp_grammar.coerce (List.t_sexp_grammar grammar) ;; let resize t size = let arr = Option_array.create ~len:size in Option_array.blit ~src:t.elts ~dst:arr ~src_pos:0 ~dst_pos:0 ~len:t.length; t.elts <- arr ;; let set_capacity t new_capacity = let new_capacity = max new_capacity (length t) in if new_capacity <> capacity t then resize t new_capacity ;; let push t a = if t.length = Option_array.length t.elts then resize t (2 * (t.length + 1)); Option_array.set_some t.elts t.length a; t.length <- t.length + 1 ;; let pop_nonempty t = let i = t.length - 1 in let result = Option_array.get_some_exn t.elts i in Option_array.set_none t.elts i; t.length <- i; result ;; let pop_error = Error.of_string "Stack.pop of empty stack" let pop t = if is_empty t then None else Some (pop_nonempty t) let pop_exn t = if is_empty t then Error.raise pop_error else pop_nonempty t let top_nonempty t = Option_array.get_some_exn t.elts (t.length - 1) let top_error = Error.of_string "Stack.top of empty stack" let top t = if is_empty t then None else Some (top_nonempty t) let top_exn t = if is_empty t then Error.raise top_error else top_nonempty t let copy { length; elts } = { length; elts = Option_array.copy elts } let clear t = if t.length > 0 then ( for i = 0 to t.length - 1 do Option_array.set_none t.elts i done; t.length <- 0) ;; let until_empty t f = let rec loop () = if t.length > 0 then ( f (pop_nonempty t); loop ()) in loop () [@nontail] ;; let filter_map t ~f = let t_result = create () in for i = 0 to t.length - 1 do match f (Option_array.get_some_exn t.elts i) with | None -> () | Some x -> push t_result x done; t_result ;; let filter t ~f = let t_result = create () in for i = 0 to t.length - 1 do let x = Option_array.get_some_exn t.elts i in if f x then push t_result x done; t_result ;; let filter_inplace t ~f = let write_index = ref 0 in Exn.protect ~f:(fun () -> for read_index = 0 to t.length - 1 do let x = Option_array.unsafe_get_some_assuming_some t.elts read_index in if f x then ( if !write_index < read_index then Option_array.unsafe_set_some t.elts !write_index x; incr write_index) done) ~finally:(fun () -> for i = !write_index to t.length - 1 do Option_array.unsafe_set_none t.elts i done; t.length <- !write_index) [@nontail] ;; let singleton x = let t = create () in push t x; t ;; base-0.16.3/src/stack.mli000066400000000000000000000000501446274340700151200ustar00rootroot00000000000000include Stack_intf.Stack (** @inline *) base-0.16.3/src/stack_intf.ml000066400000000000000000000061721446274340700160020ustar00rootroot00000000000000(** An interface for stacks that follows [Core]'s conventions, as opposed to OCaml's standard [Stack] module. *) open! Import module type S = sig type 'a t [@@deriving_inline sexp, sexp_grammar] include Sexplib0.Sexpable.S1 with type 'a t := 'a t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] include Invariant.S1 with type 'a t := 'a t (** [fold], [iter], [find], and [find_map] visit the elements in order from the top of the stack to the bottom. [to_list] and [to_array] return the elements in order from the top of the stack to the bottom. Iteration functions ([iter], [fold], etc.) have unspecified behavior (although they should still be memory-safe) when the stack is mutated while they are running (e.g. by having the passed-in function call [push] or [pop] on the stack). *) include Container.S1 with type 'a t := 'a t (** [of_list l] returns a stack whose top is the first element of [l] and bottom is the last element of [l]. *) val of_list : 'a list -> 'a t (** [create ()] returns an empty stack. *) val create : unit -> _ t (** [singleton a] creates a new stack containing only [a]. *) val singleton : 'a -> 'a t (** [push t a] adds [a] to the top of stack [t]. *) val push : 'a t -> 'a -> unit (** [pop t] removes and returns the top element of [t] as [Some a], or returns [None] if [t] is empty. *) val pop : 'a t -> 'a option val pop_exn : 'a t -> 'a (** [top t] returns [Some a], where [a] is the top of [t], unless [is_empty t], in which case [top] returns [None]. *) val top : 'a t -> 'a option val top_exn : 'a t -> 'a (** [clear t] discards all elements from [t]. *) val clear : _ t -> unit (** [copy t] returns a copy of [t]. *) val copy : 'a t -> 'a t (** [until_empty t f] repeatedly pops an element [a] off of [t] and runs [f a], until [t] becomes empty. It is fine if [f] adds more elements to [t], in which case the most-recently-added element will be processed next. *) val until_empty : 'a t -> (('a -> unit)[@local]) -> unit (** [filter_map t ~f] creates a new stack with only the elements for which [f] returns [Some] *) val filter_map : 'a t -> f:(('a -> 'b option)[@local]) -> 'b t (** [filter t ~f] creates a new stack with only the elements that satisfy [f]. *) val filter : 'a t -> f:(('a -> bool)[@local]) -> 'a t (** [filter_inplace t ~f] removes all elements of [t] that don't satisfy [f]. *) val filter_inplace : 'a t -> f:(('a -> bool)[@local]) -> unit end (** A stack implemented with an array. The implementation will grow the array as necessary, and will never automatically shrink the array. One can use [set_capacity] to explicitly resize the array. *) module type Stack = sig module type S = S include S (** @open *) (** [capacity t] returns the length of the array backing [t]. *) val capacity : _ t -> int (** [set_capacity t capacity] sets the length of the array backing [t] to [max capacity (length t)]. To shrink as much as possible, do [set_capacity t 0]. *) val set_capacity : _ t -> int -> unit end base-0.16.3/src/staged.ml000066400000000000000000000001041446274340700151110ustar00rootroot00000000000000open! Import type 'a t = 'a let stage = Fn.id let unstage = Fn.id base-0.16.3/src/staged.mli000066400000000000000000000017411446274340700152720ustar00rootroot00000000000000(** A type for making staging explicit in the type of a function. For example, you might want to have a function that creates a function for allocating unique identifiers. Rather than using the type: {[ val make_id_allocator : unit -> unit -> int ]} you would have {[ val make_id_allocator : unit -> (unit -> int) Staged.t ]} Such a function could be defined as follows: {[ let make_id_allocator () = let ctr = ref 0 in stage (fun () -> incr ctr; !ctr) ]} and could be invoked as follows: {[ let (id1,id2) = let alloc = unstage (make_id_allocator ()) in (alloc (), alloc ()) ]} both {!stage} and {!unstage} functions are available in the toplevel namespace. (Note that in many cases, including perhaps the one above, it's preferable to create a custom type rather than use [Staged].) *) open! Import type +'a t val stage : 'a -> 'a t val unstage : 'a t -> 'a base-0.16.3/src/string.ml000066400000000000000000001662601446274340700151700ustar00rootroot00000000000000open! Import module Array = Array0 module Bytes = Bytes0 module Int = Int0 include String0 let invalid_argf = Printf.invalid_argf let raise_s = Error.raise_s let stage = Staged.stage module T = struct type t = string [@@deriving_inline globalize, hash, sexp, sexp_grammar] let (globalize : (t[@ocaml.local]) -> t) = (globalize_string : (t[@ocaml.local]) -> t) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = hash_fold_string and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = hash_string in fun x -> func x ;; let t_of_sexp = (string_of_sexp : Sexplib0.Sexp.t -> t) let sexp_of_t = (sexp_of_string : t -> Sexplib0.Sexp.t) let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = string_sexp_grammar [@@@end] let hashable : t Hashable.t = { hash; compare; sexp_of_t } let compare = compare end include T include Comparator.Make (T) type elt = char let invariant (_ : t) = () (* This is copied/adapted from 'blit.ml'. [sub], [subo] could be implemented using [Blit.Make(Bytes)] plus unsafe casts to/from string but were inlined here to avoid using [Bytes.unsafe_of_string] as much as possible. *) let unsafe_sub src ~pos ~len = if len = 0 then "" else ( let dst = Bytes.create len in Bytes.unsafe_blit_string ~src ~src_pos:pos ~dst ~dst_pos:0 ~len; Bytes.unsafe_to_string ~no_mutation_while_string_reachable:dst) ;; let sub src ~pos ~len = if pos = 0 && len = String.length src then src else ( Ordered_collection_common.check_pos_len_exn ~pos ~len ~total_length:(length src); unsafe_sub src ~pos ~len) ;; let subo ?(pos = 0) ?len src = sub src ~pos ~len: (match len with | Some i -> i | None -> length src - pos) ;; let rec contains_unsafe t ~pos ~end_ char = pos < end_ && (Char.equal (unsafe_get t pos) char || contains_unsafe t ~pos:(pos + 1) ~end_ char) ;; let contains ?(pos = 0) ?len t char = let total_length = String.length t in let len = Option.value len ~default:(total_length - pos) in Ordered_collection_common.check_pos_len_exn ~pos ~len ~total_length; contains_unsafe t ~pos ~end_:(pos + len) char ;; let is_empty t = length t = 0 let rec index_from_exn_internal string ~pos ~len ~not_found char = if pos >= len then raise not_found else if Char.equal (unsafe_get string pos) char then pos else index_from_exn_internal string ~pos:(pos + 1) ~len ~not_found char ;; let index_exn_internal t ~not_found char = index_from_exn_internal t ~pos:0 ~len:(length t) ~not_found char ;; let index_exn = let not_found = Not_found_s (Atom "String.index_exn: not found") in let index_exn t char = index_exn_internal t ~not_found char in (* named to preserve symbol in compiled binary *) index_exn ;; let index_from_exn = let not_found = Not_found_s (Atom "String.index_from_exn: not found") in let index_from_exn t pos char = let len = length t in if pos < 0 || pos > len then invalid_arg "String.index_from_exn" else index_from_exn_internal t ~pos ~len ~not_found char in (* named to preserve symbol in compiled binary *) index_from_exn ;; let rec rindex_from_exn_internal string ~pos ~len ~not_found char = if pos < 0 then raise not_found else if Char.equal (unsafe_get string pos) char then pos else rindex_from_exn_internal string ~pos:(pos - 1) ~len ~not_found char ;; let rindex_exn_internal t ~not_found char = let len = length t in rindex_from_exn_internal t ~pos:(len - 1) ~len ~not_found char ;; let rindex_exn = let not_found = Not_found_s (Atom "String.rindex_exn: not found") in let rindex_exn t char = rindex_exn_internal t ~not_found char in (* named to preserve symbol in compiled binary *) rindex_exn ;; let rindex_from_exn = let not_found = Not_found_s (Atom "String.rindex_from_exn: not found") in let rindex_from_exn t pos char = let len = length t in if pos < -1 || pos >= len then invalid_arg "String.rindex_from_exn" else rindex_from_exn_internal t ~pos ~len ~not_found char in (* named to preserve symbol in compiled binary *) rindex_from_exn ;; let index t char = try Some (index_exn t char) with | Not_found_s _ | Stdlib.Not_found -> None ;; let rindex t char = try Some (rindex_exn t char) with | Not_found_s _ | Stdlib.Not_found -> None ;; let index_from t pos char = try Some (index_from_exn t pos char) with | Not_found_s _ | Stdlib.Not_found -> None ;; let rindex_from t pos char = try Some (rindex_from_exn t pos char) with | Not_found_s _ | Stdlib.Not_found -> None ;; module Search_pattern0 = struct type t = { pattern : string ; case_sensitive : bool ; kmp_array : int array } let sexp_of_t { pattern; case_sensitive; kmp_array = _ } : Sexp.t = List [ List [ Atom "pattern"; sexp_of_string pattern ] ; List [ Atom "case_sensitive"; sexp_of_bool case_sensitive ] ] ;; let pattern t = t.pattern let case_sensitive t = t.case_sensitive (* Find max number of matched characters at [next_text_char], given the current [matched_chars]. Try to extend the current match, if chars don't match, try to match fewer chars. If chars match then extend the match. *) let kmp_internal_loop ~matched_chars ~next_text_char ~pattern ~kmp_array ~char_equal = let matched_chars = ref matched_chars in while !matched_chars > 0 && not (char_equal next_text_char (unsafe_get pattern !matched_chars)) do matched_chars := Array.unsafe_get kmp_array (!matched_chars - 1) done; if char_equal next_text_char (unsafe_get pattern !matched_chars) then matched_chars := !matched_chars + 1; !matched_chars ;; let get_char_equal ~case_sensitive = match case_sensitive with | true -> Char.equal | false -> Char.Caseless.equal ;; (* Classic KMP pre-processing of the pattern: build the int array, which, for each i, contains the length of the longest non-trivial prefix of s which is equal to a suffix ending at s.[i] *) let create pattern ~case_sensitive = let n = length pattern in let kmp_array = Array.create ~len:n (-1) in if n > 0 then ( let char_equal = get_char_equal ~case_sensitive in Array.unsafe_set kmp_array 0 0; let matched_chars = ref 0 in for i = 1 to n - 1 do matched_chars := kmp_internal_loop ~matched_chars:!matched_chars ~next_text_char:(unsafe_get pattern i) ~pattern ~kmp_array ~char_equal; Array.unsafe_set kmp_array i !matched_chars done); { pattern; case_sensitive; kmp_array } ;; (* Classic KMP: use the pre-processed pattern to optimize look-behinds on non-matches. We return int to avoid allocation in [index_exn]. -1 means no match. *) let index_internal ?(pos = 0) { pattern; case_sensitive; kmp_array } ~in_:text = if pos < 0 || pos > length text - length pattern then -1 else ( let char_equal = get_char_equal ~case_sensitive in let j = ref pos in let matched_chars = ref 0 in let k = length pattern in let n = length text in while !j < n && !matched_chars < k do let next_text_char = unsafe_get text !j in matched_chars := kmp_internal_loop ~matched_chars:!matched_chars ~next_text_char ~pattern ~kmp_array ~char_equal; j := !j + 1 done; if !matched_chars = k then !j - k else -1) ;; let matches t str = index_internal t ~in_:str >= 0 let index ?pos t ~in_ = let p = index_internal ?pos t ~in_ in if p < 0 then None else Some p ;; let index_exn ?pos t ~in_ = let p = index_internal ?pos t ~in_ in if p >= 0 then p else raise_s (Sexp.message "Substring not found" [ "substring", sexp_of_string t.pattern ]) ;; let index_all { pattern; case_sensitive; kmp_array } ~may_overlap ~in_:text = if length pattern = 0 then List.init (1 + length text) ~f:Fn.id else ( let char_equal = get_char_equal ~case_sensitive in let matched_chars = ref 0 in let k = length pattern in let n = length text in let found = ref [] in for j = 0 to n do if !matched_chars = k then ( found := (j - k) :: !found; (* we just found a match in the previous iteration *) match may_overlap with | true -> matched_chars := Array.unsafe_get kmp_array (k - 1) | false -> matched_chars := 0); if j < n then ( let next_text_char = unsafe_get text j in matched_chars := kmp_internal_loop ~matched_chars:!matched_chars ~next_text_char ~pattern ~kmp_array ~char_equal) done; List.rev !found) ;; let replace_first ?pos t ~in_:s ~with_ = match index ?pos t ~in_:s with | None -> s | Some i -> let len_s = length s in let len_t = length t.pattern in let len_with = length with_ in let dst = Bytes.create (len_s + len_with - len_t) in Bytes.blit_string ~src:s ~src_pos:0 ~dst ~dst_pos:0 ~len:i; Bytes.blit_string ~src:with_ ~src_pos:0 ~dst ~dst_pos:i ~len:len_with; Bytes.blit_string ~src:s ~src_pos:(i + len_t) ~dst ~dst_pos:(i + len_with) ~len:(len_s - i - len_t); Bytes.unsafe_to_string ~no_mutation_while_string_reachable:dst ;; let replace_all t ~in_:s ~with_ = let matches = index_all t ~may_overlap:false ~in_:s in match matches with | [] -> s | _ :: _ -> let len_s = length s in let len_t = length t.pattern in let len_with = length with_ in let num_matches = List.length matches in let dst = Bytes.create (len_s + ((len_with - len_t) * num_matches)) in let next_dst_pos = ref 0 in let next_src_pos = ref 0 in List.iter matches ~f:(fun i -> let len = i - !next_src_pos in Bytes.blit_string ~src:s ~src_pos:!next_src_pos ~dst ~dst_pos:!next_dst_pos ~len; Bytes.blit_string ~src:with_ ~src_pos:0 ~dst ~dst_pos:(!next_dst_pos + len) ~len:len_with; next_dst_pos := !next_dst_pos + len + len_with; next_src_pos := !next_src_pos + len + len_t); Bytes.blit_string ~src:s ~src_pos:!next_src_pos ~dst ~dst_pos:!next_dst_pos ~len:(len_s - !next_src_pos); Bytes.unsafe_to_string ~no_mutation_while_string_reachable:dst ;; let split_on t s = let pattern_len = String.length t.pattern in let matches = index_all t ~may_overlap:false ~in_:s in List.map2_exn (-pattern_len :: matches) (matches @ [ String.length s ]) ~f:(fun i j -> sub s ~pos:(i + pattern_len) ~len:(j - i - pattern_len)) ;; module Private = struct type public = t type nonrec t = t = { pattern : string ; case_sensitive : bool ; kmp_array : int array } [@@deriving_inline equal, sexp_of] let equal = (fun a__003_ b__004_ -> if Stdlib.( == ) a__003_ b__004_ then true else Stdlib.( && ) (equal_string a__003_.pattern b__004_.pattern) (Stdlib.( && ) (equal_bool a__003_.case_sensitive b__004_.case_sensitive) (equal_array equal_int a__003_.kmp_array b__004_.kmp_array)) : t -> t -> bool) ;; let sexp_of_t = (fun { pattern = pattern__008_ ; case_sensitive = case_sensitive__010_ ; kmp_array = kmp_array__012_ } -> let bnds__007_ = ([] : _ Stdlib.List.t) in let bnds__007_ = let arg__013_ = sexp_of_array sexp_of_int kmp_array__012_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "kmp_array"; arg__013_ ] :: bnds__007_ : _ Stdlib.List.t) in let bnds__007_ = let arg__011_ = sexp_of_bool case_sensitive__010_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "case_sensitive"; arg__011_ ] :: bnds__007_ : _ Stdlib.List.t) in let bnds__007_ = let arg__009_ = sexp_of_string pattern__008_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "pattern"; arg__009_ ] :: bnds__007_ : _ Stdlib.List.t) in Sexplib0.Sexp.List bnds__007_ : t -> Sexplib0.Sexp.t) ;; [@@@end] let representation = Fn.id end end module Search_pattern_helper = struct module Search_pattern = Search_pattern0 end open Search_pattern_helper let substr_index_gen ~case_sensitive ?pos t ~pattern = Search_pattern.index ?pos (Search_pattern.create ~case_sensitive pattern) ~in_:t ;; let substr_index_exn_gen ~case_sensitive ?pos t ~pattern = Search_pattern.index_exn ?pos (Search_pattern.create ~case_sensitive pattern) ~in_:t ;; let substr_index_all_gen ~case_sensitive t ~may_overlap ~pattern = Search_pattern.index_all (Search_pattern.create ~case_sensitive pattern) ~may_overlap ~in_:t ;; let substr_replace_first_gen ~case_sensitive ?pos t ~pattern = Search_pattern.replace_first ?pos (Search_pattern.create ~case_sensitive pattern) ~in_:t ;; let substr_replace_all_gen ~case_sensitive t ~pattern = Search_pattern.replace_all (Search_pattern.create ~case_sensitive pattern) ~in_:t ;; let is_substring_gen ~case_sensitive t ~substring = Option.is_some (substr_index_gen t ~pattern:substring ~case_sensitive) ;; let substr_index = substr_index_gen ~case_sensitive:true let substr_index_exn = substr_index_exn_gen ~case_sensitive:true let substr_index_all = substr_index_all_gen ~case_sensitive:true let substr_replace_first = substr_replace_first_gen ~case_sensitive:true let substr_replace_all = substr_replace_all_gen ~case_sensitive:true let is_substring = is_substring_gen ~case_sensitive:true let is_substring_at_gen = let rec loop ~str ~str_pos ~sub ~sub_pos ~sub_len ~char_equal = if sub_pos = sub_len then true else if char_equal (unsafe_get str str_pos) (unsafe_get sub sub_pos) then loop ~str ~str_pos:(str_pos + 1) ~sub ~sub_pos:(sub_pos + 1) ~sub_len ~char_equal else false in fun str ~pos:str_pos ~substring:sub ~char_equal -> let str_len = length str in let sub_len = length sub in if str_pos < 0 || str_pos > str_len then invalid_argf "String.is_substring_at: invalid index %d for string of length %d" str_pos str_len (); str_pos + sub_len <= str_len && loop ~str ~str_pos ~sub ~sub_pos:0 ~sub_len ~char_equal ;; let is_suffix_gen string ~suffix ~char_equal = let string_len = length string in let suffix_len = length suffix in string_len >= suffix_len && is_substring_at_gen string ~pos:(string_len - suffix_len) ~substring:suffix ~char_equal ;; let is_prefix_gen string ~prefix ~char_equal = let string_len = length string in let prefix_len = length prefix in string_len >= prefix_len && is_substring_at_gen string ~pos:0 ~substring:prefix ~char_equal ;; module Caseless = struct module T = struct type t = string [@@deriving_inline sexp, sexp_grammar] let t_of_sexp = (string_of_sexp : Sexplib0.Sexp.t -> t) let sexp_of_t = (sexp_of_string : t -> Sexplib0.Sexp.t) let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = string_sexp_grammar [@@@end] let char_compare_caseless c1 c2 = Char.compare (Char.lowercase c1) (Char.lowercase c2) let rec compare_loop ~pos ~string1 ~len1 ~string2 ~len2 = if pos = len1 then if pos = len2 then 0 else -1 else if pos = len2 then 1 else ( let c = char_compare_caseless (unsafe_get string1 pos) (unsafe_get string2 pos) in match c with | 0 -> compare_loop ~pos:(pos + 1) ~string1 ~len1 ~string2 ~len2 | _ -> c) ;; let compare string1 string2 = if phys_equal string1 string2 then 0 else compare_loop ~pos:0 ~string1 ~len1:(String.length string1) ~string2 ~len2:(String.length string2) ;; let hash_fold_t state t = let len = length t in let state = ref (hash_fold_int state len) in for pos = 0 to len - 1 do state := hash_fold_char !state (Char.lowercase (unsafe_get t pos)) done; !state ;; let hash t = Hash.run hash_fold_t t let is_suffix s ~suffix = is_suffix_gen s ~suffix ~char_equal:Char.Caseless.equal let is_prefix s ~prefix = is_prefix_gen s ~prefix ~char_equal:Char.Caseless.equal let substr_index = substr_index_gen ~case_sensitive:false let substr_index_exn = substr_index_exn_gen ~case_sensitive:false let substr_index_all = substr_index_all_gen ~case_sensitive:false let substr_replace_first = substr_replace_first_gen ~case_sensitive:false let substr_replace_all = substr_replace_all_gen ~case_sensitive:false let is_substring = is_substring_gen ~case_sensitive:false let is_substring_at = is_substring_at_gen ~char_equal:Char.Caseless.equal end include T include Comparable.Make (T) end let of_string = Fn.id let to_string = Fn.id let init n ~f = if n < 0 then invalid_argf "String.init %d" n (); let t = Bytes.create n in for i = 0 to n - 1 do Bytes.set t i (f i) done; Bytes.unsafe_to_string ~no_mutation_while_string_reachable:t ;; let to_list s = let rec loop acc i = if i < 0 then acc else loop (s.[i] :: acc) (i - 1) in loop [] (length s - 1) ;; let to_list_rev s = let len = length s in let rec loop acc i = if i = len then acc else loop (s.[i] :: acc) (i + 1) in loop [] 0 ;; let rev t = let len = length t in let res = Bytes.create len in for i = 0 to len - 1 do Bytes.unsafe_set res i (unsafe_get t (len - 1 - i)) done; Bytes.unsafe_to_string ~no_mutation_while_string_reachable:res ;; (** Efficient string splitting *) let lsplit2_exn = let not_found = Not_found_s (Atom "String.lsplit2_exn: not found") in let lsplit2_exn line ~on:delim = let pos = index_exn_internal line ~not_found delim in sub line ~pos:0 ~len:pos, sub line ~pos:(pos + 1) ~len:(length line - pos - 1) in (* named to preserve symbol in compiled binary *) lsplit2_exn ;; let rsplit2_exn = let not_found = Not_found_s (Atom "String.rsplit2_exn: not found") in let rsplit2_exn line ~on:delim = let pos = rindex_exn_internal line ~not_found delim in sub line ~pos:0 ~len:pos, sub line ~pos:(pos + 1) ~len:(length line - pos - 1) in (* named to preserve symbol in compiled binary *) rsplit2_exn ;; let lsplit2 line ~on = try Some (lsplit2_exn line ~on) with | Not_found_s _ | Stdlib.Not_found -> None ;; let rsplit2 line ~on = try Some (rsplit2_exn line ~on) with | Not_found_s _ | Stdlib.Not_found -> None ;; let rec char_list_mem l (c : char) = match l with | [] -> false | hd :: tl -> Char.equal hd c || char_list_mem tl c ;; let split_gen str ~on = let is_delim = match on with | `char c' -> fun c -> Char.equal c c' | `char_list l -> fun c -> char_list_mem l c in let len = length str in let rec loop acc last_pos pos = if pos = -1 then sub str ~pos:0 ~len:last_pos :: acc else if is_delim str.[pos] then ( let pos1 = pos + 1 in let sub_str = sub str ~pos:pos1 ~len:(last_pos - pos1) in loop (sub_str :: acc) pos (pos - 1)) else loop acc last_pos (pos - 1) in loop [] len (len - 1) ;; let split str ~on = split_gen str ~on:(`char on) let split_on_chars str ~on:chars = split_gen str ~on:(`char_list chars) let split_lines = let back_up_at_newline ~t ~pos ~eol = pos := !pos - if !pos > 0 && Char.equal t.[!pos - 1] '\r' then 2 else 1; eol := !pos + 1 in fun t -> let n = length t in if n = 0 then [] else ( (* Invariant: [-1 <= pos < eol]. *) let pos = ref (n - 1) in let eol = ref n in let ac = ref [] in (* We treat the end of the string specially, because if the string ends with a newline, we don't want an extra empty string at the end of the output. *) if Char.equal t.[!pos] '\n' then back_up_at_newline ~t ~pos ~eol; while !pos >= 0 do if Char.( <> ) t.[!pos] '\n' then decr pos else ( (* Because [pos < eol], we know that [start <= eol]. *) let start = !pos + 1 in ac := sub t ~pos:start ~len:(!eol - start) :: !ac; back_up_at_newline ~t ~pos ~eol) done; sub t ~pos:0 ~len:!eol :: !ac) ;; let is_suffix s ~suffix = is_suffix_gen s ~suffix ~char_equal:Char.equal let is_prefix s ~prefix = is_prefix_gen s ~prefix ~char_equal:Char.equal let is_substring_at s ~pos ~substring = is_substring_at_gen s ~pos ~substring ~char_equal:Char.equal ;; let wrap_sub_n t n ~name ~pos ~len ~on_error = if n < 0 then invalid_arg (name ^ " expecting nonnegative argument") else ( try sub t ~pos ~len with | _ -> on_error) ;; let drop_prefix t n = wrap_sub_n ~name:"drop_prefix" t n ~pos:n ~len:(length t - n) ~on_error:"" ;; let drop_suffix t n = wrap_sub_n ~name:"drop_suffix" t n ~pos:0 ~len:(length t - n) ~on_error:"" ;; let prefix t n = wrap_sub_n ~name:"prefix" t n ~pos:0 ~len:n ~on_error:t let suffix t n = wrap_sub_n ~name:"suffix" t n ~pos:(length t - n) ~len:n ~on_error:t let lfindi ?(pos = 0) t ~f = let n = length t in let rec loop i = if i = n then None else if f i t.[i] then Some i else loop (i + 1) in loop pos [@nontail] ;; let find t ~f = match lfindi t ~f:(fun _ c -> f c) with | None -> None | Some i -> Some t.[i] ;; let find_map t ~f = let n = length t in let rec loop i = if i = n then None else ( match f t.[i] with | None -> loop (i + 1) | Some _ as res -> res) in loop 0 [@nontail] ;; let rfindi ?pos t ~f = let rec loop i = if i < 0 then None else if f i t.[i] then Some i else loop (i - 1) in let pos = match pos with | Some pos -> pos | None -> length t - 1 in loop pos [@nontail] ;; let last_non_drop ~drop t = rfindi t ~f:(fun _ c -> not (drop c)) [@nontail] let rstrip ?(drop = Char.is_whitespace) t = match last_non_drop t ~drop with | None -> "" | Some i -> if i = length t - 1 then t else prefix t (i + 1) ;; let first_non_drop ~drop t = lfindi t ~f:(fun _ c -> not (drop c)) [@nontail] let lstrip ?(drop = Char.is_whitespace) t = match first_non_drop t ~drop with | None -> "" | Some 0 -> t | Some n -> drop_prefix t n ;; (* [strip t] could be implemented as [lstrip (rstrip t)]. The implementation below saves (at least) a factor of two allocation, by only allocating the final result. This also saves some amount of time. *) let strip ?(drop = Char.is_whitespace) t = let length = length t in if length = 0 || not (drop t.[0] || drop t.[length - 1]) then t else ( match first_non_drop t ~drop with | None -> "" | Some first -> (match last_non_drop t ~drop with | None -> assert false | Some last -> sub t ~pos:first ~len:(last - first + 1))) ;; let mapi t ~f = let l = length t in let t' = Bytes.create l in for i = 0 to l - 1 do Bytes.unsafe_set t' i (f i t.[i]) done; Bytes.unsafe_to_string ~no_mutation_while_string_reachable:t' ;; (* repeated code to avoid requiring an extra allocation for a closure on each call. *) let map t ~f = let l = length t in let t' = Bytes.create l in for i = 0 to l - 1 do Bytes.unsafe_set t' i (f t.[i]) done; Bytes.unsafe_to_string ~no_mutation_while_string_reachable:t' ;; let to_array s = Array.init (length s) ~f:(fun i -> s.[i]) let exists = let rec loop s i ~len ~f = i < len && (f s.[i] || loop s (i + 1) ~len ~f) in fun s ~f -> loop s 0 ~len:(length s) ~f ;; let for_all = let rec loop s i ~len ~f = i = len || (f s.[i] && loop s (i + 1) ~len ~f) in fun s ~f -> loop s 0 ~len:(length s) ~f ;; let fold = let rec loop t i ac ~f ~len = if i = len then ac else loop t (i + 1) (f ac t.[i]) ~f ~len in fun t ~init ~f -> loop t 0 init ~f ~len:(length t) ;; let foldi = let rec loop t i ac ~f ~len = if i = len then ac else loop t (i + 1) (f i ac t.[i]) ~f ~len in fun t ~init ~f -> loop t 0 init ~f ~len:(length t) ;; let iteri t ~f = for i = 0 to length t - 1 do f i (unsafe_get t i) done ;; let count t ~f = Container.count ~fold t ~f let sum m t ~f = Container.sum ~fold m t ~f let min_elt t = Container.min_elt ~fold t let max_elt t = Container.max_elt ~fold t let fold_result t ~init ~f = Container.fold_result ~fold ~init ~f t let fold_until t ~init ~f ~finish = Container.fold_until ~fold ~init ~f t ~finish let find_mapi t ~f = Indexed_container.find_mapi ~iteri t ~f let findi t ~f = Indexed_container.findi ~iteri t ~f let counti t ~f = Indexed_container.counti ~foldi t ~f let for_alli t ~f = Indexed_container.for_alli ~iteri t ~f let existsi t ~f = Indexed_container.existsi ~iteri t ~f let mem = let rec loop t c ~pos:i ~len = i < len && (Char.equal c (unsafe_get t i) || loop t c ~pos:(i + 1) ~len) in fun t c -> loop t c ~pos:0 ~len:(length t) ;; let tr ~target ~replacement s = if Char.equal target replacement then s else if mem s target then map s ~f:(fun c -> if Char.equal c target then replacement else c) else s ;; let tr_multi ~target ~replacement = if is_empty target then stage Fn.id else if is_empty replacement then invalid_arg "tr_multi replacement is empty string" else ( match Bytes_tr.tr_create_map ~target ~replacement with | None -> stage Fn.id | Some tr_map -> stage (fun s -> if exists s ~f:(fun c -> Char.( <> ) c (unsafe_get tr_map (Char.to_int c))) then map s ~f:(fun c -> unsafe_get tr_map (Char.to_int c)) else s)) ;; (* fast version, if we ever need it: {[ let concat_array ~sep ar = let ar_len = Array.length ar in if ar_len = 0 then "" else let sep_len = length sep in let res_len_ref = ref (sep_len * (ar_len - 1)) in for i = 0 to ar_len - 1 do res_len_ref := !res_len_ref + length ar.(i) done; let res = create !res_len_ref in let str_0 = ar.(0) in let len_0 = length str_0 in blit ~src:str_0 ~src_pos:0 ~dst:res ~dst_pos:0 ~len:len_0; let pos_ref = ref len_0 in for i = 1 to ar_len - 1 do let pos = !pos_ref in blit ~src:sep ~src_pos:0 ~dst:res ~dst_pos:pos ~len:sep_len; let new_pos = pos + sep_len in let str_i = ar.(i) in let len_i = length str_i in blit ~src:str_i ~src_pos:0 ~dst:res ~dst_pos:new_pos ~len:len_i; pos_ref := new_pos + len_i done; res ]} *) let concat_array ?sep ar = concat ?sep (Array.to_list ar) let concat_map ?sep s ~f = concat_array ?sep (Array.map (to_array s) ~f) let concat_mapi ?sep t ~f = concat_array ?sep (Array.mapi (to_array t) ~f) let concat_lines = let rec line_lengths ~lines ~newline_len ~sum = match lines with | [] -> sum | line :: lines -> let sum = sum + String.length line + newline_len in line_lengths ~lines ~newline_len ~sum in let rec write_lines ~buf ~lines ~crlf ~pos = match lines with | [] -> pos | line :: lines -> Bytes.unsafe_blit_string ~src:line ~src_pos:0 ~dst:buf ~dst_pos:pos ~len:(String.length line); let pos = pos + String.length line in let pos = if crlf then ( Bytes.unsafe_set buf pos '\r'; pos + 1) else pos in Bytes.unsafe_set buf pos '\n'; let pos = pos + 1 in write_lines ~buf ~lines ~crlf ~pos in fun ?(crlf = false) lines -> let newline_len = if crlf then 2 else 1 in let len = line_lengths ~newline_len ~lines ~sum:0 in let buf = Bytes.create len in let written = write_lines ~buf ~lines ~crlf ~pos:0 in assert (written = len); Bytes.unsafe_to_string ~no_mutation_while_string_reachable:buf ;; (* [filter t f] is implemented by the following algorithm. Let [n = length t]. 1. Find the lowest [i] such that [not (f t.[i])]. 2. If there is no such [i], then return [t]. 3. If there is such an [i], allocate a string, [out], to hold the result. [out] has length [n - 1], which is the maximum possible output size given that there is at least one character not satisfying [f]. 4. Copy characters at indices 0 ... [i - 1] from [t] to [out]. 5. Walk through characters at indices [i+1] ... [n-1] of [t], copying those that satisfy [f] from [t] to [out]. 6. If we completely filled [out], then return it. If not, return the prefix of [out] that we did fill in. This algorithm has the property that it doesn't allocate a new string if there's nothing to filter, which is a common case. *) let filter t ~f = let n = length t in let i = ref 0 in while !i < n && f t.[!i] do incr i done; if !i = n then t else ( let out = Bytes.create (n - 1) in Bytes.blit_string ~src:t ~src_pos:0 ~dst:out ~dst_pos:0 ~len:!i; let out_pos = ref !i in incr i; while !i < n do let c = t.[!i] in if f c then ( Bytes.set out !out_pos c; incr out_pos); incr i done; let out = Bytes.unsafe_to_string ~no_mutation_while_string_reachable:out in if !out_pos = n - 1 then out else sub out ~pos:0 ~len:!out_pos) ;; (* repeated code to avoid requiring an extra allocation for a closure on each call. *) let filteri t ~f = let n = length t in let i = ref 0 in while !i < n && f !i t.[!i] do incr i done; if !i = n then t else ( let out = Bytes.create (n - 1) in Bytes.blit_string ~src:t ~src_pos:0 ~dst:out ~dst_pos:0 ~len:!i; let out_pos = ref !i in incr i; while !i < n do let c = t.[!i] in if f !i c then ( Bytes.set out !out_pos c; incr out_pos); incr i done; let out = Bytes.unsafe_to_string ~no_mutation_while_string_reachable:out in if !out_pos = n - 1 then out else sub out ~pos:0 ~len:!out_pos) ;; let chop_prefix s ~prefix = if is_prefix s ~prefix then Some (drop_prefix s (length prefix)) else None ;; let chop_prefix_if_exists s ~prefix = if is_prefix s ~prefix then drop_prefix s (length prefix) else s ;; let chop_prefix_exn s ~prefix = match chop_prefix s ~prefix with | Some str -> str | None -> invalid_argf "String.chop_prefix_exn %S %S" s prefix () ;; let chop_suffix s ~suffix = if is_suffix s ~suffix then Some (drop_suffix s (length suffix)) else None ;; let chop_suffix_if_exists s ~suffix = if is_suffix s ~suffix then drop_suffix s (length suffix) else s ;; let chop_suffix_exn s ~suffix = match chop_suffix s ~suffix with | Some str -> str | None -> invalid_argf "String.chop_suffix_exn %S %S" s suffix () ;; module For_common_prefix_and_suffix = struct (* When taking a string prefix or suffix, we extract from the shortest input available in case we can just return one of our inputs without allocating a new string. *) let shorter a b = if length a <= length b then a else b let shortest list = match list with | [] -> "" | first :: rest -> List.fold rest ~init:first ~f:shorter ;; (* Our generic accessors for common prefix/suffix abstract over [get_pos], which is either [pos_from_left] or [pos_from_right]. *) let pos_from_left (_ : t) (i : int) = i let pos_from_right t i = length t - i - 1 let rec common_generic2_length_loop a b ~get_pos ~max_len ~len_so_far = if len_so_far >= max_len then max_len else if Char.equal (unsafe_get a (get_pos a len_so_far)) (unsafe_get b (get_pos b len_so_far)) then common_generic2_length_loop a b ~get_pos ~max_len ~len_so_far:(len_so_far + 1) else len_so_far ;; let common_generic2_length a b ~get_pos = let max_len = min (length a) (length b) in common_generic2_length_loop a b ~get_pos ~max_len ~len_so_far:0 ;; let rec common_generic_length_loop first list ~get_pos ~max_len = match list with | [] -> max_len | second :: rest -> let max_len = (* We call [common_generic2_length_loop] rather than [common_generic2_length] so that [max_len] limits our traversal of [first] and [second]. *) common_generic2_length_loop first second ~get_pos ~max_len ~len_so_far:0 in common_generic_length_loop second rest ~get_pos ~max_len ;; let common_generic_length list ~get_pos = match list with | [] -> 0 | first :: rest -> (* Precomputing [max_len] based on [shortest list] saves us work in longer strings, at the cost of an extra pass over the spine of [list]. For example, if you're looking for the longest prefix of the strings: {v let long_a = List.init 1000 ~f:(Fn.const 'a') [ long_a; long_a; 'aa' ] v} the approach below will just check the first two characters of all the strings. *) let max_len = length (shortest list) in common_generic_length_loop first rest ~get_pos ~max_len ;; (* Our generic accessors that produce a string abstract over [take], which is either [prefix] or [suffix]. *) let common_generic2 a b ~get_pos ~take = let len = common_generic2_length a b ~get_pos in (* Use the shorter of the two strings, so that if the shorter one is the shared prefix, [take] won't allocate another string. *) take (shorter a b) len ;; let common_generic list ~get_pos ~take = match list with | [] -> "" | first :: rest -> (* As with [common_generic_length], we base [max_len] on [shortest list]. We also use this result for [take], below, to potentially avoid allocating a string. *) let s = shortest list in let max_len = length s in if max_len = 0 then "" else ( let len = (* We call directly into [common_generic_length_loop] rather than [common_generic_length] to avoid recomputing [shortest list]. *) common_generic_length_loop first rest ~get_pos ~max_len in take s len) ;; end include struct open For_common_prefix_and_suffix let common_prefix list = common_generic list ~take:prefix ~get_pos:pos_from_left let common_suffix list = common_generic list ~take:suffix ~get_pos:pos_from_right let common_prefix2 a b = common_generic2 a b ~take:prefix ~get_pos:pos_from_left let common_suffix2 a b = common_generic2 a b ~take:suffix ~get_pos:pos_from_right let common_prefix_length list = common_generic_length list ~get_pos:pos_from_left let common_suffix_length list = common_generic_length list ~get_pos:pos_from_right let common_prefix2_length a b = common_generic2_length a b ~get_pos:pos_from_left let common_suffix2_length a b = common_generic2_length a b ~get_pos:pos_from_right end (* There used to be a custom implementation that was faster for very short strings (peaking at 40% faster for 4-6 char long strings). This new function is around 20% faster than the default hash function, but slower than the previous custom implementation. However, the new OCaml function is well behaved, and this implementation is less likely to diverge from the default OCaml implementation does, which is a desirable property. (The only way to avoid the divergence is to expose the macro redefined in hash_stubs.c in the hash.h header of the OCaml compiler.) *) module Hash = struct external hash : string -> int = "Base_hash_string" [@@noalloc] end (* [include Hash] to make the [external] version override the [hash] from [Hashable.Make_binable], so that we get a little bit of a speedup by exposing it as external in the mli. *) let _ = hash include Hash (* for interactive top-levels -- modules deriving from String should have String's pretty printer. *) let pp ppf string = Stdlib.Format.fprintf ppf "%S" string let of_char c = make 1 c let of_char_list l = let t = Bytes.create (List.length l) in List.iteri l ~f:(fun i c -> Bytes.set t i c); Bytes.unsafe_to_string ~no_mutation_while_string_reachable:t ;; let of_list = of_char_list let of_array a = init (Array.length a) ~f:(Array.get a) let append = ( ^ ) let pad_right ?(char = ' ') s ~len = let src_len = length s in if src_len >= len then s else ( let res = Bytes.create len in Bytes.blit_string ~src:s ~dst:res ~src_pos:0 ~dst_pos:0 ~len:src_len; Bytes.fill ~pos:src_len ~len:(len - src_len) res char; Bytes.unsafe_to_string ~no_mutation_while_string_reachable:res) ;; let pad_left ?(char = ' ') s ~len = let src_len = length s in if src_len >= len then s else ( let res = Bytes.create len in Bytes.blit_string ~src:s ~dst:res ~src_pos:0 ~dst_pos:(len - src_len) ~len:src_len; Bytes.fill ~pos:0 ~len:(len - src_len) res char; Bytes.unsafe_to_string ~no_mutation_while_string_reachable:res) ;; (* Called upon first difference generated by filtering. Allocates [buffer_len] bytes for new result, and copies [prefix_len] unchanged characters from [src]. Always returns a local buffer. *) let local_copy_prefix (src [@local]) ~prefix_len ~buffer_len = let dst = Bytes.create_local buffer_len in Bytes.Primitives.unsafe_blit_string ~src ~dst ~src_pos:0 ~dst_pos:0 ~len:prefix_len; dst ;; (* Copies a perhaps-local buffer into a definitely-global string. *) let local_copy_to_string (buf [@local]) ~pos = let str = Bytes.unsafe_to_string ~no_mutation_while_string_reachable:buf in unsafe_sub str ~pos:0 ~len:pos [@nontail] ;; include struct open struct (* filter_map helpers *) (* Filters from string [src] into an allocated buffer [dst]; copies the allocated buffer to a heap-allocated result string. Pre-conditions: [src_len = length src] [src != dst] [0 <= src_pos < src_len] [0 <= dst_pos < length dst] *) let filter_mapi_into src (dst [@local]) ~f ~src_pos ~dst_pos ~src_len = let dst_pos = (ref dst_pos) in for src_pos = src_pos to src_len - 1 do match f src_pos (unsafe_get src src_pos) with | None -> () | Some c -> Bytes.unsafe_set dst !dst_pos c; incr dst_pos done; local_copy_to_string dst ~pos:!dst_pos ;; (* Filters [t]. If the result turns out to be identical to the input, returns [t] directly without needing to allocate a buffer and traverse the string twice. Pre-condition: [len == length t] Pre-condition: [0 <= pos <= len] *) let rec filter_mapi_maybe_id t ~f ~pos ~len = if pos = len then t else ( let c1 = unsafe_get t pos in let next = Int.succ pos in match f pos c1 with | Some c2 when Char.equal c1 c2 -> (* if nothing has changed, continue *) filter_mapi_maybe_id t ~f ~pos:next ~len | option -> (* If a character has been changed or dropped, begin an output buffer up to [pos], and write the new character into it. *) let copy = local_copy_prefix t ~prefix_len:pos ~buffer_len:len in let dst_pos = match option with | None -> pos | Some c -> Bytes.unsafe_set copy pos c; next in filter_mapi_into t copy ~f ~src_pos:next ~dst_pos ~src_len:len [@nontail]) ;; end (* filter_map functions *) let filter_mapi t ~f = filter_mapi_maybe_id t ~f ~pos:0 ~len:(length t) let filter_map t ~f = filter_mapi t ~f:(fun _ c -> f c) [@nontail] end include struct open struct (* partition helpers *) let partition_map_into src ~fsts ~snds ~f ~len ~src_pos ~fst_pos ~snd_pos = let fst_pos = (ref fst_pos) in let snd_pos = (ref snd_pos) in for src_pos = src_pos to len - 1 do match (f (unsafe_get src src_pos) : (_, _) Either.t) with | First c -> Bytes.unsafe_set fsts !fst_pos c; incr fst_pos | Second c -> Bytes.unsafe_set snds !snd_pos c; incr snd_pos done; local_copy_to_string fsts ~pos:!fst_pos, local_copy_to_string snds ~pos:!snd_pos ;; let partition_map_difference src ~f ~len ~pos:src_pos ~fst_pos ~snd_pos either = let fsts = local_copy_prefix src ~prefix_len:fst_pos ~buffer_len:len in let snds = local_copy_prefix src ~prefix_len:snd_pos ~buffer_len:len in let fst_pos, snd_pos = match (either : (_, _) Either.t) with | First c -> Bytes.unsafe_set fsts fst_pos c; (fst_pos + 1, snd_pos) | Second c -> Bytes.unsafe_set snds snd_pos c; (fst_pos, snd_pos + 1) in partition_map_into src ~fsts ~snds ~f ~len ~src_pos:(src_pos + 1) ~fst_pos ~snd_pos [@nontail] ;; let rec partition_map_first_maybe_id src ~f ~pos ~len = if pos = len then src, "" else ( let c1 = unsafe_get src pos in match (f c1 : (_, _) Either.t) with | First c2 when Char.equal c1 c2 -> partition_map_first_maybe_id src ~f ~len ~pos:(pos + 1) | either -> partition_map_difference src ~f ~len ~pos ~fst_pos:pos ~snd_pos:0 either [@nontail]) ;; let rec partition_map_second_maybe_id src ~f ~pos ~len = if pos = len then "", src else ( let c1 = unsafe_get src pos in match (f c1 : (_, _) Either.t) with | Second c2 when Char.equal c1 c2 -> partition_map_second_maybe_id src ~f ~len ~pos:(pos + 1) | either -> partition_map_difference src ~f ~len ~pos ~fst_pos:0 ~snd_pos:pos either [@nontail]) ;; end (* partition functions *) let partition_map src ~f = let len = length src in if len = 0 then "", "" else ( let c1 = unsafe_get src 0 in match (f c1 : (_, _) Either.t) with | First c2 when Char.equal c1 c2 -> partition_map_first_maybe_id src ~f ~len ~pos:1 | Second c2 when Char.equal c1 c2 -> partition_map_second_maybe_id src ~f ~len ~pos:1 | either -> partition_map_difference src ~f ~len ~pos:0 ~fst_pos:0 ~snd_pos:0 either [@nontail]) ;; let partition_tf t ~f = partition_map t ~f:(fun c -> if f c then (First c) else (Second c)) [@nontail ] ;; end module Escaping = struct (* If this is changed, make sure to update [escape], which attempts to ensure all the invariants checked here. *) let build_and_validate_escapeworthy_map escapeworthy_map escape_char func = let escapeworthy_map = if List.Assoc.mem escapeworthy_map ~equal:Char.equal escape_char then escapeworthy_map else (escape_char, escape_char) :: escapeworthy_map in let arr = Array.create ~len:256 (-1) in let vals = Array.create ~len:256 false in let rec loop = function | [] -> Ok arr | (c_from, c_to) :: l -> let k, v = match func with | `Escape -> Char.to_int c_from, c_to | `Unescape -> Char.to_int c_to, c_from in if arr.(k) <> -1 || vals.(Char.to_int v) then Or_error.error_s (Sexp.message "escapeworthy_map not one-to-one" [ "c_from", sexp_of_char c_from ; "c_to", sexp_of_char c_to ; ( "escapeworthy_map" , sexp_of_list (sexp_of_pair sexp_of_char sexp_of_char) escapeworthy_map ) ]) else ( arr.(k) <- Char.to_int v; vals.(Char.to_int v) <- true; loop l) in loop escapeworthy_map ;; let escape_gen ~escapeworthy_map ~escape_char = match build_and_validate_escapeworthy_map escapeworthy_map escape_char `Escape with | Error _ as x -> x | Ok escapeworthy -> Ok (fun src -> (* calculate a list of (index of char to escape * escaped char) first, the order is from tail to head *) let to_escape_len = ref 0 in let to_escape = foldi src ~init:[] ~f:(fun i acc c -> match escapeworthy.(Char.to_int c) with | -1 -> acc | n -> (* (index of char to escape * escaped char) *) incr to_escape_len; (i, Char.unsafe_of_int n) :: acc) in match to_escape with | [] -> src | _ -> (* [to_escape] divide [src] to [List.length to_escape + 1] pieces separated by the chars to escape. Lets take {[ escape_gen_exn ~escapeworthy_map:[('a', 'A'); ('b', 'B'); ('c', 'C')] ~escape_char:'_' ]} for example, and assume the string to escape is "000a111b222c333" then [to_escape] is [(11, 'C'); (7, 'B'); (3, 'A')]. Then we create a [dst] of length [length src + 3] to store the result, copy piece "333" to [dst] directly, then copy '_' and 'C' to [dst]; then move on to next; after 3 iterations, copy piece "000" and we are done. Finally the result will be "000_A111_B222_C333" *) let src_len = length src in let dst_len = src_len + !to_escape_len in let dst = Bytes.create dst_len in let rec loop last_idx last_dst_pos = function | [] -> (* copy "000" at last *) Bytes.blit_string ~src ~src_pos:0 ~dst ~dst_pos:0 ~len:last_idx | (idx, escaped_char) :: to_escape -> (*[idx] = the char to escape*) (* take first iteration for example *) (* calculate length of "333", minus 1 because we don't copy 'c' *) let len = last_idx - idx - 1 in (* set the dst_pos to copy to *) let dst_pos = last_dst_pos - len in (* copy "333", set [src_pos] to [idx + 1] to skip 'c' *) Bytes.blit_string ~src ~src_pos:(idx + 1) ~dst ~dst_pos ~len; (* backoff [dst_pos] by 2 to copy '_' and 'C' *) let dst_pos = dst_pos - 2 in Bytes.set dst dst_pos escape_char; Bytes.set dst (dst_pos + 1) escaped_char; loop idx dst_pos to_escape in (* set [last_dst_pos] and [last_idx] to length of [dst] and [src] first *) loop src_len dst_len to_escape; Bytes.unsafe_to_string ~no_mutation_while_string_reachable:dst) ;; let escape_gen_exn ~escapeworthy_map ~escape_char = Or_error.ok_exn (escape_gen ~escapeworthy_map ~escape_char) |> stage ;; let escape ~escapeworthy ~escape_char = (* For [escape_gen_exn], we don't know how to fix invalid escapeworthy_map so we have to raise exception; but in this case, we know how to fix duplicated elements in escapeworthy list, so we just fix it instead of raising exception to make this function easier to use. *) let escapeworthy_map = escapeworthy |> List.dedup_and_sort ~compare:Char.compare |> List.map ~f:(fun c -> c, c) in escape_gen_exn ~escapeworthy_map ~escape_char ;; (* In an escaped string, any char is either `Escaping, `Escaped or `Literal. For example, the escape statuses of chars in string "a_a__" with escape_char = '_' are a : `Literal _ : `Escaping a : `Escaped _ : `Escaping _ : `Escaped [update_escape_status str ~escape_char i previous_status] gets escape status of str.[i] basing on escape status of str.[i - 1] *) let update_escape_status str ~escape_char i = function | `Escaping -> `Escaped | `Literal | `Escaped -> if Char.equal str.[i] escape_char then `Escaping else `Literal ;; let unescape_gen ~escapeworthy_map ~escape_char = match build_and_validate_escapeworthy_map escapeworthy_map escape_char `Unescape with | Error _ as x -> x | Ok escapeworthy -> Ok (fun src -> (* Continue the example in [escape_gen_exn], now we unescape "000_A111_B222_C333" back to "000a111b222c333" Then [to_unescape] is [14; 9; 4], which is indexes of '_'s. Then we create a string [dst] to store the result, copy "333" to it, then copy 'c', then move on to next iteration. After 3 iterations copy "000" and we are done. *) (* indexes of escape chars *) let to_unescape = let rec loop i status acc = if i >= length src then acc else ( let status = update_escape_status src ~escape_char i status in loop (i + 1) status (match status with | `Escaping -> i :: acc | `Escaped | `Literal -> acc)) in loop 0 `Literal [] in match to_unescape with | [] -> src | idx :: to_unescape' -> let dst = Bytes.create (length src - List.length to_unescape) in let rec loop last_idx last_dst_pos = function | [] -> (* copy "000" at last *) Bytes.blit_string ~src ~src_pos:0 ~dst ~dst_pos:0 ~len:last_idx | idx :: to_unescape -> (* [idx] = index of escaping char *) (* take 1st iteration as example, calculate the length of "333", minus 2 to skip '_C' *) let len = last_idx - idx - 2 in (* point [dst_pos] to the position to copy "333" to *) let dst_pos = last_dst_pos - len in (* copy "333" *) Bytes.blit_string ~src ~src_pos:(idx + 2) ~dst ~dst_pos ~len; (* backoff [dst_pos] by 1 to copy 'c' *) let dst_pos = dst_pos - 1 in Bytes.set dst dst_pos (match escapeworthy.(Char.to_int src.[idx + 1]) with | -1 -> src.[idx + 1] | n -> Char.unsafe_of_int n); (* update [last_dst_pos] and [last_idx] *) loop idx dst_pos to_unescape in if idx < length src - 1 then (* set [last_dst_pos] and [last_idx] to length of [dst] and [src] *) loop (length src) (Bytes.length dst) to_unescape else (* for escaped string ending with an escaping char like "000_", just ignore the last escaping char *) loop (length src - 1) (Bytes.length dst) to_unescape'; Bytes.unsafe_to_string ~no_mutation_while_string_reachable:dst) ;; let unescape_gen_exn ~escapeworthy_map ~escape_char = Or_error.ok_exn (unescape_gen ~escapeworthy_map ~escape_char) |> stage ;; let unescape ~escape_char = unescape_gen_exn ~escapeworthy_map:[] ~escape_char let preceding_escape_chars str ~escape_char pos = let rec loop p cnt = if p < 0 || Char.( <> ) str.[p] escape_char then cnt else loop (p - 1) (cnt + 1) in loop (pos - 1) 0 ;; (* In an escaped string, any char is either `Escaping, `Escaped or `Literal. For example, the escape statuses of chars in string "a_a__" with escape_char = '_' are a : `Literal _ : `Escaping a : `Escaped _ : `Escaping _ : `Escaped [update_escape_status str ~escape_char i previous_status] gets escape status of str.[i] basing on escape status of str.[i - 1] *) let update_escape_status str ~escape_char i = function | `Escaping -> `Escaped | `Literal | `Escaped -> if Char.equal str.[i] escape_char then `Escaping else `Literal ;; let escape_status str ~escape_char pos = let odd = preceding_escape_chars str ~escape_char pos mod 2 = 1 in match odd, Char.equal str.[pos] escape_char with | true, (true | false) -> `Escaped | false, true -> `Escaping | false, false -> `Literal ;; let check_bound str pos function_name = if pos >= length str || pos < 0 then invalid_argf "%s: out of bounds" function_name () ;; let is_char_escaping str ~escape_char pos = check_bound str pos "is_char_escaping"; match escape_status str ~escape_char pos with | `Escaping -> true | `Escaped | `Literal -> false ;; let is_char_escaped str ~escape_char pos = check_bound str pos "is_char_escaped"; match escape_status str ~escape_char pos with | `Escaped -> true | `Escaping | `Literal -> false ;; let is_char_literal str ~escape_char pos = check_bound str pos "is_char_literal"; match escape_status str ~escape_char pos with | `Literal -> true | `Escaped | `Escaping -> false ;; let index_from str ~escape_char pos char = check_bound str pos "index_from"; let rec loop i status = if i >= pos && (match status with | `Literal -> true | `Escaped | `Escaping -> false) && Char.equal str.[i] char then Some i else ( let i = i + 1 in if i >= length str then None else loop i (update_escape_status str ~escape_char i status)) in loop pos (escape_status str ~escape_char pos) ;; let index_from_exn str ~escape_char pos char = match index_from str ~escape_char pos char with | None -> raise_s (Sexp.message "index_from_exn: not found" [ "str", sexp_of_t str ; "escape_char", sexp_of_char escape_char ; "pos", sexp_of_int pos ; "char", sexp_of_char char ]) | Some pos -> pos ;; let index str ~escape_char char = index_from str ~escape_char 0 char let index_exn str ~escape_char char = index_from_exn str ~escape_char 0 char let rindex_from str ~escape_char pos char = check_bound str pos "rindex_from"; (* if the target char is the same as [escape_char], we have no way to determine which escape_char is literal, so just return None *) if Char.equal char escape_char then None else ( let rec loop pos = if pos < 0 then None else ( let escape_chars = preceding_escape_chars str ~escape_char pos in if escape_chars mod 2 = 0 && Char.equal str.[pos] char then Some pos else loop (pos - escape_chars - 1)) in loop pos) ;; let rindex_from_exn str ~escape_char pos char = match rindex_from str ~escape_char pos char with | None -> raise_s (Sexp.message "rindex_from_exn: not found" [ "str", sexp_of_t str ; "escape_char", sexp_of_char escape_char ; "pos", sexp_of_int pos ; "char", sexp_of_char char ]) | Some pos -> pos ;; let rindex str ~escape_char char = if is_empty str then None else rindex_from str ~escape_char (length str - 1) char ;; let rindex_exn str ~escape_char char = rindex_from_exn str ~escape_char (length str - 1) char ;; (* [split_gen str ~escape_char ~on] works similarly to [String.split_gen], with an additional requirement: only split on literal chars, not escaping or escaped *) let split_gen str ~escape_char ~on = let is_delim = match on with | `char c' -> fun c -> Char.equal c c' | `char_list l -> fun c -> char_list_mem l c in let len = length str in let rec loop acc status last_pos pos = if pos = len then List.rev (sub str ~pos:last_pos ~len:(len - last_pos) :: acc) else ( let status = update_escape_status str ~escape_char pos status in if (match status with | `Literal -> true | `Escaped | `Escaping -> false) && is_delim str.[pos] then ( let sub_str = sub str ~pos:last_pos ~len:(pos - last_pos) in loop (sub_str :: acc) status (pos + 1) (pos + 1)) else loop acc status last_pos (pos + 1)) in loop [] `Literal 0 0 ;; let split str ~on = split_gen str ~on:(`char on) let split_on_chars str ~on:chars = split_gen str ~on:(`char_list chars) let split_at str pos = sub str ~pos:0 ~len:pos, sub str ~pos:(pos + 1) ~len:(length str - pos - 1) ;; let lsplit2 str ~on ~escape_char = Option.map (index str ~escape_char on) ~f:(fun x -> split_at str x) ;; let rsplit2 str ~on ~escape_char = Option.map (rindex str ~escape_char on) ~f:(fun x -> split_at str x) ;; let lsplit2_exn str ~on ~escape_char = split_at str (index_exn str ~escape_char on) let rsplit2_exn str ~on ~escape_char = split_at str (rindex_exn str ~escape_char on) (* [last_non_drop_literal] and [first_non_drop_literal] are either both [None] or both [Some]. If [Some], then the former is >= the latter. *) let last_non_drop_literal ~drop ~escape_char t = rfindi t ~f:(fun i c -> (not (drop c)) || is_char_escaping t ~escape_char i || is_char_escaped t ~escape_char i) [@nontail] ;; let first_non_drop_literal ~drop ~escape_char t = lfindi t ~f:(fun i c -> (not (drop c)) || is_char_escaping t ~escape_char i || is_char_escaped t ~escape_char i) [@nontail] ;; let rstrip_literal ?(drop = Char.is_whitespace) t ~escape_char = match last_non_drop_literal t ~drop ~escape_char with | None -> "" | Some i -> if i = length t - 1 then t else prefix t (i + 1) ;; let lstrip_literal ?(drop = Char.is_whitespace) t ~escape_char = match first_non_drop_literal t ~drop ~escape_char with | None -> "" | Some 0 -> t | Some n -> drop_prefix t n ;; (* [strip t] could be implemented as [lstrip (rstrip t)]. The implementation below saves (at least) a factor of two allocation, by only allocating the final result. This also saves some amount of time. *) let strip_literal ?(drop = Char.is_whitespace) t ~escape_char = let length = length t in (* performance hack: avoid copying [t] in common cases *) if length = 0 || not (drop t.[0] || drop t.[length - 1]) then t else ( match first_non_drop_literal t ~drop ~escape_char with | None -> "" | Some first -> (match last_non_drop_literal t ~drop ~escape_char with | None -> assert false | Some last -> sub t ~pos:first ~len:(last - first + 1))) ;; end (* Open replace_polymorphic_compare after including functor instantiations so they do not shadow its definitions. This is here so that efficient versions of the comparison functions are available within this module. *) open! String_replace_polymorphic_compare let between t ~low ~high = low <= t && t <= high let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max let clamp_exn t ~min ~max = assert (min <= max); clamp_unchecked t ~min ~max ;; let clamp t ~min ~max = if min > max then Or_error.error_s (Sexp.message "clamp requires [min <= max]" [ "min", T.sexp_of_t min; "max", T.sexp_of_t max ]) else Ok (clamp_unchecked t ~min ~max) ;; (* Override [Search_pattern] with default case-sensitivity argument at the end of the file, so that call sites above are forced to supply case-sensitivity explicitly. *) module Search_pattern = struct include Search_pattern0 let create ?(case_sensitive = true) pattern = create pattern ~case_sensitive end (* Include type-specific [Replace_polymorphic_compare] at the end, after including functor application that could shadow its definitions. This is here so that efficient versions of the comparison functions are exported by this module. *) include String_replace_polymorphic_compare base-0.16.3/src/string.mli000066400000000000000000000534261446274340700153400ustar00rootroot00000000000000(** An extension of the standard [StringLabels]. If you [open Base], you'll get these extensions in the [String] module. *) open! Import type t = string [@@deriving_inline globalize, sexp, sexp_grammar] val globalize : (t[@ocaml.local]) -> t include Sexplib0.Sexpable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] val sub : (t, t) Blit.sub (** [sub] with no bounds checking, and always returns a new copy *) val unsafe_sub : (t[@local]) -> pos:int -> len:int -> t val subo : (t, t) Blit.subo include Indexed_container.S0_with_creators with type t := t with type elt = char include Identifiable.S with type t := t include Invariant.S with type t := t (** Maximum length of a string. *) val max_length : int val mem : (t[@local]) -> char -> bool external length : (t[@local_opt]) -> int = "%string_length" external get : (t[@local_opt]) -> (int[@local_opt]) -> char = "%string_safe_get" (** [unsafe_get t i] is like [get t i] but does not perform bounds checking. The caller must ensure that it is a memory-safe operation. *) external unsafe_get : (string[@local_opt]) -> (int[@local_opt]) -> char = "%string_unsafe_get" val make : int -> char -> t (** String append. Also available unqualified, but re-exported here for documentation purposes. Note that [a ^ b] must copy both [a] and [b] into a newly-allocated result string, so [a ^ b ^ c ^ ... ^ z] is quadratic in the number of strings. [String.concat] does not have this problem -- it allocates the result buffer only once. *) val ( ^ ) : t -> t -> t (** Concatenates all strings in the list using separator [sep] (with a default separator [""]). *) val concat : ?sep:t -> t list -> t (** Special characters are represented by escape sequences, following the lexical conventions of OCaml. *) val escaped : t -> t val contains : ?pos:int -> ?len:int -> t -> char -> bool (** Operates on the whole string using the US-ASCII character set, e.g. [uppercase "foo" = "FOO"]. *) val uppercase : t -> t val lowercase : t -> t (** Operates on just the first character using the US-ASCII character set, e.g. [capitalize "foo" = "Foo"]. *) val capitalize : t -> t val uncapitalize : t -> t (** [Caseless] compares and hashes strings ignoring case, so that for example [Caseless.equal "OCaml" "ocaml"] and [Caseless.("apple" < "Banana")] are [true]. [Caseless] also provides case-insensitive [is_suffix] and [is_prefix] functions, so that for example [Caseless.is_suffix "OCaml" ~suffix:"AmL"] and [Caseless.is_prefix "OCaml" ~prefix:"oc"] are [true]. *) module Caseless : sig type nonrec t = t [@@deriving_inline hash, sexp, sexp_grammar] include Ppx_hash_lib.Hashable.S with type t := t include Sexplib0.Sexpable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] include Comparable.S with type t := t val is_suffix : t -> suffix:t -> bool val is_prefix : t -> prefix:t -> bool val is_substring : t -> substring:t -> bool val is_substring_at : t -> pos:int -> substring:t -> bool val substr_index : ?pos:int -> t -> pattern:t -> int option val substr_index_exn : ?pos:int -> t -> pattern:t -> int val substr_index_all : t -> may_overlap:bool -> pattern:t -> int list val substr_replace_first : ?pos:int -> t -> pattern:t -> with_:t -> t val substr_replace_all : t -> pattern:t -> with_:t -> t end (** [index] gives the index of the first appearance of [char] in the string when searching from left to right, or [None] if it's not found. [rindex] does the same but searches from the right. For example, [String.index "Foo" 'o'] is [Some 1] while [String.rindex "Foo" 'o'] is [Some 2]. The [_exn] versions return the actual index (instead of an option) when [char] is found, and raise [Stdlib.Not_found] or [Not_found_s] otherwise. *) val index : t -> char -> int option val index_exn : t -> char -> int val index_from : t -> int -> char -> int option val index_from_exn : t -> int -> char -> int val rindex : t -> char -> int option val rindex_exn : t -> char -> int val rindex_from : t -> int -> char -> int option val rindex_from_exn : t -> int -> char -> int (** Substring search and replace functions. They use the Knuth-Morris-Pratt algorithm (KMP) under the hood. The functions in the [Search_pattern] module allow the program to preprocess the searched pattern once and then use it many times without further allocations. *) module Search_pattern : sig type t [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] (** [create pattern] preprocesses [pattern] as per KMP, building an [int array] of length [length pattern]. All inputs are valid. *) val create : ?case_sensitive:bool (** default = true *) -> string -> t (** [pattern t] returns the string pattern used to create [t]. *) val pattern : t -> string (** [case_sensitive t] returns whether [t] matches strings case-sensitively. *) val case_sensitive : t -> bool (** [matches pat str] returns true if [str] matches [pat] *) val matches : t -> string -> bool (** [pos < 0] or [pos >= length string] result in no match (hence [index] returns [None] and [index_exn] raises). *) val index : ?pos:int -> t -> in_:string -> int option val index_exn : ?pos:int -> t -> in_:string -> int (** [may_overlap] determines whether after a successful match, [index_all] should start looking for another one at the very next position ([~may_overlap:true]), or jump to the end of that match and continue from there ([~may_overlap:false]), e.g.: - [index_all (create "aaa") ~may_overlap:false ~in_:"aaaaBaaaaaa" = [0; 5; 8]] - [index_all (create "aaa") ~may_overlap:true ~in_:"aaaaBaaaaaa" = [0; 1; 5; 6; 7; 8]] E.g., [replace_all] internally calls [index_all ~may_overlap:false]. *) val index_all : t -> may_overlap:bool -> in_:string -> int list (** Note that the result of [replace_all pattern ~in_:text ~with_:r] may still contain [pattern], e.g., {[ replace_all (create "bc") ~in_:"aabbcc" ~with_:"cb" = "aabcbc" ]} *) val replace_first : ?pos:int -> t -> in_:string -> with_:string -> string val replace_all : t -> in_:string -> with_:string -> string (** Similar to [String.split] or [String.split_on_chars], but instead uses a given search pattern as the separator. Separators are non-overlapping. *) val split_on : t -> string -> string list (**/**) (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig type public = t type t = { pattern : string ; case_sensitive : bool ; kmp_array : int array } [@@deriving_inline equal, sexp_of] include Ppx_compare_lib.Equal.S with type t := t val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] val representation : public -> t end end (** Substring search and replace convenience functions. They call [Search_pattern.create] and then forget the preprocessed pattern when the search is complete. [pos < 0] or [pos >= length t] result in no match (hence [substr_index] returns [None] and [substr_index_exn] raises). [may_overlap] indicates whether to report overlapping matches, see [Search_pattern.index_all]. *) val substr_index : ?pos:int -> t -> pattern:t -> int option val substr_index_exn : ?pos:int -> t -> pattern:t -> int val substr_index_all : t -> may_overlap:bool -> pattern:t -> int list val substr_replace_first : ?pos:int -> t -> pattern:t -> with_:t -> t (** As with [Search_pattern.replace_all], the result may still contain [pattern]. *) val substr_replace_all : t -> pattern:t -> with_:t -> t (** [is_substring ~substring:"bar" "foo bar baz"] is true. *) val is_substring : t -> substring:t -> bool (** [is_substring_at "foo bar baz" ~pos:4 ~substring:"bar"] is true. *) val is_substring_at : t -> pos:int -> substring:t -> bool (** Returns the reversed list of characters contained in a list. *) val to_list_rev : t -> char list (** [rev t] returns [t] in reverse order. *) val rev : t -> t (** [is_suffix s ~suffix] returns [true] if [s] ends with [suffix]. *) val is_suffix : t -> suffix:t -> bool (** [is_prefix s ~prefix] returns [true] if [s] starts with [prefix]. *) val is_prefix : t -> prefix:t -> bool (** If the string [s] contains the character [on], then [lsplit2_exn s ~on] returns a pair containing [s] split around the first appearance of [on] (from the left). Raises [Stdlib.Not_found] or [Not_found_s] when [on] cannot be found in [s]. *) val lsplit2_exn : t -> on:char -> t * t (** If the string [s] contains the character [on], then [rsplit2_exn s ~on] returns a pair containing [s] split around the first appearance of [on] (from the right). Raises [Stdlib.Not_found] or [Not_found_s] when [on] cannot be found in [s]. *) val rsplit2_exn : t -> on:char -> t * t (** [lsplit2 s ~on] optionally returns [s] split into two strings around the first appearance of [on] from the left. *) val lsplit2 : t -> on:char -> (t * t) option (** [rsplit2 s ~on] optionally returns [s] split into two strings around the first appearance of [on] from the right. *) val rsplit2 : t -> on:char -> (t * t) option (** [split s ~on] returns a list of substrings of [s] that are separated by [on]. Consecutive [on] characters will cause multiple empty strings in the result. Splitting the empty string returns a list of the empty string, not the empty list. *) val split : t -> on:char -> t list (** [split_on_chars s ~on] returns a list of all substrings of [s] that are separated by one of the chars from [on]. [on] are not grouped. So a grouping of [on] in the source string will produce multiple empty string splits in the result. *) val split_on_chars : t -> on:char list -> t list (** [split_lines t] returns the list of lines that comprise [t]. The lines do not include the trailing ["\n"] or ["\r\n"]. *) val split_lines : t -> t list (** [lfindi ?pos t ~f] returns the smallest [i >= pos] such that [f i t.[i]], if there is such an [i]. By default, [pos = 0]. *) val lfindi : ?pos:int -> t -> f:((int -> char -> bool)[@local]) -> int option (** [rfindi ?pos t ~f] returns the largest [i <= pos] such that [f i t.[i]], if there is such an [i]. By default [pos = length t - 1]. *) val rfindi : ?pos:int -> t -> f:((int -> char -> bool)[@local]) -> int option (** [lstrip ?drop s] returns a string with consecutive chars satisfying [drop] (by default white space, e.g. tabs, spaces, newlines, and carriage returns) stripped from the beginning of [s]. *) val lstrip : ?drop:((char -> bool)[@local]) -> t -> t (** [rstrip ?drop s] returns a string with consecutive chars satisfying [drop] (by default white space, e.g. tabs, spaces, newlines, and carriage returns) stripped from the end of [s]. *) val rstrip : ?drop:((char -> bool)[@local]) -> t -> t (** [strip ?drop s] returns a string with consecutive chars satisfying [drop] (by default white space, e.g. tabs, spaces, newlines, and carriage returns) stripped from the beginning and end of [s]. *) val strip : ?drop:((char -> bool)[@local]) -> t -> t (** Like [map], but allows the replacement of a single character with zero or two or more characters. *) val concat_map : ?sep:t -> t -> f:((char -> t)[@local]) -> t val concat_mapi : ?sep:t -> t -> f:((int -> char -> t)[@local]) -> t (** [tr ~target ~replacement s] replaces every instance of [target] in [s] with [replacement]. *) val tr : target:char -> replacement:char -> t -> t (** [tr_multi ~target ~replacement] returns a function that replaces every instance of a character in [target] with the corresponding character in [replacement]. If [replacement] is shorter than [target], it is lengthened by repeating its last character. Empty [replacement] is illegal unless [target] also is. If [target] contains multiple copies of the same character, the last corresponding [replacement] character is used. Note that character ranges are {b not} supported, so [~target:"a-z"] means the literal characters ['a'], ['-'], and ['z']. *) val tr_multi : target:t -> replacement:t -> (t -> t) Staged.t (** [chop_suffix_exn s ~suffix] returns [s] without the trailing [suffix], raising [Invalid_argument] if [suffix] is not a suffix of [s]. *) val chop_suffix_exn : t -> suffix:t -> t (** [chop_prefix_exn s ~prefix] returns [s] without the leading [prefix], raising [Invalid_argument] if [prefix] is not a prefix of [s]. *) val chop_prefix_exn : t -> prefix:t -> t val chop_suffix : t -> suffix:t -> t option val chop_prefix : t -> prefix:t -> t option (** [chop_suffix_if_exists s ~suffix] returns [s] without the trailing [suffix], or just [s] if [suffix] isn't a suffix of [s]. Equivalent to [chop_suffix s ~suffix |> Option.value ~default:s], but avoids allocating the intermediate option. *) val chop_suffix_if_exists : t -> suffix:t -> t (** [chop_prefix_if_exists s ~prefix] returns [s] without the leading [prefix], or just [s] if [prefix] isn't a prefix of [s]. Equivalent to [chop_prefix s ~prefix |> Option.value ~default:s], but avoids allocating the intermediate option. *) val chop_prefix_if_exists : t -> prefix:t -> t (** [suffix s n] returns the longest suffix of [s] of length less than or equal to [n]. *) val suffix : t -> int -> t (** [prefix s n] returns the longest prefix of [s] of length less than or equal to [n]. *) val prefix : t -> int -> t (** [drop_suffix s n] drops the longest suffix of [s] of length less than or equal to [n]. *) val drop_suffix : t -> int -> t (** [drop_prefix s n] drops the longest prefix of [s] of length less than or equal to [n]. *) val drop_prefix : t -> int -> t (** Produces the longest common suffix, or [""] if the list is empty. *) val common_suffix : t list -> t (** Produces the longest common prefix, or [""] if the list is empty. *) val common_prefix : t list -> t (** Produces the length of the longest common suffix, or 0 if the list is empty. *) val common_suffix_length : t list -> int (** Produces the length of the longest common prefix, or 0 if the list is empty. *) val common_prefix_length : t list -> int (** Produces the longest common suffix. *) val common_suffix2 : t -> t -> t (** Produces the longest common prefix. *) val common_prefix2 : t -> t -> t (** Produces the length of the longest common suffix. *) val common_suffix2_length : t -> t -> int (** Produces the length of the longest common prefix. *) val common_prefix2_length : t -> t -> int (** [concat_array sep ar] like {!String.concat}, but operates on arrays. *) val concat_array : ?sep:t -> t array -> t (** Builds a multiline text from a list of lines. Each line is terminated and then concatenated. Equivalent to: {[ String.concat (List.map lines ~f:(fun line -> line ^ if crlf then "\r\n" else "\n")) ]} *) val concat_lines : ?crlf:bool (** default [false] *) -> string list -> string (** Slightly faster hash function on strings. *) external hash : t -> int = "Base_hash_string" [@@noalloc] (** Fast equality function on strings, doesn't use [compare_val]. *) val equal : t -> t -> bool val of_char : char -> t val of_char_list : char list -> t (** [pad_left ?char s ~len] returns [s] padded to the length [len] by adding characters [char] to the beginning of the string. If s is already longer than [len] it is returned unchanged. *) val pad_left : ?char:char (** default is [' '] *) -> string -> len:int -> string (** [pad_right ?char ~s len] returns [s] padded to the length [len] by adding characters [char] to the end of the string. If s is already longer than [len] it is returned unchanged. *) val pad_right : ?char:char (** default is [' '] *) -> string -> len:int -> string (** Operations for escaping and unescaping strings, with parameterized escape and escapeworthy characters. Escaping/unescaping using this module is more efficient than using Pcre. Benchmark code can be found in core/benchmarks/string_escaping.ml. *) module Escaping : sig (** [escape_gen_exn escapeworthy_map escape_char] returns a function that will escape a string [s] as follows: if [(c1,c2)] is in [escapeworthy_map], then all occurrences of [c1] are replaced by [escape_char] concatenated to [c2]. Raises an exception if [escapeworthy_map] is not one-to-one. If [escape_char] is not in [escapeworthy_map], then it will be escaped to itself.*) val escape_gen_exn : escapeworthy_map:(char * char) list -> escape_char:char -> (string -> string) Staged.t val escape_gen : escapeworthy_map:(char * char) list -> escape_char:char -> (string -> string) Or_error.t (** [escape ~escapeworthy ~escape_char s] is {[ escape_gen_exn ~escapeworthy_map:(List.zip_exn escapeworthy escapeworthy) ~escape_char ]} Duplicates and [escape_char] will be removed from [escapeworthy]. So, no exception will be raised *) val escape : escapeworthy:char list -> escape_char:char -> (string -> string) Staged.t (** [unescape_gen_exn] is the inverse operation of [escape_gen_exn]. That is, {[ let escape = Staged.unstage (escape_gen_exn ~escapeworthy_map ~escape_char) in let unescape = Staged.unstage (unescape_gen_exn ~escapeworthy_map ~escape_char) in assert (s = unescape (escape s)) ]} always succeed when ~escapeworthy_map is not causing exceptions. *) val unescape_gen_exn : escapeworthy_map:(char * char) list -> escape_char:char -> (string -> string) Staged.t val unescape_gen : escapeworthy_map:(char * char) list -> escape_char:char -> (string -> string) Or_error.t (** [unescape ~escape_char] is defined as [unescape_gen_exn ~map:\[\] ~escape_char] *) val unescape : escape_char:char -> (string -> string) Staged.t (** Any char in an escaped string is either escaping, escaped, or literal. For example, for escaped string ["0_a0__0"] with [escape_char] as ['_'], pos 1 and 4 are escaping, 2 and 5 are escaped, and the rest are literal. [is_char_escaping s ~escape_char pos] returns true if the char at [pos] is escaping, false otherwise. *) val is_char_escaping : string -> escape_char:char -> int -> bool (** [is_char_escaped s ~escape_char pos] returns true if the char at [pos] is escaped, false otherwise. *) val is_char_escaped : string -> escape_char:char -> int -> bool (** [is_char_literal s ~escape_char pos] returns true if the char at [pos] is not escaped or escaping. *) val is_char_literal : string -> escape_char:char -> int -> bool (** [index s ~escape_char char] finds the first literal (not escaped) instance of [char] in s starting from 0. *) val index : string -> escape_char:char -> char -> int option val index_exn : string -> escape_char:char -> char -> int (** [rindex s ~escape_char char] finds the first literal (not escaped) instance of [char] in [s] starting from the end of [s] and proceeding towards 0. *) val rindex : string -> escape_char:char -> char -> int option val rindex_exn : string -> escape_char:char -> char -> int (** [index_from s ~escape_char pos char] finds the first literal (not escaped) instance of [char] in [s] starting from [pos] and proceeding towards the end of [s]. *) val index_from : string -> escape_char:char -> int -> char -> int option val index_from_exn : string -> escape_char:char -> int -> char -> int (** [rindex_from s ~escape_char pos char] finds the first literal (not escaped) instance of [char] in [s] starting from [pos] and towards 0. *) val rindex_from : string -> escape_char:char -> int -> char -> int option val rindex_from_exn : string -> escape_char:char -> int -> char -> int (** [split s ~escape_char ~on] returns a list of substrings of [s] that are separated by literal versions of [on]. Consecutive [on] characters will cause multiple empty strings in the result. Splitting the empty string returns a list of the empty string, not the empty list. E.g., [split ~escape_char:'_' ~on:',' "foo,bar_,baz" = ["foo"; "bar_,baz"]]. *) val split : string -> on:char -> escape_char:char -> string list (** [split_on_chars s ~on] returns a list of all substrings of [s] that are separated by one of the literal chars from [on]. [on] are not grouped. So a grouping of [on] in the source string will produce multiple empty string splits in the result. E.g., [split_on_chars ~escape_char:'_' ~on:[',';'|'] "foo_|bar,baz|0" -> ["foo_|bar"; "baz"; "0"]]. *) val split_on_chars : string -> on:char list -> escape_char:char -> string list (** [lsplit2 s ~on ~escape_char] splits s into a pair on the first literal instance of [on] (meaning the first unescaped instance) starting from the left. *) val lsplit2 : string -> on:char -> escape_char:char -> (string * string) option val lsplit2_exn : string -> on:char -> escape_char:char -> string * string (** [rsplit2 s ~on ~escape_char] splits [s] into a pair on the first literal instance of [on] (meaning the first unescaped instance) starting from the right. *) val rsplit2 : string -> on:char -> escape_char:char -> (string * string) option val rsplit2_exn : string -> on:char -> escape_char:char -> string * string (** These are the same as [lstrip], [rstrip], and [strip] for generic strings, except that they only drop literal characters -- they do not drop characters that are escaping or escaped. This makes sense if you're trying to get rid of junk whitespace (for example), because escaped whitespace seems more likely to be deliberate and not junk. *) val lstrip_literal : ?drop:((char -> bool)[@local]) -> t -> escape_char:char -> t val rstrip_literal : ?drop:((char -> bool)[@local]) -> t -> escape_char:char -> t val strip_literal : ?drop:((char -> bool)[@local]) -> t -> escape_char:char -> t end base-0.16.3/src/string0.ml000066400000000000000000000035271446274340700152440ustar00rootroot00000000000000(* [String0] defines string functions that are primitives or can be simply defined in terms of [Stdlib.String]. [String0] is intended to completely express the part of [Stdlib.String] that [Base] uses -- no other file in Base other than string0.ml should use [Stdlib.String]. [String0] has few dependencies, and so is available early in Base's build order. All Base files that need to use strings, including the subscript syntax [x.[i]] which the OCaml parser desugars into calls to [String], and come before [Base.String] in build order should do {[ module String = String0 ]} Defining [module String = String0] is also necessary because it prevents ocamldep from mistakenly causing a file to depend on [Base.String]. *) open! Import0 module Sys = Sys0 module String = struct external get : (string[@local_opt]) -> (int[@local_opt]) -> char = "%string_safe_get" external length : (string[@local_opt]) -> int = "%string_length" external unsafe_get : (string[@local_opt]) -> (int[@local_opt]) -> char = "%string_unsafe_get" end include String let max_length = Sys.max_string_length let ( ^ ) = ( ^ ) let capitalize = Stdlib.String.capitalize_ascii let compare = Stdlib.String.compare let escaped = Stdlib.String.escaped let lowercase = Stdlib.String.lowercase_ascii let make = Stdlib.String.make let sub = Stdlib.String.sub let uncapitalize = Stdlib.String.uncapitalize_ascii let unsafe_blit = Stdlib.String.unsafe_blit let uppercase = Stdlib.String.uppercase_ascii let split_on_char = Stdlib.String.split_on_char let concat ?(sep = "") l = match l with | [] -> "" (* The stdlib does not specialize this case because it could break existing projects. *) | [ x ] -> x | l -> Stdlib.String.concat ~sep l ;; let iter t ~f:(f [@local]) = for i = 0 to length t - 1 do f (unsafe_get t i) done ;; base-0.16.3/src/stringable.ml000066400000000000000000000002661446274340700160050ustar00rootroot00000000000000(** Provides type-specific conversion functions to and from [string]. *) open! Import module type S = sig type t val of_string : string -> t val to_string : t -> string end base-0.16.3/src/sys.ml000066400000000000000000000000321446274340700144600ustar00rootroot00000000000000open! Import include Sys0 base-0.16.3/src/sys.mli000066400000000000000000000122641446274340700146430ustar00rootroot00000000000000(** Cross-platform system configuration values. *) (** The command line arguments given to the process. The first element is the command name used to invoke the program. The following elements are the command-line arguments given to the program. When running in JavaScript in the browser, it is [[| "a.out" |]]. [get_argv] is a function because the external function [caml_sys_modify_argv] can replace the array starting in OCaml 4.09. *) val get_argv : unit -> string array (** A single result from [get_argv ()]. This value is indefinitely deprecated. It is kept for compatibility with {!Stdlib.Sys}. *) val argv : string array [@@deprecated "[since 2019-08] Use [Sys.get_argv] instead, which has the correct behavior when \ [caml_sys_modify_argv] is called."] (** [interactive] is set to [true] when being executed in the [ocaml] REPL, and [false] otherwise. *) val interactive : bool ref (** [os_type] describes the operating system that the OCaml program is running on. Its value is one of: - ["Unix"] (for all Unix versions, including Linux and macOS); - ["Win32"] (for MS-Windows, OCaml compiled with MSVC++ or MinGW); or - ["Cygwin"] (for MS-Windows, OCaml compiled with Cygwin) When running in JavaScript, it is ["Unix"]. *) val os_type : string (** [unix] is [true] if [os_type = "Unix"]. *) val unix : bool (** [win32] is [true] if [os_type = "Win32"]. *) val win32 : bool (** [cygwin] is [true] if [os_type = "Cygwin"]. *) val cygwin : bool (** Currently, the official distribution only supports [Native] and [Bytecode], but it can be other backends with alternative compilers, for example, JavaScript. *) type backend_type = Sys0.backend_type = | Native | Bytecode | Other of string (** Backend type currently executing the OCaml program. *) val backend_type : backend_type (** [word_size_in_bits] is the number of bits in one word on the machine currently executing the OCaml program. Generally speaking it will be either [32] or [64]. When running in JavaScript, it will be [32]. *) val word_size_in_bits : int (** [int_size_in_bits] is the number of bits in the [int] type. Generally, on 32-bit platforms, its value will be [31], and on 64 bit platforms its value will be [63]. When running in JavaScript, it will be [32]. {!Int.num_bits} is the same as this value. *) val int_size_in_bits : int (** [big_endian] is true when the program is running on a big-endian architecture. When running in JavaScript, it will be [false]. *) val big_endian : bool (** [max_string_length] is the maximum allowed length of a [string] or [Bytes.t]. {!String.max_length} is the same as this value. *) val max_string_length : int (** [max_array_length] is the maximum allowed length of an ['a array]. {!Array.max_length} is the same as this value. *) val max_array_length : int (** Returns the name of the runtime variant the program is running on. This is normally the argument given to [-runtime-variant] at compile time, but for byte-code it can be changed after compilation. When running in JavaScript or utop it will be [""], while if compiled with DEBUG (debugging of the runtime) it will be ["d"], and if compiled with CAML_INSTR (instrumentation of the runtime) it will be ["i"]. *) val runtime_variant : unit -> string (** Returns the value of the runtime parameters, in the same format as the contents of the [OCAMLRUNPARAM] environment variable. When running in JavaScript, it will be [""]. *) val runtime_parameters : unit -> string (** [ocaml_version] is the OCaml version with which the program was compiled. It is a string of the form ["major.minor[.patchlevel][+additional-info]"], where major, minor, and patchlevel are integers, and additional-info is an arbitrary string. The [[.patchlevel]] and [[+additional-info]] parts may be absent. *) val ocaml_version : string (** Controls whether the OCaml runtime system can emit warnings on stderr. Currently, the only supported warning is triggered when a channel created by [open_*] functions is finalized without being closed. Runtime warnings are enabled by default. *) val enable_runtime_warnings : bool -> unit (** Returns whether runtime warnings are currently enabled. *) val runtime_warnings_enabled : unit -> bool (** Return the value associated to a variable in the process environment. Return [None] if the variable is unbound or the process has special privileges, as determined by [secure_getenv(3)] on Linux. *) val getenv : string -> string option val getenv_exn : string -> string (** For the purposes of optimization, [opaque_identity] behaves like an unknown (and thus possibly side-effecting) function. At runtime, [opaque_identity] disappears altogether. A typical use of this function is to prevent pure computations from being optimized away in benchmarking loops. For example: {[ for _round = 1 to 100_000 do ignore (Sys.opaque_identity (my_pure_computation ())) done ]} *) external opaque_identity : ('a[@local_opt]) -> ('a[@local_opt]) = "%opaque" (** Like [opaque_identity]. Forces its argument to be globally allocated. *) external opaque_identity_global : 'a -> 'a = "%opaque" base-0.16.3/src/sys0.ml000066400000000000000000000036161446274340700145530ustar00rootroot00000000000000(* [Sys0] defines functions that are primitives or can be simply defined in terms of [Stdlib.Sys]. [Sys0] is intended to completely express the part of [Stdlib.Sys] that [Base] uses -- no other file in Base other than sys.ml should use [Stdlib.Sys]. [Sys0] has few dependencies, and so is available early in Base's build order. All Base files that need to use these functions and come before [Base.Sys] in build order should do [module Sys = Sys0]. Defining [module Sys = Sys0] is also necessary because it prevents ocamldep from mistakenly causing a file to depend on [Base.Sys]. *) open! Import0 type backend_type = Stdlib.Sys.backend_type = | Native | Bytecode | Other of string let backend_type = Stdlib.Sys.backend_type let interactive = Stdlib.Sys.interactive let os_type = Stdlib.Sys.os_type let unix = Stdlib.Sys.unix let win32 = Stdlib.Sys.win32 let cygwin = Stdlib.Sys.cygwin let word_size_in_bits = Stdlib.Sys.word_size let int_size_in_bits = Stdlib.Sys.int_size let big_endian = Stdlib.Sys.big_endian let max_string_length = Stdlib.Sys.max_string_length let max_array_length = Stdlib.Sys.max_array_length let runtime_variant = Stdlib.Sys.runtime_variant let runtime_parameters = Stdlib.Sys.runtime_parameters let argv = Stdlib.Sys.argv let get_argv () = Stdlib.Sys.argv let ocaml_version = Stdlib.Sys.ocaml_version let enable_runtime_warnings = Stdlib.Sys.enable_runtime_warnings let runtime_warnings_enabled = Stdlib.Sys.runtime_warnings_enabled let getenv_exn var = try Stdlib.Sys.getenv var with | Stdlib.Not_found -> Printf.failwithf "Sys.getenv_exn: environment variable %s is not set" var () ;; let getenv var = match Stdlib.Sys.getenv var with | x -> Some x | exception Stdlib.Not_found -> None ;; external opaque_identity : ('a[@local_opt]) -> ('a[@local_opt]) = "%opaque" external opaque_identity_global : 'a -> 'a = "%opaque" exception Break = Stdlib.Sys.Break base-0.16.3/src/t.ml000066400000000000000000000006131446274340700141120ustar00rootroot00000000000000(** This module defines various abstract interfaces that are convenient when one needs a module that matches a bare signature with just a type. This sometimes occurs in functor arguments and in interfaces. *) open! Import module type T = sig type t end module type T1 = sig type 'a t end module type T2 = sig type ('a, 'b) t end module type T3 = sig type ('a, 'b, 'c) t end base-0.16.3/src/type_equal.ml000066400000000000000000000107521446274340700160240ustar00rootroot00000000000000open! Import type ('a, 'b) t = T : ('a, 'a) t [@@deriving_inline sexp_of] let sexp_of_t : 'a 'b. ('a -> Sexplib0.Sexp.t) -> ('b -> Sexplib0.Sexp.t) -> ('a, 'b) t -> Sexplib0.Sexp.t = fun (type a__003_ b__004_) : ((a__003_ -> Sexplib0.Sexp.t) -> (b__004_ -> Sexplib0.Sexp.t) -> (a__003_, b__004_) t -> Sexplib0.Sexp.t) -> fun _of_a__001_ _of_b__002_ T -> Sexplib0.Sexp.Atom "T" ;; [@@@end] type ('a, 'b) equal = ('a, 'b) t let refl = T let sym (type a b) (T : (a, b) t) : (b, a) t = T let trans (type a b c) (T : (a, b) t) (T : (b, c) t) : (a, c) t = T let conv (type a b) (T : (a, b) t) (a : a) : b = a module Lift (X : sig type 'a t end) = struct let lift (type a b) (T : (a, b) t) : (a X.t, b X.t) t = T end module Lift2 (X : sig type ('a1, 'a2) t end) = struct let lift (type a1 b1 a2 b2) (T : (a1, b1) t) (T : (a2, b2) t) : ((a1, a2) X.t, (b1, b2) X.t) t = T ;; end module Lift3 (X : sig type ('a1, 'a2, 'a3) t end) = struct let lift (type a1 b1 a2 b2 a3 b3) (T : (a1, b1) t) (T : (a2, b2) t) (T : (a3, b3) t) : ((a1, a2, a3) X.t, (b1, b2, b3) X.t) t = T ;; end let detuple2 (type a1 a2 b1 b2) (T : (a1 * a2, b1 * b2) t) : (a1, b1) t * (a2, b2) t = T, T ;; let tuple2 (type a1 a2 b1 b2) (T : (a1, b1) t) (T : (a2, b2) t) : (a1 * a2, b1 * b2) t = T module type Injective = sig type 'a t val strip : ('a t, 'b t) equal -> ('a, 'b) equal end module type Injective2 = sig type ('a1, 'a2) t val strip : (('a1, 'a2) t, ('b1, 'b2) t) equal -> ('a1, 'b1) equal * ('a2, 'b2) equal end module Composition_preserves_injectivity (M1 : Injective) (M2 : Injective) = struct type 'a t = 'a M1.t M2.t let strip e = M1.strip (M2.strip e) end module Id = struct module Uid = Int module Witness = struct module Key = struct type _ t = .. type type_witness_int = [ `type_witness of int ] [@@deriving_inline sexp_of] let sexp_of_type_witness_int = (fun (`type_witness v__005_) -> Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "type_witness"; sexp_of_int v__005_ ] : type_witness_int -> Sexplib0.Sexp.t) ;; [@@@end] let sexp_of_t _sexp_of_a t = `type_witness (Stdlib.Obj.Extension_constructor.id (Stdlib.Obj.Extension_constructor.of_val t)) |> sexp_of_type_witness_int ;; end module type S = sig type t type _ Key.t += Key : t Key.t end type 'a t = (module S with type t = 'a) let sexp_of_t (type a) sexp_of_a (module M : S with type t = a) = M.Key |> Key.sexp_of_t sexp_of_a ;; let create (type t) () = let module M = struct type nonrec t = t type _ Key.t += Key : t Key.t end in (module M : S with type t = t) ;; let uid (type a) (module M : S with type t = a) = Stdlib.Obj.Extension_constructor.id (Stdlib.Obj.Extension_constructor.of_val M.Key) ;; (* We want a constant allocated once that [same] can return whenever it gets the same witnesses. If we write the constant inside the body of [same], the native-code compiler will do the right thing and lift it out. But for clarity and robustness, we do it ourselves. *) let some_t = Some T let same (type a b) (a : a t) (b : b t) : (a, b) equal option = let module A = (val a : S with type t = a) in let module B = (val b : S with type t = b) in match A.Key with | B.Key -> some_t | _ -> None ;; end type 'a t = { witness : 'a Witness.t ; name : string ; to_sexp : 'a -> Sexp.t } let sexp_of_t _ { witness; name; to_sexp } : Sexp.t = if am_testing then Atom name else List [ List [ Atom "name"; Atom name ] ; List [ Atom "witness"; witness |> Witness.sexp_of_t to_sexp ] ] ;; let to_sexp t = t.to_sexp let name t = t.name let create ~name to_sexp = { witness = Witness.create (); name; to_sexp } let uid t = Witness.uid t.witness let hash t = uid t let hash_fold_t s t = hash_fold_int s (uid t) let same_witness t1 t2 = Witness.same t1.witness t2.witness let same t1 t2 = Option.is_some (same_witness t1 t2) let same_witness_exn t1 t2 = match same_witness t1 t2 with | Some w -> w | None -> Error.raise_s (Sexp.message "Type_equal.Id.same_witness_exn got different ids" [ ( "" , sexp_of_pair (sexp_of_t sexp_of_opaque) (sexp_of_t sexp_of_opaque) (t1, t2) ) ]) ;; end base-0.16.3/src/type_equal.mli000066400000000000000000000205741446274340700162000ustar00rootroot00000000000000(** The purpose of [Type_equal] is to represent type equalities that the type checker otherwise would not know, perhaps because the type equality depends on dynamic data, or perhaps because the type system isn't powerful enough. A value of type [(a, b) Type_equal.t] represents that types [a] and [b] are equal. One can think of such a value as a proof of type equality. The [Type_equal] module has operations for constructing and manipulating such proofs. For example, the functions [refl], [sym], and [trans] express the usual properties of reflexivity, symmetry, and transitivity of equality. If one has a value [t : (a, b) Type_equal.t] that proves types [a] and [b] are equal, there are two ways to use [t] to safely convert a value of type [a] to a value of type [b]: [Type_equal.conv] or pattern matching on [Type_equal.T]: {[ let f (type a) (type b) (t : (a, b) Type_equal.t) (a : a) : b = Type_equal.conv t a let f (type a) (type b) (t : (a, b) Type_equal.t) (a : a) : b = let Type_equal.T = t in a ]} At runtime, conversion by either means is just the identity -- nothing is changing about the value. Consistent with this, a value of type [Type_equal.t] is always just a constructor [Type_equal.T]; the value has no interesting semantic content. [Type_equal] gets its power from the ability to, in a type-safe way, prove to the type checker that two types are equal. The [Type_equal.t] value that is passed is necessary for the type-checker's rules to be correct, but the compiler could, in principle, not pass around values of type [Type_equal.t] at runtime. *) open! Import open T type ('a, 'b) t = T : ('a, 'a) t [@@deriving_inline sexp_of] val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> ('b -> Sexplib0.Sexp.t) -> ('a, 'b) t -> Sexplib0.Sexp.t [@@@end] (** just an alias, needed when [t] gets shadowed below *) type ('a, 'b) equal = ('a, 'b) t (** [refl], [sym], and [trans] construct proofs that type equality is reflexive, symmetric, and transitive. *) val refl : ('a, 'a) t val sym : ('a, 'b) t -> ('b, 'a) t val trans : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t (** [conv t x] uses the type equality [t : (a, b) t] as evidence to safely cast [x] from type [a] to type [b]. [conv] is semantically just the identity function. In a program that has [t : (a, b) t] where one has a value of type [a] that one wants to treat as a value of type [b], it is often sufficient to pattern match on [Type_equal.T] rather than use [conv]. However, there are situations where OCaml's type checker will not use the type equality [a = b], and one must use [conv]. For example: {[ module F (M1 : sig type t end) (M2 : sig type t end) : sig val f : (M1.t, M2.t) equal -> M1.t -> M2.t end = struct let f equal (m1 : M1.t) = conv equal m1 end ]} If one wrote the body of [F] using pattern matching on [T]: {[ let f (T : (M1.t, M2.t) equal) (m1 : M1.t) = (m1 : M2.t) ]} this would give a type error. *) val conv : ('a, 'b) t -> 'a -> 'b (** It is always safe to conclude that if type [a] equals [b], then for any type ['a t], type [a t] equals [b t]. The OCaml type checker uses this fact when it can. However, sometimes, e.g., when using [conv], one needs to explicitly use this fact to construct an appropriate [Type_equal.t]. The [Lift*] functors do this. *) module Lift (X : T1) : sig val lift : ('a, 'b) t -> ('a X.t, 'b X.t) t end module Lift2 (X : T2) : sig val lift : ('a1, 'b1) t -> ('a2, 'b2) t -> (('a1, 'a2) X.t, ('b1, 'b2) X.t) t end module Lift3 (X : T3) : sig val lift : ('a1, 'b1) t -> ('a2, 'b2) t -> ('a3, 'b3) t -> (('a1, 'a2, 'a3) X.t, ('b1, 'b2, 'b3) X.t) t end (** [tuple2] and [detuple2] convert between equality on a 2-tuple and its components. *) val detuple2 : ('a1 * 'a2, 'b1 * 'b2) t -> ('a1, 'b1) t * ('a2, 'b2) t val tuple2 : ('a1, 'b1) t -> ('a2, 'b2) t -> ('a1 * 'a2, 'b1 * 'b2) t (** [Injective] is an interface that states that a type is injective, where the type is viewed as a function from types to other types. The typical usage is: {[ type 'a t include Injective with type 'a t := 'a t ]} For example, ['a list] is an injective type, because whenever ['a list = 'b list], we know that ['a] = ['b]. On the other hand, if we define: {[ type 'a t = unit ]} then clearly [t] isn't injective, because, e.g., [int t = bool t], but [int <> bool]. If [module M : Injective], then [M.strip] provides a way to get a proof that two types are equal from a proof that both types transformed by [M.t] are equal. OCaml has no built-in language feature to state that a type is injective, which is why we have [module type Injective]. However, OCaml can infer that a type is injective, and we can use this to match [Injective]. A typical implementation will look like this: {[ let strip (type a) (type b) (Type_equal.T : (a t, b t) Type_equal.t) : (a, b) Type_equal.t = Type_equal.T ]} This will not type check for all type constructors (certainly not for non-injective ones!), but it's always safe to try the above implementation if you are unsure. If OCaml accepts this definition, then the type is injective. On the other hand, if OCaml doesn't, then the type may or may not be injective. For example, if the definition of the type depends on abstract types that match [Injective], OCaml will not automatically use their injectivity, and one will have to write a more complicated definition of [strip] that causes OCaml to use that fact. For example: {[ module F (M : Type_equal.Injective) : Type_equal.Injective = struct type 'a t = 'a M.t * int let strip (type a) (type b) (e : (a t, b t) Type_equal.t) : (a, b) Type_equal.t = let e1, _ = Type_equal.detuple2 e in M.strip e1 ;; end ]} If in the definition of [F] we had written the simpler implementation of [strip] that didn't use [M.strip], then OCaml would have reported a type error. *) module type Injective = sig type 'a t val strip : ('a t, 'b t) equal -> ('a, 'b) equal end (** [Injective2] is for a binary type that is injective in both type arguments. *) module type Injective2 = sig type ('a1, 'a2) t val strip : (('a1, 'a2) t, ('b1, 'b2) t) equal -> ('a1, 'b1) equal * ('a2, 'b2) equal end (** [Composition_preserves_injectivity] is a functor that proves that composition of injective types is injective. *) module Composition_preserves_injectivity (M1 : Injective) (M2 : Injective) : Injective with type 'a t = 'a M1.t M2.t (** [Id] provides identifiers for types, and the ability to test (via [Id.same]) at runtime if two identifiers are equal, and if so to get a proof of equality of their types. Unlike values of type [Type_equal.t], values of type [Id.t] do have semantic content and must have a nontrivial runtime representation. *) module Id : sig type 'a t [@@deriving_inline sexp_of] val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t [@@@end] (** Every [Id.t] contains a unique id that is distinct from the [Uid.t] in any other [Id.t]. *) module Uid : Identifiable.S val uid : _ t -> Uid.t (** [create ~name] defines a new type identity. Two calls to [create] will result in two distinct identifiers, even for the same arguments with the same type. If the type ['a] doesn't support sexp conversion, then a good practice is to have the converter be [[%sexp_of: _]], (or [sexp_of_opaque], if not using ppx_sexp_conv). *) val create : name:string -> ('a -> Sexp.t) -> 'a t (** Accessors *) val hash : _ t -> int val name : _ t -> string val to_sexp : 'a t -> 'a -> Sexp.t val hash_fold_t : Hash.state -> _ t -> Hash.state (** [same_witness t1 t2] and [same_witness_exn t1 t2] return a type equality proof iff the two identifiers are the same (i.e., physically equal, resulting from the same call to [create]). This is a useful way to achieve a sort of dynamic typing. [same_witness] does not allocate a [Some] every time it is called. [same t1 t2 = is_some (same_witness t1 t2)]. *) val same : _ t -> _ t -> bool val same_witness : 'a t -> 'b t -> ('a, 'b) equal option val same_witness_exn : 'a t -> 'b t -> ('a, 'b) equal end base-0.16.3/src/uchar.ml000066400000000000000000000047731446274340700147640ustar00rootroot00000000000000open! Import let failwithf = Printf.failwithf module T = struct include Uchar0 let module_name = "Base.Uchar" let hash_fold_t state t = Hash.fold_int state (to_int t) let hash t = Hash.run hash_fold_t t let to_string t = Printf.sprintf "U+%04X" (to_int t) (* Do not actually export this. See discussion in the .mli *) let sexp_of_t t = Sexp.Atom (to_string t) let t_of_sexp sexp = match sexp with | Sexp.List _ -> of_sexp_error "Uchar.t_of_sexp: atom needed" sexp | Sexp.Atom s -> (try Stdlib.Scanf.sscanf s "U+%X" (fun i -> Uchar0.of_int i) with | _ -> of_sexp_error "Uchar.t_of_sexp: atom of the form U+XXXX needed" sexp) ;; let t_sexp_grammar : t Sexplib0.Sexp_grammar.t = Sexplib0.Sexp_grammar.coerce String.t_sexp_grammar ;; end include T include Pretty_printer.Register (T) include Comparable.Make (T) (* Open replace_polymorphic_compare after including functor instantiations so they do not shadow its definitions. This is here so that efficient versions of the comparison functions are available within this module. *) open! Uchar_replace_polymorphic_compare let invariant (_ : t) = () let int_is_scalar = is_valid let succ_exn c = try Uchar0.succ c with | Invalid_argument msg -> failwithf "Uchar.succ_exn: %s" msg () ;; let succ c = try Some (Uchar0.succ c) with | Invalid_argument _ -> None ;; let pred_exn c = try Uchar0.pred c with | Invalid_argument msg -> failwithf "Uchar.pred_exn: %s" msg () ;; let pred c = try Some (Uchar0.pred c) with | Invalid_argument _ -> None ;; let of_scalar i = if int_is_scalar i then Some (unsafe_of_int i) else None let of_scalar_exn i = if int_is_scalar i then unsafe_of_int i else failwithf "Uchar.of_int_exn got a invalid Unicode scalar value: %04X" i () ;; let to_scalar t = Uchar0.to_int t let to_char c = if is_char c then Some (unsafe_to_char c) else None let to_char_exn c = if is_char c then unsafe_to_char c else failwithf "Uchar.to_char_exn got a non latin-1 character: U+%04X" (to_int c) () ;; let utf8_byte_length uchar = let codepoint = to_scalar uchar in if Int.( < ) codepoint 0x80 then 1 else if Int.( < ) codepoint 0x800 then 2 else if Int.( < ) codepoint 0x10000 then 3 else 4 ;; (* Include type-specific [Replace_polymorphic_compare] at the end, after including functor application that could shadow its definitions. This is here so that efficient versions of the comparison functions are exported by this module. *) include Uchar_replace_polymorphic_compare base-0.16.3/src/uchar.mli000066400000000000000000000040431446274340700151230ustar00rootroot00000000000000(** Unicode character operations. A [Uchar.t] represents a Unicode code point -- that is, an integer identifying the character in abstract. This module does not provide any utilties for converting [Uchar.t]s to and from strings -- in order to do so, one needs to settle on a particular encoding, such as UTF-8 or UTF-16. See, for instance, the [utf8_text] library for converting to and from UTF-8. *) open! Import type t = Uchar0.t [@@deriving_inline hash, sexp, sexp_grammar] include Ppx_hash_lib.Hashable.S with type t := t include Sexplib0.Sexpable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] include Comparable.S with type t := t include Pretty_printer.S with type t := t include Invariant.S with type t := t (** [succ_exn t] is the scalar value after [t] in the set of Unicode scalar values, and raises if [t = max_value]. *) val succ : t -> t option val succ_exn : t -> t (** [pred_exn t] is the scalar value before [t] in the set of Unicode scalar values, and raises if [t = min_value]. *) val pred : t -> t option val pred_exn : t -> t (** [is_char t] is [true] iff [n] is in the latin-1 character set. *) val is_char : t -> bool (** [to_char_exn t] is [t] as a [char] if it is in the latin-1 character set, and raises otherwise. *) val to_char : t -> char option val to_char_exn : t -> char (** [of_char c] is [c] as a Unicode character. *) val of_char : char -> t (** [int_is_scalar n] is [true] iff [n] is an Unicode scalar value (i.e., in the ranges [0x0000]...[0xD7FF] or [0xE000]...[0x10FFFF]). *) val int_is_scalar : int -> bool (** [of_scalar_exn n] is [n] as a Unicode character. Raises if [not (int_is_scalar i)]. *) val of_scalar : int -> t option val of_scalar_exn : int -> t (** [to_scalar t] is [t] as an integer scalar value. *) val to_scalar : t -> int (** [utf8_byte_width t] returns the number of bytes needed to represent [t] in the UTF-8 encoding (https://en.wikipedia.org/wiki/UTF-8). *) val utf8_byte_length : t -> int val min_value : t val max_value : t base-0.16.3/src/uchar0.ml000066400000000000000000000007631446274340700150370ustar00rootroot00000000000000open! Import0 type t = Stdlib.Uchar.t let succ = Stdlib.Uchar.succ let pred = Stdlib.Uchar.pred let is_valid = Stdlib.Uchar.is_valid let is_char = Stdlib.Uchar.is_char let unsafe_to_char = Stdlib.Uchar.unsafe_to_char let unsafe_of_int = Stdlib.Uchar.unsafe_of_int let of_int = Stdlib.Uchar.of_int let to_int = Stdlib.Uchar.to_int let of_char = Stdlib.Uchar.of_char let compare = Stdlib.Uchar.compare let equal = Stdlib.Uchar.equal let min_value = Stdlib.Uchar.min let max_value = Stdlib.Uchar.max base-0.16.3/src/uniform_array.ml000066400000000000000000000134641446274340700165340ustar00rootroot00000000000000open! Import (* WARNING: We use non-memory-safe things throughout the [Trusted] module. Most of it is only safe in combination with the type signature (e.g. exposing [val copy : 'a t -> 'b t] would be a big mistake). *) module Trusted : sig type 'a t val empty : 'a t val unsafe_create_uninitialized : len:int -> 'a t val create_obj_array : len:int -> 'a t val create : len:int -> 'a -> 'a t val singleton : 'a -> 'a t val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> unit val swap : _ t -> int -> int -> unit val unsafe_get : 'a t -> int -> 'a val unsafe_set : 'a t -> int -> 'a -> unit val unsafe_set_omit_phys_equal_check : 'a t -> int -> 'a -> unit val unsafe_set_int : 'a t -> int -> int -> unit val unsafe_set_int_assuming_currently_int : 'a t -> int -> int -> unit val unsafe_set_assuming_currently_int : 'a t -> int -> 'a -> unit val unsafe_set_with_caml_modify : 'a t -> int -> 'a -> unit val set_with_caml_modify : 'a t -> int -> 'a -> unit val length : ('a t[@local]) -> int val unsafe_blit : ('a t, 'a t) Blit.blit val copy : 'a t -> 'a t val unsafe_clear_if_pointer : _ t -> int -> unit end = struct type 'a t = Obj_array.t let empty = Obj_array.empty let unsafe_create_uninitialized ~len = Obj_array.create_zero ~len let create_obj_array ~len = Obj_array.create_zero ~len let create ~len x = Obj_array.create ~len (Stdlib.Obj.repr x) let singleton x = Obj_array.singleton (Stdlib.Obj.repr x) let swap t i j = Obj_array.swap t i j let get arr i = Stdlib.Obj.obj (Obj_array.get arr i) let set arr i x = Obj_array.set arr i (Stdlib.Obj.repr x) let unsafe_get arr i = Stdlib.Obj.obj (Obj_array.unsafe_get arr i) let unsafe_set arr i x = Obj_array.unsafe_set arr i (Stdlib.Obj.repr x) let unsafe_set_int arr i x = Obj_array.unsafe_set_int arr i x let unsafe_set_int_assuming_currently_int arr i x = Obj_array.unsafe_set_int_assuming_currently_int arr i x ;; let unsafe_set_assuming_currently_int arr i x = Obj_array.unsafe_set_assuming_currently_int arr i (Stdlib.Obj.repr x) ;; let length = Obj_array.length let unsafe_blit = Obj_array.unsafe_blit let copy = Obj_array.copy let unsafe_set_omit_phys_equal_check t i x = Obj_array.unsafe_set_omit_phys_equal_check t i (Stdlib.Obj.repr x) ;; let unsafe_set_with_caml_modify t i x = Obj_array.unsafe_set_with_caml_modify t i (Stdlib.Obj.repr x) ;; let set_with_caml_modify t i x = Obj_array.set_with_caml_modify t i (Stdlib.Obj.repr x) let unsafe_clear_if_pointer = Obj_array.unsafe_clear_if_pointer end include Trusted let invariant t = assert (Stdlib.Obj.tag (Stdlib.Obj.repr t) <> Stdlib.Obj.double_array_tag) ;; let init l ~f = if l < 0 then invalid_arg "Uniform_array.init" else ( let res = unsafe_create_uninitialized ~len:l in for i = 0 to l - 1 do unsafe_set res i (f i) done; res) ;; let of_array arr = init ~f:(Array.unsafe_get arr) (Array.length arr) [@nontail] let map a ~f = init ~f:(fun i -> f (unsafe_get a i)) (length a) [@nontail] let mapi a ~f = init ~f:(fun i -> f i (unsafe_get a i)) (length a) [@nontail] let iter a ~f = for i = 0 to length a - 1 do f (unsafe_get a i) done ;; let iteri a ~f = for i = 0 to length a - 1 do f i (unsafe_get a i) done ;; let foldi a ~init ~f = let acc = ref init in for i = 0 to length a - 1 do acc := f i !acc (unsafe_get a i) done; !acc ;; let to_list t = List.init ~f:(get t) (length t) let of_list l = let len = List.length l in let res = unsafe_create_uninitialized ~len in List.iteri l ~f:(fun i x -> set res i x); res ;; (* It is not safe for [to_array] to be the identity function because we have code that relies on [float array]s being unboxed, for example in [bin_write_array]. *) let to_array t = Array.init (length t) ~f:(fun i -> unsafe_get t i) let exists t ~f = let rec loop t ~f i = if i < 0 then false else f (unsafe_get t i) || loop t ~f (i - 1) in loop t ~f (length t - 1) ;; let for_all t ~f = let rec loop t ~f i = if i < 0 then true else f (unsafe_get t i) && loop t ~f (i - 1) in loop t ~f (length t - 1) ;; let map2_exn t1 t2 ~f = let len = length t1 in if length t2 <> len then invalid_arg "Array.map2_exn"; init len ~f:(fun i -> f (unsafe_get t1 i) (unsafe_get t2 i)) [@nontail] ;; let t_sexp_grammar (type elt) (grammar : elt Sexplib0.Sexp_grammar.t) : elt t Sexplib0.Sexp_grammar.t = Sexplib0.Sexp_grammar.coerce (Array.t_sexp_grammar grammar) ;; include Sexpable.Of_sexpable1 (Array) (struct type nonrec 'a t = 'a t let to_sexpable = to_array let of_sexpable = of_array end) include Blit.Make1 (struct type nonrec 'a t = 'a t let length = length let create_like ~len t = if len = 0 then empty else ( assert (length t > 0); create ~len (get t 0)) ;; let unsafe_blit = unsafe_blit end) let fold t ~init ~f = let r = ref init in for i = 0 to length t - 1 do r := f !r (unsafe_get t i) done; !r ;; let min_elt t ~compare = Container.min_elt ~fold t ~compare let max_elt t ~compare = Container.max_elt ~fold t ~compare (* This is the same as the ppx_compare [compare_array] but uses our [unsafe_get] and [length]. *) let compare compare_elt a b = if phys_equal a b then 0 else ( let len_a = length a in let len_b = length b in let ret = compare len_a len_b in if ret <> 0 then ret else ( let rec loop i = if i = len_a then 0 else ( let l = unsafe_get a i and r = unsafe_get b i in let res = compare_elt l r in if res <> 0 then res else loop (i + 1)) in loop 0)) ;; module Sort = Array.Private.Sorter (struct type nonrec 'a t = 'a t let length = length let get = unsafe_get let set = unsafe_set end) let sort = Sort.sort base-0.16.3/src/uniform_array.mli000066400000000000000000000110141446274340700166720ustar00rootroot00000000000000(** Same semantics as ['a Array.t], except it's guaranteed that the representation array is not tagged with [Double_array_tag], the tag for float arrays. This means it's safer to use in the presence of [Obj.magic], but it's slower than normal [Array] if you use it with floats. It can often be faster than [Array] if you use it with non-floats. *) open! Import (** See [Base.Array] for comments. *) type 'a t [@@deriving_inline sexp, sexp_grammar, compare] include Sexplib0.Sexpable.S1 with type 'a t := 'a t val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t [@@@end] val invariant : _ t -> unit val empty : _ t val create : len:int -> 'a -> 'a t val singleton : 'a -> 'a t val init : int -> f:((int -> 'a)[@local]) -> 'a t val length : ('a t[@local]) -> int val get : 'a t -> int -> 'a val unsafe_get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> unit val unsafe_set : 'a t -> int -> 'a -> unit val swap : _ t -> int -> int -> unit (** [unsafe_set_omit_phys_equal_check] is like [unsafe_set], except it doesn't do a [phys_equal] check to try to skip [caml_modify]. It is safe to call this even if the values are [phys_equal]. *) val unsafe_set_omit_phys_equal_check : 'a t -> int -> 'a -> unit (** [unsafe_set_with_caml_modify] always calls [caml_modify] before setting and never gets the old value. This is like [unsafe_set_omit_phys_equal_check] except it doesn't check whether the old value and the value being set are integers to try to skip [caml_modify]. *) val unsafe_set_with_caml_modify : 'a t -> int -> 'a -> unit (** Same as [unsafe_set_with_caml_modify], but with bounds check. *) val set_with_caml_modify : 'a t -> int -> 'a -> unit val map : 'a t -> f:(('a -> 'b)[@local]) -> 'b t val mapi : 'a t -> f:((int -> 'a -> 'b)[@local]) -> 'b t val iter : 'a t -> f:(('a -> unit)[@local]) -> unit (** Like {!iter}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) val iteri : 'a t -> f:((int -> 'a -> unit)[@local]) -> unit val foldi : 'a t -> init:'acc -> f:((int -> 'acc -> 'a -> 'acc)[@local]) -> 'acc (** [of_array] and [to_array] return fresh arrays with the same contents rather than returning a reference to the underlying array. *) val of_array : 'a array -> 'a t val to_array : 'a t -> 'a array val of_list : 'a list -> 'a t val to_list : 'a t -> 'a list include Blit.S1 with type 'a t := 'a t val copy : 'a t -> 'a t (** {2 Extra lowlevel and unsafe functions} *) (** The behavior is undefined if you access an element before setting it. *) val unsafe_create_uninitialized : len:int -> _ t (** New obj array filled with [Obj.repr 0] *) val create_obj_array : len:int -> Stdlib.Obj.t t (** [unsafe_set_assuming_currently_int t i obj] sets index [i] of [t] to [obj], but only works correctly if the value there is an immediate, i.e. [Stdlib.Obj.is_int (get t i)]. This precondition saves a dynamic check. [unsafe_set_int_assuming_currently_int] is similar, except the value being set is an int. [unsafe_set_int] is similar but does not assume anything about the target. *) val unsafe_set_assuming_currently_int : Stdlib.Obj.t t -> int -> Stdlib.Obj.t -> unit val unsafe_set_int_assuming_currently_int : Stdlib.Obj.t t -> int -> int -> unit val unsafe_set_int : Stdlib.Obj.t t -> int -> int -> unit (** [unsafe_clear_if_pointer t i] prevents [t.(i)] from pointing to anything to prevent space leaks. It does this by setting [t.(i)] to [Stdlib.Obj.repr 0]. As a performance hack, it only does this when [not (Stdlib.Obj.is_int t.(i))]. It is an error to access the cleared index before setting it again. *) val unsafe_clear_if_pointer : Stdlib.Obj.t t -> int -> unit (** As [Array.exists]. *) val exists : 'a t -> f:(('a -> bool)[@local]) -> bool (** As [Array.for_all]. *) val for_all : 'a t -> f:(('a -> bool)[@local]) -> bool (** Functions with the 2 suffix raise an exception if the lengths of the two given arrays aren't the same. *) val map2_exn : 'a t -> 'b t -> f:(('a -> 'b -> 'c)[@local]) -> 'c t val min_elt : 'a t -> compare:(('a -> 'a -> int)[@local]) -> 'a option val max_elt : 'a t -> compare:(('a -> 'a -> int)[@local]) -> 'a option (** [sort] uses constant heap space. To sort only part of the array, specify [pos] to be the index to start sorting from and [len] indicating how many elements to sort. *) val sort : ?pos:int -> ?len:int -> 'a t -> compare:(('a -> 'a -> int)[@local]) -> unit base-0.16.3/src/unit.ml000066400000000000000000000016051446274340700146300ustar00rootroot00000000000000open! Import module T = struct type t = unit [@@deriving_inline enumerate, globalize, hash, sexp, sexp_grammar] let all = ([ () ] : t list) let (globalize : (t[@ocaml.local]) -> t) = (globalize_unit : (t[@ocaml.local]) -> t) let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) = hash_fold_unit and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let func = hash_unit in fun x -> func x ;; let t_of_sexp = (unit_of_sexp : Sexplib0.Sexp.t -> t) let sexp_of_t = (sexp_of_unit : t -> Sexplib0.Sexp.t) let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = unit_sexp_grammar [@@@end] let compare _ _ = 0 let of_string = function | "()" -> () | _ -> failwith "Base.Unit.of_string: () expected" ;; let to_string () = "()" let module_name = "Base.Unit" end include T include Identifiable.Make (T) let invariant () = () base-0.16.3/src/unit.mli000066400000000000000000000006241446274340700150010ustar00rootroot00000000000000(** Module for the type [unit]. *) open! Import type t = unit [@@deriving_inline enumerate, globalize, sexp, sexp_grammar] include Ppx_enumerate_lib.Enumerable.S with type t := t val globalize : (t[@ocaml.local]) -> t include Sexplib0.Sexpable.S with type t := t val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] include Identifiable.S with type t := t include Invariant.S with type t := t base-0.16.3/src/variant.ml000066400000000000000000000002541446274340700153140ustar00rootroot00000000000000type 'constructor t = { name : string ; (* the position of the constructor in the type definition, starting from 0 *) rank : int ; constructor : 'constructor } base-0.16.3/src/variant.mli000066400000000000000000000004371446274340700154700ustar00rootroot00000000000000(** First-class representative of an individual variant in a variant type, used in [[@@deriving variants]]. *) type 'constructor t = { name : string (** The position of the constructor in the type definition, starting from 0 *) ; rank : int ; constructor : 'constructor } base-0.16.3/src/variantslib.ml000066400000000000000000000001731446274340700161660ustar00rootroot00000000000000(** This module is for use by ppx_variants_conv, and is thus not in the interface of Base. *) module Variant = Variant base-0.16.3/src/with_return.ml000066400000000000000000000016471446274340700162310ustar00rootroot00000000000000(* belongs in Common, but moved here to avoid circular dependencies *) open! Import type 'a return = { return : 'b. 'a -> 'b } [@@unboxed] let with_return (type a) f = let module M = struct (* Raised to indicate ~return was called. Local so that the exception is tied to a particular call of [with_return]. *) exception Return of a end in let is_alive = ref true in let return a = if not !is_alive then failwith "use of [return] from a [with_return] that already returned"; Exn.raise_without_backtrace (M.Return a) in try let a = f { return } in is_alive := false; a with | exn -> is_alive := false; (match exn with | M.Return a -> a | _ -> raise exn) ;; let with_return_option f = with_return (fun return -> f { return = (fun a -> return.return (Some a)) }; None) [@nontail] ;; let prepend { return } ~f = { return = (fun x -> return (f x)) } base-0.16.3/src/with_return.mli000066400000000000000000000041501446274340700163720ustar00rootroot00000000000000 (** [with_return f] allows for something like the return statement in C within [f]. There are three ways [f] can terminate: + If [f] calls [r.return x], then [x] is returned by [with_return]. + If [f] evaluates to a value [x], then [x] is returned by [with_return]. + If [f] raises an exception, it escapes [with_return]. Here is a typical example: {[ let find l ~f = with_return (fun r -> List.iter l ~f:(fun x -> if f x then r.return (Some x)); None ) ]} It is only because of a deficiency of ML types that [with_return] doesn't have type: {[ val with_return : 'a. (('a -> ('b. 'b)) -> 'a) -> 'a ]} but we can slightly increase the scope of ['b] without changing the meaning of the type, and then we get: {[ type 'a return = { return : 'b . 'a -> 'b } val with_return : ('a return -> 'a) -> 'a ]} But the actual reason we chose to use a record type with polymorphic field is that otherwise we would have to clobber the namespace of functions with [return] and that is undesirable because [return] would get hidden as soon as we open any monad. We considered names different than [return] but everything seemed worse than just having [return] as a record field. We are clobbering the namespace of record fields but that is much more acceptable. *) open! Import type -'a return = private { return : 'b. 'a -> 'b } [@@unboxed] val with_return : (('a return -> 'a)[@local]) -> 'a (** Note that [with_return_option] allocates ~5 words more than the equivalent [with_return] call. *) val with_return_option : (('a return -> unit)[@local]) -> 'a option (** [prepend a ~f] returns a value [x] such that each call to [x.return] first applies [f] before applying [a.return]. The call to [f] is "prepended" to the call to the original [a.return]. A possible use case is to hand [x] over to another function which returns ['b], a subtype of ['a], or to capture a common transformation [f] applied to returned values at several call sites. *) val prepend : 'a return -> f:('b -> 'a) -> 'b return base-0.16.3/src/word_size.ml000066400000000000000000000006411446274340700156550ustar00rootroot00000000000000open! Import module Sys = Sys0 type t = | W32 | W64 [@@deriving_inline sexp_of] let sexp_of_t = (function | W32 -> Sexplib0.Sexp.Atom "W32" | W64 -> Sexplib0.Sexp.Atom "W64" : t -> Sexplib0.Sexp.t) ;; [@@@end] let num_bits = function | W32 -> 32 | W64 -> 64 ;; let word_size = match Sys.word_size_in_bits with | 32 -> W32 | 64 -> W64 | _ -> failwith "unknown word size" ;; base-0.16.3/src/word_size.mli000066400000000000000000000004511446274340700160250ustar00rootroot00000000000000(** For determining the word size that the program is using. *) open! Import type t = | W32 | W64 [@@deriving_inline sexp_of] val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] val num_bits : t -> int (** Returns the word size of this program, not necessarily of the OS. *) val word_size : t base-0.16.3/test/000077500000000000000000000000001446274340700135055ustar00rootroot00000000000000base-0.16.3/test/allocation/000077500000000000000000000000001446274340700156325ustar00rootroot00000000000000base-0.16.3/test/allocation/base_test_allocation.ml000066400000000000000000000000731446274340700223420ustar00rootroot00000000000000(*_ This library deliberately does not export anything. *) base-0.16.3/test/allocation/bin/000077500000000000000000000000001446274340700164025ustar00rootroot00000000000000base-0.16.3/test/allocation/bin/dune000066400000000000000000000002521446274340700172570ustar00rootroot00000000000000(executables (names test_option_array_allocation) (libraries base expect_test_helpers_core compiler-libs.common core_kernel.version_util) (preprocess (pps ppx_jane)))base-0.16.3/test/allocation/bin/test_option_array_allocation.ml000066400000000000000000000027701446274340700247140ustar00rootroot00000000000000open! Base open Option_array open Expect_test_helpers_core let () = let t = of_array [| None |] in assert ( require_no_allocation [%here] (fun () -> match get t 0 with | None -> true | Some _ -> false)) ;; let () = let t = of_array [| Some 0 |] in let get_some () = match get t 0 with | None -> false | Some _ -> true in (* After inlining, [match get t 0 with] is: {[ match let cheap_option = Uniform_array.get t 0 in if Cheap_option.is_some cheap_option then Some (Cheap_option.value_unsafe cheap_option) else None with ]} This situation is called "match-in-match" (the inner [if] is essentially a match). The OCaml compiler and Flambda optimizer don't handle match-in-match well, and so cannot eliminate the allocation of [Some]. Flambda2 is expected to eliminate the allocation, at which point we can [require_no_allocation] (possibly annotating the test with [@tags "fast-flambda"]). *) let compiler_eliminates_the_allocation = (* [Version_util.x_library_inlining] is the whole reason this is a separate executable. *) Config.flambda2 && Version_util.x_library_inlining in if compiler_eliminates_the_allocation then assert (require_no_allocation [%here] get_some) else let module Gc = Core.Gc.For_testing in let _, { Gc.Allocation_report.minor_words_allocated; _ } = Gc.measure_allocation get_some in assert (minor_words_allocated = 2) ;; base-0.16.3/test/allocation/bin/test_option_array_allocation.mli000066400000000000000000000000551446274340700250570ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/allocation/dune000066400000000000000000000002151446274340700165060ustar00rootroot00000000000000(library (name base_test_allocation) (libraries async base expect_test_helpers_async expect_test_helpers_core) (preprocess (pps ppx_jane)))base-0.16.3/test/allocation/test_array_allocation.ml000066400000000000000000000015531446274340700225520ustar00rootroot00000000000000open! Base open Expect_test_helpers_core let%expect_test "Array.sort [||] only allocates when computing bounds" = require_allocation_does_not_exceed (Minor_words 3) [%here] (fun () -> Array.sort ~compare:Int.compare [||]); [%expect {||}] ;; let%expect_test "Array.sort [| 5; 2; 3; 4; 1 |] only allocates when computing bounds" = let arr = [| 5; 2; 3; 4; 1 |] in require_allocation_does_not_exceed (Minor_words 3) [%here] (fun () -> Array.sort ~compare:Int.compare arr); [%expect {||}] ;; let%test "equal does not allocate" = let arr1 = [| 1; 2; 3; 4 |] in let arr2 = [| 1; 2; 4; 3 |] in require_no_allocation [%here] (fun () -> not (Array.equal Int.equal arr1 arr2)) ;; let%test "foldi does not allocate" = let arr = [| 1; 2; 3; 4 |] in let f i x y = i + x + y in require_no_allocation [%here] (fun () -> 16 = Array.foldi ~init:0 ~f arr) ;; base-0.16.3/test/allocation/test_array_allocation.mli000066400000000000000000000000551446274340700227170ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/allocation/test_char_allocation.ml000066400000000000000000000004131446274340700223430ustar00rootroot00000000000000open! Base open Expect_test_helpers_core let%expect_test _ = let x = Sys.opaque_identity 'a' in let y = Sys.opaque_identity 'b' in require_no_allocation [%here] (fun () -> ignore (Sys.opaque_identity (Char.Caseless.equal x y) : bool)); [%expect {||}] ;; base-0.16.3/test/allocation/test_char_allocation.mli000066400000000000000000000000551446274340700225160ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/allocation/test_float_allocation.ml000066400000000000000000000004011446274340700225300ustar00rootroot00000000000000open! Base open Stdio open Float let%expect_test "iround_nearest_exn noalloc" = let t = Sys.opaque_identity 205.414 in Expect_test_helpers_core.require_no_allocation [%here] (fun () -> iround_nearest_exn t) |> printf "%d\n"; [%expect {| 205 |}] ;; base-0.16.3/test/allocation/test_float_allocation.mli000066400000000000000000000000551446274340700227060ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/allocation/test_hashtbl_allocation.ml000066400000000000000000000043511446274340700230600ustar00rootroot00000000000000open! Base open Expect_test_helpers_core let () = Int_conversions.sexp_of_int_style := `Underscores let%expect_test "find_and_call_1_and_2" = let test x = let t = Hashtbl.create (module Int) ~size:16 ~growth_allowed:false in for i = 0 to x - 1 do Hashtbl.add_exn t ~key:i ~data:(i * 7) done; let if_found a b = assert (a = b) in let if_not_found a b = assert (a = x); assert (b = x * 7) in require_no_allocation [%here] (fun () -> for i = 0 to x do Hashtbl.find_and_call1 t i ~a:(i * 7) ~if_found ~if_not_found done); let if_found ~key ~data:a b = assert (a = b); assert (key = a / 7) in let if_not_found a b = assert (a = x); assert (b = x * 7) in require_no_allocation [%here] (fun () -> for i = 0 to x do Hashtbl.findi_and_call1 t i ~a:(i * 7) ~if_found ~if_not_found done); let if_found a b c = assert (a = b); assert (b = c / 2) in let if_not_found a b c = assert (a = x); assert (b = x * 7); assert (c = x * 14) in require_no_allocation [%here] (fun () -> for i = 0 to x do Hashtbl.find_and_call2 t i ~a:(i * 7) ~b:(i * 14) ~if_found ~if_not_found done); let if_found ~key ~data:a b c = assert (a = b); assert (b = c / 2); assert (key = a / 7) in let if_not_found a b c = assert (a = x); assert (b = x * 7); assert (c = x * 14) in require_no_allocation [%here] (fun () -> for i = 0 to x do Hashtbl.findi_and_call2 t i ~a:(i * 7) ~b:(i * 14) ~if_found ~if_not_found done); print_s (Int.sexp_of_t x) in (* try various load factors, to exercise all branches of matching on the structure of the avl tree *) test 1; test 3; test 10; test 17; test 25; test 29; test 33; test 3133; [%expect {| 1 3 10 17 25 29 33 3_133 |}] ;; let%expect_test ("find_or_add shouldn't allocate" [@tags "no-js"]) = let default = Fn.const () in let t = Hashtbl.create (module Int) ~size:16 ~growth_allowed:false in Hashtbl.add_exn t ~key:100 ~data:(); require_no_allocation [%here] (fun () -> Hashtbl.find_or_add t 100 ~default); [%expect {| |}] ;; base-0.16.3/test/allocation/test_hashtbl_allocation.mli000066400000000000000000000000551446274340700232260ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/allocation/test_list_allocation.ml000066400000000000000000000011731446274340700224050ustar00rootroot00000000000000open! Base open Expect_test_helpers_core let%expect_test "is_prefix does not allocate" = let list = Sys.opaque_identity [ 1; 2; 3 ] in let prefix = Sys.opaque_identity [ 1; 2 ] in let equal = Int.equal in let (_ : bool) = require_no_allocation [%here] (fun () -> List.is_prefix list ~equal ~prefix) in [%expect {| |}] ;; let%expect_test "is_suffix does not allocate" = let list = Sys.opaque_identity [ 1; 2; 3 ] in let suffix = Sys.opaque_identity [ 2; 3 ] in let equal = Int.equal in let (_ : bool) = require_no_allocation [%here] (fun () -> List.is_suffix list ~equal ~suffix) in [%expect {| |}] ;; base-0.16.3/test/allocation/test_list_allocation.mli000066400000000000000000000000551446274340700225540ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/allocation/test_option_array_allocation.ml000066400000000000000000000006131446274340700241360ustar00rootroot00000000000000open! Async open Expect_test_helpers_async let%expect_test _ = (* Sadly, the test is sensitive to cross-library inlining, which we can only detect using the build info in version_util, which isn't available while compiling a test. So we delegate the whole test to this executable: *) let%bind () = run "bin/test_option_array_allocation.exe" [] in [%expect {||}]; return () ;; base-0.16.3/test/allocation/test_option_array_allocation.mli000066400000000000000000000000551446274340700243070ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/allocation/test_string_allocation.ml000066400000000000000000000132431446274340700227410ustar00rootroot00000000000000open! Base open Expect_test_helpers_core let%expect_test _ = let x = Sys.opaque_identity "one string" in let y = Sys.opaque_identity "another" in require_no_allocation [%here] (fun () -> ignore (Sys.opaque_identity (String.Caseless.equal x y) : bool)); [%expect {||}] ;; let%expect_test "empty substring" = let string = String.init 10 ~f:Char.of_int_exn in let test here f = let substring = require_no_allocation here f in assert (String.is_empty substring) in test [%here] (fun () -> String.sub string ~pos:0 ~len:0); test [%here] (fun () -> String.prefix string 0); test [%here] (fun () -> String.suffix string 0); test [%here] (fun () -> String.drop_prefix string 10); test [%here] (fun () -> String.drop_suffix string 10); [%expect {| |}] ;; let%expect_test "mem does not allocate" = let string = Sys.opaque_identity "abracadabra" in let char = Sys.opaque_identity 'd' in require_no_allocation [%here] (fun () -> ignore (String.mem string char : bool)); [%expect {||}] ;; let%expect_test "fold does not allocate" = let string = Sys.opaque_identity "abracadabra" in let char = Sys.opaque_identity 'd' in let f acc c = if Char.equal c char then true else acc in require_no_allocation [%here] (fun () -> ignore (String.fold string ~init:false ~f : bool)); [%expect {||}] ;; let%expect_test "foldi does not allocate" = let string = Sys.opaque_identity "abracadabra" in let char = Sys.opaque_identity 'd' in let f _i acc c = if Char.equal c char then true else acc in require_no_allocation [%here] (fun () -> ignore (String.foldi string ~init:false ~f : bool)); [%expect {||}] ;; let%test_module "common prefix and suffix" = (module struct let require_int_equal a b ~message = require_equal [%here] (module Int) a b ~message let require_string_equal a b ~message = require_equal [%here] (module String) a b ~message ;; let simulate_common_length ~get_common2_length list = let rec loop acc prev list ~get_common2_length = match list with | [] -> acc | head :: tail -> loop (Int.min acc (get_common2_length prev head)) head tail ~get_common2_length in match list with | [] -> 0 | [ head ] -> String.length head | head :: tail -> loop Int.max_value head tail ~get_common2_length ;; let get_shortest_and_longest list = let compare_by_length a b = Comparable.lift Int.compare ~f:String.length a b in Option.both (List.min_elt list ~compare:compare_by_length) (List.max_elt list ~compare:compare_by_length) ;; let test_generic get_common get_common2 get_common_length get_common2_length = Staged.stage (fun list -> let common = get_common list in print_s [%sexp (common : string)]; let len = get_common_length list in require_int_equal len (String.length common) ~message:"wrong length"; let common2 = List.reduce list ~f:get_common2 |> Option.value ~default:"" in require_string_equal common common2 ~message:"pairwise result mismatch"; let len2 = simulate_common_length ~get_common2_length list in require_int_equal len len2 ~message:"pairwise length mismatch"; if not (String.is_empty common || List.mem list common ~equal:String.equal) then print_endline "(may allocate)" else ( ignore (require_no_allocation [%here] (fun () -> get_common list) : string); Option.iter (get_shortest_and_longest list) ~f:(fun (shortest, longest) -> ignore (require_no_allocation [%here] (fun () -> get_common2 shortest longest) : string); ignore (require_no_allocation [%here] (fun () -> get_common2 longest shortest) : string)))) ;; let test_prefix = test_generic String.common_prefix String.common_prefix2 String.common_prefix_length String.common_prefix2_length |> Staged.unstage ;; let test_suffix = test_generic String.common_suffix String.common_suffix2 String.common_suffix_length String.common_suffix2_length |> Staged.unstage ;; let%expect_test "empty" = test_prefix []; [%expect {| "" |}]; test_suffix []; [%expect {| "" |}] ;; let%expect_test "singleton" = test_prefix [ "abut" ]; [%expect {| abut |}]; test_suffix [ "tuba" ]; [%expect {| tuba |}] ;; let%expect_test "doubleton, alloc" = test_prefix [ "hello"; "help"; "hex" ]; [%expect {| he (may allocate) |}]; test_suffix [ "crest"; "zest"; "1st" ]; [%expect {| st (may allocate) |}] ;; let%expect_test "doubleton, no alloc" = test_prefix [ "hello"; "help"; "he" ]; [%expect {| he |}]; test_suffix [ "crest"; "zest"; "st" ]; [%expect {| st |}] ;; let%expect_test "many, alloc" = test_prefix [ "this"; "that"; "the other"; "these"; "those"; "thy"; "thou" ]; [%expect {| th (may allocate) |}]; test_suffix [ "fourth"; "fifth"; "sixth"; "seventh"; "eleventh"; "twelfth" ]; [%expect {| th (may allocate) |}] ;; let%expect_test "many, no alloc" = test_prefix [ "inconsequential"; "invariant"; "in"; "inner"; "increment" ]; [%expect {| in |}]; test_suffix [ "fat"; "cat"; "sat"; "at"; "bat" ]; [%expect {| at |}] ;; let%expect_test "many, nothing in common" = let lorem_ipsum = [ "lorem"; "ipsum"; "dolor"; "sit"; "amet" ] in test_prefix lorem_ipsum; [%expect {| "" |}]; test_suffix lorem_ipsum; [%expect {| "" |}] ;; end) ;; base-0.16.3/test/allocation/test_string_allocation.mli000066400000000000000000000000551446274340700231070ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/allocation/test_type_equal_allocation.ml000066400000000000000000000003731446274340700236030ustar00rootroot00000000000000open! Base open Expect_test_helpers_core let t1 = Type_equal.Id.create ~name:"t1" [%sexp_of: _] let%expect_test "Type_equal.Id.to_sexp allocation" = require_no_allocation [%here] (fun () -> ignore (Type_equal.Id.to_sexp t1 : 'a -> Sexp.t)) ;; base-0.16.3/test/allocation/test_type_equal_allocation.mli000066400000000000000000000000551446274340700237510ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/avltree_unit_tests.ml000066400000000000000000000317061446274340700177710ustar00rootroot00000000000000open! Import let%test_module _ = (module ( struct open Avltree type ('k, 'v) t = ('k, 'v) Avltree.t = private | Empty | Node of { mutable left : ('k, 'v) t ; key : 'k ; mutable value : 'v ; mutable height : int ; mutable right : ('k, 'v) t } | Leaf of { key : 'k ; mutable value : 'v } module For_quickcheck = struct module Key = struct include Int type t = int [@@deriving quickcheck] let quickcheck_generator = Base_quickcheck.Generator.small_positive_or_zero_int ;; end module Data = struct include String type t = string [@@deriving quickcheck] let quickcheck_generator = Base_quickcheck.Generator.string_of Base_quickcheck.Generator.char_lowercase ;; end let compare = Key.compare module Constructor = struct type t = | Add of Key.t * Data.t | Replace of Key.t * Data.t | Remove of Key.t [@@deriving quickcheck, sexp_of] let apply_to_tree t tree = match t with | Add (key, data) -> add tree ~key ~data ~compare ~added:(ref false) ~replace:false | Replace (key, data) -> add tree ~key ~data ~compare ~added:(ref false) ~replace:true | Remove key -> remove tree key ~compare ~removed:(ref false) ;; let apply_to_map t map = match t with | Add (key, data) -> if Map.mem map key then map else Map.set map ~key ~data | Replace (key, data) -> Map.set map ~key ~data | Remove key -> Map.remove map key ;; end module Constructors = struct type t = Constructor.t list [@@deriving quickcheck, sexp_of] end let reify constructors = List.fold constructors ~init:(empty, Map.empty (module Key)) ~f:(fun (t, map) constructor -> ( Constructor.apply_to_tree constructor t , Constructor.apply_to_map constructor map )) ;; let merge map1 map2 = Map.merge map1 map2 ~f:(fun ~key variant -> match variant with | `Left data | `Right data -> Some data | `Both (data1, data2) -> Error.raise_s [%message "duplicate data for key" (key : Key.t) (data1 : Data.t) (data2 : Data.t)]) ;; let rec to_map = function | Empty -> Map.empty (module Key) | Leaf { key; value = data } -> Map.singleton (module Key) key data | Node { left; key; value = data; height = _; right } -> merge (Map.singleton (module Key) key data) (merge (to_map left) (to_map right)) ;; end open For_quickcheck let empty = empty let%test_unit _ = match empty with | Empty -> () | _ -> assert false ;; let is_empty = is_empty let%test _ = is_empty empty let%test_unit _ = Base_quickcheck.Test.run_exn (module Constructors) ~f:(fun constructors -> let t, map = reify constructors in [%test_result: bool] (is_empty t) ~expect:(Map.is_empty map)) ;; let invariant = invariant let%test_unit _ = Base_quickcheck.Test.run_exn (module Constructors) ~f:(fun constructors -> let t, map = reify constructors in invariant t ~compare; [%test_result: Data.t Map.M(Key).t] (to_map t) ~expect:map) ;; let add = add let%test_unit _ = Base_quickcheck.Test.run_exn (module struct type t = Constructor.t list * Key.t * Data.t * bool [@@deriving quickcheck, sexp_of] end) ~f:(fun (constructors, key, data, replace) -> let t, map = reify constructors in (* test [added], other aspects of [add] are tested via [reify] in the [invariant] test above *) let added = ref false in let (_ : (Key.t, Data.t) t) = add t ~key ~data ~compare ~added ~replace in [%test_result: bool] !added ~expect:(not (Map.mem map key))) ;; let remove = remove let%test_unit _ = Base_quickcheck.Test.run_exn (module struct type t = Constructors.t * Key.t [@@deriving quickcheck, sexp_of] end) ~f:(fun (constructors, key) -> let t, map = reify constructors in (* test [removed], other aspects of [remove] are tested via [reify] in the [invariant] test above *) let removed = ref false in let (_ : (Key.t, Data.t) t) = remove t key ~compare ~removed in [%test_result: bool] !removed ~expect:(Map.mem map key)) ;; let find = find let%test_unit _ = Base_quickcheck.Test.run_exn (module struct type t = Constructors.t * Key.t [@@deriving quickcheck, sexp_of] end) ~f:(fun (constructors, key) -> let t, map = reify constructors in [%test_result: Data.t option] (find t key ~compare) ~expect:(Map.find map key)) ;; let mem = mem let%test_unit _ = Base_quickcheck.Test.run_exn (module struct type t = Constructors.t * Key.t [@@deriving quickcheck, sexp_of] end) ~f:(fun (constructors, key) -> let t, map = reify constructors in [%test_result: bool] (mem t key ~compare) ~expect:(Map.mem map key)) ;; let first = first let%test_unit _ = Base_quickcheck.Test.run_exn (module Constructors) ~f:(fun constructors -> let t, map = reify constructors in [%test_result: (Key.t * Data.t) option] (first t) ~expect:(Map.min_elt map)) ;; let last = last let%test_unit _ = Base_quickcheck.Test.run_exn (module Constructors) ~f:(fun constructors -> let t, map = reify constructors in [%test_result: (Key.t * Data.t) option] (last t) ~expect:(Map.max_elt map)) ;; let find_and_call = find_and_call let%test_unit _ = Base_quickcheck.Test.run_exn (module struct type t = Constructors.t * Key.t [@@deriving quickcheck, sexp_of] end) ~f:(fun (constructors, key) -> let t, map = reify constructors in [%test_result: [ `Found of Data.t | `Not_found of Key.t ]] (find_and_call t key ~compare ~if_found:(fun data -> `Found data) ~if_not_found:(fun key -> `Not_found key)) ~expect: (match Map.find map key with | None -> `Not_found key | Some data -> `Found data)) ;; let findi_and_call = findi_and_call let%test_unit _ = Base_quickcheck.Test.run_exn (module struct type t = Constructors.t * Key.t [@@deriving quickcheck, sexp_of] end) ~f:(fun (constructors, key) -> let t, map = reify constructors in [%test_result: [ `Found of Key.t * Data.t | `Not_found of Key.t ]] (findi_and_call t key ~compare ~if_found:(fun ~key ~data -> `Found (key, data)) ~if_not_found:(fun key -> `Not_found key)) ~expect: (match Map.find map key with | None -> `Not_found key | Some data -> `Found (key, data))) ;; let find_and_call1 = find_and_call1 let%test_unit _ = Base_quickcheck.Test.run_exn (module struct type t = Constructors.t * Key.t * int [@@deriving quickcheck, sexp_of] end) ~f:(fun (constructors, key, a) -> let t, map = reify constructors in [%test_result: [ `Found of Data.t * int | `Not_found of Key.t * int ]] (find_and_call1 t key ~compare ~a ~if_found:(fun data a -> `Found (data, a)) ~if_not_found:(fun key a -> `Not_found (key, a))) ~expect: (match Map.find map key with | None -> `Not_found (key, a) | Some data -> `Found (data, a))) ;; let findi_and_call1 = findi_and_call1 let%test_unit _ = Base_quickcheck.Test.run_exn (module struct type t = Constructors.t * Key.t * int [@@deriving quickcheck, sexp_of] end) ~f:(fun (constructors, key, a) -> let t, map = reify constructors in [%test_result: [ `Found of Key.t * Data.t * int | `Not_found of Key.t * int ]] (findi_and_call1 t key ~compare ~a ~if_found:(fun ~key ~data a -> `Found (key, data, a)) ~if_not_found:(fun key a -> `Not_found (key, a))) ~expect: (match Map.find map key with | None -> `Not_found (key, a) | Some data -> `Found (key, data, a))) ;; let find_and_call2 = find_and_call2 let%test_unit _ = Base_quickcheck.Test.run_exn (module struct type t = Constructors.t * Key.t * int * string [@@deriving quickcheck, sexp_of] end) ~f:(fun (constructors, key, a, b) -> let t, map = reify constructors in [%test_result: [ `Found of Data.t * int * string | `Not_found of Key.t * int * string ]] (find_and_call2 t key ~compare ~a ~b ~if_found:(fun data a b -> `Found (data, a, b)) ~if_not_found:(fun key a b -> `Not_found (key, a, b))) ~expect: (match Map.find map key with | None -> `Not_found (key, a, b) | Some data -> `Found (data, a, b))) ;; let findi_and_call2 = findi_and_call2 let%test_unit _ = Base_quickcheck.Test.run_exn (module struct type t = Constructors.t * Key.t * int * string [@@deriving quickcheck, sexp_of] end) ~f:(fun (constructors, key, a, b) -> let t, map = reify constructors in [%test_result: [ `Found of Key.t * Data.t * int * string | `Not_found of Key.t * int * string ]] (findi_and_call2 t key ~compare ~a ~b ~if_found:(fun ~key ~data a b -> `Found (key, data, a, b)) ~if_not_found:(fun key a b -> `Not_found (key, a, b))) ~expect: (match Map.find map key with | None -> `Not_found (key, a, b) | Some data -> `Found (key, data, a, b))) ;; let iter = iter let%test_unit _ = Base_quickcheck.Test.run_exn (module Constructors) ~f:(fun constructors -> let t, map = reify constructors in [%test_result: (Key.t * Data.t) list] (let q = Queue.create () in iter t ~f:(fun ~key ~data -> Queue.enqueue q (key, data)); Queue.to_list q) ~expect:(Map.to_alist map)) ;; let mapi_inplace = mapi_inplace let%test_unit _ = Base_quickcheck.Test.run_exn (module Constructors) ~f:(fun constructors -> let t, map = reify constructors in [%test_result: (Key.t * Data.t) list] (mapi_inplace t ~f:(fun ~key:_ ~data -> data ^ data); fold t ~init:[] ~f:(fun ~key ~data acc -> (key, data) :: acc)) ~expect: (Map.map map ~f:(fun data -> data ^ data) |> Map.to_alist |> List.rev)) ;; let fold = fold let%test_unit _ = Base_quickcheck.Test.run_exn (module Constructors) ~f:(fun constructors -> let t, map = reify constructors in [%test_result: (Key.t * Data.t) list] (fold t ~init:[] ~f:(fun ~key ~data acc -> (key, data) :: acc)) ~expect:(Map.to_alist map |> List.rev)) ;; let choose_exn = choose_exn let%test_unit _ = Base_quickcheck.Test.run_exn (module Constructors) ~f:(fun constructors -> let t, map = reify constructors in [%test_result: bool] (is_some (Option.try_with (fun () -> choose_exn t))) ~expect:(not (Map.is_empty map))) ;; end : module type of Avltree)) ;; base-0.16.3/test/avltree_unit_tests.mli000066400000000000000000000000321446274340700201260ustar00rootroot00000000000000(* intentionally blank *) base-0.16.3/test/base_test.ml000066400000000000000000000000731446274340700160100ustar00rootroot00000000000000(*_ This library deliberately does not export anything. *) base-0.16.3/test/dune000066400000000000000000000004431446274340700143640ustar00rootroot00000000000000(library (name base_test) (libraries base base_container_tests core.base_for_tests base_test_helpers expect_test_helpers_core.expect_test_helpers_base sexplib sexp_grammar sexp_grammar_validation num stdio uutf) (preprocess (pps ppx_jane -dont-apply=pipebang -no-check-on-extensions)))base-0.16.3/test/hashtbl_tests.ml000066400000000000000000000311251446274340700167100ustar00rootroot00000000000000open! Base module type Hashtbl_for_testing = sig include Hashtbl.Accessors with type 'key key = 'key include Invariant.S2 with type ('key, 'data) t := ('key, 'data) t (* we don't define [module Poly : Hashtbl.S_poly] because we want to require only the minimal number of constructors necessary to implement the tests, and also avoid conflicting with any existing names. *) val create_poly : ?size:int -> unit -> ('key, 'data) t val of_alist_poly_exn : ('key * 'data) list -> ('key, 'data) t val of_alist_poly_or_error : ('key * 'data) list -> ('key, 'data) t Or_error.t end module Make (Hashtbl : Hashtbl_for_testing) = struct open Poly let test_data = [ "a", 1; "b", 2; "c", 3 ] let test_hash = let h = Hashtbl.create_poly () ~size:10 in List.iter test_data ~f:(fun (k, v) -> Hashtbl.set h ~key:k ~data:v); h ;; (* This is a very strong notion of equality on hash tables *) let equal t t' equal_data = let subtable t t' = try List.for_all (Hashtbl.keys t) ~f:(fun key -> equal_data (Hashtbl.find_exn t key) (Hashtbl.find_exn t' key)) with | Invalid_argument _ -> false in subtable t t' && subtable t' t ;; let%test "find" = let found = Hashtbl.find test_hash "a" in let not_found = Hashtbl.find test_hash "A" in Hashtbl.invariant ignore ignore test_hash; match found, not_found with | Some _, None -> true | _ -> false ;; (* In js_of_ocaml, strings can be hashconst-ed. *) let%test ("findi_and_call" [@tags "no-js"]) = let our_hash = Hashtbl.copy test_hash in let test_string = "test string" in Hashtbl.add_exn our_hash ~key:test_string ~data:10; let test_string' = "test " ^ "string" in assert (not (phys_equal test_string test_string')); Hashtbl.findi_and_call our_hash test_string' ~if_found:(fun ~key ~data -> phys_equal test_string key && data = 10) ~if_not_found:(fun _ -> false) ;; let%test_unit "add" = let our_hash = Hashtbl.copy test_hash in let duplicate = Hashtbl.add our_hash ~key:"a" ~data:4 in let no_duplicate = Hashtbl.add our_hash ~key:"d" ~data:5 in assert (Hashtbl.find our_hash "a" = Some 1); assert (Hashtbl.find our_hash "d" = Some 5); Hashtbl.invariant ignore ignore our_hash; assert ( match duplicate, no_duplicate with | `Duplicate, `Ok -> true | _ -> false) ;; let%test "iter" = let predicted = List.sort ~compare:Int.descending (List.map test_data ~f:(fun (_, v) -> v)) in let found = let found = ref [] in Hashtbl.iter test_hash ~f:(fun v -> found := v :: !found); !found |> List.sort ~compare:Int.descending in List.equal Int.equal predicted found ;; let%test "iter_keys" = let predicted = List.sort ~compare:String.descending (List.map test_data ~f:(fun (k, _) -> k)) in let found = let found = ref [] in Hashtbl.iter_keys test_hash ~f:(fun k -> found := k :: !found); !found |> List.sort ~compare:String.descending in List.equal String.equal predicted found ;; let%test_module "of_alist" = (module struct let%test "size" = let predicted = List.length test_data in let found = Hashtbl.length (Hashtbl.of_alist_poly_exn test_data) in predicted = found ;; let%test "right keys" = let predicted = List.map test_data ~f:(fun (k, _) -> k) in let found = Hashtbl.keys (Hashtbl.of_alist_poly_exn test_data) in let sp = List.sort ~compare:Poly.ascending predicted in let sf = List.sort ~compare:Poly.ascending found in sp = sf ;; end) ;; let%test_module "of_alist_or_error" = (module struct let%test "unique" = Result.is_ok (Hashtbl.of_alist_poly_or_error test_data) let%test "duplicate" = Result.is_error (Hashtbl.of_alist_poly_or_error (test_data @ test_data)) ;; end) ;; let%test "size and right keys" = let predicted = List.map test_data ~f:(fun (k, _) -> k) in let found = Hashtbl.keys test_hash in let sp = List.sort ~compare:Poly.ascending predicted in let sf = List.sort ~compare:Poly.ascending found in sp = sf ;; let%test "size and right data" = let predicted = List.map test_data ~f:(fun (_, v) -> v) in let found = Hashtbl.data test_hash in let sp = List.sort ~compare:Poly.ascending predicted in let sf = List.sort ~compare:Poly.ascending found in sp = sf ;; let%test "map" = let add1 x = x + 1 in let predicted_data = List.sort ~compare:Poly.ascending (List.map test_data ~f:(fun (k, v) -> k, add1 v)) in let found_alist = Hashtbl.map test_hash ~f:add1 |> Hashtbl.to_alist |> List.sort ~compare:Poly.ascending in List.equal Poly.equal predicted_data found_alist ;; let%test_unit "filter_map" = let f x = Some x in let result = Hashtbl.filter_map test_hash ~f in assert (equal test_hash result Int.( = )); let is_even x = x % 2 = 0 in let add1_to_even x = if is_even x then Some (x + 1) else None in let predicted_data = List.filter_map test_data ~f:(fun (k, v) -> if is_even v then Some (k, v + 1) else None) in let found = Hashtbl.filter_map test_hash ~f:add1_to_even in let found_alist = List.sort ~compare:Poly.ascending (Hashtbl.to_alist found) in assert (List.equal Poly.equal predicted_data found_alist) ;; let%test "filter_inplace" = let f x = x <> 2 in let predicted_data = List.sort ~compare:Poly.ascending (List.filter test_data ~f:(fun (_, v) -> f v)) in let test_hash = Hashtbl.copy test_hash in Hashtbl.filter_inplace test_hash ~f; let found_alist = Hashtbl.to_alist test_hash |> List.sort ~compare:Poly.ascending in List.equal Poly.equal predicted_data found_alist ;; let%test "filter_keys_inplace" = let f x = x = "c" in let predicted_data = List.sort ~compare:Poly.ascending (List.filter test_data ~f:(fun (k, _) -> f k)) in let test_hash = Hashtbl.copy test_hash in Hashtbl.filter_keys_inplace test_hash ~f; let found_alist = Hashtbl.to_alist test_hash |> List.sort ~compare:Poly.ascending in List.equal Poly.equal predicted_data found_alist ;; let%test "filter_map_inplace" = let f x = if x = 1 then None else Some (x * 2) in let predicted_data = List.sort ~compare:Poly.ascending (List.filter_map test_data ~f:(fun (k, v) -> Option.map (f v) ~f:(fun x -> k, x))) in let test_hash = Hashtbl.copy test_hash in Hashtbl.filter_map_inplace test_hash ~f; let found_alist = Hashtbl.to_alist test_hash |> List.sort ~compare:Poly.ascending in List.equal Poly.equal predicted_data found_alist ;; let%test "map_inplace" = let f x = x + 3 in let predicted_data = List.sort ~compare:Poly.ascending (List.map test_data ~f:(fun (k, v) -> k, f v)) in let test_hash = Hashtbl.copy test_hash in Hashtbl.map_inplace test_hash ~f; let found_alist = Hashtbl.to_alist test_hash |> List.sort ~compare:Poly.ascending in List.equal Poly.equal predicted_data found_alist ;; let%test_unit "insert-find-remove" = let t = Hashtbl.create_poly () ~size:1 in let inserted = ref [] in Random.init 123; let verify_inserted t = let missing = List.fold !inserted ~init:[] ~f:(fun acc (key, data) -> match Hashtbl.find t key with | None -> `Missing key :: acc | Some d -> if data = d then acc else `Wrong_data (key, data) :: acc) in match missing with | [] -> () | _ -> raise_s [%message "some inserts are missing" (missing : [ `Missing of int | `Wrong_data of int * int ] list)] in let equal = Int.equal in let rec loop i t = if i < 2000 then ( let k = Random.int 10_000 in inserted := List.Assoc.add (List.Assoc.remove !inserted ~equal k) ~equal k i; Hashtbl.set t ~key:k ~data:i; Hashtbl.invariant ignore ignore t; verify_inserted t; loop (i + 1) t) in loop 0 t; List.iter !inserted ~f:(fun (x, _) -> Hashtbl.remove t x; Hashtbl.invariant ignore ignore t; (match Hashtbl.find t x with | None -> () | Some _ -> failwith (Printf.sprintf "present after removal: %d" x)); inserted := List.Assoc.remove !inserted ~equal x; verify_inserted t) ;; let%test_unit "clear" = let t = Hashtbl.create_poly () ~size:1 in let l = List.range 0 100 in let verify_present l = List.for_all l ~f:(Hashtbl.mem t) in let verify_not_present l = List.for_all l ~f:(fun i -> not (Hashtbl.mem t i)) in List.iter l ~f:(fun i -> Hashtbl.set t ~key:i ~data:(i * i)); List.iter l ~f:(fun i -> Hashtbl.set t ~key:i ~data:(i * i)); assert (Hashtbl.length t = 100); assert (verify_present l); Hashtbl.clear t; Hashtbl.invariant ignore ignore t; assert (Hashtbl.length t = 0); assert (verify_not_present l); let l = List.take l 42 in List.iter l ~f:(fun i -> Hashtbl.set t ~key:i ~data:(i * i)); assert (Hashtbl.length t = 42); assert (verify_present l); Hashtbl.invariant ignore ignore t ;; let%test_unit "mem" = let t = Hashtbl.create_poly () ~size:1 in Hashtbl.invariant ignore ignore t; assert (not (Hashtbl.mem t "Fred")); Hashtbl.invariant ignore ignore t; Hashtbl.set t ~key:"Fred" ~data:"Wilma"; Hashtbl.invariant ignore ignore t; assert (Hashtbl.mem t "Fred"); Hashtbl.invariant ignore ignore t; Hashtbl.remove t "Fred"; Hashtbl.invariant ignore ignore t; assert (not (Hashtbl.mem t "Fred")); Hashtbl.invariant ignore ignore t ;; let%test_unit "exists" = let t = Hashtbl.create_poly () in assert (not (Hashtbl.exists t ~f:(fun _ -> failwith "can't be called"))); assert (not (Hashtbl.existsi t ~f:(fun ~key:_ ~data:_ -> failwith "can't be called"))); Hashtbl.set t ~key:7 ~data:3; assert (not (Hashtbl.exists t ~f:(Int.equal 4))); Hashtbl.set t ~key:8 ~data:4; assert (Hashtbl.exists t ~f:(Int.equal 4)); Hashtbl.set t ~key:9 ~data:5; assert (Hashtbl.existsi t ~f:(fun ~key ~data -> key + data = 14)) ;; let%test_unit "for_all" = let t = Hashtbl.create_poly () in assert (Hashtbl.for_all t ~f:(fun _ -> failwith "can't be called")); assert (Hashtbl.for_alli t ~f:(fun ~key:_ ~data:_ -> failwith "can't be called")); Hashtbl.set t ~key:7 ~data:3; assert (Hashtbl.for_all t ~f:(fun x -> Int.equal x 3)); Hashtbl.set t ~key:8 ~data:4; assert (not (Hashtbl.for_all t ~f:(fun x -> Int.equal x 3))); Hashtbl.set t ~key:9 ~data:5; assert (Hashtbl.for_alli t ~f:(fun ~key ~data -> key - 4 = data)) ;; let%test_unit "count" = let t = Hashtbl.create_poly () in assert (Hashtbl.count t ~f:(fun _ -> failwith "can't be called") = 0); assert (Hashtbl.counti t ~f:(fun ~key:_ ~data:_ -> failwith "can't be called") = 0); Hashtbl.set t ~key:7 ~data:3; assert (Hashtbl.count t ~f:(fun x -> Int.equal x 3) = 1); Hashtbl.set t ~key:8 ~data:4; assert (Hashtbl.count t ~f:(fun x -> Int.equal x 3) = 1); Hashtbl.set t ~key:9 ~data:5; assert (Hashtbl.counti t ~f:(fun ~key ~data -> key - 4 = data) = 3) ;; let%test_unit "merge" = let make alist = Hashtbl.of_alist_poly_exn alist in let t1 = make [ 1, 111; 2, 222; 3, 333 ] in let t2 = make [ 1, 123; 2, 222; 4, 444 ] in [%test_result: (int * [ `Left of int | `Right of int | `Both of int * int ]) List.t] (Hashtbl.merge t1 t2 ~f:(fun ~key:_ -> function | `Left x -> Some (`Left x) | `Right y -> Some (`Right y) | `Both (x, y) -> if x = y then None else Some (`Both (x, y))) |> Hashtbl.to_alist |> List.sort ~compare:(fun (x, _) (y, _) -> Int.compare x y)) ~expect:[ 1, `Both (111, 123); 3, `Left 333; 4, `Right 444 ] ;; end (* typechecking this code is a compile-time test that [Creators] is a specialization of [Creators_generic]. *) module _ : sig end = struct module Make_creators_check (Type : T.T2) (Key : T.T1) (Options : T.T3) (_ : Hashtbl.Private.Creators_generic with type ('a, 'b) t := ('a, 'b) Type.t with type 'a key := 'a Key.t with type ('a, 'b, 'z) create_options := ('a, 'b, 'z) Options.t) = struct end module _ (M : Hashtbl.Creators) = Make_creators_check (struct type ('a, 'b) t = ('a, 'b) M.t end) (struct type 'a t = 'a end) (struct type ('a, 'b, 'z) t = ('a, 'b, 'z) Hashtbl.create_options end) (struct include M let create ?growth_allowed ?size m () = create ?growth_allowed ?size m end) end base-0.16.3/test/hashtbl_tests.mli000066400000000000000000000006631446274340700170640ustar00rootroot00000000000000open! Base module type Hashtbl_for_testing = sig include Hashtbl.Accessors with type 'key key = 'key include Invariant.S2 with type ('key, 'data) t := ('key, 'data) t val create_poly : ?size:int -> unit -> ('key, 'data) t val of_alist_poly_exn : ('key * 'data) list -> ('key, 'data) t val of_alist_poly_or_error : ('key * 'data) list -> ('key, 'data) t Or_error.t end module Make (Hashtbl : Hashtbl_for_testing) : sig end base-0.16.3/test/helpers/000077500000000000000000000000001446274340700151475ustar00rootroot00000000000000base-0.16.3/test/helpers/dune000066400000000000000000000001201446274340700160160ustar00rootroot00000000000000(library (name base_test_helpers) (libraries base) (preprocess (pps ppx_jane)))base-0.16.3/test/helpers/test_container.ml000066400000000000000000000146741446274340700205360ustar00rootroot00000000000000open! Base open! Container module Test_generic (Elt : sig type 'a t val of_int : int -> int t val to_int : int t -> int end) (Container : sig type 'a t [@@deriving sexp] include Generic with type ('a, _) t := 'a t with type 'a elt := 'a Elt.t val mem : 'a t -> 'a Elt.t -> equal:(('a Elt.t -> 'a Elt.t -> bool)[@local]) -> bool val of_list : 'a Elt.t list -> [ `Ok of 'a t | `Skip_test ] end) : sig type 'a t [@@deriving sexp] include Generic with type ('a, _) t := 'a t val mem : 'a t -> 'a Elt.t -> equal:(('a Elt.t -> 'a Elt.t -> bool)[@local]) -> bool end with type 'a t := 'a Container.t with type 'a elt := 'a Elt.t = (* This signature constraint reminds us to add unit tests when functions are added to [Generic]. *) struct open Container let find = find let find_map = find_map let fold = fold let is_empty = is_empty let iter = iter let length = length let mem = mem let sexp_of_t = sexp_of_t let t_of_sexp = t_of_sexp let to_array = to_array let to_list = to_list let fold_result = fold_result let fold_until = fold_until let%test_unit _ = let ( = ) = Poly.equal in let compare = Poly.compare in List.iter [ 0; 1; 2; 3; 4; 8; 128 ] ~f:(fun n -> let list = List.init n ~f:Elt.of_int in match Container.of_list list with | `Skip_test -> () | `Ok c -> let sort l = List.sort l ~compare in let sorts_are_equal l1 l2 = sort l1 = sort l2 in assert (n = Container.length c); assert (n = 0 = Container.is_empty c); assert (sorts_are_equal list (Container.fold c ~init:[] ~f:(fun ac e -> e :: ac))); assert (sorts_are_equal list (Container.to_list c)); assert (sorts_are_equal list (Array.to_list (Container.to_array c))); assert (n > 0 = Option.is_some (Container.find c ~f:(fun e -> Elt.to_int e = 0))); assert ( n > 0 = Option.is_some (Container.find c ~f:(fun e -> Elt.to_int e = n - 1))); assert (Option.is_none (Container.find c ~f:(fun e -> Elt.to_int e = n))); assert (n > 0 = Container.mem c (Elt.of_int 0) ~equal:( = )); if n > 0 then assert (Container.mem c (Elt.of_int (n - 1)) ~equal:( = )); assert (not (Container.mem c (Elt.of_int n) ~equal:( = ))); assert ( n > 0 = Option.is_some (Container.find_map c ~f:(fun e -> if Elt.to_int e = 0 then Some () else None))); assert ( n > 0 = Option.is_some (Container.find_map c ~f:(fun e -> if Elt.to_int e = n - 1 then Some () else None))); assert ( Option.is_none (Container.find_map c ~f:(fun e -> if Elt.to_int e = n then Some () else None))); let r = ref 0 in Container.iter c ~f:(fun e -> r := !r + Elt.to_int e); assert (!r = List.fold list ~init:0 ~f:(fun n e -> n + Elt.to_int e)); assert (!r = sum (module Int) c ~f:Elt.to_int); let c2 = [%of_sexp: int Container.t] ([%sexp_of: int Container.t] c) in assert (sorts_are_equal list (Container.to_list c2)); let compare_elt a b = Int.compare (Elt.to_int a) (Elt.to_int b) in if n = 0 then ( assert (!r = 0); assert (min_elt ~compare:compare_elt c = None); assert (max_elt ~compare:compare_elt c = None)) else ( assert (!r = n * (n - 1) / 2); assert (Option.map ~f:Elt.to_int (min_elt ~compare:compare_elt c) = Some 0); assert ( Option.map ~f:Elt.to_int (max_elt ~compare:compare_elt c) = Some (Int.pred n))); let mid = Container.length c / 2 in (match Container.fold_result c ~init:0 ~f:(fun count _elt -> if count = mid then Error count else Ok (count + 1)) with | Ok 0 -> assert (Container.length c = 0) | Ok _ -> failwith "Expected fold to stop early" | Error x -> assert (mid = x))) ;; let min_elt = min_elt let max_elt = max_elt let count = count let sum = sum let exists = exists let for_all = for_all let%test_unit _ = List.iter [ [] ; [ true ] ; [ false ] ; [ false; false ] ; [ true; false ] ; [ false; true ] ; [ true; true ] ] ~f:(fun bools -> let count_should_be = List.fold bools ~init:0 ~f:(fun n b -> if b then n + 1 else n) in let forall_should_be = List.fold bools ~init:true ~f:(fun ac b -> b && ac) in let exists_should_be = List.fold bools ~init:false ~f:(fun ac b -> b || ac) in match Container.of_list (List.map bools ~f:(fun b -> Elt.of_int (if b then 1 else 0))) with | `Skip_test -> () | `Ok container -> let is_one e = Elt.to_int e = 1 in let ( = ) = Poly.equal in assert (forall_should_be = Container.for_all container ~f:is_one); assert (exists_should_be = Container.exists container ~f:is_one); assert (count_should_be = Container.count container ~f:is_one)) ;; end module Test_S1_allow_skipping_tests (Container : sig type 'a t [@@deriving sexp] include Container.S1 with type 'a t := 'a t val of_list : 'a list -> [ `Ok of 'a t | `Skip_test ] end) = struct include Test_generic (struct type 'a t = 'a let of_int = Fn.id let to_int = Fn.id end) (Container) end module Test_S1 (Container : sig type 'a t [@@deriving sexp] include Container.S1 with type 'a t := 'a t val of_list : 'a list -> 'a t end) = Test_S1_allow_skipping_tests (struct include Container let of_list l = `Ok (of_list l) end) module Test_S0 (Container : sig module Elt : sig type t [@@deriving sexp] val of_int : int -> t val to_int : t -> int end type t [@@deriving sexp] include Container.S0 with type t := t and type elt := Elt.t val of_list : Elt.t list -> t end) = struct include Test_generic (struct include Container.Elt type 'a t = Container.Elt.t end) (struct include Container type 'a t = Container.t [@@deriving sexp] let of_list l = `Ok (of_list l) let mem t x ~equal:_ = Container.mem t x end) (* [mem] in the second functor argument above ignores its [~equal], so this [~equal] should never be called. *) let mem t x = mem t x ~equal:(fun _ _ -> assert false) end base-0.16.3/test/helpers/test_container.mli000066400000000000000000000024061446274340700206750ustar00rootroot00000000000000open! Base open! Container module Test_S1_allow_skipping_tests (Container : sig type 'a t [@@deriving sexp] include Container.S1 with type 'a t := 'a t val of_list : 'a list -> [ `Ok of 'a t | `Skip_test ] end) : sig type 'a t [@@deriving sexp] include Generic with type ('a, _) t := 'a t val mem : 'a t -> 'a -> equal:(('a -> 'a -> bool)[@local]) -> bool end with type 'a t := 'a Container.t with type 'a elt := 'a module Test_S1 (Container : sig type 'a t [@@deriving sexp] include Container.S1 with type 'a t := 'a t val of_list : 'a list -> 'a t end) : sig type 'a t [@@deriving sexp] include Generic with type ('a, _) t := 'a t val mem : 'a t -> 'a -> equal:(('a -> 'a -> bool)[@local]) -> bool end with type 'a t := 'a Container.t with type 'a elt := 'a module Test_S0 (Container : sig module Elt : sig type t [@@deriving sexp] val of_int : int -> t val to_int : t -> int end type t [@@deriving sexp] include Container.S0 with type t := t and type elt := Elt.t val of_list : Elt.t list -> t end) : sig type 'a t [@@deriving sexp] include Generic with type ('a, _) t := 'a t val mem : 'a t -> 'a elt -> bool end with type 'a t := Container.t with type 'a elt := Container.Elt.t base-0.16.3/test/helpers/test_stack.ml000066400000000000000000000241261446274340700176520ustar00rootroot00000000000000open! Base open! Stack module Debug (Stack : S) : S with type 'a t = 'a Stack.t = struct open Stack type nonrec 'a t = 'a t let invariant = invariant let t_sexp_grammar = t_sexp_grammar let check_and_return t = invariant ignore t; t ;; let debug t f = let result = Result.try_with f in invariant ignore t; Result.ok_exn result ;; (* The return-type annotations are to prevent an error where we don't supply all the arguments to the function, and thus wouldn't be checking the invariant after fully applying the function. *) let clear t : unit = debug t (fun () -> clear t) let copy t : _ t = check_and_return (debug t (fun () -> copy t)) let count t ~f : int = debug t (fun () -> count t ~f) [@nontail] let sum m t ~f = debug t (fun () -> sum m t ~f) [@nontail] let create () : _ t = check_and_return (create ()) let exists t ~f : bool = debug t (fun () -> exists t ~f) [@nontail] let find t ~f : _ option = debug t (fun () -> find t ~f) [@nontail] let find_map t ~f : _ option = debug t (fun () -> find_map t ~f) [@nontail] let fold (type a) t ~init ~f : a = debug t (fun () -> fold t ~init ~f) [@nontail] let for_all t ~f : bool = debug t (fun () -> for_all t ~f) [@nontail] let is_empty t : bool = debug t (fun () -> is_empty t) let iter t ~f : unit = debug t (fun () -> iter t ~f) [@nontail] let length t : int = debug t (fun () -> length t) let mem t a ~equal : bool = debug t (fun () -> mem t a ~equal) [@nontail] let of_list l : _ t = check_and_return (of_list l) let pop t : _ option = debug t (fun () -> pop t) let pop_exn (type a) t : a = debug t (fun () -> pop_exn t) let push t a : unit = debug t (fun () -> push t a) let sexp_of_t sexp_of_a t : Sexp.t = debug t (fun () -> [%sexp_of: a t] t) let singleton x : _ t = check_and_return (singleton x) let t_of_sexp a_of_sexp sexp : _ t = check_and_return ([%of_sexp: a t] sexp) let to_array t : _ array = debug t (fun () -> to_array t) let to_list t : _ list = debug t (fun () -> to_list t) let top t : _ option = debug t (fun () -> top t) let top_exn (type a) t : a = debug t (fun () -> top_exn t) let until_empty t f : unit = debug t (fun () -> until_empty t f) [@nontail] let min_elt t ~compare : _ option = debug t (fun () -> min_elt t ~compare) [@nontail] let max_elt t ~compare : _ option = debug t (fun () -> max_elt t ~compare) [@nontail] let fold_result t ~init ~f = debug t (fun () -> fold_result t ~init ~f) [@nontail] let fold_until t ~init ~f ~finish = debug t (fun () -> fold_until t ~init ~f ~finish) [@nontail] ;; let filter_map t ~f = debug t (fun () -> filter_map t ~f) [@nontail] let filter t ~f = debug t (fun () -> filter t ~f) [@nontail] let filter_inplace t ~f = debug t (fun () -> filter_inplace t ~f) [@nontail] end module Test (Stack : S) : S with type 'a t = 'a Stack.t = (* This signature is here to remind us to add a unit test whenever we add something to the stack interface. *) struct open Stack type nonrec 'a t = 'a t include Test_container.Test_S1 (Stack) let t_sexp_grammar = t_sexp_grammar let invariant = invariant let create = create let is_empty = is_empty let top_exn = top_exn let pop_exn = pop_exn let pop = pop let top = top let singleton = singleton let%test_unit _ = let empty = create () in invariant ignore empty; invariant (fun b -> assert b) (of_list [ true ]); assert (is_empty empty); let t = create () in push t 0; assert (not (is_empty t)); assert (Exn.does_raise (fun () -> top_exn empty)); let t = create () in push t 0; [%test_result: int] (top_exn t) ~expect:0; assert (Exn.does_raise (fun () -> pop_exn empty)); let t = create () in push t 0; [%test_result: int] (pop_exn t) ~expect:0; assert (Option.is_none (pop empty)); assert (Option.is_some (pop (of_list [ 0 ]))); assert (Option.is_none (top empty)); assert (Option.is_some (top (of_list [ 0 ]))); assert (Option.is_some (top (singleton 0))); assert (Option.is_some (pop (singleton 0))); assert ( let t = singleton 0 in ignore (pop_exn t : int); Option.is_none (top t)) ;; let min_elt = min_elt let max_elt = max_elt let%test_unit _ = let empty = create () in [%test_result: _ option] (min_elt ~compare:Int.compare empty) ~expect:None; [%test_result: _ option] (max_elt ~compare:Int.compare empty) ~expect:None; [%test_result: int] (sum (module Int) ~f:Fn.id empty) ~expect:0 ;; let push = push let copy = copy let until_empty = until_empty let%test_unit _ = let t = let t = create () in push t 0; push t 1; push t 2; t in [%test_result: bool] (is_empty t) ~expect:false; [%test_result: int] (length t) ~expect:3; [%test_result: int option] (top t) ~expect:(Some 2); [%test_result: int] (top_exn t) ~expect:2; [%test_result: int option] (min_elt ~compare:Int.compare t) ~expect:(Some 0); [%test_result: int option] (max_elt ~compare:Int.compare t) ~expect:(Some 2); [%test_result: int] (sum (module Int) ~f:Fn.id t) ~expect:3; let t' = copy t in [%test_result: int] (pop_exn t') ~expect:2; [%test_result: int] (pop_exn t') ~expect:1; [%test_result: int] (pop_exn t') ~expect:0; [%test_result: int] (length t') ~expect:0; [%test_result: bool] (is_empty t') ~expect:true; let t' = copy t in [%test_result: int option] (pop t') ~expect:(Some 2); [%test_result: int option] (pop t') ~expect:(Some 1); [%test_result: int option] (pop t') ~expect:(Some 0); [%test_result: int] (length t') ~expect:0; [%test_result: bool] (is_empty t') ~expect:true; (* test that t was not modified by pops applied to copies *) [%test_result: int] (length t) ~expect:3; [%test_result: int] (top_exn t) ~expect:2; [%test_result: int list] (to_list t) ~expect:[ 2; 1; 0 ]; [%test_result: int array] (to_array t) ~expect:[| 2; 1; 0 |]; [%test_result: int] (length t) ~expect:3; [%test_result: int] (top_exn t) ~expect:2; let t' = copy t in let n = ref 0 in until_empty t' (fun x -> n := !n + x); [%test_result: int] !n ~expect:3; [%test_result: bool] (is_empty t') ~expect:true; [%test_result: int] (length t') ~expect:0 ;; let%test_unit _ = let t = create () in [%test_result: bool] (is_empty t) ~expect:true; [%test_result: int] (length t) ~expect:0; [%test_result: _ list] (to_list t) ~expect:[]; [%test_result: _ option] (pop t) ~expect:None; push t 13; [%test_result: bool] (is_empty t) ~expect:false; [%test_result: int] (length t) ~expect:1; [%test_result: int option] (min_elt ~compare:Int.compare t) ~expect:(Some 13); [%test_result: int option] (max_elt ~compare:Int.compare t) ~expect:(Some 13); [%test_result: int] (sum (module Int) ~f:Fn.id t) ~expect:13; [%test_result: int] (pop_exn t) ~expect:13; [%test_result: bool] (is_empty t) ~expect:true; [%test_result: int] (length t) ~expect:0; push t 13; push t 14; [%test_result: bool] (is_empty t) ~expect:false; [%test_result: int] (length t) ~expect:2; [%test_result: int list] (to_list t) ~expect:[ 14; 13 ]; [%test_result: int option] (min_elt ~compare:Int.compare t) ~expect:(Some 13); [%test_result: int option] (max_elt ~compare:Int.compare t) ~expect:(Some 14); [%test_result: int] (sum (module Int) ~f:Fn.id t) ~expect:27; [%test_result: bool] (Option.is_some (pop t)) ~expect:true; [%test_result: bool] (Option.is_some (pop t)) ~expect:true ;; let of_list = of_list let%test_unit _ = for n = 0 to 5 do let l = List.init n ~f:Fn.id in [%test_result: int list] (to_list (of_list l)) ~expect:l done ;; let clear = clear let%test_unit _ = for n = 0 to 5 do let t = of_list (List.init n ~f:Fn.id) in clear t; assert (is_empty t); push t 13; [%test_result: int] (length t) ~expect:1 done ;; let%test_unit "float test" = let s = create () in push s 1.0; push s 2.0; push s 3.0 ;; let filter_map = filter_map let%test_unit "filter_map" = let s = create () in push s 0; push s 1; push s 2; push s 3; [%test_result: int list] (to_list s) ~expect:[ 3; 2; 1; 0 ]; let s = filter_map s ~f:(fun i -> if i % 2 <> 0 then Some (i * 2) else None) in [%test_result: int list] (to_list s) ~expect:[ 6; 2 ]; let s = filter_map s ~f:(fun i -> if i < 4 then Some (i * 2) else None) in [%test_result: int list] (to_list s) ~expect:[ 4 ] ;; let filter = filter let%test_unit "filter" = let s = create () in push s 0; push s 1; push s 2; push s 3; [%test_result: int list] (to_list s) ~expect:[ 3; 2; 1; 0 ]; let s = filter s ~f:(fun i -> i % 2 <> 0) in [%test_result: int list] (to_list s) ~expect:[ 3; 1 ]; let s = filter s ~f:(fun i -> i < 2) in [%test_result: int list] (to_list s) ~expect:[ 1 ] ;; let filter_inplace = filter_inplace let%test_unit "filter_inplace" = let s = create () in push s 0; push s 1; push s 2; push s 3; [%test_result: int list] (to_list s) ~expect:[ 3; 2; 1; 0 ]; filter_inplace s ~f:(fun i -> i % 2 <> 0); [%test_result: int list] (to_list s) ~expect:[ 3; 1 ]; filter_inplace s ~f:(fun i -> i < 2); [%test_result: int list] (to_list s) ~expect:[ 1 ] ;; let%test_unit "filter_inplace raises after removing" = let s = create () in push s 0; push s 1; push s 2; push s 3; [%test_result: int list] (to_list s) ~expect:[ 3; 2; 1; 0 ]; assert ( Exn.does_raise (fun () -> filter_inplace s ~f:(fun i -> if Int.(i = 2) then raise_s [%message "exn"] else false))); [%test_result: int list] (to_list s) ~expect:[] ;; let%test_unit "filter_inplace raises after keeping" = let s = create () in push s 0; push s 1; push s 2; push s 3; [%test_result: int list] (to_list s) ~expect:[ 3; 2; 1; 0 ]; assert ( Exn.does_raise (fun () -> filter_inplace s ~f:(fun i -> if Int.(i = 2) then raise_s [%message "exn"] else true))); [%test_result: int list] (to_list s) ~expect:[ 1; 0 ] ;; end base-0.16.3/test/helpers/test_stack.mli000066400000000000000000000001541446274340700200160ustar00rootroot00000000000000open! Base module Debug (S : Stack.S) : Stack.S with type 'a t = 'a S.t module Test (S : Stack.S) : sig end base-0.16.3/test/import.ml000066400000000000000000000022001446274340700153430ustar00rootroot00000000000000include Base include Stdio include Base_for_tests include Base_test_helpers include Base_quickcheck.Export include Expect_test_helpers_base let () = Int_conversions.sexp_of_int_style := `Underscores let is_none = Option.is_none let is_some = Option.is_some let ok_exn = Or_error.ok_exn let stage = Staged.stage let unstage = Staged.unstage module type Hash = sig type t [@@deriving hash, sexp_of] end let check_hash_coherence (type t) here (module T : Hash with type t = t) ts = List.iter ts ~f:(fun t -> let hash1 = T.hash t in let hash2 = [%hash: T.t] t in require here (hash1 = hash2) ~cr:CR_soon ~if_false_then_print_s: (lazy [%message "" ~value:(t : T.t) (hash1 : int) (hash2 : int)])) ;; module type Int_hash = sig include Hash val of_int_exn : int -> t val min_value : t val max_value : t end let check_int_hash_coherence (type t) here (module I : Int_hash with type t = t) = check_hash_coherence here (module I) [ I.min_value; I.of_int_exn 0; I.of_int_exn 37; I.max_value ] ;; let test_conversion ~to_string f x = printf "%s --> %s\n" (to_string x) (to_string (f x)) base-0.16.3/test/test_am_testing.ml000066400000000000000000000002151446274340700172260ustar00rootroot00000000000000open! Base open! Import let%expect_test _ = print_s [%sexp (Exported_for_specific_uses.am_testing : bool)]; [%expect {| true |}] ;; base-0.16.3/test/test_am_testing.mli000066400000000000000000000000551446274340700174010ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_am_testing.mlt000066400000000000000000000002121446274340700174070ustar00rootroot00000000000000open! Base open! Expect_test_helpers_base let () = print_s [%sexp (Exported_for_specific_uses.am_testing : bool)] [%%expect {| true |}] base-0.16.3/test/test_applicative.ml000066400000000000000000000243251446274340700174050ustar00rootroot00000000000000open! Import module Test_applicative_s (A : Applicative.S with type 'a t := 'a Or_error.t) : Applicative.S with type 'a t := 'a Or_error.t = struct let error = Or_error.error_string let return = A.return let%expect_test _ = print_s [%sexp (return "okay" : string Or_error.t)]; [%expect {| (Ok okay) |}] ;; let apply = A.apply let%expect_test _ = let test x y = print_s [%sexp (apply x y : string Or_error.t)] in test (Ok String.capitalize) (Ok "okay"); [%expect {| (Ok Okay) |}]; test (error "not okay") (Ok "okay"); [%expect {| (Error "not okay") |}]; test (Ok String.capitalize) (error "not okay"); [%expect {| (Error "not okay") |}]; test (error "no fun") (error "no arg"); [%expect {| (Error ("no fun" "no arg")) |}] ;; let ( <*> ) = A.( <*> ) let%expect_test _ = let test x y = print_s [%sexp (x <*> y : string Or_error.t)] in test (Ok String.capitalize) (Ok "okay"); [%expect {| (Ok Okay) |}]; test (error "not okay") (Ok "okay"); [%expect {| (Error "not okay") |}]; test (Ok String.capitalize) (error "not okay"); [%expect {| (Error "not okay") |}]; test (error "no fun") (error "no arg"); [%expect {| (Error ("no fun" "no arg")) |}] ;; let ( *> ) = A.( *> ) let%expect_test _ = let test x y = print_s [%sexp (x *> y : string Or_error.t)] in test (Ok ()) (Ok "kay"); [%expect {| (Ok kay) |}]; test (error "not okay") (Ok "kay"); [%expect {| (Error "not okay") |}]; test (Ok ()) (error "not okay"); [%expect {| (Error "not okay") |}]; test (error "no fst") (error "no snd"); [%expect {| (Error ("no fst" "no snd")) |}] ;; let ( <* ) = A.( <* ) let%expect_test _ = let test x y = print_s [%sexp (x <* y : string Or_error.t)] in test (Ok "okay") (Ok ()); [%expect {| (Ok okay) |}]; test (error "not okay") (Ok ()); [%expect {| (Error "not okay") |}]; test (Ok "okay") (error "not okay"); [%expect {| (Error "not okay") |}]; test (error "no fst") (error "no snd"); [%expect {| (Error ("no fst" "no snd")) |}] ;; let both = A.both let%expect_test _ = let test x y = print_s [%sexp (both x y : (string * string) Or_error.t)] in test (Ok "o") (Ok "kay"); [%expect {| (Ok (o kay)) |}]; test (error "not okay") (Ok "kay"); [%expect {| (Error "not okay") |}]; test (Ok "o") (error "not okay"); [%expect {| (Error "not okay") |}]; test (error "no fst") (error "no snd"); [%expect {| (Error ("no fst" "no snd")) |}] ;; let map = A.map let%expect_test _ = let test x = print_s [%sexp (map x ~f:String.capitalize : string Or_error.t)] in test (Ok "okay"); [%expect {| (Ok Okay) |}]; test (error "not okay"); [%expect {| (Error "not okay") |}] ;; let ( >>| ) = A.( >>| ) let%expect_test _ = let test x = print_s [%sexp (x >>| String.capitalize : string Or_error.t)] in test (Ok "okay"); [%expect {| (Ok Okay) |}]; test (error "not okay"); [%expect {| (Error "not okay") |}] ;; let map2 = A.map2 let%expect_test _ = let test x y = print_s [%sexp (map2 x y ~f:( ^ ) : string Or_error.t)] in test (Ok "o") (Ok "kay"); [%expect {| (Ok okay) |}]; test (error "not okay") (Ok "kay"); [%expect {| (Error "not okay") |}]; test (Ok "o") (error "not okay"); [%expect {| (Error "not okay") |}]; test (error "no fst") (error "no snd"); [%expect {| (Error ("no fst" "no snd")) |}] ;; let map3 = A.map3 let%expect_test _ = let test x y z = print_s [%sexp (map3 x y z ~f:(fun a b c -> a ^ b ^ c) : string Or_error.t)] in test (Ok "o") (Ok "k") (Ok "ay"); [%expect {| (Ok okay) |}]; test (error "not okay") (Ok "k") (Ok "ay"); [%expect {| (Error "not okay") |}]; test (Ok "o") (error "not okay") (Ok "ay"); [%expect {| (Error "not okay") |}]; test (Ok "o") (Ok "k") (error "not okay"); [%expect {| (Error "not okay") |}]; test (error "no 1st") (error "no 2nd") (error "no 3rd"); [%expect {| (Error ("no 1st" "no 2nd" "no 3rd")) |}] ;; let all = A.all let%expect_test _ = let test list = print_s [%sexp (all list : string list Or_error.t)] in test []; [%expect {| (Ok ()) |}]; test [ Ok "okay" ]; [%expect {| (Ok (okay)) |}]; test [ Ok "o"; Ok "kay" ]; [%expect {| (Ok (o kay)) |}]; test [ Ok "o"; Ok "k"; Ok "ay" ]; [%expect {| (Ok (o k ay)) |}]; test [ error "oh no!" ]; [%expect {| (Error "oh no!") |}]; test [ error "oh no!"; Ok "okay" ]; [%expect {| (Error "oh no!") |}]; test [ Ok "okay"; error "oh no!" ]; [%expect {| (Error "oh no!") |}]; test [ error "oh no!"; Ok "o"; Ok "kay" ]; [%expect {| (Error "oh no!") |}]; test [ Ok "o"; error "oh no!"; Ok "aay" ]; [%expect {| (Error "oh no!") |}]; test [ Ok "o"; Ok "kay"; error "oh no!" ]; [%expect {| (Error "oh no!") |}]; test [ error "oh"; error "no"; error "!" ]; [%expect {| (Error (oh no !)) |}] ;; let all_unit = A.all_unit let%expect_test _ = let test list = print_s [%sexp (all_unit list : unit Or_error.t)] in test []; [%expect {| (Ok ()) |}]; test [ Ok () ]; [%expect {| (Ok ()) |}]; test [ Ok (); Ok () ]; [%expect {| (Ok ()) |}]; test [ Ok (); Ok (); Ok () ]; [%expect {| (Ok ()) |}]; test [ error "oh no!" ]; [%expect {| (Error "oh no!") |}]; test [ error "oh no!"; Ok () ]; [%expect {| (Error "oh no!") |}]; test [ Ok (); error "oh no!" ]; [%expect {| (Error "oh no!") |}]; test [ error "oh no!"; Ok (); Ok () ]; [%expect {| (Error "oh no!") |}]; test [ Ok (); error "oh no!"; Ok () ]; [%expect {| (Error "oh no!") |}]; test [ Ok (); Ok (); error "oh no!" ]; [%expect {| (Error "oh no!") |}]; test [ error "oh"; error "no"; error "!" ]; [%expect {| (Error (oh no !)) |}] ;; module Applicative_infix = A.Applicative_infix end let%test_module "Make" = (module Test_applicative_s (Applicative.Make (struct type 'a t = 'a Or_error.t let return = Or_error.return let apply = Or_error.apply let map = `Define_using_apply end))) ;; let%test_module "Make" = (module Test_applicative_s (Applicative.Make_using_map2 (struct type 'a t = 'a Or_error.t let return = Or_error.return let map2 = Or_error.map2 let map = `Define_using_map2 end))) ;; let%test_module "Make" = (module Test_applicative_s (Applicative.Make_using_map2_local (struct type 'a t = 'a Or_error.t let return x = Ok x let map2 = Or_error.map2 let map = `Define_using_map2 end))) ;; (* While law-abiding applicatives shouldn't be relying functions being called the minimal number of times, it is good for performance that things be this way. For many applicatives this will not matter very much, but for others, like Bonsai, it is a little more significant, since extra calls construct more Incremental nodes, yielding more strain on the Incremental stabilizer. The point is that we should not assume that the input applicative instance can be frivolous in creating nodes in the applicative call-tree. *) let%expect_test _ = let module A = struct type 'a t = | Other of string | Return : 'a -> 'a t | Map : ('a -> 'b) * 'a t -> 'b t | Map2 : ('a -> 'b -> 'c) * 'a t * 'b t -> 'c t include Applicative.Make_using_map2 (struct type nonrec 'a t = 'a t let return x = Return x let map2 a b ~f = Map2 (f, a, b) let map = `Custom (fun a ~f -> Map (f, a)) end) let rec sexp_of_t : type a. a t -> Sexp.t = function | Other x -> Atom x | Return _ -> Atom "Return" | Map (_, a) -> List [ Atom "Map"; sexp_of_t a ] | Map2 (_, a, b) -> List [ Atom "Map2"; sexp_of_t a; sexp_of_t b ] ;; end in let open A in let test x = print_s [%sexp (x : A.t)] in let a, b, c, d = Other "A", Other "B", Other "C", Other "D" in test (map2 a b ~f:(fun a b -> a, b)); [%expect {| (Map2 A B) |}]; test (both a b); [%expect {| (Map2 A B) |}]; test (all_unit [ a; b; c; d ]); [%expect {| (Map2 (Map2 (Map2 (Map2 Return A) B) C) D) |}]; test (a *> b); [%expect {| (Map2 A B) |}] ;; (* These functors serve only to check that the signatures for various Foo and Foo2 module types don't drift apart over time. *) module _ = struct open Applicative (* Applicative_infix to Applicative_infix2 *) module _ (X : Applicative_infix) : Applicative_infix2 with type ('a, 'e) t = 'a X.t = struct include X type ('a, 'e) t = 'a X.t end (* Applicative_infix2 to Applicative_infix *) module _ (X : Applicative_infix2) : Applicative_infix with type 'a t = ('a, unit) X.t = struct include X type 'a t = ('a, unit) X.t end (* Applicative_infix2 to Applicative_infix3 *) module _ (X : Applicative_infix2) : Applicative_infix3 with type ('a, 'd, 'e) t = ('a, 'd) X.t = struct include X type ('a, 'd, 'e) t = ('a, 'd) X.t end (* Applicative_infix3 to Applicative_infix2 *) module _ (X : Applicative_infix3) : Applicative_infix2 with type ('a, 'd) t = ('a, 'd, unit) X.t = struct include X type ('a, 'd) t = ('a, 'd, unit) X.t end (* Let_syntax to Let_syntax2 *) module _ (X : Let_syntax) : Let_syntax2 with type ('a, 'e) t = 'a X.t = struct include X type ('a, 'e) t = 'a X.t end (* Let_syntax2 to Let_syntax *) module _ (X : Let_syntax2) : Let_syntax with type 'a t = ('a, unit) X.t = struct include X type 'a t = ('a, unit) X.t end (* Let_syntax2 to Let_syntax3 *) module _ (X : Let_syntax2) : Let_syntax3 with type ('a, 'd, 'e) t = ('a, 'd) X.t = struct include X type ('a, 'd, 'e) t = ('a, 'd) X.t end (* Let_syntax3 to Let_syntax2 *) module _ (X : Let_syntax3) : Let_syntax2 with type ('a, 'd) t = ('a, 'd, unit) X.t = struct include X type ('a, 'd) t = ('a, 'd, unit) X.t end end base-0.16.3/test/test_applicative.mli000066400000000000000000000000551446274340700175500ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_applicative.mlt000066400000000000000000000003211446274340700175570ustar00rootroot00000000000000open Base open Expect_test_helpers_base let () = let z = 3 in let f = (fun x y -> x + y + z) in let r = Option.map2 (Some 3) (Some 4) ~f in print_s [%sexp (r : int option)] ;; [%%expect {| (10) |}] base-0.16.3/test/test_array.ml000066400000000000000000000420701446274340700162170ustar00rootroot00000000000000open! Import open! Array let%test_module "Binary_searchable" = (module Test_binary_searchable.Test1 (struct include Array module For_test = struct let of_array = Fn.id end end)) ;; let%test_module "Blit" = (module Test_blit.Test1 (struct type 'a z = 'a include Array let create_bool ~len = create ~len false end) (Array)) ;; module List_helpers = struct let rec sprinkle x xs = (x :: xs) :: (match xs with | [] -> [] | x' :: xs' -> List.map (sprinkle x xs') ~f:(fun sprinkled -> x' :: sprinkled)) ;; let rec permutations = function | [] -> [ [] ] | x :: xs -> List.concat_map (permutations xs) ~f:(fun perms -> sprinkle x perms) ;; end let%test_module "Sort" = (module struct open Private.Sort let%test_module "Intro_sort.five_element_sort" = (module struct (* run [five_element_sort] on all permutations of an array of five elements *) let all_perms = List_helpers.permutations [ 1; 2; 3; 4; 5 ] let%test _ = List.length all_perms = 120 let%test _ = not (List.contains_dup ~compare:[%compare: int list] all_perms) let%test _ = List.for_all all_perms ~f:(fun l -> let arr = Array.of_list l in Intro_sort.five_element_sort arr ~compare:[%compare: int] 0 1 2 3 4; [%compare.equal: int t] arr [| 1; 2; 3; 4; 5 |]) ;; end) ;; module Test (M : Private.Sort.Sort) = struct let random_data ~length ~range = let arr = Array.create ~len:length 0 in for i = 0 to length - 1 do arr.(i) <- Random.int range done; arr ;; let assert_sorted arr = M.sort arr ~left:0 ~right:(Array.length arr - 1) ~compare:[%compare: int]; let len = Array.length arr in let rec loop i prev = if i = len then true else if arr.(i) < prev then false else loop (i + 1) arr.(i) in loop 0 (-1) ;; let%test _ = assert_sorted (random_data ~length:0 ~range:100) let%test _ = assert_sorted (random_data ~length:1 ~range:100) let%test _ = assert_sorted (random_data ~length:100 ~range:1_000) let%test _ = assert_sorted (random_data ~length:1_000 ~range:1) let%test _ = assert_sorted (random_data ~length:1_000 ~range:10) let%test _ = assert_sorted (random_data ~length:1_000 ~range:1_000_000) end let%test_module _ = (module Test (Insertion_sort)) let%test_module _ = (module Test (Heap_sort)) let%test_module _ = (module Test (Intro_sort)) end) ;; let%test _ = is_sorted [||] ~compare:[%compare: int] let%test _ = is_sorted [| 0 |] ~compare:[%compare: int] let%test _ = is_sorted [| 0; 1; 2; 2; 4 |] ~compare:[%compare: int] let%test _ = not (is_sorted [| 0; 1; 2; 3; 2 |] ~compare:[%compare: int]) let%test_unit _ = List.iter ~f:(fun (t, expect) -> assert (Bool.equal expect (is_sorted_strictly (of_list t) ~compare:[%compare: int]))) [ [], true ; [ 1 ], true ; [ 1; 2 ], true ; [ 1; 1 ], false ; [ 2; 1 ], false ; [ 1; 2; 3 ], true ; [ 1; 1; 3 ], false ; [ 1; 2; 2 ], false ] ;; let%expect_test "merge" = let test a1 a2 = let res = merge a1 a2 ~compare:Int.compare in print_s ([%sexp_of: int array] res); require_equal [%here] (module struct type t = int list [@@deriving equal, sexp_of] end) (to_list res) (List.merge (to_list a1) (to_list a2) ~compare:Int.compare) in test [||] [||]; [%expect {| () |}]; test [| 1; 2; 3 |] [||]; [%expect {| (1 2 3) |}]; test [||] [| 1; 2; 3 |]; [%expect {| (1 2 3) |}]; test [| 1; 2; 3 |] [| 1; 2; 3 |]; [%expect {| (1 1 2 2 3 3) |}]; test [| 1; 2; 3 |] [| 4; 5; 6 |]; [%expect {| (1 2 3 4 5 6) |}]; test [| 4; 5; 6 |] [| 1; 2; 3 |]; [%expect {| (1 2 3 4 5 6) |}]; test [| 3; 5 |] [| 1; 2; 4; 6 |]; [%expect {| (1 2 3 4 5 6) |}]; test [| 1; 3; 7; 8; 9 |] [| 2; 4; 5; 6 |]; [%expect {| (1 2 3 4 5 6 7 8 9) |}]; test [| 1; 2; 2; 3 |] [| 2; 2; 3; 4 |]; [%expect {| (1 2 2 2 2 3 3 4) |}] ;; let%expect_test "merge with duplicates" = (* Testing that equal elements from a1 come before equal elements from a2 *) let test a1 a2 = let compare a b = Comparable.lift Int.compare ~f:fst a b in let res = merge a1 a2 ~compare in print_s ([%sexp_of: (int * string) array] res); require_equal [%here] (module struct type t = (int * string) list [@@deriving equal, sexp_of] end) (to_list res) (List.merge (to_list a1) (to_list a2) ~compare) in test [| 1, "a1" |] [| 1, "a2" |]; [%expect {| ((1 a1) (1 a2)) |}]; test [| 1, "a1"; 2, "a1"; 3, "a1" |] [| 3, "a2"; 4, "a2"; 5, "a2" |]; [%expect {| ((1 a1) (2 a1) (3 a1) (3 a2) (4 a2) (5 a2)) |}]; test [| 3, "a1"; 4, "a1"; 5, "a1" |] [| 1, "a2"; 2, "a2"; 3, "a2" |]; [%expect {| ((1 a2) (2 a2) (3 a1) (3 a2) (4 a1) (5 a1)) |}]; test [| 1, "a1"; 3, "a1"; 3, "a1"; 5, "a1" |] [| 2, "a2"; 3, "a2"; 3, "a2"; 4, "a2" |]; [%expect {| ((1 a1) (2 a2) (3 a1) (3 a1) (3 a2) (3 a2) (4 a2) (5 a1)) |}] ;; let%test _ = foldi [||] ~init:13 ~f:(fun _ _ _ -> failwith "bad") = 13 let%test _ = foldi [| 13 |] ~init:17 ~f:(fun i ac x -> ac + i + x) = 30 let%test _ = foldi [| 13; 17 |] ~init:19 ~f:(fun i ac x -> ac + i + x) = 50 let%test _ = counti [| 0; 1; 2; 3; 4 |] ~f:(fun idx x -> idx = x) = 5 let%test _ = counti [| 0; 1; 2; 3; 4 |] ~f:(fun idx x -> idx = 4 - x) = 1 let%test_unit _ = for i = 0 to 5 do let l1 = List.init i ~f:Fn.id in let l2 = List.rev (to_list (of_list_rev l1)) in assert ([%compare.equal: int list] l1 l2) done ;; let%test_unit _ = [%test_result: int array] (filter_opt [| Some 1; None; Some 2; None; Some 3 |]) ~expect:[| 1; 2; 3 |] ;; let%test_unit _ = [%test_result: int array] (filter_opt [| Some 1; None; Some 2 |]) ~expect:[| 1; 2 |] ;; let%test_unit _ = [%test_result: int array] (filter_opt [| Some 1 |]) ~expect:[| 1 |] let%test_unit _ = [%test_result: int array] (filter_opt [| None |]) ~expect:[||] let%test_unit _ = [%test_result: int array] (filter_opt [||]) ~expect:[||] let%expect_test _ = print_s ([%sexp_of: int array] (map2_exn [| 1; 2; 3 |] [| 2; 3; 4 |] ~f:( + ))); [%expect {| (3 5 7) |}] ;; let%expect_test "map2_exn raise" = require_does_raise [%here] (fun () -> map2_exn [| 1; 2; 3 |] [| 2; 3; 4; 5 |] ~f:( + )); [%expect {| (Invalid_argument "length mismatch in Array.map2_exn: 3 <> 4") |}] ;; let%test_unit _ = [%test_result: int] (fold2_exn [||] [||] ~init:13 ~f:(fun _ -> failwith "fail")) ~expect:13 ;; let%test_unit _ = [%test_result: (int * string) list] (fold2_exn [| 1 |] [| "1" |] ~init:[] ~f:(fun ac a b -> (a, b) :: ac)) ~expect:[ 1, "1" ] ;; let%test_unit _ = [%test_result: int array] (filter [| 0; 1 |] ~f:(fun n -> n < 2)) ~expect:[| 0; 1 |] ;; let%test_unit _ = [%test_result: int array] (filter [| 0; 1 |] ~f:(fun n -> n < 1)) ~expect:[| 0 |] ;; let%test_unit _ = [%test_result: int array] (filter [| 0; 1 |] ~f:(fun n -> n < 0)) ~expect:[||] ;; let%test_unit _ = [%test_result: bool] (exists [||] ~f:(fun _ -> true)) ~expect:false let%test_unit _ = [%test_result: bool] (exists [| 0; 1; 2; 3 |] ~f:(fun x -> 4 = x)) ~expect:false ;; let%test_unit _ = [%test_result: bool] (exists [| 0; 1; 2; 3 |] ~f:(fun x -> 2 = x)) ~expect:true ;; let%test_unit _ = [%test_result: bool] (existsi [||] ~f:(fun _ _ -> true)) ~expect:false let%test_unit _ = [%test_result: bool] (existsi [| 0; 1; 2; 3 |] ~f:(fun i x -> i <> x)) ~expect:false ;; let%test_unit _ = [%test_result: bool] (existsi [| 0; 1; 3; 3 |] ~f:(fun i x -> i <> x)) ~expect:true ;; let%test_unit _ = [%test_result: bool] (for_all [||] ~f:(fun _ -> false)) ~expect:true let%test_unit _ = [%test_result: bool] (for_all [| 1; 2; 3 |] ~f:Int.is_positive) ~expect:true ;; let%test_unit _ = [%test_result: bool] (for_all [| 0; 1; 3; 3 |] ~f:Int.is_positive) ~expect:false ;; let%test_unit _ = [%test_result: bool] (for_alli [||] ~f:(fun _ _ -> false)) ~expect:true let%test_unit _ = [%test_result: bool] (for_alli [| 0; 1; 2; 3 |] ~f:(fun i x -> i = x)) ~expect:true ;; let%test_unit _ = [%test_result: bool] (for_alli [| 0; 1; 3; 3 |] ~f:(fun i x -> i = x)) ~expect:false ;; let%test_unit _ = [%test_result: bool] (exists2_exn [||] [||] ~f:(fun _ _ -> true)) ~expect:false ;; let%test_unit _ = [%test_result: bool] (exists2_exn [| 0; 2; 4; 6 |] [| 0; 2; 4; 6 |] ~f:(fun x y -> x <> y)) ~expect:false ;; let%test_unit _ = [%test_result: bool] (exists2_exn [| 0; 2; 4; 8 |] [| 0; 2; 4; 6 |] ~f:(fun x y -> x <> y)) ~expect:true ;; let%test_unit _ = [%test_result: bool] (exists2_exn [| 2; 2; 4; 6 |] [| 0; 2; 4; 6 |] ~f:(fun x y -> x <> y)) ~expect:true ;; let%test_unit _ = [%test_result: bool] (for_all2_exn [||] [||] ~f:(fun _ _ -> false)) ~expect:true ;; let%test_unit _ = [%test_result: bool] (for_all2_exn [| 0; 2; 4; 6 |] [| 0; 2; 4; 6 |] ~f:(fun x y -> x = y)) ~expect:true ;; let%test_unit _ = [%test_result: bool] (for_all2_exn [| 0; 2; 4; 8 |] [| 0; 2; 4; 6 |] ~f:(fun x y -> x = y)) ~expect:false ;; let%test_unit _ = [%test_result: bool] (for_all2_exn [| 2; 2; 4; 6 |] [| 0; 2; 4; 6 |] ~f:(fun x y -> x = y)) ~expect:false ;; let%test_unit _ = [%test_result: bool] (equal ( = ) [||] [||]) ~expect:true let%test_unit _ = [%test_result: bool] (equal ( = ) [| 1 |] [| 1 |]) ~expect:true let%test_unit _ = [%test_result: bool] (equal ( = ) [| 1; 2 |] [| 1; 2 |]) ~expect:true let%test_unit _ = [%test_result: bool] (equal ( = ) [||] [| 1 |]) ~expect:false let%test_unit _ = [%test_result: bool] (equal ( = ) [| 1 |] [||]) ~expect:false let%test_unit _ = [%test_result: bool] (equal ( = ) [| 1 |] [| 1; 2 |]) ~expect:false let%test_unit _ = [%test_result: bool] (equal ( = ) [| 1; 2 |] [| 1; 3 |]) ~expect:false let%test_unit _ = [%test_result: (int * int) option] (findi [| 1; 2; 3; 4 |] ~f:(fun i x -> i = 2 * x)) ~expect:None ;; let%test_unit _ = [%test_result: (int * int) option] (findi [| 1; 2; 1; 4 |] ~f:(fun i x -> i = 2 * x)) ~expect:(Some (2, 1)) ;; let%test_unit _ = [%test_result: int option] (find_mapi [| 0; 5; 2; 1; 4 |] ~f:(fun i x -> if i = x then Some (i + x) else None)) ~expect:(Some 0) ;; let%test_unit _ = [%test_result: int option] (find_mapi [| 3; 5; 2; 1; 4 |] ~f:(fun i x -> if i = x then Some (i + x) else None)) ~expect:(Some 4) ;; let%test_unit _ = [%test_result: int option] (find_mapi [| 3; 5; 1; 1; 4 |] ~f:(fun i x -> if i = x then Some (i + x) else None)) ~expect:(Some 8) ;; let%test_unit _ = [%test_result: int option] (find_mapi [| 3; 5; 1; 1; 2 |] ~f:(fun i x -> if i = x then Some (i + x) else None)) ~expect:None ;; let%test_unit _ = List.iter ~f:(fun (l, expect) -> let t = of_list l in assert (Poly.equal expect (find_consecutive_duplicate t ~equal:Poly.equal))) [ [], None ; [ 1 ], None ; [ 1; 1 ], Some (1, 1) ; [ 1; 2 ], None ; [ 1; 2; 1 ], None ; [ 1; 2; 2 ], Some (2, 2) ; [ 1; 1; 2; 2 ], Some (1, 1) ] ;; let%test_unit _ = [%test_result: int option] (random_element [||]) ~expect:None let%test_unit _ = [%test_result: int option] (random_element [| 0 |]) ~expect:(Some 0) let%test_unit _ = List.iter [ [||]; [| 1 |]; [| 1; 2; 3; 4; 5 |] ] ~f:(fun t -> [%test_result: int array] (Sequence.to_array (to_sequence t)) ~expect:t) ;; let test_fold_map array ~init ~f ~expect = [%test_result: int array] (folding_map array ~init ~f) ~expect:(snd expect); [%test_result: int * int array] (fold_map array ~init ~f) ~expect ;; let test_fold_mapi array ~init ~f ~expect = [%test_result: int array] (folding_mapi array ~init ~f) ~expect:(snd expect); [%test_result: int * int array] (fold_mapi array ~init ~f) ~expect ;; let%test_unit _ = test_fold_map [| 1; 2; 3; 4 |] ~init:0 ~f:(fun acc x -> let y = acc + x in y, y) ~expect:(10, [| 1; 3; 6; 10 |]) ;; let%test_unit _ = test_fold_map [||] ~init:0 ~f:(fun acc x -> let y = acc + x in y, y) ~expect:(0, [||]) ;; let%test_unit _ = test_fold_mapi [| 1; 2; 3; 4 |] ~init:0 ~f:(fun i acc x -> let y = acc + (i * x) in y, y) ~expect:(20, [| 0; 2; 8; 20 |]) ;; let%test_unit _ = test_fold_mapi [||] ~init:0 ~f:(fun i acc x -> let y = acc + (i * x) in y, y) ~expect:(0, [||]) ;; let%test_module "permute" = (module struct module Int_list = struct type t = int list [@@deriving compare, sexp_of] include (val Comparator.make ~compare ~sexp_of_t) end let test_permute initial_contents ~pos ~len = let all_permutations = let pos, len = Ordered_collection_common.get_pos_len_exn ?pos ?len ~total_length:(List.length initial_contents) () in let left = List.take initial_contents pos in let middle = List.sub initial_contents ~pos ~len in let right = List.drop initial_contents (pos + len) in Set.of_list (module Int_list) (List_helpers.permutations middle |> List.map ~f:(fun middle -> left @ middle @ right)) in let not_yet_seen = ref all_permutations in while not (Set.is_empty !not_yet_seen) do let array = of_list initial_contents in permute ?pos ?len array; let permutation = to_list array in if not (Set.mem all_permutations permutation) then raise_s [%sexp "invalid permutation" , { array_length = (List.length initial_contents : int) ; permutation : int list ; pos : int option ; len : int option }]; not_yet_seen := Set.remove !not_yet_seen permutation done ;; let%expect_test "permute different array lengths and subranges" = let indices = None :: List.map [ 0; 1; 2; 3; 4 ] ~f:Option.some in for array_length = 0 to 4 do let initial_contents = List.init array_length ~f:Int.succ in List.iter indices ~f:(fun pos -> List.iter indices ~f:(fun len -> match Ordered_collection_common.get_pos_len ?pos ?len ~total_length:array_length () with | Ok _ -> test_permute initial_contents ~pos ~len | Error _ -> require [%here] (Exn.does_raise (fun () -> permute ?pos ?len (Array.of_list initial_contents))))) done; [%expect {| |}] ;; end) ;; let%expect_test "create_float_uninitialized" = let array = create_float_uninitialized ~len:10 in (* make sure reading/writing the array is safe *) Array.permute array; (* sanity check without depending on specific contents *) print_s [%sexp (Array.length array : int)]; [%expect {| 10 |}] ;; module Int_array = struct type t = int array [@@deriving equal, sexp_of] end module Int_list = struct type t = int list [@@deriving equal, sexp_of] end let%expect_test "swap" = let array = [| 0; 1; 2; 3 |] in print_s [%sexp (array : int array)]; [%expect {| (0 1 2 3) |}]; swap array 0 0; print_s [%sexp (array : int array)]; [%expect {| (0 1 2 3) |}]; swap array 0 3; print_s [%sexp (array : int array)]; [%expect {| (3 1 2 0) |}] ;; let%expect_test "rev and rev_inplace" = let test ordered_list = let ordered_array = of_list ordered_list in let reversed_array = let array = copy ordered_array in rev_inplace array; array in require_equal [%here] (module Int_list) (to_list reversed_array) (List.rev ordered_list); require_equal [%here] (module Int_array) reversed_array (rev ordered_array); print_s [%sexp (reversed_array : int array)] in test []; [%expect {| () |}]; test [ 0 ]; [%expect {| (0) |}]; test (List.init 10 ~f:Fn.id); [%expect {| (9 8 7 6 5 4 3 2 1 0) |}] ;; let%expect_test "map_inplace" = let test list = let f x = x * x in let array = of_list list in map_inplace array ~f; require_equal [%here] (module Int_list) (to_list array) (List.map list ~f); print_s [%sexp (array : int array)] in test []; [%expect {| () |}]; test [ 0 ]; [%expect {| (0) |}]; test (List.init 10 ~f:Fn.id); [%expect {| (0 1 4 9 16 25 36 49 64 81) |}] ;; let%expect_test "cartesian_product" = require [%here] (is_empty (cartesian_product [||] [||])); require [%here] (is_empty (cartesian_product [||] [| 13 |])); require [%here] (is_empty (cartesian_product [| 13 |] [||])); print_s [%sexp (cartesian_product [| 1; 2; 3 |] [| "a"; "b" |] : (int * string) array)]; [%expect {| ((1 a) (1 b) (2 a) (2 b) (3 a) (3 b)) |}] ;; let%expect_test "create_local" = let len = 10 in let array = create_local ~len (-1) in for i = 0 to len - 1 do assert (get array i = -1); set array i i done; let array = init len ~f:(fun i -> get array i) in print_s (sexp_of_t sexp_of_int array); [%expect {| (0 1 2 3 4 5 6 7 8 9) |}] ;; base-0.16.3/test/test_array.mli000066400000000000000000000000551446274340700163650ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_array_local.mlt000066400000000000000000000006311446274340700175520ustar00rootroot00000000000000open! Base (* first test that we only allow global elements *) let local_id (x [@local]) = x;; let k = local_id 42 in Array.create_local ~len:10 k [%%expect {| Line _, characters _-_: Error: This value escapes its region |}];; (* then check that the array is indeed local *) let arr = Array.create_local ~len:10 42 in ref arr [%%expect {| Line _, characters _-_: Error: This value escapes its region |}] base-0.16.3/test/test_backtrace.ml000066400000000000000000000005471446274340700170230ustar00rootroot00000000000000open! Import open! Backtrace let%test_unit (_ [@tags "no-js"]) = let t = get () in assert (String.length (to_string t) > 0) ;; let%expect_test _ = Backtrace.elide := true; Stdio.Out_channel.(output_string stdout) (Sexp.to_string (sexp_of_t (Exn.with_recording false ~f:Exn.most_recent))); [%expect {| ("") |}] ;; base-0.16.3/test/test_backtrace.mli000066400000000000000000000000551446274340700171660ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_base.ml000066400000000000000000000005571446274340700160170ustar00rootroot00000000000000open! Import let%expect_test _ = let f x = x * 2 in let g x = x + 3 in print_s [%sexp (f @@ 5 : int)]; [%expect {| 10 |}]; print_s [%sexp (g @@ f @@ 5 : int)]; [%expect {| 13 |}]; print_s [%sexp (f @@ g @@ 5 : int)]; [%expect {| 16 |}] ;; let%expect_test "exp is present at the toplevel" = print_s [%sexp (2 ** 8 : int)]; [%expect {| 256 |}] ;; base-0.16.3/test/test_base.mli000066400000000000000000000000551446274340700161610ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_base_containers.ml000066400000000000000000000246341446274340700202460ustar00rootroot00000000000000open! Import open Test_container include (Test_S1 (Array) : sig end) include (Test_S1 (List) : sig end) include (Test_S1 (Queue) : sig end) include ( Test_S0 (struct include String let mem t c = mem t c module Elt = struct type t = char [@@deriving sexp] let of_int = Char.of_int_exn let to_int = Char.to_int end let of_list = of_char_list end) : sig end) (* Quickcheck-based expect tests *) let%expect_test "Array" = Base_container_tests.test_indexed_container_s1_with_creators (module struct include Array type 'a t = 'a array [@@deriving quickcheck] (* [Array.concat] has a slightly different type than S1 expects *) let concat array = concat (Array.to_list array) end); [%expect {| Container: testing [length] Container: testing [is_empty] Container: testing [mem] Container: testing [iter] Container: testing [fold] Container: testing [fold_result] Container: testing [fold_until] Container: testing [exists] Container: testing [for_all] Container: testing [count] Container: testing [sum] Container: testing [find] Container: testing [find_map] Container: testing [to_list] Container: testing [to_array] Container: testing [min_elt] Container: testing [max_elt] Container: testing [of_list] Container: testing [of_array] Container: testing [append] Container: testing [concat] Container: testing [map] Container: testing [filter] Container: testing [filter_map] Container: testing [concat_map] Container: testing [partition_tf] Container: testing [partition_map] Container: testing [foldi] Container: testing [iteri] Container: testing [existsi] Container: testing [for_alli] Container: testing [counti] Container: testing [findi] Container: testing [find_mapi] Container: testing [init] Container: testing [mapi] Container: testing [filteri] Container: testing [filter_mapi] Container: testing [concat_mapi] |}] ;; let%expect_test "Hash_set" = Base_container_tests.test_container_s0 (module struct open Base_quickcheck module Elt = struct include Int type t = (int[@generator Generator.small_strictly_positive_int]) [@@deriving compare, equal, quickcheck, sexp_of] end include Hash_set type t = Hash_set.M(Int).t [@@deriving sexp_of] let quickcheck_generator = Generator.map [%generator: Elt.t list] ~f:(Hash_set.of_list (module Int)) ;; let quickcheck_observer = Observer.unmap [%observer: Elt.t list] ~f:Hash_set.to_list let quickcheck_shrinker = Shrinker.map [%shrinker: Elt.t list] ~f:(Hash_set.of_list (module Int)) ~f_inverse:Hash_set.to_list ;; (* [to_list] and [to_array] proceed in the opposite order as everything else. This is likely a performance hack to reuse [fold] without adding a [List.rev]. It is not particularly problematic, since hash table order is already unpredictable due to hash functions. *) let to_list t = List.rev (to_list t) let to_array t = Array.rev (to_array t) end); [%expect {| Container: testing [length] Container: testing [is_empty] Container: testing [mem] Container: testing [iter] Container: testing [fold] Container: testing [fold_result] Container: testing [fold_until] Container: testing [exists] Container: testing [for_all] Container: testing [count] Container: testing [sum] Container: testing [find] Container: testing [find_map] Container: testing [to_list] Container: testing [to_array] Container: testing [min_elt] Container: testing [max_elt] |}] ;; let%expect_test "List" = Base_container_tests.test_indexed_container_s1_with_creators (module struct include List type 'a t = 'a list [@@deriving quickcheck] end); [%expect {| Container: testing [length] Container: testing [is_empty] Container: testing [mem] Container: testing [iter] Container: testing [fold] Container: testing [fold_result] Container: testing [fold_until] Container: testing [exists] Container: testing [for_all] Container: testing [count] Container: testing [sum] Container: testing [find] Container: testing [find_map] Container: testing [to_list] Container: testing [to_array] Container: testing [min_elt] Container: testing [max_elt] Container: testing [of_list] Container: testing [of_array] Container: testing [append] Container: testing [concat] Container: testing [map] Container: testing [filter] Container: testing [filter_map] Container: testing [concat_map] Container: testing [partition_tf] Container: testing [partition_map] Container: testing [foldi] Container: testing [iteri] Container: testing [existsi] Container: testing [for_alli] Container: testing [counti] Container: testing [findi] Container: testing [find_mapi] Container: testing [init] Container: testing [mapi] Container: testing [filteri] Container: testing [filter_mapi] Container: testing [concat_mapi] |}] ;; let%expect_test "Set" = Base_container_tests.test_container_s0 (module struct open Base_quickcheck module Elt = struct include Int type t = (int[@generator Generator.small_strictly_positive_int]) [@@deriving compare, equal, quickcheck, sexp_of] end include Set type t = Set.M(Int).t [@@deriving sexp_of] let quickcheck_generator = Generator.set_t_m (module Elt) Elt.quickcheck_generator let quickcheck_observer = Observer.set_t Elt.quickcheck_observer let quickcheck_shrinker = Shrinker.set_t Elt.quickcheck_shrinker let min_elt t ~compare:_ = min_elt t let max_elt t ~compare:_ = max_elt t (* [find] and [find_map] use pre-order traversals (root -> left -> right), while all the other traversals are in-order (left -> root -> right). We patch them up here to behave like pre-order, while still using [Set.find] and [Set.find_map] for the searching so we're actually testing those functions. *) let rec find t ~f = match Set.find t ~f with | None -> None | Some elt as some -> let lt, _ = Set.split_lt_ge t elt in Option.first_some (find lt ~f) some ;; let rec find_map t ~f = match Set.find_map t ~f:(fun elt -> Option.map (f elt) ~f:(fun x -> elt, x)) with | None -> None | Some (elt, x) -> let lt, _ = Set.split_lt_ge t elt in Option.first_some (find_map lt ~f) (Some x) ;; end); [%expect {| Container: testing [length] Container: testing [is_empty] Container: testing [mem] Container: testing [iter] Container: testing [fold] Container: testing [fold_result] Container: testing [fold_until] Container: testing [exists] Container: testing [for_all] Container: testing [count] Container: testing [sum] Container: testing [find] Container: testing [find_map] Container: testing [to_list] Container: testing [to_array] Container: testing [min_elt] Container: testing [max_elt] |}] ;; let%expect_test "String" = Base_container_tests.test_indexed_container_s0_with_creators (module struct include String module Elt = struct type t = char [@@deriving compare, equal, quickcheck, sexp_of] end type t = string [@@deriving quickcheck] (* eta-expand due to [local_] types *) let mem t c = mem t c (* leave off the [?sep] argument *) let concat list = concat list let concat_map list = concat_map list let concat_mapi list = concat_mapi list end); [%expect {| Container: testing [length] Container: testing [is_empty] Container: testing [mem] Container: testing [iter] Container: testing [fold] Container: testing [fold_result] Container: testing [fold_until] Container: testing [exists] Container: testing [for_all] Container: testing [count] Container: testing [sum] Container: testing [find] Container: testing [find_map] Container: testing [to_list] Container: testing [to_array] Container: testing [min_elt] Container: testing [max_elt] Container: testing [of_list] Container: testing [of_array] Container: testing [append] Container: testing [concat] Container: testing [map] Container: testing [filter] Container: testing [filter_map] Container: testing [concat_map] Container: testing [partition_tf] Container: testing [partition_map] Container: testing [foldi] Container: testing [iteri] Container: testing [existsi] Container: testing [for_alli] Container: testing [counti] Container: testing [findi] Container: testing [find_mapi] Container: testing [init] Container: testing [mapi] Container: testing [filteri] Container: testing [filter_mapi] Container: testing [concat_mapi] |}] ;; let%expect_test "Queue" = Base_container_tests.test_indexed_container_s1 (module struct include Queue open Base_quickcheck let quickcheck_generator quickcheck_generator_elt = [%generator: elt list] |> Generator.map ~f:Queue.of_list ;; let quickcheck_observer quickcheck_observer_elt = [%observer: elt list] |> Observer.unmap ~f:Queue.to_list ;; let quickcheck_shrinker quickcheck_shrinker_elt = [%shrinker: elt list] |> Shrinker.map ~f:Queue.of_list ~f_inverse:Queue.to_list ;; end); [%expect {| Container: testing [length] Container: testing [is_empty] Container: testing [mem] Container: testing [iter] Container: testing [fold] Container: testing [fold_result] Container: testing [fold_until] Container: testing [exists] Container: testing [for_all] Container: testing [count] Container: testing [sum] Container: testing [find] Container: testing [find_map] Container: testing [to_list] Container: testing [to_array] Container: testing [min_elt] Container: testing [max_elt] Container: testing [foldi] Container: testing [iteri] Container: testing [existsi] Container: testing [for_alli] Container: testing [counti] Container: testing [findi] Container: testing [find_mapi] |}] ;; base-0.16.3/test/test_base_containers.mli000066400000000000000000000000551446274340700204060ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_base_stack.ml000066400000000000000000000011211446274340700171700ustar00rootroot00000000000000open! Import open Stack include Test_container.Test_S1 (Stack) include Test_stack.Test (Test_stack.Debug (Stack)) let capacity = capacity let set_capacity = set_capacity let%test_unit _ = let t = create () in [%test_result: int] (capacity t) ~expect:0; set_capacity t (-1); [%test_result: int] (capacity t) ~expect:0; set_capacity t 10; [%test_result: int] (capacity t) ~expect:10; set_capacity t 0; [%test_result: int] (capacity t) ~expect:0; push t (); set_capacity t 0; [%test_result: int] (length t) ~expect:1; [%test_pred: int] (fun c -> c >= 1) (capacity t) ;; base-0.16.3/test/test_base_stack.mli000066400000000000000000000000551446274340700173460ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_blit.ml000066400000000000000000000055351446274340700160400ustar00rootroot00000000000000open! Import open! Blit (* This unit test checks that when [blit] calls [unsafe_blit], the slices are valid. It also checks that [blit] doesn't call [unsafe_blit] when there is a range error. *) let%test_module _ = (module struct let blit_was_called = ref false let slices_are_valid = ref (Ok ()) module B = Make (struct type t = bool array let create ~len = Array.create false ~len let length = Array.length let unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len = blit_was_called := true; slices_are_valid := Or_error.try_with (fun () -> assert (len >= 0); assert (src_pos >= 0); assert (src_pos + len <= Array.length src); assert (dst_pos >= 0); assert (dst_pos + len <= Array.length dst)); Array.blit ~src ~src_pos ~dst ~dst_pos ~len ;; end) let%test_module "Bool" = (module Test_blit.Test (struct type t = bool let equal = Bool.equal let of_bool = Fn.id end) (struct type t = bool array [@@deriving sexp_of] let create ~len = Array.create false ~len let length = Array.length let get = Array.get let set = Array.set end) (B)) ;; let%test_unit _ = let opts = [ None; Some (-1); Some 0; Some 1; Some 2 ] in List.iter [ 0; 1; 2 ] ~f:(fun src -> List.iter [ 0; 1; 2 ] ~f:(fun dst -> List.iter opts ~f:(fun src_pos -> List.iter opts ~f:(fun src_len -> List.iter opts ~f:(fun dst_pos -> try let check f = blit_was_called := false; slices_are_valid := Ok (); match Or_error.try_with f with | Error _ -> assert (not !blit_was_called) | Ok () -> ok_exn !slices_are_valid in check (fun () -> B.blito ~src:(Array.create ~len:src false) ?src_pos ?src_len ~dst:(Array.create ~len:dst false) ?dst_pos ()); check (fun () -> ignore (B.subo (Array.create ~len:src false) ?pos:src_pos ?len:src_len : bool array)) with | exn -> raise_s [%message "failure" (exn : exn) (src : int) (src_pos : int option) (src_len : int option) (dst : int) (dst_pos : int option)]))))) ;; end) ;; base-0.16.3/test/test_blit.mli000066400000000000000000000000551446274340700162010ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_bool.ml000066400000000000000000000016611446274340700160350ustar00rootroot00000000000000open! Import let%expect_test "hash coherence" = check_hash_coherence [%here] (module Bool) [ false; true ]; [%expect {| |}] ;; let%expect_test "Bool.Non_short_circuiting.(||)" = let ( || ) = Bool.Non_short_circuiting.( || ) in assert (true || true); assert (true || false); assert (false || true); assert (not (false || false)); assert ( true || (print_endline "rhs"; true)); [%expect {|rhs|}]; assert ( false || (print_endline "rhs"; true)); [%expect {|rhs|}] ;; let%expect_test "Bool.Non_short_circuiting.(&&)" = let ( && ) = Bool.Non_short_circuiting.( && ) in assert (true && true); assert (not (true && false)); assert (not (false && true)); assert (not (false && false)); assert ( true && (print_endline "rhs"; true)); [%expect {|rhs|}]; assert ( not (false && (print_endline "rhs"; true))); [%expect {|rhs|}] ;; base-0.16.3/test/test_bool.mli000066400000000000000000000000551446274340700162020ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_bytes.ml000066400000000000000000000065001446274340700162250ustar00rootroot00000000000000open! Import open! Bytes let%test_module "Blit" = (module Test_blit.Test (struct include Char let of_bool b = if b then 'a' else 'b' end) (struct include Bytes let create ~len = create len end) (Bytes)) ;; let%expect_test "local" = let bytes = Bytes.create_local 10 in printf "%d\n" (Bytes.length bytes); [%expect {| 10 |}]; for i = 0 to 9 do Bytes.set bytes i (Int.to_string i).[0] done; let string = Bytes.unsafe_to_string ~no_mutation_while_string_reachable:bytes in for i = 0 to 9 do printf "%c" string.[i] done; [%expect {| 0123456789 |}]; Expect_test_helpers_base.require_does_raise [%here] (fun () -> ignore (Bytes.create_local (Sys.max_string_length + 1) : Bytes.t)); [%expect {| (Invalid_argument Bytes.create_local) |}] ;; let%test_module "Unsafe primitives" = (module struct let%expect_test "16-bit primitives" = let buffer = create 10 in (* Ensure that writing the biggest possible 16-bit value works. *) Bytes.unsafe_set_int16 buffer 2 0xFFFF; printf "0x%04x" (Bytes.unsafe_get_int16 buffer 2); [%expect {| 0xffff |}]; (* Ensure that [16-bit] operations are indeed 16-bit, meaning it doesn't affect anything other than x[pos] and x[pos + 1]. *) Bytes.unsafe_set_int16 buffer 4 0; Bytes.unsafe_set_int16 buffer 2 ((1 lsl 16) + 1); printf "0x%04x" (Bytes.unsafe_get_int16 buffer 2); [%expect {| 0x0001 |}]; printf "0x%04x" (Bytes.unsafe_get_int16 buffer 4); [%expect {| 0x0000 |}] ;; let%expect_test "32-bit primitives" = let buffer = create 10 in Bytes.unsafe_set_int32 buffer 0 0xdeadbeefl; printf "%lx" (Bytes.unsafe_get_int32 buffer 0); [%expect {| deadbeef |}]; (* Ensure that Bytes.get will retrieve the individual positions byte values as written by Bytes.unsafe_set_int32. *) for i = 0 to 3 do let chr = Bytes.get buffer i in printf "buffer[%d] = 0x%02x\n" i (Char.to_int chr) done; [%expect {| buffer[0] = 0xef buffer[1] = 0xbe buffer[2] = 0xad buffer[3] = 0xde |}]; (* Ensure that 32-bit writes works on non-word-aligned positions. *) Bytes.unsafe_set_int32 buffer 1 178293l; printf "%ld" (Bytes.unsafe_get_int32 buffer 1); [%expect {| 178293 |}] ;; let%expect_test "64-bit primitives" = let buffer = create 10 in Bytes.unsafe_set_int64 buffer 0 0x12345678_deadbeefL; printf "%Lx" (Bytes.unsafe_get_int64 buffer 0); [%expect {| 12345678deadbeef |}]; (* Ensure that Bytes.get will retrieve the individual positions byte values as written by Bytes.unsafe_set_int64. *) for i = 0 to 7 do let chr = Bytes.get buffer i in printf "buffer[%d] = 0x%02x\n" i (Char.to_int chr) done; [%expect {| buffer[0] = 0xef buffer[1] = 0xbe buffer[2] = 0xad buffer[3] = 0xde buffer[4] = 0x78 buffer[5] = 0x56 buffer[6] = 0x34 buffer[7] = 0x12 |}]; (* Ensure that 64-bit writes works on non-word-aligned positions. *) Bytes.unsafe_set_int64 buffer 1 0x12345678_deadbeefL; printf "%Lx" (Bytes.unsafe_get_int64 buffer 1); [%expect {| 12345678deadbeef |}] ;; end) ;; base-0.16.3/test/test_bytes.mli000066400000000000000000000000551446274340700163750ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_char.ml000066400000000000000000000134361446274340700160220ustar00rootroot00000000000000open! Import open! Char let%test _ = not (is_whitespace '\008') (* backspace *) let%test _ = is_whitespace '\009' (* '\t': horizontal tab *) let%test _ = is_whitespace '\010' (* '\n': line feed *) let%test _ = is_whitespace '\011' (* '\v': vertical tab *) let%test _ = is_whitespace '\012' (* '\f': form feed *) let%test _ = is_whitespace '\013' (* '\r': carriage return *) let%test _ = not (is_whitespace '\014') (* shift out *) let%test _ = is_whitespace '\032' (* space *) let%expect_test "hash coherence" = check_hash_coherence [%here] (module Char) [ min_value; 'a'; max_value ]; [%expect {| |}] ;; let%test_module "int to char conversion" = (module struct let%test_unit "of_int bounds" = let bounds_check i = [%test_result: t option] (of_int i) ~expect:None ~message:(Int.to_string i) in for i = 1 to 100 do bounds_check (-i); bounds_check (255 + i) done ;; let%test_unit "of_int_exn vs of_int" = for i = -100 to 300 do [%test_eq: t option] (of_int i) (Option.try_with (fun () -> of_int_exn i)) ~message:(Int.to_string i) done ;; let%test_unit "unsafe_of_int vs of_int_exn" = for i = 0 to 255 do [%test_eq: t] (unsafe_of_int i) (of_int_exn i) ~message:(Int.to_string i) done ;; end) ;; let%expect_test "all" = Ref.set_temporarily sexp_style To_string_hum ~f:(fun () -> print_s [%sexp (all : t list)]); [%expect {| ("\000" "\001" "\002" "\003" "\004" "\005" "\006" "\007" "\b" "\t" "\n" "\011" "\012" "\r" "\014" "\015" "\016" "\017" "\018" "\019" "\020" "\021" "\022" "\023" "\024" "\025" "\026" "\027" "\028" "\029" "\030" "\031" " " ! "\"" # $ % & ' "(" ")" * + , - . / 0 1 2 3 4 5 6 7 8 9 : ";" < = > ? @ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z [ "\\" ] ^ _ ` a b c d e f g h i j k l m n o p q r s t u v w x y z { | } ~ "\127" "\128" "\129" "\130" "\131" "\132" "\133" "\134" "\135" "\136" "\137" "\138" "\139" "\140" "\141" "\142" "\143" "\144" "\145" "\146" "\147" "\148" "\149" "\150" "\151" "\152" "\153" "\154" "\155" "\156" "\157" "\158" "\159" "\160" "\161" "\162" "\163" "\164" "\165" "\166" "\167" "\168" "\169" "\170" "\171" "\172" "\173" "\174" "\175" "\176" "\177" "\178" "\179" "\180" "\181" "\182" "\183" "\184" "\185" "\186" "\187" "\188" "\189" "\190" "\191" "\192" "\193" "\194" "\195" "\196" "\197" "\198" "\199" "\200" "\201" "\202" "\203" "\204" "\205" "\206" "\207" "\208" "\209" "\210" "\211" "\212" "\213" "\214" "\215" "\216" "\217" "\218" "\219" "\220" "\221" "\222" "\223" "\224" "\225" "\226" "\227" "\228" "\229" "\230" "\231" "\232" "\233" "\234" "\235" "\236" "\237" "\238" "\239" "\240" "\241" "\242" "\243" "\244" "\245" "\246" "\247" "\248" "\249" "\250" "\251" "\252" "\253" "\254" "\255") |}] ;; let%expect_test "predicates" = Ref.set_temporarily sexp_style To_string_hum ~f:(fun () -> print_s [%sexp (List.filter all ~f:is_digit : t list)]; [%expect {| (0 1 2 3 4 5 6 7 8 9) |}]; print_s [%sexp (List.filter all ~f:is_lowercase : t list)]; [%expect {| (a b c d e f g h i j k l m n o p q r s t u v w x y z) |}]; print_s [%sexp (List.filter all ~f:is_uppercase : t list)]; [%expect {| (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z) |}]; print_s [%sexp (List.filter all ~f:is_alpha : t list)]; [%expect {| (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z a b c d e f g h i j k l m n o p q r s t u v w x y z) |}]; print_s [%sexp (List.filter all ~f:is_alphanum : t list)]; [%expect {| (0 1 2 3 4 5 6 7 8 9 A B C D E F G H I J K L M N O P Q R S T U V W X Y Z a b c d e f g h i j k l m n o p q r s t u v w x y z) |}]; print_s [%sexp (List.filter all ~f:is_print : t list)]; [%expect {| (" " ! "\"" # $ % & ' "(" ")" * + , - . / 0 1 2 3 4 5 6 7 8 9 : ";" < = > ? @ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z [ "\\" ] ^ _ ` a b c d e f g h i j k l m n o p q r s t u v w x y z { | } ~) |}]; print_s [%sexp (List.filter all ~f:is_whitespace : t list)]; [%expect {| ("\t" "\n" "\011" "\012" "\r" " ") |}]; print_s [%sexp (List.filter all ~f:is_hex_digit : t list)]; [%expect {| (0 1 2 3 4 5 6 7 8 9 A B C D E F a b c d e f) |}]; print_s [%sexp (List.filter all ~f:is_hex_digit_lower : t list)]; [%expect {| (0 1 2 3 4 5 6 7 8 9 a b c d e f) |}]; print_s [%sexp (List.filter all ~f:is_hex_digit_upper : t list)]; [%expect {| (0 1 2 3 4 5 6 7 8 9 A B C D E F) |}]) ;; let%expect_test "get_hex_digit" = Ref.set_temporarily sexp_style To_string_hum ~f:(fun () -> let hex_digit_alist = List.filter_map Char.all ~f:(fun char -> Option.map (get_hex_digit char) ~f:(fun digit -> char, digit)) in print_s [%sexp (hex_digit_alist : (char * int) list)]; [%expect {| ((0 0) (1 1) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9) (A 10) (B 11) (C 12) (D 13) (E 14) (F 15) (a 10) (b 11) (c 12) (d 13) (e 14) (f 15)) |}]; require_equal [%here] (module struct type t = (char * int) list [@@deriving equal, sexp_of] end) (Char.all |> List.filter ~f:is_hex_digit |> List.map ~f:(fun char -> char, get_hex_digit_exn char)) hex_digit_alist; [%expect {| |}]; require_does_raise [%here] (fun () -> get_hex_digit_exn Char.min_value); [%expect {| ("Char.get_hex_digit_exn: not a hexadecimal digit" (char "\000")) |}]) ;; let%test_module "Caseless Comparable" = (module struct (* examples from docs *) let%test _ = Caseless.equal 'A' 'a' let%test _ = Caseless.('a' < 'B') let%test _ = Int.( <> ) (Caseless.compare 'a' 'B') (compare 'a' 'B') let%test _ = List.is_sorted ~compare:Caseless.compare [ 'A'; 'b'; 'C' ] end) ;; base-0.16.3/test/test_char.mli000066400000000000000000000000551446274340700161640ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_clz_ctz.ml000066400000000000000000000070071446274340700165520ustar00rootroot00000000000000open! Import module E = struct type t = { clz : int ; ctz : int } [@@deriving compare, sexp_of] end module type T = sig type t [@@deriving sexp_of] val one : t val ( lsl ) : t -> int -> t val clz : t -> int val ctz : t -> int val num_bits : int end module Make (Int : T) = struct let%expect_test "one-hot" = let clz_and_ctz int = { E.clz = Int.clz int; ctz = Int.ctz int } in for i = 0 to Int.num_bits - 1 do [%test_result: E.t] ~expect:{ E.clz = Int.num_bits - 1 - i; ctz = i } (clz_and_ctz Int.(one lsl i)) done ;; end include Make (Nativeint) include Make (Int63) include Make (Int63.Private.Emul) include Make (struct include Int let%expect_test "zero" = (* [clz 0] is guaranteed to be num_bits for int. We compute clz on the tagged representation of int's, and the binary representation of the int [0] is num_bits 0's followed by a 1 (the tag bit). *) [%test_result: int] ~expect:num_bits (clz 0) ;; (* [ctz 0] is unspecified. On linux it seems to be stable and equal to the system word size (which is num_bits + 1). ran 2019-02-11 on linux: {v [%test_result: int] ~expect:(num_bits + 1) (ctz 0) v} in javascript, it is 32 (which is num_bits): ran 2019-02-11 on javascript: {v [%test_result: int] ~expect:(num_bits) (ctz 0) v} *) end) include Make (struct include Int32 let clz_and_ctz i32 = { E.clz = clz i32; ctz = ctz i32 } let%expect_test "extra examples" = [%test_result: E.t] ~expect:{ clz = 31; ctz = 0 } (clz_and_ctz 0b1l); [%test_result: E.t] ~expect:{ clz = 30; ctz = 1 } (clz_and_ctz 0b10l); [%test_result: E.t] ~expect:{ clz = 30; ctz = 0 } (clz_and_ctz 0b11l); [%test_result: E.t] ~expect:{ clz = 25; ctz = 1 } (clz_and_ctz 0b1000010l); [%test_result: E.t] ~expect:{ clz = 8; ctz = 6 } (clz_and_ctz 0b100000010000001001000000l); [%test_result: E.t] ~expect:{ clz = 0; ctz = 31 } (clz_and_ctz 0b10000000000000000000000000000000l); [%test_result: E.t] ~expect:{ clz = 9; ctz = 6 } (clz_and_ctz 0b00000000010000000100000001000000l); [%test_result: E.t] ~expect:{ clz = 0; ctz = 6 } (clz_and_ctz 0b10000000010000000100000001000000l) ;; end) include Make (struct include Int64 let clz_and_ctz i64 = { E.clz = clz i64; ctz = ctz i64 } let%expect_test "extra examples" = [%test_result: E.t] ~expect:{ clz = 63; ctz = 0 } (clz_and_ctz 0b1L); [%test_result: E.t] ~expect:{ clz = 62; ctz = 1 } (clz_and_ctz 0b10L); [%test_result: E.t] ~expect:{ clz = 62; ctz = 0 } (clz_and_ctz 0b11L); [%test_result: E.t] ~expect:{ clz = 57; ctz = 1 } (clz_and_ctz 0b1000010L); [%test_result: E.t] ~expect:{ clz = 40; ctz = 6 } (clz_and_ctz 0b100000010000001001000000L); [%test_result: E.t] ~expect:{ clz = 0; ctz = 63 } (clz_and_ctz 0b1000000000000000000000000000000000000000000000000000000000000000L); [%test_result: E.t] ~expect:{ clz = 32; ctz = 31 } (clz_and_ctz 0b0000000000000000000000000000000010000000000000000000000000000000L); [%test_result: E.t] ~expect:{ clz = 32; ctz = 6 } (clz_and_ctz 0b0000000000000000000000000000000010000000010000000100000001000000L); [%test_result: E.t] ~expect:{ clz = 33; ctz = 6 } (clz_and_ctz 0b0000000000000000000000000000000001000000010000000100000001000000L) ;; end) base-0.16.3/test/test_clz_ctz.mli000066400000000000000000000000551446274340700167170ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_compare.ml000066400000000000000000000124511446274340700165270ustar00rootroot00000000000000open! Base open Expect_test_helpers_base module type S = sig type t [@@deriving sexp_of] include Comparable.Comparisons with type t := t end (* Test the consistency of derived comparison operators with [compare] because many of them are hand-optimized in [Base]. *) let test (type a) here (module T : S with type t = a) list = let op (type b) (module Result : S with type t = b) operator ~actual ~expect = With_return.with_return (fun failed -> List.iter list ~f:(fun arg1 -> List.iter list ~f:(fun arg2 -> let actual = actual arg1 arg2 in let expect = expect arg1 arg2 in if not (Result.compare actual expect = 0) then ( print_cr here [%message "comparison failed" (operator : string) (arg1 : T.t) (arg2 : T.t) (actual : Result.t) (expect : Result.t)]; failed.return ())))) in let module C = Comparable.Make (T) in op (module Bool) "equal" ~actual:T.equal ~expect:C.equal; op (module T) "min" ~actual:T.min ~expect:C.min; op (module T) "max" ~actual:T.max ~expect:C.max; op (module Bool) "(=)" ~actual:T.( = ) ~expect:C.( = ); op (module Bool) "(<)" ~actual:T.( < ) ~expect:C.( < ); op (module Bool) "(>)" ~actual:T.( > ) ~expect:C.( > ); op (module Bool) "(<>)" ~actual:T.( <> ) ~expect:C.( <> ); op (module Bool) "(<=)" ~actual:T.( <= ) ~expect:C.( <= ); op (module Bool) "(>=)" ~actual:T.( >= ) ~expect:C.( >= ); op (module Bool) "Comparable.equal" ~actual:(fun a b -> Comparable.equal T.compare a b) ~expect:C.equal; op (module T) "Comparable.min" ~actual:(fun a b -> Comparable.min T.compare a b) ~expect:C.min; op (module T) "Comparable.max" ~actual:(fun a b -> Comparable.max T.compare a b) ~expect:C.max ;; let%expect_test "Base" = test [%here] (module struct include Base type t = int [@@deriving sexp_of] end) Int.[ min_value; minus_one; zero; one; max_value ]; [%expect {||}] ;; let%expect_test "Unit" = test [%here] (module Unit) Unit.all; [%expect {||}] ;; let%expect_test "Bool" = test [%here] (module Bool) Bool.all; [%expect {||}] ;; let%expect_test "Char" = test [%here] (module Char) Char.all; [%expect {||}] ;; let%expect_test "Float" = test [%here] (module Float) Float.[ min_value; minus_one; zero; one; max_value ]; [%expect {||}] ;; let%expect_test "Int" = test [%here] (module Int) Int.[ min_value; minus_one; zero; one; max_value ]; [%expect {||}] ;; let%expect_test "Int32" = test [%here] (module Int32) Int32.[ min_value; minus_one; zero; one; max_value ]; [%expect {||}] ;; let%expect_test "Int64" = test [%here] (module Int64) Int64.[ min_value; minus_one; zero; one; max_value ]; [%expect {||}] ;; let%expect_test "Nativeint" = test [%here] (module Nativeint) Nativeint.[ min_value; minus_one; zero; one; max_value ]; [%expect {||}] ;; let%expect_test "Int63" = test [%here] (module Int63) Int63.[ min_value; minus_one; zero; one; max_value ]; [%expect {||}] ;; let%test_module "lexicographic" = (module struct let%expect_test "single" = Ref.set_temporarily sexp_style To_string_hum ~f:(fun () -> List.iter [ 1, 2; 1, 1; 2, 1 ] ~f:(fun (a, b) -> let ordering = Ordering.of_int (compare a b) in print_s [%message (a : int) (b : int) (ordering : Ordering.t)]; require_equal [%here] (module Ordering) (Ordering.of_int (compare a b)) (Ordering.of_int (Comparable.lexicographic [ compare ] a b))); [%expect {| ((a 1) (b 2) (ordering Less)) ((a 1) (b 1) (ordering Equal)) ((a 2) (b 1) (ordering Greater)) |}]) ;; let%expect_test "three comparisons" = Ref.set_temporarily sexp_style To_string_hum ~f:(fun () -> let compare_first_three_elts a_1 b_1 = Comparable.lexicographic (List.init 3 ~f:(fun i a b -> compare a.(i) b.(i))) a_1 b_1 in let test a b = let a = Array.of_list a in let b = Array.of_list b in let ordering = Ordering.of_int (compare_first_three_elts a b) in print_s [%message (a : int array) (b : int array) (ordering : Ordering.t)] in test [ 1; 2; 3; 4 ] [ 1; 2; 4; 9 ]; [%expect {| ((a (1 2 3 4)) (b (1 2 4 9)) (ordering Less)) |}]; test [ 1; 2; 3; 4 ] [ 1; 2; 3; 9 ]; [%expect {| ((a (1 2 3 4)) (b (1 2 3 9)) (ordering Equal)) |}]; test [ 1; 2; 3; 4 ] [ 1; 1; 4; 9 ]; [%expect {| ((a (1 2 3 4)) (b (1 1 4 9)) (ordering Greater)) |}]) ;; end) ;; let%expect_test "reversed" = let list = [ 3; 1; 4; 1; 5; 9; 2; 6; 5; 3; 5; 9 ] in let sort_asc1 = List.sort ~compare:[%compare: int] list in let sort_desc = List.sort ~compare:[%compare: int Comparable.reversed] list in let sort_asc2 = List.sort ~compare:[%compare: int Comparable.reversed Comparable.reversed] list in print_s [%message (sort_asc1 : int list) (sort_desc : int list) (sort_asc2 : int list)]; [%expect {| ((sort_asc1 (1 1 2 3 3 4 5 5 5 6 9 9)) (sort_desc (9 9 6 5 5 5 4 3 3 2 1 1)) (sort_asc2 (1 1 2 3 3 4 5 5 5 6 9 9))) |}] ;; base-0.16.3/test/test_compare.mli000066400000000000000000000000551446274340700166750ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_container_module_types.ml000066400000000000000000000146351446274340700216620ustar00rootroot00000000000000(** This file tests the consistency of [Container] and [Indexed_container] module types. We compare each module type S to the most generic version G that exports the same set of values. We create a module type I by instantiating G to mimic S, such as by dropping a type parameter. We then test that S = I by writing two identity functors, one from S to I and one from I to S. *) open! Base module _ : module type of Container = struct (* The most generic interface that everything else implements. *) module type Generic = Container.Generic (* The generic interface with creator functions. Ensure it implements Generic. *) module type Generic_with_creators = Container.Generic_with_creators module _ (M : Container.Generic_with_creators) : Container.Generic = M (* Ensure that S0 is Generic with no type arguments. *) module type S0 = Container.S0 open struct module type Generic0 = sig type elt type t include Generic with type _ elt := elt and type (_, _) t := t val mem : t -> elt -> bool end end module _ (M : S0) : Generic0 = M module _ (M : Generic0) : S0 = M (* Ensure that S0_phantom is Generic with a fixed element type. *) module type S0_phantom = Container.S0_phantom open struct module type Generic0_phantom = sig type elt type _ t include Container.Generic with type _ elt := elt and type (_, 'p) t := 'p t val mem : _ t -> elt -> bool end end module _ (M : S0_phantom) : Generic0_phantom = M module _ (M : Generic0_phantom) : S0_phantom = M (* Ensure that S0_with_creators is Generic_with_creators with no type arguments. *) module type S0_with_creators = Container.S0_with_creators open struct module type Generic0_with_creators = sig type elt type t include Generic_with_creators with type _ elt := elt and type (_, _) t := t and type ('a, _) concat := 'a list val mem : t -> elt -> bool end end module _ (M : S0_with_creators) : Generic0_with_creators = M module _ (M : Generic0_with_creators) : S0_with_creators = M (* Ensure that S1 is Generic with no phantom type. *) module type S1 = Container.S1 open struct module type Generic1 = sig type _ t include Container.Generic with type 'a elt := 'a and type ('a, _) t := 'a t end end module _ (M : S1) : Generic1 = M module _ (M : Generic1) : S1 = M (* Ensure that S1_phantom is Generic with a covariant phantom type. *) module type S1_phantom = Container.S1_phantom open struct module type Generic1_phantom = sig type (_, _) t include Generic with type 'a elt := 'a and type ('a, 'p) t := ('a, 'p) t end end module _ (M : S1_phantom) : Generic1_phantom = M module _ (M : Generic1_phantom) : S1_phantom = M (* Ensure that S1_with_creators is Generic_with_creators with no phantom type. *) module type S1_with_creators = Container.S1_with_creators open struct module type Generic1_with_creators = sig type 'a t include Generic_with_creators with type 'a elt := 'a and type ('a, _) t := 'a t and type ('a, _) concat := 'a t end end module _ (M : S1_with_creators) : Generic1_with_creators = M module _ (M : Generic1_with_creators) : S1_with_creators = M (* Other definitions that we are not testing: *) module Continue_or_stop = Container.Continue_or_stop module Make = Container.Make module Make0 = Container.Make0 module Make_gen = Container.Make_gen module Make_with_creators = Container.Make_with_creators module Make0_with_creators = Container.Make0_with_creators module Make_gen_with_creators = Container.Make_gen_with_creators module type Derived = Container.Derived module type Summable = Container.Summable include (Container : Derived) end module _ : module type of Indexed_container = struct (* The generic interface everything else implements. *) module type Generic = Indexed_container.Generic (* Ensure that S0 is Generic without type parameters. *) module type S0 = Indexed_container.S0 open struct module type Generic0 = sig type elt type t include Generic with type _ elt := elt and type (_, _) t := t val mem : t -> elt -> bool end end module _ (M : S0) : Generic0 = M module _ (M : Generic0) : S0 = M (* Ensure that S1 is Generic without an abstract element type. *) module type S1 = Indexed_container.S1 open struct module type Generic1 = sig type 'a t include Generic with type 'a elt := 'a and type ('a, _) t := 'a t end end module _ (M : S1) : Generic1 = M module _ (M : Generic1) : S1 = M (* Ensure that Generic_with_creators includes Generic. *) module type Generic_with_creators = Indexed_container.Generic_with_creators module _ (M : Indexed_container.Generic_with_creators) : Indexed_container.Generic = M (* Ensure that S0_with_creators is Generic_with_creators with no type arguments. *) module type S0_with_creators = Indexed_container.S0_with_creators open struct module type Generic0_with_creators = sig type elt type t include Generic_with_creators with type _ elt := elt and type (_, _) t := t and type ('a, _) concat := 'a list val mem : t -> elt -> bool end end module _ (M : S0_with_creators) : Generic0_with_creators = M module _ (M : Generic0_with_creators) : S0_with_creators = M (* Ensure that S1_with_creators is Generic_with_creators with no phantom type. *) module type S1_with_creators = Indexed_container.S1_with_creators open struct module type Generic1_with_creators = sig type 'a t include Generic_with_creators with type 'a elt := 'a and type ('a, _) t := 'a t and type ('a, _) concat := 'a t end end module _ (M : S1_with_creators) : Generic1_with_creators = M module _ (M : Generic1_with_creators) : S1_with_creators = M (* Other definitions that we are not testing: *) module Make = Indexed_container.Make module Make0 = Indexed_container.Make0 module Make_gen = Indexed_container.Make_gen module Make_with_creators = Indexed_container.Make_with_creators module Make0_with_creators = Indexed_container.Make0_with_creators module Make_gen_with_creators = Indexed_container.Make_gen_with_creators module type Derived = Indexed_container.Derived include (Indexed_container : Derived) end base-0.16.3/test/test_container_module_types.mli000066400000000000000000000000551446274340700220220ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_either.ml000066400000000000000000000041731446274340700163630ustar00rootroot00000000000000open! Import type t = (int, string) Either.t [@@deriving sexp_of] let f : t = First 0 let s : t = Second "str" let%expect_test "First.Monad.map" = let open Either.First.Let_syntax in let inc x = let%map v = x in v + 1 in let f' = inc f in let s' = inc s in print_s [%message (f' : t) (s' : t)]; [%expect {| ((f' (First 1)) (s' (Second str))) |}] ;; let%expect_test "Second.Monad.map" = let open Either.Second.Let_syntax in let add x = let%map v = x in String.concat [ v; "1" ] in let f' = add f in let s' = add s in print_s [%message (f' : t) (s' : t)]; [%expect {| ((f' (First 0)) (s' (Second str1))) |}] ;; let%expect_test "First.Monad.bind" = let open Either.First.Let_syntax in let inc x = let%bind v = x in return (v + 1) in let f' = inc f in let s' = inc s in print_s [%message (f' : t) (s' : t)]; [%expect {| ((f' (First 1)) (s' (Second str))) |}] ;; let%expect_test "Second.Monad.bind" = let open Either.Second.Let_syntax in let add x = let%bind v = x in return (String.concat [ v; "1" ]) in let f' = add f in let s' = add s in print_s [%message (f' : t) (s' : t)]; [%expect {| ((f' (First 0)) (s' (Second str1))) |}] ;; let%expect_test "First.map2" = let m t1 t2 = let result = Either.First.map2 ~f:(fun x y -> x + y) t1 t2 in print_s [%sexp (result : (int, string) Either.t)] in let foo = "foo" in let bar = "bar" in m (Second foo) (Second bar); [%expect {| (Second foo) |}]; m (First 1) (First 2); [%expect {| (First 3) |}]; m (Second foo) (First 1); [%expect {| (Second foo) |}]; m (First 1) (Second bar); [%expect {| (Second bar) |}] ;; let%expect_test "Second.map2" = let m t1 t2 = let result = Either.Second.map2 ~f:(fun x y -> x + y) t1 t2 in print_s [%sexp (result : (string, int) Either.t)] in let foo = "foo" in let bar = "bar" in m (First foo) (First bar); [%expect {| (First foo) |}]; m (Second 1) (Second 2); [%expect {| (Second 3) |}]; m (First foo) (Second 1); [%expect {| (First foo) |}]; m (Second 1) (First bar); [%expect {| (First bar) |}] ;; base-0.16.3/test/test_either.mli000066400000000000000000000000551446274340700165270ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_error.ml000066400000000000000000000011131446274340700162230ustar00rootroot00000000000000open! Base open! Import let errors = [ Error.of_string "ABC" ; Error.tag ~tag:"DEF" (Error.of_thunk (fun () -> "GHI")) ; Error.create_s [%message "foo" ~bar:(31 : int)] ] ;; let%expect_test _ = List.iter errors ~f:(fun error -> show_raise (fun () -> Error.raise error)); [%expect {| (raised ABC) (raised (DEF GHI)) (raised (foo (bar 31))) |}] ;; let%expect_test _ = List.iter errors ~f:(fun error -> show_raise (fun () -> Error.raise_s [%sexp (error : Error.t)])); [%expect {| (raised ABC) (raised (DEF GHI)) (raised (foo (bar 31))) |}] ;; base-0.16.3/test/test_error.mli000066400000000000000000000000551446274340700164000ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_exn.ml000066400000000000000000000007021446274340700156670ustar00rootroot00000000000000open! Import open! Exn let%expect_test "[create_s]" = print_s [%sexp (create_s [%message "foo"] : t)]; [%expect {| foo |}]; print_s [%sexp (create_s [%message "foo" "bar"] : t)]; [%expect {| (foo bar) |}]; let sexp = [%message "foo"] in print_s [%sexp (phys_equal sexp (sexp_of_t (create_s sexp)) : bool)]; [%expect {| true |}] ;; let%test _ = not (does_raise Fn.ignore) let%test _ = does_raise (fun () -> failwith "foo") base-0.16.3/test/test_exn.mli000066400000000000000000000000551446274340700160410ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_exn_reraise.ml000066400000000000000000000170441446274340700174100ustar00rootroot00000000000000open! Import (* These methods miss part of the backtrace. *) let clobber_most_recent_backtrace () = try failwith "clobbering" with | _ -> () ;; let _Base_Exn_reraise exn = Exn.reraise exn "reraised" let _Base_Exn_reraise_after_clobbering_most_recent_backtrace exn = clobber_most_recent_backtrace (); Exn.reraise exn "reraised" ;; external reraiser_raw : exn -> 'a = "%reraise" let external_reraise_unequal exn = reraiser_raw (Exn.Reraised ("reraised", exn)) let vanilla_raise_unequal exn = raise (Exn.Reraised ("reraised", exn)) (* These methods produce the full, desired backtrace. *) let vanilla_raise exn = raise exn let raise_with_original_backtrace exn = let backtrace = Backtrace.Exn.most_recent () in Exn.raise_with_original_backtrace (Exn.Reraised ("reraised", exn)) backtrace ;; (* This ref causes [check_value] to appear in the backtrace, because the [raise_s] call is no longer in tail position. *) let setter = ref 0 let check_value x = if x < 0 then raise_s [%message "bad value" (x : int)]; setter := x ;; (* This function duplicates the functionality of [Exn.reraise_uncaught] with a custom [reraiser] *) let reraise_uncaught reraiser f = try f () with | exn -> reraiser exn ;; let callstacker ~reraise_uncaught = let rec loop reraise_uncaught x = reraise_uncaught (fun () -> check_value x); loop reraise_uncaught (x - 1); reraise_uncaught (fun () -> check_value x) in loop reraise_uncaught 1 ;; let with_backtraces_enabled f = Backtrace.Exn.with_recording true ~f:(fun () -> Ref.set_temporarily Backtrace.elide false ~f) ;; let test_reraise_uncaught ~reraise_uncaught = with_backtraces_enabled (fun () -> Exn.handle_uncaught ~exit:false (fun () -> callstacker ~reraise_uncaught)) ;; let test_reraiser reraiser = test_reraise_uncaught ~reraise_uncaught:(reraise_uncaught reraiser) ;; (* If you want to see what the underlying backtraces look like, set this to true. Otherwise, these tests extract small snippets from the backtraces so that they are robust to compiler changes. *) let just_print = false let really_show_backtrace s = if just_print then print_endline s else printf "Before re-raise: %b\nAfter re-raise: %b" (String.is_substring s ~substring:"check_value") (String.is_substring s ~substring:"handle_uncaught") ;; let%test_module ("Show native backtraces" [@tags "no-js"]) = (module struct (* good *) let%expect_test "Base.Exn.reraise" = test_reraiser _Base_Exn_reraise; really_show_backtrace [%expect.output]; [%expect {| Before re-raise: true After re-raise: true |}] ;; (* bad, because the backtrace was clobbered *) let%expect_test "Base.Exn.reraise" = test_reraiser _Base_Exn_reraise_after_clobbering_most_recent_backtrace; really_show_backtrace [%expect.output]; [%expect {| Before re-raise: false After re-raise: true |}] ;; (* bad, missing the backtrace before the reraise *) let%expect_test "%reraise unequal" = test_reraiser external_reraise_unequal; really_show_backtrace [%expect.output]; [%expect {| Before re-raise: false After re-raise: true |}] ;; (* bad, missing the backtrace before the reraise *) let%expect_test "raise unequal" = test_reraiser vanilla_raise_unequal; really_show_backtrace [%expect.output]; [%expect {| Before re-raise: false After re-raise: true |}] ;; (* good, but no additional info attached *) let%expect_test "raise equal" = test_reraiser vanilla_raise; really_show_backtrace [%expect.output]; [%expect {| Before re-raise: true After re-raise: true |}] ;; (* good *) let%expect_test "Caml.Printexc.raise_with_backtrace" = test_reraiser raise_with_original_backtrace; really_show_backtrace [%expect.output]; [%expect {| Before re-raise: true After re-raise: true |}] ;; (* good *) let%expect_test "Exn.reraise_uncaught" = test_reraise_uncaught ~reraise_uncaught:(Exn.reraise_uncaught "reraised"); really_show_backtrace [%expect.output]; [%expect {| Before re-raise: true After re-raise: true |}] ;; end) ;; (* An example bad backtrace: {v Uncaught exception: (exn.ml.Reraised reraised ("bad value" (x -1))) Raised at Base_test__Test_exn_reraise.vanilla_raise_unequal in file "test_exn_reraise.ml" (inlined), line 10, characters 32-70 Called from Base_test__Test_exn_reraise.reraise_uncaught in file "test_exn_reraise.ml" (inlined), line 34, characters 11-23 Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml", line 39, characters 4-55 Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml" (inlined), line 38, characters 15-167 Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml" (inlined), line 40, characters 4-25 Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml" (inlined), line 38, characters 15-167 Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml" (inlined), line 40, characters 4-25 Called from Base_test__Test_exn_reraise.callstacker in file "test_exn_reraise.ml" (inlined), line 43, characters 2-17 Called from Base__Exn.handle_uncaught_aux in file "exn.ml" (inlined), line 113, characters 6-10 Called from Base__Exn.handle_uncaught in file "exn.ml" (inlined), line 139, characters 2-88 Called from Base_test__Test_exn_reraise.test.(fun) in file "test_exn_reraise.ml", line 53, characters 4-68 v} *) (* An example good backtrace: {v Uncaught exception: (exn.ml.Reraised reraised ("bad value" (x -1))) Raised at Base__Error.raise in file "error.ml" (inlined), line 9, characters 14-30 Called from Base__Error.raise_s in file "error.ml" (inlined), line 10, characters 19-40 Called from Base_test__Test_exn_reraise.check_value in file "test_exn_reraise.ml", line 26, characters 16-56 Called from Base_test__Test_exn_reraise.callstacker.loop.(fun) in file "test_exn_reraise.ml" (inlined), line 39, characters 41-54 Called from Base_test__Test_exn_reraise.reraise_uncaught in file "test_exn_reraise.ml" (inlined), line 33, characters 6-10 Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml", line 39, characters 4-55 Re-raised at Base_test__Test_exn_reraise._Caml_Printexc_raise_with_backtrace in file "test_exn_reraise.ml", line 18, characters 2-79 Called from Base_test__Test_exn_reraise.reraise_uncaught in file "test_exn_reraise.ml" (inlined), line 34, characters 11-23 Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml", line 39, characters 4-55 Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml" (inlined), line 40, characters 4-25 Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml" (inlined), line 40, characters 4-25 Called from Base_test__Test_exn_reraise.callstacker in file "test_exn_reraise.ml" (inlined), line 43, characters 2-17 Called from Base__Exn.handle_uncaught_aux in file "exn.ml" (inlined), line 113, characters 6-10 Called from Base__Exn.handle_uncaught in file "exn.ml" (inlined), line 139, characters 2-88 Called from Base_test__Test_exn_reraise.test.(fun) in file "test_exn_reraise.ml", line 53, characters 4-68 v}*) base-0.16.3/test/test_exn_reraise.mli000066400000000000000000000000551446274340700175530ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_exported_int_conversions.ml000066400000000000000000000204011446274340700222270ustar00rootroot00000000000000open! Import module type S = sig type t [@@deriving compare, sexp_of] val num_bits : int val min_value : t val minus_one : t val zero : t val one : t val max_value : t val to_int64 : t -> int64 val shift_right : t -> int -> t val random : Random.State.t -> t -> t -> t end module I : S with type t = int = struct include Int let random = Random.State.int_incl end module Native : S with type t = nativeint = struct include Nativeint let random = Random.State.nativeint_incl end module I32 : S with type t = int32 = struct include Int32 let random = Random.State.int32_incl end module I64 : S with type t = int64 = struct include Int64 let random = Random.State.int64_incl end module I63 : S with type t = Int63.t = struct include Int63 let random state lo hi = Int63.random_incl ~state lo hi end let iter (type a) (module M : S with type t = a) ~f = let state = Random.State.make [| 0; 1; 2; 3; 4; 5 |] in List.iter ~f [ M.min_value; M.minus_one; M.zero; M.one; M.max_value ]; for _ = 1 to 10_000 do (* skew toward low numbers of bits so that, e.g., choosing a random int64 does frequently find a value that can be converted to int32. *) let strip_bits = Random.State.int_incl state 0 (M.num_bits - 1) in let lo = M.shift_right M.min_value strip_bits in let hi = M.shift_right M.max_value strip_bits in f (M.random state lo hi) done ;; let try_with f x = Option.try_with (fun () -> f x) (* Checks that a conversion from [A.t] to [B.t] is total using [of] and [to]. *) let test_total (type a b) (module A : S with type t = a) (module B : S with type t = b) ~of_:b_of_a ~to_:a_to_b = iter (module A) ~f:(fun a -> require_compare_equal [%here] (module B) (b_of_a a) (a_to_b a); require_compare_equal [%here] (module Int64) (A.to_int64 a) (B.to_int64 (b_of_a a))) ;; let truncate int64 ~num_bits = Int64.shift_right (Int64.shift_left int64 (64 - num_bits)) (64 - num_bits) ;; (* Checks that a conversion from [A.t] to [B.t] is partial using [of] and [to], and the [_exn] equivalents. In the case where the conversion fails, ensure that the value, converted to an [Int64.t] is outside the representable range of [B.t] converted to an [Int64.t] as well. *) let test_partial (type a b) (module A : S with type t = a) (module B : S with type t = b) ~of_:b_of_a ~of_exn:b_of_a_exn ~of_trunc:b_of_a_trunc ~to_:a_to_b ~to_exn:a_to_b_exn ~to_trunc:a_to_b_trunc = let module B_option = struct type t = B.t option [@@deriving compare, sexp_of] end in let convertible_count = ref 0 in iter (module A) ~f:(fun a -> require_compare_equal [%here] (module B_option) (b_of_a a) (a_to_b a); require_compare_equal [%here] (module B_option) (b_of_a a) (try_with b_of_a_exn a); require_compare_equal [%here] (module B_option) (a_to_b a) (try_with a_to_b_exn a); match b_of_a a with | Some b -> Int.incr convertible_count; require_compare_equal [%here] (module B) b (b_of_a_trunc a); require_compare_equal [%here] (module B) b (a_to_b_trunc a); require_compare_equal [%here] (module Int64) (A.to_int64 a) (B.to_int64 b) | None -> let trunc = truncate (A.to_int64 a) ~num_bits:B.num_bits in require_compare_equal [%here] (module Int64) trunc (B.to_int64 (b_of_a_trunc a)); require_compare_equal [%here] (module Int64) trunc (B.to_int64 (a_to_b_trunc a)); require [%here] (Int64.( > ) (A.to_int64 a) (B.to_int64 B.max_value) || Int64.( < ) (A.to_int64 a) (B.to_int64 B.min_value)) ~if_false_then_print_s:(lazy [%message "failed to convert" ~_:(a : A.t)])); (* Make sure we stress the conversion a nontrivial number of times. This makes sure the random generation is useful and we aren't just testing the hard-coded examples. *) require [%here] (!convertible_count > 100) ~if_false_then_print_s: (lazy [%message "did not test successful conversion often enough" (convertible_count : int ref)]) ;; let%expect_test "int <-> nativeint" = test_total (module I) (module Native) ~of_:Nativeint.of_int ~to_:Int.to_nativeint; [%expect {| |}]; test_partial (module Native) (module I) ~of_:Int.of_nativeint ~of_exn:Int.of_nativeint_exn ~of_trunc:Int.of_nativeint_trunc ~to_:Nativeint.to_int ~to_exn:Nativeint.to_int_exn ~to_trunc:Nativeint.to_int_trunc; [%expect {| |}] ;; let%expect_test "int <-> int32" = test_partial (module I) (module I32) ~of_:Int32.of_int ~of_exn:Int32.of_int_exn ~of_trunc:Int32.of_int_trunc ~to_:Int.to_int32 ~to_exn:Int.to_int32_exn ~to_trunc:Int.to_int32_trunc; [%expect {| |}]; test_partial (module I32) (module I) ~of_:Int.of_int32 ~of_exn:Int.of_int32_exn ~of_trunc:Int.of_int32_trunc ~to_:Int32.to_int ~to_exn:Int32.to_int_exn ~to_trunc:Int32.to_int_trunc; [%expect {| |}] ;; let%expect_test "nativeint <-> int32" = test_partial (module Native) (module I32) ~of_:Int32.of_nativeint ~of_exn:Int32.of_nativeint_exn ~of_trunc:Int32.of_nativeint_trunc ~to_:Nativeint.to_int32 ~to_exn:Nativeint.to_int32_exn ~to_trunc:Nativeint.to_int32_trunc; [%expect {| |}]; test_total (module I32) (module Native) ~of_:Nativeint.of_int32 ~to_:Int32.to_nativeint; [%expect {| |}] ;; let%expect_test "int <-> int64" = test_total (module I) (module I64) ~of_:Int64.of_int ~to_:Int.to_int64; [%expect {| |}]; test_partial (module I64) (module I) ~of_:Int.of_int64 ~of_exn:Int.of_int64_exn ~of_trunc:Int.of_int64_trunc ~to_:Int64.to_int ~to_exn:Int64.to_int_exn ~to_trunc:Int64.to_int_trunc; [%expect {| |}] ;; let%expect_test "nativeint <-> int64" = test_total (module Native) (module I64) ~of_:Int64.of_nativeint ~to_:Nativeint.to_int64; [%expect {| |}]; test_partial (module I64) (module Native) ~of_:Nativeint.of_int64 ~of_exn:Nativeint.of_int64_exn ~of_trunc:Nativeint.of_int64_trunc ~to_:Int64.to_nativeint ~to_exn:Int64.to_nativeint_exn ~to_trunc:Int64.to_nativeint_trunc; [%expect {| |}] ;; let%expect_test "int32 <-> int64" = test_total (module I32) (module I64) ~of_:Int64.of_int32 ~to_:Int32.to_int64; [%expect {| |}]; test_partial (module I64) (module I32) ~of_:Int32.of_int64 ~of_exn:Int32.of_int64_exn ~of_trunc:Int32.of_int64_trunc ~to_:Int64.to_int32 ~to_exn:Int64.to_int32_exn ~to_trunc:Int64.to_int32_trunc; [%expect {| |}] ;; let%expect_test "int <-> int63" = test_total (module I) (module I63) ~of_:Int63.of_int ~to_:Int63.of_int; [%expect {| |}]; test_partial (module I63) (module I) ~of_:Int63.to_int ~of_exn:Int63.to_int_exn ~of_trunc:Int63.to_int_trunc ~to_:Int63.to_int ~to_exn:Int63.to_int_exn ~to_trunc:Int63.to_int_trunc; [%expect {| |}] ;; let%expect_test "nativeint <-> int63" = test_partial (module Native) (module I63) ~of_:Int63.of_nativeint ~of_exn:Int63.of_nativeint_exn ~of_trunc:Int63.of_nativeint_trunc ~to_:Int63.of_nativeint ~to_exn:Int63.of_nativeint_exn ~to_trunc:Int63.of_nativeint_trunc; [%expect {| |}]; test_partial (module I63) (module Native) ~of_:Int63.to_nativeint ~of_exn:Int63.to_nativeint_exn ~of_trunc:Int63.to_nativeint_trunc ~to_:Int63.to_nativeint ~to_exn:Int63.to_nativeint_exn ~to_trunc:Int63.to_nativeint_trunc; [%expect {| |}] ;; let%expect_test "int32 <-> int63" = test_total (module I32) (module I63) ~of_:Int63.of_int32 ~to_:Int63.of_int32; [%expect {| |}]; test_partial (module I63) (module I32) ~of_:Int63.to_int32 ~of_exn:Int63.to_int32_exn ~of_trunc:Int63.to_int32_trunc ~to_:Int63.to_int32 ~to_exn:Int63.to_int32_exn ~to_trunc:Int63.to_int32_trunc; [%expect {| |}] ;; let%expect_test "int64 <-> int63" = test_partial (module I64) (module I63) ~of_:Int63.of_int64 ~of_exn:Int63.of_int64_exn ~of_trunc:Int63.of_int64_trunc ~to_:Int63.of_int64 ~to_exn:Int63.of_int64_exn ~to_trunc:Int63.of_int64_trunc; [%expect {| |}]; test_total (module I63) (module I64) ~of_:Int63.to_int64 ~to_:Int63.to_int64; [%expect {| |}] ;; base-0.16.3/test/test_exported_int_conversions.mli000066400000000000000000000000551446274340700224030ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_float.ml000066400000000000000000001321611446274340700162070ustar00rootroot00000000000000open! Import open! Float open! Float.Private let%expect_test ("hash coherence" [@tags "64-bits-only"]) = check_hash_coherence [%here] (module Float) [ min_value; 0.; 37.; max_value ]; [%expect {| |}] ;; let%expect_test "of_string_opt" = print_s [%sexp (of_string_opt "1." : float option)]; [%expect "(1)"]; print_s [%sexp (of_string_opt "1.a" : float option)]; [%expect "()"]; print_s [%sexp (of_string_opt "1e10000" : float option)]; [%expect "(INF)"] ;; let exponent_bits = 11 let mantissa_bits = 52 let exponent_mask64 = Int64.(shift_left one exponent_bits - one) let exponent_mask = Int64.to_int_exn exponent_mask64 let mantissa_mask = Int63.(shift_left one mantissa_bits - one) let _mantissa_mask64 = Int63.to_int64 mantissa_mask let%test_unit "upper/lower_bound_for_int" = assert ( [%compare.equal: (int * t * t) list] ([ 8; 16; 31; 32; 52; 53; 54; 62; 63; 64 ] |> List.map ~f:(fun x -> x, lower_bound_for_int x, upper_bound_for_int x)) [ 8, -128.99999999999997, 127.99999999999999 ; 16, -32768.999999999993, 32767.999999999996 ; 31, -1073741824.9999998, 1073741823.9999999 ; 32, -2147483648.9999995, 2147483647.9999998 ; 52, -2251799813685248.5, 2251799813685247.8 ; 53, -4503599627370496., 4503599627370495.5 ; 54, -9007199254740992., 9007199254740991. ; 62, -2305843009213693952., 2305843009213693696. ; 63, -4611686018427387904., 4611686018427387392. ; 64, -9223372036854775808., 9223372036854774784. ]) ;; let%test_unit _ = (* on 64-bit platform ppx_hash hashes floats exactly the same as polymorphic hash *) match Word_size.word_size with | W32 -> () | W64 -> List.iter ~f:(fun float -> let hash1 = Stdlib.Hashtbl.hash float in let hash2 = [%hash: float] float in let hash3 = specialized_hash float in if not Int.(hash1 = hash2 && hash1 = hash3) then raise_s [%message "bad" (hash1 : Int.Hex.t) (hash2 : Int.Hex.t) (hash3 : Int.Hex.t)]) [ 0.926038888360971146; 34.1638588598232076 ] ;; let test_both_ways (a : t) (b : int64) = Int64.( = ) (to_int64_preserve_order_exn a) b && Float.( = ) (of_int64_preserve_order b) a ;; let%test _ = test_both_ways 0. 0L let%test _ = test_both_ways (-0.) 0L let%test _ = test_both_ways 1. Int64.(shift_left 1023L 52) let%test _ = test_both_ways (-2.) Int64.(neg (shift_left 1024L 52)) let%test _ = test_both_ways infinity Int64.(shift_left 2047L 52) let%test _ = test_both_ways neg_infinity Int64.(neg (shift_left 2047L 52)) let%test _ = one_ulp `Down infinity = max_finite_value let%test _ = is_nan (one_ulp `Up infinity) let%test _ = is_nan (one_ulp `Down neg_infinity) let%test _ = one_ulp `Up neg_infinity = ~-.max_finite_value (* Some tests to make sure that the compiler is generating code for handling subnormal numbers at runtime accurately. *) let x () = min_positive_subnormal_value let y () = min_positive_normal_value let%test _ = test_both_ways (x ()) 1L let%test _ = test_both_ways (y ()) Int64.(shift_left 1L 52) let%test _ = x () > 0. let%test_unit _ = [%test_result: float] (x () /. 2.) ~expect:0. let%test _ = one_ulp `Up 0. = x () let%test _ = one_ulp `Down 0. = ~-.(x ()) let are_one_ulp_apart a b = one_ulp `Up a = b let%test _ = are_one_ulp_apart (x ()) (2. *. x ()) let%test _ = are_one_ulp_apart (2. *. x ()) (3. *. x ()) let one_ulp_below_y () = y () -. x () let%test _ = one_ulp_below_y () < y () let%test _ = y () -. one_ulp_below_y () = x () let%test _ = are_one_ulp_apart (one_ulp_below_y ()) (y ()) let one_ulp_above_y () = y () +. x () let%test _ = y () < one_ulp_above_y () let%test _ = one_ulp_above_y () -. y () = x () let%test _ = are_one_ulp_apart (y ()) (one_ulp_above_y ()) let%test _ = not (are_one_ulp_apart (one_ulp_below_y ()) (one_ulp_above_y ())) (* [2 * min_positive_normal_value] is where the ulp increases for the first time. *) let z () = 2. *. y () let one_ulp_below_z () = z () -. x () let%test _ = one_ulp_below_z () < z () let%test _ = z () -. one_ulp_below_z () = x () let%test _ = are_one_ulp_apart (one_ulp_below_z ()) (z ()) let one_ulp_above_z () = z () +. (2. *. x ()) let%test _ = z () < one_ulp_above_z () let%test _ = one_ulp_above_z () -. z () = 2. *. x () let%test _ = are_one_ulp_apart (z ()) (one_ulp_above_z ()) let%test_module "clamp" = (module struct let%test _ = clamp_exn 1.0 ~min:2. ~max:3. = 2. let%test _ = clamp_exn 2.5 ~min:2. ~max:3. = 2.5 let%test _ = clamp_exn 3.5 ~min:2. ~max:3. = 3. let%test_unit "clamp" = [%test_result: float Or_error.t] (clamp 3.5 ~min:2. ~max:3.) ~expect:(Ok 3.) ;; let%test_unit "clamp nan" = [%test_result: float Or_error.t] (clamp nan ~min:2. ~max:3.) ~expect:(Ok nan) ;; let%test "clamp bad" = Or_error.is_error (clamp 2.5 ~min:3. ~max:2.) end) ;; let%test_unit _ = [%test_result: Int64.t] (Int64.bits_of_float 1.1235582092889474E+307) ~expect:0x7fb0000000000000L ;; let%test_module "IEEE" = (module struct (* Note: IEEE 754 defines NaN values to be those where the exponent is all 1s and the mantissa is nonzero. test_result sees nan values as equal because it is based on [compare] rather than [=]. (If [x] and [x'] are nan, [compare x x'] returns 0, whereas [x = x'] returns [false]. This is the case regardless of whether or not [x] and [x'] are bit-identical values of nan.) *) let f (t : t) (negative : bool) (exponent : int) (mantissa : Int63.t) : unit = let str = to_string t in let is_nan = is_nan t in (* the sign doesn't matter when nan *) if not is_nan then [%test_result: bool] ~message:("ieee_negative " ^ str) (ieee_negative t) ~expect:negative; [%test_result: int] ~message:("ieee_exponent " ^ str) (ieee_exponent t) ~expect:exponent; if is_nan then assert (Int63.(zero <> ieee_mantissa t)) else [%test_result: Int63.t] ~message:("ieee_mantissa " ^ str) (ieee_mantissa t) ~expect:mantissa; [%test_result: t] ~message: (Printf.sprintf !"create_ieee ~negative:%B ~exponent:%d ~mantissa:%{Int63}" negative exponent mantissa) (create_ieee_exn ~negative ~exponent ~mantissa) ~expect:t ;; let%test_unit _ = let ( !! ) x = Int63.of_int x in f zero false 0 !!0; f min_positive_subnormal_value false 0 !!1; f min_positive_normal_value false 1 !!0; f epsilon_float false Int.(1023 - mantissa_bits) !!0; f one false 1023 !!0; f minus_one true 1023 !!0; f max_finite_value false Int.(exponent_mask - 1) mantissa_mask; f infinity false exponent_mask !!0; f neg_infinity true exponent_mask !!0; f nan false exponent_mask !!1 ;; (* test the normalized case, that is, 1 <= exponent <= 2046 *) let%test_unit _ = let g ~negative ~exponent ~mantissa = assert ( create_ieee_exn ~negative ~exponent ~mantissa:(Int63.of_int64_exn mantissa) = (if negative then -1. else 1.) * (2. **. (Float.of_int exponent - 1023.)) * (1. + ((2. **. -52.) * Int64.to_float mantissa))) in g ~negative:false ~exponent:1 ~mantissa:147L; g ~negative:true ~exponent:137 ~mantissa:13L; g ~negative:false ~exponent:1015 ~mantissa:1370001L; g ~negative:true ~exponent:2046 ~mantissa:137000100945L ;; end) ;; let%test_module _ = (module struct let test f expect = let actual = to_padded_compact_string f in if String.(actual <> expect) then raise_s [%message "failure" (f : t) (expect : string) (actual : string)] ;; let both f expect = assert (f > 0.); test f expect; test ~-.f ("-" ^ expect) ;; let decr = one_ulp `Down let incr = one_ulp `Up let boundary f ~closer_to_zero ~at = assert (f > 0.); (* If [f] looks like an odd multiple of 0.05, it might be slightly under-represented as a float, e.g. 1. -. 0.95 = 0.0500000000000000444 In such case, sadly, the right way for [to_padded_compact_string], just as for [sprintf "%.1f"], is to round it down. However, the next representable number should be rounded up: # let x = 0.95 in sprintf "%.0f / %.1f / %.2f / %.3f / %.20f" x x x x x;; - : string = "1 / 0.9 / 0.95 / 0.950 / 0.94999999999999995559" # let x = incr 0.95 in sprintf "%.0f / %.1f / %.2f / %.3f / %.20f" x x x x x ;; - : string = "1 / 1.0 / 0.95 / 0.950 / 0.95000000000000006661" *) let f = if f >= 1000. then f else ( let x = Printf.sprintf "%.20f" f in let spot = String.index_exn x '.' in (* the following condition is only meant to work for small multiples of 0.05 *) let ( + ) = Int.( + ) in let ( = ) = Char.( = ) in if x.[spot + 2] = '4' && x.[spot + 3] = '9' && x.[spot + 4] = '9' then (* something like 0.94999999999999995559 *) incr f else f) in both (decr f) closer_to_zero; both f at ;; let%test_unit _ = test nan "nan " let%test_unit _ = test 0.0 "0 " let%test_unit _ = both min_positive_subnormal_value "0 " let%test_unit _ = both infinity "inf " let%test_unit _ = boundary 0.05 ~closer_to_zero:"0 " ~at:"0.1" let%test_unit _ = boundary 0.15 ~closer_to_zero:"0.1" ~at:"0.2" (* glibc printf resolves ties to even, cf. http://www.exploringbinary.com/inconsistent-rounding-of-printed-floating-point-numbers/ Ties are resolved differently in JavaScript - mark some tests as no running with JavaScript. *) let%test_unit (_ [@tags "no-js"]) = boundary (* tie *) 0.25 ~closer_to_zero:"0.2" ~at:"0.2" ;; let%test_unit (_ [@tags "no-js"]) = boundary (incr 0.25) ~closer_to_zero:"0.2" ~at:"0.3" ;; let%test_unit _ = boundary 0.35 ~closer_to_zero:"0.3" ~at:"0.4" let%test_unit _ = boundary 0.45 ~closer_to_zero:"0.4" ~at:"0.5" let%test_unit _ = both 0.50 "0.5" let%test_unit _ = boundary 0.55 ~closer_to_zero:"0.5" ~at:"0.6" let%test_unit _ = boundary 0.65 ~closer_to_zero:"0.6" ~at:"0.7" (* this time tie-to-even means round away from 0 *) let%test_unit _ = boundary (* tie *) 0.75 ~closer_to_zero:"0.7" ~at:"0.8" let%test_unit _ = boundary 0.85 ~closer_to_zero:"0.8" ~at:"0.9" let%test_unit _ = boundary 0.95 ~closer_to_zero:"0.9" ~at:"1 " let%test_unit _ = boundary 1.05 ~closer_to_zero:"1 " ~at:"1.1" let%test_unit (_ [@tags "no-js"]) = boundary 3.25 ~closer_to_zero:"3.2" ~at:"3.2" let%test_unit (_ [@tags "no-js"]) = boundary (incr 3.25) ~closer_to_zero:"3.2" ~at:"3.3" ;; let%test_unit _ = boundary 3.75 ~closer_to_zero:"3.7" ~at:"3.8" let%test_unit _ = boundary 9.95 ~closer_to_zero:"9.9" ~at:"10 " let%test_unit _ = boundary 10.05 ~closer_to_zero:"10 " ~at:"10.1" let%test_unit _ = boundary 100.05 ~closer_to_zero:"100 " ~at:"100.1" let%test_unit (_ [@tags "no-js"]) = boundary (* tie *) 999.25 ~closer_to_zero:"999.2" ~at:"999.2" ;; let%test_unit (_ [@tags "no-js"]) = boundary (incr 999.25) ~closer_to_zero:"999.2" ~at:"999.3" ;; let%test_unit _ = boundary 999.75 ~closer_to_zero:"999.7" ~at:"999.8" let%test_unit _ = boundary 999.95 ~closer_to_zero:"999.9" ~at:"1k " let%test_unit _ = both 1000. "1k " (* some ties which we resolve manually in [iround_ratio_exn] *) let%test_unit _ = boundary 1050. ~closer_to_zero:"1k " ~at:"1k " let%test_unit _ = boundary (incr 1050.) ~closer_to_zero:"1k " ~at:"1k1" let%test_unit _ = boundary 1950. ~closer_to_zero:"1k9" ~at:"2k " let%test_unit _ = boundary 3250. ~closer_to_zero:"3k2" ~at:"3k2" let%test_unit _ = boundary (incr 3250.) ~closer_to_zero:"3k2" ~at:"3k3" let%test_unit _ = boundary 9950. ~closer_to_zero:"9k9" ~at:"10k " let%test_unit _ = boundary 33_250. ~closer_to_zero:"33k2" ~at:"33k2" let%test_unit _ = boundary (incr 33_250.) ~closer_to_zero:"33k2" ~at:"33k3" let%test_unit _ = boundary 33_350. ~closer_to_zero:"33k3" ~at:"33k4" let%test_unit _ = boundary 33_750. ~closer_to_zero:"33k7" ~at:"33k8" let%test_unit _ = boundary 333_250. ~closer_to_zero:"333k2" ~at:"333k2" let%test_unit _ = boundary (incr 333_250.) ~closer_to_zero:"333k2" ~at:"333k3" let%test_unit _ = boundary 333_750. ~closer_to_zero:"333k7" ~at:"333k8" let%test_unit _ = boundary 999_850. ~closer_to_zero:"999k8" ~at:"999k8" let%test_unit _ = boundary (incr 999_850.) ~closer_to_zero:"999k8" ~at:"999k9" let%test_unit _ = boundary 999_950. ~closer_to_zero:"999k9" ~at:"1m " let%test_unit _ = boundary 1_050_000. ~closer_to_zero:"1m " ~at:"1m " let%test_unit _ = boundary (incr 1_050_000.) ~closer_to_zero:"1m " ~at:"1m1" let%test_unit _ = boundary 999_950_000. ~closer_to_zero:"999m9" ~at:"1g " let%test_unit _ = boundary 999_950_000_000. ~closer_to_zero:"999g9" ~at:"1t " let%test_unit _ = boundary 999_950_000_000_000. ~closer_to_zero:"999t9" ~at:"1p " let%test_unit _ = boundary 999_950_000_000_000_000. ~closer_to_zero:"999p9" ~at:"1.0e+18" ;; (* Test the boundary between the subnormals and the normals. *) let%test_unit _ = boundary min_positive_normal_value ~closer_to_zero:"0 " ~at:"0 " end) ;; let%test "int_pow" = let tol = 1e-15 in let test (x, n) = let reference_value = x **. of_int n in let relative_error = (int_pow x n -. reference_value) /. reference_value in abs relative_error < tol in List.for_all ~f:test [ 1.5, 17 ; 1.5, 42 ; 0.99, 64 ; 2., -5 ; 2., -1 ; -1.3, 2 ; -1.3, -1 ; -1.3, -2 ; 5., 0 ; nan, 0 ; 0., 0 ; infinity, 0 ] ;; let%test "int_pow misc" = int_pow 0. (-1) = infinity && int_pow (-0.) (-1) = neg_infinity && int_pow (-0.) (-2) = infinity && int_pow 1.5 5000 = infinity && int_pow 1.5 (-5000) = 0. && int_pow (-1.) Int.max_value = -1. && int_pow (-1.) Int.min_value = 1. ;; (* some ugly corner cases with extremely large exponents and some serious precision loss *) let%test ("int_pow bad cases" [@tags "64-bits-only"]) = let a = one_ulp `Down 1. in let b = one_ulp `Up 1. in let large = 1 lsl 61 in let small = Int.neg large in (* this huge discrepancy comes from the fact that [1 / a = b] but this is a very poor approximation, and in particular [1 / b = one_ulp `Down a = a * a]. *) a **. of_int small = 1.5114276650041252e+111 && int_pow a small = 2.2844048619719663e+222 && int_pow b large = 2.2844048619719663e+222 && b **. of_int large = 2.2844135865396268e+222 ;; let%test_unit "sign_exn" = List.iter ~f:(fun (input, expect) -> assert (Sign.equal (sign_exn input) expect)) [ 1e-30, Sign.Pos; -0., Zero; 0., Zero; neg_infinity, Neg ] ;; let%test _ = match sign_exn nan with | Neg | Zero | Pos -> false | exception _ -> true ;; let%test_unit "sign_or_nan" = List.iter ~f:(fun (input, expect) -> assert (Sign_or_nan.equal (sign_or_nan input) expect)) [ 1e-30, Sign_or_nan.Pos; -0., Zero; 0., Zero; neg_infinity, Neg; nan, Nan ] ;; let%test_module _ = (module struct (* Some of the following tests used to live in lib_test/core_float_test.ml. *) let () = Random.init 137 (* round: ... <-)[-><-)[-><-)[-><-)[-><-)[-><-)[-> ... ... -+-----+-----+-----+-----+-----+-----+- ... ... -3 -2 -1 0 1 2 3 ... so round x -. x should be in (-0.5,0.5] *) let round_test x = let y = round x in -0.5 < y -. x && y -. x <= 0.5 ;; let iround_up_vs_down_test x = let expected_difference = if Parts.fractional (modf x) = 0. then 0 else 1 in match iround_up x, iround_down x with | Some x, Some y -> Int.(x - y = expected_difference) | _, _ -> true ;; let test_all_six x ~specialized_iround ~specialized_iround_exn ~float_rounding ~dir ~validate = let result1 = iround x ~dir in let result2 = Option.try_with (fun () -> iround_exn x ~dir) in let result3 = specialized_iround x in let result4 = Option.try_with (fun () -> specialized_iround_exn x) in let result5 = Option.try_with (fun () -> Int.of_float (float_rounding x)) in let result6 = Option.try_with (fun () -> Int.of_float (round ~dir x)) in let ( = ) = Stdlib.( = ) in if result1 = result2 && result2 = result3 && result3 = result4 && result4 = result5 && result5 = result6 then validate result1 else false ;; (* iround ~dir:`Nearest built so this should always be true *) let iround_nearest_test x = test_all_six x ~specialized_iround:iround_nearest ~specialized_iround_exn:iround_nearest_exn ~float_rounding:round_nearest ~dir:`Nearest ~validate:(function | None -> true | Some y -> let y = of_int y in -0.5 < y -. x && y -. x <= 0.5) ;; (* iround_down: ... )[<---)[<---)[<---)[<---)[<---)[<---)[ ... ... -+-----+-----+-----+-----+-----+-----+- ... ... -3 -2 -1 0 1 2 3 ... so x -. iround_down x should be in [0,1) *) let iround_down_test x = test_all_six x ~specialized_iround:iround_down ~specialized_iround_exn:iround_down_exn ~float_rounding:round_down ~dir:`Down ~validate:(function | None -> true | Some y -> let y = of_int y in 0. <= x -. y && x -. y < 1.) ;; (* iround_up: ... ](--->](--->](--->](--->](--->](--->]( ... ... -+-----+-----+-----+-----+-----+-----+- ... ... -3 -2 -1 0 1 2 3 ... so iround_up x -. x should be in [0,1) *) let iround_up_test x = test_all_six x ~specialized_iround:iround_up ~specialized_iround_exn:iround_up_exn ~float_rounding:round_up ~dir:`Up ~validate:(function | None -> true | Some y -> let y = of_int y in 0. <= y -. x && y -. x < 1.) ;; (* iround_towards_zero: ... ](--->](--->](---><--->)[<---)[<---)[ ... ... -+-----+-----+-----+-----+-----+-----+- ... ... -3 -2 -1 0 1 2 3 ... so abs x -. abs (iround_towards_zero x) should be in [0,1) *) let iround_towards_zero_test x = test_all_six x ~specialized_iround:iround_towards_zero ~specialized_iround_exn:iround_towards_zero_exn ~float_rounding:round_towards_zero ~dir:`Zero ~validate:(function | None -> true | Some y -> let x = abs x in let y = abs (of_int y) in 0. <= x -. y && x -. y < 1. && (Sign.(sign_exn x = sign_exn y) || y = 0.0)) ;; (* Easy cases that used to live inline with the code above. *) let%test_unit _ = [%test_result: int option] (iround_up (-3.4)) ~expect:(Some (-3)) let%test_unit _ = [%test_result: int option] (iround_up 0.0) ~expect:(Some 0) let%test_unit _ = [%test_result: int option] (iround_up 3.4) ~expect:(Some 4) let%test_unit _ = [%test_result: int] (iround_up_exn (-3.4)) ~expect:(-3) let%test_unit _ = [%test_result: int] (iround_up_exn 0.0) ~expect:0 let%test_unit _ = [%test_result: int] (iround_up_exn 3.4) ~expect:4 let%test_unit _ = [%test_result: int option] (iround_down (-3.4)) ~expect:(Some (-4)) let%test_unit _ = [%test_result: int option] (iround_down 0.0) ~expect:(Some 0) let%test_unit _ = [%test_result: int option] (iround_down 3.4) ~expect:(Some 3) let%test_unit _ = [%test_result: int] (iround_down_exn (-3.4)) ~expect:(-4) let%test_unit _ = [%test_result: int] (iround_down_exn 0.0) ~expect:0 let%test_unit _ = [%test_result: int] (iround_down_exn 3.4) ~expect:3 let%test_unit _ = [%test_result: int option] (iround_towards_zero (-3.4)) ~expect:(Some (-3)) ;; let%test_unit _ = [%test_result: int option] (iround_towards_zero 0.0) ~expect:(Some 0) ;; let%test_unit _ = [%test_result: int option] (iround_towards_zero 3.4) ~expect:(Some 3) ;; let%test_unit _ = [%test_result: int] (iround_towards_zero_exn (-3.4)) ~expect:(-3) let%test_unit _ = [%test_result: int] (iround_towards_zero_exn 0.0) ~expect:0 let%test_unit _ = [%test_result: int] (iround_towards_zero_exn 3.4) ~expect:3 let%test_unit _ = [%test_result: int option] (iround_nearest (-3.6)) ~expect:(Some (-4)) ;; let%test_unit _ = [%test_result: int option] (iround_nearest (-3.5)) ~expect:(Some (-3)) ;; let%test_unit _ = [%test_result: int option] (iround_nearest (-3.4)) ~expect:(Some (-3)) ;; let%test_unit _ = [%test_result: int option] (iround_nearest 0.0) ~expect:(Some 0) let%test_unit _ = [%test_result: int option] (iround_nearest 3.4) ~expect:(Some 3) let%test_unit _ = [%test_result: int option] (iround_nearest 3.5) ~expect:(Some 4) let%test_unit _ = [%test_result: int option] (iround_nearest 3.6) ~expect:(Some 4) let%test_unit _ = [%test_result: int] (iround_nearest_exn (-3.6)) ~expect:(-4) let%test_unit _ = [%test_result: int] (iround_nearest_exn (-3.5)) ~expect:(-3) let%test_unit _ = [%test_result: int] (iround_nearest_exn (-3.4)) ~expect:(-3) let%test_unit _ = [%test_result: int] (iround_nearest_exn 0.0) ~expect:0 let%test_unit _ = [%test_result: int] (iround_nearest_exn 3.4) ~expect:3 let%test_unit _ = [%test_result: int] (iround_nearest_exn 3.5) ~expect:4 let%test_unit _ = [%test_result: int] (iround_nearest_exn 3.6) ~expect:4 let special_values_test () = [%test_result: float] (round (-1.50001)) ~expect:(-2.); [%test_result: float] (round (-1.5)) ~expect:(-1.); [%test_result: float] (round (-0.50001)) ~expect:(-1.); [%test_result: float] (round (-0.5)) ~expect:0.; [%test_result: float] (round 0.49999) ~expect:0.; [%test_result: float] (round 0.5) ~expect:1.; [%test_result: float] (round 1.49999) ~expect:1.; [%test_result: float] (round 1.5) ~expect:2.; [%test_result: int] (iround_exn ~dir:`Up (-2.)) ~expect:(-2); [%test_result: int] (iround_exn ~dir:`Up (-1.9999)) ~expect:(-1); [%test_result: int] (iround_exn ~dir:`Up (-1.)) ~expect:(-1); [%test_result: int] (iround_exn ~dir:`Up (-0.9999)) ~expect:0; [%test_result: int] (iround_exn ~dir:`Up 0.) ~expect:0; [%test_result: int] (iround_exn ~dir:`Up 0.00001) ~expect:1; [%test_result: int] (iround_exn ~dir:`Up 1.) ~expect:1; [%test_result: int] (iround_exn ~dir:`Up 1.00001) ~expect:2; [%test_result: int] (iround_up_exn (-2.)) ~expect:(-2); [%test_result: int] (iround_up_exn (-1.9999)) ~expect:(-1); [%test_result: int] (iround_up_exn (-1.)) ~expect:(-1); [%test_result: int] (iround_up_exn (-0.9999)) ~expect:0; [%test_result: int] (iround_up_exn 0.) ~expect:0; [%test_result: int] (iround_up_exn 0.00001) ~expect:1; [%test_result: int] (iround_up_exn 1.) ~expect:1; [%test_result: int] (iround_up_exn 1.00001) ~expect:2; [%test_result: int] (iround_exn ~dir:`Down (-1.00001)) ~expect:(-2); [%test_result: int] (iround_exn ~dir:`Down (-1.)) ~expect:(-1); [%test_result: int] (iround_exn ~dir:`Down (-0.00001)) ~expect:(-1); [%test_result: int] (iround_exn ~dir:`Down 0.) ~expect:0; [%test_result: int] (iround_exn ~dir:`Down 0.99999) ~expect:0; [%test_result: int] (iround_exn ~dir:`Down 1.) ~expect:1; [%test_result: int] (iround_exn ~dir:`Down 1.99999) ~expect:1; [%test_result: int] (iround_exn ~dir:`Down 2.) ~expect:2; [%test_result: int] (iround_down_exn (-1.00001)) ~expect:(-2); [%test_result: int] (iround_down_exn (-1.)) ~expect:(-1); [%test_result: int] (iround_down_exn (-0.00001)) ~expect:(-1); [%test_result: int] (iround_down_exn 0.) ~expect:0; [%test_result: int] (iround_down_exn 0.99999) ~expect:0; [%test_result: int] (iround_down_exn 1.) ~expect:1; [%test_result: int] (iround_down_exn 1.99999) ~expect:1; [%test_result: int] (iround_down_exn 2.) ~expect:2; [%test_result: int] (iround_exn ~dir:`Zero (-2.)) ~expect:(-2); [%test_result: int] (iround_exn ~dir:`Zero (-1.99999)) ~expect:(-1); [%test_result: int] (iround_exn ~dir:`Zero (-1.)) ~expect:(-1); [%test_result: int] (iround_exn ~dir:`Zero (-0.99999)) ~expect:0; [%test_result: int] (iround_exn ~dir:`Zero 0.99999) ~expect:0; [%test_result: int] (iround_exn ~dir:`Zero 1.) ~expect:1; [%test_result: int] (iround_exn ~dir:`Zero 1.99999) ~expect:1; [%test_result: int] (iround_exn ~dir:`Zero 2.) ~expect:2 ;; let is_64_bit_platform = of_int Int.max_value >= 2. **. 60. (* Tests for values close to [iround_lbound] and [iround_ubound]. *) let extremities_test ~round = let ( + ) = Int.( + ) in let ( - ) = Int.( - ) in if is_64_bit_platform then ( (* 64 bits *) [%test_result: int option] (round ((2.0 **. 62.) -. 512.)) ~expect:(Some (Int.max_value - 511)); [%test_result: int option] (round ((2.0 **. 62.) -. 1024.)) ~expect:(Some (Int.max_value - 1023)); [%test_result: int option] (round (-.(2.0 **. 62.))) ~expect:(Some Int.min_value); [%test_result: int option] (round (-.((2.0 **. 62.) -. 512.))) ~expect:(Some (Int.min_value + 512)); [%test_result: int option] (round (2.0 **. 62.)) ~expect:None; [%test_result: int option] (round (-.((2.0 **. 62.) +. 1024.))) ~expect:None) else ( let int_size_minus_one = of_int (Int.num_bits - 1) in (* 32 bits *) [%test_result: int option] (round ((2.0 **. int_size_minus_one) -. 1.)) ~expect:(Some Int.max_value); [%test_result: int option] (round ((2.0 **. int_size_minus_one) -. 2.)) ~expect:(Some (Int.max_value - 1)); [%test_result: int option] (round (-.(2.0 **. int_size_minus_one))) ~expect:(Some Int.min_value); [%test_result: int option] (round (-.((2.0 **. int_size_minus_one) -. 1.))) ~expect:(Some (Int.min_value + 1)); [%test_result: int option] (round (2.0 **. int_size_minus_one)) ~expect:None; [%test_result: int option] (round (-.((2.0 **. int_size_minus_one) +. 1.))) ~expect:None) ;; let%test_unit _ = extremities_test ~round:iround_down let%test_unit _ = extremities_test ~round:iround_up let%test_unit _ = extremities_test ~round:iround_nearest let%test_unit _ = extremities_test ~round:iround_towards_zero (* test values beyond the integers range *) let large_value_test x = [%test_result: int option] (iround_down x) ~expect:None; [%test_result: int option] (iround ~dir:`Down x) ~expect:None; [%test_result: int option] (iround_up x) ~expect:None; [%test_result: int option] (iround ~dir:`Up x) ~expect:None; [%test_result: int option] (iround_towards_zero x) ~expect:None; [%test_result: int option] (iround ~dir:`Zero x) ~expect:None; [%test_result: int option] (iround_nearest x) ~expect:None; [%test_result: int option] (iround ~dir:`Nearest x) ~expect:None; assert (Exn.does_raise (fun () -> iround_down_exn x)); assert (Exn.does_raise (fun () -> iround_exn ~dir:`Down x)); assert (Exn.does_raise (fun () -> iround_up_exn x)); assert (Exn.does_raise (fun () -> iround_exn ~dir:`Up x)); assert (Exn.does_raise (fun () -> iround_towards_zero_exn x)); assert (Exn.does_raise (fun () -> iround_exn ~dir:`Zero x)); assert (Exn.does_raise (fun () -> iround_nearest_exn x)); assert (Exn.does_raise (fun () -> iround_exn ~dir:`Nearest x)); [%test_result: float] (round_down x) ~expect:x; [%test_result: float] (round ~dir:`Down x) ~expect:x; [%test_result: float] (round_up x) ~expect:x; [%test_result: float] (round ~dir:`Up x) ~expect:x; [%test_result: float] (round_towards_zero x) ~expect:x; [%test_result: float] (round ~dir:`Zero x) ~expect:x; [%test_result: float] (round_nearest x) ~expect:x; [%test_result: float] (round ~dir:`Nearest x) ~expect:x ;; let large_numbers = let ( + ) = Int.( + ) in let ( - ) = Int.( - ) in List.concat (List.init (1024 - 64) ~f:(fun x -> let x = of_int (x + 64) in let y = [ 2. **. x ; (2. **. x) -. (2. **. (x -. 53.)) ; (* one ulp down *) (2. **. x) +. (2. **. (x -. 52.)) ] (* one ulp up *) in y @ List.map y ~f:neg)) @ [ infinity; neg_infinity ] ;; let%test_unit _ = List.iter large_numbers ~f:large_value_test let numbers_near_powers_of_two = List.concat (List.init 64 ~f:(fun i -> let pow2 = 2. **. of_int i in let x = [ pow2 ; one_ulp `Down (pow2 +. 0.5) ; pow2 +. 0.5 ; one_ulp `Down (pow2 +. 1.0) ; pow2 +. 1.0 ; one_ulp `Down (pow2 +. 1.5) ; pow2 +. 1.5 ; one_ulp `Down (pow2 +. 2.0) ; pow2 +. 2.0 ; one_ulp `Down ((pow2 *. 2.0) -. 1.0) ; one_ulp `Down pow2 ; one_ulp `Up pow2 ] in x @ List.map x ~f:neg)) ;; let%test _ = List.for_all numbers_near_powers_of_two ~f:iround_up_vs_down_test let%test _ = List.for_all numbers_near_powers_of_two ~f:iround_nearest_test let%test _ = List.for_all numbers_near_powers_of_two ~f:iround_down_test let%test _ = List.for_all numbers_near_powers_of_two ~f:iround_up_test let%test _ = List.for_all numbers_near_powers_of_two ~f:iround_towards_zero_test let%test _ = List.for_all numbers_near_powers_of_two ~f:round_test (* code for generating random floats on which to test functions *) let rec absirand () = let open Int.O in let rec aux acc cnt = if cnt = 0 then acc else ( let bit = if Random.bool () then 1 else 0 in aux ((2 * acc) + bit) (cnt - 1)) in let result = aux 0 (if is_64_bit_platform then 62 else 30) in if result >= Int.max_value - 255 then (* On a 64-bit box, [float x > Int.max_value] when [x >= Int.max_value - 255], so [iround (float x)] would be out of bounds. So we try again. This branch of code runs with probability 6e-17 :-) As such, we have some fixed tests in [extremities_test] above, to ensure that we do always check some examples in that range. *) absirand () else result ;; (* -Int.max_value <= frand () <= Int.max_value *) let frand () = let x = of_int (absirand ()) +. Random.float 1.0 in if Random.bool () then -1.0 *. x else x ;; let randoms = List.init ~f:(fun _ -> frand ()) 10_000 let%test _ = List.for_all randoms ~f:iround_up_vs_down_test let%test _ = List.for_all randoms ~f:iround_nearest_test let%test _ = List.for_all randoms ~f:iround_down_test let%test _ = List.for_all randoms ~f:iround_up_test let%test _ = List.for_all randoms ~f:iround_towards_zero_test let%test _ = List.for_all randoms ~f:round_test let%test_unit _ = special_values_test () let%test _ = iround_nearest_test (of_int Int.max_value) let%test _ = iround_nearest_test (of_int Int.min_value) end) ;; module Test_bounds (I : sig type t val num_bits : int val of_float : float -> t val to_int64 : t -> Int64.t val max_value : t val min_value : t end) = struct open I let float_lower_bound = lower_bound_for_int num_bits let float_upper_bound = upper_bound_for_int num_bits let%test_unit "lower bound is valid" = ignore (of_float float_lower_bound : t) let%test_unit "upper bound is valid" = ignore (of_float float_upper_bound : t) let%test "smaller than lower bound is not valid" = Exn.does_raise (fun () -> of_float (one_ulp `Down float_lower_bound)) ;; let%test "bigger than upper bound is not valid" = Exn.does_raise (fun () -> of_float (one_ulp `Up float_upper_bound)) ;; (* We use [Caml.Int64.of_float] in the next two tests because [Int64.of_float] rejects out-of-range inputs, whereas [Caml.Int.of_float] simply overflows (returns [Int64.min_int]). *) let%test "smaller than lower bound overflows" = let lower_bound = Int64.of_float float_lower_bound in let lower_bound_minus_epsilon = Stdlib.Int64.of_float (one_ulp `Down float_lower_bound) in let min_value = to_int64 min_value in if Int.( = ) num_bits 64 (* We cannot detect overflow because on Intel overflow results in min_value. *) then true else ( assert (Int64.( <= ) lower_bound_minus_epsilon lower_bound); (* a value smaller than min_value would overflow if converted to [t] *) Int64.( < ) lower_bound_minus_epsilon min_value) ;; let%test "bigger than upper bound overflows" = let upper_bound = Int64.of_float float_upper_bound in let upper_bound_plus_epsilon = Stdlib.Int64.of_float (one_ulp `Up float_upper_bound) in let max_value = to_int64 max_value in if Int.( = ) num_bits 64 (* upper_bound_plus_epsilon is not representable as a Int64.t, it has overflowed *) then Int64.( < ) upper_bound_plus_epsilon upper_bound else ( assert (Int64.( >= ) upper_bound_plus_epsilon upper_bound); (* a value greater than max_value would overflow if converted to [t] *) Int64.( > ) upper_bound_plus_epsilon max_value) ;; end let%test_module "Int" = (module Test_bounds (Int)) let%test_module "Int32" = (module Test_bounds (Int32)) let%test_module "Int63" = (module Test_bounds (Int63)) let%test_module "Int63_emul" = (module Test_bounds (Base.Int63.Private.Emul)) let%test_module "Int64" = (module Test_bounds (Int64)) let%test_module "Nativeint" = (module Test_bounds (Nativeint)) let%test_unit _ = [%test_result: string] (to_string 3.14) ~expect:"3.14" let%test_unit _ = [%test_result: string] (to_string 3.1400000000000001) ~expect:"3.14" let%test_unit _ = [%test_result: string] (to_string 3.1400000000000004) ~expect:"3.1400000000000006" ;; let%test_unit _ = [%test_result: string] (to_string 8.000000000000002) ~expect:"8.0000000000000018" ;; let%test_unit _ = [%test_result: string] (to_string 9.992) ~expect:"9.992" let%test_unit _ = [%test_result: string] (to_string ((2. **. 63.) *. (1. +. (2. **. -52.)))) ~expect:"9.2233720368547779e+18" ;; let%test_unit _ = [%test_result: string] (to_string (-3.)) ~expect:"-3." let%test_unit _ = [%test_result: string] (to_string nan) ~expect:"nan" let%test_unit _ = [%test_result: string] (to_string infinity) ~expect:"inf" let%test_unit _ = [%test_result: string] (to_string neg_infinity) ~expect:"-inf" let%test_unit _ = [%test_result: string] (to_string 3e100) ~expect:"3e+100" let%test_unit _ = [%test_result: string] (to_string max_finite_value) ~expect:"1.7976931348623157e+308" ;; let%test_unit _ = [%test_result: string] (to_string min_positive_subnormal_value) ~expect:"4.94065645841247e-324" ;; let%test _ = epsilon_float = one_ulp `Up 1. -. 1. let%test _ = one_ulp_less_than_half = 0.49999999999999994 let%test _ = round_down 3.6 = 3. && round_down (-3.6) = -4. let%test _ = round_up 3.6 = 4. && round_up (-3.6) = -3. let%test _ = round_towards_zero 3.6 = 3. && round_towards_zero (-3.6) = -3. let%test _ = round_nearest_half_to_even 0. = 0. let%test _ = round_nearest_half_to_even 0.5 = 0. let%test _ = round_nearest_half_to_even (-0.5) = 0. let%test _ = round_nearest_half_to_even (one_ulp `Up 0.5) = 1. let%test _ = round_nearest_half_to_even (one_ulp `Down 0.5) = 0. let%test _ = round_nearest_half_to_even (one_ulp `Up (-0.5)) = 0. let%test _ = round_nearest_half_to_even (one_ulp `Down (-0.5)) = -1. let%test _ = round_nearest_half_to_even 3.5 = 4. let%test _ = round_nearest_half_to_even 4.5 = 4. let%test _ = round_nearest_half_to_even (one_ulp `Up (-5.5)) = -5. let%test _ = round_nearest_half_to_even 5.5 = 6. let%test _ = round_nearest_half_to_even 6.5 = 6. let%test _ = round_nearest_half_to_even (one_ulp `Up (-.(2. **. 52.))) = -.(2. **. 52.) let%test _ = round_nearest (one_ulp `Up (-.(2. **. 52.))) = 1. -. (2. **. 52.) let%test _ = is_integer 1. let%test _ = is_integer 0. let%test _ = is_integer (-0.) let%test _ = is_integer (-1.) let%test _ = is_integer 8.98e307 let%test _ = is_integer ((2. ** 53.) -. 0.5) let%test _ = not (is_integer ((2. ** 52.) -. 0.5)) let%test _ = not (is_integer 0.0000000000000001) let%test _ = not (is_integer (-0.0000000000000001)) let%test _ = not (is_integer 0.9999999999999999) let%test _ = not (is_integer nan) let%test _ = not (is_integer infinity) let%test _ = not (is_integer neg_infinity) let%test_module _ = (module struct (* check we raise on invalid input *) let must_fail f x = Exn.does_raise (fun () -> f x) let must_succeed f x = ignore (f x : _); true ;; let%test _ = must_fail int63_round_nearest_portable_alloc_exn nan let%test _ = must_fail int63_round_nearest_portable_alloc_exn max_value let%test _ = must_fail int63_round_nearest_portable_alloc_exn min_value let%test _ = must_fail int63_round_nearest_portable_alloc_exn (2. **. 63.) let%test _ = must_fail int63_round_nearest_portable_alloc_exn ~-.(2. **. 63.) let%test _ = must_succeed int63_round_nearest_portable_alloc_exn ((2. **. 62.) -. 512.) let%test _ = must_fail int63_round_nearest_portable_alloc_exn (2. **. 62.) let%test _ = must_fail int63_round_nearest_portable_alloc_exn (~-.(2. **. 62.) -. 1024.) ;; let%test _ = must_succeed int63_round_nearest_portable_alloc_exn ~-.(2. **. 62.) end) ;; let%test _ = round_nearest 3.6 = 4. && round_nearest (-3.6) = -4. (* The redefinition of [sexp_of_t] in float.ml assumes sexp conversion uses E rather than e. *) let%test_unit "e vs E" = [%test_result: Sexp.t] [%sexp (1.4e100 : t)] ~expect:(Atom "1.4E+100") ;; let%test_module _ = (module struct let test ?delimiter ~decimals f s s_strip_zero = let s' = to_string_hum ?delimiter ~decimals ~strip_zero:false f in if String.(s' <> s) then raise_s [%message "to_string_hum ~strip_zero:false" ~input:(f : float) (decimals : int) ~got:(s' : string) ~expected:(s : string)]; let s_strip_zero' = to_string_hum ?delimiter ~decimals ~strip_zero:true f in if String.(s_strip_zero' <> s_strip_zero) then raise_s [%message "to_string_hum ~strip_zero:true" ~input:(f : float) (decimals : int) ~got:(s_strip_zero : string) ~expected:(s_strip_zero' : string)] ;; let%test_unit _ = test ~decimals:3 0.99999 "1.000" "1" let%test_unit _ = test ~decimals:3 0.00001 "0.000" "0" let%test_unit _ = test ~decimals:3 ~-.12345.1 "-12_345.100" "-12_345.1" let%test_unit _ = test ~delimiter:',' ~decimals:3 ~-.12345.1 "-12,345.100" "-12,345.1" let%test_unit _ = test ~decimals:0 0.99999 "1" "1" let%test_unit _ = test ~decimals:0 0.00001 "0" "0" let%test_unit _ = test ~decimals:0 ~-.12345.1 "-12_345" "-12_345" let%test_unit _ = test ~decimals:0 (5.0 /. 0.0) "inf" "inf" let%test_unit _ = test ~decimals:0 (-5.0 /. 0.0) "-inf" "-inf" let%test_unit _ = test ~decimals:0 (0.0 /. 0.0) "nan" "nan" let%test_unit _ = test ~decimals:2 (5.0 /. 0.0) "inf" "inf" let%test_unit _ = test ~decimals:2 (-5.0 /. 0.0) "-inf" "-inf" let%test_unit _ = test ~decimals:2 (0.0 /. 0.0) "nan" "nan" let%test_unit _ = test ~decimals:5 (10_000.0 /. 3.0) "3_333.33333" "3_333.33333" let%test_unit _ = test ~decimals:2 ~-.0.00001 "-0.00" "-0" let rand_test n = let go () = let f = Random.float 1_000_000.0 -. 500_000.0 in let repeatable to_str = let s = to_str f in if String.( <> ) (String.split s ~on:',' |> String.concat |> of_string |> to_str) s then raise_s [%message "failed" (f : t)] in repeatable (to_string_hum ~decimals:3 ~strip_zero:false) in try for _ = 0 to Int.( - ) n 1 do go () done; true with | e -> eprintf "%s\n%!" (Exn.to_string e); false ;; let%test _ = rand_test 10_000 end) ;; let%test_module "Hexadecimal syntax" = (module struct let should_fail str = Exn.does_raise (fun () -> Stdlib.float_of_string str) let test_equal str g = Stdlib.float_of_string str = g let%test _ = should_fail "0x" let%test _ = should_fail "0x.p0" let%test _ = test_equal "0x0" 0. let%test _ = test_equal "0x1.b7p-1" 0.857421875 let%test _ = test_equal "0x1.999999999999ap-4" 0.1 end) ;; let%expect_test "square" = printf "%f\n" (square 1.5); printf "%f\n" (square (-2.5)); [%expect {| 2.250000 6.250000 |}] ;; let%expect_test "mathematical constants" = (* Compare to the from-string conversion of numbers from Wolfram Alpha *) let eq x s = assert (x = of_string s) in eq pi "3.141592653589793238462643383279502884197169399375105820974"; eq sqrt_pi "1.772453850905516027298167483341145182797549456122387128213"; eq sqrt_2pi "2.506628274631000502415765284811045253006986740609938316629"; eq euler "0.577215664901532860606512090082402431042159335939923598805"; (* Check size of diff from ordinary computation. *) printf "sqrt pi diff : %.20f\n" (sqrt_pi - sqrt pi); printf "sqrt 2pi diff : %.20f\n" (sqrt_2pi - sqrt (2. * pi)); [%expect {| sqrt pi diff : 0.00000000000000022204 sqrt 2pi diff : 0.00000000000000044409 |}] ;; let%test _ = not (is_negative Float.nan) let%test _ = not (is_non_positive Float.nan) let%test _ = is_non_negative (-0.) let%test_unit "int to float conversion consistency" = let test_int63 x = [%test_result: float] (Float.of_int63 x) ~expect:(Float.of_int64 (Int63.to_int64 x)) in let test_int x = [%test_result: float] (Float.of_int x) ~expect:(Float.of_int63 (Int63.of_int x)); test_int63 (Int63.of_int x) in test_int 0; test_int 35; test_int (-1); test_int Int.max_value; test_int Int.min_value; test_int63 Int63.zero; test_int63 Int63.min_value; test_int63 Int63.max_value; let rand = Random.State.make [| Hashtbl.hash "int to float conversion consistency" |] in for _i = 0 to 100 do let x = Random.State.int rand Int.max_value in test_int x done; () ;; let%expect_test "min and max" = let nan = Float.nan in let inf = Float.infinity in let ninf = Float.neg_infinity in List.iter [ 0.1, 0.3; 71., -7.; nan, 0.3; nan, ninf; nan, inf; nan, nan; ninf, inf; 0., -0. ] ~f:(fun (a, b) -> printf "%5g%5g%5g%5g%5g%5g\n" a b (Float.min a b) (Float.min b a) (Float.max a b) (Float.max b a)); [%expect {| 0.1 0.3 0.1 0.1 0.3 0.3 71 -7 -7 -7 71 71 nan 0.3 nan nan nan nan nan -inf nan nan nan nan nan inf nan nan nan nan nan nan nan nan nan nan -inf inf -inf -inf inf inf 0 -0 -0 0 -0 0 |}] ;; let%expect_test "is_nan, is_inf, and is_finite" = List.iter ~f:(fun x -> printf !"%24s %5s %5s %5s\n" (to_string x) (Bool.to_string (is_nan x)) (Bool.to_string (is_inf x)) (Bool.to_string (is_finite x))) [ nan ; neg_infinity ; -.max_finite_value ; -1. ; -.min_positive_subnormal_value ; -0. ; 0. ; min_positive_subnormal_value ; 1. ; max_finite_value ; infinity ]; [%expect {| nan true false false -inf false true false -1.7976931348623157e+308 false false true -1. false false true -4.94065645841247e-324 false false true -0. false false true 0. false false true 4.94065645841247e-324 false false true 1. false false true 1.7976931348623157e+308 false false true inf false true false |}] ;; let%expect_test "nan" = require [%here] (Float.is_nan (Float.min 1. Float.nan)); require [%here] (Float.is_nan (Float.min Float.nan 0.)); require [%here] (Float.is_nan (Float.min Float.nan Float.nan)); require [%here] (Float.is_nan (Float.max 1. Float.nan)); require [%here] (Float.is_nan (Float.max Float.nan 0.)); require [%here] (Float.is_nan (Float.max Float.nan Float.nan)); require_equal [%here] (module Float) 1. (Float.min_inan 1. Float.nan); require_equal [%here] (module Float) 0. (Float.min_inan Float.nan 0.); require [%here] (Float.is_nan (Float.min_inan Float.nan Float.nan)); require_equal [%here] (module Float) 1. (Float.max_inan 1. Float.nan); require_equal [%here] (module Float) 0. (Float.max_inan Float.nan 0.); require [%here] (Float.is_nan (Float.max_inan Float.nan Float.nan)) ;; let%expect_test "iround_exn" = require_equal [%here] (module Int) 0 (Float.iround_exn ~dir:`Nearest 0.2); require_equal [%here] (module Int) 0 (Float.iround_exn ~dir:`Nearest (-0.2)); require_equal [%here] (module Int) 3 (Float.iround_exn ~dir:`Nearest 3.4); require_equal [%here] (module Int) (-3) (Float.iround_exn ~dir:`Nearest (-3.4)) ;; base-0.16.3/test/test_float.mli000066400000000000000000000000551446274340700163540ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_fn.ml000066400000000000000000000006071446274340700155040ustar00rootroot00000000000000open! Import open! Fn (* enforce that we're testing [Fn.(|>)] and not ppx_pipebang. *) let (_ : 'a -> ('a -> 'b) -> 'b) = ( |> ) let%test _ = 1 |> fun x -> x = 1 let%test _ = 1 |> fun x -> x + 1 |> fun y -> y = 2 let%test _ = 0 = apply_n_times ~n:0 (fun _ -> assert false) 0 let%test _ = 0 = apply_n_times ~n:(-3) (fun _ -> assert false) 0 let%test _ = 10 = apply_n_times ~n:10 (( + ) 1) 0 base-0.16.3/test/test_fn.mli000066400000000000000000000000551446274340700156520ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_fn_local.mlt000066400000000000000000000015621446274340700170430ustar00rootroot00000000000000open Base (* [id] can operate on global arguments *) let f : 'a. 'a -> 'a = Fn.id [%%expect {||}] (* [id] can operate on local arguments *) let f : 'a. ('a[@local]) -> ('a[@local]) = Fn.id [%%expect {||}] (* [id] cannot make a local argument global; this would be unsound *) let f : 'a. ('a[@local]) -> 'a = Fn.id [%%expect {| Line _, characters _-_: Error: This expression has type local_ 'b -> local_ 'b but an expression was expected of type local_ 'a -> 'a |}] (* [id] cannot make a global argument local; this is unexpected. If this following code gets accepted, it means that the meaning of [@local_opt] may have changed. However, the [f] below is not unsound. *) let f : 'a. 'a -> ('a[@local]) = Fn.id [%%expect {| Line _, characters _-_: Error: This expression has type 'b -> 'b but an expression was expected of type 'a -> local_ 'a |}] base-0.16.3/test/test_globalize_lib.ml000066400000000000000000000051561446274340700177030ustar00rootroot00000000000000open! Core open! Import let%expect_test "bool_true" = printf "%b" (globalize_bool true); [%expect {| true |}] ;; let%expect_test "bool_false" = printf "%b" (globalize_bool false); [%expect {| false |}] ;; let%expect_test "char" = let c = 'A' in let c' = globalize_char c in printf "%s" (Char.to_string c'); [%expect {| A |}] ;; let%expect_test "float" = let f = 5.5 in let f' = globalize_float f in printf "%f" f'; [%expect {| 5.500000 |}] ;; let%expect_test "int" = printf "%d" (globalize_int 42); [%expect {| 42 |}] ;; let%expect_test "int32" = let i = 42l in let i' = globalize_int32 i in printf "%ld" i'; [%expect {| 42 |}] ;; let%expect_test "int64" = let i = 42L in let i' = globalize_int64 i in printf "%Ld" i'; [%expect {| 42 |}] ;; let%expect_test "nativeint" = let i = 42n in let i' = globalize_nativeint i in printf "%nd" i'; [%expect {| 42 |}] ;; let%expect_test "string" = let s = "hello" in let s' = globalize_string s in printf "%s" s'; [%expect {| hello |}] ;; let%expect_test "array" = let a = [| "one"; "two"; "three" |] in let a' = globalize_array globalize_string a in Array.iter ~f:print_endline a'; [%expect {| one two three |}] ;; let%expect_test "list" = let l = [ "one"; "two"; "three" ] in let l' = globalize_list globalize_string l in List.iter ~f:print_endline l'; [%expect {| one two three |}] ;; let%expect_test "option" = let o = (Some "hello") in let o' = globalize_option globalize_string o in Option.iter ~f:print_endline o'; [%expect {| hello |}] ;; let%expect_test "ref" = let r = (ref "hello") in let r' = globalize_ref globalize_string r in print_endline !r'; [%expect {| hello |}] ;; let%expect_test "no sharing between globalized refs" = let r = (ref "initial") in let r' = globalize_ref (fun _ -> assert false) r in print_endline !r; [%expect {| initial |}]; print_endline !r'; [%expect {| initial |}]; r := "local"; r' := "global"; print_endline !r; [%expect {| local |}]; print_endline !r'; [%expect {| global |}] ;; external get : ('a array[@local]) -> int -> 'a = "%array_safe_get" external set : ('a array[@local]) -> int -> 'a -> unit = "%array_safe_set" let%expect_test "no sharing between globalized arrays" = let a = [| "initial" |] in let a' = globalize_array (fun _ -> assert false) a in print_endline (get a 0); [%expect {| initial |}]; print_endline (get a' 0); [%expect {| initial |}]; set a 0 "local"; set a' 0 "global"; print_endline (get a 0); [%expect {| local |}]; print_endline (get a' 0); [%expect {| global |}] ;; base-0.16.3/test/test_globalize_lib.mli000066400000000000000000000000331446274340700200410ustar00rootroot00000000000000(*_ Intentionally blank *) base-0.16.3/test/test_hash_set.ml000066400000000000000000000066341446274340700167050ustar00rootroot00000000000000open! Import open! Hash_set let%test_module "Set Intersection" = (module struct let run_test first_contents second_contents ~expect = let of_list lst = let s = create (module String) in List.iter lst ~f:(add s); s in let s1 = of_list first_contents in let s2 = of_list second_contents in let expect = of_list expect in let result = inter s1 s2 in iter result ~f:(fun x -> assert (mem expect x)); iter expect ~f:(fun x -> assert (mem result x)); let equal x y = 0 = String.compare x y in assert (List.equal equal (to_list result) (to_list expect)); assert (length result = length expect); (* Make sure the sets are unmodified by the inter *) assert (List.length first_contents = length s1); assert (List.length second_contents = length s2) ;; let%test_unit "First smaller" = run_test [ "0"; "3"; "99" ] [ "0"; "1"; "2"; "3" ] ~expect:[ "0"; "3" ] ;; let%test_unit "Second smaller" = run_test [ "a"; "b"; "c"; "d" ] [ "b"; "d" ] ~expect:[ "b"; "d" ] ;; let%test_unit "No intersection" = run_test ~expect:[] [ "a"; "b"; "c"; "d" ] [ "1"; "2"; "3"; "4" ] ;; end) ;; let%expect_test "sexp" = let ints = List.init 20 ~f:(fun x -> x * x) in let int_hash_set = Hash_set.of_list (module Int) ints in print_s [%sexp (int_hash_set : int Hash_set.t)]; [%expect {| (0 1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361) |}]; let strs = List.init 20 ~f:(fun x -> Int.to_string x) in let str_hash_set = Hash_set.of_list (module String) strs in print_s [%sexp (str_hash_set : string Hash_set.t)]; [%expect {| (0 1 10 11 12 13 14 15 16 17 18 19 2 3 4 5 6 7 8 9) |}] ;; let%expect_test "to_array" = let empty_array = to_array (Hash_set.of_list (module Int) []) in print_s [%sexp (empty_array : int Array.t)]; [%expect {| () |}]; let array_from_to_array = to_array (Hash_set.of_list (module Int) [ 1; 2; 3; 4; 5 ]) in print_s [%sexp (array_from_to_array : int Array.t)]; [%expect {| (1 3 2 4 5) |}]; let array_via_to_list = to_list (Hash_set.of_list (module Int) [ 1; 2; 3; 4; 5 ]) |> Array.of_list in print_s [%sexp (array_via_to_list : int Array.t)]; [%expect {| (1 3 2 4 5) |}] ;; let%expect_test "union" = let print_union s1 s2 = let s1 = Hash_set.of_list (module Int) s1 in let s2 = Hash_set.of_list (module Int) s2 in print_s [%sexp (Hash_set.union s1 s2 : int Hash_set.t)] in print_union [ 0; 1; 2 ] [ 3; 4; 5 ]; [%expect {| (0 1 2 3 4 5) |}]; print_union [ 0; 1; 2 ] [ 1; 2; 3 ]; [%expect {| (0 1 2 3) |}] ;; let%expect_test "deriving equal" = let module Hs = struct type t = { hs : Hash_set.M(Int).t } [@@deriving equal] let of_list lst = { hs = Hash_set.of_list (module Int) lst } end in require [%here] (Hs.equal (Hs.of_list []) (Hs.of_list [])); require [%here] (not (Hs.equal (Hs.of_list [ 1 ]) (Hs.of_list []))); require [%here] (not (Hs.equal (Hs.of_list [ 1 ]) (Hs.of_list [ 2 ]))); require [%here] (Hs.equal (Hs.of_list [ 1 ]) (Hs.of_list [ 1 ])) ;; (* This module exists to check, at compile-time, that [Creators] is a subset of [Creators_generic]. *) module _ (M : Creators) : Creators_generic with type 'a t := 'a M.t with type 'a elt := 'a with type ('a, 'z) create_options := ('a, 'z) create_options = struct include M let create ?growth_allowed ?size m () = create ?growth_allowed ?size m end base-0.16.3/test/test_hash_set.mli000066400000000000000000000000551446274340700170450ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_hashtbl.ml000066400000000000000000000104321446274340700165230ustar00rootroot00000000000000open! Base open Expect_test_helpers_base type int_hashtbl = int Hashtbl.M(Int).t [@@deriving sexp] let%test "Hashtbl.merge succeeds with first-class-module interface" = let t1 = Hashtbl.create (module Int) in let t2 = Hashtbl.create (module Int) in let result = Hashtbl.merge t1 t2 ~f:(fun ~key:_ -> function | `Left x -> x | `Right x -> x | `Both _ -> assert false) |> Hashtbl.to_alist in List.equal Poly.equal result [] ;; let%test_module _ = (module Hashtbl_tests.Make (struct include Hashtbl let create_poly ?size () = Poly.create ?size () let of_alist_poly_exn l = Poly.of_alist_exn l let of_alist_poly_or_error l = Poly.of_alist_or_error l end)) ;; let%expect_test "Hashtbl.find_exn" = let table = Hashtbl.of_alist_exn (module String) [ "one", 1; "two", 2; "three", 3 ] in let test_success key = require_does_not_raise [%here] (fun () -> print_s [%sexp (Hashtbl.find_exn table key : int)]) in test_success "one"; [%expect {| 1 |}]; test_success "two"; [%expect {| 2 |}]; test_success "three"; [%expect {| 3 |}]; let test_failure key = require_does_raise [%here] (fun () -> Hashtbl.find_exn table key) in test_failure "zero"; [%expect {| (Not_found_s ("Hashtbl.find_exn: not found" zero)) |}]; test_failure "four"; [%expect {| (Not_found_s ("Hashtbl.find_exn: not found" four)) |}] ;; let%expect_test "[t_of_sexp] error on duplicate" = let sexp = Sexplib.Sexp.of_string "((0 a)(1 b)(2 c)(1 d))" in (match [%of_sexp: string Hashtbl.M(String).t] sexp with | t -> print_cr [%here] [%message "did not raise" (t : string Hashtbl.M(String).t)] | exception (Sexp.Of_sexp_error _ as exn) -> print_s (sexp_of_exn exn) | exception exn -> print_cr [%here] [%message "wrong kind of exception" (exn : exn)]); [%expect {| (Of_sexp_error "Hashtbl.t_of_sexp: duplicate key" (invalid_sexp 1)) |}] ;; let%expect_test "[choose], [choose_exn], [choose_randomly], [choose_randomly_exn]" = let test ?size l = let t = l |> List.map ~f:(fun i -> i, i) |> Hashtbl.of_alist_exn ?size (module Int) in print_s [%message "" ~input:(t : int_hashtbl) ~choose:(Hashtbl.choose t : (_ * _) option) ~choose_exn: (Or_error.try_with (fun () -> Hashtbl.choose_exn t) : (_ * _) Or_error.t) ~choose_randomly:(Hashtbl.choose_randomly t : (_ * _) option) ~choose_randomly_exn: (Or_error.try_with (fun () -> Hashtbl.choose_randomly_exn t) : (_ * _) Or_error.t)] in test []; [%expect {| ((input ()) (choose ()) (choose_exn (Error ("[Hashtbl.choose_exn] of empty hashtbl"))) (choose_randomly ()) (choose_randomly_exn ( Error ("[Hashtbl.choose_randomly_exn] of empty hashtbl")))) |}]; test [] ~size:100; [%expect {| ((input ()) (choose ()) (choose_exn (Error ("[Hashtbl.choose_exn] of empty hashtbl"))) (choose_randomly ()) (choose_randomly_exn ( Error ("[Hashtbl.choose_randomly_exn] of empty hashtbl")))) |}]; test [ 1 ]; [%expect {| ((input ((1 1))) (choose ((_ _))) (choose_exn (Ok (_ _))) (choose_randomly ((_ _))) (choose_randomly_exn (Ok (_ _)))) |}]; test [ 1 ] ~size:100; [%expect {| ((input ((1 1))) (choose ((_ _))) (choose_exn (Ok (_ _))) (choose_randomly ((_ _))) (choose_randomly_exn (Ok (_ _)))) |}]; test [ 1; 2 ]; [%expect {| ((input ( (1 1) (2 2))) (choose ((_ _))) (choose_exn (Ok (_ _))) (choose_randomly ((_ _))) (choose_randomly_exn (Ok (_ _)))) |}]; test [ 1; 2 ] ~size:100; [%expect {| ((input ( (1 1) (2 2))) (choose ((_ _))) (choose_exn (Ok (_ _))) (choose_randomly ((_ _))) (choose_randomly_exn (Ok (_ _)))) |}] ;; let%expect_test "update_and_return" = let t = Hashtbl.create (module String) in let update_and_return str ~f = let x = Hashtbl.update_and_return t str ~f in print_s [%message (t : (string, int) Hashtbl.t) (x : int)] in update_and_return "foo" ~f:(function | None -> 1 | Some _ -> failwith "no"); [%expect {| ((t ((foo 1))) (x 1)) |}]; update_and_return "foo" ~f:(function | Some 1 -> 2 | _ -> failwith "no"); [%expect {| ((t ((foo 2))) (x 2)) |}] ;; base-0.16.3/test/test_hashtbl.mli000066400000000000000000000000551446274340700166740ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_identifiable.ml000066400000000000000000000005141446274340700175150ustar00rootroot00000000000000open! Import open! Identifiable module T = struct type t = string include Make (struct let module_name = "test" include String end) end let%expect_test ("hash coherence" [@tags "64-bits-only"]) = check_hash_coherence [%here] (module T) ([ ""; "a"; "foo" ] |> List.map ~f:T.of_string); [%expect {| |}] ;; base-0.16.3/test/test_identifiable.mli000066400000000000000000000000551446274340700176660ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_indexed_container.ml000066400000000000000000000072161446274340700205660ustar00rootroot00000000000000open! Import module type S = Indexed_container.S1 with type 'a t = 'a list module This_list : S = struct include List include Indexed_container.Make (struct type 'a t = 'a list let fold = List.fold let iter = `Custom List.iter let length = `Custom List.length let foldi = `Define_using_fold let iteri = `Define_using_fold end) end module That_list : S = List let examples = [ []; [ 1 ]; [ 2; 3 ]; [ 4; 5; 1 ]; List.init 8 ~f:(fun i -> i * i) ] module type Output = sig type t [@@deriving compare, sexp_of] end module Int_list = struct type t = int list [@@deriving compare, sexp_of] end module Int_pair_option = struct type t = (int * int) option [@@deriving compare, sexp_of] end module Int_option = struct type t = int option [@@deriving compare, sexp_of] end let check (type a) here examples ~actual ~expect (module Output : Output with type t = a) = List.iter examples ~f:(fun example -> let actual = actual example in let expect = expect example in require here (Output.compare actual expect = 0) ~if_false_then_print_s:(lazy [%message (expect : Output.t)]); print_s [%sexp (actual : Output.t)]) ;; let%expect_test "foldi" = let f i acc elt = if i % 2 = 0 then elt :: acc else acc in check [%here] examples (module Int_list) ~actual:(fun list -> This_list.foldi list ~init:[] ~f) ~expect:(fun list -> That_list.foldi list ~init:[] ~f); [%expect {| () (1) (2) (1 4) (36 16 4 0) |}] ;; let%expect_test "findi" = let check f = check [%here] examples (module Int_pair_option) ~actual:(fun list -> This_list.findi list ~f) ~expect:(fun list -> That_list.findi list ~f) in check (fun i _elt -> i = 0); [%expect {| () ((0 1)) ((0 2)) ((0 4)) ((0 0)) |}]; check (fun _i elt -> elt = 1); [%expect {| () ((0 1)) () ((2 1)) ((1 1)) |}] ;; let%expect_test "find_mapi" = let f i elt = if elt = 1 then Some ((i * 100) + elt) else None in check [%here] examples (module Int_option) ~actual:(fun list -> This_list.find_mapi list ~f) ~expect:(fun list -> That_list.find_mapi list ~f); [%expect {| () (1) () (201) (101) |}] ;; let%expect_test "iteri" = let go iteri = let acc = ref [] in iteri ~f:(fun i elt -> acc := i :: elt :: !acc); !acc in check [%here] examples (module Int_list) ~actual:(fun list -> go (This_list.iteri list)) ~expect:(fun list -> go (That_list.iteri list)); [%expect {| () (0 1) (1 3 0 2) (2 1 1 5 0 4) (7 49 6 36 5 25 4 16 3 9 2 4 1 1 0 0) |}] ;; let bool_examples = [ [] ; [ true ] ; [ false ] ; [ false; false ] ; [ true; false ] ; [ false; true ] ; [ true; true ] ] ;; let%expect_test "for_alli" = let f _i elt = elt in check [%here] bool_examples (module Bool) ~actual:(fun list -> This_list.for_alli list ~f) ~expect:(fun list -> That_list.for_alli list ~f); [%expect {| true true false false false false true |}] ;; let%expect_test "existsi" = let f _i elt = elt in check [%here] bool_examples (module Bool) ~actual:(fun list -> This_list.existsi list ~f) ~expect:(fun list -> That_list.existsi list ~f); [%expect {| false true false false true true true |}] ;; let%expect_test "counti" = let f _i elt = elt in check [%here] bool_examples (module Int) ~actual:(fun list -> This_list.counti list ~f) ~expect:(fun list -> That_list.counti list ~f); [%expect {| 0 1 0 0 1 1 2 |}] ;; base-0.16.3/test/test_indexed_container.mli000066400000000000000000000000551446274340700207310ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_info.ml000066400000000000000000000110171446274340700160310ustar00rootroot00000000000000open! Import open! Info let%expect_test _ = print_endline (to_string_hum (of_exn (Failure "foo"))); [%expect {| (Failure foo) |}] ;; let%expect_test _ = print_endline (to_string_hum (tag (of_string "b") ~tag:"a")); [%expect {| (a b) |}] ;; let%expect_test _ = print_endline (to_string_hum (of_list (List.map ~f:of_string [ "a"; "b"; "c" ]))); [%expect {| (a b c) |}] ;; let%expect_test _ = print_endline (to_string_hum (tag_s ~tag:[%message "tag"] (create_s [%message "info"]))); [%expect {| (tag info) |}] ;; let of_strings strings = of_list (List.map ~f:of_string strings) let nested = of_list (List.map ~f:of_strings [ [ "a"; "b"; "c" ]; [ "d"; "e"; "f" ]; [ "g"; "h"; "i" ] ]) ;; let%expect_test _ = print_endline (to_string_hum nested); [%expect {| (a b c d e f g h i) |}] ;; let%expect_test _ = require_equal [%here] (module Sexp) (sexp_of_t nested) (sexp_of_t (of_strings [ "a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i" ])); [%expect {| |}] ;; let%expect_test _ = match to_exn (of_exn (Failure "foo")) with | Failure "foo" -> () | exn -> raise_s [%sexp { got = (exn : exn); expected = Failure "foo" }] ;; let round t = let sexp = sexp_of_t t in require [%here] (Sexp.( = ) sexp (sexp_of_t (t_of_sexp sexp))) ;; let%expect_test "non-empty tag" = tag_arg (of_string "hello") "tag" 13 [%sexp_of: int] |> sexp_of_t |> print_s; [%expect {| (tag 13 hello) |}] ;; let%expect_test "empty tag" = tag_arg (of_string "hello") "" 13 [%sexp_of: int] |> sexp_of_t |> print_s; [%expect {| (13 hello) |}] ;; let%expect_test _ = round (of_string "hello") let%expect_test _ = round (of_thunk (fun () -> "hello")) let%expect_test _ = round (create "tag" 13 [%sexp_of: int]) let%expect_test _ = round (tag (of_string "hello") ~tag:"tag") let%expect_test _ = round (tag_arg (of_string "hello") "tag" 13 [%sexp_of: int]) let%expect_test _ = round (tag_arg (of_string "hello") "" 13 [%sexp_of: int]) let%expect_test _ = round (of_list [ of_string "hello"; of_string "goodbye" ]) let%expect_test _ = round (t_of_sexp (Sexplib.Sexp.of_string "((random sexp 1)(b 2)((c (1 2 3))))")) ;; let%expect_test _ = require_equal [%here] (module String) (to_string_hum (of_string "a\nb")) "a\nb"; [%expect {| |}] ;; let%expect_test "show how backtraces are printed" = (* This is a real backtrace from some random OCaml program. The words [Raised] and [Called] have been lowercased to fool the expect test collector and prevent it from complaining about the presence of a backtrace. This is fine for this test because we are using a static string as the source for the backtrace, rather than actually raising (which might change output between compiler versions). *) let backtrace = "raised at Base__Error.raise in file \"error.ml\" (inlined), line 9, characters 14-30\n\ called from Base__Error.raise_s in file \"error.ml\", line 10, characters 19-40\n\ called from Floops_interfaces__Registrant.register_exn in file \"registrant.ml\", \ line 18, characters 4-241\n\ called from Floops_interfaces_test__Registrant_test.Test_brick.create_exn.(fun) in \ file \"registrant_test.ml\", line 25, characters 6-67\n\ called from Base__Or_error.try_with in file \"or_error.ml\", line 84, characters 9-15\n" in let exn = of_exn ~backtrace:(`This backtrace) (Failure "foo") in print_s [%sexp (exn : t)]; [%expect {| ((Failure foo) ("raised at Base__Error.raise in file \"error.ml\" (inlined), line 9, characters 14-30" "called from Base__Error.raise_s in file \"error.ml\", line 10, characters 19-40" "called from Floops_interfaces__Registrant.register_exn in file \"registrant.ml\", line 18, characters 4-241" "called from Floops_interfaces_test__Registrant_test.Test_brick.create_exn.(fun) in file \"registrant_test.ml\", line 25, characters 6-67" "called from Base__Or_error.try_with in file \"or_error.ml\", line 84, characters 9-15")) |}]; print_endline (Info.to_string_hum exn); [%expect {| ((Failure foo) ("raised at Base__Error.raise in file \"error.ml\" (inlined), line 9, characters 14-30" "called from Base__Error.raise_s in file \"error.ml\", line 10, characters 19-40" "called from Floops_interfaces__Registrant.register_exn in file \"registrant.ml\", line 18, characters 4-241" "called from Floops_interfaces_test__Registrant_test.Test_brick.create_exn.(fun) in file \"registrant_test.ml\", line 25, characters 6-67" "called from Base__Or_error.try_with in file \"or_error.ml\", line 84, characters 9-15")) |}] ;; base-0.16.3/test/test_info.mli000066400000000000000000000000551446274340700162020ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_int.ml000066400000000000000000000120611446274340700156700ustar00rootroot00000000000000open! Import open! Int let%expect_test ("hash coherence" [@tags "64-bits-only"]) = check_int_hash_coherence [%here] (module Int); [%expect {| |}] ;; let%expect_test "[max_value_30_bits]" = print_s [%sexp (max_value_30_bits : t)]; [%expect {| 1_073_741_823 |}] ;; let%expect_test "of_string_opt" = print_s [%sexp (of_string_opt "1" : int option)]; [%expect "(1)"]; print_s [%sexp (of_string_opt "1a" : int option)]; [%expect "()"]; print_s [%sexp (of_string_opt "99999999999999999999999999999" : int option)]; [%expect "()"] ;; let%expect_test "to_string_hum" = let test_roundtrip int = require_equal [%here] (module Int) (of_string (to_string_hum int)) int in quickcheck_m [%here] (module struct type t = int [@@deriving quickcheck, sexp_of] end) ~examples:[ Int.min_value; Int.max_value ] ~f:test_roundtrip ;; let%expect_test "hex" = let test x = let n = Or_error.try_with (fun () -> Int.Hex.of_string x) in print_s [%message (n : int Or_error.t)] in test "0x1c5f"; [%expect {| (n (Ok 7_263)) |}]; test "0x1c5f NON-HEX-GARBAGE"; [%expect {| (n ( Error ( Failure "Base.Int.Hex.of_string: invalid input \"0x1c5f NON-HEX-GARBAGE\""))) |}] ;; let%test_module "Hex" = (module struct let f (i, s_hum) = let s = String.filter s_hum ~f:(fun c -> not (Char.equal c '_')) in let sexp_hum = Sexp.Atom s_hum in let sexp = Sexp.Atom s in [%test_result: Sexp.t] ~message:"sexp_of_t" ~expect:sexp (Hex.sexp_of_t i); [%test_result: int] ~message:"t_of_sexp" ~expect:i (Hex.t_of_sexp sexp); [%test_result: int] ~message:"t_of_sexp[human]" ~expect:i (Hex.t_of_sexp sexp_hum); [%test_result: string] ~message:"to_string" ~expect:s (Hex.to_string i); [%test_result: string] ~message:"to_string_hum" ~expect:s_hum (Hex.to_string_hum i); [%test_result: int] ~message:"of_string" ~expect:i (Hex.of_string s); [%test_result: int] ~message:"of_string[human]" ~expect:i (Hex.of_string s_hum) ;; let%test_unit _ = List.iter ~f [ 0, "0x0" ; 1, "0x1" ; 2, "0x2" ; 5, "0x5" ; 10, "0xa" ; 16, "0x10" ; 254, "0xfe" ; 65_535, "0xffff" ; 65_536, "0x1_0000" ; 1_000_000, "0xf_4240" ; -1, "-0x1" ; -2, "-0x2" ; -1_000_000, "-0xf_4240" ; ( max_value , match num_bits with | 31 -> "0x3fff_ffff" | 32 -> "0x7fff_ffff" | 63 -> "0x3fff_ffff_ffff_ffff" | _ -> assert false ) ; ( min_value , match num_bits with | 31 -> "-0x4000_0000" | 32 -> "-0x8000_0000" | 63 -> "-0x4000_0000_0000_0000" | _ -> assert false ) ] ;; let%test_unit _ = [%test_result: int] (Hex.of_string "0XA") ~expect:10 let%test_unit _ = match Option.try_with (fun () -> Hex.of_string "0") with | None -> () | Some _ -> failwith "Hex must always have a 0x prefix." ;; let%test_unit _ = match Option.try_with (fun () -> Hex.of_string "0x_0") with | None -> () | Some _ -> failwith "Hex may not have '_' before the first digit." ;; end) ;; let%test _ = neg 5 + 5 = 0 let%test _ = pow min_value 1 = min_value let%test _ = pow max_value 1 = max_value let%test "comparisons" = let original_compare (x : int) y = Stdlib.compare x y in let valid_compare x y = let result = compare x y in let expect = original_compare x y in assert (Bool.( = ) (result < 0) (expect < 0)); assert (Bool.( = ) (result > 0) (expect > 0)); assert (Bool.( = ) (result = 0) (expect = 0)); assert (result = expect) in valid_compare min_value min_value; valid_compare min_value (-1); valid_compare (-1) min_value; valid_compare min_value 0; valid_compare 0 min_value; valid_compare max_value (-1); valid_compare (-1) max_value; valid_compare max_value min_value; valid_compare max_value max_value; true ;; let test f x = test_conversion ~to_string:Int.Hex.to_string_hum f x let numbers = [ 0x10_20; 0x11_22_33; 0x11_22_33_1F; 0x11_22_33_44 ] let%expect_test "bswap16" = List.iter numbers ~f:(test bswap16); [%expect {| 0x1020 --> 0x2010 0x11_2233 --> 0x3322 0x1122_331f --> 0x1f33 0x1122_3344 --> 0x4433 |}] ;; let%expect_test "% and /%" = quickcheck_m [%here] (module struct type t = int * (int [@quickcheck.generator Base_quickcheck.Generator.small_strictly_positive_int]) [@@deriving quickcheck, sexp_of] end) ~f:(fun (a, b) -> let r = a % b in let q = a /% b in require [%here] (r >= 0); require_equal [%here] (module Int) a ((q * b) + r)) ;; include ( struct (** Various functors whose type-correctness ensures desired relationships between interfaces. *) (* O contained in S *) module _ (M : S) : module type of M.O = M (* O contained in S_unbounded *) module _ (M : S_unbounded) : module type of M.O = M (* S_unbounded in S *) module _ (M : S) : S_unbounded = M end : sig end) base-0.16.3/test/test_int.mli000066400000000000000000000000551446274340700160410ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_int32.ml000066400000000000000000000012551446274340700160400ustar00rootroot00000000000000open! Import open! Int32 let%expect_test "hash coherence" = check_int_hash_coherence [%here] (module Int32); [%expect {| |}] ;; let numbers = [ 0x10_20l; 0x11_22_33l; 0x11_22_33_1Fl; 0x11_22_33_44l ] let test = test_conversion ~to_string:(fun x -> Int32.Hex.to_string_hum x) let%expect_test "bswap16" = List.iter numbers ~f:(test bswap16); [%expect {| 0x1020 --> 0x2010 0x11_2233 --> 0x3322 0x1122_331f --> 0x1f33 0x1122_3344 --> 0x4433 |}] ;; let%expect_test "bswap32" = List.iter numbers ~f:(test bswap32); [%expect {| 0x1020 --> 0x2010_0000 0x11_2233 --> 0x3322_1100 0x1122_331f --> 0x1f33_2211 0x1122_3344 --> 0x4433_2211 |}] ;; base-0.16.3/test/test_int32.mli000066400000000000000000000000551446274340700162060ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_int32_pow2.ml000066400000000000000000000046421446274340700170120ustar00rootroot00000000000000open! Import open! Int32 let of_ints = List.map ~f:of_int_exn let examples = of_ints [ -1; 0; 1; 2; 3; 4; 5; 7; 8; 9; 63; 64; 65 ] let examples_64_bit = [ min_value; succ min_value; pred max_value; max_value ] let print_for ints f = List.iter ints ~f:(fun i -> print_s [%message "" ~_:(i : int32) ~_:(Or_error.try_with (fun () -> f i) : int Or_error.t)]) ;; let%expect_test "[floor_log2]" = print_for examples floor_log2; [%expect {| (-1 (Error ("[Int32.floor_log2] got invalid input" -1))) (0 (Error ("[Int32.floor_log2] got invalid input" 0))) (1 (Ok 0)) (2 (Ok 1)) (3 (Ok 1)) (4 (Ok 2)) (5 (Ok 2)) (7 (Ok 2)) (8 (Ok 3)) (9 (Ok 3)) (63 (Ok 5)) (64 (Ok 6)) (65 (Ok 6)) |}] ;; let%expect_test ("[floor_log2]" [@tags "64-bits-only"]) = print_for examples_64_bit floor_log2; [%expect {| (-2_147_483_648 (Error ("[Int32.floor_log2] got invalid input" -2147483648))) (-2_147_483_647 (Error ("[Int32.floor_log2] got invalid input" -2147483647))) (2_147_483_646 (Ok 30)) (2_147_483_647 (Ok 30)) |}] ;; let%expect_test "[ceil_log2]" = print_for examples ceil_log2; [%expect {| (-1 (Error ("[Int32.ceil_log2] got invalid input" -1))) (0 (Error ("[Int32.ceil_log2] got invalid input" 0))) (1 (Ok 0)) (2 (Ok 1)) (3 (Ok 2)) (4 (Ok 2)) (5 (Ok 3)) (7 (Ok 3)) (8 (Ok 3)) (9 (Ok 4)) (63 (Ok 6)) (64 (Ok 6)) (65 (Ok 7)) |}] ;; let%expect_test ("[ceil_log2]" [@tags "64-bits-only"]) = print_for examples_64_bit ceil_log2; [%expect {| (-2_147_483_648 (Error ("[Int32.ceil_log2] got invalid input" -2147483648))) (-2_147_483_647 (Error ("[Int32.ceil_log2] got invalid input" -2147483647))) (2_147_483_646 (Ok 31)) (2_147_483_647 (Ok 31)) |}] ;; let%test_module "int_math" = (module struct let test_cases () = of_ints [ 0b10101010 ; 0b1010101010101010 ; 0b101010101010101010101010 ; 0b10000000 ; 0b1000000000001000 ; 0b100000000000000000001000 ] ;; let%test_unit "ceil_pow2" = List.iter (test_cases ()) ~f:(fun x -> let p2 = ceil_pow2 x in assert (is_pow2 p2 && p2 >= x && x >= p2 / of_int_exn 2)) ;; let%test_unit "floor_pow2" = List.iter (test_cases ()) ~f:(fun x -> let p2 = floor_pow2 x in assert (is_pow2 p2 && of_int_exn 2 * p2 >= x && x >= p2)) ;; end) ;; base-0.16.3/test/test_int32_pow2.mli000066400000000000000000000000551446274340700171550ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_int63.ml000066400000000000000000000065311446274340700160460ustar00rootroot00000000000000open! Import open! Int63 let%expect_test ("hash coherence" [@tags "64-bits-only"]) = check_int_hash_coherence [%here] (module Int63); [%expect {| |}] ;; let%test_unit _ = [%test_result: t] max_value ~expect:(of_int64_exn 4611686018427387903L) let%test_unit _ = [%test_result: t] min_value ~expect:(of_int64_exn (-4611686018427387904L)) ;; let%test_unit _ = [%test_result: t] (of_int32_exn Int32.min_value) ~expect:(of_int32 Int32.min_value) ;; let%test_unit _ = [%test_result: t] (of_int32_exn Int32.max_value) ~expect:(of_int32 Int32.max_value) ;; let%test "typical random 0" = Exn.does_raise (fun () -> random zero) let%test_module "Overflow_exn" = (module struct open Overflow_exn let%test_module "( + )" = (module struct let test t = Exn.does_raise (fun () -> t + t) let%test "max_value / 2 + 1" = test (succ (max_value / of_int 2)) let%test "min_value / 2 - 1" = test (pred (min_value / of_int 2)) let%test "min_value + min_value" = test min_value let%test "max_value + max_value" = test max_value end) ;; let%test_module "( - )" = (module struct let%test "min_value - 1" = Exn.does_raise (fun () -> min_value - one) let%test "max_value - -1" = Exn.does_raise (fun () -> max_value - neg one) let%test "min_value / 2 - max_value / 2 - 2" = Exn.does_raise (fun () -> (min_value / of_int 2) - (max_value / of_int 2) - of_int 2) ;; let%test "min_value - max_value" = Exn.does_raise (fun () -> min_value - max_value) ;; let%test "max_value - min_value" = Exn.does_raise (fun () -> max_value - min_value) ;; let%test "max_value - -max_value" = Exn.does_raise (fun () -> max_value - neg max_value) ;; end) ;; let is_overflow = Exn.does_raise let%test_module "( * )" = (module struct let%test "1 * 1" = one * one = one let%test "1 * 0" = one * zero = zero let%test "0 * 1" = zero * one = zero let%test "min_value * -1" = is_overflow (fun () -> min_value * neg one) let%test "-1 * min_value" = is_overflow (fun () -> neg one * min_value) let%test "46116860184273879 * 100" = of_int64_exn 46116860184273879L * of_int 100 = of_int64_exn 4611686018427387900L ;; let%test "46116860184273879 * 101" = is_overflow (fun () -> of_int64_exn 46116860184273879L * of_int 101) ;; end) ;; let%test_module "( / )" = (module struct let%test "1 / 1" = one / one = one let%test "min_value / -1" = is_overflow (fun () -> min_value / neg one) let%test "min_value / 1" = min_value / one = min_value let%test "max_value / -1" = max_value / neg one = min_value + one end) ;; end) ;; let%expect_test "[floor_log2]" = let floor_log2 t = print_s [%sexp (floor_log2 t : int)] in show_raise (fun () -> floor_log2 zero); [%expect {| (raised ("[Int.floor_log2] got invalid input" 0)) |}]; floor_log2 one; [%expect {| 0 |}]; for i = 1 to 8 do floor_log2 (i |> of_int) done; [%expect {| 0 1 1 2 2 2 2 3 |}]; floor_log2 ((one lsl 61) - one); [%expect {| 60 |}]; floor_log2 (one lsl 61); [%expect {| 61 |}]; floor_log2 max_value; [%expect {| 61 |}] ;; base-0.16.3/test/test_int63.mli000066400000000000000000000000551446274340700162120ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_int63_emul.ml000066400000000000000000000005741446274340700170710ustar00rootroot00000000000000open! Import module Int63_emul = Base.Int63.Private.Emul let%expect_test _ = let s63 = Int63.(Hex.to_string min_value) in let s63_emul = Int63_emul.(Hex.to_string min_value) in print_s [%message (s63 : string) (s63_emul : string)]; require [%here] (String.equal s63 s63_emul); [%expect {| ((s63 -0x4000000000000000) (s63_emul -0x4000000000000000)) |}] ;; base-0.16.3/test/test_int63_emul.mli000066400000000000000000000000551446274340700172340ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_int64.ml000066400000000000000000000034021446274340700160410ustar00rootroot00000000000000open! Import open! Int64 let%expect_test "hash coherence" = check_int_hash_coherence [%here] (module Int64); [%expect {| |}] ;; let numbers = [ 0x0000_0000_0000_1020L ; 0x0000_0000_0011_2233L ; 0x0000_0000_1122_3344L ; 0x0000_0011_2233_4455L ; 0x0000_1122_3344_5566L ; 0x0011_2233_4455_6677L ; 0x1122_3344_5566_7788L ] ;; let test = test_conversion ~to_string:Int64.Hex.to_string_hum let%expect_test "bswap16" = List.iter numbers ~f:(test bswap16); [%expect {| 0x1020 --> 0x2010 0x11_2233 --> 0x3322 0x1122_3344 --> 0x4433 0x11_2233_4455 --> 0x5544 0x1122_3344_5566 --> 0x6655 0x11_2233_4455_6677 --> 0x7766 0x1122_3344_5566_7788 --> 0x8877 |}] ;; let%expect_test "bswap32" = List.iter numbers ~f:(test bswap32); [%expect {| 0x1020 --> 0x2010_0000 0x11_2233 --> 0x3322_1100 0x1122_3344 --> 0x4433_2211 0x11_2233_4455 --> 0x5544_3322 0x1122_3344_5566 --> 0x6655_4433 0x11_2233_4455_6677 --> 0x7766_5544 0x1122_3344_5566_7788 --> 0x8877_6655 |}] ;; let%expect_test "bswap48" = List.iter numbers ~f:(test bswap48); [%expect {| 0x1020 --> 0x2010_0000_0000 0x11_2233 --> 0x3322_1100_0000 0x1122_3344 --> 0x4433_2211_0000 0x11_2233_4455 --> 0x5544_3322_1100 0x1122_3344_5566 --> 0x6655_4433_2211 0x11_2233_4455_6677 --> 0x7766_5544_3322 0x1122_3344_5566_7788 --> 0x8877_6655_4433 |}] ;; let%expect_test "bswap64" = List.iter numbers ~f:(test bswap64); [%expect {| 0x1020 --> 0x2010_0000_0000_0000 0x11_2233 --> 0x3322_1100_0000_0000 0x1122_3344 --> 0x4433_2211_0000_0000 0x11_2233_4455 --> 0x5544_3322_1100_0000 0x1122_3344_5566 --> 0x6655_4433_2211_0000 0x11_2233_4455_6677 --> 0x7766_5544_3322_1100 0x1122_3344_5566_7788 --> -0x7788_99aa_bbcc_ddef |}] ;; base-0.16.3/test/test_int64.mli000066400000000000000000000000551446274340700162130ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_int64_pow2.ml000066400000000000000000000055041446274340700170150ustar00rootroot00000000000000open! Import open! Int64 let examples = [ -1L; 0L; 1L; 2L; 3L; 4L; 5L; 7L; 8L; 9L; 63L; 64L; 65L ] let examples_64_bit = [ min_value; succ min_value; pred max_value; max_value ] let print_for ints f = List.iter ints ~f:(fun i -> print_s [%message "" ~_:(i : int64) ~_:(Or_error.try_with (fun () -> f i) : int Or_error.t)]) ;; let%expect_test "[floor_log2]" = print_for examples floor_log2; [%expect {| (-1 (Error ("[Int64.floor_log2] got invalid input" -1))) (0 (Error ("[Int64.floor_log2] got invalid input" 0))) (1 (Ok 0)) (2 (Ok 1)) (3 (Ok 1)) (4 (Ok 2)) (5 (Ok 2)) (7 (Ok 2)) (8 (Ok 3)) (9 (Ok 3)) (63 (Ok 5)) (64 (Ok 6)) (65 (Ok 6)) |}] ;; let%expect_test ("[floor_log2]" [@tags "64-bits-only"]) = print_for examples_64_bit floor_log2; [%expect {| (-9_223_372_036_854_775_808 ( Error ("[Int64.floor_log2] got invalid input" -9223372036854775808))) (-9_223_372_036_854_775_807 ( Error ("[Int64.floor_log2] got invalid input" -9223372036854775807))) (9_223_372_036_854_775_806 (Ok 62)) (9_223_372_036_854_775_807 (Ok 62)) |}] ;; let%expect_test "[ceil_log2]" = print_for examples ceil_log2; [%expect {| (-1 (Error ("[Int64.ceil_log2] got invalid input" -1))) (0 (Error ("[Int64.ceil_log2] got invalid input" 0))) (1 (Ok 0)) (2 (Ok 1)) (3 (Ok 2)) (4 (Ok 2)) (5 (Ok 3)) (7 (Ok 3)) (8 (Ok 3)) (9 (Ok 4)) (63 (Ok 6)) (64 (Ok 6)) (65 (Ok 7)) |}] ;; let%expect_test ("[ceil_log2]" [@tags "64-bits-only"]) = print_for examples_64_bit ceil_log2; [%expect {| (-9_223_372_036_854_775_808 ( Error ("[Int64.ceil_log2] got invalid input" -9223372036854775808))) (-9_223_372_036_854_775_807 ( Error ("[Int64.ceil_log2] got invalid input" -9223372036854775807))) (9_223_372_036_854_775_806 (Ok 63)) (9_223_372_036_854_775_807 (Ok 63)) |}] ;; let%test_module "int64_math" = (module struct let test_cases () = let cases = [ 0b10101010L ; 0b1010101010101010L ; 0b101010101010101010101010L ; 0b10000000L ; 0b1000000000001000L ; 0b100000000000000000001000L ] in let cases = cases @ [ (0b1010101010101010L lsl 16) lor 0b1010101010101010L ; (0b1000000000000000L lsl 16) lor 0b0000000000001000L ] in let added_cases = List.map cases ~f:(fun x -> x lsl 16) in List.concat [ cases; added_cases ] ;; let%test_unit "ceil_pow2" = List.iter (test_cases ()) ~f:(fun x -> let p2 = ceil_pow2 x in assert (is_pow2 p2 && p2 >= x && x >= p2 / 2L)) ;; let%test_unit "floor_pow2" = List.iter (test_cases ()) ~f:(fun x -> let p2 = floor_pow2 x in assert (is_pow2 p2 && 2L * p2 >= x && x >= p2)) ;; end) ;; base-0.16.3/test/test_int64_pow2.mli000066400000000000000000000000551446274340700171620ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_int_conversions.ml000066400000000000000000000161411446274340700203230ustar00rootroot00000000000000open! Import open! Int_conversions let%test_module "pretty" = (module struct let check input output = List.for_all [ ""; "+"; "-" ] ~f:(fun prefix -> let input = prefix ^ input in let output = prefix ^ output in [%compare.equal: string] output (insert_underscores input)) ;; let%test _ = check "1" "1" let%test _ = check "12" "12" let%test _ = check "123" "123" let%test _ = check "1234" "1_234" let%test _ = check "12345" "12_345" let%test _ = check "123456" "123_456" let%test _ = check "1234567" "1_234_567" let%test _ = check "12345678" "12_345_678" let%test _ = check "123456789" "123_456_789" let%test _ = check "1234567890" "1_234_567_890" end) ;; let%test_module "conversions" = (module struct module type S = sig include Int.S val module_name : string end let test_conversion (type a b) loc ma mb a_to_b_or_error a_to_b_trunc b_to_a_trunc = let (module A : S with type t = a) = ma in let (module B : S with type t = b) = mb in let examples = [ A.min_value ; A.minus_one ; A.zero ; A.one ; A.max_value ; B.min_value |> b_to_a_trunc ; B.max_value |> b_to_a_trunc ] |> List.concat_map ~f:(fun a -> [ A.pred a; a; A.succ a ]) |> List.dedup_and_sort ~compare:A.compare |> List.sort ~compare:A.compare in List.iter examples ~f:(fun a -> let b' = a_to_b_trunc a in let a' = b_to_a_trunc b' in match a_to_b_or_error a with | Ok b -> require loc (B.equal b b') ~if_false_then_print_s: (lazy [%message "conversion produced wrong value" ~from:(A.module_name : string) ~to_:(B.module_name : string) ~input:(a : A.t) ~output:(b : B.t) ~expected:(b' : B.t)]); require loc (A.equal a a') ~if_false_then_print_s: (lazy [%message "conversion does not round-trip" ~from:(A.module_name : string) ~to_:(B.module_name : string) ~input:(a : A.t) ~output:(b : B.t) ~round_trip:(a' : A.t)]) | Error error -> require loc (not (A.equal a a')) ~if_false_then_print_s: (lazy [%message "conversion failed" ~from:(A.module_name : string) ~to_:(B.module_name : string) ~input:(a : A.t) ~expected_output:(b' : B.t) ~error:(error : Error.t)])) ;; let test loc ma mb (a_to_b_trunc, a_to_b_or_error) (b_to_a_trunc, b_to_a_or_error) = test_conversion loc ma mb a_to_b_or_error a_to_b_trunc b_to_a_trunc; test_conversion loc mb ma b_to_a_or_error b_to_a_trunc a_to_b_trunc ;; module Int = struct include Int let module_name = "Int" end module Int32 = struct include Int32 let module_name = "Int32" end module Int64 = struct include Int64 let module_name = "Int64" end module Nativeint = struct include Nativeint let module_name = "Nativeint" end let with_exn f x = Or_error.try_with (fun () -> f x) let optional f x = Or_error.try_with (fun () -> Option.value_exn (f x)) let alwaysok f x = Ok (f x) let%expect_test "int <-> int32" = test [%here] (module Int) (module Int32) (Stdlib.Int32.of_int, with_exn int_to_int32_exn) (Stdlib.Int32.to_int, with_exn int32_to_int_exn); [%expect {| |}]; test [%here] (module Int) (module Int32) (Stdlib.Int32.of_int, optional int_to_int32) (Stdlib.Int32.to_int, optional int32_to_int); [%expect {| |}] ;; let%expect_test "int <-> int64" = test [%here] (module Int) (module Int64) (Stdlib.Int64.of_int, alwaysok int_to_int64) (Stdlib.Int64.to_int, with_exn int64_to_int_exn); [%expect {| |}]; test [%here] (module Int) (module Int64) (Stdlib.Int64.of_int, alwaysok int_to_int64) (Stdlib.Int64.to_int, optional int64_to_int); [%expect {| |}] ;; let%expect_test "int <-> nativeint" = test [%here] (module Int) (module Nativeint) (Stdlib.Nativeint.of_int, alwaysok int_to_nativeint) (Stdlib.Nativeint.to_int, with_exn nativeint_to_int_exn); [%expect {| |}]; test [%here] (module Int) (module Nativeint) (Stdlib.Nativeint.of_int, alwaysok int_to_nativeint) (Stdlib.Nativeint.to_int, optional nativeint_to_int); [%expect {| |}] ;; let%expect_test "int32 <-> int64" = test [%here] (module Int32) (module Int64) (Stdlib.Int64.of_int32, alwaysok int32_to_int64) (Stdlib.Int64.to_int32, with_exn int64_to_int32_exn); [%expect {| |}]; test [%here] (module Int32) (module Int64) (Stdlib.Int64.of_int32, alwaysok int32_to_int64) (Stdlib.Int64.to_int32, optional int64_to_int32); [%expect {| |}] ;; let%expect_test "int32 <-> nativeint" = test [%here] (module Int32) (module Nativeint) (Stdlib.Nativeint.of_int32, alwaysok int32_to_nativeint) (Stdlib.Nativeint.to_int32, with_exn nativeint_to_int32_exn); [%expect {| |}]; test [%here] (module Int32) (module Nativeint) (Stdlib.Nativeint.of_int32, alwaysok int32_to_nativeint) (Stdlib.Nativeint.to_int32, optional nativeint_to_int32); [%expect {| |}] ;; let%expect_test "int64 <-> nativeint" = test [%here] (module Int64) (module Nativeint) (Stdlib.Int64.to_nativeint, with_exn int64_to_nativeint_exn) (Stdlib.Int64.of_nativeint, alwaysok nativeint_to_int64); [%expect {| |}]; test [%here] (module Int64) (module Nativeint) (Stdlib.Int64.to_nativeint, optional int64_to_nativeint) (Stdlib.Int64.of_nativeint, alwaysok nativeint_to_int64); [%expect {| |}] ;; end) ;; let%test_module "Make_hex" = (module struct module Hex_int = struct type t = int [@@deriving quickcheck] module M = Make_hex (struct type nonrec t = int [@@deriving sexp, compare, hash, quickcheck] let to_string = Int.Hex.to_string let of_string = Int.Hex.of_string let zero = 0 let ( < ) = ( < ) let neg = Int.neg let module_name = "Hex_int" end) include (M.Hex : module type of M.Hex with type t := t) end let%expect_test "validate sexp grammar" = require_ok [%here] (Sexp_grammar_validation.validate_grammar (module Hex_int)); [%expect {| String |}] ;; end) ;; base-0.16.3/test/test_int_conversions.mli000066400000000000000000000000551446274340700204710ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_int_hash.ml000066400000000000000000000003411446274340700166710ustar00rootroot00000000000000open! Base open! Import let%expect_test ("int hash is not ident" [@tags "64-bits-only"]) = print_s [%message "hash of 10" (Int.hash 10 : int)]; [%expect {| ("hash of 10" ("Int.hash 10" 1_579_120_067_278_557_813)) |}] ;; base-0.16.3/test/test_int_hash.mli000066400000000000000000000000531446274340700170420ustar00rootroot00000000000000(* this interface is deliberately empty *) base-0.16.3/test/test_int_math.ml000066400000000000000000000401231446274340700167010ustar00rootroot00000000000000open! Import open! Base.Int_math open! Base.Int_math.Private let%test_unit _ = let x = match Word_size.word_size with | W32 -> 9 | W64 -> 10 in for i = 0 to x do for j = 0 to x do assert (int_pow i j = Stdlib.(int_of_float (float_of_int i ** float_of_int j))) done done ;; module Test (X : Make_arg) : sig end = struct open X include Make (X) let%test_module "integer-rounding" = (module struct let check dir ~range:(lower, upper) ~modulus expected = let modulus = of_int_exn modulus in let expected = of_int_exn expected in for i = lower to upper do let observed = round ~dir ~to_multiple_of:modulus (of_int_exn i) in if observed <> expected then raise_s [%message "invalid result" (i : int)] done ;; let%test_unit _ = check ~modulus:10 `Down ~range:(10, 19) 10 let%test_unit _ = check ~modulus:10 `Down ~range:(0, 9) 0 let%test_unit _ = check ~modulus:10 `Down ~range:(-10, -1) (-10) let%test_unit _ = check ~modulus:10 `Down ~range:(-20, -11) (-20) let%test_unit _ = check ~modulus:10 `Up ~range:(11, 20) 20 let%test_unit _ = check ~modulus:10 `Up ~range:(1, 10) 10 let%test_unit _ = check ~modulus:10 `Up ~range:(-9, 0) 0 let%test_unit _ = check ~modulus:10 `Up ~range:(-19, -10) (-10) let%test_unit _ = check ~modulus:10 `Zero ~range:(10, 19) 10 let%test_unit _ = check ~modulus:10 `Zero ~range:(-9, 9) 0 let%test_unit _ = check ~modulus:10 `Zero ~range:(-19, -10) (-10) let%test_unit _ = check ~modulus:10 `Nearest ~range:(15, 24) 20 let%test_unit _ = check ~modulus:10 `Nearest ~range:(5, 14) 10 let%test_unit _ = check ~modulus:10 `Nearest ~range:(-5, 4) 0 let%test_unit _ = check ~modulus:10 `Nearest ~range:(-15, -6) (-10) let%test_unit _ = check ~modulus:10 `Nearest ~range:(-25, -16) (-20) let%test_unit _ = check ~modulus:5 `Nearest ~range:(8, 12) 10 let%test_unit _ = check ~modulus:5 `Nearest ~range:(3, 7) 5 let%test_unit _ = check ~modulus:5 `Nearest ~range:(-2, 2) 0 let%test_unit _ = check ~modulus:5 `Nearest ~range:(-7, -3) (-5) let%test_unit _ = check ~modulus:5 `Nearest ~range:(-12, -8) (-10) end) ;; let%test_module "remainder-and-modulus" = (module struct let one = of_int_exn 1 let check_integers x y = let sexp_of_t t = sexp_of_string (to_string t) in let check_raises f what = match f () with | exception _ -> () | z -> raise_s [%message "produced result instead of raising" (what : string) (x : t) (y : t) (z : t)] in let check_true cond what = if not cond then raise_s [%message "failed" (what : string) (x : t) (y : t)] in if y = zero then ( check_raises (fun () -> x / y) "division by zero"; check_raises (fun () -> rem x y) "rem _ zero"; check_raises (fun () -> x % y) "_ % zero"; check_raises (fun () -> x /% y) "_ /% zero") else ( if x < zero then check_true (rem x y <= zero) "non-positive remainder" else check_true (rem x y >= zero) "non-negative remainder"; check_true (abs (rem x y) <= abs y - one) "range of remainder"; if y < zero then ( check_raises (fun () -> x % y) "_ % negative"; check_raises (fun () -> x /% y) "_ /% negative") else ( check_true (x = (x /% y * y) + (x % y)) "(/%) and (%) identity"; check_true (x = (x / y * y) + rem x y) "(/) and rem identity"; check_true (x % y >= zero) "non-negative (%)"; check_true (x % y <= y - one) "range of (%)"; if x > zero && y > zero then ( check_true (x /% y = x / y) "(/%) and (/) identity"; check_true (x % y = rem x y) "(%) and rem identity"))) ;; let check_natural_numbers x y = List.iter [ x; -x; x + one; -(x + one) ] ~f:(fun x -> List.iter [ y; -y; y + one; -(y + one) ] ~f:(fun y -> check_integers x y)) ;; let%test_unit "deterministic" = let big1 = of_int_exn 118_310_344 in let big2 = of_int_exn 828_172_408 in (* Important to test the case where one value is a multiple of the other. Note that the [x + one] and [y + one] cases in [check_natural_numbers] ensure that we also test non-multiple cases. *) assert (big2 = big1 * of_int_exn 7); let values = [ zero; one; big1; big2 ] in List.iter values ~f:(fun x -> List.iter values ~f:(fun y -> check_natural_numbers x y)) ;; let%test_unit "random" = let rand = Random.State.make [| 8; 67; -5_309 |] in for _ = 0 to 1_000 do let max_value = 1_000_000_000 in let x = of_int_exn (Random.State.int rand max_value) in let y = of_int_exn (Random.State.int rand max_value) in check_natural_numbers x y done ;; end) ;; end include Test (Int) include Test (Int32) include Test (Int63) include Test (Int64) include Test (Nativeint) let%test_module "int rounding quickcheck tests" = (module struct module type With_quickcheck = sig type t [@@deriving sexp_of] include Make_arg with type t := t val min_value : t val max_value : t val quickcheck_generator_incl : t -> t -> t Base_quickcheck.Generator.t val quickcheck_generator_log_incl : t -> t -> t Base_quickcheck.Generator.t end module Rounding_direction = struct type t = [ `Up | `Down | `Zero | `Nearest ] [@@deriving enumerate, sexp_of] end module Rounding_pair (Integer : With_quickcheck) = struct type t = { number : Integer.t ; factor : Integer.t } [@@deriving sexp_of] let quickcheck_generator = (* This generator should frequently generate "interesting" numbers for rounding. *) let open Base_quickcheck.Generator.Let_syntax in (* First we choose a factor to round to. *) let%bind factor = Integer.quickcheck_generator_log_incl (Integer.of_int_exn 1) Integer.max_value in (* Then we choose a multiplier for that factor. *) let%map multiplier = Integer.quickcheck_generator_incl (Integer.( / ) Integer.min_value factor) (Integer.( / ) Integer.max_value factor) (* Then we choose an offset such that [multiplier * factor] is the nearest value to round to. [quickcheck_generator_incl] puts extra weight on the [-factor/2, factor/2] bounds, and we also weight 0 heavily. *) and offset = let half_factor = Integer.( / ) factor (Integer.of_int_exn 2) in Base_quickcheck.Generator.weighted_union [ 9., Integer.quickcheck_generator_incl (Integer.neg half_factor) half_factor ; 1., Base_quickcheck.Generator.return Integer.zero ] in let number = Integer.( + ) offset (Integer.( * ) factor multiplier) in { number; factor } ;; let quickcheck_shrinker = Base_quickcheck.Shrinker.atomic end let test_direction (module Integer : With_quickcheck) ~dir = let open Integer in (* Criterion for correct rounding: must be a multiple of the factor *) let is_multiple_of number ~factor = factor * (number / factor) = number in (* Criterion for correct rounding: must not reverse sign *) let is_compatible_sign number ~rounded = if number > zero then rounded >= zero else if number < zero then rounded <= zero else rounded = zero in (* Criterion for correct rounding: must be less than factor away from original *) let is_close_enough x y ~factor = if x > y then x - y > zero && x - y < factor else if x < y then y - x > zero && y - x < factor else true in (* Criterion for correct rounding: rounding direction must be respected *) let is_in_correct_direction number ~dir ~rounded ~factor = match dir with | `Down -> rounded <= number | `Up -> rounded >= number | `Zero -> if number < zero then rounded >= number else if number > zero then rounded <= number else rounded = zero | `Nearest -> if rounded > number then rounded - number <= number - (rounded - factor) else if rounded < number then number - rounded < rounded + factor - number else true in (* Correct rounding obeys all four criteria *) let is_rounded_correctly number ~dir ~factor ~rounded = is_multiple_of rounded ~factor && is_compatible_sign number ~rounded && is_close_enough number rounded ~factor && is_in_correct_direction number ~dir ~rounded ~factor in (* Round correctly by finding a multiple of the factor, and trying +/-factor away from that. If this returns [None], there should be no correct representable result. *) let round_correctly number ~dir ~factor = let rounded0 = factor * (number / factor) in match List.filter [ rounded0 - factor; rounded0; rounded0 + factor ] ~f:(fun rounded -> is_rounded_correctly number ~dir ~factor ~rounded) with | [] -> None | [ rounded ] -> Some rounded | multiple -> raise_s [%sexp "test bug: multiple correctly rounded values", (multiple : Integer.t list)] in let module Math = Make (Integer) in let module Pair = Rounding_pair (Integer) in require_does_not_raise [%here] (fun () -> Base_quickcheck.Test.run_exn (module Pair) ~f:(fun ({ number; factor } : Pair.t) -> let rounded = Math.round number ~dir ~to_multiple_of:factor in (* Test that if it is possible to round correctly, then we do. *) match round_correctly number ~dir ~factor with | None -> if is_rounded_correctly number ~dir ~factor ~rounded then raise_s [%sexp "test bug: did not find correctly rounded value" , { rounded : Integer.t }] | Some rounded_correctly -> if rounded <> rounded_correctly then raise_s [%sexp "rounding failed" , { rounded : Integer.t; rounded_correctly : Integer.t }])) ;; let test m = List.iter Rounding_direction.all ~f:(fun dir -> print_s [%sexp "testing", (dir : Rounding_direction.t)]; test_direction m ~dir) ;; let%expect_test ("int" [@tags "no-js", "64-bits-only"]) = test (module struct include Int let quickcheck_generator_incl = Base_quickcheck.Generator.int_inclusive let quickcheck_generator_log_incl = Base_quickcheck.Generator.int_log_inclusive end); [%expect {| (testing Up) (testing Down) (testing Zero) (testing Nearest) |}] ;; let%expect_test "int32" = test (module struct include Int32 let quickcheck_generator_incl = Base_quickcheck.Generator.int32_inclusive let quickcheck_generator_log_incl = Base_quickcheck.Generator.int32_log_inclusive ;; end); [%expect {| (testing Up) (testing Down) (testing Zero) (testing Nearest) |}] ;; let%expect_test "int63" = test (module struct include Int63 let quickcheck_generator_incl = Base_quickcheck.Generator.int63_inclusive let quickcheck_generator_log_incl = Base_quickcheck.Generator.int63_log_inclusive ;; end); [%expect {| (testing Up) (testing Down) (testing Zero) (testing Nearest) |}] ;; let%expect_test "int64" = test (module struct include Int64 let quickcheck_generator_incl = Base_quickcheck.Generator.int64_inclusive let quickcheck_generator_log_incl = Base_quickcheck.Generator.int64_log_inclusive ;; end); [%expect {| (testing Up) (testing Down) (testing Zero) (testing Nearest) |}] ;; let%expect_test ("nativeint" [@tags "no-js", "64-bits-only"]) = test (module struct include Nativeint let quickcheck_generator_incl = Base_quickcheck.Generator.nativeint_inclusive let quickcheck_generator_log_incl = Base_quickcheck.Generator.nativeint_log_inclusive ;; end); [%expect {| (testing Up) (testing Down) (testing Zero) (testing Nearest) |}] ;; end) ;; let%test_module "pow" = (module struct let%test _ = int_pow 0 0 = 1 let%test _ = int_pow 0 1 = 0 let%test _ = int_pow 10 1 = 10 let%test _ = int_pow 10 2 = 100 let%test _ = int_pow 10 3 = 1_000 let%test _ = int_pow 10 4 = 10_000 let%test _ = int_pow 10 5 = 100_000 let%test _ = int_pow 2 10 = 1024 let%test _ = int_pow 0 1_000_000 = 0 let%test _ = int_pow 1 1_000_000 = 1 let%test _ = int_pow (-1) 1_000_000 = 1 let%test _ = int_pow (-1) 1_000_001 = -1 let ( = ) = Int64.( = ) let%test _ = int64_pow 0L 0L = 1L let%test _ = int64_pow 0L 1_000_000L = 0L let%test _ = int64_pow 1L 1_000_000L = 1L let%test _ = int64_pow (-1L) 1_000_000L = 1L let%test _ = int64_pow (-1L) 1_000_001L = -1L let%test _ = int64_pow 10L 1L = 10L let%test _ = int64_pow 10L 2L = 100L let%test _ = int64_pow 10L 3L = 1_000L let%test _ = int64_pow 10L 4L = 10_000L let%test _ = int64_pow 10L 5L = 100_000L let%test _ = int64_pow 2L 10L = 1_024L let%test _ = int64_pow 5L 27L = 7450580596923828125L let exception_thrown pow b e = Exn.does_raise (fun () -> pow b e) let%test _ = exception_thrown int_pow 10 60 let%test _ = exception_thrown int64_pow 10L 60L let%test _ = exception_thrown int_pow 10 (-1) let%test _ = exception_thrown int64_pow 10L (-1L) let%test _ = exception_thrown int64_pow 2L 63L let%test _ = not (exception_thrown int64_pow 2L 62L) let%test _ = exception_thrown int64_pow (-2L) 63L let%test _ = not (exception_thrown int64_pow (-2L) 62L) end) ;; let%test_module "overflow_bounds" = (module struct module Pow_overflow_bounds = Pow_overflow_bounds let%test _ = Int.equal Pow_overflow_bounds.overflow_bound_max_int_value Int.max_value let%test _ = Int64.equal Pow_overflow_bounds.overflow_bound_max_int64_value Int64.max_value ;; module Big_int = struct include Big_int let ( > ) = gt_big_int let ( = ) = eq_big_int let ( ^ ) = power_big_int_positive_int let ( + ) = add_big_int let one = unit_big_int let to_string = string_of_big_int end let test_overflow_table tbl conv max_val = assert (Array.length tbl = 64); let max_val = conv max_val in Array.iteri tbl ~f:(fun i max_base -> let max_base = conv max_base in let overflows b = Big_int.(b ^ i > max_val) in let is_ok = if i = 0 then Big_int.(max_base = max_val) else (not (overflows max_base)) && overflows Big_int.(max_base + one) in if not is_ok then Printf.failwithf "overflow table check failed for %s (index %d)" (Big_int.to_string max_base) i ()) ;; let%test_unit _ = test_overflow_table Pow_overflow_bounds.int_positive_overflow_bounds Big_int.big_int_of_int Int.max_value ;; let%test_unit _ = test_overflow_table Pow_overflow_bounds.int64_positive_overflow_bounds Big_int.big_int_of_int64 Int64.max_value ;; end) ;; base-0.16.3/test/test_int_math.mli000066400000000000000000000000551446274340700170520ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_int_pow2.ml000066400000000000000000000060061446274340700166410ustar00rootroot00000000000000open! Import open! Int let examples = [ -1; 0; 1; 2; 3; 4; 5; 7; 8; 9; 63; 64; 65 ] let examples_64_bit = [ Int.min_value; Int.min_value + 1; Int.max_value - 1; Int.max_value ] ;; let print_for ints f = List.iter ints ~f:(fun i -> print_s [%message "" ~_:(i : int) ~_:(Or_error.try_with (fun () -> f i) : int Or_error.t)]) ;; let%expect_test "[floor_log2]" = print_for examples floor_log2; [%expect {| (-1 (Error ("[Int.floor_log2] got invalid input" -1))) (0 (Error ("[Int.floor_log2] got invalid input" 0))) (1 (Ok 0)) (2 (Ok 1)) (3 (Ok 1)) (4 (Ok 2)) (5 (Ok 2)) (7 (Ok 2)) (8 (Ok 3)) (9 (Ok 3)) (63 (Ok 5)) (64 (Ok 6)) (65 (Ok 6)) |}] ;; let%expect_test ("[floor_log2]" [@tags "64-bits-only"]) = print_for examples_64_bit floor_log2; [%expect {| (-4_611_686_018_427_387_904 ( Error ("[Int.floor_log2] got invalid input" -4611686018427387904))) (-4_611_686_018_427_387_903 ( Error ("[Int.floor_log2] got invalid input" -4611686018427387903))) (4_611_686_018_427_387_902 (Ok 61)) (4_611_686_018_427_387_903 (Ok 61)) |}] ;; let%expect_test "[ceil_log2]" = print_for examples ceil_log2; [%expect {| (-1 (Error ("[Int.ceil_log2] got invalid input" -1))) (0 (Error ("[Int.ceil_log2] got invalid input" 0))) (1 (Ok 0)) (2 (Ok 1)) (3 (Ok 2)) (4 (Ok 2)) (5 (Ok 3)) (7 (Ok 3)) (8 (Ok 3)) (9 (Ok 4)) (63 (Ok 6)) (64 (Ok 6)) (65 (Ok 7)) |}] ;; let%expect_test ("[ceil_log2]" [@tags "64-bits-only"]) = print_for examples_64_bit ceil_log2; [%expect {| (-4_611_686_018_427_387_904 ( Error ("[Int.ceil_log2] got invalid input" -4611686018427387904))) (-4_611_686_018_427_387_903 ( Error ("[Int.ceil_log2] got invalid input" -4611686018427387903))) (4_611_686_018_427_387_902 (Ok 62)) (4_611_686_018_427_387_903 (Ok 62)) |}] ;; let%test_module "int_math" = (module struct let test_cases () = let cases = [ 0b10101010 ; 0b1010101010101010 ; 0b101010101010101010101010 ; 0b10000000 ; 0b1000000000001000 ; 0b100000000000000000001000 ] in match Word_size.word_size with | W64 -> (* create some >32 bit values... *) (* We can't use literals directly because the compiler complains on 32 bits. *) let cases = cases @ [ (0b1010101010101010 lsl 16) lor 0b1010101010101010 ; (0b1000000000000000 lsl 16) lor 0b0000000000001000 ] in let added_cases = List.map cases ~f:(fun x -> x lsl 16) in List.concat [ cases; added_cases ] | W32 -> cases ;; let%test_unit "ceil_pow2" = List.iter (test_cases ()) ~f:(fun x -> let p2 = ceil_pow2 x in assert (is_pow2 p2 && p2 >= x && x >= p2 / 2)) ;; let%test_unit "floor_pow2" = List.iter (test_cases ()) ~f:(fun x -> let p2 = floor_pow2 x in assert (is_pow2 p2 && 2 * p2 >= x && x >= p2)) ;; end) ;; base-0.16.3/test/test_int_pow2.mli000066400000000000000000000000551446274340700170100ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_lazy.ml000066400000000000000000000042471446274340700160640ustar00rootroot00000000000000open! Import open! Lazy let%test_unit _ = let r = ref 0 in let t = return () >>= fun () -> Int.incr r; return () in assert (!r = 0); force t; assert (!r = 1); force t; assert (!r = 1) ;; let%test_unit _ = let r = ref 0 in let t = return () >>= fun () -> lazy (Int.incr r) in assert (!r = 0); force t; assert (!r = 1); force t; assert (!r = 1) ;; let%expect_test "peek" = let t = lazy (print_endline "force t"; "forced") in print_s [%sexp (peek t : string option)]; [%expect {| () |}]; ignore (force t : string); [%expect {| force t |}]; print_s [%sexp (peek t : string option)]; [%expect {| (forced) |}] ;; let%test_module _ = (module struct module M1 = struct type nonrec t = { x : int t } [@@deriving sexp_of] end module M2 = struct type t = { x : int T_unforcing.t } [@@deriving sexp_of] end let%test_unit _ = let v = lazy 42 in let (_ : int) = (* no needed, but the purpose of this test is not to test this compiler optimization *) force v in assert (is_val v); let t1 = { M1.x = v } in let t2 = { M2.x = v } in assert (Sexp.equal (M1.sexp_of_t t1) (M2.sexp_of_t t2)) ;; let%test_unit _ = let t1 = { M1.x = lazy (40 + 2) } in let t2 = { M2.x = lazy (40 + 2) } in assert (not (Sexp.equal (M1.sexp_of_t t1) (M2.sexp_of_t t2))); assert (is_val t1.x); assert (not (is_val t2.x)) ;; end) ;; let%expect_test "equal" = let lazy_a = lazy (print_endline "force lazy_a"; 1) in let lazy_b = lazy (print_endline "force lazy_b"; 1) in let lazy_c = lazy (print_endline "force lazy_c"; 2) in (* [phys_equal] short-circuiting without [force] *) print_s [%sexp (equal Int.equal lazy_a lazy_a : bool)]; [%expect {| true |}]; (* [force], resulting in [true] *) print_s [%sexp (equal Int.equal lazy_a lazy_b : bool)]; [%expect {| force lazy_b force lazy_a true |}]; (* [force], resulting in [false] *) print_s [%sexp (equal Int.equal lazy_b lazy_c : bool)]; [%expect {| force lazy_c false |}] ;; base-0.16.3/test/test_lazy.mli000066400000000000000000000000551446274340700162260ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_list.ml000066400000000000000000001157341446274340700160640ustar00rootroot00000000000000open! Import open! List let%expect_test "find_exn" = let show f sexp_of_ok = print_s [%sexp (Result.try_with f : (ok, exn) Result.t)] in let test list = show (fun () -> List.find_exn list ~f:Int.is_negative) [%sexp_of: int] in test []; [%expect {| (Error (Not_found_s "List.find_exn: not found")) |}]; test [ 1; 2; 3 ]; [%expect {| (Error (Not_found_s "List.find_exn: not found")) |}]; test [ -1; -2; -3 ]; [%expect {| (Ok -1) |}]; test [ 1; -2; -3 ]; [%expect {| (Ok -2) |}] ;; let%test_module "reduce_balanced" = (module struct let test expect list = [%test_result: string option] ~expect (reduce_balanced ~f:(fun a b -> "(" ^ a ^ "+" ^ b ^ ")") list) ;; let%test_unit "length 0" = test None [] let%test_unit "length 1" = test (Some "a") [ "a" ] let%test_unit "length 2" = test (Some "(a+b)") [ "a"; "b" ] let%test_unit "length 6" = test (Some "(((a+b)+(c+d))+(e+f))") [ "a"; "b"; "c"; "d"; "e"; "f" ] ;; let%test_unit "longer" = (* pairs (index, number of times f called on me) to check: 1. f called on results in index order 2. total number of calls on any element is low called on 2^n + 1 to demonstrate lack of balance (most elements are distance 7 from the tree root, but one is distance 1) *) let data = map (range 0 65) ~f:(fun i -> [ i, 0 ]) in let f x y = map (x @ y) ~f:(fun (ix, cx) -> ix, cx + 1) in match reduce_balanced data ~f with | None -> failwith "None" | Some l -> [%test_result: int] ~expect:65 (List.length l); iteri l ~f:(fun actual_index (computed_index, num_f) -> let expected_num_f = if actual_index = 64 then 1 else 7 in [%test_result: int * int] ~expect:(actual_index, expected_num_f) (computed_index, num_f)) ;; end) ;; let%test_module "range symmetries" = (module struct let basic ~stride ~start ~stop ~start_n ~stop_n ~result = [%compare.equal: int t] (range ~stride ~start ~stop start_n stop_n) result ;; let test stride (start_n, start) (stop_n, stop) result = basic ~stride ~start ~stop ~start_n ~stop_n ~result && (* works for negative [start] and [stop] *) basic ~stride:(-stride) ~start_n:(-start_n) ~stop_n:(-stop_n) ~start ~stop ~result:(List.map result ~f:(fun x -> -x)) ;; let%test _ = test 1 (3, `inclusive) (1, `exclusive) [] let%test _ = test 1 (3, `inclusive) (3, `exclusive) [] let%test _ = test 1 (3, `inclusive) (4, `exclusive) [ 3 ] let%test _ = test 1 (3, `inclusive) (8, `exclusive) [ 3; 4; 5; 6; 7 ] let%test _ = test 3 (4, `inclusive) (10, `exclusive) [ 4; 7 ] let%test _ = test 3 (4, `inclusive) (11, `exclusive) [ 4; 7; 10 ] let%test _ = test 3 (4, `inclusive) (12, `exclusive) [ 4; 7; 10 ] let%test _ = test 3 (4, `inclusive) (13, `exclusive) [ 4; 7; 10 ] let%test _ = test 3 (4, `inclusive) (14, `exclusive) [ 4; 7; 10; 13 ] let%test _ = test (-1) (1, `inclusive) (3, `exclusive) [] let%test _ = test (-1) (3, `inclusive) (3, `exclusive) [] let%test _ = test (-1) (4, `inclusive) (3, `exclusive) [ 4 ] let%test _ = test (-1) (8, `inclusive) (3, `exclusive) [ 8; 7; 6; 5; 4 ] let%test _ = test (-3) (10, `inclusive) (4, `exclusive) [ 10; 7 ] let%test _ = test (-3) (10, `inclusive) (3, `exclusive) [ 10; 7; 4 ] let%test _ = test (-3) (10, `inclusive) (2, `exclusive) [ 10; 7; 4 ] let%test _ = test (-3) (10, `inclusive) (1, `exclusive) [ 10; 7; 4 ] let%test _ = test (-3) (10, `inclusive) (0, `exclusive) [ 10; 7; 4; 1 ] let%test _ = test 1 (3, `exclusive) (1, `exclusive) [] let%test _ = test 1 (3, `exclusive) (3, `exclusive) [] let%test _ = test 1 (3, `exclusive) (4, `exclusive) [] let%test _ = test 1 (3, `exclusive) (8, `exclusive) [ 4; 5; 6; 7 ] let%test _ = test 3 (4, `exclusive) (10, `exclusive) [ 7 ] let%test _ = test 3 (4, `exclusive) (11, `exclusive) [ 7; 10 ] let%test _ = test 3 (4, `exclusive) (12, `exclusive) [ 7; 10 ] let%test _ = test 3 (4, `exclusive) (13, `exclusive) [ 7; 10 ] let%test _ = test 3 (4, `exclusive) (14, `exclusive) [ 7; 10; 13 ] let%test _ = test (-1) (1, `exclusive) (3, `exclusive) [] let%test _ = test (-1) (3, `exclusive) (3, `exclusive) [] let%test _ = test (-1) (4, `exclusive) (3, `exclusive) [] let%test _ = test (-1) (8, `exclusive) (3, `exclusive) [ 7; 6; 5; 4 ] let%test _ = test (-3) (10, `exclusive) (4, `exclusive) [ 7 ] let%test _ = test (-3) (10, `exclusive) (3, `exclusive) [ 7; 4 ] let%test _ = test (-3) (10, `exclusive) (2, `exclusive) [ 7; 4 ] let%test _ = test (-3) (10, `exclusive) (1, `exclusive) [ 7; 4 ] let%test _ = test (-3) (10, `exclusive) (0, `exclusive) [ 7; 4; 1 ] let%test _ = test 1 (3, `inclusive) (1, `inclusive) [] let%test _ = test 1 (3, `inclusive) (3, `inclusive) [ 3 ] let%test _ = test 1 (3, `inclusive) (4, `inclusive) [ 3; 4 ] let%test _ = test 1 (3, `inclusive) (8, `inclusive) [ 3; 4; 5; 6; 7; 8 ] let%test _ = test 3 (4, `inclusive) (10, `inclusive) [ 4; 7; 10 ] let%test _ = test 3 (4, `inclusive) (11, `inclusive) [ 4; 7; 10 ] let%test _ = test 3 (4, `inclusive) (12, `inclusive) [ 4; 7; 10 ] let%test _ = test 3 (4, `inclusive) (13, `inclusive) [ 4; 7; 10; 13 ] let%test _ = test 3 (4, `inclusive) (14, `inclusive) [ 4; 7; 10; 13 ] let%test _ = test (-1) (1, `inclusive) (3, `inclusive) [] let%test _ = test (-1) (3, `inclusive) (3, `inclusive) [ 3 ] let%test _ = test (-1) (4, `inclusive) (3, `inclusive) [ 4; 3 ] let%test _ = test (-1) (8, `inclusive) (3, `inclusive) [ 8; 7; 6; 5; 4; 3 ] let%test _ = test (-3) (10, `inclusive) (4, `inclusive) [ 10; 7; 4 ] let%test _ = test (-3) (10, `inclusive) (3, `inclusive) [ 10; 7; 4 ] let%test _ = test (-3) (10, `inclusive) (2, `inclusive) [ 10; 7; 4 ] let%test _ = test (-3) (10, `inclusive) (1, `inclusive) [ 10; 7; 4; 1 ] let%test _ = test (-3) (10, `inclusive) (0, `inclusive) [ 10; 7; 4; 1 ] let%test _ = test 1 (3, `exclusive) (1, `inclusive) [] let%test _ = test 1 (3, `exclusive) (3, `inclusive) [] let%test _ = test 1 (3, `exclusive) (4, `inclusive) [ 4 ] let%test _ = test 1 (3, `exclusive) (8, `inclusive) [ 4; 5; 6; 7; 8 ] let%test _ = test 3 (4, `exclusive) (10, `inclusive) [ 7; 10 ] let%test _ = test 3 (4, `exclusive) (11, `inclusive) [ 7; 10 ] let%test _ = test 3 (4, `exclusive) (12, `inclusive) [ 7; 10 ] let%test _ = test 3 (4, `exclusive) (13, `inclusive) [ 7; 10; 13 ] let%test _ = test 3 (4, `exclusive) (14, `inclusive) [ 7; 10; 13 ] let%test _ = test (-1) (1, `exclusive) (3, `inclusive) [] let%test _ = test (-1) (3, `exclusive) (3, `inclusive) [] let%test _ = test (-1) (4, `exclusive) (3, `inclusive) [ 3 ] let%test _ = test (-1) (8, `exclusive) (3, `inclusive) [ 7; 6; 5; 4; 3 ] let%test _ = test (-3) (10, `exclusive) (4, `inclusive) [ 7; 4 ] let%test _ = test (-3) (10, `exclusive) (3, `inclusive) [ 7; 4 ] let%test _ = test (-3) (10, `exclusive) (2, `inclusive) [ 7; 4 ] let%test _ = test (-3) (10, `exclusive) (1, `inclusive) [ 7; 4; 1 ] let%test _ = test (-3) (10, `exclusive) (0, `inclusive) [ 7; 4; 1 ] let test_start_inc_exc stride start (stop, stop_inc_exc) result = test stride (start, `inclusive) (stop, stop_inc_exc) result && match result with | [] -> true | head :: tail -> head = start && test stride (start, `exclusive) (stop, stop_inc_exc) tail ;; let test_inc_exc stride start stop result = test_start_inc_exc stride start (stop, `inclusive) result && match List.rev result with | [] -> true | last :: all_but_last -> let all_but_last = List.rev all_but_last in if last = stop then test_start_inc_exc stride start (stop, `exclusive) all_but_last else true ;; let%test _ = test_inc_exc 1 4 10 [ 4; 5; 6; 7; 8; 9; 10 ] let%test _ = test_inc_exc 3 4 10 [ 4; 7; 10 ] let%test _ = test_inc_exc 3 4 11 [ 4; 7; 10 ] let%test _ = test_inc_exc 3 4 12 [ 4; 7; 10 ] let%test _ = test_inc_exc 3 4 13 [ 4; 7; 10; 13 ] let%test _ = test_inc_exc 3 4 14 [ 4; 7; 10; 13 ] end) ;; module Test_values = struct let long1 = let v = lazy (range 1 100_000) in fun () -> Lazy.force v ;; let long2 = let v = lazy (range 2 100_001) in fun () -> Lazy.force v ;; let l1 = [ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ] end let%test_unit _ = [%test_result: int list] (rev_append [ 1; 2; 3 ] [ 4; 5; 6 ]) ~expect:[ 3; 2; 1; 4; 5; 6 ] ;; let%test_unit _ = [%test_result: int list] (rev_append [] [ 4; 5; 6 ]) ~expect:[ 4; 5; 6 ] let%test_unit _ = [%test_result: int list] (rev_append [ 1; 2; 3 ] []) ~expect:[ 3; 2; 1 ] let%test_unit _ = [%test_result: int list] (rev_append [ 1 ] [ 2; 3 ]) ~expect:[ 1; 2; 3 ] let%test_unit _ = [%test_result: int list] (rev_append [ 1; 2 ] [ 3 ]) ~expect:[ 2; 1; 3 ] let%test_unit _ = let long = Test_values.long1 () in ignore (rev_append long long : int list) ;; let%test_unit _ = let long1 = Test_values.long1 () in let long2 = Test_values.long2 () in [%test_result: int list] (map long1 ~f:(fun x -> x + 1)) ~expect:long2 ;; let test_ordering n = let l = List.range 0 n in let r = ref [] in let (_ : unit list) = List.map l ~f:(fun x -> r := x :: !r) in [%test_eq: int list] l (List.rev !r) ;; let%test_unit _ = test_ordering 10 let%test_unit _ = test_ordering 1000 let%test_unit _ = test_ordering 1_000_000 let%test _ = for_all2_exn [] [] ~f:(fun _ _ -> assert false) let%test_unit _ = [%test_result: int option] (find_mapi [ 0; 5; 2; 1; 4 ] ~f:(fun i x -> if i = x then Some (i + x) else None)) ~expect:(Some 0) ;; let%test_unit _ = [%test_result: int option] (find_mapi [ 3; 5; 2; 1; 4 ] ~f:(fun i x -> if i = x then Some (i + x) else None)) ~expect:(Some 4) ;; let%test_unit _ = [%test_result: int option] (find_mapi [ 3; 5; 1; 1; 4 ] ~f:(fun i x -> if i = x then Some (i + x) else None)) ~expect:(Some 8) ;; let%test_unit _ = [%test_result: int option] (find_mapi [ 3; 5; 1; 1; 2 ] ~f:(fun i x -> if i = x then Some (i + x) else None)) ~expect:None ;; let%test_unit _ = [%test_result: bool] (for_alli [] ~f:(fun _ _ -> false)) ~expect:true let%test_unit _ = [%test_result: bool] (for_alli [ 0; 1; 2; 3 ] ~f:(fun i x -> i = x)) ~expect:true ;; let%test_unit _ = [%test_result: bool] (for_alli [ 0; 1; 3; 3 ] ~f:(fun i x -> i = x)) ~expect:false ;; let%test_unit _ = [%test_result: bool] (existsi [] ~f:(fun _ _ -> true)) ~expect:false let%test_unit _ = [%test_result: bool] (existsi [ 0; 1; 2; 3 ] ~f:(fun i x -> i <> x)) ~expect:false ;; let%test_unit _ = [%test_result: bool] (existsi [ 0; 1; 3; 3 ] ~f:(fun i x -> i <> x)) ~expect:true ;; let%test_unit _ = [%test_result: int list] (append [ 1; 2; 3 ] [ 4; 5; 6 ]) ~expect:[ 1; 2; 3; 4; 5; 6 ] ;; let%test_unit _ = [%test_result: int list] (append [] [ 4; 5; 6 ]) ~expect:[ 4; 5; 6 ] let%test_unit _ = [%test_result: int list] (append [ 1; 2; 3 ] []) ~expect:[ 1; 2; 3 ] let%test_unit _ = [%test_result: int list] (append [ 1 ] [ 2; 3 ]) ~expect:[ 1; 2; 3 ] let%test_unit _ = [%test_result: int list] (append [ 1; 2 ] [ 3 ]) ~expect:[ 1; 2; 3 ] let%test_unit _ = let long = Test_values.long1 () in ignore (append long long : int list) ;; let%test_unit _ = [%test_result: int list] (map ~f:Fn.id Test_values.l1) ~expect:Test_values.l1 ;; let%test_unit _ = [%test_result: int list] (map ~f:Fn.id []) ~expect:[] let%test_unit _ = [%test_result: float list] (map ~f:(fun x -> x +. 5.) [ 1.; 2.; 3. ]) ~expect:[ 6.; 7.; 8. ] ;; let%test_unit _ = ignore (map ~f:Fn.id (Test_values.long1 ()) : int list) let%test_unit _ = [%test_result: (int * char) list] (map2_exn ~f:(fun a b -> a, b) [ 1; 2; 3 ] [ 'a'; 'b'; 'c' ]) ~expect:[ 1, 'a'; 2, 'b'; 3, 'c' ] ;; let%test_unit _ = [%test_result: _ list] (map2_exn ~f:(fun _ _ -> ()) [] []) ~expect:[] let%test_unit _ = let long = Test_values.long1 () in ignore (map2_exn ~f:(fun _ _ -> ()) long long : unit list) ;; let%test_unit _ = [%test_result: int list] (rev_map_append [ 1; 2; 3; 4; 5 ] [ 6 ] ~f:Fn.id) ~expect:[ 5; 4; 3; 2; 1; 6 ] ;; let%test_unit _ = [%test_result: int list] (rev_map_append [ 1; 2; 3; 4; 5 ] [ 6 ] ~f:(fun x -> 2 * x)) ~expect:[ 10; 8; 6; 4; 2; 6 ] ;; let%test_unit _ = [%test_result: int list] (rev_map_append [] [ 6 ] ~f:(fun _ -> failwith "bug!")) ~expect:[ 6 ] ;; let%test_unit _ = [%test_result: int list] (fold_right ~f:(fun e acc -> e :: acc) Test_values.l1 ~init:[]) ~expect:Test_values.l1 ;; let%test_unit _ = [%test_result: string] (fold_right ~f:(fun e acc -> e ^ acc) [ "1"; "2" ] ~init:"3") ~expect:"123" ;; let%test_unit _ = [%test_result: unit] (fold_right ~f:(fun _ _ -> ()) [] ~init:()) ~expect:() ;; let%test_unit _ = let long = Test_values.long1 () in ignore (fold_right ~f:(fun e acc -> e :: acc) long ~init:[] : int list) ;; let%test_unit _ = [%test_result: string] (fold_right2_exn ~f:(fun e1 e2 acc -> e1 ^ e2 ^ acc) [ "1"; "2" ] [ "a"; "b" ] ~init:"3c") ~expect:"1a2b3c" ;; let%test_unit _ = [%test_result: string Or_unequal_lengths.t] (fold_right2 ~f:(fun e1 e2 acc -> e1 ^ e2 ^ acc) [ "1"; "2" ] [ "a"; "b"; "c" ] ~init:"#") ~expect:Or_unequal_lengths.Unequal_lengths ;; let%test_unit _ = let l1 = Test_values.l1 in [%test_result: int list * int list] (unzip (zip_exn l1 (List.rev l1))) ~expect:(l1, List.rev l1) ;; let%test_unit _ = let long = Test_values.long1 () in ignore (unzip (zip_exn long long) : int list * int list) ;; let%test_unit _ = [%test_result: int list * int list] (unzip [ 1, 2; 4, 5 ]) ~expect:([ 1; 4 ], [ 2; 5 ]) ;; let%test_unit _ = [%test_result: int list * int list * int list] (unzip3 [ 1, 2, 3; 4, 5, 6 ]) ~expect:([ 1; 4 ], [ 2; 5 ], [ 3; 6 ]) ;; let%test_unit _ = [%test_result: (int * int) list Or_unequal_lengths.t] (zip [ 1; 2; 3 ] [ 4; 5; 6 ]) ~expect:(Ok [ 1, 4; 2, 5; 3, 6 ]) ;; let%test_unit _ = [%test_result: (int * int) list Or_unequal_lengths.t] (zip [ 1 ] [ 4; 5; 6 ]) ~expect:Unequal_lengths ;; let%test_unit _ = [%test_result: (int * int) list] (zip_exn [ 1; 2; 3 ] [ 4; 5; 6 ]) ~expect:[ 1, 4; 2, 5; 3, 6 ] ;; let%expect_test _ = show_raise (fun () -> zip_exn [ 1 ] [ 4; 5; 6 ]); [%expect {| (raised (Invalid_argument "length mismatch in zip_exn: 1 <> 3")) |}] ;; let%expect_test _ = show_raise (fun () -> rev_map3_exn [ 1 ] [ 4; 5; 6 ] [ 2; 3 ] ~f:(fun a b c -> a + b + c)); [%expect {| (raised (Invalid_argument "length mismatch in rev_map3_exn: 1 <> 3 || 3 <> 2")) |}] ;; let%test_unit _ = [%test_result: (int * string) list] (mapi ~f:(fun i x -> i, x) [ "one"; "two"; "three"; "four" ]) ~expect:[ 0, "one"; 1, "two"; 2, "three"; 3, "four" ] ;; let%test_unit _ = [%test_result: (int * _) list] (mapi ~f:(fun i x -> i, x) []) ~expect:[] let%test_module "group" = (module struct let%test_unit _ = [%test_result: int list list] (group [ 1; 2; 3; 4 ] ~break:(fun _ x -> x = 3)) ~expect:[ [ 1; 2 ]; [ 3; 4 ] ] ;; let%test_unit _ = [%test_result: int list list] (group [] ~break:(fun _ -> assert false)) ~expect:[] ;; let mis = [ 'M'; 'i'; 's'; 's'; 'i'; 's'; 's'; 'i'; 'p'; 'p'; 'i' ] let equal_letters = [ [ 'M' ] ; [ 'i' ] ; [ 's'; 's' ] ; [ 'i' ] ; [ 's'; 's' ] ; [ 'i' ] ; [ 'p'; 'p' ] ; [ 'i' ] ] ;; let single_letters = [ [ 'M'; 'i'; 's'; 's'; 'i'; 's'; 's'; 'i'; 'p'; 'p'; 'i' ] ] let every_three = [ [ 'M'; 'i'; 's' ]; [ 's'; 'i'; 's' ]; [ 's'; 'i'; 'p' ]; [ 'p'; 'i' ] ] ;; let%test_unit _ = [%test_result: char list list] (group ~break:Char.( <> ) mis) ~expect:equal_letters ;; let%test_unit _ = [%test_result: char list list] (group ~break:(fun _ _ -> false) mis) ~expect:single_letters ;; let%test_unit _ = [%test_result: char list list] (groupi ~break:(fun i _ _ -> i % 3 = 0) mis) ~expect:every_three ;; end) ;; let%test_module "sort_and_group" = (module struct let%expect_test _ = let compare a b = Comparable.lift String.compare ~f:(fun s -> String.rstrip ~drop:Char.is_digit s) a b in [%test_result: string list list] (sort_and_group [ "b1"; "c1"; "a1"; "a2"; "b2"; "a3" ] ~compare) ~expect:[ [ "a1"; "a2"; "a3" ]; [ "b1"; "b2" ]; [ "c1" ] ] ;; end) ;; let%test_module "Assoc.group" = (module struct let%expect_test _ = let test alist = let multi = Assoc.group alist ~equal:String.Caseless.equal in print_s [%sexp (multi : (string * int list) list)]; let round_trip = List.concat_map multi ~f:(fun (key, data) -> List.map data ~f:(fun datum -> key, datum)) in require_equal [%here] (module struct type t = (String.Caseless.t * int) list [@@deriving equal, sexp_of] end) alist round_trip in test []; [%expect {| () |}]; test [ "a", 1; "A", 2 ]; [%expect {| ((a (1 2))) |}]; test [ "a", 1; "b", 2 ]; [%expect {| ((a (1)) (b (2))) |}]; test [ "odd", 1; "even", 2; "Odd", 3; "Even", 4; "ODD", 5; "EVEN", 6 ]; [%expect {| ((odd (1)) (even (2)) (Odd (3)) (Even (4)) (ODD (5)) (EVEN (6))) |}]; test [ "odd", 1; "Odd", 3; "ODD", 5; "even", 2; "Even", 4; "EVEN", 6 ]; [%expect {| ((odd (1 3 5)) (even (2 4 6))) |}] ;; end) ;; let%test_module "Assoc.sort_and_group" = (module struct let%expect_test _ = let test alist = let multi = Assoc.sort_and_group alist ~compare:String.Caseless.compare in print_s [%sexp (multi : (string * int list) list)]; require_equal [%here] (module struct type t = (string * int list) list [@@deriving equal, sexp_of] end) multi (Map.to_alist (Map.of_alist_multi (module String.Caseless) alist)) in test []; [%expect {| () |}]; test [ "a", 1; "A", 2 ]; [%expect {| ((a (1 2))) |}]; test [ "a", 1; "b", 2 ]; [%expect {| ((a (1)) (b (2))) |}]; test [ "odd", 1; "even", 2; "Odd", 3; "Even", 4; "ODD", 5; "EVEN", 6 ]; [%expect {| ((even (2 4 6)) (odd (1 3 5))) |}] ;; end) ;; let%test_module "chunks_of" = (module struct let test length break_every = let l = List.init length ~f:Fn.id in let b = chunks_of l ~length:break_every in [%test_eq: int list] (List.concat b) l; List.iter b ~f:([%test_pred: int list] (fun batch -> List.length batch <= break_every)) ;; let expect_exn length break_every = match test length break_every with | exception _ -> () | () -> raise_s [%message "Didn't raise." (length : int) (break_every : int)] ;; let%test_unit _ = for n = 0 to 10 do for k = n + 2 downto 1 do test n k done done; expect_exn 1 0; expect_exn 1 (-1) ;; let%test_unit _ = [%test_result: _ list list] (chunks_of [] ~length:1) ~expect:[] end) ;; let%test _ = last_exn [ 1; 2; 3 ] = 3 let%test _ = last_exn [ 1 ] = 1 let%test _ = last_exn (Test_values.long1 ()) = 99_999 let%test _ = is_prefix [] ~prefix:[] ~equal:( = ) let%test _ = is_prefix [ 1 ] ~prefix:[] ~equal:( = ) let%test _ = is_prefix [ 1 ] ~prefix:[ 1 ] ~equal:( = ) let%test _ = not (is_prefix [ 1 ] ~prefix:[ 1; 2 ] ~equal:( = )) let%test _ = not (is_prefix [ 1; 3 ] ~prefix:[ 1; 2 ] ~equal:( = )) let%test _ = is_prefix [ 1; 2; 3 ] ~prefix:[ 1; 2 ] ~equal:( = ) let%test _ = is_suffix [] ~suffix:[] ~equal:( = ) let%test _ = is_suffix [ 1 ] ~suffix:[] ~equal:( = ) let%test _ = is_suffix [ 1 ] ~suffix:[ 1 ] ~equal:( = ) let%test _ = not (is_suffix [ 1 ] ~suffix:[ 1; 2 ] ~equal:( = )) let%test _ = not (is_suffix [ 1; 3 ] ~suffix:[ 1; 2 ] ~equal:( = )) let%test _ = is_suffix [ 1; 2; 3 ] ~suffix:[ 2; 3 ] ~equal:( = ) let%test_unit _ = List.iter ~f:(fun (t, expect) -> assert (Poly.equal expect (find_consecutive_duplicate t ~equal:Poly.equal))) [ [], None ; [ 1 ], None ; [ 1; 1 ], Some (1, 1) ; [ 1; 2 ], None ; [ 1; 2; 1 ], None ; [ 1; 2; 2 ], Some (2, 2) ; [ 1; 1; 2; 2 ], Some (1, 1) ] ;; let%test_unit _ = [%test_result: ((int * char) * (int * char)) option] (find_consecutive_duplicate [ 0, 'a'; 1, 'b'; 2, 'b' ] ~equal:(fun (_, a) (_, b) -> Char.( = ) a b)) ~expect:(Some ((1, 'b'), (2, 'b'))) ;; let%test_unit _ = [%test_result: int list] (remove_consecutive_duplicates ~which_to_keep:`Last [] ~equal:Int.( = )) ~expect:[] ;; let%test_unit _ = [%test_result: int list] (remove_consecutive_duplicates ~which_to_keep:`Last [ 5; 5; 5; 5; 5 ] ~equal:Int.( = )) ~expect:[ 5 ] ;; let%test_unit _ = [%test_result: int list] (remove_consecutive_duplicates ~which_to_keep:`Last [ 5; 6; 5; 6; 5; 6 ] ~equal:Int.( = )) ~expect:[ 5; 6; 5; 6; 5; 6 ] ;; let%test_unit _ = [%test_result: int list] (remove_consecutive_duplicates ~which_to_keep:`Last [ 5; 5; 6; 6; 5; 5; 8; 8 ] ~equal:Int.( = )) ~expect:[ 5; 6; 5; 8 ] ;; let%test_unit _ = [%test_result: (int * int) list] (remove_consecutive_duplicates ~which_to_keep:`Last [ 0, 1; 0, 2; 2, 2; 4, 1 ] ~equal:(fun (a, _) (b, _) -> Int.( = ) a b)) ~expect:[ 0, 2; 2, 2; 4, 1 ] ;; let%test_unit _ = [%test_result: (int * int) list] (remove_consecutive_duplicates ~which_to_keep:`Last [ 0, 1; 2, 2; 0, 2; 4, 1 ] ~equal:(fun (a, _) (b, _) -> Int.( = ) a b)) ~expect:[ 0, 1; 2, 2; 0, 2; 4, 1 ] ;; let%test_unit _ = [%test_result: (int * int) list] (remove_consecutive_duplicates ~which_to_keep:`Last [ 0, 1; 2, 1; 0, 2; 4, 2 ] ~equal:(fun (_, a) (_, b) -> Int.( = ) a b)) ~expect:[ 2, 1; 4, 2 ] ;; let%test_unit _ = [%test_result: (int * int) list] (remove_consecutive_duplicates ~which_to_keep:`Last [ 0, 1; 2, 2; 0, 2; 4, 1 ] ~equal:(fun (_, a) (_, b) -> Int.( = ) a b)) ~expect:[ 0, 1; 0, 2; 4, 1 ] ;; let%test_unit _ = [%test_result: int list] (remove_consecutive_duplicates ~which_to_keep:`First [] ~equal:Int.( = )) ~expect:[] ;; let%test_unit _ = [%test_result: int list] (remove_consecutive_duplicates ~which_to_keep:`First [ 5; 5; 5; 5; 5 ] ~equal:Int.( = )) ~expect:[ 5 ] ;; let%test_unit _ = [%test_result: int list] (remove_consecutive_duplicates ~which_to_keep:`First [ 5; 6; 5; 6; 5; 6 ] ~equal:Int.( = )) ~expect:[ 5; 6; 5; 6; 5; 6 ] ;; let%test_unit _ = [%test_result: int list] (remove_consecutive_duplicates ~which_to_keep:`First [ 5; 5; 6; 6; 5; 5; 8; 8 ] ~equal:Int.( = )) ~expect:[ 5; 6; 5; 8 ] ;; let%test_unit _ = [%test_result: (int * int) list] (remove_consecutive_duplicates ~which_to_keep:`First [ 0, 1; 0, 2; 2, 2; 4, 1 ] ~equal:(fun (a, _) (b, _) -> Int.( = ) a b)) ~expect:[ 0, 1; 2, 2; 4, 1 ] ;; let%test_unit _ = [%test_result: (int * int) list] (remove_consecutive_duplicates ~which_to_keep:`First [ 0, 1; 2, 2; 0, 2; 4, 1 ] ~equal:(fun (a, _) (b, _) -> Int.( = ) a b)) ~expect:[ 0, 1; 2, 2; 0, 2; 4, 1 ] ;; let%test_unit _ = [%test_result: (int * int) list] (remove_consecutive_duplicates ~which_to_keep:`First [ 0, 1; 2, 1; 0, 2; 4, 2 ] ~equal:(fun (_, a) (_, b) -> Int.( = ) a b)) ~expect:[ 0, 1; 0, 2 ] ;; let%test_unit _ = [%test_result: (int * int) list] (remove_consecutive_duplicates ~which_to_keep:`First [ 0, 1; 2, 2; 0, 2; 4, 1 ] ~equal:(fun (_, a) (_, b) -> Int.( = ) a b)) ~expect:[ 0, 1; 2, 2; 4, 1 ] ;; let%test_unit _ = [%test_result: int list] (dedup_and_sort ~compare:Int.compare []) ~expect:[] ;; let%test_unit _ = [%test_result: int list] (dedup_and_sort ~compare:Int.compare [ 5; 5; 5; 5; 5 ]) ~expect:[ 5 ] ;; let%test_unit _ = [%test_result: int] (length (dedup_and_sort ~compare:Int.compare [ 2; 1; 5; 3; 4 ])) ~expect:5 ;; let%test_unit _ = [%test_result: int] (length (dedup_and_sort ~compare:Int.compare [ 2; 3; 5; 3; 4 ])) ~expect:4 ;; let%test_unit _ = [%test_result: int] (length (dedup_and_sort [ 0, 1; 2, 2; 0, 2; 4, 1 ] ~compare:(fun (a, _) (b, _) -> Int.compare a b))) ~expect:3 ;; let%test_unit _ = [%test_result: int] (length (dedup_and_sort [ 0, 1; 2, 2; 0, 2; 4, 1 ] ~compare:(fun (_, a) (_, b) -> Int.compare a b))) ~expect:2 ;; let%test_unit _ = [%test_result: int option] (find_a_dup ~compare:Int.compare []) ~expect:None ;; let%test_unit _ = [%test_result: int option] (find_a_dup ~compare:Int.compare [ 3 ]) ~expect:None ;; let%test_unit _ = [%test_result: int option] (find_a_dup ~compare:Int.compare [ 3; 4 ]) ~expect:None ;; let%test_unit _ = [%test_result: int option] (find_a_dup ~compare:Int.compare [ 3; 3 ]) ~expect:(Some 3) ;; let%test_unit _ = [%test_result: int option] (find_a_dup ~compare:Int.compare [ 3; 5; 4; 6; 12 ]) ~expect:None ;; let%test_unit _ = [%test_result: int option] (find_a_dup ~compare:Int.compare [ 3; 5; 4; 5; 12 ]) ~expect:(Some 5) ;; let%test_unit _ = [%test_result: int option] (find_a_dup ~compare:Int.compare [ 3; 5; 12; 5; 12 ]) ~expect:(Some 5) ;; let%test_unit _ = [%test_result: (int * int) option] (find_a_dup ~compare:[%compare: int * int] [ 0, 1; 2, 2; 0, 2; 4, 1 ]) ~expect:None ;; let%test _ = find_a_dup [ 0, 1; 2, 2; 0, 2; 4, 1 ] ~compare:(fun (_, a) (_, b) -> Int.compare a b) |> Option.is_some ;; let%test _ = let dup = find_a_dup [ 0, 1; 2, 2; 0, 2; 4, 1 ] ~compare:(fun (a, _) (b, _) -> Int.compare a b) in match dup with | Some (0, _) -> true | _ -> false ;; let%test_unit _ = [%test_result: bool] (contains_dup ~compare:Int.compare []) ~expect:false ;; let%test_unit _ = [%test_result: bool] (contains_dup ~compare:Int.compare [ 3 ]) ~expect:false ;; let%test_unit _ = [%test_result: bool] (contains_dup ~compare:Int.compare [ 3; 4 ]) ~expect:false ;; let%test_unit _ = [%test_result: bool] (contains_dup ~compare:Int.compare [ 3; 3 ]) ~expect:true ;; let%test_unit _ = [%test_result: bool] (contains_dup ~compare:Int.compare [ 3; 5; 4; 6; 12 ]) ~expect:false ;; let%test_unit _ = [%test_result: bool] (contains_dup ~compare:Int.compare [ 3; 5; 4; 5; 12 ]) ~expect:true ;; let%test_unit _ = [%test_result: bool] (contains_dup ~compare:Int.compare [ 3; 5; 12; 5; 12 ]) ~expect:true ;; let%test_unit _ = [%test_result: bool] (contains_dup ~compare:[%compare: int * int] [ 0, 1; 2, 2; 0, 2; 4, 1 ]) ~expect:false ;; let%test_unit _ = [%test_result: bool] (contains_dup [ 0, 1; 2, 2; 0, 2; 4, 1 ] ~compare:(fun (_, a) (_, b) -> Int.compare a b)) ~expect:true ;; let%test_unit _ = [%test_result: int list] (find_all_dups ~compare:Int.compare []) ~expect:[] ;; let%test_unit _ = [%test_result: int list] (find_all_dups ~compare:Int.compare [ 3 ]) ~expect:[] ;; let%test_unit _ = [%test_result: int list] (find_all_dups ~compare:Int.compare [ 3; 4 ]) ~expect:[] ;; let%test_unit _ = [%test_result: int list] (find_all_dups ~compare:Int.compare [ 3; 3 ]) ~expect:[ 3 ] ;; let%test_unit _ = [%test_result: int list] (find_all_dups ~compare:Int.compare [ 3; 5; 4; 6; 12 ]) ~expect:[] ;; let%test_unit _ = [%test_result: int list] (find_all_dups ~compare:Int.compare [ 3; 5; 4; 5; 12 ]) ~expect:[ 5 ] ;; let%test_unit _ = [%test_result: int list] (find_all_dups ~compare:Int.compare [ 3; 5; 12; 5; 12 ]) ~expect:[ 5; 12 ] ;; let%test_unit _ = [%test_result: (int * int) list] (find_all_dups ~compare:[%compare: int * int] [ 0, 1; 2, 2; 0, 2; 4, 1 ]) ~expect:[] ;; let%test_unit _ = [%test_result: int] (length (find_all_dups [ 0, 1; 2, 2; 0, 2; 4, 1 ] ~compare:(fun (_, a) (_, b) -> Int.compare a b))) ~expect:2 ;; let%test_unit _ = [%test_result: int] (length (find_all_dups [ 0, 1; 2, 2; 0, 2; 4, 1 ] ~compare:(fun (a, _) (b, _) -> Int.compare a b))) ~expect:1 ;; let%test_unit _ = [%test_result: int] (counti [ 0; 1; 2; 3; 4 ] ~f:(fun idx x -> idx = x)) ~expect:5 ;; let%test_unit _ = [%test_result: int] (counti [ 0; 1; 2; 3; 4 ] ~f:(fun idx x -> idx = 4 - x)) ~expect:1 ;; let%test_unit _ = [%test_result: int list] (filter_map ~f:(fun x -> Some x) Test_values.l1) ~expect:Test_values.l1 ;; let%test_unit _ = [%test_result: int list] (filter_map ~f:(fun x -> Some x) []) ~expect:[] let%test_unit _ = [%test_result: int list] (filter_map ~f:(fun _x -> None) [ 1.; 2.; 3. ]) ~expect:[] ;; let%test_unit _ = [%test_result: int list] (filter_map ~f:(fun x -> if x > 0 then Some x else None) [ 1; -1; 3 ]) ~expect:[ 1; 3 ] ;; let%test_unit _ = [%test_result: int list] (filter_mapi ~f:(fun _i x -> Some x) Test_values.l1) ~expect:Test_values.l1 ;; let%test_unit _ = [%test_result: int list] (filter_mapi ~f:(fun _i x -> Some x) []) ~expect:[] ;; let%test_unit _ = [%test_result: int list] (filter_mapi ~f:(fun _i _x -> None) [ 1.; 2.; 3. ]) ~expect:[] ;; let%test_unit _ = [%test_result: int list] (filter_mapi ~f:(fun _i x -> if x > 0 then Some x else None) [ 1; -1; 3 ]) ~expect:[ 1; 3 ] ;; let%test_unit _ = [%test_result: int list] (filter_mapi ~f:(fun i x -> if i % 2 = 0 then Some x else None) [ 1; -1; 3 ]) ~expect:[ 1; 3 ] ;; let%test_unit _ = [%test_result: int list * int list] (split_n [ 1; 2; 3; 4; 5; 6 ] 3) ~expect:([ 1; 2; 3 ], [ 4; 5; 6 ]) ;; let%test_unit _ = [%test_result: int list * int list] (split_n [ 1; 2; 3; 4; 5; 6 ] 100) ~expect:([ 1; 2; 3; 4; 5; 6 ], []) ;; let%test_unit _ = [%test_result: int list * int list] (split_n [ 1; 2; 3; 4; 5; 6 ] 0) ~expect:([], [ 1; 2; 3; 4; 5; 6 ]) ;; let%test_unit _ = [%test_result: int list * int list] (split_n [ 1; 2; 3; 4; 5; 6 ] (-5)) ~expect:([], [ 1; 2; 3; 4; 5; 6 ]) ;; let%test_unit _ = [%test_result: int list] (take [ 1; 2; 3; 4; 5; 6 ] 3) ~expect:[ 1; 2; 3 ] ;; let%test_unit _ = [%test_result: int list] (take [ 1; 2; 3; 4; 5; 6 ] 100) ~expect:[ 1; 2; 3; 4; 5; 6 ] ;; let%test_unit _ = [%test_result: int list] (take [ 1; 2; 3; 4; 5; 6 ] 0) ~expect:[] let%test_unit _ = [%test_result: int list] (take [ 1; 2; 3; 4; 5; 6 ] (-5)) ~expect:[] let%test_unit _ = [%test_result: int list] (drop [ 1; 2; 3; 4; 5; 6 ] 3) ~expect:[ 4; 5; 6 ] ;; let%test_unit _ = [%test_result: int list] (drop [ 1; 2; 3; 4; 5; 6 ] 100) ~expect:[] let%test_unit _ = [%test_result: int list] (drop [ 1; 2; 3; 4; 5; 6 ] 0) ~expect:[ 1; 2; 3; 4; 5; 6 ] ;; let%test_unit _ = [%test_result: int list] (drop [ 1; 2; 3; 4; 5; 6 ] (-5)) ~expect:[ 1; 2; 3; 4; 5; 6 ] ;; let%test_module "{take,drop,split}_while" = (module struct let pred = function | '0' .. '9' -> true | _ -> false ;; let test xs prefix suffix = let prefix1, suffix1 = split_while ~f:pred xs in let prefix2 = take_while xs ~f:pred in let suffix2 = drop_while xs ~f:pred in [%test_eq: char list] xs (prefix @ suffix); [%test_result: char list] ~expect:prefix prefix1; [%test_result: char list] ~expect:prefix prefix2; [%test_result: char list] ~expect:suffix suffix1; [%test_result: char list] ~expect:suffix suffix2 ;; let%test_unit _ = test [ '1'; '2'; '3'; 'a'; 'b'; 'c' ] [ '1'; '2'; '3' ] [ 'a'; 'b'; 'c' ] ;; let%test_unit _ = test [ '1'; '2'; 'a'; 'b'; 'c' ] [ '1'; '2' ] [ 'a'; 'b'; 'c' ] let%test_unit _ = test [ '1'; 'a'; 'b'; 'c' ] [ '1' ] [ 'a'; 'b'; 'c' ] let%test_unit _ = test [ 'a'; 'b'; 'c' ] [] [ 'a'; 'b'; 'c' ] let%test_unit _ = test [ '1'; '2'; '3' ] [ '1'; '2'; '3' ] [] let%test_unit _ = test [] [] [] end) ;; let%test_unit _ = [%test_result: int list] (concat []) ~expect:[] let%test_unit _ = [%test_result: int list] (concat [ [] ]) ~expect:[] let%test_unit _ = [%test_result: int list] (concat [ [ 3 ] ]) ~expect:[ 3 ] let%test_unit _ = [%test_result: int list] (concat [ [ 1; 2; 3; 4 ] ]) ~expect:[ 1; 2; 3; 4 ] ;; let%test_unit _ = [%test_result: int list] (concat [ [ 1; 2; 3; 4 ]; [ 5; 6; 7 ]; [ 8; 9; 10 ]; []; [ 11; 12 ] ]) ~expect:[ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12 ] ;; let%test_unit _ = [%test_result: bool] (is_sorted [] ~compare:Int.compare) ~expect:true let%test_unit _ = [%test_result: bool] (is_sorted [ 1 ] ~compare:Int.compare) ~expect:true let%test_unit _ = [%test_result: bool] (is_sorted [ 1; 2; 3; 4 ] ~compare:Int.compare) ~expect:true ;; let%test_unit _ = [%test_result: bool] (is_sorted [ 2; 1 ] ~compare:Int.compare) ~expect:false ;; let%test_unit _ = [%test_result: bool] (is_sorted [ 1; 3; 2 ] ~compare:Int.compare) ~expect:false ;; let%test_unit _ = List.iter ~f:(fun (t, expect) -> [%test_result: bool] ~expect (is_sorted_strictly t ~compare:Int.compare)) [ [], true ; [ 1 ], true ; [ 1; 2 ], true ; [ 1; 1 ], false ; [ 2; 1 ], false ; [ 1; 2; 3 ], true ; [ 1; 1; 3 ], false ; [ 1; 2; 2 ], false ] ;; let%test_unit _ = [%test_result: int option] (random_element []) ~expect:None let%test_unit _ = [%test_result: int option] (random_element [ 0 ]) ~expect:(Some 0) let%test_module "transpose" = (module struct let round_trip a b = [%test_result: int list list option] (transpose a) ~expect:(Some b); [%test_result: int list list option] (transpose b) ~expect:(Some a) ;; let%test_unit _ = round_trip [] [] let%test_unit _ = [%test_result: int list list option] (transpose [ [] ]) ~expect:(Some []) ;; let%test_unit _ = [%test_result: int list list option] (transpose [ []; [] ]) ~expect:(Some []) ;; let%test_unit _ = [%test_result: int list list option] (transpose [ []; []; [] ]) ~expect:(Some []) ;; let%test_unit _ = round_trip [ [ 1 ] ] [ [ 1 ] ] let%test_unit _ = round_trip [ [ 1 ]; [ 2 ] ] [ [ 1; 2 ] ] let%test_unit _ = round_trip [ [ 1 ]; [ 2 ]; [ 3 ] ] [ [ 1; 2; 3 ] ] let%test_unit _ = round_trip [ [ 1; 2 ]; [ 3; 4 ] ] [ [ 1; 3 ]; [ 2; 4 ] ] let%test_unit _ = round_trip [ [ 1; 2; 3 ]; [ 4; 5; 6 ] ] [ [ 1; 4 ]; [ 2; 5 ]; [ 3; 6 ] ] ;; let%test_unit _ = round_trip [ [ 1; 2; 3 ]; [ 4; 5; 6 ]; [ 7; 8; 9 ] ] [ [ 1; 4; 7 ]; [ 2; 5; 8 ]; [ 3; 6; 9 ] ] ;; let%test_unit _ = round_trip [ [ 1; 2; 3; 4 ]; [ 5; 6; 7; 8 ]; [ 9; 10; 11; 12 ] ] [ [ 1; 5; 9 ]; [ 2; 6; 10 ]; [ 3; 7; 11 ]; [ 4; 8; 12 ] ] ;; let%test_unit _ = round_trip [ [ 1; 2; 3; 4 ]; [ 5; 6; 7; 8 ]; [ 9; 10; 11; 12 ]; [ 13; 14; 15; 16 ] ] [ [ 1; 5; 9; 13 ]; [ 2; 6; 10; 14 ]; [ 3; 7; 11; 15 ]; [ 4; 8; 12; 16 ] ] ;; let%test_unit _ = round_trip [ [ 1; 2; 3 ]; [ 4; 5; 6 ]; [ 7; 8; 9 ]; [ 10; 11; 12 ] ] [ [ 1; 4; 7; 10 ]; [ 2; 5; 8; 11 ]; [ 3; 6; 9; 12 ] ] ;; let%test_unit _ = [%test_result: int list list option] (transpose [ []; [ 1 ] ]) ~expect:None ;; let%test_unit _ = [%test_result: int list list option] (transpose [ [ 1; 2 ]; [ 3 ] ]) ~expect:None ;; end) ;; let%test_unit _ = [%test_result: int list] (intersperse [ 1; 2; 3 ] ~sep:0) ~expect:[ 1; 0; 2; 0; 3 ] ;; let%test_unit _ = [%test_result: int list] (intersperse [ 1; 2 ] ~sep:0) ~expect:[ 1; 0; 2 ] ;; let%test_unit _ = [%test_result: int list] (intersperse [ 1 ] ~sep:0) ~expect:[ 1 ] let%test_unit _ = [%test_result: int list] (intersperse [] ~sep:0) ~expect:[] let test_fold_map list ~init ~f ~expect = [%test_result: int list] (folding_map list ~init ~f) ~expect:(snd expect); [%test_result: _ * int list] (fold_map list ~init ~f) ~expect ;; let test_fold_mapi list ~init ~f ~expect = [%test_result: int list] (folding_mapi list ~init ~f) ~expect:(snd expect); [%test_result: _ * int list] (fold_mapi list ~init ~f) ~expect ;; let%test_unit _ = test_fold_map [ 1; 2; 3; 4 ] ~init:0 ~f:(fun acc x -> let y = acc + x in y, y) ~expect:(10, [ 1; 3; 6; 10 ]) ;; let%test_unit _ = test_fold_map [] ~init:0 ~f:(fun acc x -> let y = acc + x in y, y) ~expect:(0, []) ;; let%test_unit _ = test_fold_mapi [ 1; 2; 3; 4 ] ~init:0 ~f:(fun i acc x -> let y = acc + (i * x) in y, y) ~expect:(20, [ 0; 2; 8; 20 ]) ;; let%test_unit _ = test_fold_mapi [] ~init:0 ~f:(fun i acc x -> let y = acc + (i * x) in y, y) ~expect:(0, []) ;; let%expect_test "drop_last" = let print_drop_last x = print_s [%sexp (List.drop_last x : int list option)] in print_drop_last []; [%expect {| () |}]; print_drop_last [ 1 ]; [%expect {| (()) |}]; print_drop_last [ 1; 2; 3 ]; [%expect {| ((1 2)) |}] ;; let%expect_test "drop_last_exn" = let print_drop_last_exn x = print_s [%sexp (List.drop_last_exn x : int list)] in require_does_raise [%here] (fun () -> print_drop_last_exn []); [%expect {| (Failure "List.drop_last_exn: empty list") |}]; require_does_not_raise [%here] (fun () -> print_drop_last_exn [ 1 ]); [%expect {| () |}] ;; let%expect_test "[all_equal]" = let test list = print_s [%sexp (all_equal list ~equal:Char.Caseless.equal : char option)] in (* empty list *) test []; [%expect {| () |}]; (* singleton *) test [ 'a' ]; [%expect {| (a) |}]; (* homogenous pairs (up to [equal]) *) test [ 'a'; 'a' ]; [%expect {| (a) |}]; test [ 'a'; 'A' ]; [%expect {| (a) |}]; test [ 'A'; 'a' ]; [%expect {| (A) |}]; (* heterogenous pairs *) test [ 'a'; 'b' ]; [%expect {| () |}]; test [ 'b'; 'a' ]; [%expect {| () |}]; (* heterogenous lists *) test [ 'a'; 'b'; 'a'; 'b'; 'a'; 'b' ]; [%expect {| () |}]; test [ 'a'; 'b'; 'c'; 'd'; 'e'; 'f' ]; [%expect {| () |}]; (* homogenous lists (up to [equal]) *) test [ 'a'; 'a'; 'a'; 'a'; 'a'; 'a' ]; [%expect {| (a) |}]; test [ 'A'; 'a'; 'A'; 'a'; 'A'; 'a' ]; [%expect {| (A) |}] ;; let%expect_test "[Cartesian_product.apply] identity" = let test list = require_equal [%here] (module struct type t = char list [@@deriving equal, sexp_of] end) list (List.Cartesian_product.apply (return Fn.id) list) in test []; test [ 'a'; 'b'; 'c' ]; test [ 'a'; 'z'; 'd'; 'b' ] ;; let%expect_test "[Cartesian_product]" = (let%map.List.Cartesian_product letter = [ 'a'; 'b'; 'c' ] and number = [ 1; 2; 3 ] and solfege = [ "do"; "re"; "mi" ] in [%sexp (letter : char), (number : int), (solfege : string)]) |> List.iter ~f:print_s; [%expect {| (a 1 do) (a 1 re) (a 1 mi) (a 2 do) (a 2 re) (a 2 mi) (a 3 do) (a 3 re) (a 3 mi) (b 1 do) (b 1 re) (b 1 mi) (b 2 do) (b 2 re) (b 2 mi) (b 3 do) (b 3 re) (b 3 mi) (c 1 do) (c 1 re) (c 1 mi) (c 2 do) (c 2 re) (c 2 mi) (c 3 do) (c 3 re) (c 3 mi) |}] ;; base-0.16.3/test/test_list.mli000066400000000000000000000000551446274340700162220ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_map.ml000066400000000000000000000266151446274340700156650ustar00rootroot00000000000000open! Import open! Map let%expect_test "Finished_or_unfinished <-> Continue_or_stop" = (* These functions are implemented using [Caml.Obj.magic]. It is important to test them comprehensively. *) List.iter2_exn Continue_or_stop.all Finished_or_unfinished.all ~f:(fun c_or_s f_or_u -> print_s [%sexp (c_or_s : Continue_or_stop.t), (f_or_u : Finished_or_unfinished.t)]; require_equal [%here] (module Continue_or_stop) c_or_s (Finished_or_unfinished.to_continue_or_stop f_or_u); require_equal [%here] (module Finished_or_unfinished) f_or_u (Finished_or_unfinished.of_continue_or_stop c_or_s)); [%expect {| (Continue Finished) (Stop Unfinished) |}] ;; let%test _ = invariants (of_increasing_iterator_unchecked (module Int) ~len:20 ~f:(fun x -> x, x)) ;; let%test _ = invariants (Poly.of_increasing_iterator_unchecked ~len:20 ~f:(fun x -> x, x)) let add12 t = add_exn t ~key:1 ~data:2 type int_map = int Map.M(Int).t [@@deriving compare, hash, sexp] let%expect_test "[add_exn] success" = print_s [%sexp (add12 (empty (module Int)) : int_map)]; [%expect {| ((1 2)) |}] ;; let%expect_test "[add_exn] failure" = show_raise (fun () -> add12 (add12 (empty (module Int)))); [%expect {| (raised ("[Map.add_exn] got key already present" (key 1))) |}] ;; let%expect_test "[add] success" = print_s [%sexp (add (empty (module Int)) ~key:1 ~data:2 : int_map Or_duplicate.t)]; [%expect {| (Ok ((1 2))) |}] ;; let%expect_test "[add] duplicate" = print_s [%sexp (add (add12 (empty (module Int))) ~key:1 ~data:2 : int_map Or_duplicate.t)]; [%expect {| Duplicate |}] ;; let%expect_test "[Map.of_alist_multi] preserves value ordering" = print_s [%sexp (Map.of_alist_multi (module String) [ "a", 1; "a", 2; "b", 1; "b", 3 ] : int list Map.M(String).t)]; [%expect {| ((a (1 2)) (b (1 3))) |}] ;; let%expect_test "find_exn" = let map = Map.of_alist_exn (module String) [ "one", 1; "two", 2; "three", 3 ] in let test_success key = require_does_not_raise [%here] (fun () -> print_s [%sexp (Map.find_exn map key : int)]) in test_success "one"; [%expect {| 1 |}]; test_success "two"; [%expect {| 2 |}]; test_success "three"; [%expect {| 3 |}]; let test_failure key = require_does_raise [%here] (fun () -> Map.find_exn map key) in test_failure "zero"; [%expect {| (Not_found_s ("Map.find_exn: not found" zero)) |}]; test_failure "four"; [%expect {| (Not_found_s ("Map.find_exn: not found" four)) |}] ;; let%expect_test "[t_of_sexp] error on duplicate" = let sexp = Sexplib.Sexp.of_string "((0 a)(1 b)(2 c)(1 d))" in (match [%of_sexp: string Map.M(String).t] sexp with | t -> print_cr [%here] [%message "did not raise" (t : string Map.M(String).t)] | exception (Sexp.Of_sexp_error _ as exn) -> print_s (sexp_of_exn exn) | exception exn -> print_cr [%here] [%message "wrong kind of exception" (exn : exn)]); [%expect {| (Of_sexp_error "Map.t_of_sexp_direct: duplicate key" (invalid_sexp 1)) |}] ;; let%expect_test "combine_errors" = let test list = let input = list |> List.map ~f:(Result.map_error ~f:Error.of_string) |> List.mapi ~f:(fun k x -> Int.succ k, x) |> Map.of_alist_exn (module Int) in let output = Map.combine_errors input in print_s [%sexp (output : string Map.M(Int).t Or_error.t)] in (* empty *) test []; [%expect {| (Ok ()) |}]; (* singletons *) test [ Ok "one" ]; test [ Error "one" ]; [%expect {| (Ok ((1 one))) (Error ((1 one))) |}]; (* multiple ok *) test [ Ok "one"; Ok "two"; Ok "three" ]; [%expect {| (Ok ( (1 one) (2 two) (3 three))) |}]; (* multiple errors *) test [ Error "one"; Error "two"; Error "three" ]; [%expect {| (Error ( (1 one) (2 two) (3 three))) |}]; (* one error among oks *) test [ Error "one"; Ok "two"; Ok "three" ]; test [ Ok "one"; Error "two"; Ok "three" ]; test [ Ok "one"; Ok "two"; Error "three" ]; [%expect {| (Error ((1 one))) (Error ((2 two))) (Error ((3 three))) |}]; (* one ok among errors *) test [ Ok "one"; Error "two"; Error "three" ]; test [ Error "one"; Ok "two"; Error "three" ]; test [ Error "one"; Error "two"; Ok "three" ]; [%expect {| (Error ( (2 two) (3 three))) (Error ( (1 one) (3 three))) (Error ( (1 one) (2 two))) |}] ;; let%test_module "Poly" = (module struct let%test _ = length Poly.empty = 0 let%test _ = let a = Poly.of_alist_exn [] in Poly.equal Base.Poly.equal a Poly.empty ;; let%test _ = let a = Poly.of_alist_exn [ "a", 1 ] in let b = Poly.of_alist_exn [ 1, "b" ] in length a = length b ;; end) ;; let%test_module "[symmetric_diff]" = (module struct let%expect_test "examples" = let test alist1 alist2 = Map.symmetric_diff ~data_equal:Int.equal (Map.of_alist_exn (module String) alist1) (Map.of_alist_exn (module String) alist2) |> Sequence.to_list |> [%sexp_of: (string, int) Symmetric_diff_element.t list] |> print_s in test [] []; [%expect {| () |}]; test [ "one", 1 ] []; [%expect {| ((one (Left 1))) |}]; test [] [ "two", 2 ]; [%expect {| ((two (Right 2))) |}]; test [ "one", 1; "two", 2 ] [ "one", 1; "two", 2 ]; [%expect {| () |}]; test [ "one", 1; "two", 2 ] [ "one", 1; "two", 3 ]; [%expect {| ((two (Unequal (2 3)))) |}] ;; module String_to_int_map = struct type t = int Map.M(String).t [@@deriving equal, sexp_of] open Base_quickcheck let quickcheck_generator = Generator.map_t_m (module String) Generator.string Generator.int ;; let quickcheck_observer = Observer.map_t Observer.string Observer.int let quickcheck_shrinker = Shrinker.map_t Shrinker.string Shrinker.int end let apply_diff_left_to_right map (key, elt) = match elt with | `Right data | `Unequal (_, data) -> Map.set map ~key ~data | `Left _ -> Map.remove map key ;; let apply_diff_right_to_left map (key, elt) = match elt with | `Left data | `Unequal (data, _) -> Map.set map ~key ~data | `Right _ -> Map.remove map key ;; (* This is a deterministic benchmark rather than a test, measuring the number of comparisons made by fold_symmetric_diff. *) let%expect_test "number of key comparisons" = let count = ref 0 in let measure_comparisons f = let c = !count in f (); !count - c in let module Key = struct module T = struct type t = int [@@deriving sexp_of] let compare x y = Int.incr count; compare_int x y ;; end include T include Comparator.Make (T) end in let (_m : unit Map.M(Key).t), map_pairs = List.fold (List.init 1000 ~f:Fn.id) ~init:(Map.empty (module Key), []) ~f:(fun (m, acc) i -> let m' = Map.add_exn m ~key:i ~data:() in m', (m, m') :: acc) in print_s [%sexp (!count : int)]; [%expect {| 9_966 |}]; count := 0; let diffs = ref 0 in let counts = List.map map_pairs ~f:(fun (m, m') -> measure_comparisons (fun () -> diffs := !diffs + Map.fold_symmetric_diff ~init:0 ~f:(fun n _ -> n + 1) ~data_equal:(fun () () -> true) (m : unit Map.M(Key).t) m')) in let worst_counts = List.sort counts ~compare:[%compare: int] |> List.rev |> fun l -> List.take l 20 in (* The smaller these numbers are, the better. *) print_s [%sexp (!diffs : int), (!count : int)]; [%expect {| (1_000 10_955) |}]; print_s [%sexp (worst_counts : int list)]; [%expect {| (12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12 12) |}] ;; let%expect_test "reconstructing in both directions" = let test (map1, map2) = let diff = Map.symmetric_diff map1 map2 ~data_equal:Int.equal in require_equal [%here] (module String_to_int_map) (Sequence.fold diff ~init:map1 ~f:apply_diff_left_to_right) map2; require_equal [%here] (module String_to_int_map) map1 (Sequence.fold diff ~init:map2 ~f:apply_diff_right_to_left) in Base_quickcheck.Test.run_exn ~f:test (module struct type t = String_to_int_map.t * String_to_int_map.t [@@deriving quickcheck, sexp_of] end) ;; let%expect_test "vs [fold_symmetric_diff]" = let test (map1, map2) = require_compare_equal [%here] (module struct type t = (string, int) Symmetric_diff_element.t list [@@deriving compare, sexp_of] end) (Map.symmetric_diff map1 map2 ~data_equal:Int.equal |> Sequence.fold ~init:[] ~f:(Fn.flip List.cons)) (Map.fold_symmetric_diff map1 map2 ~data_equal:Int.equal ~init:[] ~f:(Fn.flip List.cons)) in Base_quickcheck.Test.run_exn ~f:test (module struct type t = String_to_int_map.t * String_to_int_map.t [@@deriving quickcheck, sexp_of] end) ;; end) ;; let%test_module "of_alist_multi key equality" = (module struct module Key = struct module T = struct type t = string * int [@@deriving sexp_of] let compare = [%compare: string * _] end include T include Comparator.Make (T) end let alist = [ ("a", 1), 1; ("a", 2), 3; ("b", 0), 0; ("a", 3), 2 ] let%expect_test "of_alist_multi chooses the first key" = print_s [%sexp (Map.of_alist_multi (module Key) alist : int list Map.M(Key).t)]; [%expect {| (((a 1) (1 3 2)) ((b 0) (0))) |}] ;; let%test_unit "of_{alist,sequence}_multi have the same behaviour" = [%test_result: int list Map.M(Key).t] ~expect:(Map.of_alist_multi (module Key) alist) (Map.of_sequence_multi (module Key) (Sequence.of_list alist)) ;; end) ;; let%expect_test "remove returns the same object if there's nothing to do" = let map1 = Map.of_alist_exn (module Int) [ 1, "one"; 3, "three" ] in let map2 = Map.remove map1 2 in require [%here] (phys_equal map1 map2) ;; let%expect_test "[map_keys]" = let test m c ~f = print_s [%sexp (Map.map_keys c ~f m : [ `Duplicate_key of string | `Ok of string Map.M(String).t ])] in let map = Map.of_alist_exn (module Int) [ 1, "one"; 2, "two"; 3, "three" ] in test map (module String) ~f:Int.to_string; [%expect {| (Ok ( (1 one) (2 two) (3 three))) |}]; test map (module String) ~f:(fun x -> Int.to_string (x / 2)); [%expect {| (Duplicate_key 1) |}] ;; let%expect_test "[fold_until]" = let test t = print_s [%sexp (Map.fold_until t ~init:0 ~f:(fun ~key ~data acc -> if key > 2 then Stop data else Continue (acc + key)) ~finish:Int.to_string : string)] in let map = Map.of_alist_exn (module Int) [ 1, "one"; 2, "two"; 3, "three" ] in test map; [%expect {| three |}]; let map = Map.of_alist_exn (module Int) [ -1, "minus-one"; 1, "one"; 2, "two" ] in test map; [%expect {| 2 |}] ;; base-0.16.3/test/test_map.mli000066400000000000000000000000551446274340700160240ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_map.mlt000066400000000000000000000000551446274340700160370ustar00rootroot00000000000000open Base let _ = Map.add [%%expect {| |}] base-0.16.3/test/test_map_comprehensive.ml000066400000000000000000001644531446274340700206170ustar00rootroot00000000000000(** Comprehensive testing of [Base.Map]. This file tests all exports of [Base.Map]. Every time a new export is added, we have to add a new definition somewhere here. Every time we add a definition, we should add a test unless the definition is untestable (e.g., a module type) or trivial (e.g., a module containing only ppx-derived definitions). We should document categories of untested definitions, mark them as untested, and keep them separate from definitions that need tests. *) open! Import open struct (** quickcheck configuration *) let quickcheck_config = let test_count = (* In js_of_ocaml, quickcheck is slow due to 64-bit arithmetic, and some map operations are especially slow due to use of exceptions and exception handlers. So on "other" backends, we turn the test count down. *) match Sys.backend_type with | Native | Bytecode -> 10_000 | Other _ -> 1_000 in { Base_quickcheck.Test.default_config with test_count } ;; let quickcheck_m here m ~f = quickcheck_m here m ~f ~config:quickcheck_config end (** The types that distinguish instances of [Map.Creators_and_accessors_generic]. *) module type Types = sig type 'k key type 'c cmp type ('k, 'v, 'c) t type ('k, 'v, 'c) tree type ('k, 'c, 'a) create_options type ('k, 'c, 'a) access_options end (** Like [Map.Creators_and_accessors_generic], but based on [Types] for easier instantiation. *) module type S = sig module Types : Types include Map.Creators_and_accessors_generic with type ('a, 'b, 'c) t := ('a, 'b, 'c) Types.t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Types.tree with type 'a key := 'a Types.key with type 'a cmp := 'a Types.cmp with type ('a, 'b, 'c) create_options := ('a, 'b, 'c) Types.create_options with type ('a, 'b, 'c) access_options := ('a, 'b, 'c) Types.access_options end (** Helpers for testing a tree or map type that is an instance of [S]. *) module type Instance = sig module Types : Types module Key : sig type t = int Types.key [@@deriving compare, equal, quickcheck, sexp_of] include Comparable.Infix with type t := t end type 'a t = (int, 'a, Int.comparator_witness) Types.t [@@deriving equal, quickcheck, sexp_of] (** Construct a [Key.t]. *) val key : int -> Key.t (** Extract an int from a [Key.t]. *) val int : Key.t -> int (** Extract a tree (without a comparator) from [t]. *) val tree : (Key.t, 'a, Int.comparator_witness) Types.tree -> (Key.t, 'a, Int.comparator_witness Types.cmp) Map.Using_comparator.Tree.t (** Pass a comparator to a creator function, if necessary. *) val create : (int, Int.comparator_witness, 'a) Types.create_options -> 'a (** Pass a comparator to an accessor function, if necessary *) val access : (int, Int.comparator_witness, 'a) Types.access_options -> 'a end (** A functor to generate all of [Instance] but [create] and [access] for a map type. *) module Instance (Cmp : sig type comparator_witness val comparator : (int, comparator_witness) Comparator.t end) = struct module Key = struct type t = int [@@deriving quickcheck, sexp_of] type comparator_witness = Cmp.comparator_witness let comparator = Cmp.comparator let compare = comparator.compare let equal = [%compare.equal: t] let quickcheck_generator = Base_quickcheck.Generator.small_strictly_positive_int include Comparable.Infix (struct type nonrec t = t let compare = compare end) end type 'a t = 'a Map.M(Key).t [@@deriving equal, sexp_of] let key x = x let int x = x let tree x = x let quickcheck_generator gen = Base_quickcheck.Generator.map_t_m (module Key) Base_quickcheck.Generator.small_strictly_positive_int gen ;; let quickcheck_observer obs = Base_quickcheck.Observer.map_t Base_quickcheck.Observer.int obs ;; let quickcheck_shrinker shr = Base_quickcheck.Shrinker.map_t Base_quickcheck.Shrinker.int shr ;; end (** Instantiating key and data both as [int]. *) module Instance_int = struct module I = Instance (Int) type t = int I.t [@@deriving equal, quickcheck, sexp_of] end (** A functor like [Instance], but for tree types. *) module Instance_tree (Cmp : sig type comparator_witness val comparator : (int, comparator_witness) Comparator.t end) = struct module M = Instance (Cmp) include M type 'a t = (int, 'a, Cmp.comparator_witness) Map.Using_comparator.Tree.t let of_tree tree = Map.Using_comparator.of_tree ~comparator:Cmp.comparator tree let to_tree t = Map.Using_comparator.to_tree t let quickcheck_generator gen = Base_quickcheck.Generator.map (M.quickcheck_generator gen) ~f:to_tree ;; let quickcheck_observer obs = Base_quickcheck.Observer.unmap (M.quickcheck_observer obs) ~f:of_tree ;; let quickcheck_shrinker shr = Base_quickcheck.Shrinker.map (M.quickcheck_shrinker shr) ~f:to_tree ~f_inverse:of_tree ;; let equal equal_a = Map.Using_comparator.Tree.equal ~comparator:Int.comparator equal_a let sexp_of_t sexp_of_a t = M.sexp_of_t sexp_of_a (of_tree t) end (** Functor for [List.t] *) module Lst (T : sig type t [@@deriving equal, sexp_of] end) = struct type t = T.t list [@@deriving equal, sexp_of] end (** Functor for [Or_error], ignoring error contents when comparing. *) module Ok (T : sig type t [@@deriving equal, sexp_of] end) = struct type t = (T.t, (Error.t[@equal.ignore])) Result.t [@@deriving equal, sexp_of] end (** Functor for [Option.t] *) module Opt (T : sig type t [@@deriving equal, sexp_of] end) = struct type t = T.t option [@@deriving equal, sexp_of] end (** Functor for pairs of a single type. Random generation frequently generates pairs of identical values. *) module Pair (T : sig type t [@@deriving equal, quickcheck, sexp_of] end) = struct type t = T.t * T.t [@@deriving equal, quickcheck, sexp_of] let quickcheck_generator = let open Base_quickcheck.Generator.Let_syntax in match%bind Base_quickcheck.Generator.bool with | true -> [%generator: t] | false -> let%map x = [%generator: T.t] in x, x ;; end (** Expect tests for everything exported from [Map.Creators_and_accessors_generic]. *) module Test_creators_and_accessors (Types : Types) (Impl : S with module Types := Types) (Instance : Instance with module Types := Types) : S with module Types := Types = struct open Instance open Impl open struct (** Test helpers, not to be exported. *) module Alist = struct type t = (Key.t * int) list [@@deriving compare, equal, quickcheck, sexp_of] end module Alist_merge = struct type t = (Key.t * (int, int) Map.Merge_element.t) list [@@deriving equal, sexp_of] end module Alist_multi = struct type t = (Key.t * int list) list [@@deriving equal, quickcheck, sexp_of] end module Diff = struct type t = (Key.t, int) Map.Symmetric_diff_element.t list [@@deriving equal, sexp_of] end module Inst = struct type t = int Instance.t [@@deriving equal, quickcheck, sexp_of] end module Inst_and_key = struct type t = Inst.t * Key.t [@@deriving quickcheck, sexp_of] end module Inst_and_key_and_data = struct type t = Inst.t * Key.t * int [@@deriving quickcheck, sexp_of] end module Inst_inst = struct type t = Inst.t Instance.t [@@deriving equal, quickcheck, sexp_of] end module Inst_multi = struct type t = int list Instance.t [@@deriving equal, quickcheck, sexp_of] end module Key_and_data = struct type t = Key.t * int [@@deriving equal, sexp_of] end module Key_and_data_inst = struct type t = (Key.t * int) Instance.t [@@deriving equal, sexp_of] end module Key_and_data_inst_multi = struct type t = (Key.t * int) list Instance.t [@@deriving equal, sexp_of] end module Maybe_bound = struct include Maybe_bound type 'a t = 'a Maybe_bound.t = | Incl of 'a | Excl of 'a | Unbounded [@@deriving quickcheck, sexp_of] end let ok_or_duplicate_key = function | `Ok x -> Ok x | `Duplicate_key key -> Or_error.error_s [%sexp (key : Key.t)] ;; end (** creators *) let empty = empty let%expect_test _ = print_s [%sexp (create empty : int t)]; [%expect {| () |}] ;; let singleton = singleton let%expect_test _ = print_s [%sexp (create singleton (key 1) 2 : int t)]; [%expect {| ((1 2)) |}] ;; let of_alist = of_alist let of_alist_or_error = of_alist_or_error let of_alist_exn = of_alist_exn let%expect_test _ = quickcheck_m [%here] (module Alist) ~f:(fun alist -> let t_or_error = create of_alist_or_error alist in let t_exn = Or_error.try_with (fun () -> create of_alist_exn alist) in let t_or_duplicate = match create of_alist alist with | `Ok t -> Ok t | `Duplicate_key key -> Or_error.error_s [%sexp (key : Key.t)] in require_equal [%here] (module Ok (Alist)) (Or_error.map t_or_error ~f:to_alist) (let compare a b = Comparable.lift Key.compare ~f:fst a b in if List.contains_dup alist ~compare then Or_error.error_string "duplicate" else Ok (List.sort alist ~compare)); require_equal [%here] (module Ok (Inst)) t_exn t_or_error; require_equal [%here] (module Ok (Inst)) t_or_duplicate t_or_error); [%expect {| |}] ;; let of_alist_multi = of_alist_multi let of_alist_fold = of_alist_fold let of_alist_reduce = of_alist_reduce let%expect_test _ = quickcheck_m [%here] (module Alist) ~f:(fun alist -> let t_multi = create of_alist_multi alist in let t_fold = create of_alist_fold alist ~init:[] ~f:(fun xs x -> x :: xs) |> map ~f:List.rev in let t_reduce = create of_alist_reduce (List.Assoc.map alist ~f:List.return) ~f:(fun x y -> x @ y) in require_equal [%here] (module Alist_multi) (to_alist t_multi) (List.Assoc.sort_and_group alist ~compare:Key.compare); require_equal [%here] (module Inst_multi) t_fold t_multi; require_equal [%here] (module Inst_multi) t_reduce t_multi); [%expect {| |}] ;; let of_sequence = of_sequence let of_sequence_or_error = of_sequence_or_error let of_sequence_exn = of_sequence_exn let%expect_test _ = quickcheck_m [%here] (module Alist) ~f:(fun alist -> let seq = Sequence.of_list alist in let t_or_error = create of_sequence_or_error seq in let t_exn = Or_error.try_with (fun () -> create of_sequence_exn seq) in let t_or_duplicate = match create of_sequence seq with | `Ok t -> Ok t | `Duplicate_key key -> Or_error.error_s [%sexp (key : Key.t)] in let expect = create of_alist_or_error alist in require_equal [%here] (module Ok (Inst)) t_or_error expect; require_equal [%here] (module Ok (Inst)) t_exn expect; require_equal [%here] (module Ok (Inst)) t_or_duplicate expect); [%expect {| |}] ;; let of_sequence_multi = of_sequence_multi let of_sequence_fold = of_sequence_fold let of_sequence_reduce = of_sequence_reduce let%expect_test _ = quickcheck_m [%here] (module Alist) ~f:(fun alist -> let seq = Sequence.of_list alist in let t_multi = create of_sequence_multi seq in let t_fold = create of_sequence_fold seq ~init:[] ~f:(fun xs x -> x :: xs) |> map ~f:List.rev in let t_reduce = create of_sequence_reduce (alist |> List.Assoc.map ~f:List.return |> Sequence.of_list) ~f:(fun x y -> x @ y) in let expect = create of_alist_multi alist in require_equal [%here] (module Inst_multi) t_multi expect; require_equal [%here] (module Inst_multi) t_fold expect; require_equal [%here] (module Inst_multi) t_reduce expect); [%expect {| |}] ;; let of_list_with_key = of_list_with_key let of_list_with_key_or_error = of_list_with_key_or_error let of_list_with_key_exn = of_list_with_key_exn let of_list_with_key_multi = of_list_with_key_multi let%expect_test _ = quickcheck_m [%here] (module Alist) ~f:(fun list -> let alist = List.map list ~f:(fun (key, data) -> key, (key, data)) in require_equal [%here] (module Ok (Key_and_data_inst)) (create of_list_with_key list ~get_key:fst |> ok_or_duplicate_key) (create of_alist alist |> ok_or_duplicate_key); require_equal [%here] (module Ok (Key_and_data_inst)) (create of_list_with_key_or_error list ~get_key:fst) (create of_alist_or_error alist); require_equal [%here] (module Ok (Key_and_data_inst)) (Or_error.try_with (fun () -> create of_list_with_key_exn list ~get_key:fst)) (Or_error.try_with (fun () -> create of_alist_exn alist)); require_equal [%here] (module Key_and_data_inst_multi) (create of_list_with_key_multi list ~get_key:fst) (create of_alist_multi alist)); [%expect {| |}] ;; let of_increasing_sequence = of_increasing_sequence let%expect_test _ = quickcheck_m [%here] (module Alist) ~f:(fun alist -> let seq = Sequence.of_list alist in let actual = create of_increasing_sequence seq in let expect = if List.is_sorted alist ~compare:(fun a b -> Comparable.lift Key.compare ~f:fst a b) then create of_alist_or_error alist else Or_error.error_string "decreasing keys" in require_equal [%here] (module Ok (Inst)) actual expect); [%expect {| |}] ;; let of_sorted_array = of_sorted_array let%expect_test _ = quickcheck_m [%here] (module Alist) ~f:(fun alist -> let actual = create of_sorted_array (Array.of_list alist) in let expect = let compare a b = Comparable.lift Key.compare ~f:fst a b in if List.is_sorted_strictly ~compare alist || List.is_sorted_strictly ~compare (List.rev alist) then create of_alist_or_error alist else Or_error.error_string "unsorted" in require_equal [%here] (module Ok (Inst)) actual expect); [%expect {| |}] ;; let of_sorted_array_unchecked = of_sorted_array_unchecked let%expect_test _ = quickcheck_m [%here] (module Alist) ~f:(fun alist -> let alist = List.dedup_and_sort alist ~compare:(fun a b -> Comparable.lift Key.compare ~f:fst a b) in let actual_fwd = create of_sorted_array_unchecked (Array.of_list alist) in let actual_rev = create of_sorted_array_unchecked (Array.of_list_rev alist) in let expect = create of_alist_exn alist in require_equal [%here] (module Inst) actual_fwd expect; require_equal [%here] (module Inst) actual_rev expect); [%expect {| |}] ;; let of_increasing_iterator_unchecked = of_increasing_iterator_unchecked let%expect_test _ = quickcheck_m [%here] (module Alist) ~f:(fun alist -> let alist = List.dedup_and_sort alist ~compare:(fun a b -> Comparable.lift Key.compare ~f:fst a b) in let actual = let array = Array.of_list alist in create of_increasing_iterator_unchecked ~len:(Array.length array) ~f:(Array.get array) in let expect = create of_alist_exn alist in require_equal [%here] (module Inst) actual expect); [%expect {| |}] ;; let of_iteri = of_iteri let of_iteri_exn = of_iteri_exn let%expect_test _ = quickcheck_m [%here] (module Alist) ~f:(fun alist -> let iteri ~f = List.iter alist ~f:(fun (key, data) -> f ~key ~data) [@nontail] in let actual_or_duplicate = match create of_iteri ~iteri with | `Ok t -> Ok t | `Duplicate_key key -> Or_error.error_s [%sexp (key : Key.t)] in let actual_exn = Or_error.try_with (fun () -> create of_iteri_exn ~iteri) in let expect = create of_alist_or_error alist in require_equal [%here] (module Ok (Inst)) actual_or_duplicate expect; require_equal [%here] (module Ok (Inst)) actual_exn expect); [%expect {| |}] ;; let map_keys = map_keys let map_keys_exn = map_keys_exn let%expect_test _ = quickcheck_m [%here] (module Inst_and_key) ~f:(fun (t, k) -> let f key = Comparable.min Key.compare k key in let actual_or_duplicate = match create map_keys t ~f with | `Ok t -> Ok t | `Duplicate_key key -> Or_error.error_s [%sexp (key : Key.t)] in let actual_exn = Or_error.try_with (fun () -> create map_keys_exn t ~f) in let expect = to_alist t |> List.map ~f:(fun (key, data) -> f key, data) |> create of_alist_or_error in require_equal [%here] (module Ok (Inst)) actual_or_duplicate expect; require_equal [%here] (module Ok (Inst)) actual_exn expect); [%expect {| |}] ;; let transpose_keys = transpose_keys let%expect_test _ = quickcheck_m [%here] (module Inst_inst) ~f:(fun t -> let transpose_keys = create (access transpose_keys) in let transposed = transpose_keys t in require [%here] (access invariants transposed); let round_trip = transpose_keys transposed in require_equal [%here] (module Inst_inst) (filter t ~f:(Fn.non is_empty)) round_trip); [%expect {| |}] ;; (** accessors *) let invariants = invariants let%expect_test _ = quickcheck_m [%here] (module Inst) ~f:(fun t -> require [%here] (access invariants t)); [%expect {| |}] ;; let is_empty = is_empty let length = length let%expect_test _ = quickcheck_m [%here] (module Inst) ~f:(fun t -> let len = length t in require_equal [%here] (module Bool) (is_empty t) (len = 0); require_equal [%here] (module Int) len (List.length (to_alist t))); [%expect {| |}] ;; let mem = mem let find = find let find_exn = find_exn let%expect_test _ = quickcheck_m [%here] (module Inst_and_key) ~f:(fun (t, key) -> let expect = List.Assoc.find (to_alist t) key ~equal:Key.equal in require_equal [%here] (module Bool) (access mem t key) (Option.is_some expect); require_equal [%here] (module Opt (Int)) (access find t key) expect; require_equal [%here] (module Opt (Int)) (Option.try_with (fun () -> access find_exn t key)) expect); [%expect {| |}] ;; let set = set let%expect_test _ = quickcheck_m [%here] (module Inst_and_key_and_data) ~f:(fun (t, key, data) -> require_equal [%here] (module Alist) (to_alist (access set t ~key ~data)) (List.sort ~compare:(fun a b -> Comparable.lift Key.compare ~f:fst a b) ((key, data) :: List.Assoc.remove (to_alist t) key ~equal:Key.equal))); [%expect {| |}] ;; let add = add let add_exn = add_exn let%expect_test _ = quickcheck_m [%here] (module Inst_and_key_and_data) ~f:(fun (t, key, data) -> let t_add = match access add t ~key ~data with | `Ok t -> Ok t | `Duplicate -> Or_error.error_string "duplicate" in let t_add_exn = Or_error.try_with (fun () -> access add_exn t ~key ~data) in let expect = if access mem t key then Or_error.error_string "duplicate" else Ok (access set t ~key ~data) in require_equal [%here] (module Ok (Inst)) t_add expect; require_equal [%here] (module Ok (Inst)) t_add_exn expect); [%expect {| |}] ;; let remove = remove let%expect_test _ = quickcheck_m [%here] (module Inst_and_key) ~f:(fun (t, key) -> require_equal [%here] (module Alist) (to_alist (access remove t key)) (List.Assoc.remove (to_alist t) key ~equal:Key.equal)); [%expect {| |}] ;; let change = change let%expect_test _ = quickcheck_m [%here] (module struct type t = Inst.t * Key.t * int option [@@deriving quickcheck, sexp_of] end) ~f:(fun (t, key, maybe_data) -> let actual = access change t key ~f:(fun previous -> require_equal [%here] (module Opt (Int)) previous (access find t key); [%expect {| |}]; maybe_data) in let expect = match maybe_data with | None -> access remove t key | Some data -> access set t ~key ~data in require_equal [%here] (module Inst) actual expect); [%expect {| |}] ;; let update = update let%expect_test _ = quickcheck_m [%here] (module Inst_and_key_and_data) ~f:(fun (t, key, data) -> let actual = access update t key ~f:(fun previous -> require_equal [%here] (module Opt (Int)) previous (access find t key); [%expect {| |}]; data) in let expect = access set t ~key ~data in require_equal [%here] (module Inst) actual expect); [%expect {| |}] ;; let find_multi = find_multi let add_multi = add_multi let remove_multi = remove_multi let%expect_test _ = quickcheck_m [%here] (module struct type t = Inst_multi.t * Key.t * int [@@deriving quickcheck, sexp_of] end) ~f:(fun (t, key, data) -> require_equal [%here] (module Lst (Int)) (access find_multi t key) (access find t key |> Option.value ~default:[]); require_equal [%here] (module Inst_multi) (access add_multi t ~key ~data) (access update t key ~f:(fun option -> data :: Option.value option ~default:[])); require_equal [%here] (module Inst_multi) (access remove_multi t key) (access change t key ~f:(function | None | Some ([] | [ _ ]) -> None | Some (_ :: (_ :: _ as rest)) -> Some rest))); [%expect {| |}] ;; let iter_keys = iter_keys let iter = iter let iteri = iteri let%expect_test _ = quickcheck_m [%here] (module Inst) ~f:(fun t -> let actuali = let q = Queue.create () in iteri t ~f:(fun ~key ~data -> Queue.enqueue q (key, data)); Queue.to_list q in let actual_keys = let q = Queue.create () in iter_keys t ~f:(Queue.enqueue q); Queue.to_list q in let actual = let q = Queue.create () in iter t ~f:(Queue.enqueue q); Queue.to_list q in require_equal [%here] (module Alist) actuali (to_alist t); require_equal [%here] (module Lst (Key)) actual_keys (keys t); require_equal [%here] (module Lst (Int)) actual (data t)); [%expect {| |}] ;; let map = map let mapi = mapi let%expect_test _ = quickcheck_m [%here] (module Inst) ~f:(fun t -> require_equal [%here] (module Inst) (map t ~f:Int.succ) (t |> to_alist |> List.Assoc.map ~f:Int.succ |> create of_alist_exn); require_equal [%here] (module struct type t = (Key.t * int) Instance.t [@@deriving equal, sexp_of] end) (mapi t ~f:(fun ~key ~data -> key, data)) (t |> to_alist |> List.map ~f:(fun (k, v) -> k, (k, v)) |> create of_alist_exn)); [%expect {| |}] ;; let filter_keys = filter_keys let filter = filter let filteri = filteri module Physical_equality (T : sig type t [@@deriving sexp_of] end) = struct type t = T.t [@@deriving sexp_of] let equal a b = phys_equal a b end let%expect_test _ = quickcheck_m [%here] (module Inst_and_key_and_data) ~f:(fun (t, k, d) -> require_equal [%here] (module Physical_equality (Inst)) (filter ~f:(fun _ -> true) t) t; require_equal [%here] (module Alist) (to_alist (filter_keys t ~f:(fun key -> Key.( <= ) key k))) (List.filter (to_alist t) ~f:(fun (key, _) -> Key.( <= ) key k)); require_equal [%here] (module Alist) (to_alist (filter t ~f:(fun data -> data <= d))) (List.filter (to_alist t) ~f:(fun (_, data) -> data <= d)); require_equal [%here] (module Alist) (to_alist (filteri t ~f:(fun ~key ~data -> Key.( <= ) key k && data <= d))) (List.filter (to_alist t) ~f:(fun (key, data) -> Key.( <= ) key k && data <= d))); [%expect {| |}] ;; let filter_map = filter_map let filter_mapi = filter_mapi let%expect_test _ = quickcheck_m [%here] (module Inst_and_key_and_data) ~f:(fun (t, k, d) -> require_equal [%here] (module Alist) (to_alist (filter_map t ~f:(fun data -> Option.some_if (data >= d) (data - d)))) (List.filter_map (to_alist t) ~f:(fun (key, data) -> Option.some_if (data >= d) (key, data - d))); require_equal [%here] (module Alist) (to_alist (filter_mapi t ~f:(fun ~key ~data -> Option.some_if (Key.( <= ) key k && data >= d) (data - d)))) (List.filter_map (to_alist t) ~f:(fun (key, data) -> Option.some_if (Key.( <= ) key k && data >= d) (key, data - d)))); [%expect {| |}] ;; let partition_mapi = partition_mapi let partition_map = partition_map let partitioni_tf = partitioni_tf let partition_tf = partition_tf let%expect_test _ = quickcheck_m [%here] (module Inst_and_key_and_data) ~f:(fun (t, k, d) -> require_equal [%here] (module Physical_equality (Inst)) (fst (partition_tf ~f:(fun _ -> true) t)) t; require_equal [%here] (module Pair (Alist)) (let a, b = partition_tf t ~f:(fun data -> data <= d) in to_alist a, to_alist b) (List.partition_tf (to_alist t) ~f:(fun (_, data) -> data <= d)); require_equal [%here] (module Pair (Alist)) (let a, b = partitioni_tf t ~f:(fun ~key ~data -> Key.( <= ) key k && data <= d) in to_alist a, to_alist b) (List.partition_tf (to_alist t) ~f:(fun (key, data) -> Key.( <= ) key k && data <= d)); require_equal [%here] (module Pair (Alist)) (let a, b = partition_map t ~f:(fun data -> if data >= d then First (data - d) else Second d) in to_alist a, to_alist b) (List.partition_map (to_alist t) ~f:(fun (key, data) -> if data >= d then First (key, data - d) else Second (key, d))); require_equal [%here] (module Pair (Alist)) (let a, b = partition_mapi t ~f:(fun ~key ~data -> if Key.( <= ) key k && data >= d then First (data - d) else Second d) in to_alist a, to_alist b) (List.partition_map (to_alist t) ~f:(fun (key, data) -> if Key.( <= ) key k && data >= d then First (key, data - d) else Second (key, d)))); [%expect {| |}] ;; let fold = fold let fold_right = fold_right let%expect_test _ = quickcheck_m [%here] (module Inst) ~f:(fun t -> require_equal [%here] (module Alist) (fold t ~init:[] ~f:(fun ~key ~data list -> (key, data) :: list)) (List.rev (to_alist t)); require_equal [%here] (module Alist) (fold_right t ~init:[] ~f:(fun ~key ~data list -> (key, data) :: list)) (to_alist t)); [%expect {| |}] ;; let fold_until = fold_until let iteri_until = iteri_until let%expect_test _ = quickcheck_m [%here] (module Inst_and_key) ~f:(fun (t, threshold) -> require_equal [%here] (module struct type t = int list * Base.Map.Finished_or_unfinished.t [@@deriving equal, sexp_of] end) (let q = Queue.create () in let status = iteri_until t ~f:(fun ~key ~data -> if Key.( >= ) key threshold then Stop else ( Queue.enqueue q data; Continue)) in Queue.to_list q, status) (let list = to_alist t |> List.take_while ~f:(fun (key, _) -> Key.( < ) key threshold) |> List.map ~f:snd in list, if List.length list = length t then Finished else Unfinished)); [%expect {| |}] ;; let combine_errors = combine_errors let%expect_test _ = quickcheck_m [%here] (module Inst_and_key) ~f:(fun (t, threshold) -> let t = mapi t ~f:(fun ~key ~data -> if Key.( <= ) key threshold then Ok data else Or_error.error_string "too big") in require_equal [%here] (module Ok (Inst)) (access combine_errors t) (to_alist t |> List.map ~f:(fun (key, result) -> Or_error.map result ~f:(fun data -> key, data)) |> Or_error.combine_errors |> Or_error.map ~f:(create of_alist_exn))); [%expect {| |}] ;; let equal = equal let compare_direct = compare_direct let%expect_test _ = quickcheck_m [%here] (module Pair (Inst)) ~f:(fun (a, b) -> require_equal [%here] (module Ordering) (Ordering.of_int (access compare_direct Int.compare a b)) (Ordering.of_int (Alist.compare (to_alist a) (to_alist b))); require_equal [%here] (module Bool) (access compare_direct Int.compare a b = 0) (access equal Int.equal a b)); [%expect {| |}] ;; let keys = keys let data = data let to_alist = to_alist let to_sequence = to_sequence let%expect_test _ = quickcheck_m [%here] (module Inst) ~f:(fun t -> let alist = to_alist t in require_equal [%here] (module Inst) (create of_alist_exn alist) t; require_equal [%here] (module Lst (Key)) (keys t) (List.map alist ~f:fst); require_equal [%here] (module Lst (Int)) (data t) (List.map alist ~f:snd); require_equal [%here] (module Alist) (Sequence.to_list ((access to_sequence) t)) alist); [%expect {| |}] ;; let%expect_test _ = quickcheck_m [%here] (module struct type t = Inst.t * [ `Decreasing | `Increasing ] [@@deriving quickcheck, sexp_of] end) ~f:(fun (t, key_order) -> let alist = to_alist t ~key_order in require_equal [%here] (module Lst (Key_and_data)) alist (match key_order with | `Increasing -> to_alist t | `Decreasing -> List.rev (to_alist t)); require_equal [%here] (module Lst (Key_and_data)) alist (Sequence.to_list ((access to_sequence) t ~order: (match key_order with | `Decreasing -> `Decreasing_key | `Increasing -> `Increasing_key)))); [%expect {| |}] ;; let%expect_test _ = quickcheck_m [%here] (module struct type t = Inst.t * [ `Decreasing_key | `Increasing_key ] * Key.t * Key.t [@@deriving quickcheck, sexp_of] end) ~f:(fun (t, order, keys_greater_or_equal_to, keys_less_or_equal_to) -> let alist = Sequence.to_list ((access to_sequence) t ~order ~keys_greater_or_equal_to ~keys_less_or_equal_to) in require_equal [%here] (module Lst (Key_and_data)) alist (List.filter (match order with | `Decreasing_key -> List.rev (to_alist t) | `Increasing_key -> to_alist t) ~f:(fun (key, _) -> Key.( <= ) keys_greater_or_equal_to key && Key.( <= ) key keys_less_or_equal_to))); [%expect {| |}] ;; let merge = merge let iter2 = iter2 let fold2 = fold2 let%expect_test _ = quickcheck_m [%here] (module struct module Inst2 = Pair (Inst) type t = Inst2.t * Key.t [@@deriving quickcheck, sexp_of] end) ~f:(fun ((a, b), k) -> let merge_alist = access merge a b ~f:(fun ~key elt -> Option.some_if (Key.( > ) key k) (key, elt)) |> data in let iter2_alist = let q = Queue.create () in access iter2 a b ~f:(fun ~key ~data:elt -> if Key.( > ) key k then Queue.enqueue q (key, elt)); Queue.to_list q in let fold2_alist = access fold2 a b ~init:[] ~f:(fun ~key ~data:elt acc -> if Key.( > ) key k then (key, elt) :: acc else acc) |> List.rev in let expect = [ map a ~f:Either.first; map b ~f:Either.second ] |> List.concat_map ~f:to_alist |> List.Assoc.sort_and_group ~compare:Key.compare |> List.filter_map ~f:(fun (key, list) -> let elt = match (list : _ Either.t list) with | [ First x ] -> `Left x | [ Second y ] -> `Right y | [ First x; Second y ] -> `Both (x, y) | _ -> assert false in Option.some_if (Key.( > ) key k) (key, elt)) in require_equal [%here] (module Alist_merge) merge_alist expect; require_equal [%here] (module Alist_merge) iter2_alist expect; require_equal [%here] (module Alist_merge) fold2_alist expect); [%expect {| |}] ;; let merge_skewed = merge_skewed let%expect_test _ = quickcheck_m [%here] (module Pair (Inst)) ~f:(fun (a, b) -> let actual = access merge_skewed a b ~combine:(fun ~key a b -> int key + a + b) in let expect = access merge a b ~f:(fun ~key elt -> match elt with | `Left a -> Some a | `Right b -> Some b | `Both (a, b) -> Some (int key + a + b)) in require_equal [%here] (module Inst) actual expect); [%expect {| |}] ;; let symmetric_diff = symmetric_diff let fold_symmetric_diff = fold_symmetric_diff let%expect_test _ = quickcheck_m [%here] (module Pair (Inst)) ~f:(fun (a, b) -> let diff_alist = access symmetric_diff a b ~data_equal:Int.equal |> Sequence.to_list in let fold_alist = access fold_symmetric_diff a b ~data_equal:(fun x y -> Int.equal x y) ~init:[] ~f:(fun acc pair -> pair :: acc) |> List.rev in let expect = access merge a b ~f:(fun ~key:_ elt -> match elt with | `Left x -> Some (`Left x) | `Right y -> Some (`Right y) | `Both (x, y) -> if x = y then None else Some (`Unequal (x, y))) |> to_alist in require_equal [%here] (module Diff) diff_alist expect; require_equal [%here] (module Diff) fold_alist expect); [%expect {| |}] ;; let min_elt = min_elt let max_elt = max_elt let min_elt_exn = min_elt_exn let max_elt_exn = max_elt_exn let%expect_test _ = quickcheck_m [%here] (module Inst) ~f:(fun t -> require_equal [%here] (module Opt (Key_and_data)) (min_elt t) (List.hd (to_alist t)); require_equal [%here] (module Opt (Key_and_data)) (max_elt t) (List.last (to_alist t)); require_equal [%here] (module Opt (Key_and_data)) (Option.try_with (fun () -> min_elt_exn t)) (List.hd (to_alist t)); require_equal [%here] (module Opt (Key_and_data)) (Option.try_with (fun () -> max_elt_exn t)) (List.last (to_alist t))); [%expect {| |}] ;; let for_all = for_all let for_alli = for_alli let exists = exists let existsi = existsi let count = count let counti = counti let%expect_test _ = quickcheck_m [%here] (module Inst_and_key_and_data) ~f:(fun (t, k, d) -> let f data = data <= d in let fi ~key ~data = Key.( <= ) key k && data <= d in let fp (key, data) = fi ~key ~data in let data = data t in let alist = to_alist t in require_equal [%here] (module Bool) (for_all t ~f) (List.for_all data ~f); require_equal [%here] (module Bool) (for_alli t ~f:fi) (List.for_all alist ~f:fp); require_equal [%here] (module Bool) (exists t ~f) (List.exists data ~f); require_equal [%here] (module Bool) (existsi t ~f:fi) (List.exists alist ~f:fp); require_equal [%here] (module Int) (count t ~f) (List.count data ~f); require_equal [%here] (module Int) (counti t ~f:fi) (List.count alist ~f:fp)); [%expect {| |}] ;; let split = split let%expect_test "split" = quickcheck_m [%here] (module Inst_and_key) ~f:(fun (t, k) -> require_equal [%here] (module struct type t = Inst.t * (Key.t * int) option * Inst.t [@@deriving equal, sexp_of] end) (access split t k) (let before, equal, after = List.partition3_map (to_alist t) ~f:(fun (key, data) -> match Ordering.of_int (Key.compare key k) with | Less -> `Fst (key, data) | Equal -> `Snd (key, data) | Greater -> `Trd (key, data)) in create of_alist_exn before, List.hd equal, create of_alist_exn after)); [%expect {| |}] ;; let split_le_gt = split_le_gt let%expect_test "split_le_gt" = quickcheck_m [%here] (module Inst_and_key) ~f:(fun (t, k) -> require_equal [%here] (module struct type t = Inst.t * Inst.t [@@deriving equal, sexp_of] end) (access split_le_gt t k) (let before, after = List.partition_tf (to_alist t) ~f:(fun (key, _) -> Key.( <= ) key k) in create of_alist_exn before, create of_alist_exn after)); [%expect {| |}] ;; let split_lt_ge = split_lt_ge let%expect_test "split_lt_ge" = quickcheck_m [%here] (module Inst_and_key) ~f:(fun (t, k) -> require_equal [%here] (module struct type t = Inst.t * Inst.t [@@deriving equal, sexp_of] end) (access split_lt_ge t k) (let before, after = List.partition_tf (to_alist t) ~f:(fun (key, _) -> Key.( < ) key k) in create of_alist_exn before, create of_alist_exn after)); [%expect {| |}] ;; let append = append let%expect_test _ = quickcheck_m [%here] (module Pair (Inst)) ~f:(fun (a, b) -> require_equal [%here] (module Ok (Inst)) (match access append ~lower_part:a ~upper_part:b with | `Ok t -> Ok t | `Overlapping_key_ranges -> Or_error.error_string "overlap") (match max_elt a, min_elt b with | Some (x, _), Some (y, _) when Key.( >= ) x y -> Or_error.error_string "overlap" | _ -> Ok (create of_alist_exn (to_alist a @ to_alist b))); let a' = (* we rely on the fact that the [Inst] generator uses positive keys *) create map_keys_exn a ~f:(fun k -> key (-int k)) in require_equal [%here] (module Ok (Inst)) (match access append ~lower_part:a' ~upper_part:b with | `Ok t -> Ok t | `Overlapping_key_ranges -> Or_error.error_string "overlap") (Ok (create of_alist_exn (to_alist a' @ to_alist b)))); [%expect {| |}] ;; let subrange = subrange let fold_range_inclusive = fold_range_inclusive let range_to_alist = range_to_alist let%expect_test _ = quickcheck_m [%here] (module struct type t = Inst.t * Key.t Maybe_bound.t * Key.t Maybe_bound.t [@@deriving quickcheck, sexp_of] end) ~f:(fun (t, lower_bound, upper_bound) -> let subrange_alist = access subrange t ~lower_bound ~upper_bound |> to_alist in let min = match lower_bound with | Unbounded -> key Int.min_value | Incl min -> min | Excl too_small -> (* key generator does not generate [max_value], so this cannot overflow *) key (int too_small + 1) in let max = match upper_bound with | Unbounded -> key Int.max_value | Incl max -> max | Excl too_large -> (* key generator does not generate [min_value], so this cannot overflow *) key (int too_large - 1) in let fold_alist = access fold_range_inclusive t ~min ~max ~init:[] ~f:(fun ~key ~data acc -> (key, data) :: acc) |> List.rev in let range_alist = access range_to_alist t ~min ~max in let expect = if Maybe_bound.bounds_crossed ~lower:lower_bound ~upper:upper_bound ~compare:Key.compare then [] else List.filter (to_alist t) ~f:(fun (key, _) -> Maybe_bound.interval_contains_exn key ~lower:lower_bound ~upper:upper_bound ~compare:Key.compare) in require_equal [%here] (module Alist) subrange_alist expect; require_equal [%here] (module Alist) fold_alist expect; require_equal [%here] (module Alist) range_alist expect); [%expect {| |}] ;; let closest_key = closest_key let%expect_test _ = quickcheck_m [%here] (module Inst_and_key) ~f:(fun (t, k) -> let alist = to_alist t in let rev_alist = List.rev alist in require_equal [%here] (module Opt (Key_and_data)) (access closest_key t `Less_than k) (List.find rev_alist ~f:(fun (key, _) -> Key.( < ) key k)); require_equal [%here] (module Opt (Key_and_data)) (access closest_key t `Less_or_equal_to k) (List.find rev_alist ~f:(fun (key, _) -> Key.( <= ) key k)); require_equal [%here] (module Opt (Key_and_data)) (access closest_key t `Greater_or_equal_to k) (List.find alist ~f:(fun (key, _) -> Key.( >= ) key k)); require_equal [%here] (module Opt (Key_and_data)) (access closest_key t `Greater_than k) (List.find alist ~f:(fun (key, _) -> Key.( > ) key k))); [%expect {| |}] ;; let nth = nth let nth_exn = nth_exn let rank = rank let%expect_test _ = quickcheck_m [%here] (module Inst_and_key) ~f:(fun (t, k) -> List.iteri (to_alist t) ~f:(fun i (key, data) -> require_equal [%here] (module Opt (Key_and_data)) (nth t i) (Some (key, data)); require_equal [%here] (module Opt (Key_and_data)) (Option.try_with (fun () -> nth_exn t i)) (nth t i); require_equal [%here] (module Opt (Int)) (access rank t key) (Some i)); require_equal [%here] (module Opt (Key_and_data)) (nth t (length t)) None; require_equal [%here] (module Opt (Int)) (access rank t k) (List.find_mapi (to_alist t) ~f:(fun i (key, _) -> Option.some_if (Key.equal key k) i))); [%expect {| |}] ;; let binary_search = binary_search let%expect_test _ = quickcheck_m [%here] (module Inst_and_key) ~f:(fun (t, k) -> let targets = [%all: Binary_searchable.Which_target_by_key.t] in let compare (key, _) k = Key.compare key k in List.iter targets ~f:(fun which_target -> require_equal [%here] (module Opt (Key_and_data)) (access binary_search t ~compare:(fun ~key ~data k' -> require_equal [%here] (module Key) k' k; require_equal [%here] (module Opt (Int)) (access find t key) (Some data); [%expect {| |}]; compare (key, data) k') which_target k) (let array = Array.of_list (to_alist t) in Array.binary_search array ~compare which_target k |> Option.map ~f:(Array.get array)))); [%expect {| |}] ;; let binary_search_segmented = binary_search_segmented let%expect_test _ = quickcheck_m [%here] (module Inst_and_key) ~f:(fun (t, k) -> let targets = [%all: Binary_searchable.Which_target_by_segment.t] in let segment_of (key, _) = if Key.( <= ) key k then `Left else `Right in List.iter targets ~f:(fun which_target -> require_equal [%here] (module Opt (Key_and_data)) (access binary_search_segmented t ~segment_of:(fun ~key ~data -> require_equal [%here] (module Opt (Int)) (access find t key) (Some data); [%expect {| |}]; segment_of (key, data)) which_target) (let array = Array.of_list (to_alist t) in Array.binary_search_segmented array ~segment_of which_target |> Option.map ~f:(Array.get array)))); [%expect {| |}] ;; let binary_search_subrange = binary_search_subrange let%expect_test _ = quickcheck_m [%here] (module struct type t = Inst.t * Key.t Maybe_bound.t * Key.t Maybe_bound.t [@@deriving quickcheck, sexp_of] end) ~f:(fun (t, lower_bound, upper_bound) -> require_equal [%here] (module Inst) (access binary_search_subrange t ~compare:(fun ~key ~data bound -> require_equal [%here] (module Opt (Int)) (access find t key) (Some data); [%expect {| |}]; Key.compare key bound) ~lower_bound ~upper_bound) (access subrange t ~lower_bound ~upper_bound)); [%expect {| |}] ;; module Make_applicative_traversals (A : Applicative.Lazy_applicative) = struct module M = Make_applicative_traversals (A) let mapi = M.mapi let filter_mapi = M.filter_mapi end let%expect_test _ = let module M = Make_applicative_traversals (struct module M = struct type 'a t = 'a let return x = x let apply f x = f x let of_thunk f = f () let map = `Define_using_apply end include M include Applicative.Make (M) end) in quickcheck_m [%here] (module Inst) ~f:(fun t -> let f1 ~key:_ ~data = (data * 2) + 1 in let f2 ~key:_ ~data = if data < 0 then None else Some data in require_equal [%here] (module Inst) (mapi t ~f:f1) (M.mapi t ~f:f1); require_equal [%here] (module Inst) (filter_mapi t ~f:f2) (M.filter_mapi t ~f:f2)); [%expect {| |}] ;; (** tree conversion *) let to_tree = to_tree let of_tree = of_tree let%expect_test _ = quickcheck_m [%here] (module Inst) ~f:(fun t -> let tree = to_tree t in let round_trip = create of_tree tree in require_equal [%here] (module Inst) t round_trip; require_equal [%here] (module Alist) (to_alist t) (Map.Using_comparator.Tree.to_alist (Instance.tree tree))); [%expect {| |}] ;; end (** Expect tests for all of [Base.Map]'s exports. *) module _ : module type of struct include Base.Map end [@ocaml.remove_aliases] = struct open Base.Map (** module types *) module type Accessors_generic = Accessors_generic module type Creators_and_accessors_generic = Creators_and_accessors_generic module type Creators_generic = Creators_generic module type For_deriving = For_deriving module type S_poly = S_poly (** type-only modules for module type instantiation - untested *) module With_comparator = With_comparator module With_first_class_module = With_first_class_module module Without_comparator = Without_comparator (** supporting datatypes - untested *) module Continue_or_stop = Continue_or_stop module Finished_or_unfinished = Finished_or_unfinished module Merge_element = Merge_element module Or_duplicate = Or_duplicate module Symmetric_diff_element = Symmetric_diff_element (** types *) type nonrec ('k, 'v, 'c) t = ('k, 'v, 'c) t type nonrec ('k, 'c) comparator = ('k, 'c) Comparator.Module.t (** module types for ppx deriving *) module type Compare_m = Compare_m module type Equal_m = Equal_m module type Hash_fold_m = Hash_fold_m module type M_sexp_grammar = M_sexp_grammar module type M_of_sexp = M_of_sexp module type Sexp_of_m = Sexp_of_m (** functor for ppx deriving - tested below *) module M = M (** sexp conversions and grammar *) let sexp_of_m__t = sexp_of_m__t let m__t_of_sexp = m__t_of_sexp let%expect_test _ = quickcheck_m [%here] (module Instance_int) ~f:(fun t -> let sexp = [%sexp_of: int M(Int).t] t in require_equal [%here] (module Sexp) sexp [%sexp (to_alist t : (int * int) list)]; let round_trip = [%of_sexp: int M(Int).t] sexp in require_equal [%here] (module Instance_int) round_trip t); [%expect {| |}] ;; let m__t_sexp_grammar = m__t_sexp_grammar let%expect_test _ = print_s [%sexp ([%sexp_grammar: int M(Int).t] : _ Sexp_grammar.t)]; [%expect {| (Tagged ( (key sexp_grammar.assoc) (value ()) (grammar ( List ( Many ( List ( Cons (Tagged ((key sexp_grammar.assoc.key) (value ()) (grammar Integer))) (Cons (Tagged ( (key sexp_grammar.assoc.value) (value ()) (grammar Integer))) Empty)))))))) |}] ;; (** comparisons *) let compare_m__t = compare_m__t let equal_m__t = equal_m__t let%expect_test _ = quickcheck_m [%here] (module Pair (Instance_int)) ~f:(fun (a, b) -> require_equal [%here] (module Ordering) (Ordering.of_int ([%compare: int M(Int).t] a b)) (Ordering.of_int ([%compare: (int * int) list] (to_alist a) (to_alist b))); require_equal [%here] (module Bool) ([%equal: int M(Int).t] a b) ([%equal: (int * int) list] (to_alist a) (to_alist b))); [%expect {| |}] ;; (** hash functions *) let hash_fold_m__t = hash_fold_m__t let hash_fold_direct = hash_fold_direct let%expect_test _ = quickcheck_m [%here] (module Instance_int) ~f:(fun t -> let actual_m = Hash.run [%hash_fold: int M(Int).t] t in let actual_direct = Hash.run (hash_fold_direct Int.hash_fold_t Int.hash_fold_t) t in let expect = Hash.run [%hash_fold: (int * int) list] (to_alist t) in require_equal [%here] (module Int) actual_m expect; require_equal [%here] (module Int) actual_direct expect); [%expect {| |}] ;; (** comparator accessors - untested *) let comparator_s = comparator_s let comparator = comparator (** creators and accessors *) include Test_creators_and_accessors (struct type 'k key = 'k type 'c cmp = 'c type ('k, 'v, 'c) tree = ('k, 'v, 'c) Using_comparator.Tree.t type ('k, 'c, 'a) create_options = ('k, 'c) comparator -> 'a type ('k, 'c, 'a) access_options = 'a include Base.Map end) (struct include Base.Map end) (struct include Instance (Int) let create f = f ((module Int) : _ Comparator.Module.t) let access x = x end) (** polymorphic comparison interface *) module Poly = struct open Poly type nonrec ('k, 'v) t = ('k, 'v) t type nonrec ('k, 'v) tree = ('k, 'v) tree type nonrec comparator_witness = comparator_witness include Test_creators_and_accessors (struct type 'k key = 'k type 'c cmp = comparator_witness type nonrec ('k, 'v, _) t = ('k, 'v) t type nonrec ('k, 'v, _) tree = ('k, 'v) tree type ('k, 'c, 'a) create_options = 'a type ('k, 'c, 'a) access_options = 'a end) (struct include Poly end) (struct include Instance (Comparator.Poly) let create x = x let access x = x end) end (** comparator interface *) module Using_comparator = struct open Using_comparator (** type *) type nonrec ('k, 'v, 'c) t = ('k, 'v, 'c) t (** comparator accessor - untested *) let comparator = comparator (** sexp conversions *) let sexp_of_t = sexp_of_t let t_of_sexp_direct = t_of_sexp_direct let%expect_test _ = quickcheck_m [%here] (module Instance_int) ~f:(fun t -> let sexp = sexp_of_t Int.sexp_of_t Int.sexp_of_t [%sexp_of: _] t in require_equal [%here] (module Sexp) sexp ([%sexp_of: int Map.M(Int).t] t); let round_trip = t_of_sexp_direct ~comparator:Int.comparator Int.t_of_sexp Int.t_of_sexp sexp in require_equal [%here] (module Instance_int) round_trip t); [%expect {| |}] ;; (** hash function *) let hash_fold_direct = hash_fold_direct let%expect_test _ = quickcheck_m [%here] (module Instance_int) ~f:(fun t -> require_equal [%here] (module Int) (Hash.run (hash_fold_direct Int.hash_fold_t Int.hash_fold_t) t) (Hash.run [%hash_fold: int Map.M(Int).t] t)); [%expect {| |}] ;; (** functor for polymorphic definition - untested *) module Empty_without_value_restriction (Cmp : Comparator.S1) = struct open Empty_without_value_restriction (Cmp) let empty = empty end (** creators and accessors *) include Test_creators_and_accessors (struct type 'k key = 'k type 'c cmp = 'c type ('k, 'v, 'c) tree = ('k, 'v, 'c) Tree.t type ('k, 'c, 'a) create_options = comparator:('k, 'c) Comparator.t -> 'a type ('k, 'c, 'a) access_options = 'a include Using_comparator end) (struct include Using_comparator end) (struct include Instance (Int) let create f = f ~comparator:Int.comparator let access x = x end) (** tree interface *) module Tree = struct open Tree (** type *) type nonrec ('k, 'v, 'c) t = ('k, 'v, 'c) t (** sexp conversions *) let sexp_of_t = sexp_of_t let t_of_sexp_direct = t_of_sexp_direct let%expect_test _ = let module Tree_int = struct module I = Instance_tree (Int) type t = int I.t [@@deriving equal, quickcheck, sexp_of] end in quickcheck_m [%here] (module Tree_int) ~f:(fun tree -> let sexp = sexp_of_t Int.sexp_of_t Int.sexp_of_t [%sexp_of: _] tree in require_equal [%here] (module Sexp) sexp ([%sexp_of: int Map.M(Int).t] (Using_comparator.of_tree tree ~comparator:Int.comparator)); let round_trip = t_of_sexp_direct ~comparator:Int.comparator Int.t_of_sexp Int.t_of_sexp sexp in require_equal [%here] (module Tree_int) round_trip tree); [%expect {| |}] ;; (** polymorphic constructor - untested *) let empty_without_value_restriction = empty_without_value_restriction (** builders *) module Build_increasing = struct open Build_increasing type nonrec ('k, 'v, 'c) t = ('k, 'v, 'c) t (** tree builder functions *) let empty = empty let add_exn = add_exn let to_tree = to_tree let%expect_test _ = let module Tree_int = struct module I = Instance_tree (Int) type t = int I.t [@@deriving equal, quickcheck, sexp_of] end in quickcheck_m [%here] (module struct type t = ((int[@generator Base_quickcheck.Generator.small_strictly_positive_int]) * int) list [@@deriving quickcheck, sexp_of] end) ~f:(fun alist -> let actual = List.fold_result alist ~init:empty ~f:(fun builder (key, data) -> Or_error.try_with (fun () -> add_exn builder ~comparator:Int.comparator ~key ~data)) |> Or_error.map ~f:Build_increasing.to_tree in let expect = Map.Using_comparator.Tree.of_increasing_sequence ~comparator:Int.comparator (Sequence.of_list alist) in require_equal [%here] (module Ok (Tree_int)) actual expect); [%expect {| |}] ;; end (** creators and accessors *) include Test_creators_and_accessors (struct type 'k key = 'k type 'c cmp = 'c type ('k, 'v, 'c) tree = ('k, 'v, 'c) t type ('k, 'c, 'a) create_options = comparator:('k, 'c) Comparator.t -> 'a type ('k, 'c, 'a) access_options = comparator:('k, 'c) Comparator.t -> 'a include Tree end) (struct include Tree end) (struct include Instance_tree (Int) let create f = f ~comparator:Int.comparator let access f = f ~comparator:Int.comparator end) end end end base-0.16.3/test/test_map_comprehensive.mli000066400000000000000000000000551446274340700207530ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_map_interface.ml000066400000000000000000000011111446274340700176650ustar00rootroot00000000000000open! Base (* Typechecking this code is a compile-time check that the specific interfaces have not drifted apart from each other. *) module _ : sig open Map type ('a, 'b, 'c) t include Creators_and_accessors_generic with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Map.Using_comparator.Tree.t with type 'k key := 'k with type 'c cmp := 'c with type ('a, 'b, 'c) access_options := ('a, 'b, 'c) Without_comparator.t with type ('a, 'b, 'c) create_options := ('a, 'b, 'c) With_first_class_module.t end = Map base-0.16.3/test/test_map_interface.mli000066400000000000000000000000541446274340700200430ustar00rootroot00000000000000(* This signature is deliberately empty. *) base-0.16.3/test/test_map_traversal.ml000066400000000000000000000100061446274340700177330ustar00rootroot00000000000000open! Import open! Map open! Int module Lazy_apply = struct module T = struct type 'a t = { compute : unit -> 'a } [@@unboxed] let run t = t.compute () let return x = { compute = (fun () -> x) } let map x ~f = { compute = (fun () -> f (run x)) } let both x y = { compute = (fun () -> run x, run y) } let map2 a b ~f = map (both a b) ~f:(fun (x, y) -> f x y) let map = `Custom map end include T include Applicative.Make_using_map2 (T) let of_thunk f = { compute = (fun () -> run (f ())) } end module Lazy_map = Map.Make_applicative_traversals (Lazy_apply) let%expect_test "mapi correctness check" = let map = Map.of_alist_exn (module Int) (List.init 100 ~f:(fun x -> x, x)) in let f ~key:_ ~data = data + 1 in let test_output = Lazy_map.mapi map ~f:(fun ~key ~data -> Lazy_apply.return (f ~key ~data)) |> Lazy_apply.run in let reference_output = Map.mapi map ~f in require [%here] (Map.equal Int.equal test_output reference_output); require [%here] (Map.invariants test_output); [%expect {| |}] ;; let%expect_test "filter_mapi correctness check" = let map = Map.of_alist_exn (module Int) (List.init 1000 ~f:(fun x -> x, x)) in let f ~key:_ ~data = if data % 50 > 10 then None else Some data in let test_output = Lazy_map.filter_mapi map ~f:(fun ~key ~data -> Lazy_apply.return (f ~key ~data)) |> Lazy_apply.run in let reference_output = Map.filter_mapi map ~f in require [%here] (Map.equal Int.equal test_output reference_output); require [%here] (Map.invariants test_output); [%expect {| |}] ;; module Step_applicative = struct module M = struct type 'a t = { compute : steps:int -> ('a * int, 'a t) Either.t } let return x = { compute = (fun ~steps -> First (x, steps)) } let step x = let rec t = { compute = (fun ~steps -> if steps > 0 then First (x, steps - 1) else Second t) } in t ;; let internal_map x ~f = let rec fn t = { compute = (fun ~steps -> match t.compute ~steps with | First (x, steps) -> First (f x, steps) | Second t -> Second (fn t)) } in fn x ;; let map2 a b ~f = let rec fn a = { compute = (fun ~steps -> match a.compute ~steps with | First (x, steps) -> (internal_map b ~f:(fun y -> f x y)).compute ~steps | Second t -> Second (fn t)) } in fn a ;; let map = `Custom internal_map let of_thunk f = { compute = (fun ~steps -> let t = f () in t.compute ~steps) } ;; end include M include Applicative.Make_using_map2 (M) end module Step_map = Map.Make_applicative_traversals (Step_applicative) let%expect_test "mapi lazy check" = let map = Map.of_alist_exn (module Int) (List.init 10 ~f:(fun x -> x, x)) in let f ~key:_ ~data = data * 2 in (* transform the map, expect no output yet *) let step_computation = Step_map.mapi map ~f:(fun ~key ~data -> Step_applicative.of_thunk (fun () -> print_s [%message (key : int) (data : int)]; Step_applicative.step (f ~key ~data))) in [%expect {| |}]; (* take a few steps, expect some but not all output *) let more_computation = match step_computation.compute ~steps:3 with | First _ -> assert false | Second c -> c in [%expect {| ((key 0) (data 0)) ((key 1) (data 1)) ((key 2) (data 2)) ((key 3) (data 3)) |}]; (* take more than enough steps to finish, expect the rest of the output *) let test_output = match more_computation.compute ~steps:100 with | First (r, _) -> r | Second _ -> assert false in let reference_output = Map.mapi map ~f in require [%here] (Map.equal Int.equal test_output reference_output); [%expect {| ((key 4) (data 4)) ((key 5) (data 5)) ((key 6) (data 6)) ((key 7) (data 7)) ((key 8) (data 8)) ((key 9) (data 9)) |}] ;; base-0.16.3/test/test_map_traversal.mli000066400000000000000000000000551446274340700201070ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_maybe_bound.ml000066400000000000000000000061311446274340700173630ustar00rootroot00000000000000open! Import open! Maybe_bound let%test_unit "bounds_crossed" = let a, b, c, d = Incl 1, Excl 1, Incl 3, Excl 3 in let cases = [ a, a, false ; a, b, false ; a, c, false ; a, d, false ; b, a, false ; b, b, false ; b, c, false ; b, d, false ; c, a, true ; c, b, true ; c, c, false ; c, d, false ; d, a, true ; d, b, true ; d, c, false ; d, d, false ] in List.iter cases ~f:(fun (lower, upper, expect) -> let actual = bounds_crossed ~lower ~upper ~compare in assert ([%compare.equal: bool] expect actual)) ;; let%test_module "is_lower_bound" = (module struct let compare = Int.compare let%test _ = is_lower_bound Unbounded ~of_:Int.min_value ~compare let%test _ = not (is_lower_bound (Incl 2) ~of_:1 ~compare) let%test _ = is_lower_bound (Incl 2) ~of_:2 ~compare let%test _ = is_lower_bound (Incl 2) ~of_:3 ~compare let%test _ = not (is_lower_bound (Excl 2) ~of_:1 ~compare) let%test _ = not (is_lower_bound (Excl 2) ~of_:2 ~compare) let%test _ = is_lower_bound (Excl 2) ~of_:3 ~compare end) ;; let%test_module "is_upper_bound" = (module struct let compare = Int.compare let%test _ = is_upper_bound Unbounded ~of_:Int.max_value ~compare let%test _ = is_upper_bound (Incl 2) ~of_:1 ~compare let%test _ = is_upper_bound (Incl 2) ~of_:2 ~compare let%test _ = not (is_upper_bound (Incl 2) ~of_:3 ~compare) let%test _ = is_upper_bound (Excl 2) ~of_:1 ~compare let%test _ = not (is_upper_bound (Excl 2) ~of_:2 ~compare) let%test _ = not (is_upper_bound (Excl 2) ~of_:3 ~compare) end) ;; let%test_module "check_range" = (module struct let compare = Int.compare let tests (lower, upper) cases = List.iter cases ~f:(fun (n, comparison) -> [%test_result: interval_comparison] ~expect:comparison (compare_to_interval_exn n ~lower ~upper ~compare); [%test_result: bool] ~expect: (match comparison with | In_range -> true | _ -> false) (interval_contains_exn n ~lower ~upper ~compare)) ;; let%test_unit _ = tests (Unbounded, Unbounded) [ Int.min_value, In_range; 0, In_range; Int.max_value, In_range ] ;; let%test_unit _ = tests (Incl 2, Incl 4) [ 1, Below_lower_bound ; 2, In_range ; 3, In_range ; 4, In_range ; 5, Above_upper_bound ] ;; let%test_unit _ = tests (Incl 2, Excl 4) [ 1, Below_lower_bound ; 2, In_range ; 3, In_range ; 4, Above_upper_bound ; 5, Above_upper_bound ] ;; let%test_unit _ = tests (Excl 2, Incl 4) [ 1, Below_lower_bound ; 2, Below_lower_bound ; 3, In_range ; 4, In_range ; 5, Above_upper_bound ] ;; let%test_unit _ = tests (Excl 2, Excl 4) [ 1, Below_lower_bound ; 2, Below_lower_bound ; 3, In_range ; 4, Above_upper_bound ; 5, Above_upper_bound ] ;; end) ;; base-0.16.3/test/test_maybe_bound.mli000066400000000000000000000000551446274340700175330ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_minmax.ml000066400000000000000000000105571446274340700163770ustar00rootroot00000000000000open Import module Size = struct type t = | Small | Large end let[@inline never] test (type t) m size = let (module T : Int.S with type t = t) = m in let fwd = match (size : Size.t) with | Small -> List.map ~f:T.of_int_exn [ 0; -20; -10; -1; 1; 2; 4; 100 ] | Large -> [ T.min_value; T.max_value; T.zero ] in let rev = List.rev fwd in List.iter2_exn fwd rev ~f:(fun a b -> print_s [%message "min" ~_:(a : T.t) ~_:(b : T.t) "=" ~_:(T.min a b : T.t)]; print_s [%message "max" ~_:(a : T.t) ~_:(b : T.t) "=" ~_:(T.max a b : T.t)]) ;; let%expect_test "small values" = let test (module T : Int.S) = test (module T) Small; [%expect {| (min 0 100 = 0) (max 0 100 = 100) (min -20 4 = -20) (max -20 4 = 4) (min -10 2 = -10) (max -10 2 = 2) (min -1 1 = -1) (max -1 1 = 1) (min 1 -1 = -1) (max 1 -1 = 1) (min 2 -10 = -10) (max 2 -10 = 2) (min 4 -20 = -20) (max 4 -20 = 4) (min 100 0 = 0) (max 100 0 = 100) |}] in test (module Int); test (module Int64); test (module Int32); test (module Nativeint); [%expect {| |}] ;; let%expect_test "fixed-size types" = test (module Int64) Large; [%expect {| (min -9_223_372_036_854_775_808 0 = -9_223_372_036_854_775_808) (max -9_223_372_036_854_775_808 0 = 0) (min 9_223_372_036_854_775_807 9_223_372_036_854_775_807 = 9_223_372_036_854_775_807) (max 9_223_372_036_854_775_807 9_223_372_036_854_775_807 = 9_223_372_036_854_775_807) (min 0 -9_223_372_036_854_775_808 = -9_223_372_036_854_775_808) (max 0 -9_223_372_036_854_775_808 = 0) |}]; test (module Int32) Large; [%expect {| (min -2_147_483_648 0 = -2_147_483_648) (max -2_147_483_648 0 = 0) (min 2_147_483_647 2_147_483_647 = 2_147_483_647) (max 2_147_483_647 2_147_483_647 = 2_147_483_647) (min 0 -2_147_483_648 = -2_147_483_648) (max 0 -2_147_483_648 = 0) |}] ;; let%expect_test ("64-bit platforms" [@tags "no-js", "64-bits-only"]) = test (module Int) Large; [%expect {| (min -4_611_686_018_427_387_904 0 = -4_611_686_018_427_387_904) (max -4_611_686_018_427_387_904 0 = 0) (min 4_611_686_018_427_387_903 4_611_686_018_427_387_903 = 4_611_686_018_427_387_903) (max 4_611_686_018_427_387_903 4_611_686_018_427_387_903 = 4_611_686_018_427_387_903) (min 0 -4_611_686_018_427_387_904 = -4_611_686_018_427_387_904) (max 0 -4_611_686_018_427_387_904 = 0) |}]; test (module Nativeint) Large; [%expect {| (min -9_223_372_036_854_775_808 0 = -9_223_372_036_854_775_808) (max -9_223_372_036_854_775_808 0 = 0) (min 9_223_372_036_854_775_807 9_223_372_036_854_775_807 = 9_223_372_036_854_775_807) (max 9_223_372_036_854_775_807 9_223_372_036_854_775_807 = 9_223_372_036_854_775_807) (min 0 -9_223_372_036_854_775_808 = -9_223_372_036_854_775_808) (max 0 -9_223_372_036_854_775_808 = 0) |}] ;; let%expect_test ("32-bit platforms" [@tags "no-js", "32-bits-only"]) = test (module Int) Large; [%expect {| (min -1_073_741_824 0 = -1_073_741_824) (max -1_073_741_824 0 = 0) (min 1_073_741_823 1_073_741_823 = 1_073_741_823) (max 1_073_741_823 1_073_741_823 = 1_073_741_823) (min 0 -1_073_741_824 = -1_073_741_824) (max 0 -1_073_741_824 = 0) |}]; test (module Nativeint) Large; [%expect {| (min -2_147_483_648 0 = -2_147_483_648) (max -2_147_483_648 0 = 0) (min 2_147_483_647 2_147_483_647 = 2_147_483_647) (max 2_147_483_647 2_147_483_647 = 2_147_483_647) (min 0 -2_147_483_648 = -2_147_483_648) (max 0 -2_147_483_648 = 0) |}] ;; let%expect_test ("js_of_ocaml platforms" [@tags "js-only"]) = test (module Int) Large; [%expect {| (min -2_147_483_648 0 = -2_147_483_648) (max -2_147_483_648 0 = 0) (min 2_147_483_647 2_147_483_647 = 2_147_483_647) (max 2_147_483_647 2_147_483_647 = 2_147_483_647) (min 0 -2_147_483_648 = -2_147_483_648) (max 0 -2_147_483_648 = 0) |}]; test (module Nativeint) Large; [%expect {| (min -2_147_483_648 0 = -2_147_483_648) (max -2_147_483_648 0 = 0) (min 2_147_483_647 2_147_483_647 = 2_147_483_647) (max 2_147_483_647 2_147_483_647 = 2_147_483_647) (min 0 -2_147_483_648 = -2_147_483_648) (max 0 -2_147_483_648 = 0) |}] ;; base-0.16.3/test/test_minmax.mli000066400000000000000000000000551446274340700165400ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_nativeint.ml000066400000000000000000000014321446274340700170770ustar00rootroot00000000000000open! Import open! Nativeint let%expect_test "hash coherence" = check_int_hash_coherence [%here] (module Nativeint); [%expect {| |}] ;; type test_case = nativeint * int32 * int64 let test_cases : test_case list = [ 0x0000_0011n, 0x1100_0000l, 0x1100_0000_0000_0000L ; 0x0000_1122n, 0x2211_0000l, 0x2211_0000_0000_0000L ; 0x0011_2233n, 0x3322_1100l, 0x3322_1100_0000_0000L ; 0x1122_3344n, 0x4433_2211l, 0x4433_2211_0000_0000L ] ;; let%expect_test "bswap native" = List.iter test_cases ~f:(fun (arg, bswap_int32, bswap_int64) -> let result = bswap arg in match Sys.word_size_in_bits with | 32 -> assert (Int32.equal bswap_int32 (Nativeint.to_int32_trunc result)) | 64 -> assert (Int64.equal bswap_int64 (Nativeint.to_int64 result)) | _ -> assert false) ;; base-0.16.3/test/test_nativeint.mli000066400000000000000000000000551446274340700172500ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_nativeint_pow2.ml000066400000000000000000000061411446274340700200500ustar00rootroot00000000000000open! Import open! Nativeint let examples = [ -1n; 0n; 1n; 2n; 3n; 4n; 5n; 7n; 8n; 9n; 63n; 64n; 65n ] let examples_64_bit = [ min_value; succ min_value; pred max_value; max_value ] let print_for ints f = List.iter ints ~f:(fun i -> print_s [%message "" ~_:(i : nativeint) ~_:(Or_error.try_with (fun () -> f i) : int Or_error.t)]) ;; let%expect_test "[floor_log2]" = print_for examples floor_log2; [%expect {| (-1 (Error ("[Nativeint.floor_log2] got invalid input" -1))) (0 (Error ("[Nativeint.floor_log2] got invalid input" 0))) (1 (Ok 0)) (2 (Ok 1)) (3 (Ok 1)) (4 (Ok 2)) (5 (Ok 2)) (7 (Ok 2)) (8 (Ok 3)) (9 (Ok 3)) (63 (Ok 5)) (64 (Ok 6)) (65 (Ok 6)) |}] ;; let%expect_test ("[floor_log2]" [@tags "64-bits-only"]) = print_for examples_64_bit floor_log2; [%expect {| (-9_223_372_036_854_775_808 ( Error ("[Nativeint.floor_log2] got invalid input" -9223372036854775808))) (-9_223_372_036_854_775_807 ( Error ("[Nativeint.floor_log2] got invalid input" -9223372036854775807))) (9_223_372_036_854_775_806 (Ok 62)) (9_223_372_036_854_775_807 (Ok 62)) |}] ;; let%expect_test "[ceil_log2]" = print_for examples ceil_log2; [%expect {| (-1 (Error ("[Nativeint.ceil_log2] got invalid input" -1))) (0 (Error ("[Nativeint.ceil_log2] got invalid input" 0))) (1 (Ok 0)) (2 (Ok 1)) (3 (Ok 2)) (4 (Ok 2)) (5 (Ok 3)) (7 (Ok 3)) (8 (Ok 3)) (9 (Ok 4)) (63 (Ok 6)) (64 (Ok 6)) (65 (Ok 7)) |}] ;; let%expect_test ("[ceil_log2]" [@tags "64-bits-only"]) = print_for examples_64_bit ceil_log2; [%expect {| (-9_223_372_036_854_775_808 ( Error ("[Nativeint.ceil_log2] got invalid input" -9223372036854775808))) (-9_223_372_036_854_775_807 ( Error ("[Nativeint.ceil_log2] got invalid input" -9223372036854775807))) (9_223_372_036_854_775_806 (Ok 63)) (9_223_372_036_854_775_807 (Ok 63)) |}] ;; let%test_module "nativeint_math" = (module struct let test_cases () = let cases = [ 0b10101010n ; 0b1010101010101010n ; 0b101010101010101010101010n ; 0b10000000n ; 0b1000000000001000n ; 0b100000000000000000001000n ] in match Word_size.word_size with | W64 -> (* create some >32 bit values... *) (* We can't use literals directly because the compiler complains on 32 bits. *) let cases = cases @ [ (0b1010101010101010n lsl 16) lor 0b1010101010101010n ; (0b1000000000000000n lsl 16) lor 0b0000000000001000n ] in let added_cases = List.map cases ~f:(fun x -> x lsl 16) in List.concat [ cases; added_cases ] | W32 -> cases ;; let%test_unit "ceil_pow2" = List.iter (test_cases ()) ~f:(fun x -> let p2 = ceil_pow2 x in assert (is_pow2 p2 && p2 >= x && x >= p2 / of_int 2)) ;; let%test_unit "floor_pow2" = List.iter (test_cases ()) ~f:(fun x -> let p2 = floor_pow2 x in assert (is_pow2 p2 && of_int 2 * p2 >= x && x >= p2)) ;; end) ;; base-0.16.3/test/test_nativeint_pow2.mli000066400000000000000000000000551446274340700202170ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_not_found.mlt000066400000000000000000000011401446274340700172510ustar00rootroot00000000000000open Base open Expect_test_helpers_base;; print_s [%sexp (Not_found_s [%message "foo"] : exn)] [%%expect {| (Not_found_s foo) |}];; Not_found [%%expect {| Line _, characters _-_: Error (alert deprecated): Not_found [2016-09] this element comes from the stdlib distributed with OCaml. Instead of raising [Not_found], consider using [raise_s] with an informative error message. If code needs to distinguish [Not_found] from other exceptions, please change it to handle both [Not_found] and [Not_found_s]. Then, instead of raising [Not_found], raise [Not_found_s] with an informative error message. |}] base-0.16.3/test/test_option.ml000066400000000000000000000021751446274340700164130ustar00rootroot00000000000000open! Import open! Option let f = ( + ) let%test _ = [%compare.equal: int t] (merge None None ~f) None let%test _ = [%compare.equal: int t] (merge (Some 3) None ~f) (Some 3) let%test _ = [%compare.equal: int t] (merge None (Some 3) ~f) (Some 3) let%test _ = [%compare.equal: int t] (merge (Some 1) (Some 3) ~f) (Some 4) let%expect_test "[value_or_thunk]" = let default () = print_endline "THUNK!"; 0 in let value_or_thunk = value_or_thunk ~default in let test t = print_s [%sexp (value_or_thunk t : int)] in (* trigger the thunk *) test None; [%expect {| THUNK! 0 |}]; (* same value, no trigger *) test (Some 0); [%expect {| 0 |}]; (* different value *) test (Some 1); [%expect {| 1 |}]; (* trigger the thunk again: no memoization *) test None; [%expect {| THUNK! 0 |}] ;; let%expect_test "map2" = let m t1 t2 = let result = Option.map2 ~f:(fun x y -> x + y) t1 t2 in print_s [%sexp (result : int Option.t)] in m None None; [%expect {| () |}]; m (Some 1) (Some 2); [%expect {| (3) |}]; m None (Some 1); [%expect {| () |}]; m (Some 1) None; [%expect {| () |}] ;; base-0.16.3/test/test_option.mli000066400000000000000000000000551446274340700165570ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_option_array.ml000066400000000000000000000057031446274340700176110ustar00rootroot00000000000000open! Import open Option_array let%test_module "Cheap_option" = (module struct open For_testing.Unsafe_cheap_option let roundtrip_via_cheap_option (type a) (x : a) = let opt : a t = some x in assert (is_some opt); assert (phys_equal (value_exn opt) x) ;; let%test_unit _ = roundtrip_via_cheap_option 0 let%test_unit _ = roundtrip_via_cheap_option 1 let%test_unit _ = roundtrip_via_cheap_option (ref 0) let%test_unit _ = roundtrip_via_cheap_option `x6e8ee3478e1d7449 let%test_unit _ = roundtrip_via_cheap_option 0.0 let%test _ = not (is_some none) let%test_unit "memory corruption" = let make_list () = List.init ~f:(fun i -> Some i) 5 in Stdlib.Gc.minor (); let x = value_unsafe (some (make_list ())) in Stdlib.Gc.minor (); let (_ : int option list) = List.init ~f:(fun i -> Some (i * 100)) 10000 in [%test_result: Int.t Option.t List.t] ~expect:(make_list ()) x ;; end) ;; module Sequence = struct let length = length let get = get let set = set end include Base_for_tests.Test_blit.Test1_generic (struct include Option let equal a b = Option.equal Bool.equal a b let of_bool b = Some b end) (struct type nonrec 'a t = 'a t [@@deriving sexp] type 'a z = 'a include Sequence let create_bool ~len = init_some len ~f:(fun _ -> false) end) (Option_array) let%test_unit "floats are not re-boxed" = let one = 1.0 in let array = init_some 1 ~f:(fun _ -> one) in assert (phys_equal one (get_some_exn array 0)) ;; let%test_unit "segfault does not happen" = (* if [Option_array] is implemented with [Core_array] instead of [Uniform_array], this dies with a segfault *) let _array = init 2 ~f:(fun i -> if i = 0 then Some 1.0 else None) in () ;; module X = struct type t = [ `x6e8ee3478e1d7449 | `some_other_value ] [@@deriving sexp_of] let magic_value : t = `x6e8ee3478e1d7449 let some_other_value : t = `some_other_value let%expect_test _ = assert ( phys_equal magic_value (Stdlib.Obj.magic For_testing.Unsafe_cheap_option.none : t)) ;; end let%expect_test _ = let t = create ~len:1 in let check x = set t 0 (Some x); require [%here] (phys_equal x (unsafe_get_some_exn t 0)); require [%here] (phys_equal x (unsafe_get_some_assuming_some t 0)) in check X.magic_value; check X.some_other_value ;; let%test _ = foldi (of_array_some [||]) ~init:13 ~f:(fun _ _ _ -> failwith "bad") = 13 let%test _ = foldi (of_array_some [| 13 |]) ~init:17 ~f:(fun i ac x -> ac + i + Option.value_exn x) = 30 ;; let%test _ = foldi (of_array_some [| 13; 17 |]) ~init:19 ~f:(fun i ac x -> ac + i + Option.value_exn x) = 50 ;; let%test _ = counti (of_array_some [| 0; 1; 2; 3; 4 |]) ~f:(fun idx x -> idx = Option.value_exn x) = 5 ;; let%test _ = counti (of_array_some [| 0; 1; 2; 3; 4 |]) ~f:(fun idx x -> idx = 4 - Option.value_exn x) = 1 ;; base-0.16.3/test/test_option_array.mli000066400000000000000000000000551446274340700177550ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_or_error.ml000066400000000000000000000076251446274340700167410ustar00rootroot00000000000000open! Import open! Or_error let%test _ = [%compare.equal: string t] (errorf "foo %d" 13) (error_string "foo 13") let%test_unit _ = for i = 0 to 10 do assert ( [%compare.equal: unit list t] (combine_errors (List.init i ~f:(fun _ -> Ok ()))) (Ok (List.init i ~f:(fun _ -> ())))) done ;; let%test _ = Result.is_error (combine_errors [ error_string "" ]) let%test _ = Result.is_error (combine_errors [ Ok (); error_string "" ]) let ( = ) = [%compare.equal: unit t] let%test _ = combine_errors_unit [ Ok (); Ok () ] = Ok () let%test _ = combine_errors_unit [] = Ok () let%test _ = let a = Error.of_string "a" and b = Error.of_string "b" in match combine_errors_unit [ Ok (); Error a; Ok (); Error b ] with | Ok _ -> false | Error e -> String.equal (Error.to_string_hum e) (Error.to_string_hum (Error.of_list [ a; b ])) ;; let%expect_test "map2" = let m t1 t2 = let result = Or_error.map2 ~f:(fun x y -> x + y) t1 t2 in print_s [%sexp (result : int Or_error.t)] in let foo = Error.of_string "foo" in let bar = Error.of_string "bar" in m (Error foo) (Error bar); [%expect {| (Error (foo bar)) |}]; m (Ok 1) (Ok 2); [%expect {| (Ok 3) |}]; m (Error foo) (Ok 1); [%expect {| (Error foo) |}]; m (Ok 1) (Error bar); [%expect {| (Error bar) |}] ;; (* These tests check for stack overflow, and that we don't time out, when given large lists. We also test that we preserve all errors, in order, so that performance-related changes don't accidentally change behavior. History: in [2023-02], [all] and [all_unit] had O(N) stack usage and O(N^2) time for lists of length N. These costs were hidden behind the [lazy] inside [Error] values, so they could occur far from where the error was constructed. *) let%expect_test "behavior and performance on lists of or_error's" = let make_list len = (* We construct atoms with spaces in them to show sexp rendering with quotes, which is significant to [Error.to_string_hum]'s behavior below. *) List.init len ~f:(Or_error.errorf "at %d") in let short_lists = List.map ~f:make_list [ 0; 1; 2; 10 ] in let long_list = make_list 1_000_000 in let to_string = function | Ok _ -> "ok" | Error error -> (* Converting to string forces the [lazy] inside [Error.t]. Using [to_string_hum] also happens to observe whether the error was created via [Error.of_string]. *) Error.to_string_hum error in let test f = (* Show behavior on short lists. *) List.iter short_lists ~f:(fun list -> print_endline (to_string (f list))); (* Test for timeout / stack overflow on a long list. *) match to_string (f long_list) with | (_ : string) -> () | exception Stack_overflow -> print_cr [%here] [%message "stack overflow"] in (* test functions that combine a list of or_errors *) test all; [%expect {| ok at 0 ("at 0" "at 1") ("at 0" "at 1" "at 2" "at 3" "at 4" "at 5" "at 6" "at 7" "at 8" "at 9") |}]; test all_unit; [%expect {| ok at 0 ("at 0" "at 1") ("at 0" "at 1" "at 2" "at 3" "at 4" "at 5" "at 6" "at 7" "at 8" "at 9") |}]; test combine_errors; [%expect {| ok "at 0" ("at 0" "at 1") ("at 0" "at 1" "at 2" "at 3" "at 4" "at 5" "at 6" "at 7" "at 8" "at 9") |}]; test combine_errors_unit; [%expect {| ok "at 0" ("at 0" "at 1") ("at 0" "at 1" "at 2" "at 3" "at 4" "at 5" "at 6" "at 7" "at 8" "at 9") |}]; test find_ok; [%expect {| () "at 0" ("at 0" "at 1") ("at 0" "at 1" "at 2" "at 3" "at 4" "at 5" "at 6" "at 7" "at 8" "at 9") |}]; test (find_map_ok ~f:Fn.id); [%expect {| () "at 0" ("at 0" "at 1") ("at 0" "at 1" "at 2" "at 3" "at 4" "at 5" "at 6" "at 7" "at 8" "at 9") |}]; test filter_ok_at_least_one; [%expect {| () "at 0" ("at 0" "at 1") ("at 0" "at 1" "at 2" "at 3" "at 4" "at 5" "at 6" "at 7" "at 8" "at 9") |}] ;; base-0.16.3/test/test_or_error.mli000066400000000000000000000000551446274340700171000ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_ordered_collection_common.ml000066400000000000000000000040761446274340700223140ustar00rootroot00000000000000open! Import open! Ordered_collection_common let%test_unit "fast check_pos_len_exn is correct" = let n_vals = [ 0 ; 1 ; 2 ; 10 ; 100 ; (Int.max_value / 2) - 2 ; (Int.max_value / 2) - 1 ; Int.max_value / 2 ; Int.max_value - 2 ; Int.max_value - 1 ; Int.max_value ] in let z_vals = [ Int.min_value ; Int.min_value + 1 ; Int.min_value + 2 ; Int.min_value / 2 ; (Int.min_value / 2) + 1 ; (Int.min_value / 2) + 2 ; -100 ; -10 ; -2 ; -1 ] @ n_vals in List.iter z_vals ~f:(fun pos -> List.iter z_vals ~f:(fun len -> List.iter n_vals ~f:(fun total_length -> assert ( Bool.equal (Exn.does_raise (fun () -> Private.slow_check_pos_len_exn ~pos ~len ~total_length)) (Exn.does_raise (fun () -> check_pos_len_exn ~pos ~len ~total_length)))))) ;; let%test_unit _ = let vals = [ -1; 0; 1; 2; 3 ] in List.iter [ 0; 1; 2 ] ~f:(fun total_length -> List.iter vals ~f:(fun pos -> List.iter vals ~f:(fun len -> let result = Result.try_with (fun () -> check_pos_len_exn ~pos ~len ~total_length) in let valid = pos >= 0 && len >= 0 && len <= total_length - pos in assert (Bool.equal valid (Result.is_ok result))))) ;; let%test_unit _ = let opts = [ None; Some (-1); Some 0; Some 1; Some 2 ] in List.iter [ 0; 1; 2 ] ~f:(fun total_length -> List.iter opts ~f:(fun pos -> List.iter opts ~f:(fun len -> let result = Result.try_with (fun () -> get_pos_len_exn () ?pos ?len ~total_length) in let pos = match pos with | Some x -> x | None -> 0 in let len = match len with | Some x -> x | None -> total_length - pos in let valid = pos >= 0 && len >= 0 && len <= total_length - pos in match result with | Error _ -> assert (not valid) | Ok (pos', len') -> assert (pos' = pos); assert (len' = len); assert valid))) ;; base-0.16.3/test/test_ordered_collection_common.mli000066400000000000000000000000551446274340700224560ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_ordering.ml000066400000000000000000000010251446274340700167050ustar00rootroot00000000000000open! Import open! Ordering let%test _ = equal (of_int (-10)) Less let%test _ = equal (of_int (-1)) Less let%test _ = equal (of_int 0) Equal let%test _ = equal (of_int 1) Greater let%test _ = equal (of_int 10) Greater let%test _ = equal (of_int (Int.compare 0 1)) Less let%test _ = equal (of_int (Int.compare 1 1)) Equal let%test _ = equal (of_int (Int.compare 1 0)) Greater let%test _ = List.for_all all ~f:(fun t -> equal t (t |> to_int |> of_int)) let%test _ = List.for_all [ -1; 0; 1 ] ~f:(fun i -> i = (i |> of_int |> to_int)) base-0.16.3/test/test_ordering.mli000066400000000000000000000000551446274340700170600ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_popcount.ml000066400000000000000000000021421446274340700167440ustar00rootroot00000000000000open! Import module type T = sig type t [@@deriving compare, quickcheck, sexp_of] (* for implementing popcount_naive *) val zero : t val one : t val ( + ) : t -> t -> t val ( lsr ) : t -> int -> t val ( land ) : t -> t -> t val to_int_exn : t -> int val popcount : t -> int end module Make (Int : T) = struct let popcount_naive (int : Int.t) : int = let open Int in let rec loop n count = if Int.compare n zero <> 0 then loop (n lsr 1) (count + (n land one)) else count in loop int zero |> to_int_exn ;; let%test_unit _ = Base_quickcheck.Test.run_exn (module Int) ~f:(fun int -> let expect = popcount_naive int in [%test_result: int] ~expect (Int.popcount int)) ;; end include Make (struct include Int type t = int [@@deriving quickcheck] end) include Make (struct include Int32 type t = int32 [@@deriving quickcheck] end) include Make (struct include Int64 type t = int64 [@@deriving quickcheck] end) include Make (struct include Nativeint type t = nativeint [@@deriving quickcheck] end) base-0.16.3/test/test_popcount.mli000066400000000000000000000000551446274340700171160ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_pp.ml000066400000000000000000000016601446274340700155200ustar00rootroot00000000000000open! Import let to_string pp v = pp Stdlib.Format.str_formatter v; Stdlib.Format.flush_str_formatter () ;; let print pp v = Stdlib.Printf.printf "%s\n" (to_string pp v) let print_all pp vs = List.iter ~f:(print pp) vs let%expect_test "pretty-printers" = print_all Char.pp [ '\000'; '\r'; 'a' ]; [%expect {| '\000' '\r' 'a' |}]; print_all String.pp [ ""; "foo"; "abc\tdef" ]; [%expect {| "" "foo" "abc\tdef" |}]; print_all Sign.pp Sign.all; [%expect {| Neg Zero Pos |}]; print_all Bool.pp Bool.all; [%expect {| false true |}]; print_all Unit.pp Unit.all; [%expect {| () |}]; print_all Nothing.pp Nothing.all; [%expect {| |}]; print_all Float.pp [ 0.; 3.14; 1.0 /. 0.0 ]; [%expect {| 0. 3.14 inf |}]; print_all Int.pp [ 0; 1 ]; [%expect {| 0 1 |}]; print Info.pp (Info.create_s [%sexp "hello", "world"]); [%expect {| (hello world) |}] ;; base-0.16.3/test/test_pp.mli000066400000000000000000000000551446274340700156660ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_ppx_compare_lib.ml000066400000000000000000000042101446274340700202360ustar00rootroot00000000000000open! Import open! Ppx_compare_lib module Unit = struct type t = unit [@@deriving compare, sexp_of] end module type T = sig type t [@@deriving compare, sexp_of] end let test (type a) (module T : T with type t = a) ordered = List.iteri ordered ~f:(fun i ti -> List.iteri ordered ~f:(fun j tj -> require [%here] (Ordering.equal (Ordering.of_int (T.compare ti tj)) (Ordering.of_int (Int.compare i j))) ~if_false_then_print_s:(lazy [%message "" ~_:(ti : T.t) ~_:(tj : T.t)]))) ;; let%expect_test "bool, char, unit" = test (module Bool) [ false; true ]; test (module Char) [ '\000'; 'a'; 'b' ]; [%expect {| |}]; test (module Unit) [ () ]; [%expect {| |}] ;; module type Min_zero_max = sig include T val min_value : t val max_value : t val zero : t end let test_min_zero_max (type a) (module T : Min_zero_max with type t = a) = test (module T) [ T.min_value; T.zero; T.max_value ] ;; let%expect_test _ = test_min_zero_max (module Float); test_min_zero_max (module Int); test_min_zero_max (module Int32); test_min_zero_max (module Int64); test_min_zero_max (module Nativeint) ;; let%expect_test "option" = test (module struct type t = int option [@@deriving compare, sexp_of] end) [ None; Some 0; Some 1 ] ;; let%expect_test "ref" = test (module struct type t = int ref [@@deriving compare, sexp_of] end) ([ -1; 0; 1 ] |> List.map ~f:ref) ;; module type Sequence = sig type 'a t [@@deriving compare, sexp_of] val of_list : 'a list -> 'a t end let test_sequence (module T : Sequence) ordered = test (module struct type t = int T.t [@@deriving compare, sexp_of] end) (ordered |> List.map ~f:T.of_list) ;; let%expect_test "array, list" = test_sequence (module Array) [ []; [ 1 ]; [ 2 ]; [ 1; 2 ]; [ 2; 1 ] ]; test_sequence (module List) [ []; [ 1 ]; [ 1; 2 ]; [ 2 ]; [ 2; 1 ] ] ;; let%expect_test "[compare_abstract]" = show_raise (fun () -> compare_abstract ~type_name:"TY" () ()); [%expect {| (raised ( Failure "Compare called on the type TY, which is abstract in an implementation.")) |}] ;; base-0.16.3/test/test_ppx_compare_lib.mli000066400000000000000000000000551446274340700204120ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_printexc.ml000066400000000000000000000011721446274340700167330ustar00rootroot00000000000000open! Import module Printexc = Stdlib.Printexc let%expect_test "Printexc: built-in exception" = print_endline (Printexc.to_string (Invalid_argument "bad")); [%expect {| Invalid_argument("bad") |}] ;; let%expect_test "Sexp conversion of built-in exceptions" = print_endline (Sexp.to_string (sexp_of_exn (Invalid_argument "bad"))); [%expect {| (Invalid_argument bad) |}] ;; exception My_invalid_argument of string [@@deriving sexp] let%expect_test "Printexc: an exception with deriving sexp" = print_endline (Printexc.to_string (My_invalid_argument "bad")); [%expect {| (test_printexc.ml.My_invalid_argument bad) |}] ;; base-0.16.3/test/test_printexc.mli000066400000000000000000000000001446274340700170710ustar00rootroot00000000000000base-0.16.3/test/test_queue.ml000066400000000000000000001042171446274340700162270ustar00rootroot00000000000000open! Base open Base_test_helpers let%test_module _ = (module ( struct open Queue module type S = S let does_raise = Exn.does_raise type nonrec 'a t = 'a t [@@deriving sexp, sexp_grammar] let capacity = capacity let set_capacity = set_capacity let%test_unit _ = let t = create () in [%test_result: int] (capacity t) ~expect:2; enqueue t 1; [%test_result: int] (capacity t) ~expect:2; enqueue t 2; [%test_result: int] (capacity t) ~expect:2; enqueue t 3; [%test_result: int] (capacity t) ~expect:4; set_capacity t 0; [%test_result: int] (capacity t) ~expect:4; set_capacity t 3; [%test_result: int] (capacity t) ~expect:4; set_capacity t 100; [%test_result: int] (capacity t) ~expect:128; enqueue t 4; enqueue t 5; set_capacity t 0; [%test_result: int] (capacity t) ~expect:8; set_capacity t (-1); [%test_result: int] (capacity t) ~expect:8 ;; let round_trip_sexp t = let sexp = sexp_of_t Int.sexp_of_t t in let t' = t_of_sexp Int.t_of_sexp sexp in [%test_result: int list] ~expect:(to_list t) (to_list t') ;; let%test_unit _ = round_trip_sexp (of_list [ 1; 2; 3; 4 ]) let%test_unit _ = round_trip_sexp (create ()) let%test_unit _ = round_trip_sexp (of_list []) let invariant = invariant let create = create let%test_unit _ = let t = create () in [%test_result: int] (length t) ~expect:0; [%test_result: int] (capacity t) ~expect:2 ;; let%test_unit _ = let t = create ~capacity:0 () in [%test_result: int] (length t) ~expect:0; [%test_result: int] (capacity t) ~expect:1 ;; let%test_unit _ = let t = create ~capacity:6 () in [%test_result: int] (length t) ~expect:0; [%test_result: int] (capacity t) ~expect:8 ;; let%test_unit _ = assert (does_raise (fun () : _ Queue.t -> create ~capacity:(-1) ())) ;; let singleton = singleton let%test_unit _ = let t = singleton 7 in [%test_result: int] (length t) ~expect:1; [%test_result: int] (capacity t) ~expect:1; [%test_result: int option] (dequeue t) ~expect:(Some 7); [%test_result: int option] (dequeue t) ~expect:None ;; let init = init let%test_unit _ = let t = init 0 ~f:(fun _ -> assert false) in [%test_result: int] (length t) ~expect:0; [%test_result: int] (capacity t) ~expect:1; [%test_result: int option] (dequeue t) ~expect:None ;; let%test_unit _ = let t = init 3 ~f:(fun i -> i * 2) in [%test_result: int] (length t) ~expect:3; [%test_result: int] (capacity t) ~expect:4; [%test_result: int option] (dequeue t) ~expect:(Some 0); [%test_result: int option] (dequeue t) ~expect:(Some 2); [%test_result: int option] (dequeue t) ~expect:(Some 4); [%test_result: int option] (dequeue t) ~expect:None ;; let%test_unit _ = assert (does_raise (fun () : unit Queue.t -> init (-1) ~f:(fun _ -> ()))) ;; let get = get let set = set let%test_unit _ = let t = create () in let get_opt t i = Option.try_with (fun () -> get t i) in [%test_result: int option] (get_opt t 0) ~expect:None; [%test_result: int option] (get_opt t (-1)) ~expect:None; [%test_result: int option] (get_opt t 10) ~expect:None; List.iter [ -1; 0; 1 ] ~f:(fun i -> assert (does_raise (fun () -> set t i 0))); enqueue t 0; enqueue t 1; enqueue t 2; [%test_result: int option] (get_opt t 0) ~expect:(Some 0); [%test_result: int option] (get_opt t 1) ~expect:(Some 1); [%test_result: int option] (get_opt t 2) ~expect:(Some 2); [%test_result: int option] (get_opt t 3) ~expect:None; ignore (dequeue_exn t : int); [%test_result: int option] (get_opt t 0) ~expect:(Some 1); [%test_result: int option] (get_opt t 1) ~expect:(Some 2); [%test_result: int option] (get_opt t 2) ~expect:None; set t 0 3; [%test_result: int option] (get_opt t 0) ~expect:(Some 3); [%test_result: int option] (get_opt t 1) ~expect:(Some 2); List.iter [ -1; 2 ] ~f:(fun i -> assert (does_raise (fun () -> set t i 0))) ;; let map = map let%test_unit _ = for i = 0 to 5 do let l = List.init i ~f:Fn.id in let t = of_list l in let f x = x * 2 in let t' = map t ~f in [%test_result: int list] (to_list t') ~expect:(List.map l ~f) done ;; let%test_unit _ = let t = create () in let t' = map t ~f:(fun x -> x * 2) in [%test_result: int] (length t') ~expect:(length t); [%test_result: int] (length t') ~expect:0; [%test_result: int list] (to_list t') ~expect:[] ;; let mapi = mapi let%test_unit _ = for i = 0 to 5 do let l = List.init i ~f:Fn.id in let t = of_list l in let f i x = i, x * 2 in let t' = mapi t ~f in [%test_result: (int * int) list] (to_list t') ~expect:(List.mapi l ~f) done ;; let%test_unit _ = let t = create () in let t' = mapi t ~f:(fun i x -> i, x * 2) in [%test_result: int] (length t') ~expect:(length t); [%test_result: int] (length t') ~expect:0; [%test_result: (int * int) list] (to_list t') ~expect:[] ;; include Test_container.Test_S1 (Queue) let dequeue_exn = dequeue_exn let enqueue = enqueue let peek = peek let peek_exn = peek_exn let last = last let last_exn = last_exn let%test_unit _ = let t = create () in [%test_result: int option] (peek t) ~expect:None; [%test_result: int option] (last t) ~expect:None; enqueue t 1; enqueue t 2; [%test_result: int option] (peek t) ~expect:(Some 1); [%test_result: int] (peek_exn t) ~expect:1; [%test_result: int option] (last t) ~expect:(Some 2); [%test_result: int] (last_exn t) ~expect:2; [%test_result: int] (dequeue_exn t) ~expect:1; [%test_result: int] (dequeue_exn t) ~expect:2; assert (does_raise (fun () -> dequeue_exn t)); assert (does_raise (fun () -> peek_exn t)); assert (does_raise (fun () -> last_exn t)) ;; let dequeue_and_ignore_exn = dequeue_and_ignore_exn let%test_unit _ = let t = create () in enqueue t 1; enqueue t 2; enqueue t 3; [%test_result: int] (peek_exn t) ~expect:1; dequeue_and_ignore_exn t; [%test_result: int] (peek_exn t) ~expect:2; dequeue_and_ignore_exn t; [%test_result: int] (peek_exn t) ~expect:3; dequeue_and_ignore_exn t; [%test_result: int option] (peek t) ~expect:None; assert (does_raise (fun () -> dequeue_and_ignore_exn t)); assert (does_raise (fun () -> dequeue_and_ignore_exn t)); [%test_result: int option] (peek t) ~expect:None ;; let enqueue_all = enqueue_all let%test_unit _ = let t = create () in enqueue_all t [ 1; 2; 3 ]; [%test_result: int] (dequeue_exn t) ~expect:1; [%test_result: int] (dequeue_exn t) ~expect:2; [%test_result: int option] (last t) ~expect:(Some 3); enqueue_all t [ 4; 5 ]; [%test_result: int option] (last t) ~expect:(Some 5); [%test_result: int] (dequeue_exn t) ~expect:3; [%test_result: int] (dequeue_exn t) ~expect:4; [%test_result: int] (dequeue_exn t) ~expect:5; assert (does_raise (fun () -> dequeue_exn t)); enqueue_all t []; assert (does_raise (fun () -> dequeue_exn t)) ;; let of_list = of_list let to_list = to_list let%test_unit _ = for i = 0 to 4 do let list = List.init i ~f:Fn.id in [%test_result: int list] (to_list (of_list list)) ~expect:list done ;; let%test _ = let t = create () in for i = 1 to 5 do enqueue t i done; [%equal: int list] (to_list t) [ 1; 2; 3; 4; 5 ] ;; let of_array = of_array let to_array = to_array let%test_unit _ = for len = 0 to 4 do let array = Array.init len ~f:Fn.id in [%test_result: int array] (to_array (of_array array)) ~expect:array done ;; let compare = compare let equal = equal let%test_module "comparisons" = (module struct let sign x = if x < 0 then ~-1 else if x > 0 then 1 else 0 let test t1 t2 = [%test_result: bool] (equal Int.equal t1 t2) ~expect:(List.equal Int.equal (to_list t1) (to_list t2)); [%test_result: int] (sign (compare Int.compare t1 t2)) ~expect:(sign (List.compare Int.compare (to_list t1) (to_list t2))) ;; let lists = [ [] ; [ 1 ] ; [ 2 ] ; [ 1; 1 ] ; [ 1; 2 ] ; [ 2; 1 ] ; [ 1; 1; 1 ] ; [ 1; 2; 3 ] ; [ 1; 2; 4 ] ; [ 1; 2; 4; 8 ] ; [ 1; 2; 3; 4; 5 ] ] ;; let%test_unit _ = (* [phys_equal] inputs *) List.iter lists ~f:(fun list -> let t = of_list list in test t t) ;; let%test_unit _ = List.iter lists ~f:(fun list1 -> List.iter lists ~f:(fun list2 -> test (of_list list1) (of_list list2))) ;; end) ;; let clear = clear let%test_unit "clear" = let q = of_list [ 1; 2; 3; 4 ] in [%test_result: int] (length q) ~expect:4; clear q; [%test_result: int] (length q) ~expect:0 ;; let blit_transfer = blit_transfer let%test_unit _ = let q_list = [ 1; 2; 3; 4 ] in let q = of_list q_list in let q' = create () in blit_transfer ~src:q ~dst:q' (); [%test_result: int list] (to_list q') ~expect:q_list; [%test_result: int list] (to_list q) ~expect:[] ;; let%test_unit _ = let q = of_list [ 1; 2; 3; 4 ] in let q' = create () in blit_transfer ~src:q ~dst:q' ~len:2 (); [%test_result: int list] (to_list q') ~expect:[ 1; 2 ]; [%test_result: int list] (to_list q) ~expect:[ 3; 4 ] ;; let%test_unit "blit_transfer on wrapped queues" = let list = [ 1; 2; 3; 4 ] in let q = of_list list in let q' = copy q in ignore (dequeue_exn q : int); ignore (dequeue_exn q : int); ignore (dequeue_exn q' : int); ignore (dequeue_exn q' : int); ignore (dequeue_exn q' : int); enqueue q 5; enqueue q 6; blit_transfer ~src:q ~dst:q' ~len:3 (); [%test_result: int list] (to_list q') ~expect:[ 4; 3; 4; 5 ]; [%test_result: int list] (to_list q) ~expect:[ 6 ] ;; let copy = copy let%test_unit "copies behave independently" = let q = of_list [ 1; 2; 3; 4 ] in let q' = copy q in enqueue q 5; ignore (dequeue_exn q' : int); [%test_result: int list] (to_list q) ~expect:[ 1; 2; 3; 4; 5 ]; [%test_result: int list] (to_list q') ~expect:[ 2; 3; 4 ] ;; let dequeue = dequeue let filter = filter let filteri = filteri let filter_inplace = filter_inplace let filteri_inplace = filteri_inplace let concat_map = concat_map let concat_mapi = concat_mapi let filter_map = filter_map let filter_mapi = filter_mapi let counti = counti let existsi = existsi let for_alli = for_alli let iter = iter let iteri = iteri let foldi = foldi let findi = findi let find_mapi = find_mapi let%test_module "Linked_queue bisimulation" = (module struct module type Queue_intf = sig type 'a t [@@deriving sexp_of] val create : unit -> 'a t val enqueue : 'a t -> 'a -> unit val dequeue : 'a t -> 'a option val to_array : 'a t -> 'a array val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b val foldi : 'a t -> init:'b -> f:(int -> 'b -> 'a -> 'b) -> 'b val iter : 'a t -> f:('a -> unit) -> unit val iteri : 'a t -> f:(int -> 'a -> unit) -> unit val length : 'a t -> int val clear : 'a t -> unit val concat_map : 'a t -> f:('a -> 'b list) -> 'b t val concat_mapi : 'a t -> f:(int -> 'a -> 'b list) -> 'b 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 filter : 'a t -> f:('a -> bool) -> 'a t val filteri : 'a t -> f:(int -> 'a -> bool) -> 'a t val filter_inplace : 'a t -> f:('a -> bool) -> unit val filteri_inplace : 'a t -> f:(int -> 'a -> bool) -> unit val map : 'a t -> f:('a -> 'b) -> 'b t val mapi : 'a t -> f:(int -> 'a -> 'b) -> 'b t val counti : 'a t -> f:(int -> 'a -> bool) -> int val existsi : 'a t -> f:(int -> 'a -> bool) -> bool val for_alli : 'a t -> f:(int -> 'a -> bool) -> bool val findi : 'a t -> f:(int -> 'a -> bool) -> (int * 'a) option val find_mapi : 'a t -> f:(int -> 'a -> 'b option) -> 'b option val transfer : src:'a t -> dst:'a t -> unit val copy : 'a t -> 'a t end module That_queue : Queue_intf = Linked_queue module This_queue : Queue_intf = struct include Queue let create () = create () let transfer ~src ~dst = blit_transfer ~src ~dst () end let this_to_string this_t = Sexp.to_string (this_t |> [%sexp_of: int This_queue.t]) ;; let that_to_string that_t = Sexp.to_string (that_t |> [%sexp_of: int That_queue.t]) ;; let array_string arr = Sexp.to_string (arr |> [%sexp_of: int array]) let create () = This_queue.create (), That_queue.create () let enqueue (t_a, t_b) v = let start_a = This_queue.to_array t_a in let start_b = That_queue.to_array t_b in This_queue.enqueue t_a v; That_queue.enqueue t_b v; let end_a = This_queue.to_array t_a in let end_b = That_queue.to_array t_b in if not ([%equal: int array] end_a end_b) then Printf.failwithf "enqueue transition failure of: %s -> %s vs. %s -> %s" (array_string start_a) (array_string end_a) (array_string start_b) (array_string end_b) () ;; let iter (t_a, t_b) = let r_a, r_b = ref 0, ref 0 in This_queue.iter t_a ~f:(fun x -> r_a := !r_a + x); That_queue.iter t_b ~f:(fun x -> r_b := !r_b + x); if !r_a <> !r_b then Printf.failwithf "error in iter: %s (from %s) <> %s (from %s)" (Int.to_string !r_a) (this_to_string t_a) (Int.to_string !r_b) (that_to_string t_b) () ;; let iteri (t_a, t_b) = let r_a, r_b = ref 0, ref 0 in This_queue.iteri t_a ~f:(fun i x -> r_a := !r_a + (x lxor i)); That_queue.iteri t_b ~f:(fun i x -> r_b := !r_b + (x lxor i)); if !r_a <> !r_b then Printf.failwithf "error in iteri: %s (from %s) <> %s (from %s)" (Int.to_string !r_a) (this_to_string t_a) (Int.to_string !r_b) (that_to_string t_b) () ;; let dequeue (t_a, t_b) = let start_a = This_queue.to_array t_a in let start_b = That_queue.to_array t_b in let a, b = This_queue.dequeue t_a, That_queue.dequeue t_b in let end_a = This_queue.to_array t_a in let end_b = That_queue.to_array t_b in if (not ([%equal: int option] a b)) || not ([%equal: int array] end_a end_b) then Printf.failwithf "error in dequeue: %s (%s -> %s) <> %s (%s -> %s)" (Option.value ~default:"None" (Option.map a ~f:Int.to_string)) (array_string start_a) (array_string end_a) (Option.value ~default:"None" (Option.map b ~f:Int.to_string)) (array_string start_b) (array_string end_b) () ;; let clear (t_a, t_b) = This_queue.clear t_a; That_queue.clear t_b ;; let is_even x = x land 1 = 0 let filter (t_a, t_b) = let t_a' = This_queue.filter t_a ~f:is_even in let t_b' = That_queue.filter t_b ~f:is_even in if not ([%equal: int array] (This_queue.to_array t_a') (That_queue.to_array t_b')) then Printf.failwithf "error in filter: %s -> %s vs. %s -> %s" (this_to_string t_a) (this_to_string t_a') (that_to_string t_b) (that_to_string t_b') () ;; let filteri (t_a, t_b) = let t_a' = This_queue.filteri t_a ~f:(fun i j -> [%equal: bool] (is_even i) (is_even j)) in let t_b' = That_queue.filteri t_b ~f:(fun i j -> [%equal: bool] (is_even i) (is_even j)) in if not ([%equal: int array] (This_queue.to_array t_a') (That_queue.to_array t_b')) then Printf.failwithf "error in filteri: %s -> %s vs. %s -> %s" (this_to_string t_a) (this_to_string t_a') (that_to_string t_b) (that_to_string t_b') () ;; let filter_inplace (t_a, t_b) = let start_a = This_queue.to_array t_a in let start_b = That_queue.to_array t_b in This_queue.filter_inplace t_a ~f:is_even; That_queue.filter_inplace t_b ~f:is_even; let end_a = This_queue.to_array t_a in let end_b = That_queue.to_array t_b in if not ([%equal: int array] end_a end_b) then Printf.failwithf "error in filter_inplace: %s -> %s vs. %s -> %s" (array_string start_a) (array_string end_a) (array_string start_b) (array_string end_b) () ;; let filteri_inplace (t_a, t_b) = let start_a = This_queue.to_array t_a in let start_b = That_queue.to_array t_b in let f i x = [%equal: bool] (is_even i) (is_even x) in This_queue.filteri_inplace t_a ~f; That_queue.filteri_inplace t_b ~f; let end_a = This_queue.to_array t_a in let end_b = That_queue.to_array t_b in if not ([%equal: int array] end_a end_b) then Printf.failwithf "error in filteri_inplace: %s -> %s vs. %s -> %s" (array_string start_a) (array_string end_a) (array_string start_b) (array_string end_b) () ;; let concat_map (t_a, t_b) = let f x = [ x; x + 1; x + 2 ] in let t_a' = This_queue.concat_map t_a ~f in let t_b' = That_queue.concat_map t_b ~f in if not ([%equal: int array] (This_queue.to_array t_a') (That_queue.to_array t_b')) then Printf.failwithf "error in concat_map: %s (for %s) <> %s (for %s)" (this_to_string t_a') (this_to_string t_a) (that_to_string t_b') (that_to_string t_b) () ;; let concat_mapi (t_a, t_b) = let f i x = [ x; x + 1; x + 2; x + i ] in let t_a' = This_queue.concat_mapi t_a ~f in let t_b' = That_queue.concat_mapi t_b ~f in if not ([%equal: int array] (This_queue.to_array t_a') (That_queue.to_array t_b')) then Printf.failwithf "error in concat_mapi: %s (for %s) <> %s (for %s)" (this_to_string t_a') (this_to_string t_a) (that_to_string t_b') (that_to_string t_b) () ;; let filter_map (t_a, t_b) = let f x = if is_even x then None else Some (x + 1) in let t_a' = This_queue.filter_map t_a ~f in let t_b' = That_queue.filter_map t_b ~f in if not ([%equal: int array] (This_queue.to_array t_a') (That_queue.to_array t_b')) then Printf.failwithf "error in filter_map: %s (for %s) <> %s (for %s)" (this_to_string t_a') (this_to_string t_a) (that_to_string t_b') (that_to_string t_b) () ;; let filter_mapi (t_a, t_b) = let f i x = if [%equal: bool] (is_even i) (is_even x) then None else Some (x + 1 + i) in let t_a' = This_queue.filter_mapi t_a ~f in let t_b' = That_queue.filter_mapi t_b ~f in if not ([%equal: int array] (This_queue.to_array t_a') (That_queue.to_array t_b')) then Printf.failwithf "error in filter_mapi: %s (for %s) <> %s (for %s)" (this_to_string t_a') (this_to_string t_a) (that_to_string t_b') (that_to_string t_b) () ;; let map (t_a, t_b) = let f x = x * 7 in let t_a' = This_queue.map t_a ~f in let t_b' = That_queue.map t_b ~f in if not ([%equal: int array] (This_queue.to_array t_a') (That_queue.to_array t_b')) then Printf.failwithf "error in map: %s (for %s) <> %s (for %s)" (this_to_string t_a') (this_to_string t_a) (that_to_string t_b') (that_to_string t_b) () ;; let mapi (t_a, t_b) = let f i x = (x + 3) lxor i in let t_a' = This_queue.mapi t_a ~f in let t_b' = That_queue.mapi t_b ~f in if not ([%equal: int array] (This_queue.to_array t_a') (That_queue.to_array t_b')) then Printf.failwithf "error in mapi: %s (for %s) <> %s (for %s)" (this_to_string t_a') (this_to_string t_a) (that_to_string t_b') (that_to_string t_b) () ;; let counti (t_a, t_b) = let f i x = i < 7 && i % 7 = x % 7 in let a' = This_queue.counti t_a ~f in let b' = That_queue.counti t_b ~f in if a' <> b' then Printf.failwithf "error in counti: %d (for %s) <> %d (for %s)" a' (this_to_string t_a) b' (that_to_string t_b) () ;; let existsi (t_a, t_b) = let f i x = i < 7 && i % 7 = x % 7 in let a' = This_queue.existsi t_a ~f in let b' = That_queue.existsi t_b ~f in if not ([%equal: bool] a' b') then Printf.failwithf "error in existsi: %b (for %s) <> %b (for %s)" a' (this_to_string t_a) b' (that_to_string t_b) () ;; let for_alli (t_a, t_b) = let f i x = i >= 7 || i % 7 <> x % 7 in let a' = This_queue.for_alli t_a ~f in let b' = That_queue.for_alli t_b ~f in if not ([%equal: bool] a' b') then Printf.failwithf "error in for_alli: %b (for %s) <> %b (for %s)" a' (this_to_string t_a) b' (that_to_string t_b) () ;; let findi (t_a, t_b) = let f i x = i < 7 && i % 7 = x % 7 in let a' = This_queue.findi t_a ~f in let b' = That_queue.findi t_b ~f in if not ([%equal: (int * int) option] a' b') then Printf.failwithf "error in findi: %s (for %s) <> %s (for %s)" (Sexp.to_string ([%sexp_of: (int * int) option] a')) (this_to_string t_a) (Sexp.to_string ([%sexp_of: (int * int) option] b')) (that_to_string t_b) () ;; let find_mapi (t_a, t_b) = let f i x = if i < 7 && i % 7 = x % 7 then Some (i + x) else None in let a' = This_queue.find_mapi t_a ~f in let b' = That_queue.find_mapi t_b ~f in if not ([%equal: int option] a' b') then Printf.failwithf "error in find_mapi: %s (for %s) <> %s (for %s)" (Sexp.to_string ([%sexp_of: int option] a')) (this_to_string t_a) (Sexp.to_string ([%sexp_of: int option] b')) (that_to_string t_b) () ;; let copy (t_a, t_b) = let copy_a = This_queue.copy t_a in let copy_b = That_queue.copy t_b in let start_a = This_queue.to_array t_a in let start_b = That_queue.to_array t_b in let end_a = This_queue.to_array copy_a in let end_b = That_queue.to_array copy_b in if not ([%equal: int array] end_a end_b) then Printf.failwithf "error in copy: %s -> %s vs. %s -> %s" (array_string start_a) (array_string end_a) (array_string start_b) (array_string end_b) () ;; let transfer (t_a, t_b) = let dst_a = This_queue.create () in let dst_b = That_queue.create () in (* sometimes puts some elements in the destination queues *) if Random.bool () then List.iter [ 1; 2; 3; 4; 5 ] ~f:(fun elem -> This_queue.enqueue dst_a elem; That_queue.enqueue dst_b elem); let start_a = This_queue.to_array t_a in let start_b = That_queue.to_array t_b in This_queue.transfer ~src:t_a ~dst:dst_a; That_queue.transfer ~src:t_b ~dst:dst_b; let end_a = This_queue.to_array t_a in let end_b = That_queue.to_array t_b in let end_a' = This_queue.to_array dst_a in let end_b' = That_queue.to_array dst_b in if (not ([%equal: int array] end_a' end_b')) || not ([%equal: int array] end_a end_b) then Printf.failwithf "error in transfer: %s -> (%s, %s) vs. %s -> (%s, %s)" (array_string start_a) (array_string end_a) (array_string end_a') (array_string start_b) (array_string end_b) (array_string end_b) () ;; let fold_check (t_a, t_b) = let make_list fold t = fold t ~init:[] ~f:(fun acc x -> x :: acc) in let this_l = make_list This_queue.fold t_a in let that_l = make_list That_queue.fold t_b in if not ([%equal: int list] this_l that_l) then Printf.failwithf "error in fold: %s (from %s) <> %s (from %s)" (Sexp.to_string (this_l |> [%sexp_of: int list])) (this_to_string t_a) (Sexp.to_string (that_l |> [%sexp_of: int list])) (that_to_string t_b) () ;; let foldi_check (t_a, t_b) = let make_list foldi t = foldi t ~init:[] ~f:(fun i acc x -> (i, x) :: acc) in let this_l = make_list This_queue.foldi t_a in let that_l = make_list That_queue.foldi t_b in if not ([%equal: (int * int) list] this_l that_l) then Printf.failwithf "error in foldi: %s (from %s) <> %s (from %s)" (Sexp.to_string (this_l |> [%sexp_of: (int * int) list])) (this_to_string t_a) (Sexp.to_string (that_l |> [%sexp_of: (int * int) list])) (that_to_string t_b) () ;; let length_check (t_a, t_b) = let this_len = This_queue.length t_a in let that_len = That_queue.length t_b in if this_len <> that_len then Printf.failwithf "error in length: %i (for %s) <> %i (for %s)" this_len (this_to_string t_a) that_len (that_to_string t_b) () ;; let%test_unit _ = let t = create () in let rec loop ~all_ops ~non_empty_ops = if all_ops <= 0 && non_empty_ops <= 0 then ( let t_a, t_b = t in let arr_a = This_queue.to_array t_a in let arr_b = That_queue.to_array t_b in if not ([%equal: int array] arr_a arr_b) then Printf.failwithf "queue final states not equal: %s vs. %s" (array_string arr_a) (array_string arr_b) ()) else ( let queue_was_empty = This_queue.length (fst t) = 0 in let r = Random.int 195 in if r < 60 then enqueue t (Random.int 10_000) else if r < 65 then dequeue t else if r < 70 then clear t else if r < 80 then iter t else if r < 85 then iteri t else if r < 90 then fold_check t else if r < 95 then foldi_check t else if r < 100 then filter t else if r < 105 then filteri t else if r < 110 then concat_map t else if r < 115 then concat_mapi t else if r < 120 then transfer t else if r < 130 then filter_map t else if r < 135 then filter_mapi t else if r < 140 then copy t else if r < 150 then filter_inplace t else if r < 155 then for_alli t else if r < 160 then existsi t else if r < 165 then counti t else if r < 170 then findi t else if r < 175 then find_mapi t else if r < 180 then map t else if r < 185 then mapi t else if r < 190 then filteri_inplace t else if r < 195 then length_check t else failwith "Impossible: We did [Random.int 195] above"; loop ~all_ops:(all_ops - 1) ~non_empty_ops: (if queue_was_empty then non_empty_ops else non_empty_ops - 1)) in loop ~all_ops:30_000 ~non_empty_ops:20_000 ;; end) ;; let%test_unit "modification-during-iteration" = let x = `A 0 in let t = of_list [ x; x ] in let f (`A n) = ignore n; clear t in assert (does_raise (fun () -> iter t ~f)) ;; let%test_unit "more-modification-during-iteration" = let nested_iter_okay = ref false in let t = of_list [ `iter; `clear ] in assert ( does_raise (fun () -> iter t ~f:(function | `iter -> iter t ~f:ignore; nested_iter_okay := true | `clear -> clear t))); assert !nested_iter_okay ;; let%test_unit "modification-during-filter" = let reached_unreachable = ref false in let t = of_list [ `clear; `unreachable ] in let f x = match x with | `clear -> clear t; false | `unreachable -> reached_unreachable := true; false in assert (does_raise (fun () -> filter t ~f)); assert (not !reached_unreachable) ;; let%test_unit "modification-during-filter-inplace" = let reached_unreachable = ref false in let t = of_list [ `drop_this; `enqueue_new_element; `unreachable ] in let f x = (match x with | `drop_this | `new_element -> () | `enqueue_new_element -> enqueue t `new_element | `unreachable -> reached_unreachable := true); false in assert (does_raise (fun () -> filter_inplace t ~f)); (* even though we said to drop the first element, the aborted call to [filter_inplace] shouldn't have made that change *) (match peek_exn t with | `drop_this -> () | `new_element | `enqueue_new_element | `unreachable -> failwith "Expected the first element to be `drop_this"); assert (not !reached_unreachable) ;; let%test_unit "filter-inplace-during-iteration" = let reached_unreachable = ref false in let t = of_list [ `filter_inplace; `unreachable ] in let f x = match x with | `filter_inplace -> filter_inplace t ~f:(fun _ -> false) | `unreachable -> reached_unreachable := true in assert (does_raise (fun () -> iter t ~f)); assert (not !reached_unreachable) ;; end (* This signature is here to remind us to update the unit tests whenever we change [Queue]. *) : module type of Queue)) ;; base-0.16.3/test/test_queue.mli000066400000000000000000000000551446274340700163730ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_random.ml000066400000000000000000000222621446274340700163620ustar00rootroot00000000000000open! Import open! Random let%test_module "State" = (module struct include State let%test_unit ("random int above 2^30" [@tags "64-bits-only"]) = let state = make [| 1; 2; 3; 4; 5 |] in for _ = 1 to 100 do let bound = Int.shift_left 1 40 in let n = int state bound in if n < 0 || n >= bound then failwith (Printf.sprintf "random result %d out of bounds (0,%d)" n (bound - 1)) done ;; end) ;; external random_seed : unit -> Stdlib.Obj.t = "caml_sys_random_seed" let%test_unit _ = (* test that the return type of "caml_sys_random_seed" is what we expect *) let module Obj = Stdlib.Obj in let obj = random_seed () in assert (Obj.is_block obj); assert (Obj.tag obj = Obj.tag (Obj.repr [| 13 |])); for i = 0 to Obj.size obj - 1 do assert (Obj.is_int (Obj.field obj i)) done ;; module type T = sig type t [@@deriving compare, sexp_of] end (* We test that [count] trials of [generate ()] all produce values between [min, max], and generate at least one value between [lo, hi]. *) let test (type t) here m count generate ~min ~max ~check_range:(lo, hi) = let (module T : T with type t = t) = m in let between t ~lower_bound ~upper_bound = T.compare t lower_bound >= 0 && T.compare t upper_bound <= 0 in let generated = List.init count ~f:(fun _ -> generate ()) |> List.dedup_and_sort ~compare:T.compare in require here (List.for_all generated ~f:(fun t -> between t ~lower_bound:min ~upper_bound:max)) ~if_false_then_print_s: (lazy [%message "generated values outside of bounds" (min : T.t) (max : T.t) (generated : T.t list)]); require here (List.exists generated ~f:(fun t -> between t ~lower_bound:lo ~upper_bound:hi)) ~if_false_then_print_s: (lazy [%message "did not generate value inside range" (lo : T.t) (hi : T.t) (generated : T.t list)]) ;; let%expect_test "float" = test [%here] (module Float) 1_000 (fun () -> float 100.) ~min:0. ~max:100. ~check_range:(10., 20.); [%expect {||}] ;; let%expect_test "float_range" = test [%here] (module Float) 1_000 (fun () -> float_range (-100.) 100.) ~min:(-100.) ~max:100. ~check_range:(-20., -10.); [%expect {||}] ;; let%expect_test "int" = test [%here] (module Int) 1_000 (fun () -> int 100) ~min:0 ~max:99 ~check_range:(10, 20); [%expect {||}] ;; let%expect_test "int_incl" = test [%here] (module Int) 1_000 (fun () -> int_incl (-100) 100) ~min:(-100) ~max:100 ~check_range:(-20, -10); [%expect {||}]; test [%here] (module Int) 1_000 (fun () -> int_incl 0 Int.max_value) ~min:0 ~max:Int.max_value ~check_range:(0, Int.max_value / 100); [%expect {||}]; test [%here] (module Int) 1_000 (fun () -> int_incl Int.min_value Int.max_value) ~min:Int.min_value ~max:Int.max_value ~check_range:(Int.min_value / 100, Int.max_value / 100); [%expect {||}] ;; let%expect_test "int32" = test [%here] (module Int32) 1_000 (fun () -> int32 100l) ~min:0l ~max:99l ~check_range:(10l, 20l); [%expect {||}] ;; let%expect_test "int32_incl" = test [%here] (module Int32) 1_000 (fun () -> int32_incl (-100l) 100l) ~min:(-100l) ~max:100l ~check_range:(-20l, -10l); [%expect {||}]; test [%here] (module Int32) 1_000 (fun () -> int32_incl 0l Int32.max_value) ~min:0l ~max:Int32.max_value ~check_range:(0l, Int32.( / ) Int32.max_value 100l); [%expect {||}]; test [%here] (module Int32) 1_000 (fun () -> int32_incl Int32.min_value Int32.max_value) ~min:Int32.min_value ~max:Int32.max_value ~check_range:(Int32.( / ) Int32.min_value 100l, Int32.( / ) Int32.max_value 100l); [%expect {||}] ;; let%expect_test "int64" = test [%here] (module Int64) 1_000 (fun () -> int64 100L) ~min:0L ~max:99L ~check_range:(10L, 20L); [%expect {||}] ;; let%expect_test "int64_incl" = test [%here] (module Int64) 1_000 (fun () -> int64_incl (-100L) 100L) ~min:(-100L) ~max:100L ~check_range:(-20L, -10L); [%expect {||}]; test [%here] (module Int64) 1_000 (fun () -> int64_incl 0L Int64.max_value) ~min:0L ~max:Int64.max_value ~check_range:(0L, Int64.( / ) Int64.max_value 100L); [%expect {||}]; test [%here] (module Int64) 1_000 (fun () -> int64_incl Int64.min_value Int64.max_value) ~min:Int64.min_value ~max:Int64.max_value ~check_range:(Int64.( / ) Int64.min_value 100L, Int64.( / ) Int64.max_value 100L); [%expect {||}] ;; let%expect_test "nativeint" = test [%here] (module Nativeint) 1_000 (fun () -> nativeint 100n) ~min:0n ~max:99n ~check_range:(10n, 20n); [%expect {||}] ;; let%expect_test "nativeint_incl" = test [%here] (module Nativeint) 1_000 (fun () -> nativeint_incl (-100n) 100n) ~min:(-100n) ~max:100n ~check_range:(-20n, -10n); [%expect {||}]; test [%here] (module Nativeint) 1_000 (fun () -> nativeint_incl 0n Nativeint.max_value) ~min:0n ~max:Nativeint.max_value ~check_range:(0n, Nativeint.( / ) Nativeint.max_value 100n); [%expect {||}]; test [%here] (module Nativeint) 1_000 (fun () -> nativeint_incl Nativeint.min_value Nativeint.max_value) ~min:Nativeint.min_value ~max:Nativeint.max_value ~check_range: (Nativeint.( / ) Nativeint.min_value 100n, Nativeint.( / ) Nativeint.max_value 100n); [%expect {||}] ;; (* The int63 functions come from [Int63] rather than [Random], but we test them here along with the others anyway. *) let%expect_test "int63" = let i = Int63.of_int in test [%here] (module Int63) 1_000 (fun () -> Int63.random (i 100)) ~min:(i 0) ~max:(i 99) ~check_range:(i 10, i 20); [%expect {||}] ;; let%expect_test "int63_incl" = let i = Int63.of_int in test [%here] (module Int63) 1_000 (fun () -> Int63.random_incl (i (-100)) (i 100)) ~min:(i (-100)) ~max:(i 100) ~check_range:(i (-20), i (-10)); [%expect {||}]; test [%here] (module Int63) 1_000 (fun () -> Int63.random_incl (i 0) Int63.max_value) ~min:(i 0) ~max:Int63.max_value ~check_range:(i 0, Int63.( / ) Int63.max_value (i 100)); [%expect {||}]; test [%here] (module Int63) 1_000 (fun () -> Int63.random_incl Int63.min_value Int63.max_value) ~min:Int63.min_value ~max:Int63.max_value ~check_range:(Int63.( / ) Int63.min_value (i 100), Int63.( / ) Int63.max_value (i 100)); [%expect {||}] ;; let%expect_test "ascii" = test [%here] (module Char) 1_000 ascii ~min:Char.min_value ~max:(Char.of_int_exn 127) ~check_range:('a', 'z'); [%expect {||}] ;; let%expect_test "char" = test [%here] (module Char) 1_000 char ~min:Char.min_value ~max:Char.max_value ~check_range:('\128', '\255'); [%expect {||}] ;; let%test_module "float upper bound is inclusive despite docs" = (module struct (* The fact that this test passes doesn't demonstrate that the bug has gone away, since the test was explicitly contrived to provoke the bug. *) let%expect_test _ = (* No choice but to use magic, since trying to brute-force a seed that causes this behavior takes too long. Hack random_state so that the next 60 bits produced by [bits] are all 1s. *) let random_state = let st = Array.create 0 ~len:55 in st.(1) <- 0b11111__11111__11111__11111__11111__00000; st.(2) <- 0b11111__11111__11111__11111__11111__00000; (Stdlib.Obj.magic (st, 0) : Random.State.t) in require [%here] ~cr:CR_someday (Float.( < ) (Random.State.float random_state 1.) 1.); [%expect {| |}] ;; (* This bug is more clearly illustrated by copying the implementation of [Random.float] from the stdlib (which is just re-exported by Base). Basically, when [r1 /. scale +. r2] requires more than 53 bits of precision, and [bits2] consists of all 1s, rounding causes [rawfloat] to return 1. *) let rawfloat bits1 bits2 = let scale = 1073741824.0 and r1 = Stdlib.float bits1 and r2 = Stdlib.float bits2 in ((r1 /. scale) +. r2) /. scale ;; let%expect_test "likelihood of failure" = (* test 256 states of the random number generator, highest as 60-bit numbers, out of which 64 would have yield a float exactly equal to 1 if [Random.State.float] was not recursive. *) let lbound = (1 lsl 30) - (1 lsl 8) in let ubound = (1 lsl 30) - 1 in let bits2 = ubound in let failures = ref 0 in for bits1 = lbound to ubound do let open Float.O in if rawfloat bits1 bits2 >= 1. then Int.incr failures done; let prob = Stdlib.float !failures *. 0x1p-60 in print_s [%message "likelihood of failure" (failures : int ref) (prob : float)]; [%expect {| ("likelihood of failure" (failures 64) (prob 5.5511151231257827E-17)) |}] ;; end) ;; base-0.16.3/test/test_random.mli000066400000000000000000000000551446274340700165270ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_ref.ml000066400000000000000000000031351446274340700156540ustar00rootroot00000000000000open! Import open Ref let%test_unit "[set_temporarily] without raise" = let r = ref 0 in [%test_result: int] ~expect:1 (set_temporarily r 1 ~f:(fun () -> !r)); [%test_result: int] ~expect:0 !r ;; let%expect_test "[set_temporarily] with raise" = let r = ref 0 in require_does_raise [%here] (fun () -> Nothing.unreachable_code (set_temporarily r 1 ~f:(fun () -> failwith ""))); [%expect {| (Failure "") |}]; require_equal [%here] (module Int) !r 0 ;; let%test_unit "[set_temporarily] where [f] sets the ref" = let r = ref 0 in set_temporarily r 1 ~f:(fun () -> r := 2); [%test_result: int] ~expect:0 !r ;; let%expect_test "[sets_temporarily] without raise" = let r1 = ref 1 in let r2 = ref 2 in let test and_values = let i1 = !r1 in let i2 = !r2 in sets_temporarily and_values ~f:(fun () -> print_s [%message (r1 : int ref) (r2 : int ref)]); require_equal [%here] (module struct type t = int * int [@@deriving equal, sexp_of] end) (!r1, !r2) (i1, i2) in test []; [%expect {| ((r1 1) (r2 2)) |}]; test [ T (r1, 13) ]; [%expect {| ((r1 13) (r2 2)) |}]; test [ T (r1, 13); T (r1, 17) ]; [%expect {| ((r1 17) (r2 2)) |}]; test [ T (r1, 13); T (r2, 17) ]; [%expect {| ((r1 13) (r2 17)) |}] ;; let%expect_test "[sets_temporarily] with raise" = let r = ref 0 in require_does_raise [%here] (fun () -> Nothing.unreachable_code (sets_temporarily [ T (r, 1) ] ~f:(fun () -> failwith ""))); [%expect {| (Failure "") |}]; print_s [%message (r : int ref)]; [%expect {| (r 0) |}] ;; base-0.16.3/test/test_ref.mli000066400000000000000000000000551446274340700160230ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_result.ml000066400000000000000000000030201446274340700164070ustar00rootroot00000000000000open! Base open! Import let%test_module "Result.Error" = (module struct open Result.Error.Let_syntax module Int_or_string = struct type t = (int, string) Result.t [@@deriving equal, sexp_of] end let%expect_test "return" = require_equal [%here] (module Int_or_string) (return "error") (Error "error"); [%expect {| |}] ;; let%expect_test "bind Error" = let result = let%bind e1 = Error "e1" in let%bind e2 = Error "e2" in let%bind e3 = Error "e3" in return (String.concat ~sep:"," [ e1; e2; e3 ]) in require_equal [%here] (module Int_or_string) result (Error "e1,e2,e3"); [%expect {| |}] ;; let%expect_test "bind Ok" = let result = let%bind e1 = Error "e1" in let%bind e2 = Ok 1 in let%bind e3 = Error "e3" in return (String.concat ~sep:"," [ e1; e2; e3 ]) in require_equal [%here] (module Int_or_string) result (Ok 1); [%expect {| |}] ;; let%expect_test "map Error" = let result = let%map e1 = Error "e1" in e1 ^ "!" in require_equal [%here] (module Int_or_string) result (Error "e1!"); [%expect {| |}] ;; let%expect_test "map Ok" = let result = let%map e1 = Ok 1 in e1 ^ "!" in require_equal [%here] (module Int_or_string) result (Ok 1); [%expect {| |}] ;; (* The rest of the Monad functions are derived using the Monad.Make functor, which is well-tested. *) end) ;; base-0.16.3/test/test_result.mli000066400000000000000000000000551446274340700165650ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_sequence.ml000066400000000000000000000465321446274340700167200ustar00rootroot00000000000000open! Import open! Sequence let%test_unit "of_lazy" = let t = range 0 100 in [%test_result: int list] (to_list (of_lazy (lazy t))) ~expect:(to_list t) ;; let%test_unit _ = let seq_of_seqs = unfold ~init:0 ~f:(fun i -> Some (unfold ~init:i ~f:(fun j -> Some ((i, j), j + 1)), i + 1)) in [%test_result: (int * int) list] (to_list (take (interleave seq_of_seqs) 10)) ~expect:[ 0, 0; 0, 1; 1, 1; 0, 2; 1, 2; 2, 2; 0, 3; 1, 3; 2, 3; 3, 3 ] ;; let%expect_test "round_robin vs interleave" = let list_of_lists = [ [ 1; 10; 100; 1000 ]; [ 2; 20; 200 ]; [ 3; 30 ]; [ 4 ] ] in let list_of_seqs = List.map list_of_lists ~f:of_list in let seq_of_seqs = of_list list_of_seqs in print_s [%sexp (to_list (round_robin list_of_seqs) : int list)]; [%expect {| (1 2 3 4 10 20 30 100 200 1_000) |}]; print_s [%sexp (to_list (interleave seq_of_seqs) : int list)]; [%expect {| (1 10 2 100 20 3 1_000 200 30 4) |}] ;; let%test_unit _ = let evens = unfold ~init:0 ~f:(fun i -> Some (i, i + 2)) in let vowels = cycle_list_exn [ 'a'; 'e'; 'i'; 'o'; 'u' ] in [%test_result: (int * char) list] (to_list (take (interleaved_cartesian_product evens vowels) 10)) ~expect: [ 0, 'a'; 0, 'e'; 2, 'a'; 0, 'i'; 2, 'e'; 4, 'a'; 0, 'o'; 2, 'i'; 4, 'e'; 6, 'a' ] ;; let%test_module "Sequence.merge*" = (module struct let%test_unit _ = [%test_eq: (int, int) Merge_with_duplicates_element.t list] (to_list (merge_with_duplicates (of_list [ 1; 2 ]) (of_list [ 2; 3 ]) (* Can't use Core_int.compare because it would be a dependency cycle. *) ~compare:Int.compare)) [ Left 1; Both (2, 2); Right 3 ] ;; let%test_unit _ = [%test_eq: (int, int) Merge_with_duplicates_element.t list] (to_list (merge_with_duplicates (of_list [ 2; 1 ]) (of_list [ 2; 3 ]) ~compare:Int.compare)) [ Both (2, 2); Left 1; Right 3 ] ;; let test_merge_semantics ~merge ~normalize_list = Base_quickcheck.Test.run_exn (module struct module Deduped_and_sorted_int_list = struct type t = int list [@@deriving quickcheck, sexp_of] let sort t = normalize_list t ~compare:Int.compare let quickcheck_generator = Base_quickcheck.Generator.map quickcheck_generator ~f:sort ;; let quickcheck_shrinker = Base_quickcheck.Shrinker.map quickcheck_shrinker ~f:sort ~f_inverse:sort ;; end type t = Deduped_and_sorted_int_list.t * Deduped_and_sorted_int_list.t [@@deriving quickcheck, sexp_of] end) ~f:(fun (xs, ys) -> [%test_result: int list] (Sequence.to_list (merge (Sequence.of_list xs) (Sequence.of_list ys) ~compare:Int.compare)) ~expect:(normalize_list (xs @ ys) ~compare:Int.compare)) ;; let%test_unit "merge_deduped_and_sorted" = test_merge_semantics ~merge:Sequence.merge_deduped_and_sorted ~normalize_list:List.dedup_and_sort ;; let%test_unit "merge_sorted" = test_merge_semantics ~merge:Sequence.merge_sorted ~normalize_list:List.sort ;; end) ;; let%test _ = fold ~f:( + ) ~init:0 (of_list [ 1; 2; 3; 4; 5 ]) = 15 let%test _ = fold ~f:( + ) ~init:0 (of_list []) = 0 let%test_unit _ = let test_equal l = [%test_result: int list] (to_list (of_list l)) ~expect:l in test_equal []; test_equal [ 1; 2; 3; 4; 5 ] ;; (* The test for longer list is after range *) let%test_unit _ = [%test_result: int list] (to_list (range 0 5)) ~expect:[ 0; 1; 2; 3; 4 ] let%test_unit _ = [%test_result: int list] (to_list (range ~stop:`inclusive 0 5)) ~expect:[ 0; 1; 2; 3; 4; 5 ] ;; let%test_unit _ = [%test_result: int list] (to_list (range ~start:`exclusive 0 5)) ~expect:[ 1; 2; 3; 4 ] ;; let%test_unit _ = [%test_result: int list] (to_list (range ~stride:(-2) 5 1)) ~expect:[ 5; 3 ] ;; (* Test for to_list *) let%test_unit _ = [%test_result: int list] (to_list (range 0 5000)) ~expect:(List.range 0 5000) ;; (* Functions used for testing by comparing to List implementation*) let test_to_list s f g = [%test_result: int list] (to_list (f s)) ~expect:(g (to_list s)) (* For testing, we create a sequence which is equal to 1;2;3;4;5, but with a more interesting structure inside*) let s12345 = map ~f:(fun x -> x / 2) (filter ~f:(fun x -> x % 2 = 0) (of_list [ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ])) ;; let sempty = filter ~f:(fun x -> x < 0) (of_list [ 1; 2; 3; 4 ]) let test f g = test_to_list s12345 f g; test_to_list sempty f g ;; let%test_unit _ = [%test_result: int list] (to_list s12345) ~expect:[ 1; 2; 3; 4; 5 ]; [%test_result: int list] (to_list sempty) ~expect:[] ;; let%test_unit _ = [%test_result: int list] (to_list (unfold_with s12345 ~init:1 ~f:(fun s _ -> if s % 2 = 0 then Skip { state = s + 1 } else if s = 5 then Done else Yield { value = s; state = s + 1 }))) ~expect:[ 1; 3 ] ;; let test_delay init = unfold_with_and_finish ~init ~running_step:(fun prev next -> Yield { value = prev; state = next }) ~inner_finished:(fun x -> Some x) ~finishing_step:(fun prev -> match prev with | None -> Done | Some prev -> Yield { value = prev; state = None }) ;; let%test_unit _ = [%test_result: int list] (to_list (test_delay 0 s12345)) ~expect:[ 0; 1; 2; 3; 4; 5 ] ;; let%test_unit _ = [%test_result: int list] (to_list (test_delay 0 sempty)) ~expect:[ 0 ] let%test_unit _ = [%test_result: int list] (to_list s12345) ~expect:[ 1; 2; 3; 4; 5 ] let%test_unit _ = test (map ~f:(fun i -> -i)) (List.map ~f:(fun i -> -i)) let%test_unit _ = test (mapi ~f:(fun i j -> j - (2 * i))) (List.mapi ~f:(fun i j -> j - (2 * i))) ;; let%test_unit _ = test (filter ~f:(fun i -> i % 2 = 0)) (List.filter ~f:(fun i -> i % 2 = 0)) ;; let%test _ = length s12345 = 5 && length sempty = 0 let%test_unit _ = [%test_result: int option] (find s12345 ~f:(fun x -> x = 3)) ~expect:(Some 3); [%test_result: int option] (find s12345 ~f:(fun x -> x = 7)) ~expect:None ;; let%test_unit _ = [%test_result: string option] (find_map s12345 ~f:(fun x -> if x = 3 then Some "a" else None)) ~expect:(Some "a"); [%test_result: string option] (find_map s12345 ~f:(fun x -> if x = 7 then Some "a" else None)) ~expect:None ;; let%test_unit _ = [%test_result: string option] (find_mapi s12345 ~f:(fun _ x -> if x = 3 then Some "a" else None)) ~expect:(Some "a") ;; let%test_unit _ = [%test_result: string option] (find_mapi s12345 ~f:(fun _ x -> if x = 7 then Some "a" else None)) ~expect:None ;; let%test_unit _ = [%test_result: (int * int) option] (find_mapi s12345 ~f:(fun i x -> if i + x >= 6 then Some (i, x) else None)) ~expect:(Some (3, 4)) ;; let%test _ = for_all sempty ~f:(fun _ -> false) let%test _ = for_all s12345 ~f:(fun x -> x > 0) let%test _ = not (for_all s12345 ~f:(fun x -> x < 5)) let%test _ = for_alli sempty ~f:(fun _ _ -> false) let%test _ = for_alli s12345 ~f:(fun _ x -> x > 0) let%test _ = not (for_alli s12345 ~f:(fun _ x -> x < 5)) let%test _ = for_alli s12345 ~f:(fun i x -> x = i + 1) let%test _ = not (exists sempty ~f:(fun _ -> assert false)) let%test _ = exists s12345 ~f:(fun x -> x = 5) let%test _ = not (exists s12345 ~f:(fun x -> x = 0)) let%test _ = not (existsi sempty ~f:(fun _ _ -> assert false)) let%test _ = existsi s12345 ~f:(fun _ x -> x = 5) let%test _ = not (existsi s12345 ~f:(fun _ x -> x = 0)) let%test _ = not (existsi s12345 ~f:(fun i x -> x <> i + 1)) let%test_unit _ = let l = ref [] in iter s12345 ~f:(fun x -> l := x :: !l); [%test_result: int list] !l ~expect:[ 5; 4; 3; 2; 1 ] ;; let%test _ = is_empty sempty let%test _ = not (is_empty (of_list [ 1 ])) let%test _ = mem s12345 1 ~equal:Int.equal let%test _ = not (mem s12345 6 ~equal:Int.equal) let%test_unit _ = [%test_result: int list] (to_list empty) ~expect:[] let%test_unit _ = [%test_result: int list] (to_list (bind sempty ~f:(fun _ -> s12345))) ~expect:[] ;; let%test_unit _ = [%test_result: int list] (to_list (bind s12345 ~f:(fun _ -> sempty))) ~expect:[] ;; let%test_unit _ = [%test_result: int list] (to_list (bind s12345 ~f:(fun x -> of_list [ x; -x ]))) ~expect:[ 1; -1; 2; -2; 3; -3; 4; -4; 5; -5 ] ;; let%test_unit _ = [%test_result: int list] (to_list (return 1)) ~expect:[ 1 ] let%test_unit _ = [%test_result: int option] (nth s12345 3) ~expect:(Some 4) let%test_unit _ = [%test_result: int option] (nth s12345 5) ~expect:None let%test_unit _ = [%test_result: int option] (hd s12345) ~expect:(Some 1) let%test_unit _ = [%test_result: int option] (hd sempty) ~expect:None let%test_unit _ = [%test_result: int t option] (tl sempty) ~expect:None let%test_unit _ = match tl s12345 with | Some l -> [%test_result: int list] (to_list l) ~expect:[ 2; 3; 4; 5 ] | None -> failwith "expected Some" ;; let%test_unit _ = [%test_result: (int * int t) option] (next sempty) ~expect:None let%test_unit _ = match next s12345 with | Some (hd, tl) -> [%test_result: int] hd ~expect:1; [%test_result: int list] (to_list tl) ~expect:[ 2; 3; 4; 5 ] | None -> failwith "expected Some" ;; let%test_unit _ = [%test_result: int list] (to_list (filter_opt (of_list [ None; Some 1; None; Some 2; Some 3 ]))) ~expect:[ 1; 2; 3 ] ;; let%test_unit _ = let l, r = split_n s12345 2 in [%test_result: int list] l ~expect:[ 1; 2 ]; [%test_result: int list] (to_list r) ~expect:[ 3; 4; 5 ] ;; let%test_unit _ = [%test_result: int list list] (to_list (chunks_exn s12345 2)) ~expect:[ [ 1; 2 ]; [ 3; 4 ]; [ 5 ] ] ;; let%test_unit _ = [%test_result: int list] (to_list (append s12345 s12345)) ~expect:[ 1; 2; 3; 4; 5; 1; 2; 3; 4; 5 ] ;; let%test_unit _ = [%test_result: int list] (to_list (append sempty s12345)) ~expect:[ 1; 2; 3; 4; 5 ] ;; let%test_unit _ = [%test_result: (int * int) list] (to_list (zip s12345 sempty)) ~expect:[] ;; let%test_unit _ = [%test_result: (int * int) list] (to_list (zip s12345 (of_list [ 6; 5; 4; 3; 2; 1 ]))) ~expect:[ 1, 6; 2, 5; 3, 4; 4, 3; 5, 2 ] ;; let%test_unit _ = [%test_result: (int * string) list] (to_list (zip s12345 (of_list [ "a" ]))) ~expect:[ 1, "a" ] ;; let%test_unit _ = [%test_result: (int * int) option] (find_consecutive_duplicate s12345 ~equal:( = )) ~expect:None ;; let%test_unit _ = [%test_result: (int * int) option] (find_consecutive_duplicate (of_list [ 1; 2; 2; 3; 4; 4; 5 ]) ~equal:( = )) ~expect:(Some (2, 2)) ;; let%test_unit _ = [%test_result: int list] (to_list (remove_consecutive_duplicates ~equal:( = ) (of_list [ 1; 2; 2; 3; 3; 3; 3; 4; 4; 5; 6; 6; 7 ]))) ~expect:[ 1; 2; 3; 4; 5; 6; 7 ] ;; let%test_unit _ = [%test_result: int list] (to_list (remove_consecutive_duplicates ~equal:( = ) s12345)) ~expect:[ 1; 2; 3; 4; 5 ] ;; let%test_unit _ = [%test_result: int list] (to_list (remove_consecutive_duplicates ~equal:(fun _ _ -> true) s12345)) ~expect:[ 1 ] ;; let%test_unit _ = [%test_result: int list] (to_list (init (-1) ~f:(fun _ -> assert false))) ~expect:[] ;; let%test_unit _ = [%test_result: int list] (to_list (init 5 ~f:Fn.id)) ~expect:[ 0; 1; 2; 3; 4 ] ;; let%test_unit _ = [%test_result: int list] (to_list (sub s12345 ~pos:4 ~len:10)) ~expect:[ 5 ] ;; let%test_unit _ = [%test_result: int list] (to_list (sub s12345 ~pos:1 ~len:2)) ~expect:[ 2; 3 ] ;; let%test_unit _ = [%test_result: int list] (to_list (sub s12345 ~pos:0 ~len:0)) ~expect:[] let%test_unit _ = [%test_result: int list] (to_list (take s12345 2)) ~expect:[ 1; 2 ] let%test_unit _ = [%test_result: int list] (to_list (take s12345 0)) ~expect:[] let%test_unit _ = [%test_result: int list] (to_list (take s12345 9)) ~expect:[ 1; 2; 3; 4; 5 ] ;; let%test_unit _ = [%test_result: int list] (to_list (drop s12345 2)) ~expect:[ 3; 4; 5 ] let%test_unit _ = [%test_result: int list] (to_list (drop s12345 0)) ~expect:[ 1; 2; 3; 4; 5 ] ;; let%test_unit _ = [%test_result: int list] (to_list (drop s12345 9)) ~expect:[] let%test_unit _ = [%test_result: int list] (to_list (take_while ~f:(fun x -> x < 3) s12345)) ~expect:[ 1; 2 ] ;; let%test_unit _ = [%test_result: int list] (to_list (drop_while ~f:(fun x -> x < 3) s12345)) ~expect:[ 3; 4; 5 ] ;; let%test_unit _ = [%test_result: int list] (to_list (shift_right (shift_right s12345 0) (-1))) ~expect:[ -1; 0; 1; 2; 3; 4; 5 ] ;; let%test_unit _ = [%test_result: char list] (to_list (intersperse ~sep:'a' (of_list []))) ~expect:[] ;; let%test_unit _ = [%test_result: char list] (to_list (intersperse ~sep:'a' (of_list [ 'b' ]))) ~expect:[ 'b' ] ;; let%test_unit _ = [%test_result: int list] (to_list (intersperse ~sep:(-1) (take s12345 1))) ~expect:[ 1 ] ;; let%test_unit _ = [%test_result: int list] (to_list (intersperse ~sep:0 s12345)) ~expect:[ 1; 0; 2; 0; 3; 0; 4; 0; 5 ] ;; let%test_unit _ = [%test_result: int list] (to_list (take (repeat 1) 3)) ~expect:[ 1; 1; 1 ] ;; let%test_unit _ = [%test_result: int list] (to_list (take (cycle_list_exn [ 1; 2; 3; 4; 5 ]) 7)) ~expect:[ 1; 2; 3; 4; 5; 1; 2 ] ;; let%expect_test _ = require_does_raise [%here] (fun () -> cycle_list_exn []); [%expect {| (Invalid_argument Sequence.cycle_list_exn) |}] ;; let%test_unit _ = [%test_result: (char * int) list] (to_list (cartesian_product (of_list [ 'a'; 'b' ]) s12345)) ~expect: [ 'a', 1; 'a', 2; 'a', 3; 'a', 4; 'a', 5; 'b', 1; 'b', 2; 'b', 3; 'b', 4; 'b', 5 ] ;; let%test_unit _ = [%test_result: float] (delayed_fold s12345 ~init:0.0 ~f:(fun a i ~k -> if Float.( <= ) a 5.0 then k (a +. Float.of_int i) else a) ~finish:(fun _ -> assert false)) ~expect:6.0 ;; let%expect_test "fold_m" = let module Simple_monad = struct type 'a t = | Return of 'a | Step of 'a t [@@deriving sexp_of] let return a = Return a let rec bind t ~f = match t with | Return a -> f a | Step t -> Step (bind t ~f) ;; let step = Step (Return ()) end in fold_m ~bind:Simple_monad.bind ~return:Simple_monad.return s12345 ~init:[] ~f:(fun acc n -> Simple_monad.bind Simple_monad.step ~f:(fun () -> Simple_monad.return (n :: acc))) |> printf !"%{sexp: int list Simple_monad.t}\n"; [%expect {| (Step (Step (Step (Step (Step (Return (5 4 3 2 1))))))) |}] ;; let%expect_test "iter_m" = iter_m ~bind:Generator.bind ~return:Generator.return s12345 ~f:Generator.yield |> Generator.run |> printf !"%{sexp: int t}\n"; [%expect {| (1 2 3 4 5) |}] ;; let%test _ = let num_computations = ref 0 in let t = memoize (unfold ~init:() ~f:(fun () -> Int.incr num_computations; None)) in iter t ~f:Fn.id; iter t ~f:Fn.id; !num_computations = 1 ;; let%test_unit _ = [%test_result: int list] (to_list (drop_eagerly s12345 0)) ~expect:[ 1; 2; 3; 4; 5 ] ;; let%test_unit _ = [%test_result: int list] (to_list (drop_eagerly s12345 2)) ~expect:[ 3; 4; 5 ] ;; let%test_unit _ = [%test_result: int list] (to_list (drop_eagerly s12345 5)) ~expect:[] let%test_unit _ = [%test_result: int list] (to_list (drop_eagerly s12345 8)) ~expect:[] let compare_tests = [ [ 1; 2; 3 ], [ 1; 2; 3 ], 0 ; [ 1; 2; 3 ], [], 1 ; [], [ 1; 2; 3 ], -1 ; [ 1; 2 ], [ 1; 2; 3 ], -1 ; [ 1; 2; 3 ], [ 1; 2 ], 1 ; [ 1; 3; 2 ], [ 1; 2; 3 ], 1 ; [ 1; 2; 3 ], [ 1; 3; 2 ], -1 ] ;; (* this test has to use base OCaml library functions to avoid circular dependencies *) let%test _ = List.for_all ~f:Fn.id (List.map ~f:(fun (l1, l2, expected_res) -> compare Int.compare (of_list l1) (of_list l2) = expected_res) compare_tests) ;; let%expect_test "[equal]" = let equal l1 l2 = let t1 = of_list l1 in let t2 = of_list l2 in let b = equal Int.equal t1 t2 in print_s [%sexp (b : bool)]; require [%here] (Bool.equal b (equal Int.equal t2 t1)) in equal [] []; [%expect {| true |}]; equal [] [ 1 ]; [%expect {| false |}]; equal [ 1 ] [ 1 ]; [%expect {| true |}]; equal [ 1 ] [ 1; 2 ]; [%expect {| false |}] ;; let%test_unit "[equal] randomised test" = let with_gen ?examples gen = Base_quickcheck.Test.run_exn ?examples (module struct type t = int list * int list [@@deriving quickcheck, sexp_of] let quickcheck_generator = gen end) ~f:(fun (left, right) -> [%test_result: bool] ~expect:(List.equal Int.equal left right) (Comparable.lift (Sequence.equal Int.equal) ~f:Sequence.of_list left right)) in let list_gen = [%generator: int list] in (* certainly equal. *) with_gen ~examples: (List.map ~f:(fun x -> x, x) [ []; [ 1 ]; [ Int.max_value ]; [ 5; 4; 3; 2; 1 ] ]) (Base_quickcheck.Generator.map list_gen ~f:(fun x -> x, x)); (* Probably not equal. *) with_gen ~examples:[ [], []; [], [ 1 ]; [ 1 ], []; [ Int.min_value ], [ Int.max_value ] ] (Base_quickcheck.Generator.both list_gen list_gen) ;; let%test_unit _ = [%test_result: int list] (folding_map (of_list [ 1; 2; 3; 4 ]) ~init:0 ~f:(fun acc x -> let y = acc + x in y, y) |> to_list) ~expect:[ 1; 3; 6; 10 ] ;; let%test_unit _ = [%test_result: bool] (folding_map empty ~init:0 ~f:(fun acc x -> let y = acc + x in y, y) |> is_empty) ~expect:true ;; let%test_unit _ = [%test_result: int list] (folding_mapi (of_list [ 1; 2; 3; 4 ]) ~init:0 ~f:(fun i acc x -> let y = acc + (i * x) in y, y) |> to_list) ~expect:[ 0; 2; 8; 20 ] ;; let%test_unit _ = [%test_result: bool] (folding_mapi empty ~init:0 ~f:(fun i acc x -> let y = acc + (i * x) in y, y) |> is_empty) ~expect:true ;; let%expect_test _ = let xs = init 3 ~f:Fn.id |> Generator.of_sequence in let ( @ ) xs ys = Generator.bind xs ~f:(fun () -> ys) in xs @ xs @ xs @ xs @ xs |> Generator.run |> [%sexp_of: int t] |> print_s; [%expect {| (0 1 2 0 1 2 0 1 2 0 1 2 0 1 2) |}] ;; let%test_module "group" = (module struct let%test _ = of_list [ 1; 2; 3; 4 ] |> group ~break:(fun _ x -> Int.equal x 3) |> [%compare.equal: int list t] (of_list [ [ 1; 2 ]; [ 3; 4 ] ]) ;; let%test _ = group empty ~break:(fun _ -> assert false) |> [%compare.equal: unit list t] empty ;; let mis = of_list [ 'M'; 'i'; 's'; 's'; 'i'; 's'; 's'; 'i'; 'p'; 'p'; 'i' ] let equal_letters = of_list [ [ 'M' ] ; [ 'i' ] ; [ 's'; 's' ] ; [ 'i' ] ; [ 's'; 's' ] ; [ 'i' ] ; [ 'p'; 'p' ] ; [ 'i' ] ] ;; let single_letters = of_list [ [ 'M'; 'i'; 's'; 's'; 'i'; 's'; 's'; 'i'; 'p'; 'p'; 'i' ] ] ;; let%test _ = group ~break:Char.( <> ) mis |> [%compare.equal: char list t] equal_letters ;; let%test _ = group ~break:(fun _ _ -> false) mis |> [%compare.equal: char list t] single_letters ;; end) ;; let%test_module "Caml.Seq" = (module struct let list = [ 1; 2; 3; 4 ] let%expect_test "of_seq" = list |> Stdlib.List.to_seq |> Sequence.of_seq |> Sequence.iter ~f:(printf "%d\n"); [%expect {| 1 2 3 4 |}] ;; let%expect_test "to_seq" = list |> Sequence.of_list |> Sequence.to_seq |> Stdlib.Seq.iter (printf "%d\n"); [%expect {| 1 2 3 4 |}] ;; end) ;; base-0.16.3/test/test_sequence.mli000066400000000000000000000000551446274340700170570ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_set.ml000066400000000000000000000037571446274340700157050ustar00rootroot00000000000000open! Import open! Set type int_set = Set.M(Int).t [@@deriving compare, equal, hash, sexp] let%test _ = invariants (of_increasing_iterator_unchecked (module Int) ~len:20 ~f:Fn.id) let%test _ = invariants (Poly.of_increasing_iterator_unchecked ~len:20 ~f:Fn.id) let of_list = of_list (module Int) let%expect_test "split_le_gt" = for len = 1 to 4 do print_endline ""; for key = 0 to len + 1 do let le, gt = split_le_gt (of_list (List.init len ~f:Int.succ)) key in Core.print_s [%sexp (le : int_set), "<=", (key : int), "<", (gt : int_set)] done done; [%expect {| (() <= 0 < (1)) ((1) <= 1 < ()) ((1) <= 2 < ()) (() <= 0 < (1 2)) ((1) <= 1 < (2)) ((1 2) <= 2 < ()) ((1 2) <= 3 < ()) (() <= 0 < (1 2 3)) ((1) <= 1 < (2 3)) ((1 2) <= 2 < (3)) ((1 2 3) <= 3 < ()) ((1 2 3) <= 4 < ()) (() <= 0 < (1 2 3 4)) ((1) <= 1 < (2 3 4)) ((1 2) <= 2 < (3 4)) ((1 2 3) <= 3 < (4)) ((1 2 3 4) <= 4 < ()) ((1 2 3 4) <= 5 < ()) |}] ;; let%expect_test "split_lt_ge" = for len = 1 to 4 do print_endline ""; for key = 0 to len + 1 do let lt, ge = split_lt_ge (of_list (List.init len ~f:Int.succ)) key in Core.print_s [%sexp (lt : int_set), "<", (key : int), "<=", (ge : int_set)] done done; [%expect {| (() < 0 <= (1)) (() < 1 <= (1)) ((1) < 2 <= ()) (() < 0 <= (1 2)) (() < 1 <= (1 2)) ((1) < 2 <= (2)) ((1 2) < 3 <= ()) (() < 0 <= (1 2 3)) (() < 1 <= (1 2 3)) ((1) < 2 <= (2 3)) ((1 2) < 3 <= (3)) ((1 2 3) < 4 <= ()) (() < 0 <= (1 2 3 4)) (() < 1 <= (1 2 3 4)) ((1) < 2 <= (2 3 4)) ((1 2) < 3 <= (3 4)) ((1 2 3) < 4 <= (4)) ((1 2 3 4) < 5 <= ()) |}] ;; let%test_module "Poly" = (module struct let%test _ = length Poly.empty = 0 let%test _ = Poly.equal (Poly.of_list []) Poly.empty let%test _ = let a = Poly.of_list [ 1; 1 ] in let b = Poly.of_list [ "a" ] in length a = length b ;; end) ;; base-0.16.3/test/test_set.mli000066400000000000000000000000551446274340700160420ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_set_interface.ml000066400000000000000000000011361446274340700177120ustar00rootroot00000000000000open! Base (* Typechecking this code is a compile-time check that the specific interfaces have not drifted apart from each other. *) module _ : sig open Set type ('a, 'b) t include Creators_and_accessors_generic with type ('a, 'b, 'c) access_options := ('a, 'b, 'c) Without_comparator.t with type ('a, 'b, 'c) create_options := ('a, 'b, 'c) With_first_class_module.t with type ('a, 'b) set := ('a, 'b) t with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) Set.Using_comparator.Tree.t with type 'a elt := 'a with type 'c cmp := 'c end = Set base-0.16.3/test/test_set_interface.mli000066400000000000000000000000551446274340700200620ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_sexpable.ml000066400000000000000000000016711446274340700167060ustar00rootroot00000000000000open! Import open Sexpable let%test_module "Of_stringable" = (module struct module Doubled_string = struct (* Example module with a partial [of_string] function *) type t = Double of string [@@deriving quickcheck] include Of_stringable (struct type nonrec t = t let to_string (Double x) = x ^ x let of_string x = let length = String.length x in let first_half = String.drop_suffix x (length / 2) in let second_half = String.drop_suffix x (length / 2) in if length % 2 = 0 && String.(first_half = second_half) then Double first_half else failwith [%string "Invalid doubled string %{x}"] ;; end) end let%expect_test "validate sexp grammar" = require_ok [%here] (Sexp_grammar_validation.validate_grammar (module Doubled_string)); [%expect {| String |}] ;; end) ;; base-0.16.3/test/test_sexpable.mli000066400000000000000000000000551446274340700170520ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_sign.ml000066400000000000000000000006421446274340700160400ustar00rootroot00000000000000open! Import open! Sign let%test "of_int" = of_int 37 = Pos && of_int (-22) = Neg && of_int 0 = Zero let%test_unit "( * )" = List.cartesian_product all all |> List.iter ~f:(fun (s1, s2) -> [%test_result: int] (to_int (s1 * s2)) ~expect:(Int.( * ) (to_int s1) (to_int s2))) ;; let%expect_test ("hash coherence" [@tags "64-bits-only"]) = check_hash_coherence [%here] (module Sign) all; [%expect {| |}] ;; base-0.16.3/test/test_sign.mli000066400000000000000000000000551446274340700162070ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_sign_or_nan.ml000066400000000000000000000011131446274340700173660ustar00rootroot00000000000000open! Import open! Sign_or_nan let%test "of_int" = of_int 37 = Pos && of_int (-22) = Neg && of_int 0 = Zero let%expect_test ("hash coherence" [@tags "64-bits-only"]) = check_hash_coherence [%here] (module Sign_or_nan) all; [%expect {| |}] ;; let%expect_test "to_string_hum" = List.iter all ~f:(fun t -> let string = to_string_hum t in print_endline string; match to_sign_exn t with | exception _ -> () | sign -> require_equal [%here] (module String) string (Sign.to_string_hum sign)); [%expect {| negative zero positive not-a-number |}] ;; base-0.16.3/test/test_sign_or_nan.mli000066400000000000000000000000551446274340700175430ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_source_code_position.ml000066400000000000000000000005371446274340700213210ustar00rootroot00000000000000open! Base open! Import let%expect_test "[%here]" = print_s [%sexp [%here]]; [%expect {| lib/base/test/test_source_code_position.ml:5:17 |}] ;; let%expect_test "of_pos __POS__" = let here = Source_code_position.of_pos Stdlib.__POS__ in print_s [%sexp (here : Source_code_position.t)]; [%expect {| test_source_code_position.ml:10:41 |}] ;; base-0.16.3/test/test_source_code_position.mli000066400000000000000000000000551446274340700214650ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_stdlib_shadowing.mlt000066400000000000000000000024141446274340700206070ustar00rootroot00000000000000(* Additional shadowing tests, to make sure the [@@deprecated] attributes are properly transported in [Base] *) open Base let () = seek_in stdin 0 [%%expect {| Line _, characters _-_: Error (alert deprecated): Base.seek_in [2016-09] this element comes from the stdlib distributed with OCaml. Use [Stdio.In_channel.seek] instead. Line _, characters _-_: Error (alert deprecated): Base.stdin [2016-09] this element comes from the stdlib distributed with OCaml. Use [Stdio.stdin] instead. |}] let (_ : _) = StringLabels.make 10 'x' [%%expect {| Line _, characters _-_: Error (alert deprecated): module Base.StringLabels [2016-09] this element comes from the stdlib distributed with OCaml. Referring to the stdlib directly is discouraged by Base. You should either use the equivalent functionality offered by Base, or if you really want to refer to the stdlib, use Stdlib.StringLabels instead |}] let _ = ( == ) [%%expect {| Line _, characters _-_: Error (alert deprecated): Base.== [2016-09] this element comes from the stdlib distributed with OCaml. Use [phys_equal] instead. |}] let _ = ( != ) [%%expect {| Line _, characters _-_: Error (alert deprecated): Base.!= [2016-09] this element comes from the stdlib distributed with OCaml. Use [not (phys_equal ...)] instead. |}] base-0.16.3/test/test_string.ml000066400000000000000000001475541446274340700164240ustar00rootroot00000000000000open! Import open! String let%expect_test ("hash coherence" [@tags "64-bits-only"]) = check_hash_coherence [%here] (module String) [ ""; "a"; "foo" ]; [%expect {| |}] ;; let%test_module "concat" = (module struct let test ?sep list = let from_list = concat ?sep list in let from_array = concat_array ?sep (Array.of_list list) in require_equal [%here] (module String) from_list from_array; print_s [%sexp (from_list : string)] ;; let%expect_test "empty" = test [] ~sep:":"; [%expect {| "" |}] ;; let%expect_test "singleton" = test [ "a" ]; [%expect {| a |}] ;; let%expect_test "empty separator" = test [ "a"; "b" ]; [%expect {| ab |}] ;; let%expect_test "non-empty separator" = test [ "a"; "b" ] ~sep:":"; [%expect {| a:b |}] ;; end) ;; let%expect_test "to_list and to_list_rev" = let test s = let list = to_list s in require_equal [%here] (module struct type t = char list [@@deriving equal, sexp_of] end) (to_list_rev s) (List.rev list); print_s [%sexp (list : char list)] in test ""; [%expect {| () |}]; test "bladderwrack"; [%expect {| (b l a d d e r w r a c k) |}] ;; let%expect_test "sub/unsafe_sub" = let test ~pos ~len = let string = "0123456789" in match Or_error.try_with (fun () -> sub string ~pos ~len) with | Ok safe_substring -> let unsafe_substring = unsafe_sub string ~pos ~len in require_equal [%here] (module String) safe_substring unsafe_substring; print_s [%sexp (safe_substring : t)] | Error e -> print_s [%sexp (e : Error.t)] in test ~pos:0 ~len:0; [%expect {| "" |}]; test ~pos:0 ~len:5; [%expect {| 01234 |}]; test ~pos:0 ~len:10; [%expect {| 0123456789 |}]; test ~pos:0 ~len:11; [%expect {| (Invalid_argument "pos + len past end: 0 + 11 > 10") |}]; test ~pos:1 ~len:5; [%expect {| 12345 |}]; test ~pos:1 ~len:10; [%expect {| (Invalid_argument "pos + len past end: 1 + 10 > 10") |}]; test ~pos:9 ~len:1; [%expect {| 9 |}]; test ~pos:9 ~len:2; [%expect {| (Invalid_argument "pos + len past end: 9 + 2 > 10") |}]; test ~pos:10 ~len:0; [%expect {| "" |}]; test ~pos:10 ~len:1; [%expect {| (Invalid_argument "pos + len past end: 10 + 1 > 10") |}] ;; let%test_module "Caseless Suffix/Prefix" = (module struct let%test _ = Caseless.is_suffix "OCaml" ~suffix:"AmL" let%test _ = Caseless.is_suffix "OCaml" ~suffix:"ocAmL" let%test _ = Caseless.is_suffix "a@!$b" ~suffix:"a@!$B" let%test _ = not (Caseless.is_suffix "a@!$b" ~suffix:"C@!$B") let%test _ = not (Caseless.is_suffix "aa" ~suffix:"aaa") let%test _ = Caseless.is_prefix "OCaml" ~prefix:"oc" let%test _ = Caseless.is_prefix "OCaml" ~prefix:"ocAmL" let%test _ = Caseless.is_prefix "a@!$b" ~prefix:"a@!$B" let%test _ = not (Caseless.is_prefix "a@!$b" ~prefix:"a@!$C") let%test _ = not (Caseless.is_prefix "aa" ~prefix:"aaa") end) ;; let%test_module "Caseless Substring" = (module struct let%test _ = Caseless.is_substring "OCaml" ~substring:"AmL" let%test _ = Caseless.is_substring "OCaml" ~substring:"oc" let%test _ = Caseless.is_substring "OCaml" ~substring:"ocAmL" let%test _ = Caseless.is_substring "a@!$b" ~substring:"a@!$B" let%test _ = not (Caseless.is_substring "a@!$b" ~substring:"C@!$B") let%test _ = not (Caseless.is_substring "a@!$b" ~substring:"a@!$C") let%test _ = not (Caseless.is_substring "aa" ~substring:"aaa") let%test _ = not (Caseless.is_substring "aa" ~substring:"AAA") let%test_unit _ = Base_quickcheck.Test.run_exn (module struct type t = string * string [@@deriving quickcheck, sexp_of] end) ~f:(fun (t, substring) -> let actual = Caseless.is_substring t ~substring in let expect = is_substring (lowercase t) ~substring:(lowercase substring) in [%test_result: bool] actual ~expect) ;; end) ;; let%test_module "Caseless Comparable" = (module struct (* examples from docs *) let%test _ = Caseless.equal "OCaml" "ocaml" let%test _ = Caseless.("apple" < "Banana") let%test _ = Caseless.("aa" < "aaa") let%test _ = Int.( <> ) (Caseless.compare "apple" "Banana") (compare "apple" "Banana") let%test _ = Caseless.equal "XxX" "xXx" let%test _ = Caseless.("XxX" < "xXxX") let%test _ = Caseless.("XxXx" > "xXx") let%test _ = List.is_sorted ~compare:Caseless.compare [ "Apples"; "bananas"; "Carrots" ] ;; end) ;; let%test_module "Caseless Hashable" = (module struct let%test _ = Int.( <> ) (hash "x") (hash "X") && Int.( = ) (Caseless.hash "x") (Caseless.hash "X") ;; let%test _ = Int.( = ) (Caseless.hash "OCaml") (Caseless.hash "ocaml") let%test _ = Int.( <> ) (Caseless.hash "aaa") (Caseless.hash "aaaa") let%test _ = Int.( <> ) (Caseless.hash "aaa") (Caseless.hash "aab") let%test _ = let tbl = Hashtbl.create (module Caseless) in Hashtbl.add_exn tbl ~key:"x" ~data:7; [%compare.equal: int option] (Hashtbl.find tbl "X") (Some 7) ;; end) ;; let%test _ = not (contains "" 'a') let%test _ = contains "a" 'a' let%test _ = not (contains "a" 'b') let%test _ = contains "ab" 'a' let%test _ = contains "ab" 'b' let%test _ = not (contains "ab" 'c') let%test _ = not (contains "abcd" 'b' ~pos:1 ~len:0) let%test _ = contains "abcd" 'b' ~pos:1 ~len:1 let%test _ = contains "abcd" 'c' ~pos:1 ~len:2 let%test _ = not (contains "abcd" 'd' ~pos:1 ~len:2) let%test _ = contains "abcd" 'd' ~pos:1 let%test _ = not (contains "abcd" 'a' ~pos:1) let%test_module "Search_pattern" = (module struct open Search_pattern let%test_module "Search_pattern.create" = (module struct let prefix s n = sub s ~pos:0 ~len:n let suffix s n = sub s ~pos:(length s - n) ~len:n let slow_create pattern ~case_sensitive = let string_equal = if case_sensitive then String.equal else String.Caseless.equal in (* Compute the longest prefix-suffix array from definition, O(n^3) *) let n = length pattern in let kmp_array = Array.create ~len:n (-1) in for i = 0 to n - 1 do let x = prefix pattern (i + 1) in for j = 0 to i do if string_equal (prefix x j) (suffix x j) then kmp_array.(i) <- j done done; ({ pattern; kmp_array; case_sensitive } : Private.t) ;; let test_both ({ pattern; case_sensitive; kmp_array = _ } as expected : Private.t) = let create_repr = Private.representation (create pattern ~case_sensitive) in let slow_create_repr = slow_create pattern ~case_sensitive in require_equal [%here] (module Private) create_repr expected; require_equal [%here] (module Private) slow_create_repr expected ;; let cmp_both pattern ~case_sensitive = let create_repr = Private.representation (create pattern ~case_sensitive) in let slow_create_repr = slow_create pattern ~case_sensitive in require_equal [%here] (module Private) create_repr slow_create_repr ;; let%expect_test _ = List.iter [%all: bool] ~f:(fun case_sensitive -> test_both { pattern = ""; case_sensitive; kmp_array = [||] }) ;; let%expect_test _ = List.iter [%all: bool] ~f:(fun case_sensitive -> test_both { pattern = "ababab"; case_sensitive; kmp_array = [| 0; 0; 1; 2; 3; 4 |] }) ;; let%expect_test _ = List.iter [%all: bool] ~f:(fun case_sensitive -> test_both { pattern = "abaCabaD" ; case_sensitive ; kmp_array = [| 0; 0; 1; 0; 1; 2; 3; 0 |] }) ;; let%expect_test _ = List.iter [%all: bool] ~f:(fun case_sensitive -> test_both { pattern = "abaCabaDabaCabaCabaDabaCabaEabab" ; case_sensitive ; kmp_array = [| 0 ; 0 ; 1 ; 0 ; 1 ; 2 ; 3 ; 0 ; 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 ; 10 ; 11 ; 12 ; 13 ; 14 ; 15 ; 0 ; 1 ; 2 ; 3 ; 2 |] }) ;; let%expect_test _ = test_both { pattern = "aaA"; case_sensitive = true; kmp_array = [| 0; 1; 0 |] } ;; let%expect_test _ = test_both { pattern = "aaA"; case_sensitive = false; kmp_array = [| 0; 1; 2 |] } ;; let%expect_test _ = test_both { pattern = "aAaAaA" ; case_sensitive = true ; kmp_array = [| 0; 0; 1; 2; 3; 4 |] } ;; let%expect_test _ = test_both { pattern = "aAaAaA" ; case_sensitive = false ; kmp_array = [| 0; 1; 2; 3; 4; 5 |] } ;; let rec x k = if Int.( < ) k 0 then "" else ( let b = x (k - 1) in b ^ make 1 (Stdlib.Char.unsafe_chr (65 + k)) ^ b) ;; let%expect_test _ = List.iter [%all: bool] ~f:(fun case_sensitive -> cmp_both ~case_sensitive (x 10)) ;; let%expect_test _ = List.iter [%all: bool] ~f:(fun case_sensitive -> cmp_both ~case_sensitive (x 5 ^ "E" ^ x 4 ^ "D" ^ x 3 ^ "B" ^ x 2 ^ "C" ^ x 3)) ;; let%test_unit _ = Base_quickcheck.Test.run_exn (module struct type t = string [@@deriving quickcheck, sexp_of] end) ~f:(fun pattern -> let case_insensitive = Private.representation (create pattern ~case_sensitive:false) in let case_sensitive_but_lowercase = Private.representation (create (lowercase pattern) ~case_sensitive:true) in [%test_result: String.Caseless.t] case_insensitive.pattern ~expect:case_sensitive_but_lowercase.pattern; [%test_result: int array] case_insensitive.kmp_array ~expect:case_sensitive_but_lowercase.kmp_array) ;; end) ;; let ( = ) = [%compare.equal: int option] let%test _ = index (create "") ~in_:"abababac" = Some 0 let%test _ = index ~pos:(-1) (create "") ~in_:"abababac" = None let%test _ = index ~pos:1 (create "") ~in_:"abababac" = Some 1 let%test _ = index ~pos:7 (create "") ~in_:"abababac" = Some 7 let%test _ = index ~pos:8 (create "") ~in_:"abababac" = Some 8 let%test _ = index ~pos:9 (create "") ~in_:"abababac" = None let%test _ = index (create "abababaca") ~in_:"abababac" = None let%test _ = index (create "abababac") ~in_:"abababac" = Some 0 let%test _ = index ~pos:0 (create "abababac") ~in_:"abababac" = Some 0 let%test _ = index (create "abac") ~in_:"abababac" = Some 4 let%test _ = index ~pos:4 (create "abac") ~in_:"abababac" = Some 4 let%test _ = index ~pos:5 (create "abac") ~in_:"abababac" = None let%test _ = index ~pos:5 (create "abac") ~in_:"abababaca" = None let%test _ = index ~pos:5 (create "baca") ~in_:"abababaca" = Some 5 let%test _ = index ~pos:(-1) (create "a") ~in_:"abc" = None let%test _ = index ~pos:2 (create "a") ~in_:"abc" = None let%test _ = index ~pos:2 (create "c") ~in_:"abc" = Some 2 let%test _ = index ~pos:3 (create "c") ~in_:"abc" = None let ( = ) = [%compare.equal: bool] let%test _ = matches (create "") "abababac" = true let%test _ = matches (create "abababaca") "abababac" = false let%test _ = matches (create "abababac") "abababac" = true let%test _ = matches (create "abac") "abababac" = true let%test _ = matches (create "abac") "abababaca" = true let%test _ = matches (create "baca") "abababaca" = true let%test _ = matches (create "a") "abc" = true let%test _ = matches (create "c") "abc" = true let ( = ) = [%compare.equal: int list] let%test _ = index_all (create "") ~may_overlap:false ~in_:"abcd" = [ 0; 1; 2; 3; 4 ] let%test _ = index_all (create "") ~may_overlap:true ~in_:"abcd" = [ 0; 1; 2; 3; 4 ] let%test _ = index_all (create "abab") ~may_overlap:false ~in_:"abababab" = [ 0; 4 ] let%test _ = index_all (create "abab") ~may_overlap:true ~in_:"abababab" = [ 0; 2; 4 ] let%test _ = index_all (create "abab") ~may_overlap:false ~in_:"ababababab" = [ 0; 4 ] let%test _ = index_all (create "abab") ~may_overlap:true ~in_:"ababababab" = [ 0; 2; 4; 6 ] ;; let%test _ = index_all (create "aaa") ~may_overlap:false ~in_:"aaaaBaaaaaa" = [ 0; 5; 8 ] ;; let%test _ = index_all (create "aaa") ~may_overlap:true ~in_:"aaaaBaaaaaa" = [ 0; 1; 5; 6; 7; 8 ] ;; let ( = ) = [%compare.equal: string] let%test _ = replace_first (create "abab") ~in_:"abababab" ~with_:"" = "abab" let%test _ = replace_first (create "abab") ~in_:"abacabab" ~with_:"" = "abac" let%test _ = replace_first (create "abab") ~in_:"ababacab" ~with_:"A" = "Aacab" let%test _ = replace_first (create "abab") ~in_:"acabababab" ~with_:"A" = "acAabab" let%test _ = replace_first (create "ababab") ~in_:"acabababab" ~with_:"A" = "acAab" let%test _ = replace_first (create "abab") ~in_:"abababab" ~with_:"abababab" = "abababababab" ;; let%test _ = replace_all (create "abab") ~in_:"abababab" ~with_:"" = "" let%test _ = replace_all (create "abab") ~in_:"abacabab" ~with_:"" = "abac" let%test _ = replace_all (create "abab") ~in_:"acabababab" ~with_:"A" = "acAA" let%test _ = replace_all (create "ababab") ~in_:"acabababab" ~with_:"A" = "acAab" let%test _ = replace_all (create "abaC") ~in_:"abaCabaDCababaCabaCaba" ~with_:"x" = "xabaDCabxxaba" ;; let%test _ = replace_all (create "a") ~in_:"aa" ~with_:"aaa" = "aaaaaa" let%test _ = replace_all (create "") ~in_:"abcdeefff" ~with_:"X1" = "X1aX1bX1cX1dX1eX1eX1fX1fX1fX1" ;; (* a doc comment in core_string.mli gives this as an example *) let%test _ = replace_all (create "bc") ~in_:"aabbcc" ~with_:"cb" = "aabcbc" let%test _ = [%compare.equal: string list] (split_on (create "====") "aa====bbb====c=====d======e========fff") [ "aa"; "bbb"; "c"; "=d"; "==e"; ""; "fff" ] ;; let%test _ = [%compare.equal: string list] (split_on (create "XYXYX") "XYXYXaaXYXYXYXbbXYXYXYXYXYX") [ ""; "aa"; "YXbb"; "Y"; "" ] ;; let%test _ = [%compare.equal: string list] (split_on (create "") "abcd") (* [index_all (create "")] includes the occurrences at index 0 and at the end of the string, and the result of [split_on (create "")] is a consequence of this *) [ ""; "a"; "b"; "c"; "d"; "" ] ;; let%test _ = [%compare.equal: string list] (split_on (create "not present") "here is a string with no matches") [ "here is a string with no matches" ] ;; end) ;; let%test _ = rev "" = "" let%test _ = rev "a" = "a" let%test _ = rev "ab" = "ba" let%test _ = rev "abc" = "cba" let%test_unit _ = List.iter ~f:(fun (t, expect) -> let actual = split_lines t in if not ([%compare.equal: string list] actual expect) then raise_s [%message "split_lines bug" (t : t) (actual : t list) (expect : t list)]) [ "", [] ; "\n", [ "" ] ; "a", [ "a" ] ; "a\n", [ "a" ] ; "a\nb", [ "a"; "b" ] ; "a\nb\n", [ "a"; "b" ] ; "a\n\n", [ "a"; "" ] ; "a\n\nb", [ "a"; ""; "b" ] ] ;; let%test_unit _ = let lines = [ ""; "a"; "bc" ] in let newlines = [ "\n"; "\r\n" ] in let rec loop n expect to_concat = if Int.( = ) n 0 then ( let input = concat to_concat in let actual = Or_error.try_with (fun () -> split_lines input) in if not ([%compare.equal: t list Or_error.t] actual (Ok expect)) then raise_s [%message "split_lines bug" (input : t) (actual : t list Or_error.t) (expect : t list)]) else ( loop (n - 1) expect to_concat; List.iter lines ~f:(fun t -> let loop to_concat = loop (n - 1) (t :: expect) (t :: to_concat) in if (not (is_empty t)) && List.is_empty to_concat then loop []; List.iter newlines ~f:(fun newline -> loop (newline :: to_concat)))) in loop 3 [] [] ;; let%test_unit _ = let s = init 10 ~f:Char.of_int_exn in assert (phys_equal s (sub s ~pos:0 ~len:(String.length s))); assert (phys_equal s (prefix s (String.length s))); assert (phys_equal s (suffix s (String.length s))); assert (phys_equal s (concat [ s ])); assert (phys_equal s (tr s ~target:'\255' ~replacement:'\000')) ;; let%test_module "tr_multi" = (module struct let gold_standard ~target ~replacement string = map string ~f:(fun char -> match rindex target char with | None -> char | Some i -> get replacement (Int.min i (length replacement - 1))) ;; module Test = struct type nonrec t = { target : t ; replacement : t ; string : t ; expected : t option [@sexp.option] } [@@deriving sexp_of] let quickcheck_generator = let open Base_quickcheck.Generator in let open Base_quickcheck.Generator.Let_syntax in let%bind size = size in let%bind target_len = int_log_uniform_inclusive 1 255 in let%bind target = string_with_length ~length:target_len in let%bind replacement_len = int_inclusive 1 target_len in let%bind replacement = string_with_length ~length:replacement_len in let%bind string_length = int_inclusive 0 size in let%map string = string_with_length ~length:string_length in { target; replacement; string; expected = None } ;; let quickcheck_shrinker = Base_quickcheck.Shrinker.atomic end let examples = [ "", "", "abcdefg", "abcdefg" ; "", "a", "abcdefg", "abcdefg" ; "aaaa", "abcd", "abcdefg", "dbcdefg" ; "abcd", "bcde", "abcdefg", "bcdeefg" ; "abcd", "bcde", "", "" ; "abcd", "_", "abcdefg", "____efg" ; "abcd", "b_", "abcdefg", "b___efg" ; "a", "dcba", "abcdefg", "dbcdefg" ; "ab", "dcba", "abcdefg", "dccdefg" ] |> List.map ~f:(fun (target, replacement, string, expected) -> { Test.target; replacement; string; expected = Some expected }) ;; let%test_unit _ = Base_quickcheck.Test.run_exn (module Test) ~examples ~f:(fun ({ target; replacement; string; expected } : Test.t) -> (* test implementation behavior against gold standard *) let impl_result = unstage (tr_multi ~target ~replacement) string in let gold_result = gold_standard ~target ~replacement string in [%test_result: t] ~expect:gold_result impl_result; (* test against expected result, if one is provided (non-random examples) *) Option.iter expected ~f:(fun expected -> [%test_result: t] ~expect:expected impl_result); (* test for returning input if the string is unchanged *) if equal string impl_result then assert (phys_equal string impl_result)) ;; end) ;; let%test_unit _ = [%test_result: int option] (lfindi "bob" ~f:(fun _ -> Char.( = ) 'b')) ~expect:(Some 0) ;; let%test_unit _ = [%test_result: int option] (lfindi ~pos:0 "bob" ~f:(fun _ -> Char.( = ) 'b')) ~expect:(Some 0) ;; let%test_unit _ = [%test_result: int option] (lfindi ~pos:1 "bob" ~f:(fun _ -> Char.( = ) 'b')) ~expect:(Some 2) ;; let%test_unit _ = [%test_result: int option] (lfindi "bob" ~f:(fun _ -> Char.( = ) 'x')) ~expect:None ;; let%test_unit _ = [%test_result: char option] (find_map "fop" ~f:(fun c -> if Char.(c >= 'o') then Some c else None)) ~expect:(Some 'o') ;; let%test_unit _ = [%test_result: _ option] (find_map "bar" ~f:(fun _ -> None)) ~expect:None ;; let%test_unit _ = [%test_result: _ option] (find_map "" ~f:(fun _ -> assert false)) ~expect:None ;; let%test_unit _ = [%test_result: int option] (rfindi "bob" ~f:(fun _ -> Char.( = ) 'b')) ~expect:(Some 2) ;; let%test_unit _ = [%test_result: int option] (rfindi ~pos:2 "bob" ~f:(fun _ -> Char.( = ) 'b')) ~expect:(Some 2) ;; let%test_unit _ = [%test_result: int option] (rfindi ~pos:1 "bob" ~f:(fun _ -> Char.( = ) 'b')) ~expect:(Some 0) ;; let%test_unit _ = [%test_result: int option] (rfindi "bob" ~f:(fun _ -> Char.( = ) 'x')) ~expect:None ;; let%test_module "strip" = (module struct let test ?drop s = print_s [%sexp (strip ?drop s : string)] let%expect_test "whitespace on both ends" = test " foo bar \n"; [%expect {| "foo bar" |}] ;; let%expect_test "custom drop, present on end" = test ~drop:(Char.( = ) '"') "\" foo bar "; [%expect {| " foo bar " |}] ;; let%expect_test "custom drop, absent from end" = test ~drop:(Char.( = ) '"') " \" foo bar "; [%expect {| " \" foo bar " |}] ;; let%expect_test "all whitespace" = test "\n\t \n"; [%expect {| "" |}] ;; let%expect_test "no whitespace on ends" = test "as \t\ndf"; [%expect {| "as \t\ndf" |}] ;; let%expect_test "just one side" = test " a"; [%expect {| a |}]; test "a "; [%expect {| a |}] ;; end) ;; let%test_module "lstrip" = (module struct let test ?drop s = print_s [%sexp (lstrip ?drop s : string)] let%expect_test "whitespace on left" = test " \t\r\n123 \t\n"; [%expect {| "123 \t\n" |}] ;; let%expect_test "all whitespace" = test " \t \n\n\r "; [%expect {| "" |}] ;; let%expect_test "no whitespace on left" = test "foo Bar \n "; [%expect {| "foo Bar \n " |}] ;; end) ;; let%test_module "rstrip" = (module struct let test ?drop s = print_s [%sexp (rstrip ?drop s : string)] let%expect_test "whitespace on right" = test " \t\r\n123 \t\n\r"; [%expect {| " \t\r\n123" |}] ;; let%expect_test "all whitespace" = test " \t \n\n\r "; [%expect {| "" |}] ;; let%expect_test "no whitespace on right" = test " \n foo Bar"; [%expect {| " \n foo Bar" |}] ;; end) ;; let%test_module "map" = (module struct let%expect_test "empty" = require_equal [%here] (module String) (map "" ~f:Fn.id) "" let%expect_test "non-empty" = let s = "faboo" in require_equal [%here] (module String) (map s ~f:(function | 'a' -> 'b' | 'b' -> 'a' | x -> x)) "fbaoo" ;; end) ;; let%expect_test "split" = let test s = print_s [%sexp (split s ~on:'c' : string list)] in test ""; [%expect {| ("") |}]; test "c"; [%expect {| ("" "") |}]; test "fooc"; [%expect {| (foo "") |}]; test "cfoo"; [%expect {| ("" foo) |}]; test "cfooc"; [%expect {| ("" foo "") |}]; test "bocci ball"; [%expect {| (bo "" "i ball") |}] ;; let%expect_test "split_on_chars" = let test s ~on = print_s [%sexp (split_on_chars s ~on : string list)] in test "" ~on:[ 'c' ]; [%expect {| ("") |}]; test "c" ~on:[ 'c' ]; [%expect {| ("" "") |}]; test "chr" ~on:[ 'h'; 'c'; 'r' ]; [%expect {| ("" "" "" "") |}]; test "fooc" ~on:[ 'c' ]; [%expect {| (foo "") |}]; test "fooc" ~on:[ 'c'; 'o' ]; [%expect {| (f "" "" "") |}]; test "cfoo" ~on:[ 'c' ]; [%expect {| ("" foo) |}]; test "cfoo" ~on:[ 'c'; 'f' ]; [%expect {| ("" "" oo) |}]; test "bocci ball" ~on:[ 'c' ]; [%expect {| (bo "" "i ball") |}]; test "bocci ball" ~on:[ 'c'; ' '; 'i' ]; [%expect {| (bo "" "" "" ball) |}] ;; let%test_unit _ = [%test_result: bool] ~expect:false (exists "" ~f:(fun _ -> assert false)) ;; let%test_unit _ = [%test_result: bool] ~expect:false (exists "abc" ~f:(Fn.const false)) let%test_unit _ = [%test_result: bool] ~expect:true (exists "abc" ~f:(Fn.const true)) let%test_unit _ = [%test_result: bool] ~expect:true (exists "abc" ~f:(function | 'a' -> false | 'b' -> true | _ -> assert false)) ;; let%test_unit _ = [%test_result: bool] ~expect:true (for_all "" ~f:(fun _ -> assert false)) ;; let%test_unit _ = [%test_result: bool] ~expect:true (for_all "abc" ~f:(Fn.const true)) let%test_unit _ = [%test_result: bool] ~expect:false (for_all "abc" ~f:(Fn.const false)) let%test_unit _ = [%test_result: bool] ~expect:false (for_all "abc" ~f:(function | 'a' -> true | 'b' -> false | _ -> assert false)) ;; let%test_unit _ = [%test_result: char list] (fold "hello" ~init:[] ~f:(fun acc ch -> ch :: acc)) ~expect:(List.rev [ 'h'; 'e'; 'l'; 'l'; 'o' ]); [%test_result: (int * char) list] (foldi "hello" ~init:[] ~f:(fun i acc ch -> (i, ch) :: acc)) ~expect:(List.rev [ 0, 'h'; 1, 'e'; 2, 'l'; 3, 'l'; 4, 'o' ]) ;; let%expect_test "iteri" = iteri "hello" ~f:(fun i ch -> printf "%d%c " i ch); [%expect {| 0h 1e 2l 3l 4o |}] ;; let%test_unit _ = [%test_result: t] (filter "hello" ~f:(Char.( <> ) 'h')) ~expect:"ello" let%test_unit _ = [%test_result: t] (filter "hello" ~f:(Char.( <> ) 'l')) ~expect:"heo" let%test_unit _ = [%test_result: t] (filter "hello" ~f:(fun _ -> false)) ~expect:"" let%test_unit _ = [%test_result: t] (filter "hello" ~f:(fun _ -> true)) ~expect:"hello" let%test_unit _ = [%test_result: t] (filteri "hello" ~f:(fun i _ -> Int.(i % 2 = 0))) ~expect:"hlo" ;; let%test_unit _ = let s = "hello" in [%test_result: bool] ~expect:true (phys_equal (filter s ~f:(fun _ -> true)) s) ;; let%test_unit _ = let s = "abc" in let r = ref 0 in assert ( phys_equal s (filter s ~f:(fun _ -> Int.incr r; true))); assert (Int.( = ) !r (String.length s)) ;; let%test_module "Hash" = (module struct external hash : string -> int = "Base_hash_string" [@@noalloc] let%test_unit _ = List.iter ~f:(fun string -> assert (Int.( = ) (hash string) (Stdlib.Hashtbl.hash string)); (* with 31-bit integers, the hash computed by ppx_hash overflows so it doesn't match polymorphic hash exactly. *) if Int.( > ) Int.num_bits 31 then assert (Int.( = ) (hash string) ([%hash: string] string))) [ "Oh Gloria inmarcesible! Oh jubilo inmortal!" ; "Oh say can you see, by the dawn's early light" ; "Hahahaha\200" ] ;; end) ;; let%test _ = of_char_list [ 'a'; 'b'; 'c' ] = "abc" let%test _ = of_char_list [] = "" let%expect_test "is_substring_at" = let string = "lorem ipsum dolor sit amet" in let test pos substring = match is_substring_at string ~pos ~substring with | bool -> print_s [%sexp (bool : bool)] | exception exn -> print_s [%message "raised" ~_:(exn : exn)] in test 0 "lorem"; [%expect {| true |}]; test 1 "lorem"; [%expect {| false |}]; test 6 "ipsum"; [%expect {| true |}]; test 5 "ipsum"; [%expect {| false |}]; test 22 "amet"; [%expect {| true |}]; test 23 "amet"; [%expect {| false |}]; test 22 "amet and some other stuff"; [%expect {| false |}]; test 0 ""; [%expect {| true |}]; test 10 ""; [%expect {| true |}]; test 26 ""; [%expect {| true |}]; test 100 ""; [%expect {| (raised ( Invalid_argument "String.is_substring_at: invalid index 100 for string of length 26")) |}]; test (-1) ""; [%expect {| (raised ( Invalid_argument "String.is_substring_at: invalid index -1 for string of length 26")) |}] ;; let%expect_test "prefixes and suffixes" = let s = "0123456789" in require_equal [%here] (module String) (String.prefix s 0) ""; require_equal [%here] (module String) (String.prefix s 1) "0"; require_equal [%here] (module String) (String.prefix s 2) "01"; require_equal [%here] (module String) (String.prefix s 10) s; require_equal [%here] (module String) (String.prefix s 20) s; require_does_raise [%here] (fun () -> String.prefix s (-1)); [%expect {| (Invalid_argument "prefix expecting nonnegative argument") |}]; require_equal [%here] (module String) (String.suffix s 0) ""; require_equal [%here] (module String) (String.suffix s 1) "9"; require_equal [%here] (module String) (String.suffix s 2) "89"; require_equal [%here] (module String) (String.suffix s 10) s; require_equal [%here] (module String) (String.suffix s 20) s; require_does_raise [%here] (fun () -> String.suffix s (-1)); [%expect {| (Invalid_argument "suffix expecting nonnegative argument") |}] ;; let%expect_test "drop prefixes and suffixes" = let s = "0123456789" in require_equal [%here] (module String) (String.drop_prefix s 0) s; require_equal [%here] (module String) (String.drop_prefix s 1) "123456789"; require_equal [%here] (module String) (String.drop_prefix s 2) "23456789"; require_equal [%here] (module String) (String.drop_prefix s 10) ""; require_equal [%here] (module String) (String.drop_prefix s 20) ""; require_does_raise [%here] (fun () -> String.drop_prefix s (-1)); [%expect {| (Invalid_argument "drop_prefix expecting nonnegative argument") |}]; require_equal [%here] (module String) (String.drop_suffix s 0) s; require_equal [%here] (module String) (String.drop_suffix s 1) "012345678"; require_equal [%here] (module String) (String.drop_suffix s 2) "01234567"; require_equal [%here] (module String) (String.drop_suffix s 10) ""; require_equal [%here] (module String) (String.drop_suffix s 20) ""; require_does_raise [%here] (fun () -> String.drop_suffix s (-1)); [%expect {| (Invalid_argument "drop_suffix expecting nonnegative argument") |}] ;; let%expect_test "testing prefixes and suffixes" = let test outer inner = print_s [%message "" ~is_prefix:(is_prefix outer ~prefix:inner : bool) ~is_suffix:(is_suffix outer ~suffix:inner : bool)] in test "" "a"; [%expect {| ((is_prefix false) (is_suffix false)) |}]; test "" ""; [%expect {| ((is_prefix true) (is_suffix true)) |}]; test "Foo" ""; [%expect {| ((is_prefix true) (is_suffix true)) |}]; test "H" "H"; [%expect {| ((is_prefix true) (is_suffix true)) |}]; test "Hello" "He"; [%expect {| ((is_prefix true) (is_suffix false)) |}]; test "Hello" "lo"; [%expect {| ((is_prefix false) (is_suffix true)) |}]; test "HelloFoo" "lo"; [%expect {| ((is_prefix false) (is_suffix false)) |}] ;; let%expect_test "chop_prefix" = let s = "__x__" in let test_prefix ~prefix = let result = Or_error.try_with (fun () -> chop_prefix_exn s ~prefix) in require_equal [%here] (module struct type t = string option [@@deriving equal, sexp_of] end) (chop_prefix s ~prefix) (Or_error.ok result); require_equal [%here] (module String) (chop_prefix_if_exists s ~prefix) (result |> Or_error.ok |> Option.value ~default:s); print_s [%sexp (result : string Or_error.t)] in test_prefix ~prefix:""; [%expect {| (Ok __x__) |}]; test_prefix ~prefix:"__"; [%expect {| (Ok x__) |}]; test_prefix ~prefix:"=="; [%expect {| (Error (Invalid_argument "String.chop_prefix_exn \"__x__\" \"==\"")) |}] ;; let%expect_test "chop_suffix" = let s = "__x__" in let test_suffix ~suffix = let result = Or_error.try_with (fun () -> chop_suffix_exn s ~suffix) in require_equal [%here] (module struct type t = string option [@@deriving equal, sexp_of] end) (chop_suffix s ~suffix) (Or_error.ok result); require_equal [%here] (module String) (chop_suffix_if_exists s ~suffix) (result |> Or_error.ok |> Option.value ~default:s); print_s [%sexp (result : string Or_error.t)] in test_suffix ~suffix:""; [%expect {| (Ok __x__) |}]; test_suffix ~suffix:"__"; [%expect {| (Ok __x) |}]; test_suffix ~suffix:"=="; [%expect {| (Error (Invalid_argument "String.chop_suffix_exn \"__x__\" \"==\"")) |}] ;; let%expect_test "String.concat_lines" = let concat_lines_reference lines ~crlf = String.concat (List.map lines ~f:(fun line -> line ^ if crlf then "\r\n" else "\n")) in quickcheck_m [%here] (module struct type t = string list * bool [@@deriving quickcheck, sexp_of] end) ~f:(fun (lines, crlf) -> require_equal [%here] (module String) (String.concat_lines lines ~crlf) (concat_lines_reference lines ~crlf)); [%expect {| |}] ;; let%expect_test "String.concat_lines examples" = let test ?crlf lines = print_s [%sexp (String.concat_lines ?crlf lines : string)] in test [ "foo"; "bar" ]; [%expect {| "foo\nbar\n" |}]; test [ "foo\n"; "b\nar\n"; "x" ]; [%expect {| "foo\n\nb\nar\n\nx\n" |}]; test []; [%expect {| "" |}]; test ~crlf:true [ "foo"; "bar" ]; [%expect {| "foo\r\nbar\r\n" |}] ;; let%expect_test "pad_left and pad_right" = let test ?char t ~len = let padded_left = pad_left ?char t ~len in require [%here] (Int.( >= ) (length padded_left) len); require [%here] (String.is_suffix padded_left ~suffix:t); let padded_right = pad_right ?char t ~len in require [%here] (Int.( >= ) (length padded_right) len); require [%here] (String.is_prefix padded_right ~prefix:t); if Int.( >= ) (length t) len then ( require [%here] (phys_equal t padded_left); require [%here] (phys_equal t padded_right)); print_s [%message (t : string) (padded_left : string) (padded_right : string)] in test "" ~len:2; [%expect {| ((t "") (padded_left " ") (padded_right " ")) |}]; test "foo" ~len:2; [%expect {| ((t foo) (padded_left foo) (padded_right foo)) |}]; test "foo" ~len:3; [%expect {| ((t foo) (padded_left foo) (padded_right foo)) |}]; test "foo" ~len:10 ~char:'_'; [%expect {| ((t foo) (padded_left _______foo) (padded_right foo_______)) |}] ;; let%test_module "functions that raise Not_found_s" = (module struct let show f sexp_of_ok = print_s [%sexp (Result.try_with f : (ok, exn) Result.t)] let%expect_test "index_exn" = let test s = show (fun () -> index_exn s ':') [%sexp_of: int] in test ""; [%expect {| (Error (Not_found_s "String.index_exn: not found")) |}]; test "abc"; [%expect {| (Error (Not_found_s "String.index_exn: not found")) |}]; test ":abc"; [%expect {| (Ok 0) |}]; test "abc:"; [%expect {| (Ok 3) |}]; test "ab:cd:ef"; [%expect {| (Ok 2) |}] ;; let%expect_test "index_from_exn" = let test_at s i = show (fun () -> index_from_exn s i ':') [%sexp_of: int] in let test s = for i = 0 to length s do test_at s i done in test ""; [%expect {| (Error (Not_found_s "String.index_from_exn: not found")) |}]; test "abc"; [%expect {| (Error (Not_found_s "String.index_from_exn: not found")) (Error (Not_found_s "String.index_from_exn: not found")) (Error (Not_found_s "String.index_from_exn: not found")) (Error (Not_found_s "String.index_from_exn: not found")) |}]; test "a:b:c"; [%expect {| (Ok 1) (Ok 1) (Ok 3) (Ok 3) (Error (Not_found_s "String.index_from_exn: not found")) (Error (Not_found_s "String.index_from_exn: not found")) |}]; let test_bounds s = test_at s (-1); test_at s (length s + 1) in test_bounds "abc"; [%expect {| (Error (Invalid_argument String.index_from_exn)) (Error (Invalid_argument String.index_from_exn)) |}] ;; let%expect_test "rindex_exn" = let test s = show (fun () -> rindex_exn s ':') [%sexp_of: int] in test ""; [%expect {| (Error (Not_found_s "String.rindex_exn: not found")) |}]; test "abc"; [%expect {| (Error (Not_found_s "String.rindex_exn: not found")) |}]; test ":abc"; [%expect {| (Ok 0) |}]; test "abc:"; [%expect {| (Ok 3) |}]; test "ab:cd:ef"; [%expect {| (Ok 5) |}] ;; let%expect_test "rindex_from_exn" = let test_at s i = show (fun () -> rindex_from_exn s i ':') [%sexp_of: int] in let test s = for i = length s - 1 downto -1 do test_at s i done in test ""; [%expect {| (Error (Not_found_s "String.rindex_from_exn: not found")) |}]; test "abc"; [%expect {| (Error (Not_found_s "String.rindex_from_exn: not found")) (Error (Not_found_s "String.rindex_from_exn: not found")) (Error (Not_found_s "String.rindex_from_exn: not found")) (Error (Not_found_s "String.rindex_from_exn: not found")) |}]; test "a:b:c"; [%expect {| (Ok 3) (Ok 3) (Ok 1) (Ok 1) (Error (Not_found_s "String.rindex_from_exn: not found")) (Error (Not_found_s "String.rindex_from_exn: not found")) |}]; let test_bounds s = test_at s (-2); test_at s (length s) in test_bounds "abc"; [%expect {| (Error (Invalid_argument String.rindex_from_exn)) (Error (Invalid_argument String.rindex_from_exn)) |}] ;; let%expect_test "lsplit2_exn" = let test s = let option_result = lsplit2 s ~on:':' in let exn_result = Or_error.try_with (fun () -> lsplit2_exn s ~on:':') in require_equal [%here] (module struct type t = (string * string) option [@@deriving equal, sexp_of] end) option_result (Or_error.ok exn_result); print_s [%sexp (exn_result : (string * string) Or_error.t)] in test ""; [%expect {| (Error (Not_found_s "String.lsplit2_exn: not found")) |}]; test "abc"; [%expect {| (Error (Not_found_s "String.lsplit2_exn: not found")) |}]; test ":abc"; [%expect {| (Ok ("" abc)) |}]; test "abc:"; [%expect {| (Ok (abc "")) |}]; test "ab:cd:ef"; [%expect {| (Ok (ab cd:ef)) |}] ;; let%expect_test "rsplit2_exn" = let test s = let option_result = rsplit2 s ~on:':' in let exn_result = Or_error.try_with (fun () -> rsplit2_exn s ~on:':') in require_equal [%here] (module struct type t = (string * string) option [@@deriving equal, sexp_of] end) option_result (Or_error.ok exn_result); print_s [%sexp (exn_result : (string * string) Or_error.t)] in test ""; [%expect {| (Error (Not_found_s "String.rsplit2_exn: not found")) |}]; test "abc"; [%expect {| (Error (Not_found_s "String.rsplit2_exn: not found")) |}]; test ":abc"; [%expect {| (Ok ("" abc)) |}]; test "abc:"; [%expect {| (Ok (abc "")) |}]; test "ab:cd:ef"; [%expect {| (Ok (ab:cd ef)) |}] ;; end) ;; let%test_module "Escaping" = (module struct open Escaping let%test_module "escape_gen" = (module struct let escape = unstage (escape_gen_exn ~escapeworthy_map:[ '%', 'p'; '^', 'c' ] ~escape_char:'_') ;; let%test _ = escape "" = "" let%test _ = escape "foo" = "foo" let%test _ = escape "_" = "__" let%test _ = escape "foo%bar" = "foo_pbar" let%test _ = escape "^foo%" = "_cfoo_p" let escape2 = unstage (escape_gen_exn ~escapeworthy_map:[ '_', '.'; '%', 'p'; '^', 'c' ] ~escape_char:'_') ;; let%test _ = escape2 "_." = "_.." let%test _ = escape2 "_" = "_." let%test _ = escape2 "foo%_bar" = "foo_p_.bar" let%test _ = escape2 "_foo%" = "_.foo_p" let checks_for_one_to_one escapeworthy_map = Exn.does_raise (fun () -> escape_gen_exn ~escapeworthy_map ~escape_char:'_') ;; let%test _ = checks_for_one_to_one [ '%', 'p'; '^', 'c'; '$', 'c' ] let%test _ = checks_for_one_to_one [ '%', 'p'; '^', 'c'; '%', 'd' ] end) ;; let%test_module "unescape_gen" = (module struct let unescape = unstage (unescape_gen_exn ~escapeworthy_map:[ '%', 'p'; '^', 'c' ] ~escape_char:'_') ;; let%test _ = unescape "__" = "_" let%test _ = unescape "foo" = "foo" let%test _ = unescape "__" = "_" let%test _ = unescape "foo_pbar" = "foo%bar" let%test _ = unescape "_cfoo_p" = "^foo%" let unescape2 = unstage (unescape_gen_exn ~escapeworthy_map:[ '_', '.'; '%', 'p'; '^', 'c' ] ~escape_char:'_') ;; (* this one is ill-formed, just ignore the escape_char without escaped char *) let%test _ = unescape2 "_" = "" let%test _ = unescape2 "a_" = "a" let%test _ = unescape2 "__" = "_" let%test _ = unescape2 "_.." = "_." let%test _ = unescape2 "_." = "_" let%test _ = unescape2 "foo_p_.bar" = "foo%_bar" let%test _ = unescape2 "_.foo_p" = "_foo%" (* generate [n] random string and check if escaping and unescaping are consistent *) let random_test ~escapeworthy_map ~escape_char n = let escape = unstage (escape_gen_exn ~escapeworthy_map ~escape_char) in let unescape = unstage (unescape_gen_exn ~escapeworthy_map ~escape_char) in let test str = let escaped = escape str in let unescaped = unescape escaped in if str <> unescaped then failwith (Printf.sprintf "string: %s\nescaped string: %s\nunescaped string: %s" str escaped unescaped) in let random_char = let print_chars = List.range (Char.to_int Char.min_value) (Char.to_int Char.max_value + 1) |> List.filter_map ~f:Char.of_int |> List.filter ~f:Char.is_print |> Array.of_list in fun () -> Array.random_element_exn print_chars in let escapeworthy_chars = List.map escapeworthy_map ~f:fst |> Array.of_list in try for _ = 0 to n - 1 do let str = List.init (Random.int 50) ~f:(fun _ -> let p = Random.int 100 in if Int.(p < 10) then escape_char else if Int.(p < 25) then Array.random_element_exn escapeworthy_chars else random_char ()) |> of_char_list in test str done; true with | e -> raise e ;; let%test _ = random_test 1000 ~escapeworthy_map:[ '%', 'p'; '^', 'c' ] ~escape_char:'_' ;; let%test _ = random_test 1000 ~escapeworthy_map:[ '_', '.'; '%', 'p'; '^', 'c' ] ~escape_char:'_' ;; end) ;; let%test_module "escape" = (module struct let escape = unstage (escape ~escape_char:'_' ~escapeworthy:[ '_'; '%'; '^' ]) let%test _ = escape "foo" = "foo" let%test _ = escape "_" = "__" let%test _ = escape "foo%bar" = "foo_%bar" let%test _ = escape "^foo%" = "_^foo_%" end) ;; let%test_module "unescape" = (module struct let unescape = unstage (unescape ~escape_char:'_') let%test _ = unescape "foo" = "foo" let%test _ = unescape "__" = "_" let%test _ = unescape "foo_%bar" = "foo%bar" let%test _ = unescape "_^foo_%" = "^foo%" end) ;; let%test_module "is_char_escaping" = (module struct let is = is_char_escaping ~escape_char:'_' let%test_unit _ = [%test_result: bool] (is "___" 0) ~expect:true let%test_unit _ = [%test_result: bool] (is "___" 1) ~expect:false let%test_unit _ = [%test_result: bool] (is "___" 2) ~expect:true (* considered escaping, though there's nothing to escape *) let%test_unit _ = [%test_result: bool] (is "a_b__c" 0) ~expect:false let%test_unit _ = [%test_result: bool] (is "a_b__c" 1) ~expect:true let%test_unit _ = [%test_result: bool] (is "a_b__c" 2) ~expect:false let%test_unit _ = [%test_result: bool] (is "a_b__c" 3) ~expect:true let%test_unit _ = [%test_result: bool] (is "a_b__c" 4) ~expect:false let%test_unit _ = [%test_result: bool] (is "a_b__c" 5) ~expect:false end) ;; let%test_module "is_char_escaped" = (module struct let is = is_char_escaped ~escape_char:'_' let%test_unit _ = [%test_result: bool] (is "___" 2) ~expect:false let%test_unit _ = [%test_result: bool] (is "x" 0) ~expect:false let%test_unit _ = [%test_result: bool] (is "_x" 1) ~expect:true let%test_unit _ = [%test_result: bool] (is "sadflkas____sfff" 12) ~expect:false let%test_unit _ = [%test_result: bool] (is "s_____s" 6) ~expect:true end) ;; let%test_module "is_char_literal" = (module struct let is_char_literal = is_char_literal ~escape_char:'_' let%test_unit _ = [%test_result: bool] (is_char_literal "123456" 4) ~expect:true let%test_unit _ = [%test_result: bool] (is_char_literal "12345_6" 6) ~expect:false let%test_unit _ = [%test_result: bool] (is_char_literal "12345_6" 5) ~expect:false let%test_unit _ = [%test_result: bool] (is_char_literal "123__456" 4) ~expect:false ;; let%test_unit _ = [%test_result: bool] (is_char_literal "123456__" 7) ~expect:false ;; let%test_unit _ = [%test_result: bool] (is_char_literal "__123456" 1) ~expect:false ;; let%test_unit _ = [%test_result: bool] (is_char_literal "__123456" 0) ~expect:false ;; let%test_unit _ = [%test_result: bool] (is_char_literal "__123456" 2) ~expect:true end) ;; let%test_module "index_from" = (module struct let f = index_from ~escape_char:'_' let%test_unit _ = [%test_result: int option] (f "__" 0 '_') ~expect:None let%test_unit _ = [%test_result: int option] (f "_.." 0 '.') ~expect:(Some 2) let%test_unit _ = [%test_result: int option] (f "1273456_7789" 3 '7') ~expect:(Some 9) ;; let%test_unit _ = [%test_result: int option] (f "1273_7456_7789" 3 '7') ~expect:(Some 11) ;; let%test_unit _ = [%test_result: int option] (f "1273_7456_7789" 3 'z') ~expect:None ;; end) ;; let%test_module "rindex" = (module struct let f = rindex_from ~escape_char:'_' let%test_unit _ = [%test_result: int option] (f "__" 0 '_') ~expect:None let%test_unit _ = [%test_result: int option] (f "123456_37839" 9 '3') ~expect:(Some 2) ;; let%test_unit _ = [%test_result: int option] (f "123_2321" 6 '2') ~expect:(Some 6) let%test_unit _ = [%test_result: int option] (f "123_2321" 5 '2') ~expect:(Some 1) let%test_unit _ = [%test_result: int option] (rindex "" ~escape_char:'_' 'x') ~expect:None ;; let%test_unit _ = [%test_result: int option] (rindex "a_a" ~escape_char:'_' 'a') ~expect:(Some 0) ;; end) ;; let%test_module "split" = (module struct let split = split ~escape_char:'_' ~on:',' let%test_unit _ = [%test_result: string list] (split "foo,bar,baz") ~expect:[ "foo"; "bar"; "baz" ] ;; let%test_unit _ = [%test_result: string list] (split "foo_,bar,baz") ~expect:[ "foo_,bar"; "baz" ] ;; let%test_unit _ = [%test_result: string list] (split "foo_,bar_,baz") ~expect:[ "foo_,bar_,baz" ] ;; let%test_unit _ = [%test_result: string list] (split "foo__,bar,baz") ~expect:[ "foo__"; "bar"; "baz" ] ;; let%test_unit _ = [%test_result: string list] (split "foo,bar,baz_,") ~expect:[ "foo"; "bar"; "baz_," ] ;; let%test_unit _ = [%test_result: string list] (split "foo,bar_,baz_,,") ~expect:[ "foo"; "bar_,baz_,"; "" ] ;; end) ;; let%test_module "split_on_chars" = (module struct let split = split_on_chars ~escape_char:'_' ~on:[ ','; ':' ] let%test_unit _ = [%test_result: string list] (split "foo,bar:baz") ~expect:[ "foo"; "bar"; "baz" ] ;; let%test_unit _ = [%test_result: string list] (split "foo_,bar,baz") ~expect:[ "foo_,bar"; "baz" ] ;; let%test_unit _ = [%test_result: string list] (split "foo_:bar_,baz") ~expect:[ "foo_:bar_,baz" ] ;; let%test_unit _ = [%test_result: string list] (split "foo,bar,baz_,") ~expect:[ "foo"; "bar"; "baz_," ] ;; let%test_unit _ = [%test_result: string list] (split "foo:bar_,baz_,,") ~expect:[ "foo"; "bar_,baz_,"; "" ] ;; end) ;; let%test_module "split2" = (module struct let escape_char = '_' let on = ',' let%test_unit _ = [%test_result: (string * string) option] (lsplit2 ~escape_char ~on "foo_,bar,baz_,0") ~expect:(Some ("foo_,bar", "baz_,0")) ;; let%test_unit _ = [%test_result: (string * string) option] (rsplit2 ~escape_char ~on "foo_,bar,baz_,0") ~expect:(Some ("foo_,bar", "baz_,0")) ;; let%test_unit _ = [%test_result: string * string] (lsplit2_exn ~escape_char ~on "foo_,bar,baz_,0") ~expect:("foo_,bar", "baz_,0") ;; let%test_unit _ = [%test_result: string * string] (rsplit2_exn ~escape_char ~on "foo_,bar,baz_,0") ~expect:("foo_,bar", "baz_,0") ;; let%test_unit _ = [%test_result: (string * string) option] (lsplit2 ~escape_char ~on "foo_,bar") ~expect:None ;; let%test_unit _ = [%test_result: (string * string) option] (rsplit2 ~escape_char ~on "foo_,bar") ~expect:None ;; let%test _ = Exn.does_raise (fun () -> lsplit2_exn ~escape_char ~on "foo_,bar") let%test _ = Exn.does_raise (fun () -> rsplit2_exn ~escape_char ~on "foo_,bar") end) ;; let%test _ = strip_literal ~escape_char:' ' " foo bar \n" = " foo bar \n" let%test _ = strip_literal ~escape_char:' ' " foo bar \n\n" = " foo bar \n" let%test _ = strip_literal ~escape_char:'\n' " foo bar \n" = "foo bar \n" let%test _ = lstrip_literal ~escape_char:' ' " foo bar \n\n" = " foo bar \n\n" let%test _ = rstrip_literal ~escape_char:' ' " foo bar \n\n" = " foo bar \n" let%test _ = lstrip_literal ~escape_char:'\n' " foo bar \n" = "foo bar \n" let%test _ = rstrip_literal ~escape_char:'\n' " foo bar \n" = " foo bar \n" let%test _ = strip_literal ~drop:Char.is_alpha ~escape_char:'\\' "foo boar" = " " let%test _ = strip_literal ~drop:Char.is_alpha ~escape_char:'\\' "fooboar" = "" let%test _ = strip_literal ~drop:Char.is_alpha ~escape_char:'o' "foo boar" = "oo boa" let%test _ = strip_literal ~drop:Char.is_alpha ~escape_char:'a' "foo boar" = " boar" let%test _ = strip_literal ~drop:Char.is_alpha ~escape_char:'b' "foo boar" = " bo" let%test _ = lstrip_literal ~drop:Char.is_alpha ~escape_char:'o' "foo boar" = "oo boar" ;; let%test _ = rstrip_literal ~drop:Char.is_alpha ~escape_char:'o' "foo boar" = "foo boa" ;; let%test _ = lstrip_literal ~drop:Char.is_alpha ~escape_char:'b' "foo boar" = " boar" let%test _ = rstrip_literal ~drop:Char.is_alpha ~escape_char:'b' "foo boar" = "foo bo" end) ;; base-0.16.3/test/test_string.mli000066400000000000000000000000551446274340700165550ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_type_equal.ml000066400000000000000000000031441446274340700172500ustar00rootroot00000000000000open! Import open! Type_equal let%expect_test "[Id.sexp_of_t]" = let id = Id.create ~name:"some-type-id" [%sexp_of: unit] in print_s [%sexp (id : _ Id.t)]; [%expect {| some-type-id |}] ;; let%test_module "Type_equal.Id" = (module struct open Type_equal.Id let t1 = create ~name:"t1" [%sexp_of: _] let t2 = create ~name:"t2" [%sexp_of: _] let%test _ = same t1 t1 let%test _ = not (same t1 t2) let%test _ = Option.is_some (same_witness t1 t1) let%test _ = Option.is_none (same_witness t1 t2) let%test_unit _ = ignore (same_witness_exn t1 t1 : (_, _) Type_equal.equal) let%test _ = Result.is_error (Result.try_with (fun () -> same_witness_exn t1 t2)) end) ;; (* This test shows that we need [conv] even though [Type_equal.T] is exposed. *) let%test_module "Type_equal" = (module struct open Type_equal let id = Id.create ~name:"int" [%sexp_of: int] module A : sig type t val id : t Id.t end = struct type t = int let id = id end module B : sig type t val id : t Id.t end = struct type t = int let id = id end let _a_to_b (a : A.t) = let eq = Id.same_witness_exn A.id B.id in (conv eq a : B.t) ;; (* the following is rejected by the compiler *) (* let _a_to_b (a : A.t) = * let T = Id.same_witness_exn A.id B.id in * (a : B.t) *) module C = struct type 'a t end module Liftc = Lift (C) let _ac_to_bc (ac : A.t C.t) = let eq = Liftc.lift (Id.same_witness_exn A.id B.id) in (conv eq ac : B.t C.t) ;; end) ;; base-0.16.3/test/test_type_equal.mli000066400000000000000000000000551446274340700174170ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_uchar.ml000066400000000000000000000076631446274340700162140ustar00rootroot00000000000000open! Import let min_int = Int.min_value let max_int = Int.max_value let raises f v = Exn.does_raise (fun () -> f v) let%test_module "test_constants" = (module struct let%test _ = Uchar.(to_scalar min_value) = 0x0000 let%test _ = Uchar.(to_scalar max_value) = 0x10FFFF end) ;; let%test_module "test_succ_exn" = (module struct let%test _ = raises Uchar.succ_exn Uchar.max_value let%test _ = Uchar.(to_scalar (succ_exn min_value)) = 0x0001 let%test _ = Uchar.(to_scalar (succ_exn (of_scalar_exn 0xD7FF))) = 0xE000 let%test _ = Uchar.(to_scalar (succ_exn (of_scalar_exn 0xE000))) = 0xE001 end) ;; let%test_module "test_pred_exn" = (module struct let%test _ = raises Uchar.pred_exn Uchar.min_value let%test _ = Uchar.(to_scalar (pred_exn (of_scalar_exn 0xD7FF))) = 0xD7FE let%test _ = Uchar.(to_scalar (pred_exn (of_scalar_exn 0xE000))) = 0xD7FF let%test _ = Uchar.(to_scalar (pred_exn max_value)) = 0x10FFFE end) ;; let%test_module "test_int_is_scalar" = (module struct let%test _ = not (Uchar.int_is_scalar (-1)) let%test _ = Uchar.int_is_scalar 0x0000 let%test _ = Uchar.int_is_scalar 0xD7FF let%test _ = not (Uchar.int_is_scalar 0xD800) let%test _ = not (Uchar.int_is_scalar 0xDFFF) let%test _ = Uchar.int_is_scalar 0xE000 let%test _ = Uchar.int_is_scalar 0x10FFFF let%test _ = not (Uchar.int_is_scalar 0x110000) let%test _ = not (Uchar.int_is_scalar min_int) let%test _ = not (Uchar.int_is_scalar max_int) end) ;; let char_max = Uchar.of_scalar_exn 0x00FF let%test_module "test_is_char" = (module struct let%test _ = Uchar.(is_char Uchar.min_value) let%test _ = Uchar.(is_char char_max) let%test _ = Uchar.(not (is_char (of_scalar_exn 0x0100))) let%test _ = not (Uchar.is_char Uchar.max_value) end) ;; let%test_module "test_of_char" = (module struct let%test _ = Uchar.(equal (of_char '\xFF') char_max) let%test _ = Uchar.(equal (of_char '\x00') min_value) end) ;; let%test_module "test_to_char_exn" = (module struct let%test _ = Char.equal Uchar.(to_char_exn min_value) '\x00' let%test _ = Char.equal Uchar.(to_char_exn char_max) '\xFF' let%test _ = raises Uchar.to_char_exn (Uchar.succ_exn char_max) let%test _ = raises Uchar.to_char_exn Uchar.max_value end) ;; let%test_module "test_equal" = (module struct let%test _ = Uchar.(equal min_value min_value) let%test _ = Uchar.(equal max_value max_value) let%test _ = not Uchar.(equal min_value max_value) end) ;; let%test_module "test_compare" = (module struct let%test _ = Uchar.(compare min_value min_value) = 0 let%test _ = Uchar.(compare max_value max_value) = 0 let%test _ = Uchar.(compare min_value max_value) = -1 let%test _ = Uchar.(compare max_value min_value) = 1 end) ;; let%expect_test "utf8_byte_length" = let test codepoint = let uchar = Uchar.of_scalar_exn codepoint in let utf8 = let buf = Buffer.create 4 in Uutf.Buffer.add_utf_8 buf uchar; Buffer.contents buf in let computed_byte_length = Uchar.utf8_byte_length uchar in if computed_byte_length <> String.length utf8 then print_cr [%here] [%message "utf8_byte_length does not match encoded string" (computed_byte_length : int) ~actual_byte_length:(String.length utf8 : int) (utf8 : string)] else print_s [%sexp (computed_byte_length : int)] in test (Char.to_int 'A'); [%expect {| 1 |}]; test (* Copyright symbol *) 0x00a9; [%expect {| 2 |}]; test (* Check mark *) 0x2713; [%expect {| 3 |}]; test (* Cuneiform Sign A *) 0x12000; [%expect {| 4 |}]; (* Sanity check: all of ASCII fits in one byte *) for i = 0 to 127 do let char = Char.of_int_exn i in require_equal [%here] (module Int) Uchar.(utf8_byte_length (of_char char)) 1 ~if_false_then_print_s:(lazy [%message "counterexample" (char : char)]) done; [%expect {| |}] ;; base-0.16.3/test/test_uchar.mli000066400000000000000000000000551446274340700163510ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_uniform_array.ml000066400000000000000000000074521446274340700177630ustar00rootroot00000000000000open! Import open Uniform_array let does_raise = Exn.does_raise let zero_obj = Stdlib.Obj.repr (0 : int) (* [create_obj_array] *) let%test_unit _ = let t = create_obj_array ~len:0 in assert (length t = 0) ;; (* [create] *) let%test_unit _ = let str = Stdlib.Obj.repr "foo" in let t = create ~len:2 str in assert (phys_equal (get t 0) str); assert (phys_equal (get t 1) str) ;; let%test_unit _ = let float = Stdlib.Obj.repr 3.5 in let t = create ~len:2 float in assert (Stdlib.Obj.tag (Stdlib.Obj.repr t) = 0); (* not a double array *) assert (phys_equal (get t 0) float); assert (phys_equal (get t 1) float); set t 1 (Stdlib.Obj.repr 4.); assert (Float.( = ) (Stdlib.Obj.obj (get t 1)) 4.) ;; (* [empty] *) let%test _ = length empty = 0 let%test _ = does_raise (fun () -> get empty 0) (* [singleton] *) let%test _ = length (singleton zero_obj) = 1 let%test _ = phys_equal (get (singleton zero_obj) 0) zero_obj let%test _ = does_raise (fun () -> get (singleton zero_obj) 1) let%test_unit _ = let f = 13. in let t = singleton (Stdlib.Obj.repr f) in invariant t; assert (Poly.equal (Stdlib.Obj.repr f) (get t 0)) ;; (* [get], [unsafe_get], [set], [unsafe_set], [unsafe_set_assuming_currently_int], [set_with_caml_modify] *) let%test_unit _ = let t = create_obj_array ~len:1 in assert (length t = 1); assert (phys_equal (get t 0) zero_obj); assert (phys_equal (unsafe_get t 0) zero_obj); let one_obj = Stdlib.Obj.repr (1 : int) in let check_get expect = assert (phys_equal (get t 0) expect); assert (phys_equal (unsafe_get t 0) expect) in set t 0 one_obj; check_get one_obj; unsafe_set t 0 zero_obj; check_get zero_obj; unsafe_set_assuming_currently_int t 0 one_obj; check_get one_obj; set_with_caml_modify t 0 zero_obj; check_get zero_obj ;; let%expect_test "exists" = let test arr f = of_list arr |> exists ~f in let r here = require_equal here (module Bool) in r [%here] false (test [] Fn.id); r [%here] true (test [ true ] Fn.id); r [%here] true (test [ false; false; false; false; true ] Fn.id); r [%here] true (test [ 0; 1; 2; 3; 4 ] (fun i -> i % 2 = 1)); r [%here] false (test [ 0; 2; 4; 6; 8 ] (fun i -> i % 2 = 1)); [%expect {| |}] ;; let%expect_test "for_all" = let test arr f = of_list arr |> for_all ~f in let r here = require_equal here (module Bool) in r [%here] true (test [] Fn.id); r [%here] true (test [ true ] Fn.id); r [%here] false (test [ false; false; false; false; true ] Fn.id); r [%here] false (test [ 0; 1; 2; 3; 4 ] (fun i -> i % 2 = 1)); r [%here] true (test [ 0; 2; 4; 6; 8 ] (fun i -> i % 2 = 0)); [%expect {| |}] ;; let%expect_test "iteri" = let test arr = of_list arr |> iteri ~f:(printf "(%d %c)") in test []; [%expect {| |}]; test [ 'a' ]; [%expect {| (0 a) |}]; test [ 'a'; 'b'; 'c'; 'd' ]; [%expect {| (0 a)(1 b)(2 c)(3 d) |}] ;; module Sequence = struct type nonrec 'a t = 'a t type 'a z = 'a let length = length let get = get let set = set let create_bool ~len = create ~len false end include Base_for_tests.Test_blit.Test1 (Sequence) (Uniform_array) let%expect_test "map2_exn" = let test a1 a2 f = let result = map2_exn ~f (of_list a1) (of_list a2) in print_s [%message (result : int Uniform_array.t)] in test [] [] (fun _ -> failwith "don't call me"); [%expect {| (result ()) |}]; test [ 1; 2; 3 ] [ 100; 200; 300 ] ( + ); [%expect {| (result (101 202 303)) |}]; require_does_raise [%here] (fun () -> test [ 1 ] [] (fun _ _ -> 0)); [%expect {| (Invalid_argument Array.map2_exn) |}] ;; let%expect_test "mapi" = let test arr = let mapped = of_list arr |> mapi ~f:(fun i str -> i, String.capitalize str) in print_s [%sexp (mapped : (int * string) t)] in test []; [%expect {| () |}]; test [ "foo"; "bar" ]; [%expect {| ((0 Foo) (1 Bar)) |}] ;; base-0.16.3/test/test_uniform_array.mli000066400000000000000000000000551446274340700201240ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_with_return.ml000066400000000000000000000034511446274340700174530ustar00rootroot00000000000000open! Import open! With_return let test_loop loop_limit jump_out = with_return (fun { return } -> for i = 0 to loop_limit do if i = jump_out then return (`Jumped_out i) done; `Normal) ;; let ( = ) = Poly.equal let%test _ = test_loop 5 10 = `Normal let%test _ = test_loop 10 5 = `Jumped_out 5 let%test _ = test_loop 5 5 = `Jumped_out 5 let test_nested outer inner = with_return (fun { return = return_outer } -> if outer = `Outer_jump then return_outer `Outer_jump; let inner_res = with_return (fun { return = return_inner } -> if inner = `Inner_jump_out_completely then return_outer `Inner_jump; if inner = `Inner_jump then return_inner `Inner_jump; `Inner_normal) in if outer = `Jump_with_inner then return_outer (`Outer_later_jump inner_res); `Outer_normal inner_res) ;; let%test _ = test_nested `Outer_jump `Inner_jump = `Outer_jump let%test _ = test_nested `Outer_jump `Inner_jump_out_completely = `Outer_jump let%test _ = test_nested `Outer_jump `Foo = `Outer_jump let%test _ = test_nested `Jump_with_inner `Inner_jump_out_completely = `Inner_jump let%test _ = test_nested `Jump_with_inner `Inner_jump = `Outer_later_jump `Inner_jump let%test _ = test_nested `Jump_with_inner `Foo = `Outer_later_jump `Inner_normal let%test _ = test_nested `Foo `Inner_jump_out_completely = `Inner_jump let%test _ = test_nested `Foo `Inner_jump = `Outer_normal `Inner_jump let%test _ = test_nested `Foo `Foo = `Outer_normal `Inner_normal let test_loop loop_limit jump_out = with_return_option (fun { return } -> for i = 0 to loop_limit do if i = jump_out then return (`Jumped_out i) done) ;; let ( = ) = Poly.equal let%test _ = test_loop 5 10 = None let%test _ = test_loop 10 5 = Some (`Jumped_out 5) let%test _ = test_loop 5 5 = Some (`Jumped_out 5) base-0.16.3/test/test_with_return.mli000066400000000000000000000000551446274340700176210ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base-0.16.3/test/test_word_size.ml000066400000000000000000000002661446274340700171070ustar00rootroot00000000000000open! Import open! Word_size let%expect_test _ = print_s [%message (W32 : t)]; [%expect {| (W32 W32) |}]; print_s [%message (W64 : t)]; [%expect {| (W64 W64) |}] ;; base-0.16.3/test/test_word_size.mli000066400000000000000000000000551446274340700172540ustar00rootroot00000000000000(*_ This signature is deliberately empty. *)