pax_global_header00006660000000000000000000000064141560115050014510gustar00rootroot0000000000000052 comment=0aa9bef74221af07bd5639a79b1b4738fa1427c3 batteries-included-3.4.0/000077500000000000000000000000001415601150500152635ustar00rootroot00000000000000batteries-included-3.4.0/.gitignore000066400000000000000000000005161415601150500172550ustar00rootroot00000000000000*~ _build build/META build/make_suite src/batteries_config.ml doc/batteries/html/api/ hdoc/* man/* *.byte *.native /.omake* *.swp *.opt *.run apidocs batteries.docdir batteries.odocl qtest/*_t.ml qtest/test_mods.mllib bench.log qtest/all_tests.ml qtest2/all_tests.ml qtest.targets.log setup.data setup.log src/batteries_compattest.ml batteries-included-3.4.0/.mailmap000066400000000000000000000041631415601150500167100ustar00rootroot00000000000000ben kuin ben le kuin Gabriel Scherer bluestorm Gabriel Scherer bluestorm Cedric Cellier Cedric Cellier Cedric Cellier Cedric Cellier Cedric Cellier cedric cellier Dawid Toton Dawid Toton Eric Norige Edgar Friendly Gabriel Scherer Gabriel Scherer Gabriel Scherer gasche Hezekiah M. Carty Hezekiah M. Carty Hezekiah M. Carty Hezekiah M. Carty Jérémie Dimino Jérémie Dimino Justus Matthiesen Justus Matthiesen Kaustuv Chaudhuri Kaustuv Chaudhuri Michael Ekstrand Michael D Ekstrand Michael Ekstrand Michael Ekstrand Philippe Veber pveber Philippe Veber Philippe Eric Norige thelema David Teller Yoric David Teller yoric David Teller Yoric David Teller David Teller Erkki Seppälä Erkki Seppala Erkki Seppälä Erkki Seppala Francois Berenger Francois Berenger Francois BERENGER batteries-included-3.4.0/.merlin000066400000000000000000000000231415601150500165450ustar00rootroot00000000000000S src B _build/src batteries-included-3.4.0/.travis.sh000066400000000000000000000014171415601150500172100ustar00rootroot00000000000000OPAM_DEPENDS="ocamlfind ounit qtest" case "$OCAML_VERSION" in 3.12.1.1.0) ppa=avsm/ocaml312+opam11 ;; 4.00.1.0.0) ppa=avsm/ocaml40+opam10 ;; 4.00.1.1.0) ppa=avsm/ocaml40+opam11 ;; 4.01.0.0.0) ppa=avsm/ocaml41+opam10 ;; 4.01.0.1.0) ppa=avsm/ppa ;; 4.0[234567].*) ppa= *) echo Unknown $OCAML_VERSION,$OPAM_VERSION; exit 1 ;; esac echo "yes" | sudo add-apt-repository ppa:$ppa sudo apt-get update -qq sudo apt-get install -qq opam export OPAMYES=1 export OPAMVERBOSE=1 opam init --compiler=$OCAML_VERSION eval `opam config env` echo "==== Installing $OPAM_DEPENDS ====" opam install ${OPAM_DEPENDS} echo "==== Build ====" make echo "==== Internal tests ====" make test-native echo "==== Install and use test ====" opam pin add -n -k path batteries . make test-build-from-install batteries-included-3.4.0/.travis.yml000066400000000000000000000010731415601150500173750ustar00rootroot00000000000000language: c script: bash -ex .travis.sh env: - OCAML_VERSION=3.12.1 - OCAML_VERSION=4.00.1 - OCAML_VERSION=4.01.0 - OCAML_VERSION=4.02.3 - OCAML_VERSION=4.03.0 - OCAML_VERSION=4.04.2 - OCAML_VERSION=4.05.0 - OCAML_VERSION=4.06.0 - OCAML_VERSION=4.07.0 - OCAML_VERSION=4.08.0 - OCAML_VERSION=4.09.0 - OCAML_VERSION=4.10.0 - OCAML_VERSION=4.11.0 - OCAML_VERSION=4.12.0 - OCAML_VERSION=4.12.0+domains # notifications: # email: # - simon.cruanes.2007+travis@m4x.org # - add other addresses here (or batteries-devel or something?) batteries-included-3.4.0/ChangeLog000066400000000000000000000567221415601150500170510ustar00rootroot00000000000000Changelog --------- ## NEXT_RELEASE - BatString.edit_distance: faster; unsafe array accesses #1061 (Francois Berenger) - BatBytes.{fold_left,fold_right,for_all,exists,starts_with,ends_with,split_on_char} #1050 Code from the stdlib introduced in OCaml-4.13.0. (Francois Berenger) - BatArray.{find_opt,fold_left_map,find_map,combine} #1047,#1046,#1048,#1049 Most code comes from the stdlib and was introduced in OCaml-4.13.0. (Francois Berenger) - BatSet.is_singleton: t -> bool #1042 (Francois Berenger, review by Gabriel Scherer) - fix a bug in Bashtbl.Make(T).of_{list,enum} #1038, #1039 (Gabriel Scherer, report by Johnny Bock Andersen) - BatList.ExceptionLess: added reduce, min, max and min_max Now, BatList.min and max also accept a ~cmp optional parameter; defaulting to Pervasives.compare. #1037 (Nicolas Tollenaere, review by Francois Berenger) - DynArray.remove_at alias for DynArray.delete #1033 (Florent Monnier, review by Francois Berenger) - Fix several deprecated warnings for "float" and "noalloc" #729 Since 4.03: [@@unboxed] and [@@noalloc] respectively (Thibault Suzanne, review by Francois Berenger) TODO ## v3.3.0 (minor release) - Several fixes for OCaml-4.12 #994, #992, (kit-ty-kate) - Support for ocaml-multicore in the Gc module #991 (kit-ty-kate, review by Gabriel Scherer) - Significant work preparing switch to dune #1025, #1024, #1023, #1022, #1021, #1020, #1019, #1017 (Gabriel Scherer, review by Francois Berenger) - Remove `-rectypes` from BatFingerTree and simpler implementation #1012 (Gabriel Scherer) - new BatEither module; available in all OCaml versions supported by batteries #1027 The implementation comes from the stdlib and is due to Gabriel Scherer. (Francois Berenger, review by Gabriel Scherer) - BatList.partition_map: ('a -> ('b, 'c) BatEither.t) -> 'a list -> 'b list * 'c list #1028 (Francois Berenger, review by Gabriel Scherer) - BatSet: added several missing methods for compatibility with stdlib. The implementation of filter, map and filter_map was adapted from stdlib, authors of the original implementation are Xavier Leroy, Albin Coquereau and Gabriel Scherer #1006, #1008 (Jakob Krainz, review by Gabriel Scherer) - BatSeq: compatibility with stdlib.Seq #1005, #1007 (Jakob Krainz, review by Gabriel Scherer) - BatMap, BatSplay: find_first, find_first_opt, find_last, find_last_opt, to_rev_seq For compatibility with the stdlib. The implementation in BatMap was adapted from stdlib; authors of the original implementation are Albin Coquereau and Gabriel de Perthuis. #1000, #1031 (Jakob Krainz, review by Gabriel Scherer) - BatArray.remove_at: int -> 'a array -> 'a array #996 For compatibility with BatList (Francois Berenger, review by Cedric Cellier) - BatDynArray: several new functions BatDynArray now exposes almost the same functionalities as BatArray #872 (andrepd, review by Florent Monnier and Francois Berenger) - BatDynArray: uniformization of exceptions and more documentation #988 (Florent Monnier, review by Francois Berenger) - BatDynArray: user input checks in left, right, tail #987 (Florent Monnier, review by Francois Berenger) - Fix stack overflow on Int32/64.pow with negative exponent (issue #989) #990 (Cedric Cellier, review by Francois Berenger) - BatList.unfold_exn is an alias for unfold_exc. BatRefList.find_exn is an alias for find_exc. #978 (Cedric Cellier, review by Francois Berenger) ## v3.2.0 (minor release) - BatArray.fold_while: ('acc -> 'a -> bool) -> ('acc -> 'a -> 'acc) -> 'acc -> 'a array -> 'acc * int #974 (Francois Berenger, review by Cedric Cellier) - Support for OCaml 4.12 #980 (kit-ty-kate) - BatArray.fold is an alias for fold_left #976 (Francois Berenger) - BatList.fold is an alias for fold_left #975 (Francois Berenger) - BatArray.count_matching: ('a -> bool) -> 'a array -> int #972 (Francois Berenger) - BatList.count_matching: ('a -> bool) -> 'a list -> int #816 (Francois Berenger) - Provide an explicitly unthreaded package For Dune, provide an alternative batteries.unthreaded package #970 (Jerome Vouillon) - BatList.findi: correct documentation #967 (Francois Berenger) - BatOptParse.unprogify: bug fix (issue #965) '%prog' was replaced only once, now it is always replaced (in accordance with the documentation) #966 (Francois Berenger, report by OnkV) - Expose Map.remove_exn and Set.remove_exn: 'a -> 'a t -> 'a t #954 (Cedric Cellier) ## v3.1.0 (minor release) This minor release adds support for OCaml 4.11. - Compatibility fixes for OCaml-4.11 #962 (Jerome Vouillon) - BatEnum: added combination #518 (Chimrod, review by hcarty) - fix benchmarks #956 (Cedric Cellier) - BatFile: added count_lines #953 (Francois Berenger, review by Cedric Cellier) - BatArray: use unsafe_get and unsafe_set more often #947 (Francois Berenger, review by Cedric Cellier) - fix some tests for ocaml-4.10.0 #944 (kit-ty-kate) - BatResult: BatPervasives.result is now equal to Stdlib.result instead of sharing constructors without being the same type #939, #957 (Clément Busschaert, Cedric Cellier). ## v3.0.0 (major release) - added BatSplay.find_opt and BatMap.find_opt #941 (nicoTolly, review by Francois Berenger) - BatList and BatArray: sum of an empty container now return 0 rather than raising an exception. #519 (Cedric Cellier, report by Simon Cruanes, review by François Berenger) - BatString: split_on_char and nsplit now return a sigle empty string (rather than an empty list) on empty strings. #845, #846 (Cedric Cellier, report by Thibault Suzanne, review by François Berenger) - BatSeq: change Exceptionless.combine signature to make it really exceptionless. #418 (Cedric Cellier, report by Hezekiah M. Carty, review by François Berenger) - BatOo: This module was unwelcomed and has been removed #848 (Cedric Cellier, report by Max Mouratov, review by François Berenger) - BatFilename: Added to Batteries from the stdlib, with the addition of split_extension. #445 (Cedric Cellier, report and review by François Berenger) - BatSet: the Infix module is no more, as it was incompatible with metaocaml #908 (Cedric Cellier, review by Gabriel Scherer and François Berenger) - BatIO: make the ?cleanup parameter of BatIO.input_channel true by default: closing the returned input will close the underlying input channel #109, #489 (Simon Cruanes, report by Michael Ekstrand) - BatArray: add split : 'a BatOrd.ord -> 'a array -> 'a -> int * int search for the range equal to a given element in a sorted array #443, #470 (Simon Cruanes, Gabriel Scherer, request by François Berenger) - BatEnum: BatEnum.combine is now curried, just like List.combine, its signature changes from: val combine: 'a t * 'b t -> ('a * 'b) t to val combine: 'a t -> 'b t -> ('a * 'b) t #578 (François Berenger) - PSet: add a ?cmp argument to every function that creates a PSet: of_enum, of_list, of_array are changed. The default value is Pervasives.compare. #679 (Cedric Cellier) ## v2.11.0 (minor release) This minor release fixes a few bugs or interface mismatch with OCaml stdlib, and is compatible with BER MetaOCaml. This is the last planned release of the v2 series. Next planned release (v3.0.0) will introduce some API changes. Notable changes: - Add Unix.with_locked_file #904 (Simon Cruanes, Cedric Cellier, review by Francois Berenger) - Build with -strict-sequence #927 (Armaël Guéneau, review by Francois Berenger) - Add Legacy.Result for OCaml >= 4.8.0 #913 (Cedric Cellier, review by Francois Berenger) - Remove BatOo #915 (Cedric Cellier, review by Francois Berenger) - Add BatFilename #910 (Cedric Cellier, review by Francois Berenger) - Make batteries usable with BER MetaOCaml #909 (Cedric Cellier, review by Francois Berenger and Gabriel Scherer) - Unix.sleepf is provided across all OCaml versions; previously it was only for OCaml >= 4.03.0 #930 (Francois Berenger, review by Cedric Cellier) ## v2.10.0 (minor release) This minor release adds support for OCaml 4.08.0. This release is compatible with OCaml 4.08.0, but it is not complete with respect to the standard library of OCaml 4.08.0: this release saw a lot of changes to the standard library, which have not yet been made available in the corresponding Batteries module. This means that users of OCaml 4.08.0 (and Batteries 2.10.0) will have access to these functions, but users of older OCaml versions (and Batteries 2.10.0) will not. If you are looking for this kind of backward-compatibility of new functions, as provided by previous Batteries releases, we recommend trying the 'stdcompat' library. - added LazyList.equal: ('a -> 'b -> bool) -> 'a t -> 'b t -> bool #811 (Marshall Abrams, review by Gabriel Scherer) - added BatList.fold_while : ('acc -> 'a -> bool) -> ('acc -> 'a -> 'acc) -> 'acc -> 'a list -> 'acc * 'a list #889 (Francois Berenger, Thibault Suzanne) - fix `BatNum.of_float_string` on inputs between -1 and 0: "-0.5" or "-.5" would be interpreted as "0.5" or ".5". #886, #887 (Gabriel Scherer, report by Marcel Hark) - added BatHashtbl.merge and merge_all #891 (Cedric Cellier, Francois Berenger, Gabriel Scherer) - added Unix.with_locked_file #904 (Cedric Cellier, Francois Berenger) ## v2.9.0 (minor release) This minor release adds support for OCaml 4.07.0, as well as a certain number of fixes, improvements and documentation clarification from our contributors. Thanks in particular to Max Mouratov for his varied contributions. This release is compatible with OCaml 4.07.0, but it is not complete with respect to the standard library of OCaml 4.07.0: this release saw a lot of changes to the standard library, which have not yet been made available in the corresponding Batteries module. This means that users of OCaml 4.07.0 (and Batteries 2.9.0) will have access to these functions, but users of older OCaml versions (and Batteries 2.9.0) will not. If you are looking for this kind of backward-compatibility of new functions, as provided by previous Batteries releases, we recommend trying the new 'stdcompat' library by Thierry Martinez: https://github.com/thierry-martinez/stdcompat Full changelog: - add `BatString.cut_on_char : char -> int -> string -> string` (Kahina Fekir, Thibault Suzanne, request by François Bérenger) #807, #856 - add `BatString.index_after_n : char -> int -> string -> int` (Kahina Fekir) - faster BatArray.partition #829 (Francois Berenger, Gabriel Scherer) - add `BatArray.split: ('a * 'b) array -> 'a array * 'b array` #826 (Francois Berenger) - add `BatString.count_string: string -> string -> int` #799 (Francois Berenger) - Int: optimized implementation of Safe_int.mul #808, #851 (Max Mouratov) - Fix: in case of conflicted bindings, [Map.union m1 m2] should prefer the value from [m2], as stated in documentation. #814 (Max Mouratov) - Fix: [Map.update k1 k2 v m] did not work correctly when [k1 = k2]. #833 (Max Mouratov) - Fix: [Map.update k1 k2 v m] should throw [Not_found] if [k1] is not bound in [m], as stated in documentation. #833 (Max Mouratov) - Fix: [Set.update x y s] should throw [Not_found] if [x] is not in [s], as stated in documentation. #833 (Max Mouratov) - Fix: documentation of BatList.{hd,last} to match implementation w.r.t raised exceptions #840, #754 (FkHina) - Fix: [Array.insert] should throw a more relevant message on invalid indices instead of the generic [invalid_arg "index out of bounds]. The assertion is now documented. #841 (Max Mouratov) - Implementation of [Array.insert] now uses [unsafe_get] and [unsafe_set]. #841 (Max Mouratov) - Fix documentation of [String.right]. #849, #844 (Max Mouratov, reported by Thibault Suzanne) - Fix: [Heap.del_min] should throw [Invalid_argument] with the specified "del_min" message instead of "find_min_tree". #850 (Max Mouratov) - More uniform and correct [Invalid_argument] messages. #850 (Max Mouratov) - Optimization of List.unique_cmp (using Set instead of Map). #852 (Max Mouratov) - Documentation of List.append and List.concat should not include invalid estimates of stack usage. #854 (Max Mouratov) - Implementation of String should use unsafe versions of [set] and [get]. #836 (Max Mouratov, review by Gabriel Scherer) - Fix erroneous mentions of [Different_list_size] in List.mli. #857, #744 (Max Mouratov, reported by Christoph Höger) - fix Map.equal (for polymorphic maps) with custom equality function #865 (Ralf Vogler) - ocamlfind plugin support in META file (Arlen Cox) #867 ## v2.8.0 (minor release) This minor release supports the -safe-string mode for OCaml compilation, enforcing a type-level separation between (immutable) strings and mutable byte sequences. - support -safe-string compilation #673 (Gabriel Scherer) - Support for the upcoming OCaml release 4.06 (Gabriel Scherer) ## v2.7.0 (minor release) This minor release is the first to support OCaml 4.05.0. As with previous OCaml versions, we backported new 4.05.0 convenience function from the compiler stdlib, allowing Batteries user to use them with older OCaml versions, and thus write backward-compatible code. In particular, the new *_opt functions returning option values instead of exceptions are all backported. - BatNum: fix of_float_string to handle negative numbers properly #780 (Anton Yabchinskiy) - added BatArray.min_max #757 (Francois Berenger) - added a Label module to BatVect #763 (Varun Gandhi, review by Francois Berenger, Gabriel Scherer, Thibault Suzanne) - fix documentation of BatVect.insert to match (correct) implementation #766, #767 (Gabriel Scherer, report by Varun Gandhi) - avoid using exceptions for internal control-flow #768, #769 This purely internal change should improve performances when using js_of_ocaml, which generates much slower code for local exceptions raising/catching than the native OCaml backend. Internal exceptions (trough the BatReturn label) have been removed from the modules BatString, BatSubstring and BatVect. (Gabriel Scherer, request and review by Clément Pit-Claudel) - added `BatVect.find_opt : ('a -> bool) -> 'a t -> 'a option` and BatVect.Make.find_opt #769 (Gabriel Scherer) - Documents exceptions for List.(min, max) #770 (Varun Gandhi) - BatText: bugfixes in `rindex{,_from}` and `rcontains_from` #775 (Gabriel Scherer) - Support for the new OCaml release 4.05 the `*_opt` functions and List.compare_lengths, compare_length_with are also backported to older OCaml releases, so code using them from Batteries should be backwards-compatible #777, #779 (Tej Chajed, Gabriel Scherer) ## v2.6.0 (minor release) - added Bat{Set,Map,Splay}.any and fixed Bat{Map,Splay}.choose #751 (Cedric Cellier) - added BatList.favg and faster BatList.fsum #746 (Gabriel Scherer, Francois Berenger) - install .cmt and .cmti files #740 (Francois Berenger, Gabriel Scherer) - BatMap: added find_default #730 (Francois Berenger) - added scripts/test_install.sh #743 (Francois Berenger) - BatHashtbl: added {to|of}_list, bindings #728 (Francois Berenger, Thibault Suzanne) - added {BatList|BatArray}.shuffle #702, #707 (Francois Berenger, Gabriel Scherer) - Clarification and improvements to the documentation #682, #685, #693 (Florian Angeletti, Johannes Kloos, Michael Färber) - make `LazyList.split_at` lazy: `split_at : int -> 'a t -> 'a t * 'a t` would previously eagerly force the prefix of the list and only be lazy in its second returned value. #694 (Michael Färber, Gabriel Scherer, Thibault Suzanne) - Add `List.{map2i,iter2i}` #696 (Thibault Suzanne) - Added `Result.{map,map_both}` #705 (Ifaz Kabir) - Add {BatSet,BatMap}.{Int,Int32,Int64,Nativeint,Float,Char,String} as common instantions of the respective `Make` functor. #709, #712 (Thibault Suzanne, François Bérenger) - BatString: add `chop : ?l:int -> ?r:int -> string -> string` #714, #716 (Gabriel Scherer, request by François Bérenger) - BatSet: make `to_array` allocate the resulting array at first instead of using Dynarray (faster, uses less memory). #724 (Thibault Suzanne) - BatList: add `fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list` #734 (Thibault Suzanne, review by Gabriel Scherer, request by Oscar Gauthier) - add ``BatList.frange : float -> [< `To | `Downto ] -> float -> int -> float list`` ``frange 0. `To 1. 3`` is `[0.; 0.5; 1.]`. #745 (François Bérenger) ## v2.5.3 Batteries 2.5.3 synchronizes library functions with OCaml 4.04+beta2, and will hopefully be an extension of the upcoming OCaml 4.04 release. - Compatibility with OCaml 4.04. 5e63a9a756f (Gabriel Scherer) ## v2.5.1, v2.5.2 Batteries 2.5.1 and 2.5.2 fix a silly packaging bug in Batteries 2.5.0. ## v2.5.0 Batteries 2.5.0 is a minor release whose main change is that it is compatible with the newly released OCaml 4.03. Note that Batteries 2.5.0 is compatible with older OCaml releases as well, and provides back-ported versions of most standard library functions made available in 4.03 only. For example, BatString.uppercase_ascii is usable under all OCaml versions. If the documentation of a Batteries function says @since 2.5.0 then it is available under all supported OCaml version (3.12.1 and up). If it says @since 2.5.0 and OCaml 4.03.0 then it is only available under OCaml 4.03.0. - BatTuple: add Tuple{N}.make : 'a1 -> ... -> 'an -> 'a1 * ... * 'an #657 (Thibault Suzanne) - BatBig_int: fix sequence operators (--), (---) to avoid polymorphic comparison #674, #675, #676 (Pieter Goetschalckx and Cedric Cellier) - Extend all Batteries module to cover OCaml 4.03 features #670 (Gabriel Scherer, KC Sivaramakrishnan) ## v2.4.0 - BatBitSet: use Bytes instead of String (Gabriel Scherer) - BatHashtbl: fix hash computation bug introduced by 4.01 (issue #609) (Gabriel Scherer, report by Martin Neuhäußer) - BatText: synchronize nsplit to match BatString.nsplit (Gabriel Scherer) - BatLazyList: fix remove_all_such documentation (Xavier Van de Woestyne) - BatMap: add pop_min_binding: 'a t -> (key * 'a) * 'a t and pop_max_binding: 'a t -> (key * 'a) * 'a t (Francois Berenger) - BatMap: add at_rank_exn: int -> ('key, 'a) t -> ('key * 'a) and update: key -> key -> 'a -> 'a t -> 'a t (Francois Berenger) - BatEnum: add interleave: 'a t array -> 'a t (Aleksey Z. Arens) - BatFormat: expose asprintf for V>=4.01 (Ralf Vogler) - BatSet: add at_rank_exn: int -> t -> elt and update: elt -> elt -> t -> t (Francois Berenger) - BatUTF8: add enum: t -> BatUChar.t BatEnum.t (Kevin Brubeck Unhammer) - BatSet: add to_array: t -> elt array and of_array: elt array -> t and test for to_list (Francois Berenger) - BatSet: add pop_max: 'a t -> 'a * 'a t and pop_min: 'a t -> 'a * 'a t (Francois Berenger) - BatSplay: hardened against read-only-data compiler optimization (Gabriel Scherer) - BatList: simplified interleave implementation (Francois Berenger) - BatOption: add Infix.(>>=): 'a option -> ('a -> 'b option) -> 'b option (Herry Herry) - BatHashtbl: modify now have same semantics than replace for the key (Anders Fugmann) - BatHashtbl: more efficient modify_opt and modify_def (Anders Fugmann) - BatFormat: add pp_print_list: ?pp_sep:(formatter -> unit -> unit) -> (formatter -> 'a -> unit) -> (formatter -> 'a list -> unit) and pp_print_text: formatter -> string -> unit (Christoph Höger) - BatEnum: add uniq_by: ('a -> 'a -> bool) -> 'a t -> 'a t and uniqq: 'a t -> 'a t (Max Mouratov) - BatEnum: fix uniq to use structural comparison (Max Mouratov) - BatUnix: add run_and_read: string -> process_status * string (Francois Berenger) - BatCache: use hashmap to speed up lru_cache (Sang Kil Cha) - BatQueue: add filter: ('a -> bool) -> 'a t -> 'a t and filter_inplace: ('a -> bool) -> 'a t -> unit and filter_map: ('a -> 'b option) -> 'a t -> 'b t (Gabriel Scherer) ## v2.3.0 - improved test coverage (Simon Cruanes and Xavier Van de Woestyne) - Enum: bugfix in clamp (Simon Cruanes) - Stream: add concat_map (Gabriel Radanne) - List: fix a stack-overflow bug in transpose (Gabriel Scherer) - List: add unfold_exc : (unit -> a) -> 'a list * exn (François Berenger) - List: add fold_righti and fold_lefti (François Berenger) - Substring : fix fold_left, add fold_lefti, fold_righti (Xavier Van de Woestyne) - String : add fold_lefti and fold_righti (Xavier Van de Woestyne) - Set.Make: add of_list (Jacques-Pascal Deplaix) - AvlTree: add (check : 'a tree -> bool) to check well-formedness (Simon Cruanes) - Hashtbl: make modify_opt/def resize the table to preserve amortized costs (Mads Hartmann, report by user 'jj-issuu') - Enum: fix combine's count in presence of infinite enums (Gabriel Scherer, report by user 'mwnx') - Makefile: add a qtest-byte target (Gabriel Scherer) - List: add modify_opt_at: int -> ('a -> 'a option) -> 'a list -> 'a list (Gabriel Scherer) - List: add modify_at: int -> ('a -> 'a) -> 'a list -> 'a list (Gabriel Scherer) - List: add remove_at: int -> 'a list -> 'a list (François Berenger) - Int: add copysign (Simon Cruanes) - Deque: add rotate_forward, rotate_backward : 'a dq -> 'a dq (Max Mouratov) - Int: fix overflow checking in Safe_int.mul (Max Mouratov, Christopher Zimmermann) - add a local OPAM description, allows to use opam pin add batteries git@github.com:ocaml-batteries-team/batteries-included.git (Vincent Bernardoff) - Queue: add map : ('a -> 'b) -> 'a t -> 'b t (Christopher Zimmermann) - compatibility with 4.02: + Printf: remove CamlinternalPr for OCaml versions >= 4.02 (Ralf Vogler) + Printf: legacy code assumed (string = fmt) (Gabriel Scherer) + new 4.02 functions: String.mapi (String.init was already in Batteries) List.sort_uniq (List.sort_unique existed before) Array.make_float (less efficient implementation provided for <4.02 versions) a BatBytes module relying on ocamlfind's compatibility module bytes-related functions in Buffer,Digest,Marshal,Printexc,Stream,Unix new Printexc callstack interface (not available for <4.02 versions) (Gabriel Scherer) ## v2.2.0 - cartesian product in batSet - Enum.concat_map alias - UChar.is_ascii - equality and enumeration (from, to UChar enum) in batText - String.find_all function - Seq.iteri, mapi, iter2, map2 (see issue #417) - cartesian product of enums (issue #442) - List.subset - Array.bsearch dichotomic search (issue #433) - Enum.print_at_most (issue #425) - BatOption.ord instance, (issue #393) - Fix infinite loop in BitSet - Levenshtein distance on strings - Seq.{of_list, equal} - basic .merlin file for merlin users - BatDeque.eq function to compare Deques by content - BatteriesExceptionless - More explicit overriding of ocamlbuild rules, use batteries.mllib - Add Kahan summation (numerically-accurate sum of floats) to List,Array,Enum - Add BatOption.some - (text) improve element indexing in BatList's mli documentation - Add BatList.filteri_map - Compatibility with ocaml 4.01 - Add BatList.filteri - Add Set.split_lt and split_le - Add split_opt wherever there is split - Add List.range - Add the new O_CLOEXEC flag to Unix.open_flag in version 4.01 - Fix BatMutex.DebugMutex.id is always 0. - Simplify List.partition code - Add List.ntake and List.takedrop - Added List.Acc.create and use it - Add a LazyList.eager_fold_right alias to LazyList.fold_right, with sane argument order - and many tests and documentation - cleanup of whitespace batteries-included-3.4.0/FAQ000066400000000000000000000041661415601150500156240ustar00rootroot00000000000000*** FAQ for Batteries Included *** *** Common Problems *** **** "Error: Unbound module Batteries" Check that you're using ocamlfind with `-package batteries`, or `pkg(batteries)` in OCamlBuild _tags file to tell OCaml to make Batteries available to your code. *** General *** **** What is OCaml Batteries **** OCaml Batteries Included: a community-maintained foundation library for your OCaml projecs. **** What is it good for **** Batteries Included serves the following purposes: * define a standard set of libraries which may be expected on every compliant installation of OCaml * organize these libraries into a hierarchy of modules, with one source of documentation * provide a consistent API for otherwise independent libraries. *** Installation *** **** Errors **** ERROR: omake: Symbol `FamErrlist' has different size in shared object, consider re-linking This error is caused when using Gamin rather than FAM. Gamin is a binary-compatible replacement for libfam that does not use the system-wide monitor daemon. Most packages, however, are compiled and linked against libfam from the FAM package. They will work with Gamin without recompilation, but display the symbol size discrepancy warning. This error can safely be ignored. If you really want to get rid of the warning, on an Ubuntu based OS, run the following command: sudo apt-get install libfam0 Note that FAM misbehaves in certain environments, notably AFS-based systems. *** Using Batteries *** In your source code, add [open Batteries]. When you've done this, you'll have access to the Batteries modules that extend stdlib modules as part of the stdlib modules. To access the original stdlib modules, use [Legacy.List], for example. Other [BatFoo] modules provided by batteries are available as simply [Foo]. **** Compiling with Ocamlbuild **** Copy build/myocamlbuild.ml into your source directory, and use: <*>: package(batteries) in your _tags file to enable batteries for all modules. **** Bare Findlib **** ocamlfind ocamlc -package batteries -linkpkg foo.ml -o foo **** OMake **** Add the following to your OMakefile: OCAMLPACKS[] += batteries batteries-included-3.4.0/LICENSE000066400000000000000000000617461415601150500163060ustar00rootroot00000000000000This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License (LGPL) as published by the Free Software Foundation; either version 2.1 of the License (see below), or (at your option) any later version. As a special exception to the GNU Lesser General Public License, you may link, statically or dynamically, a "work that uses the Library" with a publicly distributed version of the Library to produce an executable file containing portions of the Library, and distribute that executable file under terms of your choice, without any of the additional requirements listed in clause 6 of the GNU Lesser General Public License. By "a publicly distributed version of the Library", we mean either the unmodified Library as distributed, or a modified version of the Library that is distributed under the conditions defined in clause 2 of the GNU Lesser General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Lesser General Public License. ------------ GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS batteries-included-3.4.0/META.in000066400000000000000000000014351415601150500163440ustar00rootroot00000000000000name="batteries" version="@VERSION@" description="Batteries Included is a community-maintained standard library extension" requires ="batteries.unthreaded" requires(mt)+="threads" archive(toploop,mt)="batteriesThread.cma" archive(byte,mt) ="batteriesThread.cma" archive(native,mt) ="batteriesThread.cmxa" plugin(byte,mt) ="batteriesThread.cma" plugin(native,mt) ="batteriesThread.cmxs" package "unthreaded" ( version="@VERSION@" description="Batteries Included (for use in unthreaded programs)" requires ="unix,num,bigarray,str,bytes" archive(toploop) ="batteries.cma batteriesConfig.cmo batteriesHelp.cmo batteriesPrint.cmo" archive(byte) ="batteries.cma" archive(native) ="batteries.cmxa" plugin(byte) ="batteries.cma" plugin(native) ="batteries.cmxs" ) batteries-included-3.4.0/Makefile000066400000000000000000000236251415601150500167330ustar00rootroot00000000000000# A basic Makefile for building and installing Batteries Included # It punts to ocamlbuild for all the heavy lifting. NAME = batteries VERSION := $(shell grep "^Version:" _oasis | cut -c 15-) OCAML_MAJOR_VERSION := $(firstword $(subst ., , $(shell ocamlfind ocamlc -version))) uname_S := $(shell sh -c 'uname -s 2>/dev/null || echo not') # Define variables and export them for mkconf.ml DOCROOT ?= /usr/share/doc/ocaml-batteries export DOCROOT BROWSER_COMMAND ?= x-www-browser export BROWSER_COMMAND OCAMLBUILD ?= ocamlbuild OCAMLBUILDFLAGS ?= -no-links -use-ocamlfind ifeq ($(uname_S),Darwin) BATTERIES_NATIVE ?= yes BATTERIES_NATIVE_SHLIB ?= no else BATTERIES_NATIVE ?= yes BATTERIES_NATIVE_SHLIB ?= $(BATTERIES_NATIVE) endif # Directory where to build the qtest suite QTESTDIR ?= qtest ifeq ($(shell ocamlfind query -p-format qcheck),qcheck) QTESTPKG = qcheck else QTESTPKG = QTest2Lib endif INSTALL_FILES = _build/META _build/src/*.cma _build/src/*.cmi _build/src/*.mli \ toplevel/battop.ml _build/toplevel/*.cmi _build/toplevel/*.mli \ # Note: we do not currently install # _build/toplevel/*.cma # as there are no such files. If you create a proper library for batteries-help, you need to add *.cma # to INSTALL_FILES. INSTALL_FILES += \ _build/src/batteriesConfig.cmo _build/src/batteriesPrint.cmo _build/toplevel/batteriesHelp.cmo \ toplevel/ocamlinit build/ocaml # the bin_annot flag in _tags is not handled by versions of ocamlbuild < 4.01.0 # hence we only install *.cmt{i} files if they were produced ifneq ($(wildcard _build/src/*.cmt),) INSTALL_FILES += _build/src/*.cmt INSTALL_FILES += _build/toplevel/*.cmt endif ifneq ($(wildcard _build/src/*.cmti),) INSTALL_FILES += _build/src/*.cmti INSTALL_FILES += _build/toplevel/*.cmti endif OPT_INSTALL_FILES = \ _build/src/*.cmx _build/src/*.cmxa _build/src/*.cmxs \ _build/src/*.a _build/src/*.lib \ _build/toplevel/*.cmx _build/toplevel/*.cmxa _build/toplevel/*.cmxs \ _build/toplevel/*.a _build/toplevel/*.lib ifneq ($(QTEST_SEED),) QTEST_SEED_FLAG = --seed $(QTEST_SEED) else QTEST_SEED_FLAG = endif # What to build TARGETS = src/batteries.cma TARGETS += toplevel/batteriesHelp.cmo TARGETS += src/batteriesThread.cma TARGETS += META BENCH_TARGETS = benchsuite/bench_int.native BENCH_TARGETS += benchsuite/flip.native BENCH_TARGETS += benchsuite/deque.native BENCH_TARGETS += benchsuite/lines_of.native BENCH_TARGETS += benchsuite/bitset.native BENCH_TARGETS += benchsuite/bench_map.native BENCH_TARGETS += benchsuite/bench_nreplace.native BENCH_TARGETS += benchsuite/bench_set_to_seq.native TEST_TARGET = test-byte ifeq ($(BATTERIES_NATIVE_SHLIB), yes) EXT = native MODE = shared TARGETS += src/batteries.cmxs src/batteriesThread.cmxs TEST_TARGET = test-native else ifeq ($(BATTERIES_NATIVE), yes) EXT = native MODE = native TARGETS += src/batteries.cmxa src/batteriesThread.cmxa TEST_TARGET = test-native else EXT = byte MODE = bytecode endif endif .PHONY: all clean deps doc install uninstall reinstall test qtest qtest-clean camfail camfailunk man test_install all: @echo "Build mode:" $(MODE) $(OCAMLBUILD) $(OCAMLBUILDFLAGS) $(TARGETS) clean: @${RM} src/batteriesConfig.ml src/batUnix.mli batteries.odocl \ bench.log $(QTESTDIR)/all_tests.ml src/batteries_compattest.ml @${RM} -r man/ @$(OCAMLBUILD) $(OCAMLBUILDFLAGS) -clean @echo " Cleaned up working copy" # Note: ocamlbuild eats the first char! batteries.odocl: src/batteries.mllib src/batteriesThread.mllib cat $^ > $@ doc: batteries.odocl $(OCAMLBUILD) $(OCAMLBUILDFLAGS) batteries.docdir/index.html PREFILTER_BIN = _build/build/prefilter.byte # compute human-readable dependencies between modules deps: $(PREFILTER_BIN) ocamldep -modules -all -one-line -ml-synonym .mlv -mli-synonym .mliv \ -pp $(PREFILTER_BIN) src/*.ml src/*.mlv src/*.mliv src/*.mli > dependencies.txt man: all batteries.odocl -mkdir man ocamlfind ocamldoc -package threads.posix -sort -man -hide-warnings -d man -I _build/libs -I _build/src libs/uniclib.mli src/*.mli install: all uninstall_packages ocamlfind install $(NAME) $(INSTALL_FILES) \ -optional $(OPT_INSTALL_FILES) test_install: ./scripts/test_install.sh uninstall_packages: ocamlfind remove $(NAME) uninstall: uninstall_packages ${RM} -r $(DOCROOT) install-doc: doc mkdir -p $(DOCROOT) mkdir -p $(DOCROOT)/html/api cp _build/batteries.docdir/* $(DOCROOT)/html/api cp LICENSE README.md FAQ $(DOCROOT) install-man: man install man/* /usr/local/man/man3/ reinstall: $(MAKE) uninstall $(MAKE) install ############################################################################### # Pre-Processing of Source Code ############################################################################### # the prefilter logic has moved to myocamlbuild.ml # we keep the two void rules below for backward-compatibility for now # (devs may have scripts calling them) # # For the record, and the ease of porting the build system to # something else, the "prefilter" step preprocessed each file whose # extension ends with a 'v', for example '.mliv', using the command # build/prefilter.byte foo.mliv > foo.mli prefilter: clean-prefilter: ############################################################################### # BUILDING AND RUNNING UNIT TESTS ############################################################################### ### List of source files that it's okay to try to test # TESTABLE contains the source files as the user sees them, # as a mix of .ml and .mlv files in the src/ directory # TESTDEPS represents the file whose changes Makefile should watch to # decide to reprocess the test results. It is identical to TESTABLE. # TESTFILES contains the OCaml source files as `qtest` wants to see # them, that is after preprocessing. We ask ocamlbuild to build the # $(TESTFILES) from $(TESTABLE), and pass them to qtest from the # `_build` directory. DONTTEST=src/batteries_compattest.mlv \ src/batConcreteQueue_402.ml src/batConcreteQueue_403.ml TESTABLE ?= $(filter-out $(DONTTEST),\ $(wildcard src/*.ml) $(wildcard src/*.mlv)) TESTDEPS = $(TESTABLE) TESTFILES = $(TESTABLE:.mlv=.ml) ### Test suite: "offline" unit tests ############################################## _build/testsuite/main.byte: $(TESTDEPS) $(wildcard testsuite/*.ml) $(OCAMLBUILD) $(OCAMLBUILDFLAGS) testsuite/main.byte _build/testsuite/main.native: $(TESTDEPS) $(wildcard testsuite/*.ml) $(OCAMLBUILD) $(OCAMLBUILDFLAGS) testsuite/main.native ### qtest: "inline" unit tests ############################################## # extract all qtest unit tests into a single ml file $(QTESTDIR)/all_tests.ml: $(TESTABLE) $(OCAMLBUILD) $(OCAMLBUILDFLAGS) $(TESTFILES) (cd _build; qtest -o ../$@ --shuffle \ --preamble-file ../qtest/qtest_preamble.ml \ extract $(TESTFILES)) _build/$(QTESTDIR)/all_tests.byte: $(QTESTDIR)/all_tests.ml $(OCAMLBUILD) $(OCAMLBUILDFLAGS) -cflags -warn-error,+26\ -pkg oUnit,$(QTESTPKG) $(QTESTDIR)/all_tests.byte _build/$(QTESTDIR)/all_tests.native: $(QTESTDIR)/all_tests.ml $(OCAMLBUILD) $(OCAMLBUILDFLAGS) -cflags -warn-error,+26\ -pkg oUnit,$(QTESTPKG) $(QTESTDIR)/all_tests.native ### qtest: quick run of inline unit tests ############################################## # $ make qtest TESTABLE=foo.ml # will only test the module Foo. qtest-byte-clean: @${RM} $(QTESTDIR)/all_tests.ml @${MAKE} _build/$(QTESTDIR)/all_tests.byte qtest-byte: qtest-byte-clean @_build/$(QTESTDIR)/all_tests.byte $(QTEST_SEED_FLAG) qtest-native-clean: @${RM} $(QTESTDIR)/all_tests.ml @${MAKE} _build/$(QTESTDIR)/all_tests.native $(QTEST_SEED_FLAG) qtest-native: prefilter qtest-native-clean @_build/$(QTESTDIR)/all_tests.native $(QTEST_SEED_FLAG) qtest-clean: @${RM} $(QTESTDIR)/all_tests.ml @${MAKE} _build/$(QTESTDIR)/all_tests.$(EXT) qtest: qtest-clean @_build/$(QTESTDIR)/all_tests.$(EXT) $(QTEST_SEED_FLAG) ### run all unit tests ############################################## testsuite-only-byte: _build/testsuite/main.byte @_build/testsuite/main.byte @echo "" # newline after "OK" testsuite-only-native: _build/testsuite/main.native @_build/testsuite/main.native @echo "" # newline after "OK" test-byte: qtest-byte testsuite-only-byte test-native: qtest-native testsuite-only-native full-test: $(TEST_TARGET) $(PREFILTER_BIN): build/prefilter.ml $(OCAMLBUILD) build/prefilter.byte # FIXME: Should probably be done by ocamlbuild somehow: src/batteries_compattest.ml: src/batteries_compattest.mlv $(PREFILTER_BIN) $(PREFILTER_BIN) < $< > $@ test-compat: src/batteries_compattest.ml $(OCAMLBUILD) $(OCAMLBUILDFLAGS) src/batteries_compattest.byte test-build-from-install: $(MAKE) -C test-build test: test-byte test-compat ############################################################################### # BENCHMARK SUITE ############################################################################### bench: $(OCAMLBUILD) $(OCAMLBUILDFLAGS) $(TARGETS) $(BENCH_TARGETS) $(RM) bench.log $(foreach BENCH, $(BENCH_TARGETS), _build/$(BENCH) | tee -a bench.log; ) @echo "Benchmarking results are written to bench.log" ############################################################################### # PREPARING RELEASE FILES ############################################################################### release: $(MAKE) clean git stash save "stashing local modifications before release" $(MAKE) release-cleaned # assumes irreproachably pristine working directory release-cleaned: setup.ml doc test-native git archive --format=tar --prefix=batteries-$(VERSION)/ HEAD \ | gzip -9 > batteries-$(VERSION).tar.gz setup.ml: _oasis oasis setup git commit setup.ml -m"Update setup.ml based on _oasis" # uploads the current documentation to github hdoc2/ directory upload-docs: make doc && \ rm -rf /tmp/batteries.docdir && \ cp -a _build/batteries.docdir /tmp/ && \ git checkout gh-pages && \ rm -f hdoc2/*.html && \ cp /tmp/batteries.docdir/*.html hdoc2/ && \ git add hdoc2/*.html && \ git commit hdoc2 -m "Update ocamldoc to latest release" && \ git push origin gh-pages && \ git checkout master batteries-included-3.4.0/README.folders000066400000000000000000000007161415601150500176040ustar00rootroot00000000000000The following directories contain: * benchsuite/ provide performance evaluations of Batteries functions * build/ various (old) files needed for building * examples/ example files showing how to use various features of batteries * qtest/ the inline tests * src/ the core of Batteries Included, all the batFoo modules * toplevel/ Batteries helpers for the toplevel * testsuite/ a testsuite for batteries, in addition to inline tests in src/ batteries-included-3.4.0/README.md000066400000000000000000000061501415601150500165440ustar00rootroot00000000000000Welcome to OCaml Batteries Included =================================== ***OCaml Batteries Included***, or just ***Batteries***, is a community-maintained foundation library for your OCaml projects. Batteries * defines a standard set of libraries which may be expected on every compliant installation of OCaml; * organizes these libraries into a hierarchy of modules, with a single source of documentation; and * provides a consistent API for otherwise independent libraries. [![Build Status](http://ci.cedeela.fr/buildStatus/icon?job=batteries)](http://ci.cedeela.fr/job/batteries) Building Batteries ------------------ ### Requirements You will need the following libraries: * [OCaml][] >= 3.12.1 * [Findlib][] >= 1.5.3 * GNU make * [OUnit][] to build and run the tests (optional) * [qtest][] >= 2.0.1 to build and run the tests (optional) * [ocaml-benchmark][] to build and run the performance tests (optional) [Findlib]: http://projects.camlcity.org/projects/findlib.html/ [OCaml]: http://caml.inria.fr/ocaml/release.en.html [qtest]: http://batteries.vhugot.com/qtest/ [Camomile]: http://camomile.sourceforge.net/ [OUnit]: http://ounit.forge.ocamlcore.org/ [ocaml-benchmark]: http://ocaml-benchmark.forge.ocamlcore.org/ ### Configuration and Installation To install the full version of Batteries, execute $ make all $ make test [ optional ] $ sudo make install $ make doc [ optional ] $ sudo make install-doc [ optional ] If you want the documentation installed elsewhere, set this *before* starting the build process because this location is stored in the `Batteries_config` module generated during compilation. $ export DOCROOT=/path/to/new/docroot/ To disable native compilation: $ export BATTERIES_NATIVE=false To disable building of native shared libraries: $ export BATTERIES_NATIVE_SHLIB=false Using Batteries --------------- To get started using Batteries at the toplevel, copy the `ocamlinit` file to `~/.ocamlinit`: $ cp ocamlinit ~/.ocamlinit If you already have findlib in your `~/.ocamlinit`, you only need the last line in our ocamlinit to load batteries. More usage help available on the [batteries-included wiki][batwiki]. [batwiki]: https://github.com/ocaml-batteries-team/batteries-included/wiki/ ExtLib Compatibility -------------------- If your project currently uses [ExtLib][], most likely you can just change `-package extlib` to `-package batteries` and add `open Extlib` to the top of any extlib-using modules. Batteries' modules are all named BatFoo to differentiate them from extlib's modules, so one can use Batteries and ExtLib in the same project. [ExtLib]: http://code.google.com/p/ocaml-extlib/ COMPATIBILITY NOTE: If you're using ExtLib's Unzip module, it does not have a corresponding module in batteries at the moment. Extending Batteries ------------------- See the [guidelines wiki page][batwiki-dev]. [batwiki-dev]: https://github.com/ocaml-batteries-team/batteries-included/wiki/Developers-guidelines If you use emacs, the file [`batteries_dev.el`](/batteries_dev.el) has extra highlighting to support writing quicktests. batteries-included-3.4.0/_oasis000066400000000000000000000014251415601150500164650ustar00rootroot00000000000000OASISFormat: 0.4 OCamlVersion: >= 3.12.1 Name: batteries Version: 3.4.0 Authors: Batteries Included Team License: LGPL-2.1 with OCaml linking exception LicenseFile: LICENSE BuildType: custom (0.2) InstallType: custom (0.2) BuildTools: make Synopsis: Extended OCaml Standard Library XCustomBuild: $make all XCustomInstall: $make install XCustomUninstall: $make uninstall Document manual Type: custom (0.2) Title: Ocaml Batteries Documentation XCustom: $make doc Test main Type: custom (0.2) Command: $make test SourceRepository master Type: git Location: git://github.com/ocaml-batteries-team/batteries-included.git Branch: master Browser: https://github.com/ocaml-batteries-team/batteries-included Library "batteries" Path: src/ batteries-included-3.4.0/_tags000066400000000000000000000005321415601150500163030ustar00rootroot00000000000000<**/*.ml> : annot <**/*.ml> and not : warn_-29 true: package(bytes), warn_-3, bin_annot "build": include "src": include "toplevel": include "testsuite": include "qtest": include "benchsuite": include ".git": -traverse "examples": -traverse : opaque true: safe_string true: no_alias_deps true: strict_sequence batteries-included-3.4.0/batteries.opam000066400000000000000000000022141415601150500201220ustar00rootroot00000000000000opam-version: "2.0" synopsis: "A community-maintained standard library extension" maintainer: [ "Cedric Cellier " "Francois Berenger " "Gabriel Scherer " "Thibault Suzanne " ] authors: "OCaml batteries-included team" homepage: "https://github.com/ocaml-batteries-team/batteries-included" bug-reports: "https://github.com/ocaml-batteries-team/batteries-included/issues" dev-repo: "git://github.com/ocaml-batteries-team/batteries-included.git" license: "LGPL-2.1-or-later with OCaml-LGPL-linking-exception" doc: "http://ocaml-batteries-team.github.io/batteries-included/hdoc2/" build: [ ["ocaml" "setup.ml" "-configure" "--prefix" prefix] [make "all"] ] install: [make "install"] run-test: [make "test"] depends: [ "ocaml" {>= "4.00.0" & < "4.14.0"} "ocamlfind" {build & >= "1.5.3"} "ocamlbuild" {build} "qtest" {with-test & >= "2.5"} "qcheck" {with-test & >= "0.6" & < "0.14"} "benchmark" {with-test & >= "1.6"} "num" ] # url { # src: "https://github.com/ocaml-batteries-team/batteries-included/archive/vXXX.tar.gz" # checksum: "md5=YYY" # } batteries-included-3.4.0/batteries_dev.el000066400000000000000000000016241415601150500204300ustar00rootroot00000000000000;; This file contains useful things for participating to batteries ;; Right now, this consists of ;; * colorizing specially test comments (in orange) ;; ;; To use this file, simply add the following line to your .emacs: ;; (load-file "path/to/batteries/batteries_dev.el") ;; (defface test-comment-face '((t :foreground "orangered3")) "face for test comments") (add-hook 'tuareg-mode-hook '(lambda () (defun tuareg-font-lock-syntactic-face-function (state) (if (nth 3 state) font-lock-string-face (let ((start (nth 8 state))) (save-excursion (goto-char start) (if (looking-at-p "(\\*\\$[QTRE=]") 'test-comment-face (if (looking-at-p "(\\*\\*[^*]") tuareg-doc-face font-lock-comment-face)))))))) batteries-included-3.4.0/benchsuite/000077500000000000000000000000001415601150500174145ustar00rootroot00000000000000batteries-included-3.4.0/benchsuite/README000066400000000000000000000005211415601150500202720ustar00rootroot00000000000000The purpose of this directory is to provide performance evaluations of Batteries functions implementations. This is specially useful when testing changes against an upstream library such as INRIA's stdlib or Extlib. The benchmarks rely on the Ocaml [benchmark] library. [benchmark] http://forge.ocamlcore.org/projects/ocaml-benchmark/ batteries-included-3.4.0/benchsuite/_tags000066400000000000000000000001061415601150500204310ustar00rootroot00000000000000: pkg_benchmark : rectypes "lib": include batteries-included-3.4.0/benchsuite/array_filter.ml000066400000000000000000000040701415601150500224320ustar00rootroot00000000000000let (|>) x f = f x let list_filter a p = Array.to_list a |> List.filter p |> Array.of_list open Array let new_filter xs p = let n = length xs in (* Use a bitset to store which elements will be in the final array. *) let bs = BatBitSet.create n in for i = 0 to n-1 do if p xs.(i) then BatBitSet.set bs i done; (* Allocate the final array and copy elements into it. *) let n' = BatBitSet.count bs in let j = ref 0 in init n' (fun _ -> match BatBitSet.next_set_bit bs !j with | Some i -> j := i+1; xs.(i) | None -> assert false (* not enough 1 bits - incorrect count? *) ) let old_filter xs p = let n = length xs in (* Use a bitset to store which elements will be in the final array. *) let bs = BatBitSet.create n in for i = 0 to n-1 do if p xs.(i) then BatBitSet.set bs i done; (* Allocate the final array and copy elements into it. *) let n' = BatBitSet.count bs in let j = ref 0 in let xs' = init n' (fun _ -> (* Find the next set bit in the BitSet. *) while not (BatBitSet.mem bs !j) do incr j done; let r = xs.(!j) in incr j; r) in xs' let classic_filter xs p = let n = length xs in if n = 0 then [||] else begin let bs = Array.init n (fun i -> p xs.(i)) in let size = ref 0 in for i = 0 to n - 1 do if bs.(i) then incr size done; let result = Array.make !size xs.(0) in let j = ref 0 in for i = 0 to n - 1 do if bs.(i) then begin result.(!j) <- xs.(i); incr j; end done; result end let input_gen n = Array.init (1000 * n) (fun x -> x) let m4 = fun x -> x mod 4 = 0 let m5 = fun x -> x mod 5 = 0 let m10 = fun x -> x mod 10 = 0 let () = Bench.config.Bench.samples <- 1000; Bench.config.Bench.gc_between_tests <- true; Bench.bench_n ["list_filter", (fun a -> list_filter (input_gen a) m4); "old_filter", (fun a -> old_filter (input_gen a) m4); "new_filter", (fun a -> new_filter (input_gen a) m4); "classic_filter", (fun a -> new_filter (input_gen a) m4); ] |> Bench.summarize ~alpha:0.05 batteries-included-3.4.0/benchsuite/array_filter.png000066400000000000000000000771701415601150500226210ustar00rootroot00000000000000PNG  IHDRGbKGD IDATxwxTe>{{#HHh{"XPZW׺.*tvEZ"@L&$g NsWor99#DDDH]c<93a<93כ> !!!mճgϓ'O3}`㓞QNEDvx&7>ޱc-*33s̘1Ld/ڵku:իW M|||L?3/ztҤI+V0cƌ/6dȐ>@x`ii믿pSNٳg7|#z?㪪g}6**jM{챴cǎO6S1/&&&˖:_!Cx<2_.\iӦ%m"0uTׯϞ='0`@vvvӧǎKLL3}:|Ç[QWpL(֮]k0U*UGyyyƶ|ر^z5}:v؂YYYjܸqS(UUUfN8Q]]y;w>SM=z3fkVRR矟:u4eoTDdcg"+\reч8q;QQQ.l/ :u q8۷sꔽ*Wwٳ;vHwnݺ'x"55ޅ?>99O.xq\^Z3z\wx&""W@H]0%hF2ϮVQ µkhe:,?ZWa{WAaÆ{WA6hѢ@{W0Fde!4uX g.(ԅR {{{ۻ QZۻa<F@$399 wx&""'wˬkx&""gV_K\y&g""rf.A"ř}?DDԍh48}DD uX㙈шlٻ`<s*)AM \T7c<sFP39*!8uX߿zpBBc #<%-ݻu'Okm" w?|xfxO=qƎh"Fsܹ-[,Y䧟~%^'9L>uu|]ѣ;t6dx~7j(ZB1m4Ӹ\._zu̙gϞt۷o_xqTTȑ#.\i&$7W^xq$""'0c.^!G<JK1ipsD"rGVV0nʚfrIVW̙ Ga88܆,g___oo_iii'|2!!!###''jy\TiJJ͛NqƘYfuϝ;wgyA?.f:ޅMt"mhhh4.2 MXGj9uʭ⣏|Qj={ ÍzãnÆ E'`| FhyI$$ #99xa7.7#<A^EY?fpszzzΟ?_Pdffnݺ{ڴi&MڻwSRRL/Zh|||L#~~~7ST.]t۶mm|]vsozGH$nw[Ã?n~FOOD./Gr~d=w+/www???H$ء/P 3[Ӧa$݋>Ð!:b斚`/r2ifV p}FBCCJiWTڵkSSS'O}:E32 ᷨZ,|)رcϜ9cC߾}> rzKn\-W\)zӚ\OQZҥxyuuhcնuZ//4ͭǎEr2n*Gեaa޼yعsC IJJzץRL&۵kWM 彼ϟtM6=M[-[6qѣGwB""r>cFHLSq};<=Q[ꁇsqo TU!$IIxuHɰkWt\W-""'ݻoi׆ BBBfΜrʀ_nD"0`_}ӧKKKׯ_ow<""rJ={b$'cHgCf&GQz=BЍ{{"2;w  ̙HLʕ*`jɒ%DR5ޅMeff<<Gك7w.e| A]z=n 8xY㙈ŋpwolEၥKwؽ^^HNvx+1i48{Z-7/vvg""rxF_={uvg""rlNB૯c6DD؊P_:@z0㙈 ;R᫯\鮳 㙈Xe%**4۰&[`<m벶Ro#ذ a<A~~[¾Æ[1Q]܊f;<ٰULDDJ3m"[""rAW`hIm-vy 2*ڥ㙈^v#2Š2"㙈OQ-{`qg'x&""#jW_a$֮6DD`** ڊxAqĩ09_V~NEXXA:vi6x&""GRSBm"!̟/2>p ]0ȑ\V+;1mBC[ Mx&""R9dTEK!!֮ΖDD0`4]|Ν5 @AZ %39Nr3|))旻㙈õkPZmE};1nJRg""rSZ\RLsL8DD!! @|;-j5 Aux&""??MEE:HLluc<~]۶a\(:u㙈yxz"),Dn.5ˑ`BIx&""R*q|˻mýOMG jLDDv@IA._Ɯ955 ={Z6a<tm"ٲ //z fLDDs4p21kxm-bbmLDDv"j֭xV(0bK;3Ii)͛\"̘a>^W=]~ 3MNNm6o|#F6hx&""{FQgQ^i DF"6㙈yxyσ7m‚"SZ`<44l:s:|\@x8lP#`<] AX},TW}`<i8}Z||1yxCBCo㙈lUV$/CLkjg"")N;I8|HHAuLDD6TZ 6oCLMSgծ{}DDdg"9~cU*woWXDDd+2EZ:?ԹFnҥ1VΞ9?G@>6(0&qT-[#"TWcn8u㙈leH$"+EP7WDThDDd}Z-rrDC훙7wDDd}i>~00dFk㙈Ԋ$,|\ǶmxqCd*Tm㙈C30߳))" z_?TDDd̟]Vsg mspg""NGݻqBLDDVPR|*R_N%aP%㙈 ;AA惻vae>C8u㙈,Ԋ,No ~~)0rsEVx}F@L٦4gx&""C^0vY*m69 3Yh+oŘ16hDDd9V$f]r$&?M7a<Q"HoǝwBTrg""S+ob<Y.G>Yu΋LDDJe|;W:w㙈nUE뿮^ENԹ"/ 1g""Ugϯn&66u3ݒx|ᮻDvEl,zYuΎLDDExxhEu+O|P`DDy*Ξmъ\;ٹшYu.LDDgjE9<<ڵkUUUUUUvl'NE~lP]/Ҙ1ct:|믿:t #""2-6oڵGI>Sgk?O'Np4.W^ݿ9sٳu:/^5rȅ nڴ D" ի/^:d2,|9))m.bРV=۷K.MOO =ztϥP(.\1O>dBBBFFFNN?'JoKRRR6olv΍7̚5/ZUUU\\駟<NL_כ!!!IIIT*dvJOO7;kK.޴iӍ_qٲe'No""'ES9s9 @BZ $3SO$%%UTT <|i_|ap8E6}1A]%ISX8jKs<+YYYgfk""W AĈ,;xc͚OR] ̘aV+x޹sǓX YFgۿP@0g_i{+ gR2ȌFe!!(hh]w]4Ϟ ^~q<="".8y%%m("9Ӧs557=zX@jWs<.**ڱc 1DDN<)`ժvΠӡggOkH"Ӈ6""UUCė?,_"/ee=pEV|9>>so>!""Tb^`J%/&W&uD|7.]z!7؄PrL'ͭV<3ŋ7o1bK""hc9XC/3 :3H wE d/̻6/:`֭С03YlP<[Lb""'cZӉ/۽xᅶΠPhĝwmqO+J{WBDD㕝DDl֭xYISΠ IKga٦Pw?uԶض158p͛guUDDdc~ǏE ֮5u:TT;ٶa5?&ի6-ڥTb>c`BﾃBW_mpS)Sضӑ5hϜ9"o.\W_a͚V2;ZL"{&"r*ǏLʕx9Զ 㙈y\ӧŗ {&`V/-EJ v: ػ ""jOe%~ ={_ zxEz¤Ilؿ(ط`of J¶NC9jwj^|(IIlDDĴ,8X;+1{6RSEVV".S;㙈a8pwز^^X@dL`tg""q8[] "rxzb,XF 3ct .ڵ_D)1gNsnrBg""`Z%KNJngԶs\t1EADdo ؿ`!!?lXBܹgDDveZ׷ziqddlb-ݪ0s&bcmQ'㙈ȮGEE*+n^yż^Y3}ؠF=3)U>7ߊ&W{DDvr0zYcmA@q1nMk"N8{&":ۇV ǢE]QD˶LDds; ~W^1_/VUH~;v<^&"-wC"AX:VHNn1.!(3fe}1lH&?ͭ."}H̝bm;^&" w͇#;T(;ٶ`<ل)|1ް([BCCH $x&">vZ--#w2fbLDdeR)ѧyDGe%f@\k$Gx&"&S6{{͇9#F#JJ0a]#9 34esk7O?7bڠLr@g""먪P6k4X "!y65b<YAEvj?|#eeHNfnLDdiؽgx<JKf zh49m; =u)Zh̶:ΞnvHڭoo7wa dJ0ni-XHH;'{[`$LDyEE3o޵ ;v`b O=e>9jQQ;@Jm*%x&"[6GEgS>Y7TJ1s&mP&ug""Ez_k} > /!C7ףs".eRx&nϔQQ",c:+cL׈u㙈g! ֬A]Vej=wy0"K"fH6Kw3J8{&l{5mIe%BB0klP&uOg"ΞÈĸq"!:ӧ6Y㙈\=Xxo-HO[o<%%(.Fb"Ne3m63u3@Ly6Cb*;ʦl0'6㙈S6GGgs]wwE^l0Æ6 㙈3g/"\\”)"mףc`PDx&!'ǎd3X ?E25Ӿv `2LD dg_E};^}U<}jH1II) 㙈\ ;ǎ!.Œ.SΜ,[hP[9sЫ͊%jx&"e_5f+V@Ê9J%i1E5eslll[oa <#Rr9F{/zYDfDYY8yqq-rjN2pMDDrL|bc[d#ظ?@PfMdCg"r-'e[,]޽,+CTfiKBdsg"r!LdgfￏrZPJKѻ7i`w:"r`YYnZ,^ 77,[j6Of39Ξ%44য়pzuEExm̘qy@]Ca<ǡCjBiYƄ G()>ʹ0și48v . * ^^wc?PEY&MSD*+oZ5O l؀˗jTQY3ѷ͊%39!998q ioh>Ts粙69239:>2DGXUT+ЯyTM 44`))֫D^šCps3_`zwoTB&ÌHN^Da:ó> #<%-"uQq~60zu,A35X`wOc-ZhΝ;w9s 8pʔ)QQQri-[lٲu1Ы#G-(.Ft4f̀%% y͛K/rg}'%%=sf2;Pm߾=###*****j…6m2eD" mUN[z^'9YY8y=zjn.^ěo"1(+Cj*ƎJ'LHHy󃂂nܡ\TiJJ͛NqƘ^WT.\qãWw}FW%ry h4sx߾}> rJZZK.ݸB[.\rϞ=Vlo ˗#:k׶hDI 0eJ;IZц$%%RT&ڵ+==l///]2;;{ӦM>he˖M8qVl`@f&xz[Nx%̚?ljQT#0m\y۶m~᧟~sN BBBfΜr[N" 0`M㥥ׯ^Sm-g .-6X7|/lP s`H\.n?C=QQQ//Ʊ_~111]Fp"z4Z^+R)hBU9s"rPU`W * ['|sF)k1}:Px&"K+)Az:F>38C7u:uu'"f~@E/GD֮z3 2_?E㙈,D.Flҭ'`]6Mw#\㙈U`7vf&/mA@YBC1sfw:B㙈FFFWd0u^CYk:Id3ugg"b8 @V>5TVbXuh"x&[Ҵ ,<76]>v / f }-3u^۫r%y\^??v!jx&0;|kOڵ7w qq:UdN]1ÔJ=BU`F#6m¡Cx啎^6u2c9/3uL۫j<= P]ͮ#D A@]`0 ;Ǐ#<\Wv6{BǼylDL71Q\SPV8Ƒ#@\g۶a~n,/G` lL7jQX,!0zw#, #G"!wׯYdX nnXAk:)Smْ\ .\@N7OdM EE8{@HHsr{9=ы+j5**0q"M1 ;+WHw*22p$GJ >.`@Y.^DA"6l݊}⋝][ w݅LݕN~~i6닸8h4WdfbP KV#.@/PSUcjѯRQ__{/uq* # zu27 dea ءwCիE}=ڡ=Va4,Xх2GqD8u Z-ş^ //B<rppGߦtA瑖/ӡ ÇcH.'s`R==ѳ'z=3g0h2tk%ZBC}=VBxxGjh\;g"jV~yy!**OFyx :._ٳC 4_n٭=;7=ÆW;h_&Cddk&"ƳjZUT"wwDFhDa!.^Dr2FTu(8{55BHH'qQ9??,\;z ј6;n(,Dm-l"#Cb"ҶբΡ A c X 8^2 |er A}$groz`z=NDn.&L@>sP*;wk! bc1aµҼJ'c $r)g"? aaJ{³ԷM"H$6@t:磠IIl^աV#==1jhPY\u|g/[fhpsb<;/";z=;<#) Æ!1%A@ңޫzO gFԞS`SHxvK &uuk[ݐ6RAZ uuG] (00:qۢGQaDMXQ__sO'~ a/w`0 a::gQ"yI}ez1hm^Ea! +L7 q Fƀ][n46Z6BѢq gnVW##G@#S^p%"Ƴ}**p__'V=YN+Wr쉾}ѷ/,@BB>rdg#37" C - Ç㑘ٗJ$^Lb6oH 6}M__F#)}f_̚n>LWnvV:DDDF"<5 r`g2q~Q 9x,<S1u*F '{ѿ?F#RW+} $!2Tk -^@ϞP?b"ԑ*h4o1V( ã9CBn\M p͎0PW 0p bb&DvYCG?^j4nhlT`04e @"AhUHt:?js wpo_!| ZWyF؈~1o!$*gO$%z_JGUk~jgjL*?oCs 4v4t z'л7"":{M9ʴVo B @juz}OM[ HLnnt7vhS/ƹS+hoy^ҷի1> $2zo`@ytnl0@0249yrIarBIL:'tb`8LX&` ;`EeIwj?RJd:WO=[u)x̨@Ja~ىCO¢O|uTW 8bRɱ)t @ #Q> tft_0#=.' ?Q{Q)4A@c#?55D@)c1TeQr{b8xp( 8OGGjU(v{iK奣iQ״sxXШha"*`@GM8A.vj"p@uXM~K4qi*%GWgnEG._fkY{Z]%KPW*Nf0&3SA'㌮;zLS{zP[ʕ6ͪu:xMTC(jBQr%!Sy)S s^>}`\̝ ڵ #65~U8',Mq5N+^03antu9Kw7E47 3gO]wF*sjkhvNV2C> v7,OBAIwd8[)312ʓm85w~GƧX'L==BOxӦ--X--ٵ,$(@a̛fb'1 pF@=177 r&&BAJ$ a 'ËQf0rߵ0}QP@.&%-c`L<3 MCB%vS ˖GKqA 5!]S99EѲx@dм\]yUM)t9jM/K䤴 sh.UvtԐ Àe4!eÀAӠLy"DdžǏLRəBP@(n>?lNQy( D2#G`Æzgf=S τP;0n2eZoˁ@`X9q& a:qAy9Ry)W KGJ_ZGJF(GӲ 56D*iڈV¾ۢ e˗ƄͫݴC-?}+o+MOmC:`8jj܌GUUe'TG} '8x9? U"`ҍ3MGqƸ,GS+ YW\]UUA,GC{qgZ+xF&tz5E*LUUAM 3}:G4xtkJmn]Dss5&N]P bB6Fg'W< u4M sS\jD"܂-ВfVIӚd7Vol,,Hp GUQ~3oT.P[SaQRRԜ]-^ׅ.SC@D k#FaEwȗK+flJ?i2JѥeeDBL66"@0H|>G~ep)[TLtrͮLPS18c(ǃAG}>( i/}];8ٺxwމ 6ˇvԄgdc*sϝJ#&gqلlN7&oX͙|I, śqeW,# ρ A(Sś6WxU/n4Z7M ]k094 Z{,α(H'!#[qb^9y 60iDڈXxMMhj%T[o@]ӷD;碦*pёo^i<\03|Nis|fkJ(m4S] c(7'-fJ/b*L$ Uض4CϔI&tQ.R@*PC^[jH >\VUl MXzK?DM ֬i'y'=/_^i9 99 п1 "nrɛaͩ@+nrEM ^7*h&o|$&cɢHOdȃHmlɢUR%VUE%qI<4}}'@FH Eu)ɼ-{} ;I.) 2쾔ӎNy6Jto8֭[ϟ瑜89 P55JR1Z~J%I*'tD8[-E"sn$Rz|]>G|f(fFZ]j)TZjh؜ EWm1gf'g{AcV˕Tr|Α"'&g.4zͨ{kjEa|X_10_ !q㍈FLmX,[֭^UW9F3};g<R)_GG֮_bvlߎٳd*gM+eqU0y cTF--Y$^Ȗ,b)-${c)-vkɢ-Nd < 3Ka7Zm'5Yfy/,li˞#so~{ê݇B ˧]aG(*M|ZaRnaɄȳ+tf1B9WbQILQI,8"D!x<8<xB5\x@tLu T9aGZ$q0i3Tѩkre6B.&mM6 CZqlE76( Y=항a*5~b +.,^V m1-gO7W,.C(*Idx"Xt>C7sԅJmҤ& AեOޔZsmYe?1:Tg% P]jR%A#4bӲ5`w[ n)KT!]Pv75^m}rNoQ;):++CX*$E}CuTC]nu.S!˝]2;z:P?-*nW]~,yKL?9{n{(t==Mߤ\[bF( .+Wp ~=;?nLyaShi6lل ,#+\$Y 688b*M8WMޖD" DldKM,ے@D;!j'nj 7m޶* k:[ٚC'F)M#6/Z(Ely%ND%AxYD^TD^9TElòLB,2lX5VEZh԰RRߝuP-RWQ+j-^e(A]$Th$HWfIgGn*}u'%oi4(\D]ߎ/P,"ڵ8\I<2䢥5`< 䆾,;-* V0 .lƍhhBԀP] ho,֧1#t4ERt6c$ cb6w:Ѩ#MMQ]/uw+R)U(8zRګyU/#rNN쌦r1`ɢ%whȂ;VةH>cv zmer*jw-^ Eӧ8Nj y1hpzu!xu[9E=yH"'KE dȜ(^^Q b|ye8"P'ur) E~oњ#Ҷ3}Bo]LZ[6kiB C%ttxG}b?̙86UUX yW]5FqxMDqn+[57.:qg_϶ܴ^g6͙xȳ|_28[嗟}LIЗ%R5N-A+jڣ)\>2tk࣫U}4ΆIUw2֙JU\s4Z.>>yAbX|6l8U43lbmp6gJ~=|zD1MbKNс$,Ţ.HjOP|GAyQ@ ⮛0;ك?=I QV6--h D#|AshG}=C*{Ԍ!x?)/%ॗ*~[|X \sy!靥Gx鼚_^sοN7Qs<>'W瞋}tb*dnooxԖ+.}uSͨ UċFz&TRi׮]\pD7ǶF6R( W[bVlތÇqγ%mKsN, ]Iݡ)4 "|2F \ f耯OI)Q(WC',{#{!'&)耯{=NzRÒuDsUX%RWL.[qs-sx‹ĉA+#!p~ ^|Ix:rg渱&L7+|Rdl8N &&P8#AOzГE Z7)@E | jPW"!S:;;^Y=2}i<}>?GI!X?n36h> 0,롇z衇|_1~Ly} ]6ab,C&lzz<<??F~.mxvlߎqXMTV\w &nS oTGP_%D\\^?NH̪SP*F:d  M:OtBݍwnt݌f\]Hܯ쁇ߥ__D_r*B>y? "x-׮*Vnqnڇ}nm:^߁b|nҽ[P>m¦uXw .Oӳxv1!V#?-ᱵXێf4ߡ`*!:bvW.ձ<`NX3W!OCD4:TCFv_6/Ɗd};^~O7C}=Ms-(D /oyDw"<I:WZ4ޑY1)>z,TfF$;3a pB"F*]&+hJuE kj' s8"Wi;sNHM55> Ҍ65  o xqU 2#r-?WWaUغ(X^7ԠfvdWwޓv?c/eM, -ǩhɱ>z0gӯx,5ncb0aV } Z %v*@G~*$<9)Cm6̎ a2RرO<Rc[cYڜ1Ye@։?oy'[|%"y%{nފHTH!5$tdB_ 8QDQi\݂:ѓĀCנ} "Tzns,O/琣= k^E,a ]K"%iW{ 9]WVj6 ur({Cmr.6lj ذ H>Yl؇ph߆68>Mڅ(7W*r nѠŵ*T'ڰ؜@b!V*9CyB Q3dak¤w$RV~Xxƺʯ=*khT+JA NYEV M(b$B&! `@«dmP6aR'THR9Giz B,lD{ч?g\|\ ذ[J "oz1Ġ뚶_1pu&Ƀ?~W摧!7'Vȏp]41hH'?uĝgP2ȸhz[#cCH~G[ְ UިAM+Za#ll=|205 BgGz1ޒKF]ӞpT$z`~b6ZFx ۍpQVVlO!EsC\Z^xiT;~FDY'B♘)ACkq 2\%~مy??b1<**c4N;qro3΃c_>ݏۭ`߅NDbPZc`0ƃ ω&v*pAY\y N9-99pŃyp<9<[o>ڶ}8ضn:9?A9rDUUvdS 5l*{fcƋ/Oz8lڴ+>Qijcǎp8> a L tLF,`0p<3 1``0 Ƥ3`0& `L:<3 1``0 Ƥs/|;mOtawy=S^nx<>cƌ681o{֬Y`p6l1N;L0'|g&Eq瞛1cO۶m{W뮉n[,g͚EWgΜo߾mLv={nyJqu׵mٲK/]`AGǸꪫ@{{{ccux4q^re Wԧ>~K_W _B<xQx \B1`0N& )歷ފx|ƍoFn={h4z|e|>`͉Db֬Ymmmmmm[@ >vvۯkO<Ě5k9rdʕ/_zX,Fcsw3fعsqn/˲mۣ3̝wꫯK?87|yڵۨ>&1a3q$M {[[[ x`޽K.}W/G}4\yӦMxڵ/BMM3<3v[ww7lhjjzG/^qPu '$16!d`|X|>[[[; a0{f06mjmmmllӟdf16̹` ^{UV͝;w۶m4S`0ƀ9 t0`0Ig`0&L t IENDB`batteries-included-3.4.0/benchsuite/array_partition.ml000066400000000000000000000054261415601150500231640ustar00rootroot00000000000000let (|>) x f = f x let list_partition p a = let left, right = Array.to_list a |> List.partition p in Array.of_list left, Array.of_list right open Array let current_partition p xs = let n = length xs in (* Use a bitset to store which elements will be in which final array. *) let bs = BatBitSet.create n in for i = 0 to n-1 do if p xs.(i) then BatBitSet.set bs i done; (* Allocate the final arrays and copy elements into them. *) let n1 = BatBitSet.count bs in let n2 = n - n1 in let j = ref 0 in let xs1 = init n1 (fun _ -> (* Find the next set bit in the BitSet. *) while not (BatBitSet.mem bs !j) do incr j done; let r = xs.(!j) in incr j; r) in let j = ref 0 in let xs2 = init n2 (fun _ -> (* Find the next clear bit in the BitSet. *) while BatBitSet.mem bs !j do incr j done; let r = xs.(!j) in incr j; r) in xs1, xs2 let unixjunkie_partition p a = let n = length a in if n = 0 then ([||], [||]) else let mask = make n false in let ok_count = ref 0 in iteri (fun i x -> if p x then (unsafe_set mask i true; incr ok_count) ) a; let ko_count = n - !ok_count in let init = unsafe_get a 0 in let ok = make !ok_count init in let ko = make ko_count init in let j = ref 0 in let k = ref 0 in iteri (fun i px -> let x = unsafe_get a i in if px then (unsafe_set ok !j x; incr j) else (unsafe_set ko !k x; incr k) ) mask; (ok, ko) let gasche_partition p xs = let n = length xs in if n = 0 then ([||], [||]) else begin let size_yes = ref 0 in let bs = Array.init n (fun i -> let b = p (unsafe_get xs i) in if b then incr size_yes; b) in let yes = Array.make !size_yes xs.(0) in let no = Array.make (n - !size_yes) xs.(0) in let iyes = ref 0 in let ino = ref 0 in for i = 0 to n - 1 do if (unsafe_get bs i) then begin unsafe_set yes !iyes (unsafe_get xs i); incr iyes; end else begin unsafe_set no !ino (unsafe_get xs i); incr ino; end done; yes, no end let input_gen n = Array.init (1000 * n) (fun x -> x) let m4 = fun x -> x mod 4 = 0 let m5 = fun x -> x mod 5 = 0 let m10 = fun x -> x mod 10 = 0 let () = Bench.config.Bench.samples <- 1000; Bench.config.Bench.gc_between_tests <- true; Bench.bench_n [ "list_partition", (fun a -> list_partition m4 (input_gen a)); "current_partition", (fun a -> current_partition m4 (input_gen a)); "unixjunkie_partition", (fun a -> unixjunkie_partition m4 (input_gen a)); "gasche_partition", (fun a -> gasche_partition m4 (input_gen a)); ] |> Bench.summarize ~alpha:0.05 batteries-included-3.4.0/benchsuite/bench_finger_tree_enum.ml000066400000000000000000000013421415601150500244220ustar00rootroot00000000000000(* cd .. && ocamlbuild -use-ocamlfind benchsuite/bench_finger_tree_enum.native && _build/benchsuite/bench_finger_tree_enum.native *) module Fg = BatFingerTree let test_input = let s = ref Fg.empty in for i = 0 to 999_999 do s := Fg.snoc !s i; done; !s let () = assert (BatList.of_enum (Fg.enum test_input) = Fg.to_list test_input); assert (BatList.of_enum (Fg.backwards test_input) = Fg.to_list_backwards test_input); assert (BatList.of_enum (Fg.backwards test_input) = List.rev (Fg.to_list test_input)); () let test to_enum n = for _i = 1 to n do let enum = to_enum test_input in BatEnum.iter ignore enum done let () = Bench.bench_n [ "implemented", test Fg.enum; ] |> Bench.run_outputs batteries-included-3.4.0/benchsuite/bench_int.ml000066400000000000000000000023651415601150500217050ustar00rootroot00000000000000(* cd .. && ocamlbuild benchsuite/test_int.native -- *) external primitive_int_compare : int -> int -> int = "caml_int_compare" "noalloc" [@@warning "-3"] let std_compare = Pervasives.compare[@warning "-3"] let test_compare () = let length = 1000 in let input = Array.init length (fun _ -> BatRandom.(full_range_int (), full_range_int ())) in let output = Array.map (fun (x, y) -> std_compare x y) input in let test cmp n = Array.iteri (fun i (x, y) -> assert (cmp x y = output.(i)); for _i = 1 to n do ignore (cmp x y); done) input in let naive_compare x y = (* this code actually mirrors an implementation that has been used as BatInt.compare *) if x > y then 1 else if y > x then -1 else 0 in let mfp_compare (x : int) y = if x > y then 1 else if y > x then -1 else 0 in let samples = Bench.bench_n [ "BatInt.compare", test BatInt.compare; "stdlib's compare", test std_compare; "external compare", test primitive_int_compare; "mfp's compare", test mfp_compare; "naive compare", test naive_compare; ] in print_endline "For comparing 1000 pairs of random integers"; Bench.summarize samples let () = test_compare (); () batteries-included-3.4.0/benchsuite/bench_kahan.ml000066400000000000000000000072441415601150500221760ustar00rootroot00000000000000open Batteries let array_fsum t = Array.reduce (+.) t (* naive kahan version *) let array_kahan t = let sum = ref 0. in let err = ref 0. in for i = 0 to Array.length t - 1 do let x = t.(i) -. !err in let new_sum = !sum +. x in err := (new_sum -. !sum) -. x; sum := new_sum; done; !sum (* current implementation optimized for float unboxing *) let array_kahan_opt t = let sum = ref 0. in let err = ref 0. in for i = 0 to Array.length t - 1 do let x = t.(i) -. !err in let new_sum = !sum +. x in err := (new_sum -. !sum) -. x; sum := new_sum +. 0.; done; !sum +. 0. let list_fsum t = List.reduce (+.) t (* naive kahan version *) let list_kahan t = let rec loop sum err = function | [] -> sum | x::xs -> let x = x -. err in let new_sum = sum +. x in loop new_sum ((new_sum -. sum) -. x) xs in loop 0. 0. t (* current implementation optimized for float unboxing *) let list_kahan_opt t = let li = ref t in let continue = ref (!li <> []) in let sum = ref 0. in let err = ref 0. in while !continue do match !li with | [] -> continue := false | x::xs -> li := xs; let x = x -. !err in let new_sum = !sum +. x in err := (new_sum -. !sum) -. x; sum := new_sum +. 0.; done; !sum +. 0. let enum_fsum t = Enum.reduce (+.) t (* current implementation of fsum *) let enum_kahan t = match Enum.get t with | None -> 0. | Some i -> let sum = ref i in let c = ref 0. in Enum.iter (fun x -> let y = x -. !c in let t = !sum +. y in c := (t -. !sum) -. y; sum := t ) t; !sum (* trying to use the same unboxing trick (probably won't work though given the higher-order function used) *) let enum_kahan_opt t = match Enum.get t with | None -> 0. | Some i -> let sum = ref i in let c = ref 0. in Enum.iter (fun x -> let y = x -. !c in let t = !sum +. y in c := (t -. !sum) -. y; sum := t +. 0. ) t; !sum +. 0. let () = let array = Array.make 1_000_000 1.01 in let list = List.make 1_000_000 1.01 in let enum () = Array.enum array in assert (array_fsum array = list_fsum list); assert (list_fsum list = enum_fsum (enum ())); assert (array_kahan array = list_kahan list); assert (list_kahan list = enum_kahan (enum ())); assert (array_kahan_opt array = list_kahan_opt list); assert (list_kahan_opt list = enum_kahan_opt (enum ())); let repeat f n = for _i = 1 to n do ignore (f ()) done in Bench.bench_n [ "array fsum", repeat (fun () -> array_fsum array); "array kahan", repeat (fun () -> array_kahan array); "array kahan opt", repeat (fun () -> array_kahan_opt array); ] |> Bench.run_outputs; Bench.bench_n [ "list fsum", repeat (fun () -> list_fsum list); "list kahan", repeat (fun () -> list_kahan list); "list kahan opt", repeat (fun () -> list_kahan_opt list); ] |> Bench.run_outputs; Bench.bench_n [ "enum fsum", repeat (fun () -> enum_fsum (enum ())); "enum kahan", repeat (fun () -> enum_kahan (enum ())); "enum kahan opt", repeat (fun () -> enum_kahan_opt (enum ())); ] |> Bench.run_outputs; () (* The sad truth is that the result of these benchmarks vary too much from machine to machine to deduce interesting things from them. The following conclusions seem to hold: - on arrays, kahan summation is indeed four times slower than usual summation; on lists and enum the difference is much less visible (e.g. imperative kahan outperforms List.reduce-summation on lists) - the boxing optimization is a win for arrays and lists as it avoids allocation in the loop. Anything else is hard to tell. *) batteries-included-3.4.0/benchsuite/bench_map.ml000066400000000000000000000173621415601150500216730ustar00rootroot00000000000000(* cd .. && ocamlbuild benchsuite/bench_map.native && _build/benchsuite/bench_map.native *) (* The purpose of this test is to compare different implementation of the Map associative data structure. *) let total_length = 500_000 let (%) = BatPervasives.(%) module MapBench (M : sig val input_length : int end) = struct let input_length = M.input_length let nb_iter = max 10 (total_length / input_length) let () = Printf.printf "%d iterations\n" nb_iter let random_key () = Random.int input_length let random_value () = Random.int input_length let random_inputs random_elt () = BatList.init input_length (fun _ -> random_elt ()) let make_samples input tests () = Bench.bench_funs tests input (* we don't use BatInt to ensure that the same comparison function is used (PMap use Pervasives.compare by default), in order to have comparable performance results. *) module StdMap = BatMap.Make(struct type t = int let compare = compare end) module Map = BatMap let same_elts stdmap pmap = BatList.of_enum (StdMap.enum stdmap) = BatList.of_enum (Map.enum pmap) (* A benchmark for key insertion *) let create_std_map input = List.fold_left (fun t (k, v) -> StdMap.add k v t) StdMap.empty input let create_poly_map input = List.fold_left (fun t (k, v) -> Map.add k v t) Map.empty input let create_input = let keys = random_inputs random_key () in let values = random_inputs random_value () in BatList.combine keys values let std_created_map = create_std_map create_input let poly_created_map = create_poly_map create_input let () = assert (same_elts std_created_map poly_created_map) let samples_create = make_samples create_input [ "stdmap create", ignore % create_std_map; "pmap create", ignore % create_poly_map ] (* A benchmark for fast import *) let import_std_map input = StdMap.of_enum (BatList.enum input) let import_poly_map input = Map.of_enum (BatList.enum input) let import_input = create_input let () = let std_imported_map = import_std_map import_input in assert (same_elts std_imported_map poly_created_map); let poly_imported_map = import_poly_map import_input in assert (same_elts std_created_map poly_imported_map); () let samples_import = make_samples import_input [ "stdmap import", ignore % import_std_map; "pmap import", ignore % import_poly_map ] (* A benchmark for key lookup *) let lookup_input = random_inputs random_key () let lookup_std_map input = List.iter (fun k -> ignore (StdMap.mem k std_created_map)) input let lookup_poly_map input = List.iter (fun k -> ignore (Map.mem k poly_created_map)) input let samples_lookup = make_samples lookup_input [ "stdmap lookup", lookup_std_map; "pmap lookup", lookup_poly_map ] (* A benchmark for key removal *) let remove_input = random_inputs random_key () let remove_std_map input = List.fold_left (fun t k -> StdMap.remove k t) std_created_map input let remove_poly_map input = List.fold_left (fun t k -> Map.remove k t) poly_created_map input let () = assert (same_elts (remove_std_map remove_input) (remove_poly_map remove_input)) let samples_remove = make_samples remove_input [ "stdmap remove", ignore % remove_std_map; "pmap remove", ignore % remove_poly_map ] (* A benchmark for merging *) let random_pairlist () = BatList.combine (random_inputs random_key ()) (random_inputs random_value ()) let p1 = random_pairlist () let p2 = random_pairlist () let merge_fun k _a _b = if k mod 2 = 0 then None else Some () let merge_std_map = let m1 = StdMap.of_enum (BatList.enum p1) in let m2 = StdMap.of_enum (BatList.enum p2) in fun () -> StdMap.merge merge_fun m1 m2 let merge_poly_map = let m1 = Map.of_enum (BatList.enum p1) in let m2 = Map.of_enum (BatList.enum p2) in fun () -> Map.merge merge_fun m1 m2 let samples_merge = make_samples () [ "stdmap merge", ignore % merge_std_map; "pmap merge", ignore % merge_poly_map; ] (* compare fold-based and merge-based union, diff, intersect *) let pmap_union (m1, m2) = Map.union m1 m2 let fold_union (m1, m2) = Map.foldi Map.add m2 m1 let merge_union (m1, m2) = let merge_fun _k a b = if b <> None then b else a in Map.merge merge_fun m1 m2 let union_input = let m1 = Map.of_enum (BatList.enum p1) in let m2 = Map.of_enum (BatList.enum p2) in m1, m2 let () = let li m = BatList.of_enum (Map.enum m) in let test impl_union = li (pmap_union union_input) = li (impl_union union_input) in assert (test fold_union); assert (test merge_union); () let samples_union = make_samples union_input [ "pmap union", ignore % pmap_union; "fold-based union", ignore % fold_union; "merge-based union", ignore % merge_union; ] let pmap_diff (m1, m2) = Map.diff m1 m2 let fold_diff (m1, m2) = Map.foldi (fun k _ acc -> Map.remove k acc) m2 m1 let merge_diff (m1, m2) = let merge_fun _k a b = if b <> None then None else a in Map.merge merge_fun m1 m2 let diff_input = let m1 = Map.of_enum (BatList.enum p1) in let m2 = Map.of_enum (BatList.enum p2) in m1, m2 let () = let li m = BatList.of_enum (Map.enum m) in let test impl_diff = li (pmap_diff diff_input) = li (impl_diff diff_input) in assert (test fold_diff); assert (test merge_diff); () let samples_diff = make_samples diff_input [ "pmap diff", ignore % pmap_diff; "fold-based diff", ignore % fold_diff; "merge-based diff", ignore % merge_diff; ] let pmap_intersect f (m1, m2) = Map.intersect f m1 m2 let filter_intersect f (m1, m2) = let filter_fun k v1 = match try Some (Map.find k m2) with Not_found -> None with | None -> None | Some v2 -> Some (f v1 v2) in Map.filter_map filter_fun m1 let merge_intersect f (m1, m2) = let merge_fun _k a b = match a, b with | Some v1, Some v2 -> Some (f v1 v2) | None, _ | _, None -> None in Map.merge merge_fun m1 m2 let intersect_input = let m1 = Map.of_enum (BatList.enum p1) in let m2 = Map.of_enum (BatList.enum p2) in m1, m2 let () = let li m = BatList.of_enum (Map.enum m) in let test impl_intersect = li (pmap_intersect (-) intersect_input) = li (impl_intersect (-) intersect_input) in assert (test filter_intersect); assert (test merge_intersect); () let samples_intersect = make_samples intersect_input [ "pmap intersect", ignore % pmap_intersect (-); "filter-based intersect", ignore % filter_intersect (-); "merge-based intersect", ignore % merge_intersect (-); ] let () = let create = samples_create () in let import = samples_import () in let lookup = samples_lookup () in let remove = samples_remove () in let merge = samples_merge () in let union = samples_union () in let diff = samples_diff () in let intersect = samples_intersect () in List.iter (print_newline % Bench.summarize) [ create; import; lookup; remove; merge; union; diff; intersect; ] end let big_length = 100_000 let small_length = 500 let () = Printf.printf "Test with small maps (length = %d)\n%!" small_length; let () = let module M = MapBench(struct let input_length = small_length end) in () in print_newline (); print_newline (); Printf.printf "Test with big maps (length = %d)\n%!" big_length; Bench.config.Bench.samples <- 100; let () = let module M = MapBench(struct let input_length = big_length end) in () in () batteries-included-3.4.0/benchsuite/bench_nreplace.ml000066400000000000000000000277701415601150500227130ustar00rootroot00000000000000(* Run with: make bench BENCH_TARGETS=benchsuite/bench_nreplace.native *) open Batteries open String (* The current Batteries String.nreplace *) let nreplace_current ~str ~sub ~by = if sub = "" then invalid_arg "nreplace: cannot replace all empty substrings" ; let parts = BatString.split_on_string str ~by:sub in String.concat by parts (* The suggestion from Glyn Webster that started it all. Notice that it replaces substrings from left to right instead of right to left. *) let nreplace_glyn ~str ~sub ~by = if sub = "" then invalid_arg "nreplace: cannot replace all empty substrings" ; let find_sub pos = try find_from str pos sub with Not_found -> -1 in (* allows loop to be tail recursive *) let sublen = length sub in let strlen = length str in let buffer = Buffer.create strlen in let rec loop curpos = if curpos = strlen then Buffer.contents buffer else let subpos = find_sub curpos in if subpos = -1 then ( Buffer.add_substring buffer str curpos (strlen - curpos) ; Buffer.contents buffer ) else ( Buffer.add_substring buffer str curpos (subpos - curpos) ; Buffer.add_string buffer by ; loop (subpos + sublen) ) in loop 0 (* Then Thelema suggested preallocating the final string. Here is a first * implementation, performing two rfind_from which is apparently a very bad idea *) let nreplace_rxd ~str ~sub ~by = if sub = "" then invalid_arg "nreplace: cannot replace all empty substrings" ; let strlen = length str in let sublen = length sub in let bylen = length by in let dlen = bylen - sublen in let rec loop_subst l i = match (try Some (rfind_from str (i-1) sub) with Not_found -> None) with | None -> l | Some i' -> loop_subst (l + dlen) i' in let newlen = if dlen = 0 then strlen else loop_subst strlen strlen in let newstr = Bytes.create newlen in let rec loop_copy i j = match (try Some (rfind_from str (i-1) sub) with Not_found -> None) with | None -> (* still need the first chunk *) String.unsafe_blit str 0 newstr 0 i | Some i' -> let j' = j - (i - i') - dlen in (* newstring.[j .. end] is already inited. Init from j' to (j-1). *) String.unsafe_blit by 0 newstr j' bylen ; String.unsafe_blit str (i'+sublen) newstr (j'+bylen) (i-i'-sublen) ; loop_copy i' j' in loop_copy strlen newlen ; Bytes.to_string newstr (* So Thelema proposed a version without the double rfind_from * (taken from https://gist.github.com/thelema/5639270 + small fix) *) let nreplace_thelema ~str ~sub ~by = if sub = "" then invalid_arg "nreplace: cannot replace all empty substrings" ; let strlen = length str in let sublen = length sub in let bylen = length by in let dlen = bylen - sublen in let rec loop_subst idxes i = match Exceptionless.rfind_from str (i-1) sub with | None -> idxes | Some i' -> loop_subst (i'::idxes) i' in let idxes = loop_subst [] strlen in let newlen = strlen + List.length idxes * dlen in let newstr = Bytes.create newlen in let rec loop_copy i j idxes = match idxes with | [] -> (* still need the last chunk *) String.unsafe_blit str i newstr j (strlen-i) | i'::rest -> let di = i' - i in String.unsafe_blit str i newstr j di ; String.unsafe_blit by 0 newstr (j + di) bylen ; loop_copy (i + di + sublen) (j + di + bylen) rest in loop_copy 0 0 idxes ; Bytes.to_string newstr (* Same as above but avoiding the List.length *) let nreplace_thelema2 ~str ~sub ~by = if sub = "" then invalid_arg "nreplace: cannot replace all empty substrings" ; let strlen = length str in let sublen = length sub in let bylen = length by in let dlen = bylen - sublen in let rec loop_subst idxes newlen i = match (try rfind_from str (i-1) sub with Not_found -> -1) with | -1 -> idxes, newlen | i' -> loop_subst (i'::idxes) (newlen+dlen) i' in let idxes, newlen = loop_subst [] strlen strlen in let newstr = Bytes.create newlen in let rec loop_copy i j idxes = match idxes with | [] -> (* still need the last chunk *) String.unsafe_blit str i newstr j (strlen-i) | i'::rest -> let di = i' - i in String.unsafe_blit str i newstr j di ; String.unsafe_blit by 0 newstr (j + di) bylen ; loop_copy (i + di + sublen) (j + di + bylen) rest in loop_copy 0 0 idxes ; Bytes.to_string newstr (* Independently, MadRoach implemented the same idea with less luck apparently *) let nreplace_madroach ~str ~sub ~by = let strlen = String.length str and sublen = String.length sub and bylen = String.length by in let find_simple ~sub ?(pos=0) str = let find pos = try BatString.find_from str pos sub with Not_found -> raise BatEnum.No_more_elements in let nexti = ref pos in BatEnum.from (fun () -> let i = find !nexti in nexti := i+1; i) in (* collect all positions where we need to replace, * skipping overlapping occurrences *) let todo = let skip_unto = ref 0 in find_simple ~sub str |> Enum.filter begin function |i when i < !skip_unto -> false |i -> skip_unto := i + sublen; true end in (* create destination string *) let dst = Bytes.create (strlen + Enum.count todo * (bylen - sublen)) in (* do the replacement *) let srci, dsti = fold begin fun (srci,dsti) i -> let skiplen = i-srci in String.blit str srci dst dsti skiplen; String.blit by 0 dst (dsti+skiplen) bylen; (srci+skiplen+sublen, dsti+skiplen+bylen) end (0,0) todo in assert (strlen - srci = Bytes.length dst - dsti); String.blit str srci dst dsti (strlen - srci); Bytes.to_string dst (* Gasche had its own idea based on substrings. Here are several versions, any of which seams faster than all the above. See: https://github.com/ocaml-batteries-team/batteries-included/pull/372#issuecomment-18399379 for a discussion.*) (* should be BatSubstring.nsplit *) let nsplit str pat = let pat_len = String.length pat in let rec loop pos rev_subs = let next_pos = try BatString.find_from str pos pat with Not_found -> -1 in if next_pos = -1 then (BatSubstring.extract str pos None :: rev_subs) else let sub = BatSubstring.unsafe_substring str pos (next_pos - pos) in loop (next_pos + pat_len) (sub :: rev_subs) in List.rev (loop 0 []) (* should be BatSubstring.nsplit_enum *) let nsplit_enum str pat = let pat_len = String.length pat in let pos = ref 0 in BatEnum.from (fun () -> if !pos < 0 then raise BatEnum.No_more_elements else try let next_pos = BatString.find_from str !pos pat in let sub = BatSubstring.unsafe_substring str !pos (next_pos - !pos) in pos := next_pos + pat_len; sub with Not_found -> let sub = BatSubstring.extract str !pos None in pos := -1 ; sub ) (* should be BatSubstring.concat, with a separator argument *) let concat_optimized ~sep ssl = let sep_len = String.length sep in (* use of Obj.magic is unfortunate here, but it would not be present if this function was implemented inside BatSubstring. Another option would be to make BatSubstring.t a [private (string * int * int)] and use a case here, but I'm not sure it's wise to expose the representation publicly -- we may want to change, say, from (string * start_pos * len) to (string * start_pos * end_pos). *) let ssl : (string * int * int) list = Obj.magic (ssl : BatSubstring.t list) in match ssl with | [] -> "" | (s,o,len)::tl -> let total_len = let rec count acc = function | [] -> acc | (_,_,l)::tl -> count (acc + sep_len + l) tl in count len tl in let item = Bytes.create total_len in String.unsafe_blit s o item 0 len; let pos = ref len in let rec loop = function | [] -> () | (s,o,len)::tl -> String.unsafe_blit sep 0 item !pos sep_len; pos := !pos + sep_len; String.unsafe_blit s o item !pos len; pos := !pos + len; loop tl; in loop tl; Bytes.to_string item (* should be BatSubstring.concat, with a separator argument *) let concat_simple ~sep ssl = let sep_len = String.length sep in (* see comment above about Obj.magic *) let ssl : (string * int * int) list = Obj.magic (ssl : BatSubstring.t list) in match ssl with | [] -> "" | (s,o,len)::tl -> let total_len = List.fold_left (fun acc (_,_,l) -> acc+sep_len+l) len tl in let item = Bytes.create total_len in String.unsafe_blit s o item 0 len; let pos = ref len in let write (s,o,len) = String.unsafe_blit sep 0 item !pos sep_len; pos := !pos + sep_len; String.unsafe_blit s o item !pos len; pos := !pos + len; in List.iter write tl; Bytes.to_string item let concat_enum ~sep enum = match BatEnum.get enum with | None -> "" | Some hd -> let buf = Buffer.create 100 in Buffer.add_string buf (BatSubstring.to_string hd); BatEnum.iter (fun substr -> (* see comment above about Obj.magic *) let (s,o,l) = (Obj.magic (substr : BatSubstring.t) : string * int * int) in Buffer.add_string buf sep; Buffer.add_substring buf s o l; ) enum; Buffer.contents buf let nreplace_substring_simple ~str ~sub ~by = concat_simple ~sep:by (nsplit str sub) let nreplace_substring_optimized ~str ~sub ~by = concat_optimized ~sep:by (nsplit str sub) let nreplace_substring_enum ~str ~sub ~by = concat_enum ~sep:by (nsplit_enum str sub) (* We tests these nreplace implementations on this very file, substituting various * realistic words by others. *) let long_text = File.lines_of "bench_nreplace.ml" |> Enum.cycle ~times:100 |> List.of_enum |> concat "" let do_bench_for_len length name = let run rep iters = for _i = 1 to iters do (* "realistic" workload that attempts to exercise all interesting cases *) let str = sub long_text 0 length in let str = rep ~str ~sub:"let" ~by:"let there be light" in let str = rep ~str ~sub:"nreplace" ~by:"nr" in let str = rep ~str ~sub:"you wont find me" ~by:"" in let str = rep ~str ~sub:"match" ~by:"match" in let str = rep ~str ~sub:" " ~by:" " in ignore str done in Bench.bench_n [ "current "^ name, run nreplace_current ; "glyn "^ name, run nreplace_glyn ; "rxd "^ name, run nreplace_rxd ; "thelema "^ name, run nreplace_thelema ; "thelema2 "^ name, run nreplace_thelema2 ; "madroach "^ name, run nreplace_madroach ; "gasche simple "^ name, run nreplace_substring_simple ; "gasche enum "^ name, run nreplace_substring_enum ; "gasche optimized "^ name, run nreplace_substring_optimized ; ] |> Bench.run_outputs let main = (* First check that all implementation performs superficialy the same *) let check ~str ~sub ~by = let outp = nreplace_current ~str ~sub ~by in List.iter (fun (d,rep) -> let outp' = rep ~str ~sub ~by in if outp' <> outp then ( Printf.fprintf stderr "Implementation %s failed for str:%S, sub:%S, by:%S got %S instead of %S\n" d str sub by outp' outp ; exit 1 )) [ "glyn", nreplace_glyn ; "rxd", nreplace_rxd ; "thelema", nreplace_thelema ; "thelema2", nreplace_thelema2 ; "madroach", nreplace_madroach ; "gasche simple", nreplace_substring_simple ; "gasche enum", nreplace_substring_enum ; "gasche optimz", nreplace_substring_optimized ] in check ~str:"foo bar baz" ~sub:"bar" ~by:"BAR" ; check ~str:"foo bar baz" ~sub:"bar" ~by:"" ; check ~str:"foo bar baz" ~sub:"a" ~by:"BAR" ; check ~str:"foo bar baz" ~sub:" " ~by:" " ; do_bench_for_len 100 "short" ; print_endline "-------------------------------"; do_bench_for_len 1000 "long" ; print_endline "-------------------------------"; do_bench_for_len 10000 "very long" batteries-included-3.4.0/benchsuite/bench_num.ml000066400000000000000000000007371415601150500217130ustar00rootroot00000000000000let lt1 (x:int) y = x < y let lt2 x y = x < y let lt3 x y = BatInt.Compare.(<) x y let n = 100_000 let test_array = Array.init n (fun _ -> BatRandom.full_range_int ()) let test_f f niters = for _j = 1 to niters do for i = 1 to n-1 do let x = test_array.(i-1) in let y = test_array.(i) in ignore (f x y); done done let () = Bench.bench_n [ "Specialized", test_f lt1; "Polymorphic", test_f lt2; "BatInt.Compare", test_f lt3; ] |> Bench.run_outputs batteries-included-3.4.0/benchsuite/bench_set.ml000066400000000000000000000077621415601150500217140ustar00rootroot00000000000000(* cd .. && ocamlbuild benchsuite/bench_set.native && _build/benchsuite/bench_set.native *) (* The purpose of this test is to compare different implementation of the Set data structure. *) let total_length = 500_000 let ( % ) = BatPervasives.( % ) module SetBench (M : sig val input_length : int end) = struct let input_length = M.input_length let nb_iter = max 10 (total_length / input_length) let () = Printf.printf "%d iterations\n" nb_iter let random_elt () = Random.int input_length let random_inputs () = BatList.init input_length (fun _ -> random_elt ()) let make_samples input tests () = Benchmark.throughputN 1 (List.map (fun (name, test) -> name, test, input) tests) (* we don't use BatInt to ensure that the same comparison function is used (PMap use Pervasives.compare by default), in order to have comparable performance results. *) module StdSet = BatSet.Make(struct type t = int let compare = compare end) module PSet = BatSet let same_elts stdset pset = BatList.of_enum (StdSet.enum stdset) = BatList.of_enum (PSet.enum pset) (* A benchmark for key insertion *) let create_std_set input = List.fold_left (fun t e -> StdSet.add e t) StdSet.empty input let create_poly_set input = List.fold_left (fun t e -> PSet.add e t) PSet.empty input let create_input = random_inputs () let std_created_set = create_std_set create_input let poly_created_set = create_poly_set create_input let () = assert (same_elts std_created_set poly_created_set) let samples_create = make_samples create_input [ "stdset create", ignore % create_std_set; "pset create", ignore % create_poly_set ] (* A benchmark for fast import *) let import_std_set input = StdSet.of_enum (BatList.enum input) let import_poly_set input = PSet.of_enum (BatList.enum input) let import_input = create_input let () = let std_imported_set = import_std_set import_input in assert (same_elts std_imported_set poly_created_set); let poly_imported_set = import_poly_set import_input in assert (same_elts std_created_set poly_imported_set); () let samples_import = make_samples import_input [ "stdset import", ignore % import_std_set; "pset import", ignore % import_poly_set ] (* A benchmark for key lookup *) let lookup_input = random_inputs () let lookup_std_set input = List.iter (fun k -> ignore (StdSet.mem k std_created_set)) input let lookup_poly_set input = List.iter (fun k -> ignore (PSet.mem k poly_created_set)) input let samples_lookup = make_samples lookup_input [ "stdset lookup", lookup_std_set; "pset lookup", lookup_poly_set ] (* A benchmark for key removal *) let remove_input = random_inputs () let remove_std_set input = List.fold_left (fun t k -> StdSet.remove k t) std_created_set input let remove_poly_set input = List.fold_left (fun t k -> PSet.remove k t) poly_created_set input let () = assert (same_elts (remove_std_set remove_input) (remove_poly_set remove_input)) let samples_remove = make_samples remove_input [ "stdset remove", ignore % remove_std_set; "pset remove", ignore % remove_poly_set ] let () = let create = samples_create () in let import = samples_import () in let lookup = samples_lookup () in let remove = samples_remove () in List.iter (print_newline % Benchmark.tabulate) [ create; import; lookup; remove; ] end let big_length = 100_000 let small_length = 500 let () = Printf.printf "Test with small sets (length = %d)\n%!" small_length; let () = let module M = SetBench(struct let input_length = small_length end) in () in print_newline (); print_newline (); Printf.printf "Test with big sets (length = %d)\n%!" big_length; let () = let module M = SetBench(struct let input_length = big_length end) in () in () batteries-included-3.4.0/benchsuite/bench_set_to_seq.ml000066400000000000000000000040771415601150500232620ustar00rootroot00000000000000(* cd .. && ocamlbuild -use-ocamlfind benchsuite/bench_set_to_seq.native && _build/benchsuite/bench_set_to_seq.native *) (* The purpose of this test is to compare different implementation of BatSet.to_seq. *) (* the type BatSet.t is abstract, we break the abstraction boundary locally to implement our versions outside the module. *) type 'a set = | Empty | Node of 'a set * 'a * 'a set * int external hide : 'a set -> 'a BatSet.t = "%identity" external reveal : 'a BatSet.t -> 'a set = "%identity" module TooStrict = struct let rec to_seq m = match m with | Empty -> BatSeq.nil | Node(l, v, r, _) -> BatSeq.append (to_seq l) (fun () -> BatSeq.Cons (v, to_seq r)) let to_seq s = to_seq (reveal s) end module Simple = struct let rec to_seq m = fun () -> match m with | Empty -> BatSeq.Nil | Node(l, v, r, _) -> BatSeq.append (to_seq l) (fun () -> BatSeq.Cons (v, to_seq r)) () let to_seq s = to_seq (reveal s) end module Enumeration = struct type 'a iter = E | C of 'a * 'a set * 'a iter let rec cons_iter s t = match s with | Empty -> t | Node (l, e, r, _) -> cons_iter l (C (e, r, t)) let to_seq s = let rec to_seq iter () = match iter with | E -> BatSeq.Nil | C (e, r, t) -> BatSeq.Cons (e, to_seq (cons_iter r t)) in to_seq (cons_iter s E) let to_seq s = to_seq (reveal s) end let test_input = let s = ref BatSet.empty in for i = 0 to 9999 do s := BatSet.add i !s; done; !s let test to_seq = test_input |> to_seq |> BatSeq.length let () = assert (test TooStrict.to_seq = test BatSet.to_seq); assert (test Simple.to_seq = test BatSet.to_seq); assert (test Enumeration.to_seq = test BatSet.to_seq); () let () = let repeat f n = for _i = 1 to n do ignore (f ()) done in Bench.bench_n [ "too strict", repeat (fun () -> test TooStrict.to_seq); "simple", repeat (fun () -> test Simple.to_seq); "enumeration", repeat (fun () -> test Enumeration.to_seq); "batseq", repeat (fun () -> test BatSet.to_seq); ] |> Bench.run_outputs batteries-included-3.4.0/benchsuite/bitset.ml000066400000000000000000000046221415601150500212440ustar00rootroot00000000000000let width = 100000 let op_count = 1000 let set_poss = Array.init op_count (fun _ -> Random.int width) let clear_poss = Array.init op_count (fun _ -> Random.int width) let get_poss = Array.init op_count (fun _ -> Random.int width) let fill_arr s = for i = 0 to op_count-1 do s.(Array.unsafe_get clear_poss i) <- false; s.(Array.unsafe_get set_poss i) <- true; done let farr n = let s = Array.make width false in for _a = 1 to n do fill_arr s; for _b = 1 to 100 do for i = 0 to op_count-1 do let _bool : bool = s.(Array.unsafe_get get_poss i) in () done done done let count_arr n = let s = Array.make width false in for _a = 1 to n do let count = ref 0 in fill_arr s; for i = 0 to op_count-1 do if s.(i) then incr count; done done let next_bit_set_arr n = count_arr n (* Code almost look like count_arr *) open Batteries let fill_bitset s = for i = 0 to op_count-1 do BitSet.unset s (Array.unsafe_get clear_poss i); BitSet.set s (Array.unsafe_get set_poss i); done let fbs n = let s = BitSet.create width in for _a = 1 to n do fill_bitset s; for _b = 1 to 100 do for i = 0 to op_count-1 do let _bool : bool = BitSet.mem s (Array.unsafe_get get_poss i) in () done done done let count_bitset n = let s = BitSet.create width in for _a = 1 to n do fill_bitset s; let _count: int = BitSet.count s in () done let next_bit_set_bitset n = let s = BitSet.create width in for _a = 1 to n do let res = ref (Some 0) in fill_bitset s; while !res <> None do match !res with | Some idx -> res := BitSet.next_set_bit s (idx + 1) | None -> () done done let next_bit_set_enum n = let s = BitSet.create width in for _a = 1 to n do let () = fill_bitset s in let enum = BitSet.enum s in BatEnum.iter ignore enum done let () = Bench.config.Bench.gc_between_tests <- true; Bench.bench_n ["bitset.general", fbs; "array.general", farr] |> Bench.summarize ~alpha:0.05; Bench.bench_n ["bitset.count", count_bitset; "array.count", count_arr] |> Bench.summarize ~alpha:0.05; Bench.bench_n ["bitset.next", next_bit_set_bitset; "array.next", next_bit_set_arr; "bitset(enum).next", next_bit_set_enum] |> Bench.summarize ~alpha:0.05; batteries-included-3.4.0/benchsuite/deque.ml000066400000000000000000000077131415601150500210610ustar00rootroot00000000000000module Queue1 = (* not really amortized version *) struct type 'a t = { len_front : int; front : 'a list; (* front = [] => rear = [] *) len_rear : int; rear : 'a list; } let empty = { len_front = 0; front = []; len_rear = 0; rear = [] } let snoc t x = match t with | {front = []; rear = rear; _} -> assert (rear = []); {len_front = 1; front = [x]; len_rear = 0; rear = []} | {rear = rear; len_rear = len_rear; _} -> {t with rear = x :: rear; len_rear = len_rear + 1} let front t = match t with | {front = []; rear = rear; _} -> assert (rear = []); None | {front = [hd]; rear = rear; len_rear = len_rear; _} -> Some (hd, {len_front = len_rear; front = List.rev rear; rear = []; len_rear = 0}) | {front = hd :: tl; len_front = len_front; _} -> Some (hd, {t with front = tl; len_front = len_front - 1}) end type 'a lazy_list = 'a lazy_cell Lazy.t and 'a lazy_cell = | Nil | Cons of 'a * 'a lazy_list let nil = Lazy.from_val Nil let rec append x y = lazy ( match x with | lazy Nil -> Lazy.force y | lazy (Cons (hd, tl)) -> Cons (hd, append tl y) ) let rev x = let rec rev_append x acc = match x with | lazy Nil -> acc | lazy (Cons (hd, tl)) -> rev_append tl (Lazy.from_val (Cons (hd, acc))) in rev_append x nil module Queue2 = (* really amortized version *) struct type 'a t = { len_front : int; front : 'a lazy_list; len_rear : int; (* len_front >= len_rear *) rear : 'a lazy_list; } let empty = { len_front = 0; front = nil; len_rear = 0; rear = nil; } let snoc ({len_front = len_front; front = front; len_rear = len_rear; rear = rear} as t) x = if len_front >= len_rear + 1 then { t with rear = Lazy.from_val (Cons (x, rear)); len_rear = len_rear + 1; } else { front = append front (rev (Lazy.from_val (Cons (x, rear)))); len_front = len_front + len_rear + 1; rear = nil; len_rear = 0; } let front ({len_front = len_front; front = front; len_rear = len_rear; rear = rear} as t) = if len_front - 1 >= len_rear then ( match front with | lazy Nil -> assert false | lazy (Cons (hd, tl)) -> Some (hd, {t with len_front = len_front - 1; front = tl; }) ) else match front with | lazy Nil -> None | lazy (Cons (hd, tl)) -> Some (hd, { len_front = len_front - 1 + len_rear; front = append tl (rev rear); rear = nil; len_rear = 0; }) end module type Queue = sig type 'a t val empty : 'a t val snoc : 'a t -> 'a -> 'a t val front : 'a t -> ('a * 'a t) option end let test q grow_size = let module Q = (val q:Queue) in fun n -> for _i = 0 to n do let rec loop q = function | 0 -> q | j -> loop (Q.snoc q j) (j - 1) in let q = loop Q.empty grow_size in let rec loop q = match Q.front q with | None -> () | Some (_, q) -> loop q in loop q done let test_quadratic grow_size = let rec loop q = function | 0 -> q | j -> loop (BatDeque.cons j q) (j - 1) in let q = loop BatDeque.empty grow_size in let rec loop q = match BatDeque.rear q with | None -> () | Some (q, _) -> match BatDeque.front q with | None -> () | Some (_, q) -> loop q in loop q let () = let readings = Bench.bench_n [ "Not-really amortized Deque", test (module Queue1: Queue) 100; "Really amortized Deque", test (module Queue2: Queue) 100; ] in print_endline "Time to grow and deconstruct at the opposite end a deque of 10K elements"; Bench.summarize readings; let sizes = [10; 20; 50; 100; 200; 400; 1000] in let readings = Bench.bench_throughput test_quadratic sizes in print_endline "Time (per element) to grow and then deconstruct a BatDeque at alternating ends by queue length"; Bench.summarize readings batteries-included-3.4.0/benchsuite/dune000066400000000000000000000063061415601150500202770ustar00rootroot00000000000000; note: try to keep the benchmark list in sorted order (executable (name array_filter) (modules array_filter) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:array_filter.exe}))) (executable (name bench_finger_tree_enum) (modules bench_finger_tree_enum) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:bench_finger_tree_enum.exe}))) (executable (name bench_int) (modules bench_int) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:bench_int.exe}))) (executable (name bench_kahan) (modules bench_kahan) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:bench_kahan.exe}))) (executable (name bench_map) (modules bench_map) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:bench_map.exe}))) (executable (name bench_nreplace) (modules bench_nreplace) (libraries batteries bench)) (rule (alias benchmarks) (deps bench_nreplace.ml) (action (run %{exe:bench_nreplace.exe}))) (executable (name bench_num) (modules bench_num) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:bench_num.exe}))) (executable (name bench_set) (modules bench_set) (libraries batteries benchmark)) (rule (alias benchmarks) (action (run %{exe:bench_set.exe}))) (executable (name bench_set_to_seq) (modules bench_set_to_seq) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:bench_set_to_seq.exe}))) (executable (name bitset) (modules bitset) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:bitset.exe}))) (executable (name deque) (modules deque) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:deque.exe}))) (executable (name dynarray_iter) (modules dynarray_iter) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:dynarray_iter.exe}))) (executable (name flip) (modules flip) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:flip.exe}))) (executable (name fsum) (modules fsum) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:fsum.exe}))) (executable (name grouping) (modules grouping) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:grouping.exe}))) (executable (name lazylist) (modules lazylist) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:lazylist.exe}))) (executable (name lines_of) (modules lines_of) (libraries batteries bench)) (rule (alias benchmarks) (deps lines_of.ml) (action (run %{exe:lines_of.exe}))) (executable (name mid) (modules mid) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:mid.exe}))) (executable (name popcount) (modules popcount) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:popcount.exe}))) (executable (name rand_choice) (modules rand_choice) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:rand_choice.exe}))) (executable (name sequence) (flags (:standard -rectypes)) (modules sequence) (libraries batteries bench)) (rule (alias benchmarks) (action (run %{exe:sequence.exe}))) batteries-included-3.4.0/benchsuite/dynarray_iter.ml000066400000000000000000000025721415601150500226300ustar00rootroot00000000000000type dynarray = { mutable len : int; mutable array : int array; (* int array to have cheap Array.get, like in batDynArray *) } let len = 1000 let d = { len; array = Array.make len 42; } let unsafe_iter f d = for i = 0 to d.len - 1 do f d.array.(i) done let unsafe_iter2 f d = let a = d.array in for i = 0 to d.len - 1 do f a.(i) done let iter f d = let a = d.array in let len = d.len in for i = 0 to len - 1 do f a.(i); if d.array != a || d.len <> len then failwith "whatever" done let iter2 f d = let a = d.array in let i = ref 0 in let len = d.len in while !i < d.len && !i < len do f a.(!i); incr i done let iter3 f d = let i = ref 0 in while !i < d.len do f d.array.(!i); incr i done let test iter n = for i = 0 to n - 1 do ignore i; iter ignore d done let for_ n = for i = 0 to n - 1 do ignore i; for i = 0 to d.len - 1 do ignore d.array.(i) done done let for2 n = for i = 0 to n - 1 do ignore i; let a = d.array in for i = 0 to d.len - 1 do ignore a.(i) done done let () = let readings = Bench.bench_n [ "unsafe_iter", test unsafe_iter; "unsafe_iter2", test unsafe_iter2; "iter", test iter; "iter2", test iter2; "iter3", test iter3; "for_", for_; "for2", for2; ] in Bench.summarize readings batteries-included-3.4.0/benchsuite/flip.ml000066400000000000000000000006061415601150500207020ustar00rootroot00000000000000open BatPervasives open BatSet let of_list l = List.fold_left (flip add) empty l let of_list2 l = List.fold_left (fun x y -> add y x) empty l let of_list3 l = BatList.enum l |> BatSet.of_enum let wrap f () = f [1;3;5;7;9;2;4;6;8;10; 2; 5; 8; 3; 1; 9; 6] let () = Bench.bench ["flip", wrap of_list; "fun", wrap of_list2; "enum", wrap of_list3] batteries-included-3.4.0/benchsuite/fsum.ml000066400000000000000000000012421415601150500207170ustar00rootroot00000000000000 let rand_float _ = (BatRandom.float 2. -. 1.) *. 2. ** (float (BatRandom.int 80 - 40)) let nums = Array.init 10000 rand_float let test f () = f (BatArray.enum nums) let () = let results = Bench.bench_funs [ "Enum.reduce", test (BatEnum.reduce (+.)); "Enum.fsum (Kahan)", test BatEnum.fsum; "Array.fold", (fun () -> Array.fold_left (+.) 0. nums); "for loop", (fun () -> let s = ref 0. in for i = 0 to 9_999 do s := !s +. nums.(i); done; !s); "unsafe for loop", (fun () -> let s = ref 0. in for i = 0 to 9_999 do s := !s +. Array.unsafe_get nums i; done; !s); ] () in print_endline "For summing an array of 10K floats,"; Bench.summarize results batteries-included-3.4.0/benchsuite/grouping.ml000066400000000000000000000015541415601150500216050ustar00rootroot00000000000000let rec makeintervals_aux d lo hi acc = function | [] -> List.rev ((lo,hi)::acc) | h::t when h > hi+d -> makeintervals_aux d h h ((lo,hi)::acc) t | h::t (* h <= lim *) -> makeintervals_aux d lo h acc t let make_intervals d = function | [] -> [] | h::t -> makeintervals_aux d h h [] t let makeIntervals d = let merge s num = match s with | (start,stop) :: tail -> if abs(num-stop) <= d then (start,num) :: tail else (num,num) :: s | _ -> assert false in function | [] -> [] | head :: tail -> List.fold_left merge [(head,head)] tail let g = [1;3;5;9;12;13;14] let repeat f n = for _i = 1 to n do ignore (f g) done let tests = [ "fsharp", repeat (makeIntervals 2); "ocaml", repeat (make_intervals 2); ] let () = Bench.bench_n tests |> Bench.run_outputs batteries-included-3.4.0/benchsuite/lazylist.ml000066400000000000000000000042071415601150500216240ustar00rootroot00000000000000open BatLazyList (* append *) let test_append append n = for _i = 1 to n do iter ignore (BatList.fold_left append nil (BatList.init 50 (fun len -> init len (fun i -> i)))); done let append_inlined l1 l2 = let rec aux list = match next list with | Cons (x, (t : 'a t)) -> Cons (x, lazy (aux t)) | _ -> Lazy.force l2 in lazy (aux l1) let append_folding l1 l2 = lazy_fold_right (fun x xs -> Cons (x, xs)) l1 l2 (* concat *) let test_concat concat n = for _i = 1 to n do iter ignore (concat (init 100 (fun len -> init len (fun j -> j)))) done let concat_inlined (lol : ('a t) t) = let rec aux list = match next list with | Cons (li, t) -> Lazy.force (append li (lazy (aux t))) | Nil -> Nil in lazy (aux lol) let concat_folding lol = lazy_fold_right (fun li rest -> Lazy.force (append li rest)) lol nil (* exists *) let test_exists exists n = let len = 10_000 in for _i = 1 to n do assert (exists (fun i -> i > len / 2) (init len (fun i -> i))); done let exists_inlined f l = let rec aux rest = match next rest with | Cons (x, _) when f x -> true | Cons (_, t) -> aux t | Nil -> false in aux l let exists_folding p l = let test x rest = p x || Lazy.force rest in Lazy.force (lazy_fold_right test l (Lazy.from_val false)) let () = let append_benchs = Bench.bench_n [ "append inlined", test_append append_inlined; "append folding", test_append append_folding; ] in let concat_benchs = Bench.bench_n [ "concat inlined", test_concat concat_inlined; "concat folding", test_concat concat_folding; ] in let exists_benchs = Bench.bench_n [ "exists inlined", test_exists exists_inlined; "exists folding", test_exists exists_folding; ] in List.iter Bench.summarize [ append_benchs; concat_benchs; exists_benchs ] (* some approximate results: append inlined (2.82 ms) is 10.2% faster than append folding (3.14 ms) concat folding (1.38 ms) is probably (alpha=47.71%) same speed as concat inlined (1.39 ms) exists inlined (546.18 us) is 53.5% faster than exists folding (1.18 ms) *) batteries-included-3.4.0/benchsuite/lib/000077500000000000000000000000001415601150500201625ustar00rootroot00000000000000batteries-included-3.4.0/benchsuite/lib/bench.ml000066400000000000000000000644341415601150500216060ustar00rootroot00000000000000(* * Bench - Benchmarking functions * Copyright (C) 2011 Edgar Friendly * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Benchmarking functions, based on haskell criterion @author Edgar Friendly *) open Printf let (|>) x f = f x let (/^) a b = (float a) /. (float b) let rec repeat f x n = if n <= 0 then () else (ignore (f x); repeat f x (n-1)) let curry f (x,y) = f x y let tap f x = f x; x let rec (--.) (lo,step) hi = if lo <= hi then lo :: ((lo +. step),step) --. hi else [] let debug = false let dtap f x = if debug then (f x; x) else x module Measurement = struct (* TODO: make customizable timer? *) (*external timer : unit -> float = "bat_clock_gettime"*) let timer = Unix.gettimeofday let time f x = let t0 = timer () in let ret = f x in timer () -. t0, ret let time_ f x = let t0 = timer () in f x; timer () -. t0 let rec print oc t = if t < 0. then fprintf oc "-%a" print (-. t) else if t >= 1. then fprintf oc "%.2f s" t else if t >= 1e-3 then fprintf oc "%.2f ms" (t*.1e3) else if t >= 1e-6 then fprintf oc "%.2f us" (t*.1e6) else if t >= 1e-9 then fprintf oc "%.2f ns" (t*.1e9) else if t >= 1e-12 then fprintf oc "%.2f ps" (t*.1e12) else fprintf oc "%g s" t end module M = Measurement let mean a = (Array.fold_left (+.) 0. a) /. float (Array.length a) let median a = let sorted = Array.copy a in Array.sort compare sorted; let len = Array.length a in if len land 1 = 1 then sorted.(len/2+1) else (sorted.(len/2) +. sorted.(len/2+1))/. 2. let stdev ?mu a = let mu = match mu with None -> mean a | Some x -> x in let acc_dev acc a_i = let d = a_i -. mu in acc +. d *. d in let dev = Array.fold_left acc_dev 0. a in sqrt (dev /. float (Array.length a - 1)) let run_for_time t f seed0 = let t0 = M.timer () in let rec loop seed iters = let now = M.timer() in if now -. t0 > t *. 10. then failwith (sprintf "Took too long to run: seed %d iters %d" seed iters); let ti, ret = M.time f seed in if ti > t then (ti, seed, ret) else loop (2*seed) (iters+1) in loop seed0 0 module Normal_dist = struct let pi = 4. *. atan 1. let sqrt_2 = sqrt 2.0 let sqrt_2_pi = pi *. sqrt_2 let log_pi_over_2 = 0.572364942924700087071713675675 (*log_e(pi)/2*) (*reference - Haruhiko Okumura: C-gengo niyoru saishin algorithm jiten (New Algorithm handbook in C language) (Gijyutsu hyouron sha, Tokyo, 1991) p.227 [in Japanese] *) (* Incomplete gamma function 1 / Gamma(a) * Int_0^x exp(-t) t^(a-1) dt *) let rec p_gamma a x loggamma_a = if x >= 1. +. a then 1. -. q_gamma a x loggamma_a else if x = 0. then 0. else let rec pg_loop prev res term k = if k > 1000. then (eprintf "p_gamma could not converge."; res) else if prev = res then res else let term = term *. x /. (a +. k) in pg_loop res (res +. term) term (k +. 1.) in let r0 = exp (a *. log x -. x -. loggamma_a) /. a in pg_loop min_float r0 r0 1. (* Incomplete gamma function 1 / Gamma(a) * Int_x^inf exp(-t) t^(a-1) dt *) and q_gamma a x loggamma_a = if x < 1. +. a then 1. -. p_gamma a x loggamma_a else let rec qg_loop prev res la lb w k = if k > 1000. then (eprintf "q_gamma could not converge."; res) else if prev = res then res else let la, lb = lb, ((k -. 1. -. a) *. (lb -. la) +. (k +. x) *. lb) /. k in let w = w *. (k -. 1. -. a) /. k in let prev, res = res, res +. w /. (la *. lb) in qg_loop prev res la lb w (k +. 1.) in let w = exp (a *. log x -. x -. loggamma_a) in let lb = (1. +. x -. a) in qg_loop min_float (w /. lb) 1. lb w 2.0 let erf = function | x when classify_float x = FP_nan -> x | x when classify_float x = FP_infinite -> if x > 0. then 1. else -1. | x when x > 0. -> p_gamma 0.5 (x *. x) log_pi_over_2 | x (* x < 0 *) -> -. p_gamma 0.5 (x *. x) log_pi_over_2 let erfc = function | x when classify_float x = FP_nan -> x | x when classify_float x = FP_infinite -> if x > 0. then 0. else 2. | x when x >= 0. -> q_gamma 0.5 (x *. x) log_pi_over_2 | x (* x < 0. *) -> 1. +. p_gamma 0.5 (x *. x) log_pi_over_2 let standard_pdf x = exp (-. x *. x) /. sqrt_2_pi let standard_cdf x = erfc (-. x /. sqrt_2) /. 2. let find_root ?(accuracy=1e-15) ?(max_iters=150) cdf pdf y x0 x_min x_max = let rec fr_loop i dx x lo hi = if abs_float dx < accuracy || i > max_iters then x else let err = cdf x -. y in let lo,hi = if err < 0. then x, hi else lo, x in let pdf_x = pdf x in let dx,x' = if pdf_x = 0. then dx,x else err /. pdf_x, (x -. dx) in let dx,x' = if x' < lo || x' > hi || pdf_x = 0. then let y = (lo +. hi) /. 2. in (y -. x),y else dx, x' in fr_loop (i+1) dx x' lo hi in fr_loop 0 1. x0 x_min x_max let standard_quant = function | p when p < 0. || p > 1. -> nan | p when p = 0. -> neg_infinity | p when p = 1. -> infinity | p when p = 0.5 -> 0. | p -> find_root standard_cdf standard_pdf p 0. (-100.) 100. end module Bootstrap = struct type resample = Resample of float array let resample ests num_resamples samples = let num_samples = Array.length samples in let gen_sample () = Array.init num_samples (fun _ -> samples.(Random.int num_samples)) in let gen_estimations e = let est_outs = Array.init num_resamples (fun _ -> e(gen_sample ())) in Array.sort compare est_outs; Resample est_outs in List.map gen_estimations ests let drop_at i arr = let len = Array.length arr in let ret = Array.make (len-1) 0. in if i > 0 then Array.blit arr 0 ret 0 (i-1); if i < len-1 then Array.blit arr (i+1) ret i (len-(i+1)); ret let jackknife est sample = Array.init (Array.length sample) (fun i -> est (drop_at i sample)) type estimate = {point: float; lower: float; upper: float; confidence: float} let estimate p l u c = {point=p; lower=l; upper=u; confidence=c} let get {point;lower;upper;_} = (point,lower,upper) let est_scale s est = {est with point = s *. est.point; lower = s *. est.lower; upper = s *. est.upper} let e_print name oc e = fprintf oc "%s: %a, %2.0f%% CI: (%a, %a)\n" name M.print e.point (e.confidence *. 100.) M.print e.lower M.print e.upper let e_print_csv oc e = fprintf oc "%g,%g,%g" e.point e.lower e.upper let bootstrap_bca confidence sample estimators resamples = if confidence <= 0. || confidence >= 1. then failwith "bootstrap_bca: confidence must be between 0 and 1"; let make_estimate est (Resample res) = let pt = est sample in if Array.length sample = 1 then estimate pt pt pt confidence else let n = Array.length res in let jack = jackknife est sample in let jackmean = mean jack in let sum_cubes = Array.fold_left (fun acc x -> let d = jackmean -. x in acc +. d *. d *. d) 0. jack in let sum_squares = Array.fold_left (fun acc x -> let d = jackmean -. x in acc +. d *. d) 0. jack in let accel = sum_cubes /. (6. *. (sum_squares ** 1.5)) in let cumn x = int_of_float ((Normal_dist.standard_cdf x) *. (float n)) in let probN = Array.fold_left (fun acc x -> if x < pt then acc+1 else acc) 0 res in let bias = Normal_dist.standard_quant (float probN /. float n) in let z1 = Normal_dist.standard_quant ((1. -. confidence) /. 2.) in let b1 = bias +. z1 in let b2 = bias -. z1 in let a1 = bias +. b1 /. (1. -. accel *. b1) in let a2 = bias +. b2 /. (1. -. accel *. b2) in let lo = max (cumn a1) 0 in let hi = min (cumn a2) (n-1) in estimate pt res.(lo) res.(hi) confidence in List.map2 make_estimate estimators resamples end module Outliers = struct type outliers = { data_count: int; low_severe: int; ls_limit: float; low_mild: int; lm_limit: float; high_mild: int; hm_limit: float; high_severe: int; hs_limit: float; } let print oc {data_count=dc; low_severe=ls; low_mild=lm; high_mild=hm; high_severe=hs; _} = let one_percent = dc / 100 in if ls>0 || lm > one_percent || hm > one_percent || hs > 0 then begin printf "Outliers: "; let print cat thr n = if n > thr then fprintf oc "%d (%.1f%%) %s, " n (n/^dc *. 100.) cat in print "Low Severe" 0 ls; print "Low Mild" one_percent lm; print "High Mild" one_percent hm; print "High Severe" 0 hs; print_newline(); end (* Samples must be sorted in increasing order *) let quantile nth quantiles samples = assert (quantiles >= 2); assert (nth >= 0 && nth <= quantiles); let n = Array.length samples in if n = 0 then invalid_arg "Cannot quantile an empty array"; if n = 1 then samples.(0) else (* weighted avg between idx and idx+1 *) let idx_float = ((n-1) * nth) /^ quantiles in let idx = int_of_float (idx_float) in let interp = idx_float -. (float idx) in (* printf "Quant: %d/%d of %d: %d\n" nth quantiles n idx; *) (* weighted average of idx'th and (idx+1)'th sample *) if idx >= n-1 then samples.(n-1) else samples.(idx) +. interp *. (samples.(idx+1) -. samples.(idx)) (* searches a sorted array for the offset of the transition between elements less than elem and those greater than or equal to elem *) let find_transition (data:float array) elem = let rec iter a b = (* the bounds of the search includes data.(a) and excludes data.(b) *) if a = b then a else let mid = a + (b - a)/2 in match data.(mid) with | value when value = elem -> mid | value when value < elem -> iter (mid + 1) b | _ -> iter a mid in iter 0 (Array.length data) let note_outliers oc a = let len = Array.length a in let sorted = Array.copy a in Array.sort compare sorted; let q1 = quantile 1 4 sorted in let q3 = quantile 3 4 sorted in let inter_quartile_range = q3 -. q1 in fprintf oc "N: %d Inter-quartile width:%a, Full range: (%a,%a)\n" len M.print inter_quartile_range M.print sorted.(0) M.print sorted.(len-1); if inter_quartile_range <> 0. then ( let sevr_lo = q1 -. inter_quartile_range *. 3. in let mild_lo = q1 -. inter_quartile_range *. 1.5 in let mild_hi = q3 +. inter_quartile_range *. 1.5 in let sevr_hi = q3 +. inter_quartile_range *. 3. in let slo_pos = find_transition sorted sevr_lo in let mlo_pos = find_transition sorted mild_lo in let mhi_pos = find_transition sorted mild_hi in let shi_pos = find_transition sorted sevr_hi in print oc { data_count = len; low_severe = slo_pos; ls_limit = sevr_lo; low_mild = mlo_pos - slo_pos; lm_limit = mild_lo; high_mild = shi_pos - mhi_pos; hm_limit = mild_hi; high_severe = len-shi_pos; hs_limit = sevr_hi; } ); () let analyze_mean _i a = (*note_outliers IO.stdout a;*) mean a type effect = | Unaffected (* less then 1% effect *) | Slight (* between 1% and 10% *) | Moderate (* between 10% and 50% *) | Severe (* more than 50% *) let effect_to_string = function | Unaffected -> "unaffected" | Slight -> "slightly affected" | Moderate -> "moderately affected" | Severe -> "severely affectedkil" let effect_of_var x = if x < 0.01 then Unaffected else if x < 0.1 then Slight else if x < 0.5 then Moderate else Severe let outlier_variance mu sigma n = let n_fl = float n in let sb = sigma.Bootstrap.point in let ua = mu.Bootstrap.point /. n_fl in let sb2 = sb *. sb in let sg = min (ua /. 8.) (sb /. sqrt n_fl) in let sg2 = sg *. sg in let cmax x = let d = 2. *. (ua -. x) in let ad = n_fl *. d in let k0 = -. n_fl *. ad in let k1 = sb2 -. n_fl *. sg2 +. ad in let det = k1 *. k1 -. 4. *. sg2 *. k0 in floor (-2. *. k0 /. (k1 +. sqrt det)) |> int_of_float in let var_out c = let ac = n-c in (ac /^ n) *. (sb2 -. float ac *. sg2) in let minby f x v = min (f x) (f v) in let var_out_min = minby var_out 1 (minby cmax 0. (ua /. 2.)) in var_out_min let print_effect oc ov = if ov > 0.00001 then ( let effect = effect_of_var ov |> effect_to_string in fprintf oc "variance introduced by outliers: %.5f%%\n" (ov *. 100.); fprintf oc "variance is %s by outliers\n" effect; ) end type results = { desc : string; times: float array; mean : Bootstrap.estimate; stdev: Bootstrap.estimate; ov : float; (* outlier variance *) } let analyze_sample desc ci samples num_resamples = let ests = [ mean; stdev ] in let resamples = Bootstrap.resample ests num_resamples samples in match Bootstrap.bootstrap_bca ci samples ests resamples with | [mu_hat; sigma_hat] -> let ov = Outliers.outlier_variance mu_hat sigma_hat (Array.length samples) in {desc=desc; times=samples; mean=mu_hat; stdev=sigma_hat; ov=ov} | _ -> assert false (* scale the result values by s *) let res_scale s res = { res with times = Array.map ( ( *. ) s ) res.times; mean = Bootstrap.est_scale s res.mean; stdev = Bootstrap.est_scale s res.stdev; } (* Print a summary of the results, noting any outliers *) let print_res ?(verbose=false) oc res = if verbose then Outliers.note_outliers oc res.times; Bootstrap.e_print "mean" oc res.mean; Bootstrap.e_print "std.dev." oc res.stdev; Outliers.print_effect oc res.ov; fprintf oc "\n"; () let list_print ~first ~sep ~last to_string oc lst = let rec lp_aux = function | [] -> () | [last] -> output_string oc (to_string last) | h::t -> output_string oc (to_string h); output_string oc sep; lp_aux t in output_string oc first; lp_aux lst; output_string oc last (* print a list of results to a csv file *) let print_csv resl oc = let print_csv_string l = list_print ~first:"\"" ~sep:"\",\"" ~last:"\"\n" (fun x -> x) oc l in let print_csv_float l = list_print ~first:"" ~sep:"," ~last:"\n" string_of_float oc l in print_csv_string (List.map (fun r -> r.desc) resl); for i = 0 to Array.length (List.hd resl).times - 1 do print_csv_float (List.map (fun r -> r.times.(i)) resl); done let print_json resl oc = List.iter (fun res -> fprintf oc "{ name: \"%s\"; samples: [%a] }\n" res.desc (fun oc ts -> Array.iteri (fun i x -> output_string oc (string_of_float x); if i <> Array.length ts then output_string oc ", ") ts ) res.times ) resl let print_flat resl oc = match resl with [] -> () | res::_ -> fprintf oc "flat\n"; Array.iter (fprintf oc "%g\n") res.times let print_result oc res = let mp,ml,mu = Bootstrap.get res.mean in let sp,sl,su = Bootstrap.get res.stdev in fprintf oc "%s\n%g %g %g\n%g %g %g\n" res.desc mp ml mu sp sl su; Array.iter (fprintf oc "%g ") res.times; fprintf oc "\n" let print_times filename = let handler = if Filename.check_suffix filename ".csv" then print_csv else if Filename.check_suffix filename ".json" then print_json else if Filename.check_suffix filename ".flat" then print_flat else failwith "Unknown output filename suffix" in (fun resl -> Printf.eprintf "Saving times to %s\n" filename; let oc = open_out filename in handler resl oc; close_out oc; ) let cmp_ci r1 r2 = let l1 = r1.mean.Bootstrap.lower in let u1 = r1.mean.Bootstrap.upper in let l2 = r2.mean.Bootstrap.lower in let u2 = r2.mean.Bootstrap.upper in if u1 < l2 then -1 else if u2 < l1 then 1 else 0 let cmp_point r1 r2 = compare r1.mean.Bootstrap.point r2.mean.Bootstrap.point let change r1 r2 = let t1 = r1.mean.Bootstrap.point in let t2 = r2.mean.Bootstrap.point in (t2 -. t1) /. t2 *. 100. (* percent improvement *) let test_unequal r1 r2 = (* t-test for difference in population means *) let u1 = r1.mean.Bootstrap.point in let u2 = r2.mean.Bootstrap.point in let s1 = r1.stdev.Bootstrap.point in let s2 = r2.stdev.Bootstrap.point in let s1m = s1 *. s1 /. float (Array.length r1.times) in let s2m = s2 *. s2 /. float (Array.length r2.times) in let t = (u2 -. u1) /. sqrt (s1m +. s2m) in if debug then Printf.printf "u1:%g u2:%g s1m:%g s2m:%g t-score: %g\n" u1 u2 s1m s2m t; (* Assumes large samples i.e. n>30 *) 1. -. Normal_dist.standard_cdf t (* return p-value *) (* print the given results in order from shortest time to longest time, with statistically indistinguishable values marked *) let summarize ?(alpha=0.05) = function [] -> () | [_] -> () (* no functions - do nothing *) | res_list -> (* multiple functions tested - group and compare *) let rec print_changes ~pre = function | [] -> assert false | [r] -> printf "%s (%a)\n" r.desc M.print r.mean.Bootstrap.point | r1::(r2::_ as tl) -> let p_value = test_unequal r1 r2 in printf "%s (%a) %s" r1.desc M.print r1.mean.Bootstrap.point pre; if p_value > alpha then printf "is probably (alpha=%.2f%%) same speed as\n" (p_value *. 100.) else printf "is %.1f%% faster than\n" (change r1 r2); print_changes ~pre:"which " tl in print_changes ~pre:"" (List.sort cmp_point res_list) type config = { mutable verbose : bool; mutable samples: int; mutable gc_between_tests: bool; mutable resamples: int; mutable confidence_interval: float; mutable output: (results list -> unit) list; mutable min_iters: int; } (* The module-global configuration for running benchmarks. TODO: this should be either parent or child of environment so it can be non-global *) let config = { verbose = true; samples=300; resamples = 1_000; confidence_interval = 0.95; gc_between_tests= false; (* output = [summarize ~alpha:0.05];*) output = [print_times "times.flat"; summarize ~alpha:0.05]; min_iters = 1; } let vtap f x = if config.verbose then (f x; x) else x type environment = {mutable clock_res: float; mutable clock_cost: float} let env = {clock_res = min_float; clock_cost = max_float} let is_positive x = x > 0. (* produce an environment record appropriate for the current system by measuring the cost and resolution of the M.timer() function *) let init_environment () = if env.clock_res = min_float then (* do nothing if already initialized *) let resolution i = (* measure the clock resolution *) let times = Array.init (i+1) (fun _ -> M.timer()) in let pos_diffs = Array.init i (fun i -> times.(i+1) -. times.(i)) |> Array.to_list |> List.filter is_positive |> Array.of_list in pos_diffs in let cost t t0 = (* compute clock cost *) (* put timer in closure to compensate for testing closure *) let f () = M.timer () in let tclock i = M.time_ (repeat f ()) i in ignore (tclock 100); let (_,iters,elapsed) = run_for_time t0 tclock 10_000 in let times = Array.init (ceil (t /. elapsed) |> int_of_float) (fun _ -> tclock iters) in Array.map (fun t -> t /. float iters) times in if config.verbose then print_endline "Measuring: System Clock"; if config.verbose then print_endline "Warming up"; let (_,seed,_) = run_for_time 0.1 resolution 10_000 in if config.verbose then print_string "Estimating clock resolution"; let (_,i,clocks) = run_for_time 0.5 resolution seed in (* TODO: Do we want mean here?!? Look into better detection of clock resolution *) let clock_res = Outliers.analyze_mean i clocks in if config.verbose then printf " (%a)\nEstimating cost of timer call" M.print clock_res; let ts = cost (min (10_000. *. clock_res) 3.) (max 0.01 (5.*.clock_res)) in let clock_cost = Outliers.analyze_mean (Array.length ts) ts in if config.verbose then printf " (%a)\n" M.print clock_cost; env.clock_res <- clock_res; env.clock_cost <- clock_cost let min_runtime = ref 0.1 (* benchmark a function appropriate for the current environment. The number of samples is given in config.sample The number of iterations of the benchmark to run per sample is computed based on the number of iterations that can be run in 0.1s so that each sample takes at most (clock_res * 1000) or 0.1 seconds, unless it takes longer than that for a single repetition. *) let run_benchmark (f: int -> 'a) = (* warm up clock function *) let tclock i = M.time_ (repeat M.timer ()) i in run_for_time 0.1 tclock 10_000 |> ignore; (* run for 0.1s per sample or 1000*clock resolution, whichever is shorter *) let min_time = min (env.clock_res *. 1_000.) !min_runtime in let (test_time, test_iters, _) = run_for_time min_time f 1 in if config.verbose then printf "Ran %d iterations in %a\n%!" test_iters M.print test_time; let iters = ceil (min_time *. float test_iters /. test_time) in let iters_int = max (int_of_float iters) config.min_iters in let est_time = float config.samples *. iters *. test_time /. float test_iters in if config.verbose then printf "Collecting %d samples, %d iterations each, estimated time: %a\n%!" config.samples iters_int M.print est_time; Array.init config.samples (fun _ -> if config.gc_between_tests then Gc.compact (); M.time_ f iters_int) |> Array.map (fun t -> (t -. env.clock_cost) /. iters) (** Run a benchmark and analyze the results, printing a simple summary to stdout *) let run_and_analyze desc f = init_environment (); printf "Benchmarking: %s\n%!" desc; let times = run_benchmark f in (* printf " ... Analyzing with %d resamples\n%!" config.resamples;*) analyze_sample desc config.confidence_interval times config.resamples |> tap (print_res ~verbose:config.verbose stdout) (* run the output functions on our results *) let run_outputs res = List.iter (fun f -> f res) config.output (** Functions to benchmark are (int -> unit). Parameter is number of repetitions *) let bench_n fs = List.map (curry run_and_analyze) fs (* Benchmark unit functions with names *) let bench fs = List.map (fun (d,f) -> run_and_analyze d (repeat f ())) fs |> run_outputs (** This is the main function to benchmark and compare a number of functions. Functions to benchmark have a value to apply them to. We will rewrite them to take int argument of # of reps to run. *) let bench_arg fs = List.map (fun (d,f,x) -> run_and_analyze d (repeat f x)) fs (** f argument is ('a -> unit), and we are given a [(string * 'a) list] to test across *) let bench_args f dxs = List.map (fun (d,x) -> run_and_analyze d (repeat f x)) dxs (** [bench_funs fs x] benchmarks a list of labeled functions on the same input, x *) let bench_funs fs x = List.map (fun (d,f) -> run_and_analyze d (repeat f x)) fs (** This function is similar to bench_args, but args are ints, and we rescale times. This is useful for testing different block sizes of a function to see which work unit size leads to the highest throughput. *) let bench_throughput f xs = let bench_one x = run_and_analyze (string_of_int x) (repeat f x) |> res_scale (1. /. float x) in List.map bench_one xs (* generate points spaced nicely - exponential for really big ranges (lo/hi>10), if we can hit every int between lo and hi with between n/3 and n*3 points unit spacing for medium ranges, default 10 intervals *) let rec gen_points ?(n=10) lo hi = (* printf "gp %g %g\n%!" lo hi;*) assert (hi >= lo); if hi = lo then [lo] else if lo > 0. && hi /. lo > 100. then gen_points ~n (log lo) (log hi) |> List.map exp else if hi -. lo < float (n*3) && hi -. lo > float (n/3) && floor (hi -. lo) = (hi -. lo) then (floor lo, 1.) --. ceil hi else let step = (hi -. lo) /. float n in (lo, step) --. hi let rec uniq = function | x :: y :: t when x = y -> uniq (x :: t) | x :: t -> x :: uniq t | [] -> [] (* hide the float internals, give a nice int interface *) let gen_points ?n lo hi = gen_points ?n (float lo) (float hi) |> List.map (fun x -> truncate (x+. 0.5)) |> uniq let bench_range f ~input_gen ?n (lo,hi) = let points = gen_points ?n lo hi in let run_one i = run_and_analyze (string_of_int i) (repeat f (input_gen i)) in List.map run_one points let rec transpose list = match list with | [] -> [] | [] :: xss -> transpose xss | (x::xs) :: xss -> (x :: List.map List.hd xss) :: transpose (xs :: List.map List.tl xss) let bench_2d fs ~input_gen ?n (lo,hi) = let points = gen_points ?n lo hi in let run_one (df,f) i input = let d = df ^ "_" ^ string_of_int i in run_and_analyze d (repeat f input) |> res_scale (1. /. float i) in let run_all i = let inp = input_gen i in List.map (fun f -> run_one f i inp) fs in let results_by_input = List.map run_all points in let results_by_f = transpose results_by_input in points, List.map2 (fun (df,_) rs -> df, rs) fs results_by_f (* returns list of (desc, result list); each sublist is all results for one function *) let print_ranges oc (desc,resl) = fprintf oc "%s\n" desc; list_print ~first:"est " ~last:"\n" ~sep:" " (fun r -> string_of_float r.mean.Bootstrap.point) oc resl; list_print ~first:"lo " ~last:"\n" ~sep:" " (fun r -> string_of_float r.mean.Bootstrap.lower) oc resl; list_print ~first:"hi " ~last:"\n" ~sep:" " (fun r -> string_of_float r.mean.Bootstrap.upper) oc resl let print_2d fn (points,rs) = let oc = open_out fn in output_string oc "multiplot\n"; list_print ~first:"x-values " ~last:"\n" ~sep:" " string_of_int oc points; List.iter (print_ranges oc) rs; close_out oc let print_1d fn resl = let oc = open_out fn in output_string oc "comparison\n"; List.iter (print_result oc) resl; close_out oc batteries-included-3.4.0/benchsuite/lib/dune000066400000000000000000000000741415601150500210410ustar00rootroot00000000000000(library (name bench) (libraries unix) (wrapped false) ) batteries-included-3.4.0/benchsuite/lines_of.ml000066400000000000000000000126601415601150500215510ustar00rootroot00000000000000let readfile fn = let ic = open_in fn in let r = ref [] in (try while true do let l = input_line ic in r := l :: !r done with End_of_file -> ()) ; close_in ic ; List.rev !r let readfile_batteries fn = let open Batteries in File.lines_of fn |> List.of_enum let file_lines_of fn = let ic = open_in fn in BatEnum.suffix_action (fun () -> close_in ic) (BatEnum.from (fun () -> try input_line ic with End_of_file -> raise BatEnum.No_more_elements)) let rfb2 fn = BatList.of_enum (file_lines_of fn) let rfb3 fn = BatList.of_enum (BatIO.lines_of2 (BatFile.open_in fn)) type 'a weak_set = ('a, unit) BatInnerWeaktbl.t type input = { mutable in_read : unit -> char; mutable in_input : bytes -> int -> int -> int; mutable in_close : unit -> unit; in_id: int;(**A unique identifier.*) in_upstream: input weak_set } let unread_string str pos len input = let limit = pos + len in let curr = ref pos in let restore = let old_read = input.in_read in let old_input = input.in_input in fun () -> input.in_read <- old_read; input.in_input <- old_input; () in input.in_read <- (fun () -> if !curr = limit then begin restore (); input.in_read () end else begin incr curr; Bytes.get str (!curr-1) end); input.in_input <- (fun s p l -> let curr' = !curr + l in if curr' < limit then begin Bytes.blit str !curr s p l; curr := curr'; l end else begin let l1 = limit - !curr in Bytes.blit str !curr s p l1; restore (); let l2 = input.in_input s (p + l1) (l - l1) in l1 + l2 end); () let read_line2 = fun input -> let input = Obj.magic input in (* compensate for abstract input type *) let buff_len = 256 in let buff = Bytes.create buff_len in let b = Buffer.create buff_len in let rec find_chunk () = let nread = input.in_input buff 0 buff_len in let rec loop i = if i = nread then None else if Bytes.get buff i = '\n' then Some i else loop (i + 1) in match loop 0 with | Some i -> Buffer.add_subbytes b buff 0 i; (* 'i+1' because we skip the newline *) if i+1 < nread then unread_string buff (i+1) (nread - i - 1) input; Buffer.contents b | None -> Buffer.add_subbytes b buff 0 nread; if nread < buff_len then begin Buffer.contents b end else find_chunk () in find_chunk () (** [apply_enum f x] applies [f] to [x] and converts exceptions [No_more_input] and [Input_closed] to [BatEnum.No_more_elements]*) let apply_enum do_close f x = try f x with | BatIO.No_more_input -> raise BatEnum.No_more_elements | BatInnerIO.Input_closed -> do_close := false; raise BatEnum.No_more_elements (** [close_at_end input e] returns an enumeration which behaves as [e] and has the secondary effect of closing [input] once everything has been read.*) let close_at_end do_close (input:BatIO.input) e = BatEnum.suffix_action (fun () -> if !do_close then BatIO.close_in input) e let make_enum f input = let do_close = ref true in close_at_end do_close input (BatEnum.from (fun () -> apply_enum do_close f input)) let rfb4 fn = BatList.of_enum (make_enum read_line2 (BatFile.open_in fn)) let unread_string2 str pos len input = let limit = pos + len in let curr = ref pos in let restore = let old_read = input.in_read in let old_input = input.in_input in fun () -> input.in_read <- old_read; input.in_input <- old_input; () in input.in_read <- (fun () -> if !curr = limit then begin restore (); input.in_read () end else begin incr curr; Bytes.get str (!curr-1) end); input.in_input <- (fun s p l -> let curr' = !curr + l in if curr' < limit then begin Bytes.blit str !curr s p l; curr := curr'; l end else begin let l1 = limit - !curr in Bytes.blit str !curr s p l1; restore (); l1 end); () let read_line3 = fun input -> let input = Obj.magic input in (* compensate for abstract input type *) let buff_len = 256 in let buff = Bytes.create buff_len in let b = Buffer.create buff_len in let rec find_chunk () = let nread = input.in_input buff 0 buff_len in let rec loop i = if i = nread then None else if Bytes.get buff i = '\n' then Some i else loop (i + 1) in match loop 0 with | Some i -> Buffer.add_subbytes b buff 0 i; (* 'i+1' because we skip the newline *) if i+1 < nread then unread_string2 buff (i+1) (nread - i - 1) input; Buffer.contents b | None -> Buffer.add_subbytes b buff 0 nread; if nread < buff_len then begin Buffer.contents b end else find_chunk () in find_chunk () let rfb5 fn = BatList.of_enum (make_enum read_line3 (BatFile.open_in fn)) let () = Bench.config.Bench.samples <- 300; let funs = [ "readfile", readfile; "readfile_batteries", readfile_batteries; "file_lines_of", rfb2; "lines_of2", rfb3; "push_lines_of", rfb4; "push_lines_of2", rfb5; ] in let results = Bench.bench_funs funs "lines_of.ml" in print_endline "For reading lines_of.ml into a list, "; Bench.summarize results batteries-included-3.4.0/benchsuite/mid.ml000066400000000000000000000015311415601150500205170ustar00rootroot00000000000000let mid1 a b = if (0 <= a && 0 <= b) || (a < 0 && b < 0) then if a <= b then a + ((b-a)/2) else b + ((a-b)/2) else let s = a + b in if s >= 0 then s/2 else s - s/2 let mid2 a b = (a+b)/2 let mid3 a b = if (a >= 0) then if (b >= 0) then a + (b - a) / 2 else (a+b) / 2 else if (b < 0) then a + (b - a) / 2 else (a+b) / 2 let mid4 a b = if (0 <= a && 0 <= b) || (a < 0 && b < 0) then if a <= b then a + ((b-a)/2) else b + ((a-b)/2) else (a + b)/2 let array_len = 10000 let xs = Array.init array_len (fun _ -> BatRandom.full_range_int ()) let harn f n = for _i = 1 to n do for j = 0 to array_len-2 do ignore (f xs.(j) xs.(j+1)); done done let () = Bench.(summarize ~alpha:0.05 (bench_n ["mid1", harn mid1; "mid2", harn mid2; "mid3", harn mid3; "mid4", harn mid4])) batteries-included-3.4.0/benchsuite/popcount.ml000066400000000000000000000066731415601150500216310ustar00rootroot00000000000000let popcount_test = if Sys.word_size = 32 then let k1 = 0x55555555 in let k2 = 0x33333333 in let k3 = 0x0f0f0f0f in (fun x -> let x = x - (x lsr 1) land k1 in let x = ((x lsr 2) land k2) + (x land k2) in let x = (x + (x lsr 4)) land k3 in let x = x + x lsr 8 in (x + x lsr 16) land 0x3f ) else (* word_size = 64 *) (* uses int_of_string to hide these constants from the 32-bit compiler *) let k1 = int_of_string "0x5555_5555_5555_5555" in let k2 = int_of_string "0x3333_3333_3333_3333" in let k4 = int_of_string "0x0f0f_0f0f_0f0f_0f0f" in (fun x -> let x = x - (x lsr 1) land k1 in let x = (x land k2) + ((x lsr 2) land k2) in let x = (x + x lsr 4) land k4 in let x = x + x asr 8 in let x = x + x asr 16 in let x = x + x asr 32 in x land 0x7f ) let popcount = let k1 = 0x55555555 in let k2 = 0x33333333 in let k3 = 0x0f0f0f0f in (fun x -> let x = x - (x lsr 1) land k1 in let x = ((x lsr 2) land k2) + (x land k2) in let x = (x + (x lsr 4)) land k3 in let x = x + x lsr 8 in (x + x lsr 16) land 0x3f ) let popcount2 = (fun x -> let k1 = 0x55555555 in let k2 = 0x33333333 in let k3 = 0x0f0f0f0f in let x = x - (x lsr 1) land k1 in let x = ((x lsr 2) land k2) + (x land k2) in let x = (x + (x lsr 4)) land k3 in let x = x + x lsr 8 in (x + x lsr 16) land 0x3f ) let popcount_sparse x = let rec loop n x = if x = 0 then n else loop (n+1) (x land (x-1)) in loop 0 x (* a takes 256k in 32 bits, 512 in 64 bits *) let a = Array.init (1 lsl 16) (fun i -> popcount i) let popcount_lookup x = a.(x land 0xFFFF) + a.(x lsr 16) (* a takes 64k *) let a = BatString.init (1 lsl 16) (fun i -> Char.chr (popcount i)) let popcount_lookup2 x = Char.code a.[x land 0xFFFF] + Char.code a.[x lsr 16] (* a takes 1k in 32 bits, 2k in 64 bits *) let a = Array.init (1 lsl 8) (fun i -> popcount i) let popcount_byte_lookup x = a.(x land 0xFF) + a.(x lsr 8 land 0xFF) + a.(x lsr 16 land 0xFF) + a.(x lsr 24 land 0xFF) (* a takes 1k in 32 bits, 2k in 64 bits *) let popcount_byte_lookup2 x = let pop = a.(x land 0xFF) in let x = x lsr 8 in let pop = pop + a.(x land 0xFF) in let x = x lsr 8 in let pop = pop + a.(x land 0xFF) in let x = x lsr 8 in let pop = pop + a.(x land 0xFF) in pop let test_sparse = fun n -> for i = 0 to n do ignore (popcount_sparse i) done let test_mask = fun n -> for i = 0 to n do ignore (popcount i) done let test_mask2 = fun n -> for i = 0 to n do ignore (popcount2 i) done let test_masktest = fun n -> for i = 0 to n do ignore (popcount_test i) done let test_lookup = fun n -> for i = 0 to n do ignore (popcount_lookup i) done let test_lookup2 = fun n -> for i = 0 to n do ignore (popcount_lookup2 i) done let test_byte_lookup = fun n -> for i = 0 to n do ignore (popcount_byte_lookup i) done let test_byte_lookup2 = fun n -> for i = 0 to n do ignore (popcount_byte_lookup2 i) done let () = let readings = Bench.bench_n [ "Sparse", test_sparse; "Mask", test_mask; "Mask2", test_mask2; "MaskTest", test_masktest; "Lookup", test_lookup; "Lookup2", test_lookup2; "ByteLookup", test_byte_lookup; "ByteLookup2", test_byte_lookup2; ] in Bench.summarize readings batteries-included-3.4.0/benchsuite/rand_choice.ml000066400000000000000000000014031415601150500222020ustar00rootroot00000000000000open Batteries open Random let choice e = let a = BatArray.of_enum e in let len = Array.length a in Array.get a (int len) let choice2 e = Enum.drop (int (Enum.count e)) e; Enum.get_exn e let choice3 e = if Enum.fast_count e then choice2 e else choice e let test n f = (* data structures to test *) let a = Array.init n identity in let b = List.init n identity in let c () = Random.enum_bits () |> Enum.take n in let d () = 1--n in fun () -> ignore (f (Array.enum a)); ignore (f (List.enum b)); ignore (f (c ())); ignore (f (d ())) let test = test 10_000 let () = Bench.bench ["Choice", test choice; "Choice2", test choice2; "Choice3", test choice3; ] batteries-included-3.4.0/benchsuite/sequence.ml000066400000000000000000002146671415601150500215760ustar00rootroot00000000000000(* ocamlbuild benchsuite/sequence.native -- snoc_front | tee >(./plot) *) module type SIG = sig type 'a t val empty : 'a t val cons : 'a t -> 'a -> 'a t val front : 'a t -> ('a t * 'a) option val map : ('a -> 'b) -> 'a t -> 'b t val snoc : 'a t -> 'a -> 'a t val rear : 'a t -> ('a t * 'a) option val of_enum : 'a BatEnum.t -> 'a t val enum : 'a t -> 'a BatEnum.t val of_backwards : 'a BatEnum.t -> 'a t val backwards : 'a t -> 'a BatEnum.t val fold_left : ('acc -> 'a -> 'acc) -> 'acc -> 'a t -> 'acc val fold_right : ('acc -> 'a -> 'acc) -> 'acc -> 'a t -> 'acc val reverse : 'a t -> 'a t val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> 'a t val append : 'a t -> 'a t -> 'a t val split_at : 'a t -> int -> 'a t * 'a t (* take, drop *) val generate_of_enum : 'a BatEnum.t -> 'a t end module Vect : SIG = struct type 'a t = 'a BatVect.t let empty = BatVect.empty let cons t x = BatVect.prepend x t let snoc t x = BatVect.append x t let map = BatVect.map let front t = if BatVect.is_empty t then None else let n = BatVect.length t in Some (BatVect.sub t 0 (n - 1), BatVect.get t 0) let rear t = if BatVect.is_empty t then None else let n = BatVect.length t in Some (BatVect.sub t 1 (n - 1), BatVect.get t (n - 1)) let of_enum = BatVect.of_enum let enum = BatVect.enum let of_backwards = BatVect.of_backwards let backwards = BatVect.backwards let fold_left = BatVect.fold_left let fold_right f acc t = BatVect.fold_right (fun acc elt -> f elt acc) t acc let reverse _ = assert false let get = BatVect.get let set = BatVect.set let append = BatVect.concat let split_at t n = (BatVect.sub t 0 n, BatVect.sub t n (BatVect.length t - n)) let generate_of_enum = of_enum end module ListOverflow : SIG with type 'a t = 'a list = struct type 'a t = 'a list let empty = [] let length l = let rec aux acc = function | [] -> acc | _ :: t -> aux (acc + 1) t in aux 0 l let cons t x = x :: t let front = function | [] -> None | h :: t -> Some (t, h) let rec map f = function | [] -> [] | h :: t -> let h = f h in let t = map f t in h :: t let rec rev_append l1 l2 = match l1 with | [] -> l2 | h1 :: t1 -> rev_append t1 (h1 :: l2) let reverse l = rev_append l [] let rec snoc t x = match t with | [] -> [x] | h :: t -> h :: snoc t x let rear = function | [] -> None | h :: t -> let rec aux acc prev = function | [] -> Some (reverse acc, prev) | h :: t -> aux (h :: acc) h t in aux [h] h t let rec of_enum e = match BatEnum.get e with | None -> [] | Some h -> h :: of_enum e let generate_of_enum = of_enum let of_backwards e = let rec aux acc e = match BatEnum.get e with | None -> acc | Some h -> aux (h :: acc) e in aux [] e let enum l = let rec make lr count = BatEnum.make ~next:(fun () -> match !lr with | [] -> raise BatEnum.No_more_elements | h :: t -> decr count; lr := t; h ) ~count:(fun () -> if !count < 0 then count := length !lr; !count ) ~clone:(fun () -> make (ref !lr) (ref !count) ) in make (ref l) (ref (-1)) let backwards l = enum (reverse l) let rec fold_left f acc = function | [] -> acc | h :: t -> fold_left f (f acc h) t let rec fold_right f acc l = match l with | [] -> acc | h :: t -> f (fold_right f acc t) h let rec get t i = match i, t with | _, [] -> invalid_arg "Index out of bounds" | 0, h :: _ -> h | _, _ :: t -> get t (i - 1) let rec set t i v = match i, t with | _, [] -> invalid_arg "Index out of bounds" | 0, _h :: t -> v :: t | _, h :: t -> h :: set t (i - 1) v let rec append l1 l2 = match l1 with | [] -> l2 | h :: t -> h :: append t l2 let split_at l i = let rec aux acc i l = match i, l with | 0, _ -> reverse acc, l | _, [] -> invalid_arg "Index out of bounds" | _, h :: t -> aux (h :: acc) (i - 1) t in aux [] i l end module ListTail : sig include SIG with type 'a t = 'a list val map2 : ('a -> 'b) -> 'a list -> 'b list end = struct type 'a t = 'a list let empty = [] let length l = let rec aux acc = function | [] -> acc | _ :: t -> aux (acc + 1) t in aux 0 l let cons t x = x :: t let front = function | [] -> None | h :: t -> Some (t, h) let rec rev_append l1 l2 = match l1 with | [] -> l2 | h1 :: t1 -> rev_append t1 (h1 :: l2) let reverse l = rev_append l [] let map f l = let rec aux f acc = function | [] -> reverse acc | h :: t -> aux f (f h :: acc) t in aux f [] l (* copy pasted from core lib *) let rec count_map ~f 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 > 1000 then map f tl else count_map ~f tl (ctr + 1)) let map2 f l = count_map ~f l 0 let snoc t x = let rec aux x acc = function | [] -> reverse (x :: acc) | h :: t -> aux x (h :: acc) t in aux x [] t let rear = function | [] -> None | h :: t -> let rec aux acc prev = function | [] -> Some (reverse acc, prev) | h :: t -> aux (h :: acc) h t in aux [h] h t let of_backwards e = let rec aux acc e = match BatEnum.get e with | None -> acc | Some h -> aux (h :: acc) e in aux [] e let of_enum e = reverse (of_backwards e) let generate_of_enum = of_enum let enum l = let rec make lr count = BatEnum.make ~next:(fun () -> match !lr with | [] -> raise BatEnum.No_more_elements | h :: t -> decr count; lr := t; h ) ~count:(fun () -> if !count < 0 then count := length !lr; !count ) ~clone:(fun () -> make (ref !lr) (ref !count) ) in make (ref l) (ref (-1)) let backwards l = enum (reverse l) let rec fold_left f acc = function | [] -> acc | h :: t -> fold_left f (f acc h) t let fold_right f acc l = fold_left f acc (reverse l) let rec get t i = match i, t with | _, [] -> invalid_arg "Index out of bounds" | 0, h :: _ -> h | _, _ :: t -> get t (i - 1) let set t i v = let rec aux i v acc t = match i, t with | _, [] -> invalid_arg "Index out of bounds" | 0, _ :: t -> rev_append acc (v :: t) | _, h :: t -> aux (i - 1) v (h :: acc) t in aux i v [] t let append l1 l2 = rev_append (reverse l1) l2 let split_at l i = let rec aux acc i l = match i, l with | 0, _ -> reverse acc, l | _, [] -> invalid_arg "Index out of bounds" | _, h :: t -> aux (h :: acc) (i - 1) t in aux [] i l end module ListTailModCons : sig include SIG with type 'a t = 'a list val map2 : ('a -> 'b) -> 'a list -> 'b list end = struct type 'a t = 'a BatList.t let empty = [] let cons t x = x :: t let snoc t x = BatList.append t [x] let map = BatList.map let set_tail (l : 'a list) (v : 'a list) = Obj.set_field (Obj.repr l) 1 (Obj.repr v) let map2 f = function | [] -> [] | h :: t -> let rec loop f dst = function | [] -> () | [a] -> let a = f a in set_tail dst (a :: []) | [a; b] -> let a = f a in let b = f b in set_tail dst (a :: b :: []) | [a; b; c] -> let a = f a in let b = f b in let c = f c in set_tail dst (a :: b :: c :: []) | [a; b; c; d] -> let a = f a in let b = f b in let c = f c in let d = f d in set_tail dst (a :: b :: c :: d :: []) | [a; b; c; d; e] -> let a = f a in let b = f b in let c = f c in let d = f d in let e = f e in set_tail dst (a :: b :: c :: d :: e :: []) | a :: b :: c :: d :: e :: t -> let a = f a in let b = f b in let c = f c in let d = f d in let e = f e in let last = e :: [] in set_tail dst (a :: b :: c :: d :: last); loop f last t in let r = f h :: [] in loop f r t; Obj.magic r let rec count_map ~f 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 > 1000 then map2 f tl else count_map ~f tl (ctr + 1)) let map2 f l = count_map ~f l 0 let append = BatList.append let get = BatList.nth let split_at i t = BatList.split_at t i let set t i v = (* FIXME *) let l1, l2 = split_at t i in match l2 with | [] -> invalid_arg "aze" | _ :: t -> append l1 (v :: t) let reverse = BatList.rev let fold_left = BatList.fold_left let fold_right f init l = let rec tail_loop acc = function | [] -> acc | h :: t -> tail_loop (f acc h) t in let rec loop n = function | [] -> init | h :: t -> if n < 1000 then f (loop (n+1) t) h else f (tail_loop init (reverse t)) h in loop 0 l let enum = BatList.enum let backwards = BatList.backwards let of_enum = BatList.of_enum let generate_of_enum = of_enum let of_backwards = BatList.of_backwards let front = function | [] -> None | h :: t -> Some (t, h) let rear = function (*FIXME*) | [] -> None | h :: t -> let rec aux acc prev = function | [] -> Some (reverse acc, prev) | h :: t -> aux (h :: acc) h t in aux [h] h t end module Deque : SIG = struct type 'a t = {front : 'a list; len : int; rear : 'a list} let empty = {front = []; rear = []; len = 0} let split_at _ _ = assert false let append _ _ = assert false let set _ _ _ = assert false let get _ _ = assert false let reverse {front; len; rear} = {front = rear; rear = front; len} let fold_left f acc {front; rear; len = _} = let acc = ListTailModCons.fold_left f acc front in ListTailModCons.fold_right f acc rear let fold_right f acc {front; rear; len = _} = let acc = ListTailModCons.fold_left f acc rear in ListTailModCons.fold_right f acc front let enum {front; rear; _} = BatEnum.append (ListTailModCons.enum front) (ListTailModCons.backwards rear) let backwards {front; rear; _} = BatEnum.append (ListTailModCons.enum rear) (ListTailModCons.backwards front) let of_enum e = let l = ListTailModCons.of_backwards e in {front = []; rear = l; len = List.length l} let of_backwards e = let l = ListTailModCons.of_backwards e in {front = l; rear = []; len = List.length l} let front q = match q with | {front = h :: front; len = len; _} -> Some ({ q with front = front ; len = len - 1 }, h) | {rear = rear; len = len; _} -> let rear, rev_front = BatList.split_at (len / 2) rear in let front = List.rev rev_front in match front with | [] -> None | h :: t -> Some ({ front = t ; len = len - 1 ; rear = rear ; }, h) let rear q = match q with | {rear = h :: rear; len = len; _} -> Some ({ q with rear = rear ; len = len - 1 }, h) | {front = front; len = len; _} -> let front, rev_rear = BatList.split_at (len / 2) front in let rear = List.rev rev_rear in match rear with | [] -> None | h :: t -> Some ({ rear = t ; len = len - 1 ; front = front ; }, h) let cons {front; len; rear; _} x = {front = x :: front; len = len + 1; rear = rear} let snoc {front; len; rear; _} x = {front = front; len = len + 1; rear = x :: rear} let map f {front; rear; len; _} = let front = ListTailModCons.map f front in let rear = List.rev (ListTailModCons.map f (List.rev rear)) in {front; rear; len} let generate_of_enum e = let l = of_enum e in match front l with | None -> l | Some (t, x) -> cons t x end module GenFingerTree = struct type 'a monoid = { zero : 'a; combine : 'a -> 'a -> 'a ; } exception Empty type ('a, 'm) node = | Node2 of 'm * 'a * 'a | Node3 of 'm * 'a * 'a * 'a type ('a, 'm) digit = | One of 'm * 'a | Two of 'm * 'a * 'a | Three of 'm * 'a * 'a * 'a | Four of 'm * 'a * 'a * 'a * 'a type ('a, 'm) fg = | Nil | Single of 'a | Deep of 'm * ('a, 'm) digit * (('a, 'm) node, 'm) fg * ('a, 'm) digit let empty = Nil let singleton a = Single a let is_empty = function | Nil -> true | Single _ | Deep _ -> false let fold_right_node f acc = function | Node2 (_, a, b) -> f (f acc b) a | Node3 (_, a, b, c) -> f (f (f acc c) b) a let fold_left_node f acc = function | Node2 (_, a, b) -> f (f acc a) b | Node3 (_, a, b, c) -> f (f (f acc a) b) c let fold_right_digit f acc = function | One (_, a) -> f acc a | Two (_, a, b) -> f (f acc b) a | Three (_, a, b, c) -> f (f (f acc c) b) a | Four (_, a, b, c, d) -> f (f (f (f acc d) c) b) a let fold_left_digit f acc = function | One (_, a) -> f acc a | Two (_, a, b) -> f (f acc a) b | Three (_, a, b, c) -> f (f (f acc a) b) c | Four (_, a, b, c, d) -> f (f (f (f acc a) b) c) d let rec fold_right : 'acc 'a 'm. ('acc -> 'a -> 'acc) -> 'acc -> ('a, 'm) fg -> 'acc = fun f acc -> function | Nil -> acc | Single x -> f acc x | Deep (_, pr, m, sf) -> let acc = fold_right_digit f acc sf in let acc = fold_right (fun acc elt -> fold_right_node f acc elt) acc m in let acc = fold_right_digit f acc pr in acc let rec fold_left : 'acc 'a 'm. ('acc -> 'a -> 'acc) -> 'acc -> ('a, 'm) fg -> 'acc = fun f acc -> function | Nil -> acc | Single x -> f acc x | Deep (_, pr, m, sf) -> let acc = fold_left_digit f acc pr in let acc = fold_left (fun acc elt -> fold_left_node f acc elt) acc m in let acc = fold_left_digit f acc sf in acc type ('wrapped_type, 'a, 'm) wrap = monoid:'m monoid -> measure:('a -> 'm) -> 'wrapped_type let measure_node = function | Node2 (v, _, _) | Node3 (v, _, _, _) -> v let measure_digit = function | One (v, _) | Two (v, _, _) | Three (v, _, _, _) | Four (v, _, _, _, _) -> v let measure_t_node ~monoid = function | Nil -> monoid.zero | Single x -> measure_node x | Deep (v, _, _, _) -> v let measure_t ~monoid ~measure = function | Nil -> monoid.zero | Single x -> measure x | Deep (v, _, _, _) -> v let node2 ~monoid ~measure a b = Node2 (monoid.combine (measure a) (measure b), a, b) let node2_node ~monoid a b = Node2 (monoid.combine (measure_node a) (measure_node b), a, b) let node3 ~monoid ~measure a b c = Node3 (monoid.combine (measure a) (monoid.combine (measure b) (measure c)), a, b, c) let node3_node ~monoid a b c = Node3 (monoid.combine (measure_node a) (monoid.combine (measure_node b) (measure_node c)), a, b, c) let deep ~monoid pr m sf = let v = measure_digit pr in let v = monoid.combine v (measure_t_node ~monoid m) in let v = monoid.combine v (measure_digit sf) in Deep (v, pr, m, sf) let one_node a = One (measure_node a, a) let one ~measure a = One (measure a, a) let two_node ~monoid a b = Two (monoid.combine (measure_node a) (measure_node b), a, b) let two ~monoid ~measure a b = Two (monoid.combine (measure a) (measure b), a, b) let three_node ~monoid a b c = Three (monoid.combine (monoid.combine (measure_node a) (measure_node b)) (measure_node c), a, b, c) let three ~monoid ~measure a b c = Three (monoid.combine (monoid.combine (measure a) (measure b)) (measure c), a, b, c) let four_node ~monoid a b c d = Four (monoid.combine (monoid.combine (measure_node a) (measure_node b)) (monoid.combine (measure_node c) (measure_node d)), a, b, c, d) let four ~monoid ~measure a b c d = Four (monoid.combine (monoid.combine (measure a) (measure b)) (monoid.combine (measure c) (measure d)), a, b, c, d) let cons_digit_node ~monoid d x = match d with | One (v, a) -> Two (monoid.combine (measure_node x) v, x, a) | Two (v, a, b) -> Three (monoid.combine (measure_node x) v, x, a, b) | Three (v, a, b, c) -> Four (monoid.combine (measure_node x) v, x, a, b, c) | Four _ -> assert false let cons_digit ~monoid ~measure d x = match d with | One (v, a) -> Two (monoid.combine (measure x) v, x, a) | Two (v, a, b) -> Three (monoid.combine (measure x) v, x, a, b) | Three (v, a, b, c) -> Four (monoid.combine (measure x) v, x, a, b, c) | Four _ -> assert false let snoc_digit_node ~monoid d x = match d with | One (v, a) -> Two (monoid.combine v (measure_node x), a, x) | Two (v, a, b) -> Three (monoid.combine v (measure_node x), a, b, x) | Three (v, a, b, c) -> Four (monoid.combine v (measure_node x), a, b, c, x) | Four _ -> assert false let snoc_digit ~monoid ~measure d x = match d with | One (v, a) -> Two (monoid.combine v (measure x), a, x) | Two (v, a, b) -> Three (monoid.combine v (measure x), a, b, x) | Three (v, a, b, c) -> Four (monoid.combine v (measure x), a, b, c, x) | Four _ -> assert false let rec cons_aux : 'a 'm. monoid:'m monoid -> (('a, 'm) node, 'm) fg -> ('a, 'm) node -> (('a, 'm) node, 'm) fg = fun ~monoid t a -> match t with | Nil -> Single a | Single b -> deep ~monoid (one_node a) Nil (one_node b) | Deep (_, Four (_, b, c, d, e), m, sf) -> deep ~monoid (two_node ~monoid a b) (cons_aux ~monoid m (node3_node ~monoid c d e)) sf | Deep (v, pr, m, sf) -> Deep (monoid.combine (measure_node a) v, cons_digit_node ~monoid pr a, m, sf) let cons ~monoid ~measure t a = match t with | Nil -> Single a | Single b -> deep ~monoid (one ~measure a) Nil (one ~measure b) | Deep (_, Four (_, b, c, d, e), m, sf) -> deep ~monoid (two ~monoid ~measure a b) (cons_aux ~monoid m (node3 ~monoid ~measure c d e)) sf | Deep (v, pr, m, sf) -> Deep (monoid.combine (measure a) v, cons_digit ~monoid ~measure pr a, m, sf) let rec snoc_aux : 'a 'm. monoid:'m monoid -> (('a, 'm) node, 'm) fg -> ('a, 'm) node -> (('a, 'm) node, 'm) fg = fun ~monoid t a -> match t with | Nil -> Single a | Single b -> deep ~monoid (one_node b) Nil (one_node a) | Deep (_, pr, m, Four (_, b, c, d, e)) -> deep ~monoid pr (snoc_aux ~monoid m (node3_node ~monoid b c d)) (two_node ~monoid e a) | Deep (v, pr, m, sf) -> Deep (monoid.combine v (measure_node a), pr, m, snoc_digit_node ~monoid sf a) let snoc ~monoid ~measure t a = match t with | Nil -> Single a | Single b -> deep ~monoid (one ~measure b) Nil (one ~measure a) | Deep (_, pr, m, Four (_, b, c, d, e)) -> deep ~monoid pr (snoc_aux ~monoid m (node3 ~monoid ~measure b c d)) (two ~measure ~monoid e a) | Deep (v, pr, m, sf) -> Deep (monoid.combine v (measure a), pr, m, snoc_digit ~monoid ~measure sf a) let to_tree_digit_node ~monoid d = match d with | One (_, a) -> Single a | Two (v, a, b) -> Deep (v, one_node a, Nil, one_node b) | Three (v, a, b, c) -> Deep (v, two_node ~monoid a b, Nil, one_node c) | Four (v, a, b, c, d) -> Deep (v, three_node ~monoid a b c, Nil, one_node d) let to_tree_digit ~monoid ~measure d = match d with | One (_, a) -> Single a | Two (v, a, b) -> Deep (v, one ~measure a, Nil, one ~measure b) | Three (v, a, b, c) -> Deep (v, two ~monoid ~measure a b, Nil, one ~measure c) | Four (v, a, b, c, d) -> Deep (v, three ~monoid ~measure a b c, Nil, one ~measure d) let to_tree_list ~monoid ~measure = function | [] -> Nil | [a] -> Single a | [a; b] -> deep ~monoid (one ~measure a) Nil (one ~measure b) | [a; b; c] -> deep ~monoid (two ~monoid ~measure a b) Nil (one ~measure c) | [a; b; c; d] -> deep ~monoid (three ~monoid ~measure a b c) Nil (one ~measure d) | _ -> assert false let to_digit_node = function | Node2 (v, a, b) -> Two (v, a, b) | Node3 (v, a, b, c) -> Three (v, a, b, c) let to_digit_list ~monoid ~measure = function | [a] -> one ~measure a | [a; b] -> two ~monoid ~measure a b | [a; b; c] -> three ~monoid ~measure a b c | [a; b; c; d] -> four ~monoid ~measure a b c d | _ -> assert false let to_digit_list_node ~monoid = function | [a] -> one_node a | [a; b] -> two_node ~monoid a b | [a; b; c] -> three_node ~monoid a b c | [a; b; c; d] -> four_node ~monoid a b c d | _ -> assert false let head_digit = function | One (_, a) | Two (_, a, _) | Three (_, a, _, _) | Four (_, a, _, _, _) -> a let last_digit = function | One (_, a) | Two (_, _, a) | Three (_, _, _, a) | Four (_, _, _, _, a) -> a let tail_digit_node ~monoid = function | One _ -> assert false | Two (_, _, a) -> one_node a | Three (_, _, a, b) -> two_node ~monoid a b | Four (_, _, a, b, c) -> three_node ~monoid a b c let tail_digit ~monoid ~measure = function | One _ -> assert false | Two (_, _, a) -> one ~measure a | Three (_, _, a, b) -> two ~monoid ~measure a b | Four (_, _, a, b, c) -> three ~monoid ~measure a b c let init_digit_node ~monoid = function | One _ -> assert false | Two (_, a, _) -> one_node a | Three (_, a, b, _) -> two_node ~monoid a b | Four (_, a, b, c, _) -> three_node ~monoid a b c let init_digit ~monoid ~measure = function | One _ -> assert false | Two (_, a, _) -> one ~measure a | Three (_, a, b, _) -> two ~monoid ~measure a b | Four (_, a, b, c, _) -> three ~monoid ~measure a b c type ('a, 'rest) view = | Vnil | Vcons of 'a * 'rest let rec view_left_aux : 'a 'm. monoid:'m monoid -> (('a, 'm) node, 'm) fg -> (('a, 'm) node, (('a, 'm) node, 'm) fg) view = fun ~monoid -> function | Nil -> Vnil | Single x -> Vcons (x, Nil) | Deep (_, One (_, a), m, sf) -> let vcons = match view_left_aux ~monoid m with | Vnil -> to_tree_digit_node ~monoid sf | Vcons (a, m') -> deep ~monoid (to_digit_node a) m' sf in Vcons (a, vcons) | Deep (_, pr, m, sf) -> let vcons = deep ~monoid (tail_digit_node ~monoid pr) m sf in Vcons (head_digit pr, vcons) let view_left ~monoid ~measure = function | Nil -> Vnil | Single x -> Vcons (x, Nil) | Deep (_, One (_, a), m, sf) -> let vcons = match view_left_aux ~monoid m with | Vnil -> to_tree_digit ~monoid ~measure sf | Vcons (a, m') -> deep ~monoid (to_digit_node a) m' sf in Vcons (a, vcons) | Deep (_, pr, m, sf) -> let vcons = deep ~monoid (tail_digit ~monoid ~measure pr) m sf in Vcons (head_digit pr, vcons) let rec view_right_aux : 'a 'm. monoid:'m monoid -> (('a, 'm) node, 'm) fg -> (('a, 'm) node, (('a, 'm) node, 'm) fg) view = fun ~monoid -> function | Nil -> Vnil | Single x -> Vcons (x, Nil) | Deep (_, pr, m, One (_, a)) -> let vcons = match view_right_aux ~monoid m with | Vnil -> to_tree_digit_node ~monoid pr | Vcons (a, m') -> deep ~monoid pr m' (to_digit_node a) in Vcons (a, vcons) | Deep (_, pr, m, sf) -> let vcons = deep ~monoid pr m (init_digit_node ~monoid sf) in Vcons (last_digit sf, vcons) let view_right ~monoid ~measure = function | Nil -> Vnil | Single x -> Vcons (x, Nil) | Deep (_, pr, m, One (_, a)) -> let vcons = match view_right_aux ~monoid m with | Vnil -> to_tree_digit ~monoid ~measure pr | Vcons (a, m') -> deep ~monoid pr m' (to_digit_node a) in Vcons (a, vcons) | Deep (_, pr, m, sf) -> let vcons = deep ~monoid pr m (init_digit ~monoid ~measure sf) in Vcons (last_digit sf, vcons) let head_exn = function | Nil -> raise Empty | Single a -> a | Deep (_, pr, _, _) -> head_digit pr let head = function | Nil -> None | Single a -> Some a | Deep (_, pr, _, _) -> Some (head_digit pr) let last_exn = function | Nil -> raise Empty | Single a -> a | Deep (_, _, _, sf) -> last_digit sf let last = function | Nil -> None | Single a -> Some a | Deep (_, _, _, sf) -> Some (last_digit sf) let tail ~monoid ~measure t = match view_left ~monoid ~measure t with | Vnil -> None | Vcons (_, tl) -> Some tl let tail_exn ~monoid ~measure t = match view_left ~monoid ~measure t with | Vnil -> raise Empty | Vcons (_, tl) -> tl let front ~monoid ~measure t = match view_left ~monoid ~measure t with | Vnil -> None | Vcons (hd, tl) -> Some (tl, hd) let front_exn ~monoid ~measure t = match view_left ~monoid ~measure t with | Vnil -> raise Empty | Vcons (hd, tl) -> (tl, hd) let init ~monoid ~measure t = match view_right ~monoid ~measure t with | Vnil -> None | Vcons (_, tl) -> Some tl let init_exn ~monoid ~measure t = match view_right ~monoid ~measure t with | Vnil -> raise Empty | Vcons (_, tl) -> tl let rear ~monoid ~measure t = match view_right ~monoid ~measure t with | Vnil -> None | Vcons (hd, tl) -> Some (tl, hd) let rear_exn ~monoid ~measure t = match view_right ~monoid ~measure t with | Vnil -> raise Empty | Vcons (hd, tl) -> (tl, hd) let nodes = let add_digit_to digit l = match digit with | One (_, a) -> a :: l | Two (_, a, b) -> a :: b :: l | Three (_, a, b, c) -> a :: b :: c :: l | Four (_, a, b, c, d) -> a :: b :: c :: d :: l in let rec nodes_aux ~monoid ~measure ts sf2 = match ts, sf2 with | [], One _ -> assert false | [], Two (_, a, b) | [a], One (_, b) -> [node2 ~monoid ~measure a b] | [], Three (_, a, b, c) | [a], Two (_, b, c) | [a; b], One (_, c) -> [node3 ~monoid ~measure a b c] | [], Four (_, a, b, c, d) | [a], Three (_, b, c, d) | [a; b], Two (_, c, d) | [a; b; c], One (_, d) -> [node2 ~monoid ~measure a b; node2 ~monoid ~measure c d] | a :: b :: c :: ts, _ -> node3 ~monoid ~measure a b c :: nodes_aux ~monoid ~measure ts sf2 | [a], Four (_, b, c, d, e) | [a; b], Three (_, c, d, e) -> [node3 ~monoid ~measure a b c; node2 ~monoid ~measure d e] | [a; b], Four (_, c, d, e, f) -> [node3 ~monoid ~measure a b c; node3 ~monoid ~measure d e f] in fun ~monoid ~measure sf1 ts sf2 -> let ts = add_digit_to sf1 ts in nodes_aux ~monoid ~measure ts sf2 let rec app3 : 'a 'm. monoid:'m monoid -> measure:('a -> 'm) -> ('a, 'm) fg -> 'a list -> ('a, 'm) fg -> ('a, 'm) fg = fun ~monoid ~measure t1 elts t2 -> match t1, t2 with | Nil, _ -> List.fold_right (fun elt acc -> cons ~monoid ~measure acc elt) elts t2 | _, Nil -> List.fold_left (fun acc elt -> snoc ~monoid ~measure acc elt) t1 elts | Single x1, _ -> cons ~monoid ~measure (List.fold_right (fun elt acc -> cons ~monoid ~measure acc elt) elts t2) x1 | _, Single x2 -> snoc ~monoid ~measure (List.fold_left (fun acc elt -> snoc ~monoid ~measure acc elt) t1 elts) x2 | Deep (_, pr1, m1, sf1), Deep (_, pr2, m2, sf2) -> deep ~monoid pr1 (app3 ~monoid ~measure:measure_node m1 (nodes ~monoid ~measure sf1 elts pr2) m2) sf2 let append ~monoid ~measure t1 t2 = app3 ~monoid ~measure t1 [] t2 let reverse_digit_node ~monoid rev_a = function | One (_, a) -> one_node (rev_a a) | Two (_, a, b) -> two_node ~monoid (rev_a b) (rev_a a) | Three (_, a, b, c) -> three_node ~monoid (rev_a c) (rev_a b) (rev_a a) | Four (_, a, b, c, d) -> four_node ~monoid (rev_a d) (rev_a c) (rev_a b) (rev_a a) let reverse_digit ~monoid ~measure = function | One _ as d -> d | Two (_, a, b) -> two ~monoid ~measure b a | Three (_, a, b, c) -> three ~monoid ~measure c b a | Four (_, a, b, c, d) -> four ~monoid ~measure d c b a let reverse_node_node ~monoid rev_a = function | Node2 (_, a, b) -> node2_node ~monoid (rev_a b) (rev_a a) | Node3 (_, a, b, c) -> node3_node ~monoid (rev_a c) (rev_a b) (rev_a a) let reverse_node ~monoid ~measure = function | Node2 (_, a, b) -> node2 ~monoid ~measure b a | Node3 (_, a, b, c) -> node3 ~monoid ~measure c b a let rec reverse_aux : 'a 'm. monoid:'m monoid -> (('a, 'm) node -> ('a, 'm) node) -> (('a, 'm) node, 'm) fg -> (('a, 'm) node, 'm) fg = fun ~monoid reverse_a -> function | Nil -> Nil | Single a -> Single (reverse_a a) | Deep (_, pr, m, sf) -> let rev_pr = reverse_digit_node ~monoid reverse_a pr in let rev_sf = reverse_digit_node ~monoid reverse_a sf in let rev_m = reverse_aux ~monoid (reverse_node_node ~monoid (reverse_a)) m in deep ~monoid rev_sf rev_m rev_pr let reverse ~monoid ~measure = function | Nil | Single _ as t -> t | Deep (_, pr, m, sf) -> let rev_pr = reverse_digit ~monoid ~measure pr in let rev_sf = reverse_digit ~monoid ~measure sf in let rev_m = reverse_aux ~monoid (reverse_node ~monoid ~measure) m in deep ~monoid rev_sf rev_m rev_pr type ('a, 'rest) split = Split of 'rest * 'a * 'rest let split_digit ~monoid ~measure p i = function | One (_, a) -> Split ([], a, []) | Two (_, a, b) -> let i' = monoid.combine i (measure a) in if p i' then Split ([], a, [b]) else Split ([a], b, []) | Three (_, a, b, c) -> let i' = monoid.combine i (measure a) in if p i' then Split ([], a, [b; c]) else let i'' = monoid.combine i' (measure b) in if p i'' then Split ([a], b, [c]) else Split ([a; b], c, []) | Four (_, a, b, c, d) -> let i' = monoid.combine i (measure a) in if p i' then Split ([], a, [b; c; d]) else let i'' = monoid.combine i' (measure b) in if p i'' then Split ([a], b, [c; d]) else let i''' = monoid.combine i'' (measure c) in if p i''' then Split ([a; b], c, [d]) else Split ([a; b; c], d, []) let deep_left ~monoid ~measure pr m sf = match pr with | [] -> ( match view_left ~monoid ~measure:measure_node m with | Vnil -> to_tree_digit ~monoid ~measure sf | Vcons (a, m') -> deep ~monoid (to_digit_node a) m' sf ) | _ -> deep ~monoid (to_digit_list ~monoid ~measure pr) m sf let deep_right ~monoid ~measure pr m sf = match sf with | [] -> ( match view_right ~monoid ~measure:measure_node m with | Vnil -> to_tree_digit ~monoid ~measure pr | Vcons (a, m') -> deep ~monoid pr m' (to_digit_node a) ) | _ -> deep ~monoid pr m (to_digit_list ~monoid ~measure sf) let rec split_tree : 'a 'm. monoid:'m monoid -> measure:('a -> 'm) -> ('m -> bool) -> 'm -> ('a, 'm) fg -> ('a, ('a, 'm) fg) split = fun ~monoid ~measure p i -> function | Nil -> raise Empty | Single x -> Split (Nil, x, Nil) | Deep (_, pr, m, sf) -> let vpr = monoid.combine i (measure_digit pr) in if p vpr then let Split (l, x, r) = split_digit ~monoid ~measure p i pr in Split (to_tree_list ~monoid ~measure l, x, deep_left ~monoid ~measure r m sf) else let vm = monoid.combine vpr (measure_t_node ~monoid m) in if p vm then let Split (ml, xs, mr) = split_tree ~monoid ~measure:measure_node p vpr m in let Split (l, x, r) = split_digit ~monoid ~measure p (monoid.combine vpr (measure_t_node ~monoid ml)) (to_digit_node xs) in Split (deep_right ~monoid ~measure pr ml l, x, deep_left ~monoid ~measure r mr sf) else let Split (l, x, r) = split_digit ~monoid ~measure p vm sf in Split (deep_right ~monoid ~measure pr m l, x, to_tree_list ~monoid ~measure r) let split ~monoid ~measure f t = match t with | Nil -> (Nil, Nil) | _ -> if f (measure_t ~monoid ~measure t) then let Split (l, x, r) = split_tree ~monoid ~measure f monoid.zero t in (l, cons ~monoid ~measure r x) else (t, Nil) let lookup_digit ~monoid ~measure p i = function | One (_, a) -> monoid.zero, a | Two (_, a, b) -> let m_a = measure a in let i' = monoid.combine i m_a in if p i' then monoid.zero, a else m_a, b | Three (_, a, b, c) -> let m_a = measure a in let i' = monoid.combine i m_a in if p i' then monoid.zero, a else let m_b = measure b in let i'' = monoid.combine i' m_b in if p i'' then m_a, b else monoid.combine m_a m_b, c | Four (_, a, b, c, d) -> let m_a = measure a in let i' = monoid.combine i m_a in if p i' then monoid.zero, a else let m_b = measure b in let i'' = monoid.combine i' m_b in if p i'' then m_a, b else let m_c = measure c in let i''' = monoid.combine i'' m_c in if p i''' then monoid.combine m_a m_b, c else monoid.combine (monoid.combine m_a m_b) m_c, d let lookup_node ~monoid ~measure p i = function | Node2 (_, a, b) -> let m_a = measure a in let i' = monoid.combine i m_a in if p i' then monoid.zero, a else m_a, b | Node3 (_, a, b, c) -> let m_a = measure a in let i' = monoid.combine i m_a in if p i' then monoid.zero, a else let m_b = measure b in let i'' = monoid.combine i' m_b in if p i'' then m_a, b else monoid.combine m_a m_b, c let rec lookup_tree : 'a 'm. monoid:'m monoid -> measure:('a -> 'm) -> ('m -> bool) -> 'm -> ('a, 'm) fg -> 'm * 'a = fun ~monoid ~measure p i -> function | Nil -> raise Empty | Single x -> monoid.zero, x | Deep (_, pr, m, sf) -> let m_pr = measure_digit pr in let vpr = monoid.combine i m_pr in if p vpr then lookup_digit ~monoid ~measure p i pr else let m_m = measure_t_node ~monoid m in let vm = monoid.combine vpr m_m in if p vm then let v_left, node = lookup_tree ~monoid ~measure:measure_node p vpr m in let v, x = lookup_node ~monoid ~measure p (monoid.combine vpr v_left) node in monoid.combine (monoid.combine m_pr v_left) v, x else let v, x = lookup_digit ~monoid ~measure p vm sf in monoid.combine (monoid.combine m_pr m_m) v, x let lookup ~monoid ~measure p t = snd (lookup_tree ~monoid ~measure p monoid.zero t) let enum_digit enum_a d k = match d with | One (_, a) -> enum_a a k | Two (_, a, b) -> enum_a a (fun () -> enum_a b k) | Three (_, a, b, c) -> enum_a a (fun () -> enum_a b (fun () -> enum_a c k)) | Four (_, a, b, c, d) -> enum_a a (fun () -> enum_a b (fun () -> enum_a c (fun () -> enum_a d k))) let enum_digit_backwards enum_a d k = match d with | One (_, a) -> enum_a a k | Two (_, a, b) -> enum_a b (fun () -> enum_a a k) | Three (_, a, b, c) -> enum_a c (fun () -> enum_a b (fun () -> enum_a a k)) | Four (_, a, b, c, d) -> enum_a d (fun () -> enum_a c (fun () -> enum_a b (fun () -> enum_a a k))) let enum_node enum_a n k = match n with | Node2 (_, a, b) -> enum_a a (fun () -> enum_a b k) | Node3 (_, a, b, c) -> enum_a a (fun () -> enum_a b (fun () -> enum_a c k)) let enum_node_backwards enum_a n k = match n with | Node2 (_, a, b) -> enum_a b (fun () -> enum_a a k) | Node3 (_, a, b, c) -> enum_a c (fun () -> enum_a b (fun () -> enum_a a k)) let enum_base a k = a, k type 'a iter = unit -> 'a ret and 'a ret = 'a * 'a iter type ('input, 'output) iter_into = 'input -> 'output iter -> 'output ret let rec enum_aux : 'v 'a 'm. ('a, 'v) iter_into -> (('a, 'm) fg, 'v) iter_into = fun enum_a t k -> match t with | Nil -> k () | Single a -> enum_a a k | Deep (_, pr, m, sf) -> enum_digit enum_a pr (fun () -> enum_aux (enum_node enum_a) m (fun () -> enum_digit enum_a sf k ) ) let enum_cps t = enum_aux enum_base t (fun () -> raise BatEnum.No_more_elements) let rec enum_aux_backwards : 'v 'a 'm. ('a, 'v) iter_into -> (('a, 'm) fg, 'v) iter_into = fun enum_a t k -> match t with | Nil -> k () | Single a -> enum_a a k | Deep (_, pr, m, sf) -> enum_digit_backwards enum_a sf (fun () -> enum_aux_backwards (enum_node_backwards enum_a) m (fun () -> enum_digit_backwards enum_a pr k ) ) let enum_cps_backwards t = enum_aux_backwards enum_base t (fun () -> raise BatEnum.No_more_elements) let enum t = BatEnum.from_loop (fun () -> enum_cps t) (fun k -> k ()) let backwards t = BatEnum.from_loop (fun () -> enum_cps_backwards t) (fun k -> k ()) let of_enum ~monoid ~measure enum = BatEnum.fold (fun t elt -> snoc ~monoid ~measure t elt) empty enum let of_backwards ~monoid ~measure enum = BatEnum.fold (fun t elt -> cons ~monoid ~measure t elt) empty enum let measure = measure_t let map ~monoid ~measure f t = (* suboptimal when the measure does not depend on 'a *) fold_left (fun acc elt -> snoc ~monoid ~measure acc (f elt)) empty t end module Sequence : sig include SIG val enum2 : 'a t -> 'a BatEnum.t val fold_left2 : ('acc -> 'a -> 'acc) -> 'acc -> 'a t -> 'acc val fold_right2 : ('acc -> 'a -> 'acc) -> 'acc -> 'a t -> 'acc val reverse2 : 'a t -> 'a t val update2 : 'a t -> int -> ('a -> 'a) -> 'a t val set2 : 'a t -> int -> 'a -> 'a t val get2 : 'a t -> int -> 'a val of_enum2 : 'a BatEnum.t -> 'a t val map2 : ('a -> 'b) -> 'a t -> 'b t end = struct type nat = int let nat_plus_monoid = { GenFingerTree. zero = 0; combine = (+); } let size_measurer = fun _ -> 1 type ('a, 'm) fg = ('a, nat) GenFingerTree.fg type 'a t = ('a, nat) fg let empty = GenFingerTree.empty let fold_left = GenFingerTree.fold_left let fold_right = GenFingerTree.fold_right let cons t x = GenFingerTree.cons ~monoid:nat_plus_monoid ~measure:size_measurer t x let snoc t x = GenFingerTree.snoc ~monoid:nat_plus_monoid ~measure:size_measurer t x let front t = GenFingerTree.front ~monoid:nat_plus_monoid ~measure:size_measurer t let rear t = GenFingerTree.rear ~monoid:nat_plus_monoid ~measure:size_measurer t let append t1 t2 = GenFingerTree.append ~monoid:nat_plus_monoid ~measure:size_measurer t1 t2 let reverse t = GenFingerTree.reverse ~monoid:nat_plus_monoid ~measure:size_measurer t let measure t = GenFingerTree.measure ~monoid:nat_plus_monoid ~measure:size_measurer t let size = measure let split f t = GenFingerTree.split ~monoid:nat_plus_monoid ~measure:size_measurer f t let split_at t i = if i < 0 || i >= size t then invalid_arg "Index out of bounds"; split (fun index -> i < index) t let lookup f t = GenFingerTree.lookup ~monoid:nat_plus_monoid ~measure:size_measurer f t let get t i = if i < 0 || i >= size t then invalid_arg "Index out of bounds"; lookup (fun index -> i < index) t let tail_exn t = GenFingerTree.tail_exn ~monoid:nat_plus_monoid ~measure:size_measurer t let set t i v = if i < 0 || i >= size t then invalid_arg "Index out of bounds"; let left, right = split_at t i in append (snoc left v) (tail_exn right) let of_enum e = GenFingerTree.of_enum ~monoid:nat_plus_monoid ~measure:size_measurer e let generate_of_enum = of_enum let of_backwards e = GenFingerTree.of_backwards ~monoid:nat_plus_monoid ~measure:size_measurer e let map f t = GenFingerTree.map ~monoid:nat_plus_monoid ~measure:size_measurer f t let enum = GenFingerTree.enum let backwards = GenFingerTree.backwards module Opt = (* optimized *) struct open GenFingerTree let rec height : 'a. int -> ('a, 'm) fg -> int = fun acc -> function | Nil | Single _ -> acc | Deep (_, _, m, _) -> height (acc + 1) m let height t = height 0 t let tdigit = 0 let tfg = 1 let telt = 2 let rec aux_elt stack index depth elt = if depth = 0 then ( stack.(0) <- index - 2; stack.(index - 1) <- 42; (*gc*) Obj.magic elt ) else ( match Obj.magic elt with | Node2 (_, a, b) -> stack.(index - 1) <- Obj.magic b; stack.(index + 0) <- telt lor ((depth - 1) lsl 2); aux_elt stack (index + 2) (depth - 1) a | Node3 (_, a, b, c) -> stack.(index - 1) <- Obj.magic c; stack.(index + 0) <- telt lor ((depth - 1) lsl 2); stack.(index + 1) <- Obj.magic b; stack.(index + 2) <- telt lor ((depth - 1) lsl 2); aux_elt stack (index + 4) (depth - 1) a ) let aux_digit stack index depth = function | One (_, a) -> aux_elt stack index depth a | Two (_, a, b) -> stack.(index - 1) <- Obj.magic b; stack.(index + 0) <- telt lor (depth lsl 2); aux_elt stack (index + 2) depth a | Three (_, a, b, c) -> stack.(index - 1) <- Obj.magic c; stack.(index + 0) <- telt lor (depth lsl 2); stack.(index + 1) <- Obj.magic b; stack.(index + 2) <- telt lor (depth lsl 2); aux_elt stack (index + 4) depth a | Four (_, a, b, c, d) -> stack.(index - 1) <- Obj.magic d; stack.(index + 0) <- telt lor (depth lsl 2); stack.(index + 1) <- Obj.magic c; stack.(index + 2) <- telt lor (depth lsl 2); stack.(index + 3) <- Obj.magic b; stack.(index + 4) <- telt lor (depth lsl 2); aux_elt stack (index + 6) depth a let rec aux stack index = if index = 0 then ( stack.(0) <- 0; raise BatEnum.No_more_elements ); let type_ = stack.(index) land 3 in let depth = stack.(index) lsr 2 in let value = Obj.magic stack.(index - 1) in if type_ = telt then (* this test comes first because it is * the one most likely to be true * making it last results in a 20% slow down *) aux_elt stack index depth value else if type_ = tfg then match value with | Nil -> stack.(index - 1) <- 0(*gc*); aux stack (index - 2) | Single x -> aux_elt stack index depth x | Deep (_, pr, m, sf) -> stack.(index - 1) <- Obj.magic sf; stack.(index + 0) <- tdigit lor (depth lsl 2); stack.(index + 1) <- Obj.magic m; stack.(index + 2) <- tfg lor ((depth + 1) lsl 2); aux_digit stack (index + 4) depth pr else aux_digit stack index depth value let enum_next (stack : int array) = aux stack stack.(0) let enum_stack t : _ array = let stack = Obj.obj (Obj.new_block 0 ((3 * height t + 3 + 1) * 2 + 1)) in stack.(0) <- 2; stack.(1) <- Obj.magic t; stack.(2) <- tfg; stack let enum t = let stack = enum_stack t in BatEnum.make ~next:(fun () -> enum_next stack) ~count:(fun _ -> assert false) ~clone:(fun () -> assert false) let rec fold_left_a f depth acc a = if depth = 0 then f acc a else Obj.magic ( match Obj.magic a with | Node2 (_, a, b) -> let acc = fold_left_a f (depth - 1) acc a in let acc = fold_left_a f (depth - 1) acc b in acc | Node3 (_, a, b, c) -> let acc = fold_left_a f (depth - 1) acc a in let acc = fold_left_a f (depth - 1) acc b in let acc = fold_left_a f (depth - 1) acc c in acc ) let fold_left_digit f depth acc = function | One (_, a) -> fold_left_a f depth acc a | Two (_, a, b) -> let acc = fold_left_a f depth acc a in let acc = fold_left_a f depth acc b in acc | Three (_, a, b, c) -> let acc = fold_left_a f depth acc a in let acc = fold_left_a f depth acc b in let acc = fold_left_a f depth acc c in acc | Four (_, a, b, c, d) -> let acc = fold_left_a f depth acc a in let acc = fold_left_a f depth acc b in let acc = fold_left_a f depth acc c in let acc = fold_left_a f depth acc d in acc let rec fold_left f depth acc = function | Nil -> acc | Single a -> fold_left_a f depth acc a | Deep (_, pr, m, sf) -> let acc = fold_left_digit f depth acc pr in let acc = fold_left f (depth + 1) acc (Obj.magic m) in let acc = fold_left_digit f depth acc sf in acc let fold_left f acc t = fold_left f 0 acc t let rec fold_right_a f depth acc a = if depth = 0 then f acc a else Obj.magic ( match Obj.magic a with | Node2 (_, a, b) -> let acc = fold_right_a f (depth - 1) acc b in let acc = fold_right_a f (depth - 1) acc a in acc | Node3 (_, a, b, c) -> let acc = fold_right_a f (depth - 1) acc c in let acc = fold_right_a f (depth - 1) acc b in let acc = fold_right_a f (depth - 1) acc a in acc ) let fold_right_digit f depth acc = function | One (_, a) -> fold_right_a f depth acc a | Two (_, a, b) -> let acc = fold_right_a f depth acc b in let acc = fold_right_a f depth acc a in acc | Three (_, a, b, c) -> let acc = fold_right_a f depth acc c in let acc = fold_right_a f depth acc b in let acc = fold_right_a f depth acc a in acc | Four (_, a, b, c, d) -> let acc = fold_right_a f depth acc d in let acc = fold_right_a f depth acc c in let acc = fold_right_a f depth acc b in let acc = fold_right_a f depth acc a in acc let rec fold_right f depth acc = function | Nil -> acc | Single a -> fold_right_a f depth acc a | Deep (_, pr, m, sf) -> let acc = fold_right_digit f depth acc sf in let acc = fold_right f (depth + 1) acc (Obj.magic m) in let acc = fold_right_digit f depth acc pr in acc let fold_right f acc t = fold_right f 0 acc t end let enum2 = Opt.enum let fold_left2 = Opt.fold_left let fold_right2 = Opt.fold_right module Spec = (* specialized for int annots *) struct open GenFingerTree let measure_t_node = function | Nil -> 0 | Single x -> measure_node x | Deep (v, _, _, _) -> v let node3 a b c = Node3 (3, a, b, c) let node3_node a b c = Node3 (measure_node a + measure_node b + measure_node c, a, b, c) let deep pr m sf = Deep (measure_digit pr + measure_t_node m + measure_digit sf, pr, m, sf) let one a = One (1, a) let one_node a = One (measure_node a, a) let two a b = Two (2, a, b) let two_node a b = Two (measure_node a + measure_node b, a, b) let three a b c = Three (3, a, b, c) let three_node a b c = Three (measure_node a + measure_node b + measure_node c, a, b, c) let four a b c d = Four (4, a, b, c, d) let four_node a b c d = Four (measure_node a + measure_node b + measure_node c + measure_node d, a, b, c, d) let rec reverse_a depth a = if depth = 0 then a else Obj.magic ( match Obj.magic a with | Node2 (v, a, b) -> Node2 (v, reverse_a (depth - 1) b, reverse_a (depth - 1) a) | Node3 (v, a, b, c) -> Node3 (v, reverse_a (depth - 1) c, reverse_a (depth - 1) b, reverse_a (depth - 1) a) ) let reverse_digit depth = function | One (v, a) -> One (v, reverse_a depth a) | Two (v, a, b) -> Two (v, reverse_a depth b, reverse_a depth a) | Three (v, a, b, c) -> Three (v, reverse_a depth c, reverse_a depth b, reverse_a depth a) | Four (v, a, b, c, d) -> Four (v, reverse_a depth d, reverse_a depth c, reverse_a depth b, reverse_a depth a) let rec reverse depth = function | Nil -> Nil | Single a -> Single (reverse_a depth a) | Deep (v, pr, m, sf) -> let rev_pr = reverse_digit depth pr in let rev_sf = reverse_digit depth sf in let rev_m = Obj.magic (reverse (depth + 1) (Obj.magic m)) in Deep (v, rev_sf, rev_m, rev_pr) let reverse t = reverse 0 t let get_digit d i = match d with | One (_, a) -> a | Two (_, a, b) -> if i = 0 then a else b | Three (_, a, b, c) -> if i = 0 then a else if i = 1 then b else c | Four (_, a, b, c, d) -> if i < 2 then (if i = 0 then a else b) else (if i = 2 then c else d) let rec get_a depth a i = if depth = 1 then ( match Obj.magic a with | Node2 (_, a, b) -> if i = 0 then a else b | Node3 (_, a, b, c) -> if i = 0 then a else if i = 1 then b else c ) else ( match Obj.magic a with | Node2 (_, a, b) -> if i < measure_node a then get_a (depth - 1) a i else let i = i - measure_node a in get_a (depth - 1) b i | Node3 (_, a, b, c) -> if i < measure_node a then get_a (depth - 1) a i else let i = i - measure_node a in if i < measure_node b then get_a (depth - 1) b i else let i = i - measure_node b in get_a (depth - 1) c i ) let get_digit_node depth d i = match d with | One (_, a) -> get_a depth a i | Two (_, a, b) -> if i < measure_node a then get_a depth a i else let i = i - measure_node a in get_a depth b i | Three (_, a, b, c) -> if i < measure_node a then get_a depth a i else let i = i - measure_node a in if i < measure_node b then get_a depth b i else let i = i - measure_node b in get_a depth c i | Four (_, a, b, c, d) -> if i < measure_node a then get_a depth a i else let i = i - measure_node a in if i < measure_node b then get_a depth b i else let i = i - measure_node b in if i < measure_node c then get_a depth c i else let i = i - measure_node c in get_a depth d i let rec get_aux depth t i = match t with | Nil -> assert false | Single v -> get_a depth v i | Deep (_, pr, m, sf) -> if i < measure_digit pr then get_digit_node depth pr i else let i = i - measure_digit pr in if i < measure_t_node m then get_aux (depth + 1) (Obj.magic m) i else let i = i - measure_t_node m in get_digit_node depth sf i let check_bounds t i = if i < 0 || i >= size t then invalid_arg "Index out of bounds" let get t i = check_bounds t i; match t with | Nil -> assert false | Single v -> v | Deep (_, pr, m, sf) -> if i < measure_digit pr then get_digit pr i else let i = i - measure_digit pr in if i < measure_t_node m then get_aux 1 m i else let i = i - measure_t_node m in get_digit sf i let update_digit d i f = match d with | One (v, a) -> One (v, f a) | Two (v, a, b) -> if i = 0 then Two (v, f a, b) else Two (v, a, f b) | Three (v, a, b, c) -> if i = 0 then Three (v, f a, b, c) else if i = 1 then Three (v, a, f b, c) else Three (v, a, b, f c) | Four (v, a, b, c, d) -> if i < 2 then ( if i = 0 then Four (v, f a, b, c, d) else Four (v, a, f b, c, d) ) else ( if i = 2 then Four (v, a, b, f c, d) else Four (v, a, b, c, f d) ) let rec update_a depth a i f = if depth = 1 then Obj.magic ( match Obj.magic a with | Node2 (v, a, b) -> if i = 0 then Node2 (v, f a, b) else Node2 (v, a, f b) | Node3 (v, a, b, c) -> if i = 0 then Node3 (v, f a, b, c) else if i = 1 then Node3 (v, a, f b, c) else Node3 (v, a, b, f c) ) else Obj.magic ( match Obj.magic a with | Node2 (v, a, b) -> if i < measure_node a then Node2 (v, update_a (depth - 1) a i f, b) else let i = i - measure_node a in Node2 (v, a, update_a (depth - 1) b i f) | Node3 (v, a, b, c) -> if i < measure_node a then Node3 (v, update_a (depth - 1) a i f, b, c) else let i = i - measure_node a in if i < measure_node b then Node3 (v, a, update_a (depth - 1) b i f, c) else let i = i - measure_node b in Node3 (v, a, b, update_a (depth - 1) c i f) ) let update_digit_node depth d i f = match d with | One (v, a) -> One (v, update_a depth a i f) | Two (v, a, b) -> if i < measure_node a then Two (v, update_a depth a i f, b) else let i = i - measure_node a in Two (v, a, update_a depth b i f) | Three (v, a, b, c) -> if i < measure_node a then Three (v, update_a depth a i f, b, c) else let i = i - measure_node a in if i < measure_node b then Three (v, a, update_a depth b i f, c) else let i = i - measure_node b in Three (v, a, b, update_a depth c i f) | Four (v, a, b, c, d) -> if i < measure_node a then Four (v, update_a depth a i f, b, c, d) else let i = i - measure_node a in if i < measure_node b then Four (v, a, update_a depth b i f, c, d) else let i = i - measure_node b in if i < measure_node c then Four (v, a, b, update_a depth c i f, d) else let i = i - measure_node c in Four (v, a, b, c, update_a depth d i f) let rec update_aux depth t i f = match t with | Nil -> assert false | Single v -> Single (update_a depth v i f) | Deep (v, pr, m, sf) -> if i < measure_digit pr then Deep (v, update_digit_node depth pr i f, m, sf) else let i = i - measure_digit pr in if i < measure_t_node m then Deep (v, pr, Obj.magic (update_aux (depth + 1) (Obj.magic m) i f), sf) else let i = i - measure_t_node m in Deep (v, pr, m, update_digit_node depth sf i f) let update t i f = check_bounds t i; match t with | Nil -> assert false | Single v -> Single (f v) | Deep (v, pr, m, sf) -> if i < measure_digit pr then Deep (v, update_digit pr i f, m, sf) else let i = i - measure_digit pr in if i < measure_t_node m then Deep (v, pr, update_aux 1 m i f, sf) else let i = i - measure_t_node m in Deep (v, pr, m, update_digit sf i f) let set t i v = update t i (fun _ -> v) let rec get_node depth enum = if depth = 1 then let v1 = BatEnum.get_exn enum in let v2 = BatEnum.get_exn enum in let v3 = BatEnum.get_exn enum in Obj.magic (node3 v1 v2 v3) else let v1 = get_node (depth - 1) enum in let v2 = get_node (depth - 1) enum in let v3 = get_node (depth - 1) enum in Obj.magic (node3_node v1 v2 v3) let get_digit_node depth enum n = match n with | 1 -> let v1 = get_node depth enum in one_node v1 | 2 -> let v1 = get_node depth enum in let v2 = get_node depth enum in two_node v1 v2 | 3 -> let v1 = get_node depth enum in let v2 = get_node depth enum in let v3 = get_node depth enum in three_node v1 v2 v3 | 4 -> let v1 = get_node depth enum in let v2 = get_node depth enum in let v3 = get_node depth enum in let v4 = get_node depth enum in four_node v1 v2 v3 v4 | _ -> assert false let rec fast_of_enum_aux depth enum n = if n = 0 then Nil else if n = 1 then Single (get_node depth enum) else let n_rec = if n <= 8 then 0 else (n - 8 + 3 - 1) / 3 in let n_left = (n - n_rec * 3) / 2 in let n_right = (n - n_rec * 3 + 1) / 2 in let pr = get_digit_node depth enum n_left in let m = Obj.magic (fast_of_enum_aux (depth + 1) enum n_rec) in let sf = get_digit_node depth enum n_right in deep pr m sf let get_digit enum n = match n with | 1 -> let v1 = BatEnum.get_exn enum in one v1 | 2 -> let v1 = BatEnum.get_exn enum in let v2 = BatEnum.get_exn enum in two v1 v2 | 3 -> let v1 = BatEnum.get_exn enum in let v2 = BatEnum.get_exn enum in let v3 = BatEnum.get_exn enum in three v1 v2 v3 | 4 -> let v1 = BatEnum.get_exn enum in let v2 = BatEnum.get_exn enum in let v3 = BatEnum.get_exn enum in let v4 = BatEnum.get_exn enum in four v1 v2 v3 v4 | _ -> assert false let fast_of_enum enum n = if n = 0 then Nil else if n = 1 then Single (BatEnum.get_exn enum) else let n_rec = if n <= 8 then 0 else (n - 8 + 3 - 1) / 3 in let n_left = (n - n_rec * 3) / 2 in let n_right = (n - n_rec * 3 + 1) / 2 in let pr = get_digit enum n_left in let m = fast_of_enum_aux 1 enum n_rec in let sf = get_digit enum n_right in Deep (n, pr, m, sf) let rec get_node depth a i = if depth = 1 then let v1 = BatDynArray.unsafe_get a !i in let v2 = BatDynArray.unsafe_get a (!i + 1) in let v3 = BatDynArray.unsafe_get a (!i + 2) in i := !i + 3; Obj.magic (node3 v1 v2 v3) else let v1 = get_node (depth - 1) a i in let v2 = get_node (depth - 1) a i in let v3 = get_node (depth - 1) a i in Obj.magic (node3_node v1 v2 v3) let get_digit_node depth a i n = match n with | 1 -> let v1 = get_node depth a i in one_node v1 | 2 -> let v1 = get_node depth a i in let v2 = get_node depth a i in two_node v1 v2 | 3 -> let v1 = get_node depth a i in let v2 = get_node depth a i in let v3 = get_node depth a i in three_node v1 v2 v3 | 4 -> let v1 = get_node depth a i in let v2 = get_node depth a i in let v3 = get_node depth a i in let v4 = get_node depth a i in four_node v1 v2 v3 v4 | _ -> assert false let rec fast_of_enum_aux depth a i n = if n = 0 then Nil else if n = 1 then Single (get_node depth a i) else let n_rec = if n <= 8 then 0 else (n - 8 + 3 - 1) / 3 in let n_left = (n - n_rec * 3) / 2 in let n_right = (n - n_rec * 3 + 1) / 2 in let pr = get_digit_node depth a i n_left in let m = Obj.magic (fast_of_enum_aux (depth + 1) a i n_rec) in let sf = get_digit_node depth a i n_right in deep pr m sf let get_digit a i n = match n with | 1 -> let v1 = BatDynArray.unsafe_get a !i in i := !i + 1; one v1 | 2 -> let v1 = BatDynArray.unsafe_get a !i in let v2 = BatDynArray.unsafe_get a (!i + 1) in i := !i + 2; two v1 v2 | 3 -> let v1 = BatDynArray.unsafe_get a !i in let v2 = BatDynArray.unsafe_get a (!i + 1) in let v3 = BatDynArray.unsafe_get a (!i + 2) in i := !i + 3; three v1 v2 v3 | 4 -> let v1 = BatDynArray.unsafe_get a !i in let v2 = BatDynArray.unsafe_get a (!i + 1) in let v3 = BatDynArray.unsafe_get a (!i + 2) in let v4 = BatDynArray.unsafe_get a (!i + 3) in i := !i + 4; four v1 v2 v3 v4 | _ -> assert false let fast_of_enum_array a i n = if n = 0 then Nil else if n = 1 then Single (BatDynArray.unsafe_get a 0) else let n_rec = if n <= 8 then 0 else (n - 8 + 3 - 1) / 3 in let n_left = (n - n_rec * 3) / 2 in let n_right = (n - n_rec * 3 + 1) / 2 in let pr = get_digit a i n_left in let m = fast_of_enum_aux 1 a i n_rec in let sf = get_digit a i n_right in Deep (n, pr, m, sf) let of_enum enum = if BatEnum.fast_count enum then fast_of_enum enum (BatEnum.count enum) else let a = BatDynArray.make 10 in try while true do BatDynArray.add a (BatEnum.get_exn enum) done; assert false with BatEnum.No_more_elements -> fast_of_enum_array a (ref 0) (BatDynArray.length a) let rec map_a f depth a = if depth = 0 then f a else Obj.magic ( match Obj.magic a with | Node2 (v, a, b) -> let a = map_a f (depth - 1) a in let b = map_a f (depth - 1) b in Node2 (v, a, b) | Node3 (v, a, b, c) -> let a = map_a f (depth - 1) a in let b = map_a f (depth - 1) b in let c = map_a f (depth - 1) c in Node3 (v, a, b, c) ) let map_digit f depth = function | One (v, a) -> let a = map_a f depth a in One (v, a) | Two (v, a, b) -> let a = map_a f depth a in let b = map_a f depth b in Two (v, a, b) | Three (v, a, b, c) -> let a = map_a f depth a in let b = map_a f depth b in let c = map_a f depth c in Three (v, a, b, c) | Four (v, a, b, c, d) -> let a = map_a f depth a in let b = map_a f depth b in let c = map_a f depth c in let d = map_a f depth d in Four (v, a, b, c, d) let rec map f depth = function | Nil -> Nil | Single a -> let a = map_a f depth a in Single a | Deep (v, pr, m, sf) -> let pr = map_digit f depth pr in let m = Obj.magic (map f (depth + 1) (Obj.magic m)) in let sf = map_digit f depth sf in Deep (v, pr, m, sf) let map f t = map f 0 t end let reverse2 = Spec.reverse let update2 = Spec.update let set2 = Spec.set let get2 = Spec.get let of_enum2 = Spec.of_enum let map2 = Spec.map end (*SEARCHME*) let rec memory_size acc t = let tag = Obj.tag t in if tag = Obj.int_tag then acc else if tag < Obj.no_scan_tag && tag <> Obj.lazy_tag && tag <> Obj.closure_tag && tag <> Obj.object_tag && tag <> Obj.infix_tag && tag <> Obj.forward_tag && tag <> Obj.abstract_tag && tag <> Obj.string_tag && tag <> Obj.double_tag && tag <> Obj.double_array_tag && tag <> Obj.custom_tag && tag <> Obj.out_of_heap_tag && tag <> Obj.unaligned_tag then let size = Obj.size t in let acc = ref (acc + size + 1) in for i = 0 to size - 2 do acc := memory_size !acc (Obj.field t i) done; memory_size !acc (Obj.field t (size - 1)) else assert false let memory_size a = memory_size 0 (Obj.repr a) let bench_size size s = let module M = (val s : SIG) in let rec aux stack = function | 0 -> stack | n -> aux (M.cons stack n) (n - 1) in let s = aux M.empty size in memory_size s let bench_cons_front size s n = for _i = 0 to n do let module M = (val s : SIG) in let rec aux stack = function | 0 -> stack | n -> aux (M.cons stack n) (n - 1) in let s = aux M.empty size in let rec aux stack = match M.front stack with | None -> () | Some (stack, _) -> aux stack in aux s done let bench_map size s = (* not benching the construction time, just the mapping time *) let module M = (val s : SIG) in let rec aux stack = function | 0 -> stack | n -> aux (M.cons stack n) (n - 1) in let s = aux M.empty size in fun n -> for _i = 0 to n do ignore (M.map (fun x -> x + 1) s) done let bench_snoc_front size s n = for _i = 0 to n do let module M = (val s : SIG) in let rec aux stack = function | 0 -> stack | n -> aux (M.snoc stack n) (n - 1) in let s = aux M.empty size in let rec aux stack = match M.front stack with | None -> () | Some (stack, _) -> aux stack in aux s done let bench_snoc_front_rear size s n = for _i = 0 to n do let module M = (val s : SIG) in let rec aux stack = function | 0 -> stack | n -> aux (M.snoc stack n) (n - 1) in let s = aux M.empty size in let rec aux stack = match M.front stack with | None -> () | Some (stack, _) -> match M.rear stack with | None -> () | Some (stack, _) -> aux stack in aux s done let bench_enum1 size s = let a = BatArray.Labels.init size ~f:(fun i -> i) in let e = BatArray.enum a in let module M = (val s : SIG) in let t = M.generate_of_enum e in fun n -> for _i = 0 to n do let e = M.enum t in try while true; do ignore (BatEnum.get_exn e); done with BatEnum.No_more_elements -> () done let bench_of_enum1 size s n = let a = BatArray.Labels.init size ~f:(fun i -> i) in for _i = 0 to n do let e = BatArray.enum a in let module M = (val s : SIG) in ignore (M.of_enum e) done let bench_fold_left size s = let a = BatArray.Labels.init size ~f:(fun i -> i) in let e = BatArray.enum a in let module M = (val s : SIG) in let t = M.generate_of_enum e in fun n -> for _i = 0 to n do M.fold_left (fun () _ -> ()) () t; done let bench_fold_right size s = let a = BatArray.Labels.init size ~f:(fun i -> i) in let e = BatArray.enum a in let module M = (val s : SIG) in let t = M.generate_of_enum e in fun n -> for _i = 0 to n do M.fold_right (fun () _ -> ()) () t; done let bench_reverse size s = let a = BatArray.Labels.init size ~f:(fun i -> i) in let e = BatArray.enum a in let module M = (val s : SIG) in let t = M.generate_of_enum e in fun n -> for _i = 0 to n do ignore (M.reverse t) done let bench_append size s = let a = BatArray.Labels.init size ~f:(fun i -> i) in let e = BatArray.enum a in let module M = (val s : SIG) in let t = M.generate_of_enum e in fun n -> for _i = 0 to n do ignore (M.append t t) done let bench_get size s = let a = BatArray.Labels.init size ~f:(fun i -> i) in let e = BatArray.enum a in let module M = (val s : SIG) in let t = M.generate_of_enum e in fun n -> for _i = 0 to n do for i = 0 to size - 1 do ignore (M.get t i) done done let bench_set size s = let a = BatArray.Labels.init size ~f:(fun i -> i) in let e = BatArray.enum a in let module M = (val s : SIG) in let t = M.generate_of_enum e in fun n -> for _i = 0 to n do let t = ref t in for i = 0 to size - 1 do t := M.set !t i 0 done done module ListTailCore : SIG = struct include ListTail let map = map2 end module ListTailModConsOpt : SIG = struct include ListTailModCons let map = map2 end module FgGen : SIG = Sequence module FgGenOpt : SIG = struct include Sequence let enum = enum2 let fold_left = fold_left2 let fold_right = fold_right2 end module FgSpec : SIG = struct include Sequence let reverse = reverse2 let set = set2 let get = get2 let of_enum = of_enum2 let map = map2 end let sizes = [ 1; 10; 100; 1_000; 10_000; 100_000; ] let print_readings ~title size l = if size = BatList.hd sizes then ( Printf.printf "#%s size" title; BatList.iter (fun r -> Printf.printf "\t%s" r.Bench.desc; ) l; Printf.printf "\n" ); Printf.printf "%d" size; BatList.iter (fun r -> Printf.printf "\t%.3f" (1_000_000_000. *. r.Bench.mean.Bench.Bootstrap.point /. float size) ) l; Printf.printf "\n" let bench ~title ?(deque=false) ?(list=false) ?(map=false) bench = fun size -> let core = if map then [ "ListTailModConsOpt", bench size (module ListTailModConsOpt : SIG); "ListTailCore", bench size (module ListTailCore : SIG); ] else [] in let lists = if list then [ "ListOverflow", bench size (module ListOverflow : SIG); "ListTail", bench size (module ListTail : SIG); "ListTailModCons", bench size (module ListTailModCons : SIG); ] @ core else [ ] in let deque = if deque then [ "Deque", bench size (module Deque : SIG); ] else [] in let readings = Bench.bench_n (lists @ deque @ [ "FgGen", bench size (module FgGen : SIG); "FgGenOpt", bench size (module FgGenOpt : SIG); "FgSpec", bench size (module FgSpec : SIG); "Vect", bench size (module Vect : SIG); ]) in fun () -> print_readings ~title size readings let heap_size ~title size = let assoc = [ "ListOverflow", bench_size size (module ListOverflow : SIG); "Deque", bench_size size (module Deque : SIG); "FgGen", bench_size size (module FgGen : SIG); "Vect", bench_size size (module Vect : SIG); ] in fun () -> if size = BatList.hd sizes then ( Printf.printf "#%s size" title; BatList.iter (fun (name,_) -> Printf.printf "\t%s" name) assoc; Printf.printf "\n" ); Printf.printf "%d" size; BatList.iter (fun (_,size) -> Printf.printf "\t%d" size) assoc; Printf.printf "\n" let benches = [ "cons_front", bench ~list:true ~deque:true bench_cons_front; "snoc_front", bench ~deque:true bench_snoc_front; "snoc_front_rear", bench ~deque:true bench_snoc_front_rear; "size", heap_size; "map", bench ~deque:true ~list:true ~map:true bench_map; "of_enum", bench ~list:true ~deque:true bench_of_enum1; "enum", bench ~list:true ~deque:true bench_enum1; "fold_left", bench ~list:true ~deque:true bench_fold_left; "fold_right", bench ~list:true ~deque:true bench_fold_right; "reverse", bench ~list:true bench_reverse; "append", bench bench_append; "set", bench bench_set; "get", bench bench_get; ] let () = Bench.config.Bench.samples <- 100; Array.iter (fun s -> try let f = BatList.assoc s benches in let printers = BatList.map (f ~title:s) sizes in BatList.iter (fun f -> f ()) printers; Printf.printf "\n" with Not_found -> Printf.printf "`%s' is not a valid bench name\nThe possibilities are: " s; BatList.iter (fun (name,_) -> Printf.printf "%s, " name) benches; Printf.printf "\n"; exit 1 ) (Array.sub Sys.argv 1 (Array.length Sys.argv - 1)) batteries-included-3.4.0/build/000077500000000000000000000000001415601150500163625ustar00rootroot00000000000000batteries-included-3.4.0/build/README000066400000000000000000000001211415601150500172340ustar00rootroot00000000000000This directory contains tools used during the compilation of Batteries Included. batteries-included-3.4.0/build/_tags000066400000000000000000000000231415601150500173750ustar00rootroot00000000000000true: package(str) batteries-included-3.4.0/build/dune000066400000000000000000000002051415601150500172350ustar00rootroot00000000000000(executable (name prefilter) (modules prefilter) (libraries str)) (executable (name mkconf) (modules mkconf) (libraries str)) batteries-included-3.4.0/build/fix_camlp4_print.ml000066400000000000000000000074701415601150500221660ustar00rootroot00000000000000open Format open Camlp4 let pp = fprintf module Id = struct let name = "fix for Camlp4.Printers.OCaml" let version = "0.1" end module Make (Syntax : Sig.Camlp4Syntax) = struct open Syntax include Camlp4.Printers.OCaml.Make(Syntax) module CommentFilter = Struct.CommentFilter.Make(Token);; let comment_filter = CommentFilter.mk ();; CommentFilter.define (Gram.get_filter ()) comment_filter;; class extprinter ?curry_constr ?comments () = object (self) inherit printer ?curry_constr ?comments () as super method print_comments_before loc f = let rec aux __strm = match Stream.peek __strm with | Some ((comm, comm_loc)) when Loc.strictly_before comm_loc loc -> (Stream.junk __strm; let () = pp f "%s@ \n" comm in aux __strm) | _ -> () in aux (CommentFilter.take_stream comment_filter) method flush_rest_of_comments f = Stream.iter (fun (comm, _) -> pp f "%s@ \n" comm) (CommentFilter.take_stream comment_filter) method sig_item f sg = match sg with | Ast.SgVal (_, s, t) -> self#node f sg Ast.loc_of_sig_item; pp f "%s %a :%a" value_val self#var s self#ctyp t; | _ -> super#sig_item f sg method interf f sg = pp f "@[%a@]@." self#sig_item sg; self#flush_rest_of_comments f (* Stream.iter (fun (text, lloc) -> Printf.eprintf "\n%S\n" text ) (CommentFilter.take_stream comment_filter); super#print_comments_before loc f*) (* Stream.iter (fun (text, lloc) -> pp f "%s@ zz" text) (CommentFilter.take_stream comment_filter)*) (* pp_open_box f 10;*) (* super#print_comments_before loc f; pp_print_newline f (); pp_print_string f "(*after comment*)"*) (* pp_close_box f ()*) (* pp_print_newline f ()*) (* pp_print_string f "(*after comment*)"*) end let print output_file fct = let o = new extprinter () in with_outfile output_file (fct o) let print_interf ?input_file:(_) ?output_file sg = print output_file (fun o -> o#interf) sg let print_implem ?input_file:(_) ?output_file st = print output_file (fun o -> o#implem) st end;; module MakeMore (Syntax : Sig.Camlp4Syntax)= struct include Make(Syntax);; let semisep : sep ref = ref ("@\n":sep);; let margin = ref 78;; let comments = ref true;; let locations = ref false;; let curry_constr = ref false;; let print output_file fct = let o = new extprinter ~comments:!comments ~curry_constr:!curry_constr () in let o = o#set_semisep !semisep in let o = if !locations then o#set_loc_and_comments else o in with_outfile output_file (fun f -> let () = Format.pp_set_margin f !margin in Format.fprintf f "@[%a@]@." (fct o));; let print_interf ?input_file:(_) ?output_file sg = print output_file (fun o -> o#interf) sg;; let print_implem ?input_file:(_) ?output_file st = print output_file (fun o -> o#implem) st;; let check_sep s = if String.contains s '%' then failwith "-sep Format error, % found in string" else (Obj.magic (Struct.Token.Eval.string s : string) : sep);; Options.add "-l" (Arg.Int (fun i -> margin := i)) " line length for pretty printing.";; Options.add "-ss" (Arg.Unit (fun () -> semisep := ";;;;")) " Print double semicolons.";; Options.add "-no_ss" (Arg.Unit (fun () -> semisep := "")) " Do not print double semicolons (default).";; Options.add "-sep" (Arg.String (fun s -> semisep := check_sep s)) " Use this string between phrases.";; Options.add "-curry-constr" (Arg.Set curry_constr) "Use currified constructors.";; Options.add "-no_comments" (Arg.Clear comments) "Do not add comments.";; Options.add "-add_locations" (Arg.Set locations) "Add locations as comment.";; end;; module M = Camlp4.Register.OCamlPrinter(Id)(MakeMore);; batteries-included-3.4.0/build/import.ml000066400000000000000000000002151415601150500202240ustar00rootroot00000000000000(* Placeholder for a future tool. This tool will import a set of interfaces from a library for quick initialization of layer code. *) batteries-included-3.4.0/build/intro.text000066400000000000000000000065261415601150500204340ustar00rootroot00000000000000OCaml Batteries Included documentation. OCaml Batteries included (or simply "Batteries") is a community-driven effort to standardize on an consistent, documented, and comprehensive development platform for the OCaml programming language. For the moment, Batteries Included concentrates on: {ul {- data structures} {- file manipulation} {- inputs and outputs} {- concurrency} {- numbers} {- text, including Unicode} } For more information on the installation of Batteries Included, please read the {{:https://github.com/ocaml-batteries-team/batteries-included/wiki/Installing-Batteries}Installation guide} and for an example using it in different build systems, we have the {{:https://github.com/ocaml-batteries-team/batteries-included/wiki/Getting-started}Getting started manual}. Modules listed below can also be referenced as [Batteries.]--where [] is the module name without the initial "Bat"--or as [] alone, if [Batteries] has been [open]ed. For example, [BatLazyList] can also be used as [Batteries.LazyList], or as [LazyList] after executing [open Batteries]. Do you have suggestions? Remarks? Bug reports ? To contact us or to be kept informed, don't hesitate to visit our {{:http://batteries.forge.ocamlcore.org/}website}, {{:https://github.com/ocaml-batteries-team/batteries-included}Git repo}, and our {{:https://github.com/ocaml-batteries-team/batteries-included/issues?sort=created&direction=desc&state=open}Issue tracker}. {6 New Data Structures in Batteries} {!modules: BatBitSet BatCache BatDeque BatDllist BatDynArray BatEnum BatFingerTree BatGlobal BatHashcons BatHeap BatIMap BatISet BatLazyList BatMultiPMap BatRefList BatSeq BatSplay BatText BatUChar BatUref BatUTF8 BatVect} {6 New Modules in Batteries} {!modules: BatBase64 BatCharParser BatFile BatInterfaces BatIO BatLog BatLogger BatNumber BatOptParse BatParserCo BatResult BatReturn } {6 Builtin Types as Modules} {!modules: BatBool BatChar BatFloat BatInt BatInt32 BatInt64 BatNativeint BatOption BatRef BatTuple BatUnit } {6 Extensions to the Standard Library} These modules have base library equivalents. When using [open Batteries], [BatFoo] will replace [Foo], so that the new functions are easily available without a [Bat] prefix on the module name. As well, [BatPervasives] is opened into the global namespace. Finally, the previous versions of replaced modules are available in the [Legacy] module, i.e. [Legacy.Unix] and [Legacy.Pervasives]. {!modules: BatArray BatBigarray BatBig_int BatBuffer BatComplex BatDigest BatFormat BatGc BatGenlex BatHashtbl BatLexing BatList BatMap BatMarshal BatNum BatPervasives BatPrintexc BatPrintf BatQueue BatRandom BatScanf BatSet BatStack BatStream BatString BatSys BatUnix} {6 Thread-related Modules} These modules are available only when compiling with threads. To use them, do [open BatteriesThread] at the top of your code. {!modules: BatConcurrent BatMutex BatRMutex} {6 Incubator} These modules are available only inside [Batteries.Incubator]. Their interface is not guaranteed stable, and may be changed at any time, including with backwards incompatible changes between point releases. They are included for testing and stabilization until they can be finalized and moved to batteries proper. {!modules: BatBounded BatOrd BatPathGen BatSubstring} {6 Internal Modules} {!modules: BatAvlTree BatInnerIO BatInnerWeaktbl} batteries-included-3.4.0/build/make-our-inline-tests-compatible-with-older-OCaml-versions.patch000066400000000000000000000114561415601150500325760ustar00rootroot00000000000000From c09d02f65d20c183149698cad56c1d9715b4267a Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Sun, 29 Oct 2017 18:06:05 +0100 Subject: [PATCH] make our inline tests compatible with older OCaml versions Newer qtest versions introduced API changes that makes our code incompatible with older qtest versions, and they are also incompatible with some OCaml versions that Batteries support. The present patch removes all advanced qtest modules from the Batteries inline test (at the cost of slightly reducing the breadth of the coverage in some case); applying it should make it possible to test Batteries under 3.12.1 and 4.00.1 for example. Please consider rebasing this commit with new changes if the old-qtest-incompatible features start being used in other places. --- src/batArray.mlv | 22 ++++++++++++---------- src/batInnerShuffle.ml | 2 +- src/batList.mlv | 5 +++-- 3 files changed, 16 insertions(+), 13 deletions(-) diff --git a/src/batArray.mlv b/src/batArray.mlv index 005c4df0..79ee6f94 100644 --- a/src/batArray.mlv +++ b/src/batArray.mlv @@ -175,7 +175,7 @@ let findi p xs = in loop 0 (*$Q findi - (Q.pair (Q.array Q.small_int) (Q.fun1 Q.Observable.int Q.bool)) (fun (a, Q.Fun(_,f)) -> \ + (Q.array Q.small_int) (fun a -> let f n = (n mod 4 = 0) in \ try let index = findi f a in \ let i = ref (-1) in \ for_all (fun elt -> incr i; \ @@ -187,7 +187,7 @@ let findi p xs = let find p xs = xs.(findi p xs) (*$Q find - (Q.pair (Q.array Q.small_int) (Q.fun1 Q.Observable.int Q.bool)) (fun (a, Q.Fun(_,f)) -> \ + (Q.array Q.small_int) (fun a -> let f n = (n mod 4 = 0) in \ let a = map (fun x -> `a x) a in \ let f (`a x) = f x in\ try let elt = find f a in \ @@ -217,7 +217,7 @@ let filter p xs = assert false ) (*$Q filter - (Q.pair (Q.array Q.small_int) (Q.fun1 Q.Observable.int Q.bool)) (fun (a, Q.Fun(_,f)) -> \ + (Q.array Q.small_int) (fun a -> let f n = (n mod 4 = 0) in \ let b = Array.to_list (filter f a) in \ let b' = List.filter f (Array.to_list a) in \ List.for_all (fun (x,y) -> x = y) (List.combine b b') \ @@ -276,7 +276,7 @@ let partition p xs = r) in xs1, xs2 (*$Q partition - (Q.pair (Q.array Q.small_int) (Q.fun1 Q.Observable.int Q.bool)) (fun (a, Q.Fun(_,f)) -> \ + (Q.array Q.small_int) (fun a -> let f n = (n mod 4 = 0) in \ let b1, b2 = partition f a in \ let b1, b2 = Array.to_list b1, Array.to_list b2 in \ let b1', b2' = List.partition f (Array.to_list a) in \ @@ -370,8 +370,8 @@ let range xs = BatEnum.(--^) 0 (Array.length xs) let filter_map p xs = of_enum (BatEnum.filter_map p (enum xs)) (*$Q filter_map - (Q.pair (Q.array Q.small_int) (Q.fun1 Q.Observable.int (Q.option Q.int))) \ - (fun (a, Q.Fun (_,f)) -> \ + (Q.array Q.small_int) (fun a -> \ + let f n = if (n mod 4 = 0) then Some n else None in \ let a' = filter (fun elt -> f elt <> None) a in \ let a' = map (f %> BatOption.get) a' in \ let a = filter_map f a in \ @@ -661,8 +661,9 @@ let decorate_stable_sort f xs = = [|(0,2);(1,2);(1,3);(1,4)|] *) (*$Q decorate_stable_sort - (Q.pair (Q.array Q.small_int) (Q.fun1 Q.Observable.int (Q.option Q.int))) \ - (fun (a, Q.Fun(_,f)) -> is_sorted_by f (decorate_stable_sort f a)) + (Q.array Q.small_int) (fun a -> \ + let f n = if (n mod 4 = 0) then Some n else None in \ + is_sorted_by f (decorate_stable_sort f a)) *) let decorate_fast_sort f xs = @@ -670,8 +671,9 @@ let decorate_fast_sort f xs = let () = fast_sort (fun (i,_) (j,_) -> Pervasives.compare i j) decorated in map (fun (_,x) -> x) decorated (*$Q decorate_fast_sort - (Q.pair (Q.array Q.small_int) (Q.fun1 Q.Observable.int (Q.option Q.int))) \ - (fun (a, Q.Fun(_,f)) -> is_sorted_by f (decorate_fast_sort f a)) + (Q.array Q.small_int) (fun a -> \ + let f n = if (n mod 4 = 0) then Some n else None in \ + is_sorted_by f (decorate_fast_sort f a)) *) let bsearch cmp arr x = diff --git a/src/batInnerShuffle.ml b/src/batInnerShuffle.ml index 4bcda867..3593a8f8 100644 --- a/src/batInnerShuffle.ml +++ b/src/batInnerShuffle.ml @@ -12,7 +12,7 @@ let array_shuffle ?state a = done (*$Q - Q.(array_of_size Gen.(2--15) small_int) (fun a -> \ + Q.(array_of_size (fun _ -> 10) small_int) (fun a -> \ let a' = Array.copy a in \ array_shuffle a'; \ (Array.to_list a' |> List.sort Pervasives.compare) = \ diff --git a/src/batList.mlv b/src/batList.mlv index 9208b765..d7c5d6ce 100644 --- a/src/batList.mlv +++ b/src/batList.mlv @@ -232,8 +232,9 @@ let map f = function loop r t; inj r (*$Q map - (Q.pair (Q.fun1 Q.Observable.int Q.int) (Q.list Q.small_int)) \ - (fun (Q.Fun (_,f),l) -> map f l = List.map f l) + (Q.list Q.small_int) (fun l -> \ + let f n = n+1 in \ + map f l = List.map f l) *) let rec drop n = function -- 2.13.6 batteries-included-3.4.0/build/mkconf.ml000066400000000000000000000062101415601150500201700ustar00rootroot00000000000000(* Program for substituting configuration data in various files. * Copyright (C) 2010 Michael Ekstrand * * 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. *) let () = if Array.length Sys.argv < 4 then begin prerr_endline "Not enough arguments"; exit 2 end let oasis_path = Sys.argv.(1) let input_path = Sys.argv.(2) let output_path = Sys.argv.(3) let strip ?(chars=" \t\r\n") s = let p = ref 0 in let l = String.length s in while !p < l && String.contains chars (String.unsafe_get s !p) do incr p; done; let p = !p in let l = ref (l - 1) in while !l >= p && String.contains chars (String.unsafe_get s !l) do decr l; done; String.sub s p (!l - p + 1) let version = (* get version string from _oasis *) try let chan = open_in oasis_path in let v = ref (input_line chan) in while String.sub !v 0 8 <> "Version:" do v := input_line chan done; let _ = close_in chan in strip (String.sub !v 8 (String.length !v - 8)) with x -> prerr_endline (Printexc.to_string x); exit 2 ;; let param_re = Str.regexp "@[A-Z0-9_]*@";; let repl = function "@@" -> "@" | "@VERSION@" -> version | s -> let name = String.sub s 1 (String.length s - 2) in try Sys.getenv name with Not_found -> s ;; let rec replace ?(pos=0) re f s = let p = try Str.search_forward re s pos with Not_found -> -1 in if p < 0 then s else let param = Str.matched_string s in let e = Str.match_end () in let rep = f param in (* build new string *) let s' = Str.string_before s p ^ rep ^ Str.string_after s e in (* adjust position based on change in length *) let pos = e - String.length param + String.length rep in replace ~pos re f s' ;; let rec loop_file inch outch = let line = try Some (input_line inch) with End_of_file -> None in match line with Some l -> output_string outch (replace param_re repl l); output_char outch '\n'; loop_file inch outch | None -> () ;; let () = let inch = open_in input_path in let outch = open_out output_path in loop_file inch outch; close_in inch; close_out outch batteries-included-3.4.0/build/myocamlbuild.ml000066400000000000000000000113521415601150500213770ustar00rootroot00000000000000open Ocamlbuild_plugin open Command (* no longer needed for OCaml >= 3.10.2 *) (** Overview of tags: - [pkg_batteries] to use Batteries as a library, without syntax extensions - [use_batteries] and [use_batteries_r] to use both Batteries and all the non-destructive syntax extensions - [pkg_sexplib.syntax] with [syntax_camlp4o] or [syntax_camlp4r] for sexplib *) (** {1 OCamlFind} *) let run_and_read = Ocamlbuild_pack.My_unix.run_and_read let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings module OCamlFind = struct (* this lists all supported packages *) let find_packages () = blank_sep_strings & Lexing.from_string & run_and_read "ocamlfind list | cut -d' ' -f1" (* this is supposed to list available syntaxes, but I don't know how to do it. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] (* ocamlfind command *) let ocamlfind x = S[A"ocamlfind"; x] let before_options () = (* by using Before_options one let command line options have an higher priority *) (* on the contrary using After_options will guarantee to have the higher priority *) (* override default commands by ocamlfind ones *) Options.ocamlc := ocamlfind & A"ocamlc"; Options.ocamlopt := ocamlfind & A"ocamlopt"; Options.ocamldep := ocamlfind & A"ocamldep"; Options.ocamldoc := ocamlfind & A"ocamldoc"; Options.ocamlmktop := ocamlfind & A"ocamlmktop" let get_ocamldoc_directory () = let ocamldoc_directory = run_and_read "ocamlfind ocamldoc -customdir" in let length = String.length ocamldoc_directory in assert (length != 0); let char = ocamldoc_directory.[length - 1] in if (char = '\n') || (char = '\r') then String.sub ocamldoc_directory 0 (length - 1) else ocamldoc_directory let after_rules () = (* When one link an OCaml library/binary/package, one should use -linkpkg *) flag ["ocaml"; "byte"; "link"; "program"] & A"-linkpkg"; flag ["ocaml"; "native"; "link"; "program"] & A"-linkpkg"; (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) List.iter begin fun pkg -> flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; end (find_packages ()); (* Like -package but for extensions syntax. Morover -syntax is useless * when linking. *) List.iter begin fun syntax -> flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; end (find_syntaxes ()); (* The default "thread" tag is not compatible with ocamlfind. Indeed, the default rules add the "threads.cma" or "threads.cmxa" options when using this tag. When using the "-linkpkg" option with ocamlfind, this module will then be added twice on the command line. To solve this, one approach is to add the "-thread" option when using the "threads" package using the previous plugin. *) flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) end (** {1 OCaml Batteries Included} *) module Batteries = struct let before_options () = () let after_rules () = (*The command-line for [use_batteries]*) let cl_batteries = S [A "-package"; A "batteries.syntax"; A"-syntax"; A "camlp4o"] in (** Tag [use_batteries] provides both package [batteries] and all syntax extensions, in original syntax. *) flag ["ocaml"; "compile"; "use_batteries"] & cl_batteries ; flag ["ocaml"; "ocamldep"; "use_batteries"] & cl_batteries ; flag ["ocaml"; "doc"; "use_batteries"] & cl_batteries ; flag ["ocaml"; "link"; "use_batteries"] & cl_batteries ; flag ["ocaml"; "infer_interface"; "use_batteries"] & cl_batteries ; end let _ = dispatch begin function | Before_options -> OCamlFind.before_options (); Batteries.before_options (); | After_rules -> OCamlFind.after_rules (); Batteries.after_rules (); | _ -> () end (** which ocamlrun -> header print_backtrace -> ajouter "-b" après le header **) batteries-included-3.4.0/build/ocaml000077500000000000000000000000611415601150500174000ustar00rootroot00000000000000ocaml -init `ocamlfind query batteries`/ocamlinitbatteries-included-3.4.0/build/odoc_batteries_factored.ml000066400000000000000000000507071415601150500235620ustar00rootroot00000000000000(*From OCamlDoc*) open Odoc_info;; open Odoc_info.Value open Odoc_info.Module open Odoc_info.Type open Odoc_info.Class open Odoc_info.Exception (*module StringSet = Odoc_html.StringSet*) module StringSet = Set.Make(String);; warning "Loading factored";; (*From the base library*) open List (** {1 Tools}*) (** Concatenate two names into a module path. [concat a b] is [a^"."^b] if neither [a] nor [b] is empty, [a] if [b] is empty and [b] if [a] is empty.*) let concat a b = if String.length b = 0 then a else if String.length a = 0 then b else Name.concat a b (** Return the basename in a path. [end_of_name "A.B.C.D.E.t"] produces ["t"] *) let end_of_name name = Name.get_relative (Name.father (Name.father name)) name (** Print an [info option]*) let string_of_info_opt = function | None -> "No information" | Some i -> info_string_of_info i let bs = Buffer.add_string let bp = Printf.bprintf let opt = Odoc_info.apply_opt let new_buf () = Buffer.create 1024 (** {1 Configuration}*) (** A list of primitive type names for which we should rather link to the corresponding module *) let primitive_types_names = [ "char", "Char.t"; "string", "String.t"; "array", "Array.t" ; "lazy_t", "Lazy.t"; "list", "List.t"; "option", "Option.t"; "int32", "Int32.t"; "int64", "Int64.t"; "nativeint", "Nativeint.t"; "big_int", "Big_int.t"; "int", "Int.t"; "bool", "Bool.t"; "unit", "Unit.t"; "float", "Float.t"; "ref", "Ref.t"; "exn", "Exception.t"; "format4", "Printf.format4" ] let has_parent a ~parent:b = a = b || let len_a = String.length a and len_b = String.length b in let result = len_a > len_b && let prefix = String.sub a 0 len_b in prefix = b && a.[len_b] = '.' in verbose (Printf.sprintf "Checking whether %s has parent %s: %b" a b result); result let merge_info_opt a b = verbose ("Merging information"); if a <> b then begin verbose ("1: "^(string_of_info_opt a)); verbose ("2: "^(string_of_info_opt b)); let result = Odoc_merge.merge_info_opt Odoc_types.all_merge_options a b in verbose (">: "^(string_of_info_opt result)); result end else a (** The list of modules which should appear as roots in the hierarchy. *) let roots = ["Batteries"] (** {1 Actual rewriting}*) (**[get_documents i] determines if information [i] specifies that this module "documents" another module, not included in the source tree. Specifying that module [Foo] documents module [Bar] means that every hyperlink to some element [e] in module [Bar] should actually point to an with the same name in module [Foo]. To add such a specification, add [@documents Bar] to the module comments of module [Foo]. Typical use of this feature: - the documentation of module [Sna] makes use of elements (types, values, etc.) of module [Bar] - module [Bar] is not included in the project, as it belongs to another project - for some reason, documenting module [Bar] is important, possibly because this module has not been documented by its original author or because it is expected that developers will need to read through the documentation of module [Bar] so often that this documentation should be added to the project - create a module [Foo] in the project by importing or re-creating [bar.mli] - document [foo.mli] - add [@documents Bar] in the module comments of module [Foo] *) let get_documents = function | None -> [] | Some i -> List.fold_left (fun acc x -> match x with | ("documents", [Raw s]) -> verbose ("This module documents "^s); s::acc | ("documents", x ) -> warning ("Weird documents "^(string_of_text x)); (string_of_text x)::acc | _ -> acc) [] i.i_custom (* undocumented for now, possibly useless *) let get_documented = function | None -> [] | Some i -> List.fold_left (fun acc x -> match x with | ("documented", [Raw s]) -> verbose ("This module should take its place as "^s); s::acc | ("documented", x ) -> warning ("Weird documented "^(string_of_text x)); (string_of_text x)::acc | _ -> acc) [] i.i_custom (** [module_dependencies m] lists the dependencies of a module [m] in terms of other modules*) let module_dependencies m = let rec handle_kind acc = function | Module_struct e -> List.fold_left (fun acc x -> handle_element acc x) acc e | Module_alias a -> a.ma_name :: acc | Module_functor (_, a) -> handle_kind acc a | Module_apply (a, b) -> handle_kind (handle_kind acc a) b | Module_with (_, _) -> acc | Module_constraint (a, _) -> handle_kind acc a and handle_element acc = function | Element_module m -> handle_kind acc m.m_kind | Element_included_module a -> a.im_name :: acc | _ -> acc in handle_kind m.m_top_deps m.m_kind (** [rebuild_structure m] walks through list [m] and rebuilds it as a forest of modules and sub-modules. - Resolving aliases: if we have a module [A] containing [module B = C], module [C] is renamed [A.B] and we keep that renaming for reference generation. - Resolving inclusions: if we have a module [A] containing [include C], the contents of module [C] are copied into [A] and we fabricate a renaming from [C] to [A] for reference generation. @return [(m, r)], where [m] is the new list of modules and [r] is a mapping from old module names to new module names. *) let rebuild_structure modules = let all_renamed_modules = Hashtbl.create 256 (**Mapping [old name] -> [new name, latest info]*) and all_renamed_module_types = Hashtbl.create 256 (**Mapping [old name] -> [new name, latest info]*) and all_modules = Hashtbl.create 256 (**Mapping [name] -> [t_module] -- unused*) in let add_renamed_module ~old:(old_name,old_info) ~current:(new_name,new_info) = verbose ("Setting module renaming from "^old_name^" to "^new_name); try let (better, better_info) = Hashtbl.find all_renamed_modules new_name in verbose ("... actually setting renaming from "^old_name^" to "^better); let complete_info = merge_info_opt (merge_info_opt old_info new_info) better_info in Hashtbl.replace all_renamed_modules old_name (better, complete_info); complete_info with Not_found -> let complete_info = merge_info_opt old_info new_info in Hashtbl.add all_renamed_modules old_name (new_name, complete_info); complete_info and add_renamed_module_type old current = verbose ("Setting module type renaming from "^old^" to "^current); try let further_references = Hashtbl.find all_renamed_module_types current in verbose ("... actually setting renaming from "^old^" to "^further_references); Hashtbl.add all_renamed_module_types old further_references with Not_found -> Hashtbl.add all_renamed_module_types old current in (*First pass: build hierarchy*) let rec handle_kind path (m:t_module) = function | Module_struct x -> Module_struct (List.flatten (List.map (handle_module_element path m) x)) | Module_alias x -> Module_alias (handle_alias path m x) | Module_functor (p, k) -> Module_functor (p, handle_kind path m k) | Module_apply (x, y) -> Module_apply (handle_kind path m x, handle_kind path m y) | Module_with (k, s) -> Module_with (handle_type_kind path m k, s) | Module_constraint (x, y) -> Module_constraint (handle_kind path m x, handle_type_kind path m y) and handle_module_element path m = function | Element_module x -> [Element_module (handle_module path m x)] | Element_module_type x -> [Element_module_type (handle_module_type path m x)] | Element_module_comment _ as y -> [y] | Element_class x -> [Element_class {(x) with cl_name = concat path (Name.simple x.cl_name)}] | Element_class_type x -> [Element_class_type{(x) with clt_name = concat path (Name.simple x.clt_name)}] | Element_value x -> [Element_value {(x) with val_name = concat path (Name.simple x.val_name)}] | Element_exception x -> [Element_exception {(x) with ex_name = concat path (Name.simple x.ex_name)}] | Element_type x -> [Element_type {(x) with ty_name = concat path (Name.simple x.ty_name)}] | Element_included_module x as y -> (* verbose ("Meeting inclusion "^x.im_name);*) match x.im_module with | Some (Mod a) -> verbose ("This is an included module, we'll treat it as "^path); let a' = handle_module path m {(a) with m_name = ""} in ( match a'.m_kind with | Module_struct l -> (*Copy the contents of [a] into [m]*) (*Copy the information on [a] into [m]*) verbose ("Merging "^m.m_name^" and included "^a'.m_name); m.m_info <- merge_info_opt (add_renamed_module ~old:(a.m_name,a.m_info) ~current:(m.m_name, m.m_info)) (add_renamed_module ~old:(Name.get_relative m.m_name a.m_name, None) ~current:(m.m_name, m.m_info)); l | _ -> verbose ("Structure of the module is complex"); [Element_included_module {(x) with im_module = Some (Mod a')}] (*Otherwise, it's too complicated*) ) | Some (Modtype a) -> (* verbose ("This is an included module type");*) let a' = handle_module_type path m a in [Element_included_module {(x) with im_module = Some (Modtype a')}] | None -> verbose ("Module couldn't be found"); m.m_info <- add_renamed_module ~old:(x.im_name,None) ~current:(m.m_name,m.m_info); [y] and handle_module path m t = let path' = concat path (Name.simple t.m_name) in verbose ("Visiting module "^t.m_name^" from "^m.m_name^", at path "^path'); let result = {(t) with m_kind = handle_kind path' t t.m_kind; m_name = path'} in result.m_info <- add_renamed_module ~old:(t.m_name,t.m_info) ~current:(path',None); (match get_documents t.m_info with | [] -> verbose ("No @documents for module "^t.m_name) | l -> List.iter (fun r -> verbose ("Manual @documents of module "^r^" with "^path'); result.m_info <- add_renamed_module ~old:(r,None) ~current:(path',result.m_info)) l); (match get_documented t.m_info with | [] -> verbose ("No @documented for module "^t.m_name) | l -> List.iter (fun r -> verbose ("Manual @documented of module "^r^" with "^path'); result.m_info <- add_renamed_module ~current:(r,None) ~old:(path',result.m_info)) l); result and handle_module_type path m (t:Odoc_module.t_module_type) = let path' = concat path (Name.simple t.mt_name) in verbose ("Visiting module "^t.mt_name^" from "^m.m_name^", at path "^path'); let result = {(t) with mt_kind = (match t.mt_kind with | None -> None | Some kind -> Some (handle_type_kind path' m kind)); mt_name = path'} in add_renamed_module_type t.mt_name path'; result and handle_alias path m (t:module_alias) : module_alias = (*Module [m] is an alias to [t.ma_module]*) match t.ma_module with | None -> verbose ("I'd like to merge information from "^m.m_name^" and "^t.ma_name^" but I can't find that module"); t (*let rec aux = function | [] -> verbose ("Can't do better"); t | x::xs -> if Name.prefix x t.ma_name then let suffix = Name.get_relative x t.ma_name in let info = add_renamed_module ~old:(suffix, m.m_info) ~current:(path, None) in {(t) with ma_name = suffix} else aux xs in aux packs*) | Some (Mod a) -> (* add_renamed_module a.m_name path;*) verbose ("Merging information from "^m.m_name^" and aliased "^a.m_name); let info = add_renamed_module ~old:(a.m_name,a.m_info) ~current:(path,m.m_info) in m.m_info <- info; a.m_info <- info; let a' = {(a) with m_kind = handle_kind path m a.m_kind} in {(t) with ma_module = Some (Mod a')} | Some (Modtype a) -> verbose ("Merging information from "^m.m_name^" and aliased type "^a.mt_name); m.m_info <- merge_info_opt m.m_info a.mt_info; a.mt_info <- m.m_info; add_renamed_module_type a.mt_name path; let info = Odoc_merge.merge_info_opt Odoc_types.all_merge_options m.m_info a.mt_info in let a' = match a.mt_kind with | None -> a | Some kind -> {(a) with mt_kind = Some (handle_type_kind path m kind); mt_info = info} in {(t) with ma_module = Some (Modtype a')} and handle_type_kind path m :module_type_kind -> module_type_kind = function | Module_type_struct x -> Module_type_struct (List.flatten (List.map (handle_module_element path m) x)) | Module_type_functor (p, x)-> Module_type_functor (p, handle_type_kind path m x) | Module_type_alias x -> Module_type_alias (handle_type_alias path m x) | Module_type_with (k, s) -> Module_type_with (handle_type_kind path m k, s) and handle_type_alias path m t = match t.mta_module with | None -> (*verbose ("module type "^t.mta_name^" not resolved in cross-reference stage");*) t | Some a -> (*verbose ("module type "^a.mt_name^" renamed "^(concat m.m_name a.mt_name));*) (*if a.mt_info <> None then m.m_info <- a.mt_info;*) add_renamed_module_type a.mt_name path; let info = Odoc_merge.merge_info_opt Odoc_types.all_merge_options m.m_info a.mt_info in {(t) with mta_module = Some ({(a) with mt_name = concat m.m_name a.mt_name; mt_info = info})} in (*1. Find root modules, i.e. modules which are neither included nor aliased*) (* let all_roots = Hashtbl.create 100 in List.iter (fun x -> if Name.father x.m_name = "" then ( (* verbose ("Adding "^x.m_name^" to the list of roots");*) Hashtbl.add all_roots x.m_name x ) (*else verbose ("Not adding "^x.m_name^" to the list of roots")*) ) modules; List.iter (fun x -> begin List.iter (fun y -> (*verbose(" removing "^y^" which is brought out by "^x.m_name);*) Hashtbl.remove all_roots y ) (*x.m_top_deps*) (module_dependencies x) end) modules; Hashtbl.iter (fun name _ -> verbose ("Root: "^name)) all_roots; (*let for_rewriting = Hashtbl.fold (fun k m acc -> if List.mem k roots then begin verbose ("Rewriting: " ^k); (k,m)::acc end else begin verbose ("Not rewriting: "^k); acc end) all_roots [] in*) (*Actually, we're only interested in modules which appear in [roots]*) (*Note: we could probably do something much more simple, without resorting to this dependency analysis stuff*)*) let for_rewriting = List.fold_left (fun acc x -> Hashtbl.add all_modules x.m_name x; if List.mem x.m_name roots then begin verbose ("We need to visit module "^x.m_name); (x.m_name, x)::acc end else begin verbose ("Discarding module "^x.m_name^" for now"); acc end) [] modules in verbose ("[Starting to rearrange module structure]"); (* let for_rewriting = Hashtbl.fold (fun k m acc -> (k,m)::acc) all_roots [] in*) (*2. Dive into these*) (*let rewritten = Hashtbl.fold (fun name contents acc -> {(contents) with m_kind = handle_kind name contents contents.m_kind}::acc ) all_roots [] in*) let rewritten = List.fold_left (fun acc (name, contents) -> {(contents) with m_kind = handle_kind "" contents contents.m_kind}::acc) [] for_rewriting in let result = Search.modules rewritten in (*TODO: Second pass: walk through references -- handled during html generation for the moment*) (result, all_renamed_modules) (** Determine into which topics each module/type/value/... goes *) let sort_by_topics modules = let write s = verbose ( "[SORT] "^s ) in let rec string_of_path = function | [] -> "" | (`Level l)::t -> Printf.sprintf "[%d] > %s" l (string_of_path t) | (`Topic top)::t -> Printf.sprintf "%s > %s" top (string_of_path t) in (*let write s = Printf.eprintf "[SORT] %s\n%!" s in*) let topics : StringSet.t ref = ref StringSet.empty (**The set of topics*) and modules_by_topic : (string, t_module list ref) Hashtbl.t = Hashtbl.create 16 (**topic -> set of modules*) in let add_module top m = write ("Adding module "^m.m_name); List.iter (function `Topic t -> write ("Adding module "^m.m_name^" to topic "^t); ( try let l = Hashtbl.find modules_by_topic t in l := m :: !l with Not_found -> Hashtbl.add modules_by_topic t (ref [m]) ) | _ -> ()) top in let push_top_topic l t = (*Push the latest topic on the stack of topics/levels*) write ("Adding topic "^t); topics := StringSet.add t !topics; let result = (`Topic t)::l in write ("Added topics from "^(string_of_path l)^" to "^(string_of_path result)); result and push_top_level l t = (*Push the latest level on the stack of topics/levels*) write ("Entering level "^(string_of_int t)); let result = (`Level t)::l in write ("Entered level from "^(string_of_path l)^" to "^(string_of_path result)); result and pop_top_to_level l level = write ("Removing levels higher than "^(string_of_int level)); let rec aux prefix = function | (`Level l')::t when l' >= level -> aux [] t | ((`Topic _ ) as p)::t -> aux (p::prefix) t | _ as t -> List.rev_append prefix t in let result = aux [] l in write("From "^(string_of_path l)^" to "^(string_of_path result)); result in let adjust_to_level top level = write ("Moving to level "^(string_of_int level)); let result = push_top_level (pop_top_to_level top level) level in write("Moved levels from "^(string_of_path top)^" to "^(string_of_path result)); result in let adjust_top_from_comment top c = fold_left (fun acc text -> match text with | Title (level, title, text) -> adjust_to_level acc level | Custom (("topic" | "{topic"), text) -> write ("Custom topic "^(string_of_text text)); push_top_topic acc (string_of_text text) | Custom (other, _) -> write ("Custom other "^other); acc | _ -> acc ) top c in let adjust_top_from_info top = function | None -> top | Some ({i_custom = l} as i) -> write ("Meeting custom in info "^(string_of_info i)); List.fold_left (fun acc -> function (("topic"|"{topic"), t) -> write ("Custom topic in info "^(string_of_text t)); push_top_topic acc (string_of_text t) | (other, content) -> write ("Custom other in info "^other^": "^(string_of_text content)); acc (* | _ -> acc*)) top l in let rec handle_kind top = function | Module_struct x -> List.fold_left handle_module_element top x | _ -> top and handle_module_element top = function | Element_module x -> let top' = adjust_top_from_info top x.m_info in add_module top' x; ignore (handle_kind top' x.m_kind); top | Element_module_comment c -> adjust_top_from_comment top c (*Extract level (if any) and topics (if any) If level exists - pop from [top] until we're at a level strictly higher than the level specified - push the level of [c] and, if available, information If no level exists but information exists - push the information at the current level Otherwise - do nothing *) (* let (level, topic) = extract_info_from_comment c in (match (level, topic) with | (None, Some x) -> List.fold push_top_topic top x | (Some l, None) -> push_top_level (pop_top_to_level top l) l | (Some l, Some x)-> List.fold push_top_topic (push_top_level (pop_top_to_level top l) l) x | _ -> top)*) | _ -> top (*!TODO: other tables*) and handle_module top m = handle_kind (adjust_top_from_info top m.m_info) m.m_kind in let _ = List.fold_left handle_module [] modules in (StringSet.elements !topics, modules_by_topic) let find_renaming renamings original = let rec aux s suffix = if String.length s = 0 then ( (* verbose ("Name '"^original^"' remains unchanged");*) suffix ) else let renaming = try Some (fst(Hashtbl.find renamings s)) with Not_found -> None in match renaming with | None -> let father = Name.father s in let son = Name.get_relative father s in aux father (concat son suffix) | Some r -> (*We have found a substitution, it should be over*) let result = concat r suffix in (* verbose ("We have a renaming of "^s^" to "^r);*) verbose ("Name "^original^" replaced with "^result); result in aux original "" batteries-included-3.4.0/build/odoc_extract_mli.ml000066400000000000000000000226171415601150500222430ustar00rootroot00000000000000(* * Odoc_generator_batlib - custom documentation generator for Batteries * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (* Incomplete *) (*From OCamlDoc*) open Odoc_info;; module Name = Odoc_name open Odoc_info.Value open Odoc_info.Module open Odoc_info.Type open Odoc_info.Class open Odoc_info.Exception INCLUDE "../build/odoc_batteries_factored.ml" (*From the base library*) open List open Format (** Apply [f] to the first element of [l] then [g ()] then [f] to the second element of [l], then [g ()]... finally, apply [f] to the last element of [l]. If [l] contains 0 or 1 element, [g] is never applied. *) let interleave f g l = match l with | [] -> () | [x] -> f x | h::t -> f h; List.iter (fun x -> g (); f x) t let o out = Format.fprintf out "%s\n" let p out f = Format.fprintf out f let get_root l = List.find (fun x -> x.m_name = "Batteries") l class mli_generator = object(self) method generate modules = match !Odoc_args.dump with | Some _ -> assert false | None -> verbose "Generation started"; let name = Filename.concat !Args.target_dir "generated.mli" in let cout = open_out name in let out = Format.formatter_of_out_channel cout in self#handle_root out (get_root (fst (rebuild_structure modules))); flush cout; close_out cout; Printf.eprintf "Output printed to %S\n" name; Odoc_info.verbose (Odoc_messages.file_generated name) method handle_root out m = self#handle_info_option out m.m_info; match m.m_kind with Module_struct l -> (*Don't print "struct..end"*) interleave (self#handle_module_element out) (pp_print_newline out) l | _ -> assert false (*Normally, the root module should be a structure.*) method handle_module_kind out = function | Module_struct l -> fprintf out "struct@[@\n%a@\n@]end@\n" (fun out -> interleave (self#handle_module_element out) (pp_print_newline out) ) l | Module_alias a -> self#handle_module_alias out a | Module_functor (p, k) -> fprintf out "functor(%s: %a) ->@\n%a" (Name.simple p.mp_name) self#handle_module_type_kind p.mp_kind self#handle_module_kind k | Module_apply (x, y) -> fprintf out "%a(%a)" self#handle_module_kind x self#handle_module_kind y | Module_with (k, t) -> fprintf out "%a with %s" self#handle_module_type_kind k t | Module_constraint (_, _) -> assert false method handle_info_option out = function | None -> () | Some x -> self#handle_info out x method handle_info out info = fprintf out "(**%s*)@\n" (info_string_of_info info) method handle_text_option out = function | None -> () | Some x -> self#handle_text out x method handle_text out x = fprintf out "(**%s*)@\n" (text_string_of_text x) method handle_module_element out = function | Element_module x -> self#handle_module out x | Element_module_type x -> self#handle_module_type out x | Element_included_module x -> self#handle_included_module out x | Element_class x -> self#handle_class out x | Element_class_type x -> self#handle_class_type out x | Element_value x -> self#handle_value out x | Element_exception x -> self#handle_exception out x | Element_type x -> self#handle_type out x | Element_module_comment x -> self#handle_module_comment out x method handle_module_comment out m = self#handle_text out m method handle_module_alias out x = match x.ma_module with | None -> fprintf out "module alias not found ??\n" | Some (Mod m) -> self#handle_anonymous_module out m | Some (Modtype m) -> self#handle_anonymous_module_type out m method handle_module out m = fprintf out "%amodule %s = %a@\n" self#handle_info_option m.m_info (Name.simple m.m_name) self#handle_module_kind m.m_kind method handle_module_type out m = fprintf out "%amodule type %s : %a@\n" self#handle_info_option m.mt_info (Name.simple m.mt_name) (fun out m -> match m.mt_kind with | None -> fprintf out "module type ??@\n" | Some x -> self#handle_module_type_kind out x) m method handle_anonymous_module out m = fprintf out "%a%a@\n" self#handle_info_option m.m_info self#handle_module_kind m.m_kind method handle_anonymous_module_type out m = self#handle_info_option out m.mt_info; match m.mt_kind with | None -> fprintf out "module type ??@\n" | Some x -> self#handle_module_type_kind out x method handle_module_type_kind out = function | Module_type_struct l -> fprintf out "sig@[%a@]end@\n" (fun out -> interleave (self#handle_module_element out) (pp_print_newline out) ) l | Module_type_functor (x,y) -> fprintf out "functor(%s: %a) ->@\n%a" (Name.simple x.mp_name) self#handle_module_type_kind x.mp_kind self#handle_module_type_kind y | Module_type_alias x -> self#handle_module_type_alias out x | Module_type_with (x, y) -> fprintf out "%a with %s" self#handle_module_type_kind x y method handle_module_type_alias out x = match x.mta_module with | None -> fprintf out "module type alias ??\n" | Some m -> self#handle_module_type out m method handle_included_module out x = match x.im_module with | None -> fprintf out "include ??\n" | Some (Mod m) -> self#handle_module out m | Some (Modtype m) -> self#handle_module_type out m method handle_class out x = fprintf out "class not implemented yet??\n" method handle_class_type out _ = fprintf out "class type not implemented yet??\n" method handle_value out x = fprintf out "%a@[val %s : %a@]@\n" self#handle_info_option x.val_info (Name.simple x.val_name) self#handle_type_expr x.val_type (*x.val_name (fun out l -> interleave (self#handle_parameter out) (fun () -> fprintf out " -> ") l ) x.val_parameters*) method handle_exception out x = fprintf out "%a@[exception %s %a @]@\n" self#handle_info_option x.ex_info (Name.simple x.ex_name) self#handle_type_expr_list x.ex_args method handle_type out x = fprintf out "%a@[type %a%s%a@]@\n" self#handle_info_option x.ty_info self#handle_type_args x.ty_parameters (Name.simple x.ty_name) self#handle_type_kind x.ty_kind method handle_type_arg out = function | (x, true, false) -> fprintf out "+%a" self#handle_type_expr x | (x, false, true) -> fprintf out "-%a" self#handle_type_expr x | (x, false, false)-> self#handle_type_expr out x | (x, true, true) -> fprintf out "type both co and contra variant ??%a" self#handle_type_expr x method handle_type_args out = function | [] -> () | [x]-> fprintf out "%a" self#handle_type_arg x | l -> fprintf out "(%a)" (fun out l -> interleave (self#handle_type_arg out) (fun () -> fprintf out ", ") l) l method handle_type_kind out = function | Type_abstract -> () | Type_variant l -> fprintf out "@[@\n%a@]@\n" (fun out l -> interleave (self#handle_variant_constructor out) (fun () -> fprintf out "@\n|") l ) l | Type_record l -> fprintf out "@[{%a}@]@\n" (fun out l -> interleave (self#handle_record_field out) (fun () -> fprintf out ";@\n") l ) l method handle_variant_constructor out x = fprintf out "%s %a%a" (Name.simple x.vc_name) self#handle_type_expr_list x.vc_args self#handle_text_option x.vc_text method handle_type_expr_list out = function | [] -> () | l -> fprintf out " of %a " (fun out l -> interleave (self#handle_type_expr out) (fun () -> fprintf out " * ") l ) l method handle_record_field out x = fprintf out "%a%s: %a%a" self#handle_mutability x.rf_mutable (Name.simple x.rf_name) self#handle_type_expr x.rf_type self#handle_text_option x.rf_text method handle_mutability out = function | false -> () | true -> fprintf out "mutable " method handle_type_expr out x = fprintf out "%s" (string_of_type_expr x) end;; warning "Loading batteries.mli generator";; let generator = (new mli_generator :> Args.doc_generator) let set_mli_generator () = Args.set_doc_generator (Some generator) let _ = Odoc_args.verbose := true; set_mli_generator (); verbose ("Generator loaded"); Args.add_option ("-html", Arg.Unit (fun _ -> Odoc_info.verbose "Deactivating built-in html generator"; set_mli_generator()) , "") batteries-included-3.4.0/build/odoc_generator_batlib.ml000066400000000000000000001120061415601150500232230ustar00rootroot00000000000000(* * Odoc_generator_batlib - custom documentation generator for Batteries * Copyright (C) 2008 Maxence Guesdon * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (*From OCamlDoc*) open Odoc_info;; module Naming = Odoc_html.Naming module Name = Odoc_name open Odoc_info.Value open Odoc_info.Module open Odoc_info.Type open Odoc_info.Class open Odoc_info.Exception (*From the base library*) open List (** {1 Tools}*) (** Concatenate two names into a module path. [concat a b] is [a^"."^b] if neither [a] nor [b] is empty, [a] if [b] is empty and [b] if [a] is empty.*) let concat a b = if String.length b = 0 then a else if String.length a = 0 then b else Name.concat a b (** Return the basename in a path. [end_of_name "A.B.C.D.E.t"] produces ["t"] *) let end_of_name name = Name.get_relative (Name.father (Name.father name)) name (** Print an [info option]*) let string_of_info_opt = function | None -> "No information" | Some i -> info_string_of_info i let bs = Buffer.add_string let bp = Printf.bprintf let opt = Odoc_info.apply_opt let new_buf () = Buffer.create 1024 (** {1 Configuration}*) (** A list of primitive type names for which we should rather link to the corresponding module *) let primitive_types_names = [ "char", "Data.Text.Char.t"; "string", "Data.Text.String.t"; "array", "Data.Mutable.Array.t" ; "lazy_t", "Data.Persistent.Lazy.t"; "list", "Data.Persistent.List.t"; "option", "Data.Persistent.Option.t"; "int32", "Data.Numeric.Int32.t"; "int64", "Data.Numeric.Int64.t"; "nativeint", "Data.Numeric.Nativeint.t"; "big_int", "Data.Numeric.Big_int.t"; "int", "Data.Numeric.Int.t"; "bool", "Data.Logical.Bool.t"; "unit", "Data.Numeric.Unit.t"; "float", "Data.Numeric.Float.t"; "ref", "Data.Mutable.Ref"; (*"exn", "Batteries.Control.Exceptions.Exn.t";*)(*Module not implemented yet*) "format4", "Languages.Printf.format4" ] let has_parent a ~parent:b = a = b || let len_a = String.length a and len_b = String.length b in let result = len_a > len_b && let prefix = String.sub a 0 len_b in prefix = b && a.[len_b] = '.' in verbose (Printf.sprintf "Checking whether %s has parent %s: %b" a b result); result (** The list of modules which should appear as roots in the hierarchy. *) let roots = ["Batteries"] let merge_info_opt a b = verbose ("Merging information"); if a <> b then begin verbose ("1: "^(string_of_info_opt a)); verbose ("2: "^(string_of_info_opt b)); let result = Odoc_merge.merge_info_opt Odoc_types.all_merge_options a b in verbose (">: "^(string_of_info_opt result)); result end else a (** {1 Actual rewriting}*) (**[get_documents i] determines if information [i] specifies that this module "documents" another module, not included in the source tree. Specifying that module [Foo] documents module [Bar] means that every hyperlink to some element [e] in module [Bar] should actually point to an with the same name in module [Foo]. To add such a specification, add [@documents Bar] to the module comments of module [Foo]. Typical use of this feature: - the documentation of module [Sna] makes use of elements (types, values, etc.) of module [Bar] - module [Bar] is not included in the project, as it belongs to another project - for some reason, documenting module [Bar] is important, possibly because this module has not been documented by its original author or because it is expected that developers will need to read through the documentation of module [Bar] so often that this documentation should be added to the project - create a module [Foo] in the project by importing or re-creating [bar.mli] - document [foo.mli] - add [@documents Bar] in the module comments of module [Foo] *) let get_documents = function | None -> [] | Some i -> List.fold_left (fun acc x -> match x with | ("documents", [Raw s]) -> verbose ("This module documents "^s); s::acc | ("documents", x ) -> warning ("Weird documents "^(string_of_text x)); (string_of_text x)::acc | _ -> acc) [] i.i_custom (* undocumented for now, possibly useless *) let get_documented = function | None -> [] | Some i -> List.fold_left (fun acc x -> match x with | ("documented", [Raw s]) -> verbose ("This module should take its place as "^s); s::acc | ("documented", x ) -> warning ("Weird documented "^(string_of_text x)); (string_of_text x)::acc | _ -> acc) [] i.i_custom (** [module_dependencies m] lists the dependencies of a module [m] in terms of other modules*) let module_dependencies m = let rec handle_kind acc = function | Module_struct e -> List.fold_left (fun acc x -> handle_element acc x) acc e | Module_alias a -> a.ma_name :: acc | Module_functor (_, a) -> handle_kind acc a | Module_apply (a, b) -> handle_kind (handle_kind acc a) b | Module_with (_, _) -> acc | Module_constraint (a, _) -> handle_kind acc a and handle_element acc = function | Element_module m -> handle_kind acc m.m_kind | Element_included_module a -> a.im_name :: acc | _ -> acc in handle_kind m.m_top_deps m.m_kind (** [rebuild_structure m] walks through list [m] and rebuilds it as a forest of modules and sub-modules. - Resolving aliases: if we have a module [A] containing [module B = C], module [C] is renamed [A.B] and we keep that renaming for reference generation. - Resolving inclusions: if we have a module [A] containing [include C], the contents of module [C] are copied into [A] and we fabricate a renaming from [C] to [A] for reference generation. @return [(m, r)], where [m] is the new list of modules and [r] is a mapping from old module names to new module names. *) let rebuild_structure modules = let all_renamed_modules = Hashtbl.create 256 (**Mapping [old name] -> [new name, latest info]*) and all_renamed_module_types = Hashtbl.create 256 (**Mapping [old name] -> [new name, latest info]*) and all_modules = Hashtbl.create 256 (**Mapping [name] -> [t_module] -- unused*) in let add_renamed_module ~old:(old_name,old_info) ~current:(new_name,new_info) = verbose ("Setting module renaming from "^old_name^" to "^new_name); try let (better, better_info) = Hashtbl.find all_renamed_modules new_name in verbose ("... actually setting renaming from "^old_name^" to "^better); let complete_info = merge_info_opt (merge_info_opt old_info new_info) better_info in Hashtbl.replace all_renamed_modules old_name (better, complete_info); complete_info with Not_found -> let complete_info = merge_info_opt old_info new_info in Hashtbl.add all_renamed_modules old_name (new_name, complete_info); complete_info and add_renamed_module_type old current = verbose ("Setting module type renaming from "^old^" to "^current); try let further_references = Hashtbl.find all_renamed_module_types current in verbose ("... actually setting renaming from "^old^" to "^further_references); Hashtbl.add all_renamed_module_types old further_references with Not_found -> Hashtbl.add all_renamed_module_types old current in (*First pass: build hierarchy*) let rec handle_kind path (m:t_module) = function | Module_struct x -> Module_struct (List.flatten (List.map (handle_module_element path m) x)) | Module_alias x -> Module_alias (handle_alias path m x) | Module_functor (p, k) -> Module_functor (p, handle_kind path m k) | Module_apply (x, y) -> Module_apply (handle_kind path m x, handle_kind path m y) | Module_with (k, s) -> Module_with (handle_type_kind path m k, s) | Module_constraint (x, y) -> Module_constraint (handle_kind path m x, handle_type_kind path m y) and handle_module_element path m = function | Element_module x -> [Element_module (handle_module path m x)] | Element_module_type x -> [Element_module_type (handle_module_type path m x)] | Element_module_comment _ as y -> [y] | Element_class x -> [Element_class {(x) with cl_name = concat path (Name.simple x.cl_name)}] | Element_class_type x -> [Element_class_type{(x) with clt_name = concat path (Name.simple x.clt_name)}] | Element_value x -> [Element_value {(x) with val_name = concat path (Name.simple x.val_name)}] | Element_exception x -> [Element_exception {(x) with ex_name = concat path (Name.simple x.ex_name)}] | Element_type x -> [Element_type {(x) with ty_name = concat path (Name.simple x.ty_name)}] | Element_included_module x as y -> (* verbose ("Meeting inclusion "^x.im_name);*) match x.im_module with | Some (Mod a) -> verbose ("This is an included module, we'll treat it as "^path); let a' = handle_module path m {(a) with m_name = ""} in ( match a'.m_kind with | Module_struct l -> (*Copy the contents of [a] into [m]*) (*Copy the information on [a] into [m]*) verbose ("Merging "^m.m_name^" and included "^a'.m_name); m.m_info <- merge_info_opt (add_renamed_module ~old:(a.m_name,a.m_info) ~current:(m.m_name, m.m_info)) (add_renamed_module ~old:(Name.get_relative m.m_name a.m_name, None) ~current:(m.m_name, m.m_info)); l | _ -> verbose ("Structure of the module is complex"); [Element_included_module {(x) with im_module = Some (Mod a')}] (*Otherwise, it's too complicated*) ) | Some (Modtype a) -> (* verbose ("This is an included module type");*) let a' = handle_module_type path m a in [Element_included_module {(x) with im_module = Some (Modtype a')}] | None -> verbose ("Module couldn't be found"); m.m_info <- add_renamed_module ~old:(x.im_name,None) ~current:(m.m_name,m.m_info); [y] and handle_module path m t = let path' = concat path (Name.simple t.m_name) in verbose ("Visiting module "^t.m_name^" from "^m.m_name^", at path "^path'); let result = {(t) with m_kind = handle_kind path' t t.m_kind; m_name = path'} in result.m_info <- add_renamed_module ~old:(t.m_name,t.m_info) ~current:(path',None); (match get_documents t.m_info with | [] -> verbose ("No @documents for module "^t.m_name) | l -> List.iter (fun r -> verbose ("Manual @documents of module "^r^" with "^path'); result.m_info <- add_renamed_module ~old:(r,None) ~current:(path',result.m_info)) l); (match get_documented t.m_info with | [] -> verbose ("No @documented for module "^t.m_name) | l -> List.iter (fun r -> verbose ("Manual @documented of module "^r^" with "^path'); result.m_info <- add_renamed_module ~current:(r,None) ~old:(path',result.m_info)) l); result and handle_module_type path m (t:Odoc_module.t_module_type) = let path' = concat path (Name.simple t.mt_name) in let result = {(t) with mt_kind = (match t.mt_kind with | None -> None | Some kind -> Some (handle_type_kind path' m kind)); mt_name = path'} in add_renamed_module_type t.mt_name path'; result and handle_alias path m (t:module_alias) : module_alias = (*Module [m] is an alias to [t.ma_module]*) match t.ma_module with | None -> verbose ("I'd like to merge information from "^m.m_name^" and "^t.ma_name^" but I can't find that module"); t (*let rec aux = function | [] -> verbose ("Can't do better"); t | x::xs -> if Name.prefix x t.ma_name then let suffix = Name.get_relative x t.ma_name in let info = add_renamed_module ~old:(suffix, m.m_info) ~current:(path, None) in {(t) with ma_name = suffix} else aux xs in aux packs*) | Some (Mod a) -> (* add_renamed_module a.m_name path;*) verbose ("Merging information from "^m.m_name^" and aliased "^a.m_name); let info = add_renamed_module ~old:(a.m_name,a.m_info) ~current:(path,m.m_info) in m.m_info <- info; a.m_info <- info; let a' = {(a) with m_kind = handle_kind path m a.m_kind} in {(t) with ma_module = Some (Mod a')} | Some (Modtype a) -> verbose ("Merging information from "^m.m_name^" and aliased type "^a.mt_name); m.m_info <- merge_info_opt m.m_info a.mt_info; a.mt_info <- m.m_info; add_renamed_module_type a.mt_name path; let info = Odoc_merge.merge_info_opt Odoc_types.all_merge_options m.m_info a.mt_info in let a' = match a.mt_kind with | None -> a | Some kind -> {(a) with mt_kind = Some (handle_type_kind path m kind); mt_info = info} in {(t) with ma_module = Some (Modtype a')} and handle_type_kind path m :module_type_kind -> module_type_kind = function | Module_type_struct x -> Module_type_struct (List.flatten (List.map (handle_module_element path m) x)) | Module_type_functor (p, x)-> Module_type_functor (p, handle_type_kind path m x) | Module_type_alias x -> Module_type_alias (handle_type_alias path m x) | Module_type_with (k, s) -> Module_type_with (handle_type_kind path m k, s) and handle_type_alias path m t = match t.mta_module with | None -> (*verbose ("module type "^t.mta_name^" not resolved in cross-reference stage");*) t | Some a -> (*verbose ("module type "^a.mt_name^" renamed "^(concat m.m_name a.mt_name));*) (*if a.mt_info <> None then m.m_info <- a.mt_info;*) add_renamed_module_type a.mt_name path; let info = Odoc_merge.merge_info_opt Odoc_types.all_merge_options m.m_info a.mt_info in {(t) with mta_module = Some ({(a) with mt_name = concat m.m_name a.mt_name; mt_info = info})} in (*1. Find root modules, i.e. modules which are neither included nor aliased*) (* let all_roots = Hashtbl.create 100 in List.iter (fun x -> if Name.father x.m_name = "" then ( (* verbose ("Adding "^x.m_name^" to the list of roots");*) Hashtbl.add all_roots x.m_name x ) (*else verbose ("Not adding "^x.m_name^" to the list of roots")*) ) modules; List.iter (fun x -> begin List.iter (fun y -> (*verbose(" removing "^y^" which is brought out by "^x.m_name);*) Hashtbl.remove all_roots y ) (*x.m_top_deps*) (module_dependencies x) end) modules; Hashtbl.iter (fun name _ -> verbose ("Root: "^name)) all_roots; (*let for_rewriting = Hashtbl.fold (fun k m acc -> if List.mem k roots then begin verbose ("Rewriting: " ^k); (k,m)::acc end else begin verbose ("Not rewriting: "^k); acc end) all_roots [] in*) (*Actually, we're only interested in modules which appear in [roots]*) (*Note: we could probably do something much more simple, without resorting to this dependency analysis stuff*)*) let for_rewriting = List.fold_left (fun acc x -> Hashtbl.add all_modules x.m_name x; if List.mem x.m_name roots then begin verbose ("We need to visit module "^x.m_name); (x.m_name, x)::acc end else begin verbose ("Discarding module "^x.m_name^" for now"); acc end) [] modules in verbose ("[Starting to rearrange module structure]"); (* let for_rewriting = Hashtbl.fold (fun k m acc -> (k,m)::acc) all_roots [] in*) (*2. Dive into these*) (*let rewritten = Hashtbl.fold (fun name contents acc -> {(contents) with m_kind = handle_kind name contents contents.m_kind}::acc ) all_roots [] in*) let rewritten = List.fold_left (fun acc (name, contents) -> {(contents) with m_kind = handle_kind "" contents contents.m_kind}::acc) [] for_rewriting in let result = Search.modules rewritten in (*TODO: Second pass: walk through references -- handled during html generation for the moment*) (result, all_renamed_modules) let find_renaming renamings original = let rec aux s suffix = if String.length s = 0 then ( (* verbose ("Name '"^original^"' remains unchanged");*) suffix ) else let renaming = try Some (fst(Hashtbl.find renamings s)) with Not_found -> None in match renaming with | None -> let father = Name.father s in let son = Name.get_relative father s in aux father (concat son suffix) | Some r -> (*We have found a substitution, it should be over*) let result = concat r suffix in (* verbose ("We have a renaming of "^s^" to "^r);*) verbose ("Name "^original^" replaced with "^result); result in aux original "" (** {1 Batteries generation}*) let name_substitutions : (string, string) Hashtbl.t = Hashtbl.create 100 class batlib_generator = object(self) inherit Odoc_html.html as super (*inherit framed_html as super*) val mutable renamings : (string, (string*info option)) Hashtbl.t = Hashtbl.create 0 (** Determine the category of a name*) val mutable known_values_names = Odoc_html.StringSet.empty val mutable known_exceptions_names = Odoc_html.StringSet.empty val mutable known_methods_names = Odoc_html.StringSet.empty val mutable known_attributes_names = Odoc_html.StringSet.empty val mutable known_class_types_names = Odoc_html.StringSet.empty val mutable known_module_types_names= Odoc_html.StringSet.empty method is_value n = Odoc_html.StringSet.mem n known_values_names method is_exception n = Odoc_html.StringSet.mem n known_exceptions_names method is_method n = Odoc_html.StringSet.mem n known_methods_names method is_attribute n = Odoc_html.StringSet.mem n known_attributes_names method is_class n = Odoc_html.StringSet.mem n known_classes_names method is_class_type n = Odoc_html.StringSet.mem n known_class_types_names method is_module n = Odoc_html.StringSet.mem n known_modules_names method is_module_type n = Odoc_html.StringSet.mem n known_modules_names method is_type n = Odoc_html.StringSet.mem n known_types_names method what_is n = if self#is_module n then Some RK_module else if self#is_class n then Some RK_class else if self#is_class_type n then Some RK_class_type else if self#is_value n then Some RK_value else if self#is_type n then Some RK_type else if self#is_exception n then Some RK_exception else if self#is_attribute n then Some RK_attribute else if self#is_method n then Some RK_method else if self#is_module_type n then Some RK_module_type else None (**Making links*) method make_link ?(target="detailsFrame") ~text ~url () = Printf.sprintf "%s" url target text (**Customizing index generation Only document modules which may be reached from the root. *) method generate_types_index module_list = self#generate_elements_index ((map (fun t -> `Primitive t) primitive_types_names) @ (map (fun t -> `Derived t) self#list_types)) (function `Derived t -> t.ty_name | `Primitive (name, _) -> name) (function `Derived t -> t.ty_info | `Primitive (_, _) -> None) (function `Derived t -> Naming.complete_type_target t | `Primitive (_, alias)-> Naming.complete_target Naming.mark_type alias) Odoc_messages.index_of_types self#index_types (** A method to create index files. *) method generate_elements_index : 'a. 'a list -> ('a -> Odoc_info.Name.t) -> ('a -> Odoc_info.info option) -> ('a -> string) -> string -> string -> unit = fun elements name info target title simple_file -> try let chanout = open_out (Filename.concat !Args.target_dir simple_file) in let b = new_buf () in bs b "\n"; self#print_header b (self#inner_title title); bs b "\n

"; bs b title; bs b "

\n" ; self#html_of_Index_list b; let sorted_elements = List.stable_sort (fun e1 e2 -> compare (Name.simple (name e1)) (Name.simple (name e2))) elements in let groups = Odoc_info.create_index_lists sorted_elements (fun e -> Name.simple (name e)) in let f_ele e = (*Print one entry*) (*let simple_name = Name.simple (name e) in let father_name = Name.father (name e) in bp b "%s" (self#make_link ~url:(target e) ~text:(self#escape simple_name) ()); if simple_name <> father_name && father_name <> "" then bs b (self#make_link ~url:(fst (Naming.html_files father_name)) ~text:father_name ()); bs b "\n"; self#html_of_info_first_sentence b (info e); bs b "\n";*) let simple_name = Name.simple (name e) and father_name = Name.father (name e) in bp b "
  • %s%s" (self#make_link ~url:(target e) ~text:(self#escape simple_name) ()) (if simple_name <> father_name && father_name <> "" then (*Print container module*) Printf.sprintf " [%s]" (self#make_link ~url:(fst (Naming.html_files father_name)) ~text:father_name ()) else ""); (self#html_of_info_first_sentence b (info e)); bs b "
    • \n" in let f_group l = (*Print all entries for a letter*) match l with [] -> () | e :: _ -> let e' = Name.simple (name e) in let s = if String.length e' = 0 then begin warning ("I'm not going to find an uppercase letter for "^(name e)); "" end else match (Char.uppercase e'.[0]) with 'A'..'Z' as c -> String.make 1 c | _ -> "" in bs b "
    "; bs b s ; bs b "\n\n" ; bs b "
      \n"; List.iter f_ele l; bs b "
    \n" in bs b "\n"; List.iter f_group groups ; bs b "

    \n" ; bs b "\n"; Buffer.output_buffer chanout b; close_out chanout with Sys_error s -> raise (Failure s) | _ -> assert false method is_reachable_from_root m = true (*List.exists (fun p -> has_parent m ~parent:p) roots*) method generate_modules_index _ = try let list_modules = List.filter (fun m -> self#is_reachable_from_root m.m_name) self#list_modules in self#generate_elements_index list_modules (fun m -> m.m_name) (fun m -> m.m_info) (fun m -> fst (Naming.html_files m.m_name)) Odoc_messages.index_of_modules self#index_modules with _ -> assert false method html_of_Module_list b _ = try let list_modules = List.map (fun m -> m.m_name) ((List.filter (fun m -> not (List.mem m.m_name roots) && self#is_reachable_from_root m.m_name) self#list_modules)) in super#html_of_Module_list b list_modules with _ -> assert false (**Customizing appearance of modules*) method html_of_module b ?(info=true) ?(complete=true) ?(with_link=true) m = try let name = m.m_name in let (html_file, _) = Naming.html_files name in let father = Name.father name in bs b "
    ";
      bs b ((self#keyword "module")^" ");
      (
       if with_link then
         bs b (self#make_link ~text:(*(Name.simple name)*)name ~url:html_file ())
       else
         bs b (*(Name.simple name)*)name
      );
      (
       match m.m_kind with
         Module_functor _ when !Odoc_info.Args.html_short_functors  ->
           ()
       | _ -> bs b ": "
      );
      self#html_of_module_kind b father ~modu: m m.m_kind;
      bs b "
    "; if info then begin verbose ("Printing information of module "^m.m_name^":\n"^(string_of_info_opt m.m_info)); if complete then self#html_of_info ~indent: false else self#html_of_info_first_sentence end b m.m_info else begin warning ("Module "^m.m_name^" has no associated information") end with _ -> assert false method html_of_Ref b name ref_opt = let renamed = find_renaming renamings name in let type_of_ref = match ref_opt with | Some _ -> ref_opt (*We already have all the details*) | _ -> match self#what_is name with | Some _ as r -> warning ("Found the type of "^name); r | None -> match self#what_is renamed with | Some _ as r -> verbose ("Could not find the type of "^name^", but found that of "^renamed); r | None -> warning ("Could not find the type of "^name^", even as "^renamed); None in super#html_of_Ref b renamed type_of_ref (**Replace references to [string] with [String.t], [list] with [List.t] etc. Override of [super#create_fully_qualified_idents_links]*) method create_fully_qualified_idents_links m_name s = try (** Replace a complete path with a URL to that path*) let handle_qualified_name original_type_name = let renamed_type_name = find_renaming renamings original_type_name in let rel = Name.get_relative m_name renamed_type_name in let s_final = Odoc_info.apply_if_equal Odoc_info.use_hidden_modules renamed_type_name rel in if self#is_type original_type_name || self#is_type renamed_type_name then self#make_link ~url:(Naming.complete_target Naming.mark_type renamed_type_name) ~text:s_final () else( if self#is_class original_type_name || self#is_class renamed_type_name then let (html_file, _) = Naming.html_files renamed_type_name in self#make_link ~url:html_file ~text:s_final () else s_final) (**Replace primitive type names with links to their representation module*) in let handle_word str_t = let result = let (before,match_s) = (Str.matched_group 1 str_t, Str.matched_group 2 str_t) in try let link = List.assoc match_s primitive_types_names in (*let text = before^(end_of_name link) in*) before^(self#make_link ~url:(Naming.complete_target Naming.mark_type link) ~text:match_s ()) (*(handle_qualified_name link)*) with Not_found -> Str.matched_string str_t in result in let s2 = Str.global_substitute (*Substitute fully qualified names*) (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") (fun str_t -> handle_qualified_name (Str.matched_string str_t)) s in let s3 = Str.global_substitute (*Substitute fully qualified names*) (Str.regexp "\\([^.a-zA-Z_0-9]\\|^\\)\\([a-zA-Z_0-9]+\\)") handle_word s2 in s3 with _ -> assert false (* method html_of_module b ?info ?complete ?with_link m = try verbose ("Generating html for module "^m.m_name); flush_all (); super#html_of_module b ?info ?complete ?with_link m with _ -> assert false *) method index_prefix = "root" (** Generate [index.html], as well as [indices.html] for the given module list*) method generate_index module_list = try let title = match !Args.title with None -> "" | Some t -> self#escape t in (*[index.html]*) let chanout = open_out (Filename.concat !Args.target_dir "index.html") in let b = new_buf () in (*let title = match !Args.title with None -> "" | Some t -> self#escape t in*) bs b doctype ; bs b "\n"; self#print_header b self#title; bs b "\n"; bs b "\n"; bs b "\n"; bs b ""; bs b "Frame Alert\n"; bs b "

    \n"; bs b "This document is designed to be viewed using the frames feature. If you see this message, you are using a non-frame-capable web client.\n"; bs b "
    \n"; bs b "Link to Non-frame version.\n"; bs b "\n"; Buffer.output_buffer chanout b; close_out chanout; (* (*[indices.html]*) let chanout = open_out (Filename.concat !Args.target_dir "indices.html") in let b = new_buf () in bs b doctype ; bs b "\n"; self#print_header b self#title; bs b "\n"; bs b "

    "; bs b title; bs b "

    \n" ; self#html_of_Index_list b; bs b "
    "; self#html_of_Module_list b (List.map (fun m -> m.m_name) module_list); bs b "\n"; Buffer.output_buffer chanout b; close_out chanout;*) (*[root.html]*) let chanout = open_out (Filename.concat !Args.target_dir "root.html") in let b = new_buf () in bs b doctype ; bs b "\n"; self#print_header b self#title; bs b "\n"; bs b "

    "; bs b title; bs b "

    \n" ; let info = Odoc_info.apply_opt (Odoc_info.info_of_comment_file module_list) !Odoc_info.Args.intro_file in ( match info with None -> () (*self#html_of_Index_list b; bs b "
    ";*) | Some i -> self#html_of_info ~indent: false b info ); self#html_of_Module_list b (List.map (fun m -> m.m_name) module_list); bs b "\n"; Buffer.output_buffer chanout b; close_out chanout with (*Sys_error s -> raise (Failure s)*) | _ -> assert false method html_of_Index_list b = let item s = bp b "
  • %s
    • \n" s in let index_if_not_empty l url m = match l with [] -> () | _ -> item (self#make_link ~text:m ~url ~target:"indicesFrame"()) in bs b "
      \n"; item (self#make_link ~url:"index.html"~text:"Home" ~target:"_parent" ()); index_if_not_empty self#list_types self#index_types "Types"(*Odoc_messages.index_of_types*); index_if_not_empty self#list_values self#index_values "Values" (*Odoc_messages.index_of_values*); index_if_not_empty self#list_exceptions self#index_exceptions "Exceptions" (*Odoc_messages.index_of_exceptions*); index_if_not_empty self#list_classes self#index_classes "Classes" (*Odoc_messages.index_of_classes*); index_if_not_empty self#list_attributes self#index_attributes "Attributes" (*Odoc_messages.index_of_attributes*); index_if_not_empty self#list_methods self#index_methods "Methods" (*Odoc_messages.index_of_methods*); index_if_not_empty self#list_class_types self#index_class_types "Class types" (*Odoc_messages.index_of_class_types*); index_if_not_empty self#list_modules self#index_modules "Modules" (*Odoc_messages.index_of_modules*); index_if_not_empty self#list_module_types self#index_module_types "Module types"; (*Odoc_messages.index_of_module_types*) bs b "
    " method generate_external_index name mark set = let cout = open_out (Filename.concat !Args.target_dir (name ^ ".idex")) in Odoc_html.StringSet.iter (fun elt -> Printf.fprintf cout "%S: %S\n" elt (Naming.complete_target mark elt)) set; if name = "types" then (*Special case for primitive types*) List.iter (fun (type_name, type_alias) -> Printf.fprintf cout "%S: %S\n" type_name (Naming.complete_target type_alias type_alias)) primitive_types_names; close_out cout method generate modules = try match !Odoc_args.dump with | Some l -> Odoc_info.verbose "[Internal representation stage, no readable output generated yet]"; () | None -> Odoc_info.verbose "[Final stage, generating html pages]"; flush_all (); (*Pre-process every module*) List.iter (fun m -> verbose ("My bag contains "^m.m_name)) modules; let everything = Search.modules modules in let (rewritten_modules, renamed_modules) = rebuild_structure everything in list_values <- Odoc_info.Search.values rewritten_modules ; list_exceptions <- Odoc_info.Search.exceptions rewritten_modules ; list_types <- Odoc_info.Search.types rewritten_modules ; list_attributes <- Odoc_info.Search.attributes rewritten_modules ; list_methods <- Odoc_info.Search.methods rewritten_modules ; list_classes <- Odoc_info.Search.classes rewritten_modules ; list_class_types <- Odoc_info.Search.class_types rewritten_modules ; list_modules <- Odoc_info.Search.modules rewritten_modules ; list_module_types <- Odoc_info.Search.module_types rewritten_modules ; (*Cache set of values*) known_values_names <- List.fold_left (fun acc t -> Odoc_html.StringSet.add t.val_name acc) known_values_names list_values ; (*Cache set of exceptions*) known_exceptions_names <- List.fold_left (fun acc t -> Odoc_html.StringSet.add t.ex_name acc) known_exceptions_names list_exceptions ; (*Cache set of methods*) known_methods_names <- List.fold_left (fun acc t -> Odoc_html.StringSet.add t.met_value.val_name acc) known_methods_names list_methods ; (*Cache set of attributes*) known_attributes_names <- List.fold_left (fun acc t -> Odoc_html.StringSet.add t.att_value.val_name acc) known_attributes_names list_attributes ; (*Cache set of class types*) known_class_types_names <- List.fold_left (fun acc t -> Odoc_html.StringSet.add t.clt_name acc) known_class_types_names list_class_types ; (*Cache set of module_types *) known_module_types_names <- List.fold_left (fun acc t -> Odoc_html.StringSet.add t.mt_name acc) known_module_types_names list_module_types ; (*Proceed to generation*) renamings <- renamed_modules; verbose "Beautification of modules complete, proceeding to generation"; flush_all (); super#generate rewritten_modules; (*Generate indices*) self#generate_external_index "types" Naming.mark_type known_types_names; self#generate_external_index "values" Naming.mark_value known_values_names; self#generate_external_index "modules" "" known_modules_names; self#generate_external_index "classes" "" known_classes_names; self#generate_external_index "exceptions" Naming.mark_exception known_exceptions_names; self#generate_external_index "methods" Naming.mark_method known_methods_names; self#generate_external_index "attributes" Naming.mark_attribute known_attributes_names; self#generate_external_index "class_types" "" known_class_types_names; self#generate_external_index "module_types""" known_module_types_names with e -> Printf.eprintf "%s\n%!" (Printexc.to_string e); assert false (* method html_of_custom_tag_developer text = verbose ("Generating developer name "^(string_of_text text)); "
    developer: "^(string_of_text text)^"
    "*) initializer (* tag_functions <- ("developer", self#html_of_custom_tag_developer) :: tag_functions;*) default_style_options <- default_style_options@ ["li.index_of {display:inline}"; "ul.indices {display:inline;font-variant:small-caps;list-style-position: inside;list-style-type:none;padding:0px}"; "div.indices {text-align:center}"; ".index_entry{font-size:x-small}"; "ul.index_entry {list-style-type:none;padding:0px; margin-left:none; text-ident:-1em}"; "li.index_entry_entry div.info {margin-left:1em}"; "pre {background-color:rgb(250,250,250);margin-top:2em}"; "pre.example {margin-top:2px; margin-bottom:2em}"; "p {text-align:justify}"; ".superscript { font-size : 8pt }" ]; end;; let set_batlib_doc_generator () = let doc_generator = ((new batlib_generator) :> Args.doc_generator) in Args.set_doc_generator (Some doc_generator) let _ = Odoc_args.verbose := true; set_batlib_doc_generator (); Args.add_option ("-html", Arg.Unit (fun _ -> Odoc_info.verbose "Deactivating built-in html generator"; set_batlib_doc_generator()) , "") ; match !Odoc_args.dump with | None -> Odoc_info.verbose "This is the final stage of documentation generation. You should go take a coffee, it's bound to last 15+ minutes." | _ -> () batteries-included-3.4.0/build/odoc_tags.ml000066400000000000000000000570531415601150500206700ustar00rootroot00000000000000(* * Odoc_generator_batlib - custom documentation generator for Batteries * Copyright (C) 2008 Maxence Guesdon * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (******** TODO: modules by keyword TODO: values by keyword TODO: types by keyword etc. *********) (*From OCamlDoc*) open Odoc_info;; module Naming = Odoc_html.Naming module Name = Odoc_name open Odoc_info.Value open Odoc_info.Module open Odoc_info.Type open Odoc_info.Class open Odoc_info.Exception (*From the base library*) open List (*open Odoc_batteries_factored*) INCLUDE "build/odoc_batteries_factored.ml" (** {1 Batteries generation}*) let name_substitutions : (string, string) Hashtbl.t = Hashtbl.create 100 class batlib_generator = object(self) inherit Odoc_html.html as super val mutable renamings : (string, (string*info option)) Hashtbl.t = Hashtbl.create 0 val mutable modules_by_topic : string -> t_module list = fun _ -> assert false val mutable list_topics : string list = [] (** {2 Determine the category of a name}*) val mutable known_values_names = Odoc_html.StringSet.empty val mutable known_exceptions_names = Odoc_html.StringSet.empty val mutable known_methods_names = Odoc_html.StringSet.empty val mutable known_attributes_names = Odoc_html.StringSet.empty val mutable known_class_types_names = Odoc_html.StringSet.empty val mutable known_module_types_names= Odoc_html.StringSet.empty method is_value n = Odoc_html.StringSet.mem n known_values_names method is_exception n = Odoc_html.StringSet.mem n known_exceptions_names method is_method n = Odoc_html.StringSet.mem n known_methods_names method is_attribute n = Odoc_html.StringSet.mem n known_attributes_names method is_class n = Odoc_html.StringSet.mem n known_classes_names method is_class_type n = Odoc_html.StringSet.mem n known_class_types_names method is_module n = Odoc_html.StringSet.mem n known_modules_names method is_module_type n = Odoc_html.StringSet.mem n known_modules_names method is_type n = Odoc_html.StringSet.mem n known_types_names method what_is n = if self#is_module n then Some RK_module else if self#is_class n then Some RK_class else if self#is_class_type n then Some RK_class_type else if self#is_value n then Some RK_value else if self#is_type n then Some RK_type else if self#is_exception n then Some RK_exception else if self#is_attribute n then Some RK_attribute else if self#is_method n then Some RK_method else if self#is_module_type n then Some RK_module_type else None (**Making links*) method make_link ?(target="detailsFrame") ~text ~url () = Printf.sprintf "%s" url target text (** {2 Generation of indices} *) (**Generate a list by topic.*) method generate_elements_index_by_topic: 'a. topics:(string list) -> elements:(string -> 'a list) -> name:('a -> Name.t) -> info:('a -> info option) -> target:('a -> string) -> title:string -> simple_file:string -> unit = fun ~topics ~elements ~name ~info ~target ~title ~simple_file -> let topics = List.sort String.compare topics in(*Actually, let's not sort topics*) let chanout = open_out (Filename.concat !Args.target_dir simple_file) in let b = new_buf () in let each_element e = let simple_name = Name.simple (name e) and father_name = Name.father (name e) in bp b "
  • %s%s" (self#make_link ~url:(target e) ~text:(self#escape simple_name) ()) (if simple_name <> father_name && father_name <> "" then (*Print container module*) Printf.sprintf " [%s]" (self#make_link ~url:(fst (Naming.html_files father_name)) ~text:father_name ()) else ""); (self#html_of_info_first_sentence b (info e)); bs b "
    • \n" in let each_topic topic = match elements topic with [] -> () | elems -> bs b "
    "; bs b topic ; bs b "\n\n" ; bs b "
      \n"; List.iter each_element elems; bs b "
    \n" in try bs b "\n"; self#print_header b (self#inner_title title); bs b "\n

    "; bs b title; bs b "

    \n" ; self#html_of_Index_list b; List.iter each_topic topics; bs b "
    \n" ; bs b "\n"; Buffer.output_buffer chanout b; close_out chanout with Sys_error s -> raise (Failure s) | e -> Printf.eprintf "%s\n%!" (Printexc.to_string e); assert false (**Generate the list of types. In addition to the list of types defined inside modules, we generate the list of primitive types.*) method generate_types_index module_list = self#generate_elements_index ((map (fun t -> `Primitive t) primitive_types_names) @ (map (fun t -> `Derived t) self#list_types)) (function `Derived t -> t.ty_name | `Primitive (name, _) -> name) (function `Derived t -> t.ty_info | `Primitive (_, _) -> None) (function `Derived t -> Naming.complete_type_target t | `Primitive (_, alias)-> Naming.complete_target Naming.mark_type alias) Odoc_messages.index_of_types self#index_types (** A method to create index files. *) method generate_elements_index : 'a. 'a list -> ('a -> Odoc_info.Name.t) -> ('a -> Odoc_info.info option) -> ('a -> string) -> string -> string -> unit = fun elements name info target title simple_file -> try let chanout = open_out (Filename.concat !Args.target_dir simple_file) in let b = new_buf () in bs b "\n"; self#print_header b (self#inner_title title); bs b "\n

    "; bs b title; bs b "

    \n" ; self#html_of_Index_list b; let sorted_elements = List.stable_sort (fun e1 e2 -> compare (Name.simple (name e1)) (Name.simple (name e2))) elements in let groups = Odoc_info.create_index_lists sorted_elements (fun e -> Name.simple (name e)) in let f_ele e = (*Print one entry*) (*let simple_name = Name.simple (name e) in let father_name = Name.father (name e) in bp b "%s" (self#make_link ~url:(target e) ~text:(self#escape simple_name) ()); if simple_name <> father_name && father_name <> "" then bs b (self#make_link ~url:(fst (Naming.html_files father_name)) ~text:father_name ()); bs b "\n"; self#html_of_info_first_sentence b (info e); bs b "\n";*) let simple_name = Name.simple (name e) and father_name = Name.father (name e) in bp b "
  • %s%s" (self#make_link ~url:(target e) ~text:(self#escape simple_name) ()) (if simple_name <> father_name && father_name <> "" then (*Print container module*) Printf.sprintf " [%s]" (self#make_link ~url:(fst (Naming.html_files father_name)) ~text:father_name ()) else ""); (self#html_of_info_first_sentence b (info e)); bs b "
    • \n" in let f_group l = (*Print all entries for a letter*) match l with [] -> () | e :: _ -> let e' = Name.simple (name e) in let s = if String.length e' = 0 then begin warning ("I'm not going to find an uppercase letter for "^(name e)); "" end else match (Char.uppercase e'.[0]) with 'A'..'Z' as c -> String.make 1 c | _ -> "" in bs b "
    "; bs b s ; bs b "\n\n" ; bs b "
      \n"; List.iter f_ele l; bs b "
    \n" in bs b "\n"; List.iter f_group groups ; bs b "

    \n" ; bs b "\n"; Buffer.output_buffer chanout b; close_out chanout with Sys_error s -> raise (Failure s) | _ -> assert false method is_reachable_from_root m = true (*List.exists (fun p -> has_parent m ~parent:p) roots*) (* method generate_modules_index _ = try let list_modules = List.filter (fun m -> self#is_reachable_from_root m.m_name) self#list_modules in self#generate_elements_index list_modules (fun m -> m.m_name) (fun m -> m.m_info) (fun m -> fst (Naming.html_files m.m_name)) Odoc_messages.index_of_modules self#index_modules with _ -> assert false*) method generate_modules_index _ = verbose ("[Index] Here's the list of modules"); List.iter (fun m -> print_endline m.m_name) list_modules; verbose ("[Index] Here's the list of rewritten modules"); List.iter (fun t -> List.iter (fun m -> print_endline m.m_name) (modules_by_topic t)) list_topics; self#generate_elements_index_by_topic ~topics:list_topics ~elements:modules_by_topic ~name:(fun m -> m.m_name) ~info:(fun m -> m.m_info) ~target:(fun m -> fst (Naming.html_files m.m_name)) ~title:Odoc_messages.index_of_modules ~simple_file:self#index_modules method html_of_Module_list b _ = try let list_modules = List.map (fun m -> m.m_name) ((List.filter (fun m -> not (List.mem m.m_name roots) && self#is_reachable_from_root m.m_name) self#list_modules)) in super#html_of_Module_list b list_modules with _ -> assert false (**Customizing appearance of modules*) method html_of_module b ?(info=true) ?(complete=true) ?(with_link=true) m = try let name = m.m_name in let (html_file, _) = Naming.html_files name in let father = Name.father name in bs b "
    ";
      bs b ((self#keyword "module")^" ");
      (
       if with_link then
         bs b (self#make_link ~text:(*(Name.simple name)*)name ~url:html_file ())
       else
         bs b (*(Name.simple name)*)name
      );
      (
       match m.m_kind with
         Module_functor _ when !Odoc_info.Args.html_short_functors  ->
           ()
       | _ -> bs b ": "
      );
      self#html_of_module_kind b father ~modu: m m.m_kind;
      bs b "
    "; if info then begin verbose ("Printing information of module "^m.m_name^":\n"^(string_of_info_opt m.m_info)); if complete then self#html_of_info ~indent: false else self#html_of_info_first_sentence end b m.m_info else begin warning ("Module "^m.m_name^" has no associated information") end with _ -> assert false method html_of_Ref b name ref_opt = let renamed = find_renaming renamings name in let type_of_ref = match ref_opt with | Some _ -> ref_opt (*We already have all the details*) | _ -> match self#what_is name with | Some _ as r -> warning ("Found the type of "^name); r | None -> match self#what_is renamed with | Some _ as r -> verbose ("Could not find the type of "^name^", but found that of "^renamed); r | None -> warning ("Could not find the type of "^name^", even as "^renamed); None in super#html_of_Ref b renamed type_of_ref (**Replace references to [string] with [String.t], [list] with [List.t] etc. Override of [super#create_fully_qualified_idents_links]*) method create_fully_qualified_idents_links m_name s = try (** Replace a complete path with a URL to that path*) let handle_qualified_name original_type_name = let renamed_type_name = find_renaming renamings original_type_name in let rel = Name.get_relative m_name renamed_type_name in let s_final = Odoc_info.apply_if_equal Odoc_info.use_hidden_modules renamed_type_name rel in if self#is_type original_type_name || self#is_type renamed_type_name then self#make_link ~url:(Naming.complete_target Naming.mark_type renamed_type_name) ~text:s_final () else( if self#is_class original_type_name || self#is_class renamed_type_name then let (html_file, _) = Naming.html_files renamed_type_name in self#make_link ~url:html_file ~text:s_final () else s_final) (**Replace primitive type names with links to their representation module*) in let handle_word str_t = let result = let (before,match_s) = (Str.matched_group 1 str_t, Str.matched_group 2 str_t) in try let link = List.assoc match_s primitive_types_names in (*let text = before^(end_of_name link) in*) before^(self#make_link ~url:(Naming.complete_target Naming.mark_type link) ~text:match_s ()) (*(handle_qualified_name link)*) with Not_found -> Str.matched_string str_t in result in let s2 = Str.global_substitute (*Substitute fully qualified names*) (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") (fun str_t -> handle_qualified_name (Str.matched_string str_t)) s in let s3 = Str.global_substitute (*Substitute fully qualified names*) (Str.regexp "\\([^.a-zA-Z_0-9]\\|^\\)\\([a-zA-Z_0-9]+\\)") handle_word s2 in s3 with _ -> assert false method index_prefix = "root" (** Generate [index.html], as well as [indices.html] for the given module list*) method generate_index module_list = try let title = match !Args.title with None -> "" | Some t -> self#escape t in (*[index.html]*) let chanout = open_out (Filename.concat !Args.target_dir "index.html") in let b = new_buf () in (*let title = match !Args.title with None -> "" | Some t -> self#escape t in*) bs b doctype ; bs b "\n"; self#print_header b self#title; bs b "\n"; bs b "\n"; bs b "\n"; bs b ""; bs b "Frame Alert\n"; bs b "

    \n"; bs b "This document is designed to be viewed using the frames feature. If you see this message, you are using a non-frame-capable web client.\n"; bs b "
    \n"; bs b "Link to Non-frame version.\n"; bs b "\n"; Buffer.output_buffer chanout b; close_out chanout; (* (*[indices.html]*) let chanout = open_out (Filename.concat !Args.target_dir "indices.html") in let b = new_buf () in bs b doctype ; bs b "\n"; self#print_header b self#title; bs b "\n"; bs b "

    "; bs b title; bs b "

    \n" ; self#html_of_Index_list b; bs b "
    "; self#html_of_Module_list b (List.map (fun m -> m.m_name) module_list); bs b "\n"; Buffer.output_buffer chanout b; close_out chanout;*) (*[root.html]*) let chanout = open_out (Filename.concat !Args.target_dir "root.html") in let b = new_buf () in bs b doctype ; bs b "\n"; self#print_header b self#title; bs b "\n"; bs b "

    "; bs b title; bs b "

    \n" ; let info = Odoc_info.apply_opt (Odoc_info.info_of_comment_file module_list) !Odoc_info.Args.intro_file in ( match info with None -> () (*self#html_of_Index_list b; bs b "
    ";*) | Some i -> self#html_of_info ~indent: false b info ); self#html_of_Module_list b (List.map (fun m -> m.m_name) module_list); bs b "\n"; Buffer.output_buffer chanout b; close_out chanout with (*Sys_error s -> raise (Failure s)*) | _ -> assert false method html_of_Index_list b = let item s = bp b "
  • %s
    • \n" s in let index_if_not_empty l url m = match l with [] -> () | _ -> item (self#make_link ~text:m ~url ~target:"indicesFrame"()) in bs b "
      \n"; item (self#make_link ~url:"index.html"~text:"Home" ~target:"_parent" ()); index_if_not_empty self#list_types self#index_types "Types"(*Odoc_messages.index_of_types*); index_if_not_empty self#list_values self#index_values "Values" (*Odoc_messages.index_of_values*); index_if_not_empty self#list_exceptions self#index_exceptions "Exceptions" (*Odoc_messages.index_of_exceptions*); index_if_not_empty self#list_classes self#index_classes "Classes" (*Odoc_messages.index_of_classes*); index_if_not_empty self#list_attributes self#index_attributes "Attributes" (*Odoc_messages.index_of_attributes*); index_if_not_empty self#list_methods self#index_methods "Methods" (*Odoc_messages.index_of_methods*); index_if_not_empty self#list_class_types self#index_class_types "Class types" (*Odoc_messages.index_of_class_types*); index_if_not_empty self#list_modules self#index_modules "Modules" (*Odoc_messages.index_of_modules*); index_if_not_empty self#list_module_types self#index_module_types "Module types"; (*Odoc_messages.index_of_module_types*) bs b "
    " method generate_external_index name mark set = let cout = open_out (Filename.concat !Args.target_dir (name ^ ".idex")) in Odoc_html.StringSet.iter (fun elt -> Printf.fprintf cout "%S: %S\n" elt (Naming.complete_target mark elt)) set; if name = "types" then (*Special case for primitive types*) List.iter (fun (type_name, type_alias) -> Printf.fprintf cout "%S: %S\n" type_name (Naming.complete_target type_alias type_alias)) primitive_types_names; close_out cout method generate modules = try match !Odoc_args.dump with | Some l -> Odoc_info.verbose "[Internal representation stage, no readable output generated yet]"; Odoc_info.verbose "(you still have time for coffee)"; () | None -> Odoc_info.verbose "[Final stage, we will generate html pages]"; Odoc_info.verbose "(if you don't want coffee, you could also prepare some tea)"; flush_all (); (*Pre-process every module*) List.iter (fun m -> verbose ("My bag contains "^m.m_name)) modules; let everything = Search.modules modules in let (rewritten_modules, renamed_modules) = rebuild_structure everything in list_values <- Odoc_info.Search.values rewritten_modules ; list_exceptions <- Odoc_info.Search.exceptions rewritten_modules ; list_types <- Odoc_info.Search.types rewritten_modules ; list_attributes <- Odoc_info.Search.attributes rewritten_modules ; list_methods <- Odoc_info.Search.methods rewritten_modules ; list_classes <- Odoc_info.Search.classes rewritten_modules ; list_class_types <- Odoc_info.Search.class_types rewritten_modules ; list_modules <- Odoc_info.Search.modules rewritten_modules ; list_module_types <- Odoc_info.Search.module_types rewritten_modules ; (*Cache set of values*) known_values_names <- List.fold_left (fun acc t -> Odoc_html.StringSet.add t.val_name acc) known_values_names list_values ; (*Cache set of exceptions*) known_exceptions_names <- List.fold_left (fun acc t -> Odoc_html.StringSet.add t.ex_name acc) known_exceptions_names list_exceptions ; (*Cache set of methods*) known_methods_names <- List.fold_left (fun acc t -> Odoc_html.StringSet.add t.met_value.val_name acc) known_methods_names list_methods ; (*Cache set of attributes*) known_attributes_names <- List.fold_left (fun acc t -> Odoc_html.StringSet.add t.att_value.val_name acc) known_attributes_names list_attributes ; (*Cache set of class types*) known_class_types_names <- List.fold_left (fun acc t -> Odoc_html.StringSet.add t.clt_name acc) known_class_types_names list_class_types ; (*Cache set of module_types *) known_module_types_names <- List.fold_left (fun acc t -> Odoc_html.StringSet.add t.mt_name acc) known_module_types_names list_module_types; (*Proceed to generation*) renamings <- renamed_modules; let topics = sort_by_topics (*modules*)rewritten_modules in modules_by_topic <- (let hash = snd topics in fun x -> try !(Hashtbl.find hash x) with Not_found -> []); list_topics <- fst topics; verbose "Beautification of modules complete, proceeding to generation"; flush_all (); super#generate rewritten_modules; (*Generate indices*) self#generate_external_index "types" Naming.mark_type known_types_names; self#generate_external_index "values" Naming.mark_value known_values_names; self#generate_external_index "modules" "" known_modules_names; self#generate_external_index "classes" "" known_classes_names; self#generate_external_index "exceptions" Naming.mark_exception known_exceptions_names; self#generate_external_index "methods" Naming.mark_method known_methods_names; self#generate_external_index "attributes" Naming.mark_attribute known_attributes_names; self#generate_external_index "class_types" "" known_class_types_names; self#generate_external_index "module_types""" known_module_types_names with e -> Printf.eprintf "%s\n%!" (Printexc.to_string e); assert false initializer (* tag_functions <- ("topic", fun _ -> "topic") :: tag_functions;*) default_style_options <- default_style_options@ ["li.index_of {display:inline}"; "ul.indices {display:inline;font-variant:small-caps;list-style-position: inside;list-style-type:none;padding:0px}"; "div.indices {text-align:center}"; ".index_entry{font-size:x-small}"; "ul.index_entry {list-style-type:none;padding:0px; margin-left:none; text-ident:-1em}"; "li.index_entry_entry div.info {margin-left:1em}"; "pre {background-color:rgb(250,250,250);margin-top:2em}"; "pre.example {margin-top:2px; margin-bottom:2em}"; "p {text-align:justify}"; ".superscript { font-size : 8pt }" ]; end;; let set_batlib_doc_generator () = let doc_generator = ((new batlib_generator) :> Args.doc_generator) in Args.set_doc_generator (Some doc_generator) let _ = Odoc_args.verbose := true; set_batlib_doc_generator (); Args.add_option ("-html", Arg.Unit (fun _ -> Odoc_info.verbose "Deactivating built-in html generator"; set_batlib_doc_generator()) , "") batteries-included-3.4.0/build/optcomp/000077500000000000000000000000001415601150500200435ustar00rootroot00000000000000batteries-included-3.4.0/build/optcomp/LICENSE000066400000000000000000000027601415601150500210550ustar00rootroot00000000000000Copyright (c) 2008, Jeremie Dimino All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Jeremie Dimino nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. batteries-included-3.4.0/build/optcomp/META000066400000000000000000000002701415601150500205130ustar00rootroot00000000000000# -*- conf-mode -*- name = "optcomp" version = "1.1" description = "Optional compilation with cpp-like directives" requires = "camlp4" archive(syntax, preprocessor) = "pa_optcomp.cmo" batteries-included-3.4.0/build/optcomp/README000066400000000000000000000041561415601150500207310ustar00rootroot00000000000000 Optional compilation with cpp-like directives Jeremie Dimino December 2008 * What it does Optcomp is a syntax extension which handles #if, #else, ... directives in ocaml source files. For example, to switch between two pieces of code according to the ocaml compiler version, one can write: #if ocaml_version < (3, 10) let x = 1 #else let x = 2 #end * What the difference between cpp and optcomp ? Optcomp is more caml-friendly than cpp: - it does not interpret "//", "/*", and "*/" as comment delimiters - it does not complains about missing "'" - it is easier to integrate in the build process when using other camlp4 syntax extensions By the way optcomp does not do macro expansion while cpp does. * What the difference between pa_macro and optcomp ? Optcomp does not require code that will be dropped to be valid caml code. So for example this code will be rejected by camlp4+pa_macro: let f = function | <:patt< $id:id$ >> -> "ident" | <:patt< $int:x$ >> -> "int" | <:patt< $x$, $y$ >> -> "pair" IFDEF HAVE_LAZY_PATTERNS THEN | <:patt< lazy x >> -> "lazy" ENDIF But this one will be accepted by camlp4+optcomp: let f = function | <:patt< $id:id$ >> -> "ident" | <:patt< $int:x$ >> -> "int" | <:patt< $x$, $y$ >> -> "pair" #if HAVE_LAZY_PATTERNS | <:patt< lazy x >> -> "lazy" #endif * Building instructions To compile optcomp type: $ make * Installation To install optcomp type: $ make install and to uninstall it: $ make uninstall * How to use it You can use optcomp with ocamlfind, with the package optcomp or you can directly include it in your project. * Hacking To add support to more expressions, you can modify the eval function of pa_optcomp.ml. It takes a camlp4 expression ast and must return something of type value. * Development The last development version of optcomp can always be found in the darcs repository hosted at darcs.ocamlcore.org: $ darcs get http://darcs.ocamlcore.org/repos/optcomp/optcomp local variables: mode: outline end: batteries-included-3.4.0/build/optcomp/_tags000066400000000000000000000000671415601150500210660ustar00rootroot00000000000000<*>:camlp4of,use_camlp4_full : use_dynlink batteries-included-3.4.0/build/optcomp/optcomp.ml000066400000000000000000000063371415601150500220670ustar00rootroot00000000000000(* * optcomp.ml * ---------- * Copyright : (c) 2009, Jeremie Dimino * Licence : BSD3 * * This file is a part of optcomp. *) (* Standalone version *) open Camlp4.PreCast open Camlp4.Sig let print_token ?(oc=stdout) = function | KEYWORD kwd -> Printf.fprintf oc "%s" kwd | SYMBOL sym -> Printf.fprintf oc "%s" sym | LIDENT lid -> Printf.fprintf oc "%s" lid | UIDENT uid -> Printf.fprintf oc "%s" uid | ESCAPED_IDENT id -> Printf.fprintf oc "%s" "( "; Printf.fprintf oc "%s" id; Printf.fprintf oc "%s" " )" | INT(_, s) -> Printf.fprintf oc "%s" s | INT32(_, s) -> Printf.fprintf oc "%s" s; Printf.fprintf oc "%c" 'l' | INT64(_, s) -> Printf.fprintf oc "%s" s; Printf.fprintf oc "%c" 'L' | NATIVEINT(_, s) -> Printf.fprintf oc "%s" s; Printf.fprintf oc "%c" 'n' | FLOAT(_, s) -> Printf.fprintf oc "%s" s | CHAR(_, s) -> Printf.fprintf oc "%s" s | STRING(_, s) -> Printf.fprintf oc "%c" '"'; Printf.fprintf oc "%s" s; Printf.fprintf oc "%c" '"' | LABEL lbl -> Printf.fprintf oc "%c" '~'; Printf.fprintf oc "%s" lbl; Printf.fprintf oc "%c" ':' | OPTLABEL lbl -> Printf.fprintf oc "%c" '?'; Printf.fprintf oc "%s" lbl; Printf.fprintf oc "%c" ':' | QUOTATION quot -> if quot.q_name = "" then Printf.fprintf oc "%s" "<<" else begin Printf.fprintf oc "%s" "<:"; Printf.fprintf oc "%s" quot.q_name; if quot.q_loc <> "" then begin Printf.fprintf oc "%c" '@'; Printf.fprintf oc "%s" quot.q_loc end; Printf.fprintf oc "%c" '<' end; Printf.fprintf oc "%s" quot.q_contents; Printf.fprintf oc "%s" ">>" | ANTIQUOT(n, s) -> Printf.fprintf oc "%c" '$'; if n <> "" then begin Printf.fprintf oc "%s" n; Printf.fprintf oc "%c" ':' end; Printf.fprintf oc "%s" s; Printf.fprintf oc "%c" '$' | COMMENT comment -> Printf.fprintf oc "%s" comment | BLANKS s -> Printf.fprintf oc "%s" s | NEWLINE -> Printf.fprintf oc "\n" | LINE_DIRECTIVE(n, fname_opt) -> Printf.fprintf oc "# %d" n; begin match fname_opt with | Some fname -> Printf.fprintf oc " \"%s\"\n" fname | None -> Printf.fprintf oc "\n" end | EOI -> raise Exit let filter_keywords stream = Stream.from (fun _ -> match Stream.next stream with | (SYMBOL ("#"|"="|"("|")"|"{"|"}"|"["|"]" as sym), loc) -> Some(KEYWORD sym, loc) | x -> Some x) external filter : 'a Gram.not_filtered -> 'a = "%identity" let main () = if Array.length Sys.argv <> 2 then begin Printf.eprintf "usage: %s \n%!" (Filename.basename Sys.argv.(0)); exit 2 end; try let fname = Sys.argv.(1) in let ic = open_in fname in Stream.iter (fun (tok, loc) -> print_token tok) (Pa_optcomp.stream_filter (fun x -> x) (filter_keywords (filter (Gram.lex (Loc.mk fname) (Stream.of_channel ic))))); close_in ic with | Exit -> () | exn -> Format.eprintf "@[%a@]@." Camlp4.ErrorHandler.print exn batteries-included-3.4.0/build/optcomp/optcomp_o.ml000066400000000000000000000004371415601150500224000ustar00rootroot00000000000000(* * optcomp_o.ml * ------------ * Copyright : (c) 2009, Jeremie Dimino * Licence : BSD3 *) (* Standalone version, original syntax *) let module M = Camlp4OCamlParser.Make(Camlp4OCamlRevisedParser.Make(Camlp4.PreCast.Syntax)) in () let _ = Optcomp.main () batteries-included-3.4.0/build/optcomp/optcomp_r.ml000066400000000000000000000004061415601150500223770ustar00rootroot00000000000000(* * optcomp_r.ml * ------------ * Copyright : (c) 2009, Jeremie Dimino * Licence : BSD3 *) (* Standalone version, revised syntax *) let module M = Camlp4OCamlRevisedParser.Make(Camlp4.PreCast.Syntax) in () let _ = Optcomp.main () batteries-included-3.4.0/build/optcomp/pa_optcomp.ml000066400000000000000000000503541415601150500225450ustar00rootroot00000000000000(* * pa_optcomp.ml * ------------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of optcomp. *) open Camlp4.Sig open Camlp4.PreCast (* Subset of supported caml types *) type typ = | Tvar of string | Tbool | Tint | Tchar | Tstring | Ttuple of typ list (* Subset of supported caml values *) type value = | Bool of bool | Int of int | Char of char | String of string | Tuple of value list type ident = string (* An identifier. It is either a lower or a upper identifier. *) module Env = Map.Make(struct type t = ident let compare = compare end) type env = value Env.t type directive = | Dir_let of ident * Ast.expr | Dir_default of ident * Ast.expr | Dir_if of Ast.expr | Dir_else | Dir_elif of Ast.expr | Dir_endif | Dir_include of Ast.expr | Dir_error of Ast.expr | Dir_warning of Ast.expr | Dir_directory of Ast.expr (* This one is not part of optcomp but this is one of the directives handled by camlp4 we probably want to use. *) | Dir_default_quotation of Ast.expr (* Quotations are evaluated by the token filters, but are expansed after. Evaluated quotations are kept in this table, which quotation id to to values: *) let quotations : (int, value) Hashtbl.t = Hashtbl.create 42 let next_quotation_id = let r = ref 0 in fun _ -> incr r; !r (* +-------------+ | Environment | +-------------+ *) let env = ref Env.empty let define id value = env := Env.add id value !env let _ = define "ocaml_version" (Scanf.sscanf Sys.ocaml_version "%d.%d" (fun major minor -> Tuple [Int major; Int minor])) let dirs = ref [] let add_include_dir dir = dirs := dir :: !dirs (* +--------------+ | Dependencies | +--------------+ *) module String_set = Set.Make(String) (* All dependencies of the file being parsed *) let dependencies = ref String_set.empty (* Where to write dependencies *) let dependency_filename = ref None (* The file being parsed. This is set when the first (token, location) pair is fetched. *) let source_filename = ref None let write_depencies () = match !dependency_filename, !source_filename with | None, _ | _, None -> () | Some dependency_filename, Some source_filename -> let oc = open_out dependency_filename in if not (String_set.is_empty !dependencies) then begin output_string oc "# automatically generated by optcomp\n"; output_string oc source_filename; output_string oc ": "; output_string oc (String.concat " " (String_set.elements !dependencies)); output_char oc '\n' end; close_out oc (* +----------------------------------------+ | Value to expression/pattern conversion | +----------------------------------------+ *) let rec expr_of_value _loc = function | Bool true -> <:expr< true >> | Bool false -> <:expr< false >> | Int x -> <:expr< $int:string_of_int x$ >> | Char x -> <:expr< $chr:Char.escaped x$ >> | String x -> <:expr< $str:String.escaped x$ >> | Tuple [] -> <:expr< () >> | Tuple [x] -> expr_of_value _loc x | Tuple l -> <:expr< $tup:Ast.exCom_of_list (List.map (expr_of_value _loc) l)$ >> let rec patt_of_value _loc = function | Bool true -> <:patt< true >> | Bool false -> <:patt< false >> | Int x -> <:patt< $int:string_of_int x$ >> | Char x -> <:patt< $chr:Char.escaped x$ >> | String x -> <:patt< $str:String.escaped x$ >> | Tuple [] -> <:patt< () >> | Tuple [x] -> patt_of_value _loc x | Tuple l -> <:patt< $tup:Ast.paCom_of_list (List.map (patt_of_value _loc) l)$ >> (* +-----------------------+ | Expression evaluation | +-----------------------+ *) let rec type_of_value = function | Bool _ -> Tbool | Int _ -> Tint | Char _ -> Tchar | String _ -> Tstring | Tuple l -> Ttuple (List.map type_of_value l) let rec string_of_type = function | Tvar v -> "'" ^ v | Tbool -> "bool" | Tint -> "int" | Tchar -> "char" | Tstring -> "string" | Ttuple l -> "(" ^ String.concat " * " (List.map string_of_type l) ^ ")" let invalid_type loc expected real = Loc.raise loc (Failure (Printf.sprintf "this expression has type %s but is used with type %s" (string_of_type real) (string_of_type expected))) let type_of_patt patt = let rec aux (a, n) = function | <:patt< $tup:x$ >> -> let l, x = List.fold_left (fun (l, x) patt -> let t, x = aux x patt in (t :: l, x)) ([], (a, n)) (Ast.list_of_patt x []) in (Ttuple(List.rev l), x) | _ -> (Tvar(Printf.sprintf "%c%s" (char_of_int (Char.code 'a' + a)) (if n = 0 then "" else string_of_int n)), if a = 25 then (0, n + 1) else (a + 1, n)) in fst (aux (0, 0) patt) let rec eval env = function (* Literals *) | <:expr< true >> -> Bool true | <:expr< false >> -> Bool false | <:expr< $int:x$ >> -> Int(int_of_string x) | <:expr< $chr:x$ >> -> Char(Camlp4.Struct.Token.Eval.char x) | <:expr< $str:x$ >> -> String(Camlp4.Struct.Token.Eval.string ~strict:() x) (* Tuples *) | <:expr< $tup:x$ >> -> Tuple(List.map (eval env) (Ast.list_of_expr x [])) (* Variables *) | <:expr@loc< $lid:x$ >> | <:expr@loc< $uid:x$ >> -> begin try Env.find x env with Not_found -> Loc.raise loc (Failure (Printf.sprintf "unbound value %s" x)) end (* Value comparing *) | <:expr< $x$ = $y$ >> -> let x, y = eval_same env x y in Bool(x = y) | <:expr< $x$ < $y$ >> -> let x, y = eval_same env x y in Bool(x < y) | <:expr< $x$ > $y$ >> -> let x, y = eval_same env x y in Bool(x > y) | <:expr< $x$ <= $y$ >> -> let x, y = eval_same env x y in Bool(x <= y) | <:expr< $x$ >= $y$ >> -> let x, y = eval_same env x y in Bool(x >= y) | <:expr< $x$ <> $y$ >> -> let x, y = eval_same env x y in Bool(x <> y) (* min and max *) | <:expr< min $x$ $y$ >> -> let x, y = eval_same env x y in min x y | <:expr< max $x$ $y$ >> -> let x, y = eval_same env x y in max x y (* Arithmetic *) | <:expr< $x$ + $y$ >> -> Int(eval_int env x + eval_int env y) | <:expr< $x$ - $y$ >> -> Int(eval_int env x - eval_int env y) | <:expr< $x$ * $y$ >> -> Int(eval_int env x * eval_int env y) | <:expr< $x$ / $y$ >> -> Int(eval_int env x / eval_int env y) | <:expr< $x$ mod $y$ >> -> Int(eval_int env x mod eval_int env y) (* Boolean operations *) | <:expr< not $x$ >> -> Bool(not (eval_bool env x)) | <:expr< $x$ or $y$ >> -> Bool(eval_bool env x or eval_bool env y) | <:expr< $x$ || $y$ >> -> Bool(eval_bool env x || eval_bool env y) | <:expr< $x$ && $y$ >> -> Bool(eval_bool env x && eval_bool env y) (* String operations *) | <:expr< $x$ ^ $y$ >> -> String(eval_string env x ^ eval_string env y) (* Pair operations *) | <:expr< fst $x$ >> -> fst (eval_pair env x) | <:expr< snd $x$ >> -> snd (eval_pair env x) (* Let-binding *) | <:expr< let $p$ = $x$ in $y$ >> -> let vx = eval env x in let env = try bind env p vx with Exit -> invalid_type (Ast.loc_of_expr x) (type_of_patt p) (type_of_value vx) in eval env y | e -> Loc.raise (Ast.loc_of_expr e) (Stream.Error "expression not supported") and bind env patt value = match patt with | <:patt< $lid:id$ >> -> Env.add id value env | <:patt< $tup:patts$ >> -> let patts = Ast.list_of_patt patts [] in begin match value with | Tuple values when List.length values = List.length patts -> List.fold_left2 bind env patts values | _ -> raise Exit end | _ -> Loc.raise (Ast.loc_of_patt patt) (Stream.Error "pattern not supported") and eval_same env ex ey = let vx = eval env ex and vy = eval env ey in let tx = type_of_value vx and ty = type_of_value vy in if tx = ty then (vx, vy) else invalid_type (Ast.loc_of_expr ey) tx ty and eval_int env e = match eval env e with | Int x -> x | v -> invalid_type (Ast.loc_of_expr e) Tint (type_of_value v) and eval_bool env e = match eval env e with | Bool x -> x | v -> invalid_type (Ast.loc_of_expr e) Tbool (type_of_value v) and eval_string env e = match eval env e with | String x -> x | v -> invalid_type (Ast.loc_of_expr e) Tstring (type_of_value v) and eval_pair env e = match eval env e with | Tuple [x; y] -> (x, y) | v -> invalid_type (Ast.loc_of_expr e) (Ttuple [Tvar "a"; Tvar "b"]) (type_of_value v) (* +-----------------------+ | Parsing of directives | +-----------------------+ *) let rec skip_space stream = match Stream.peek stream with | Some((BLANKS _ | COMMENT _), _) -> Stream.junk stream; skip_space stream | _ -> () let parse_equal stream = skip_space stream; match Stream.next stream with | KEYWORD "=", _ -> () | _, loc -> Loc.raise loc (Stream.Error "'=' expected") let rec parse_eol stream = let tok, loc = Stream.next stream in match tok with | BLANKS _ | COMMENT _ -> parse_eol stream | NEWLINE | EOI -> () | _ -> Loc.raise loc (Stream.Error "end of line expected") (* Return whether a keyword can be interpreted as an identifier *) let keyword_is_id str = let rec aux i = if i = String.length str then true else match str.[i] with | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' -> aux (i + 1) | _ -> false in aux 0 let parse_ident stream = skip_space stream; let tok, loc = Stream.next stream in begin match tok with | LIDENT id | UIDENT id -> id | KEYWORD kwd when keyword_is_id kwd -> kwd | _ -> Loc.raise loc (Stream.Error "identifier expected") end let parse_expr stream = (* Lists of opened brackets *) let opened_brackets = ref [] in (* Return the next token of [stream] until all opened parentheses have been closed and a newline is reached *) let rec next_token _ = Some(match Stream.next stream, !opened_brackets with | (NEWLINE, loc), [] -> EOI, loc | (KEYWORD("(" | "[" | "{" as b), _) as x, l -> opened_brackets := b :: l; x | (KEYWORD ")", loc) as x, "(" :: l -> opened_brackets := l; x | (KEYWORD "]", loc) as x, "[" :: l -> opened_brackets := l; x | (KEYWORD "}", loc) as x, "{" :: l -> opened_brackets := l; x | x, _ -> x) in Gram.parse_tokens_after_filter Syntax.expr_eoi (Gram.Token.Filter.filter (Gram.get_filter ()) (Stream.from next_token)) let parse_directive stream = match Stream.peek stream with | Some(KEYWORD "#", loc) -> Stream.junk stream; (* Move the location to the beginning of the line *) let (file_name, start_line, start_bol, start_off, stop_line, stop_bol, stop_off, ghost) = Loc.to_tuple loc in let loc = Loc.of_tuple (file_name, start_line, start_bol, start_bol, start_line, start_bol, start_bol, ghost) in begin match parse_ident stream with | "let" -> let id = parse_ident stream in parse_equal stream; let expr = parse_expr stream in Some(Dir_let(id, expr), loc) | "let_default" -> let id = parse_ident stream in parse_equal stream; let expr = parse_expr stream in Some(Dir_default(id, expr), loc) (* For compatibility *) | "define" -> let id = parse_ident stream in let expr = parse_expr stream in Some(Dir_let(id, expr), loc) (* For compatibility *) | "default" -> let id = parse_ident stream in let expr = parse_expr stream in Some(Dir_default(id, expr), loc) | "if" -> Some(Dir_if(parse_expr stream), loc) | "else" -> parse_eol stream; Some(Dir_else, loc) | "elif" -> Some(Dir_elif(parse_expr stream), loc) | "endif" -> parse_eol stream; Some(Dir_endif, loc) | "include" -> Some(Dir_include(parse_expr stream), loc) | "directory" -> Some(Dir_directory(parse_expr stream), loc) | "error" -> Some(Dir_error(parse_expr stream), loc) | "warning" -> Some(Dir_warning(parse_expr stream), loc) | "default_quotation" -> Some(Dir_default_quotation(parse_expr stream), loc) | dir -> Loc.raise loc (Stream.Error (Printf.sprintf "bad directive ``%s''" dir)) end | _ -> None let parse_command_line_define str = match Gram.parse_string Syntax.expr (Loc.mk "") str with | <:expr< $lid:id$ = $e$ >> | <:expr< $uid:id$ = $e$ >> -> define id (eval !env e) | _ -> invalid_arg str (* +----------------+ | BLock skipping | +----------------+ *) let rec skip_line stream = match Stream.next stream with | NEWLINE, _ -> () | EOI, loc -> Loc.raise loc (Stream.Error "#endif missing") | _ -> skip_line stream let rec next_directive stream = match parse_directive stream with | Some dir -> dir | None -> skip_line stream; next_directive stream let rec next_endif stream = let dir, loc = next_directive stream in match dir with | Dir_if _ -> skip_if stream; next_endif stream | Dir_else | Dir_elif _ | Dir_endif -> dir | _ -> next_endif stream and skip_if stream = let dir, loc = next_directive stream in match dir with | Dir_if _ -> skip_if stream; skip_if stream | Dir_else -> skip_else stream | Dir_elif _ -> skip_if stream | Dir_endif -> () | _ -> skip_if stream and skip_else stream = let dir, loc = next_directive stream in match dir with | Dir_if _ -> skip_if stream; skip_else stream | Dir_else -> Loc.raise loc (Stream.Error "#else without #if") | Dir_elif _ -> Loc.raise loc (Stream.Error "#elif without #if") | Dir_endif -> () | _ -> skip_else stream (* +-----------------+ | Token filtering | +-----------------+ *) type context = Ctx_if | Ctx_else (* State of the token filter *) type state = { stream : (Gram.Token.t * Loc.t) Stream.t; (* Input stream *) mutable bol : bool; (* Whether we are at the beginning of a line *) mutable stack : context list; (* Nested contexts *) on_eoi : Gram.Token.t * Loc.t -> Gram.Token.t * Loc.t; (* Eoi handler, it is used to restore the previous state on #include directives *) } (* Read and return one token *) let really_read state = let tok, loc = Stream.next state.stream in state.bol <- tok = NEWLINE; match tok with | QUOTATION ({ q_name = "optcomp" } as quot) -> let id = next_quotation_id () in Hashtbl.add quotations id (eval !env (Gram.parse_string Syntax.expr_eoi (Loc.move `start quot.q_shift loc) quot.q_contents)); (* Replace the quotation by its id *) (QUOTATION { quot with q_contents = string_of_int id }, loc) | EOI -> (* If end of input is reached, we call the eoi handler. It may continue if we were parsing an included file *) if state.stack <> [] then Loc.raise loc (Stream.Error "#endif missing"); state.on_eoi (tok, loc) | _ -> (tok, loc) (* Return the next token from a stream, interpreting directives. *) let rec next_token state_ref = let state = !state_ref in if state.bol then match parse_directive state.stream, state.stack with | Some(Dir_if e, _), _ -> let rec aux e = if eval_bool !env e then begin state.stack <- Ctx_if :: state.stack; next_token state_ref end else match next_endif state.stream with | Dir_else -> state.stack <- Ctx_else :: state.stack; next_token state_ref | Dir_elif e -> aux e | Dir_endif -> next_token state_ref | _ -> assert false in aux e | Some(Dir_else, loc), ([] | Ctx_else :: _) -> Loc.raise loc (Stream.Error "#else without #if") | Some(Dir_elif _, loc), ([] | Ctx_else :: _) -> Loc.raise loc (Stream.Error "#elif without #if") | Some(Dir_endif, loc), [] -> Loc.raise loc (Stream.Error "#endif without #if") | Some(Dir_else, loc), Ctx_if :: l -> skip_else state.stream; state.stack <- l; next_token state_ref | Some(Dir_elif _, loc), Ctx_if :: l -> skip_if state.stream; state.stack <- l; next_token state_ref | Some(Dir_endif, loc), _ :: l -> state.stack <- l; next_token state_ref | Some(Dir_let(id, e), _), _ -> define id (eval !env e); next_token state_ref | Some(Dir_default(id, e), _), _ -> if not (Env.mem id !env) then define id (eval !env e); next_token state_ref | Some(Dir_include e, _), _ -> let fname = eval_string !env e in (* Try to looks up in all include directories *) let fname = try List.find (fun dir -> Sys.file_exists (Filename.concat dir fname)) !dirs with (* Just try in the current directory *) Not_found -> fname in dependencies := String_set.add fname !dependencies; let ic = open_in fname in let nested_state = { stream = Gram.filter (Gram.lex (Loc.mk fname) (Stream.of_channel ic)); bol = true; stack = []; on_eoi = (fun _ -> (* Restore previous state and close channel on eoi *) state_ref := state; close_in ic; next_token state_ref) } in (* Replace current state with the new one *) state_ref := nested_state; next_token state_ref | Some(Dir_directory e, loc), _ -> let dir = eval_string !env e in add_include_dir dir; next_token state_ref | Some(Dir_error e, loc), _ -> Loc.raise loc (Failure (eval_string !env e)) | Some(Dir_warning e, loc), _ -> Syntax.print_warning loc (eval_string !env e); next_token state_ref | Some(Dir_default_quotation e, loc), _ -> Syntax.Quotation.default := eval_string !env e; next_token state_ref | None, _ -> really_read state else really_read state let stream_filter filter stream = (* Set the source filename *) begin match !source_filename with | Some _ -> () | None -> match Stream.peek stream with | None -> () | Some(tok, loc) -> source_filename := Some(Loc.file_name loc) end; let state_ref = ref { stream = stream; bol = true; stack = []; on_eoi = (fun x -> x) } in filter (Stream.from (fun _ -> Some(next_token state_ref))) (* +----------------------+ | Quotations expansion | +----------------------+ *) let expand f loc _ contents = try f loc (Hashtbl.find quotations (int_of_string contents)) with exn -> Loc.raise loc (Failure "fatal error in optcomp!") (* +--------------+ | Registration | +--------------+ *) let _ = Camlp4.Options.add "-let" (Arg.String parse_command_line_define) " Binding for a #let directive."; Camlp4.Options.add "-I" (Arg.String add_include_dir) " Add a directory to #include search path."; Camlp4.Options.add "-depend" (Arg.String (fun filename -> dependency_filename := Some filename)) " Write dependencies to ."; Pervasives.at_exit write_depencies; Syntax.Quotation.add "optcomp" Syntax.Quotation.DynAst.expr_tag (expand expr_of_value); Syntax.Quotation.add "optcomp" Syntax.Quotation.DynAst.patt_tag (expand patt_of_value); Gram.Token.Filter.define_filter (Gram.get_filter ()) stream_filter batteries-included-3.4.0/build/optcomp/sample.ml000066400000000000000000000102441415601150500216570ustar00rootroot00000000000000(* * sample.ml * --------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of optcomp. *) (* This file show how to use optcomp *) (* +-----------+ | Variables | +-----------+ *) (* Variables are defined with the directive let: #let = where is any lower or upper identifier and is any well-parenthesed expression, followed by a newline. For instanse here are some correct variable definition: *) #let X = 1 #let y = 1 + (1 + 1) #let z = X + y (* Notes: - contrary to cpp, expressions are evalued at definition time, so they may only refer to previously defined variables - there is no #ifdef, #ifndef directives, but you can give a default value to a variable with: #let_default = This means that if is not yet defined then it will be defined to . For instance, in: *) #let_default toto = 2 #let truc = true #let_default truc = false (* [toto] will be bound to [2] but [truc] will be bound to [true] By default only the variable ocaml_version is set. It is set to the pair of integers (major_version, minor_version). *) (* +------------+ | Conditions | +------------+ *) (* To switch between different different pieces of code, one can use the following directives: #if #else #elif #endif where must evaluate to a boolean value. For example: *) #if ocaml_version >= (3, 11) type t = private int #else type t #endif (* It is also possible to split the expression over multiple lines by using parentheses: *) #let ocaml_major_version = fst ocaml_version #let ocaml_minor_version = snd ocaml_version #if ( (ocaml_major_version = 3 && ocaml_minor_version >= 11) || ocaml_major_version > 3 ) let lazy x = lazy 1 #else let x = 1 #endif (* +-------------+ | Expressions | +-------------+ *) (* It is actually not possibles to use any kind of expressions. Here is what is allowed: - litterals booleans, integers, strings and characters: - basic integer operations: +, -, /, *, mod - value comparing: =, <>, <, >, <=, >= - maximum and minimum: max, min - basic boolean operations: or, ||, &&, not - pair operations: fst, snd - let-bindings Example: *) #let x = (1, 2, (3, 4)) #let y = (let (a, b, (c, d)) = x in a + b = c || (max b c = 2 && d = a - 1)) (* +-------------+ | Indentation | +-------------+ *) (* Spaces and comments are ignored between the "#" at the beginning of the line and the directive name, so directives can be indented like that: *) #if true let x = 1 # if false let y = 2 # (* plop *) elif 1 + 1 = 2 let i = 2 # else let o = 42 # endif #endif (* +---------------------+ | Errors and warnings | +---------------------+ *) (* You may also use the #error #warning directives to make the parser to fail or print a warning: *) #if ocaml_version < (3, 0) # error "too old ocaml version, minimum is 3.0" #endif #if ocaml_version < (2048, 0) # warning "plop!" #endif (* +-------------------------+ | #include and #directory | +-------------------------+ *) (* To include an another file one can use either #use or #include directives. The difference is that with the #include option, the file will be searched in all directories specified with the "-I" command line option or with #directory directives. #directory "dir" #include "file" Notes: - argument of #directory and #include can be any expression of type string - the environment can be accessed and modified by included files - #directory directives are interpreted by both optcomp and camlp4 *) #include "sample_incl.ml" (* +-----------------------------------+ | Access to definitions in the code | +-----------------------------------+ *) (* We may want to access to values of the optcomp environment. For that we can use the "optcomp" quotation, which will be expansed into an expression or pattern: *) #let totolib_version = (1, 1) let print_info _ = let (major, minor) = <:optcomp< totolib_version >> in Printf.printf "sample is compiled with totolib version %d.%d" major minor batteries-included-3.4.0/build/optcomp/sample_incl.ml000066400000000000000000000003221415601150500226600ustar00rootroot00000000000000(* * sample_incl.ml * -------------- * Copyright : (c) 2009, Jeremie Dimino * Licence : BSD3 * * This file is a part of optcomp. *) (* File included by "sample.ml" *) #let x = 1 batteries-included-3.4.0/build/packdoc.ml000066400000000000000000000151551415601150500203270ustar00rootroot00000000000000(* Obsolete. Now integrated into myocamlbuild.ml*) (** Imported from {!List} to avoid weird dependencies during compilation*) module List = struct include List let filter_map f l = let rec loop acc = function | [] -> acc | h::t -> match f h with | None -> loop acc t | Some x -> loop (x::acc) t in rev (loop [] l) end (** Imported from {!IO.Printf} to avoid weird dependencies during compilation*) module Printf = struct include Printf let make_list_printer (p:(out_channel -> 'b -> unit)) (start: string) (finish: string) (separate:string) (out:out_channel) (l: 'b list ) = let rec aux out l = match l with | [] -> () | [h] -> p out h | h::t -> fprintf out "%a%s%a" p h separate aux t in fprintf out "%s%a%s" start aux l finish end (** Imported from {!ExtString.String} to avoid weird dependencies during compilation*) module String = struct include String exception Invalid_string let find str sub = let sublen = length sub in if sublen = 0 then 0 else let found = ref 0 in let len = length str in try for i = 0 to len - sublen do let j = ref 0 in while unsafe_get str (i + !j) = unsafe_get sub !j do incr j; if !j = sublen then begin found := i; raise Exit; end; done; done; raise Invalid_string with Exit -> !found let split str sep = let p = find str sep in let len = length sep in let slen = length str in sub str 0 p, sub str (p + len) (slen - p - len) let nsplit str sep = if str = "" then [] else ( let rec nsplit str sep = try let s1 , s2 = split str sep in s1 :: nsplit s2 sep with Invalid_string -> [str] in nsplit str sep ) end let read_dependency dep_name = let module_name = String.capitalize (Filename.basename (Filename.chop_suffix dep_name ".mli.depends")) in let f = open_in dep_name in let (file_name, dependencies) = String.split (input_line f) ":" in let result = (file_name, module_name, List.filter (fun x -> not (String.length x = 0)) (String.nsplit dependencies " ")) in close_in f; result module StringSet = Set.Make(String) module Dependency = struct type t = (string, StringSet.t) Hashtbl.t let create () = Hashtbl.create 100 let add tbl k dep = try Hashtbl.replace tbl k (StringSet.add dep (Hashtbl.find tbl k)) with Not_found -> Hashtbl.add tbl k (StringSet.singleton dep) let remove tbl (k:string) dep = try let set = StringSet.remove dep (Hashtbl.find tbl k) in if StringSet.is_empty set then Hashtbl.remove tbl k else Hashtbl.replace tbl k set with Not_found -> () let find tbl (k:string) = try Some (Hashtbl.find tbl k) with Not_found -> None let find_all tbl (k:string) = try StringSet.elements (Hashtbl.find tbl k) with Not_found -> [] let print out tbl = Printf.fprintf out "{"; Hashtbl.iter (fun k set -> Printf.fprintf out "%s: {%a}\n" k (Printf.make_list_printer (fun out -> Printf.fprintf out "%s") "{" "}" "; ") (StringSet.elements set)) tbl; Printf.fprintf out "}\n" end (** Read the dependencies from a directory and sort them*) let sort directory = let dep = Dependency.create () (*Direct dependencies*) and rev = Dependency.create () (*Reverse dependencies*) and modules = ref StringSet.empty (*All modules involved, including external ones*) and src : (string, string) Hashtbl.t = Hashtbl.create 100 and files = Sys.readdir directory in (*Read all the dependencies and store them in the tables*) Array.iter ( fun f -> if Filename.check_suffix f ".mli.depends" then let (file_name, module_name, dependencies) = read_dependency (Filename.concat directory f) in List.iter (fun x -> (* Printf.eprintf "Adding a dependency %S => %S\n" module_name x;*) modules := StringSet.add x !modules; Dependency.add dep module_name x; Dependency.add rev x module_name ) dependencies; modules := StringSet.add module_name !modules; Hashtbl.replace src module_name file_name else () ) files ; (*Now, start sorting*) let rec aux (sorted:string list) (rest: string list) = match rest with | [] -> sorted | _ -> (*Find nodes which haven't been removed and depend on nothing*) match List.fold_left (fun (keep, remove) k -> match Dependency.find dep k with | None -> (keep, k::remove) | Some dependencies -> (* Printf.eprintf "Module %s can't be removed, as it depends on %a (%d)\n" k (Printf.make_list_printer IO.nwrite "[" "]" "; ") (StringSet.elements dependencies) (List.length (StringSet.elements dependencies) );*) (k::keep, remove) ) ([],[]) rest with | (_, []) -> Printf.eprintf "Cyclic dependencies in %a\n" Dependency.print dep; assert false | (rest, roots) -> List.iter (fun d -> List.iter (*Dependency [d] has been resolved, remove it.*) (fun x -> Dependency.remove dep x d) (Dependency.find_all rev d)) roots; aux (sorted @ roots) rest in let sorted = aux [] (StringSet.elements !modules) in List.filter_map (fun module_name -> try Some (module_name, Hashtbl.find src module_name) with Not_found -> (* Printf.eprintf "I'm not going to add module %s, it's external\n%!" module_name;*) None) sorted let generate_mli cout pack l = let feed file cout () = let cin = open_in file in try while true do output_string cout (input_line cin); output_char cout '\n' done with End_of_file -> () in let print_modules cout () = List.iter ( fun (name, src) -> Printf.fprintf cout "module %s:\nsig\n%a\nend\n" name (feed src) () ) l in (* Printf.fprintf out "module %s:\nsig\n%a\nend\n" pack print_modules ()*) print_modules cout () let dir = ref "." let out = ref "" let pack= ref "" let _ = let _ = Arg.parse [("-i", Arg.Set_string dir, "Choose the directory containing dependencies" ); ("--in", Arg.Set_string dir, "Choose the directory containing dependencies" ); ("-o", Arg.Set_string out, "Choose a destination file (stdout by default)"); ("--out", Arg.Set_string out, "Choose a destination file (stdout by default)"); ("-pack", Arg.Set_string pack,"Set the name of the enclosing module")] ignore "" in let dir = !dir and out = match !out with "" -> stdout | name -> open_out name and pack= match !pack with"" -> failwith "Missing argument -pack" | name -> name in Printf.eprintf "Sorting directory %s/%s\n" (Unix.getcwd()) dir; generate_mli out pack (sort dir) batteries-included-3.4.0/build/prefilter.ml000066400000000000000000000056101415601150500207120ustar00rootroot00000000000000let (major, minor, extra) = Scanf.sscanf Sys.ocaml_version "%d.%d.%d%s" (fun j n _ s -> (j, n, s)) let filter_cookie_re = Str.regexp "^##V\\([<>]?=?\\)\\([^#]+\\)##" let version_re = Str.regexp "\\([0-9]+\\)\\(\\.\\([0-9]+\\)\\)?" (* We track line count in the input source, to print location directives for the OCaml lexer: # 123 foo.mlv lets the compiler know that it should consider the current location to be line 123 in file foo.mlv, which lets it report errors in the right place in the .mlv instead of some random place in a generated .ml. The [stale] reference is purely cosmetic: it would be correct to print a lexer directive at each line, but generate much less readable preprocessed outputs. *) let mark_loc_stale = function | None -> () | Some (_file, _count, stale) -> stale := true let incr_loc = function | None -> () | Some (_file, count, _stale) -> incr count let print_loc = function | None -> () | Some (file, count, stale) -> if !stale then begin Printf.printf "# %d %S\n" !count file; stale := false; end let has_domains ~extra = let extra = Str.full_split (Str.regexp_string "+") extra in List.mem (Str.Text "domains") extra || List.mem (Str.Text "multicore") extra || List.mem (Str.Text "effects") extra let rec process_line loc line = if not (Str.string_match filter_cookie_re line 0) then print_endline line else begin let cmp = match Str.matched_group 1 line with | "<" -> (<) | ">" -> (>) | "=" -> (=) | "<=" -> (<=) | ">=" -> (>=) | _ -> failwith "The ##V8## form is now disabled, use ##V>=8## instead" in let ver_string = Str.matched_group 2 line in let pass = if Str.string_match version_re ver_string 0 then let ver_maj = int_of_string (Str.matched_group 1 ver_string) in let ver_min = try int_of_string (Str.matched_group 3 ver_string) with _ -> 0 in cmp (major*100+minor) (ver_maj*100+ver_min) else if ver_string = "multicore" then cmp (if has_domains ~extra then 5 else major) 5 else failwith "Could not parse version string" in if pass then process_line loc (Str.replace_first filter_cookie_re "" line) else mark_loc_stale loc end let ( |> ) x f = f x let process in_channel loc = try while true do print_loc loc; input_line in_channel |> process_line loc; incr_loc loc; done with End_of_file -> () let from_stdin () = process stdin None let from_file file = let in_channel = open_in file in let loc = Some (file, ref 1, ref true) in process in_channel loc; close_in in_channel let () = if not !Sys.interactive then begin match Array.length Sys.argv with | 1 -> (* no param *) from_stdin () | 2 -> (* one filename *) from_file Sys.argv.(1) | _ -> failwith "expected zero parameter (read from stdin) or one (filename)" end batteries-included-3.4.0/build/preprocess_mli/000077500000000000000000000000001415601150500214105ustar00rootroot00000000000000batteries-included-3.4.0/build/preprocess_mli/_tags000066400000000000000000000000541415601150500224270ustar00rootroot00000000000000<*>:camlp4oof,use_camlp4_full,use_ocamlbuildbatteries-included-3.4.0/build/preprocess_mli/extract_mli.ml000066400000000000000000000030651415601150500242610ustar00rootroot00000000000000(* * generate_mli.ml * --------------- * Copyright : (c) 2009, Jeremie Dimino * 2009, David Rajchenbach-Teller (contributor) * Licence : BSD3 *) (* This file generate a .mli from a simplified .ml file. It should be invoked like that: $ generate_mli input.ml > output.mli Allowed constructions in the .ml are: - module aliases: "module Foo = Bar" ("Bar" must be an external module) - structures: "module Foo = struct ... end" - comments *) open Preprocess_common (* +------+ | Main | +------+ *) let _ = let destination = ref "" and source = ref "" and path = ref "" in Arg.parse [("-o", Arg.Set_string destination, "Output to a given file (standard output by default)"); ("-i", Arg.Set_string source, "Input from a given file (standard input by default)"); ("-path", Arg.Set_string path, "Name of the submodule to extract (default is extract everything)")] ignore (Printf.sprintf "%s [options]: extract part of the contents of a .mli file\n%!" (Filename.basename Sys.argv.(0))); try let output = match !destination with | "" -> stdout | s -> open_out s and input = match !source with | "" -> stdin | s -> open_in s and path = match !path with | "" -> [] | s -> path_of_string (Sys.argv.(2)) in extract !source input output path; flush_all () with | Exit as e -> raise e | exn -> Format.eprintf "@[%a@]@." Camlp4.ErrorHandler.print exn batteries-included-3.4.0/build/preprocess_mli/generate_mli.ml000066400000000000000000000407531415601150500244060ustar00rootroot00000000000000(* Build a .mli from a .dist file. Files with extension .dist are used to assemble modules into a consistent hierarchy. Essentially, .dist files are .ml files with additional annotations designed to allow generation of the corresponding .mli. Format of a .dist file: {[ (*Module comment*) module Foo = A.Module.Path (*%mli "a/file/path/foo.mli" aka "InnerFoo"*) (*Module comment*) module Bar = Another.Module.Path.Foo (*%mli "another/file/path/foo.mli" submodule "Bar"*) (*Module comment*) module Sna = struct module Toto = Yet.Another.Module.Path (*%mli "a/file/path/foo.mli"*) (*...same grammar...*) end ]} Producing a .ml is trivial, there's nothing to do. Producing a .mli is more complex: - parse the .dist file, keeping comments which don't start with % (gasp) - build the list of substitutions -- here, every occurrence of [InnerFoo] must become [Foo] -- here, every occurrence of [A.Module.Path] must become [Foo] -- here, every occurrence of [Yet.Another.Module.Path] must become [Sna.Toto] - build the list of source .mli - if necessary, generate each source .mli (so this needs to be done from myocamlbuild.ml) - from each %mli directive -- build a temporary file, obtained by ---- extracting only the necessary submodules (remove [module Stuff : sig] and [end (*Stuff*)]) ---- performing all the substitutions in the list -- invoke ocamldep -- parse the result of ocamldep and deduce a list of dependencies for the destination module (here, [Foo], [Bar], [Toto]) - bubble dependencies upwards in the tree of modules (here, [Sna] should inherit all the dependencies of [Toto]) - perform topological sort on dependencies - assuming topological sort has succeeded, generate a .mli where every module alias is replaced by the contents of the corresponding temporary .mli - write down all of this to a file. easy, isn't it? *) open Preprocess_common open Genlex open Camlp4.PreCast open Camlp4.Sig module StringSet = Set.Make(String) (** {6 Finding files}*) (**The list of include directories. Specified on the command-line*) let include_dirs : string list ref = ref [] (** {6 Calling ocamldep} *) open Ocamlbuild_pack (** Invoke ocamldep and compute the dependencies of a .mli*) let stringset_of_ocamldep : string -> StringSet.t = fun file -> List.fold_left (fun acc (_, x) -> StringSet.add x acc) StringSet.empty (Ocaml_utils.path_dependencies_of file) (** {6 Utilities}*) (** Imported from {!IO.Printf} to avoid unsolvable dependencies*) module Printf = struct include Printf let make_list_printer (p:(out_channel -> 'b -> unit)) (start: string) (finish: string) (separate:string) (out:out_channel) (l: 'b list ) = let rec aux out l = match l with | [] -> () | [h] -> p out h | h::t -> fprintf out "%a%s%a" p h separate aux t in fprintf out "%s%a%s" start aux l finish end open Printf (** {6 Dependency sorting}*) module Dependency = struct type t = (string, StringSet.t) Hashtbl.t let create () = Hashtbl.create 100 let add tbl k dep = try Hashtbl.replace tbl k (StringSet.add dep (Hashtbl.find tbl k)) with Not_found -> Hashtbl.add tbl k (StringSet.singleton dep) let remove tbl (k:string) dep = try let set = StringSet.remove dep (Hashtbl.find tbl k) in if StringSet.is_empty set then Hashtbl.remove tbl k else Hashtbl.replace tbl k set with Not_found -> () let find tbl (k:string) = try Some (Hashtbl.find tbl k) with Not_found -> None let find_all tbl (k:string) = try StringSet.elements (Hashtbl.find tbl k) with Not_found -> [] let print out tbl = Printf.fprintf out "{"; Hashtbl.iter (fun k set -> Printf.fprintf out "%s: {%a}\n" k (Printf.make_list_printer (fun out -> Printf.fprintf out "%s") "{" "}" "; ") (StringSet.elements set)) tbl; Printf.fprintf out "}\n" end module Depsort = struct type t = { direct : Dependency.t (**Direct dependency*); reverse: Dependency.t (**Reverse dependency*); set : StringSet.t ref (**All the nodes*) } let create () = { direct = Dependency.create (); reverse = Dependency.create (); set = ref StringSet.empty } let add_node t node = t.set := StringSet.add node !(t.set) let add_dependency t depending depended = Dependency.add t.direct depending depended; Dependency.add t.reverse depended depending; add_node t depending; add_node t depended let sort t = (* Printf.eprintf "Sorting %a\n" Dependency.print t.direct;*) let rec aux (sorted:string list) (rest: string list) = match rest with | [] -> sorted | _ -> (*Find nodes which haven't been removed and depend on nothing*) match List.fold_left (fun (keep, remove) k -> match Dependency.find t.direct k with | None -> (keep, k::remove) | Some dependencies -> (k::keep, remove) ) ([],[]) rest with | (_, []) -> Printf.eprintf "Cyclic dependencies in %a\n" Dependency.print t.direct; failwith "Cyclic dependencies" | (rest, roots) -> List.iter (fun d -> (* Printf.eprintf "Dependency %S resolved\n" d;*) List.iter (*Dependency [d] has been resolved, remove it.*) (fun x -> Dependency.remove t.direct x d) (Dependency.find_all t.reverse d)) roots; aux (sorted @ roots) rest in aux [] (StringSet.elements !(t.set)) end (** {6 String manipulation} *) module String = struct include String exception Invalid_string let find str ?(pos=0) ?(end_pos=length str) sub = let sublen = length sub in if sublen = 0 then 0 else let found = ref 0 in try for i = pos to end_pos - sublen do let j = ref 0 in while unsafe_get str (i + !j) = unsafe_get sub !j do incr j; if !j = sublen then begin found := i; raise Exit; end; done; done; raise Invalid_string with Exit -> !found let split str sep = let p = find str sep in let len = length sep in let slen = length str in sub str 0 p, sub str (p + len) (slen - p - len) let nsplit str sep = if str = "" then [] else ( let rec nsplit str sep = try let s1 , s2 = split str sep in s1 :: nsplit s2 sep with Invalid_string -> [str] in nsplit str sep ) type segment = Changed of string | Slice of int * int let global_replace convs str = (* convs = (seek, replace) list *) let repl_one slist (seek,repl) = let rec split_multi acc = function Slice (start_idx, end_idx) -> begin try let i = find str ~pos:start_idx ~end_pos:end_idx seek in split_multi (* accumulate slice & replacement *) (Changed repl :: Slice (start_idx,i-1) :: acc) (* split the rest of the slice *) (Slice (i+length seek, end_idx)) with Invalid_string -> Slice (start_idx,end_idx) :: acc end | s -> s :: acc (* don't replace in a replacement *) in List.fold_left split_multi [] slist in let to_str pieces = let len_p = function Changed s -> length s | Slice (a,b) -> b-a + 1 in let len = List.fold_left (fun a p -> a + len_p p) 0 pieces in let out = String.create len in let rec loop pos = function Slice (s, e) :: t -> String.blit str s out pos (e-s+1); loop (pos+e-s+1) t | Changed s :: t -> String.blit s 0 out pos (length s); loop (pos + length s) t | [] -> () in loop 0 pieces; out in to_str (List.fold_left repl_one [Slice (0,length str)] convs) end (** {6 Representation of the .dist file}*) type path = string list (** The type of a module path*) (**Information regarding where to find the signature for a module.*) type sigsource = { mli : string (**Path towards the .mli file containing the data for this module, e.g. "src/core/extlib/extList.mli"*); inner_path : path (**Module path towards the interesting module, e.g. "List"*) } type comment = string list type substitution = (string * string) (** [(original, replacement)] *) type ('a,'b) sigtree = 'a * (('a, 'b) sigtree_aux) and ('a,'b) sigtree_aux = | Leaf of string * 'b * comment (**A module alias*) | Node of string * ('a, 'b) sigtree list * comment | Other of string (**Some uninterpreted content, such as unattached comments*);; (** Return the annotations on a tree*) let leaves_of (tree: (_, 'b) sigtree) : 'b list = let rec aux acc n = match n with | (_, Other _) -> acc | (_, Node (_, l, _)) -> List.fold_left aux acc l | (_, Leaf (_, x, _)) -> x :: acc in aux [] tree;; (** [extract_relevant_of_string file submodule] returns a string containing the relevant parts of [file]. If [submodule] is [[]], the relevant parts of [file] are the complete contents of [source]. If [submodule] is a module path, the relevant parts of [file] are only the contents of the corresponding path. *) let extract_relevant_of_file (filename: string) (path: path) (subs:substitution list) = let ic = open_in filename in let buf= Buffer.create 1024 in let oc = Format.formatter_of_buffer buf in extract filename ic oc path; let contents = Buffer.contents buf in String.global_replace subs contents;; let parse_annotation stream = let parse_annotation_content stream = let rec aux ?mli ~aka ?path = parser | [< 'Kwd "aka"; 'String s; stream >] -> aux ?mli ~aka:(s::aka) ?path stream | [< 'Kwd "mli"; 'String mli; stream >] -> aux ~mli ~aka ?path stream | [< 'Kwd "submodule"; 'String s; stream >] -> aux ?mli ~aka ~path:s stream | [< >] -> (mli, aka, path) in aux ~aka:[] (make_lexer ["aka"; "mli"; "submodule"] stream) in let rec aux stream = match Stream.next stream with | ((BLANKS _ | NEWLINE), _) -> aux stream | (COMMENT c, _) -> if String.length c >= 1 && String.get c 0 = '%' then Some (parse_annotation_content (Stream.of_string c)) else None | _ -> None in aux stream (** Read and parse the contents of a .dist file and return it without any additional processing*) let read_dist: in_channel -> string -> (unit, sigsource) sigtree * substitution list = fun channel name -> let renamings = ref [] in let rec aux ~recent_comments (*~old_comments*) ~path stream : (_, _) sigtree list = match Stream.next stream with | (COMMENT c, _) -> aux ~recent_comments:(c::recent_comments) ~path (*~old_comments*) stream | ((BLANKS _ | NEWLINE), _) -> aux ~recent_comments:[] ~path (*~old_comments:(recent_comments @ old_comments)*) stream | (KEYWORD "module", _) -> begin skip_blanks stream; let id = parse_uident stream in skip_blanks stream; parse_equal stream; skip_blanks stream; match Stream.peek stream with | Some(KEYWORD "struct", _) -> njunk 1 stream; (* List.rev (List.map (fun x -> Other x) old_comments) @*) [((),Node (id, aux ~recent_comments:[] stream ~path:(path^id^"."), List.rev recent_comments))] | _ -> begin let source_path = parse_path stream in renamings := (string_of_path source_path, id) :: (path, id) :: !renamings; match parse_annotation stream with | Some (Some mli, aka, Some path) -> List.iter (fun x -> renamings := (x, id)::!renamings) aka; let annot = { mli = mli; inner_path = path_of_string path } in ((), Leaf (id, annot, List.rev recent_comments)) :: aux ~recent_comments:[] ~path stream | None -> failwith "Missing annotation" | _ -> failwith "Incomplete annotation" end end | (EOI, _) -> [] | (tok, loc) -> [] in (((), Node ("", aux ~recent_comments:[] ~path:"" (tokens_of_channel name channel), [])), !renamings) (** Go through a tree applying substitutions. For each leaf of the tree - read the [source] - extract the relevant part - apply the substitutions to the relevant part - write the substituted version to a temporary file - replace the leaf content with the temporary file name*) let apply_substitutions: ('a, sigsource) sigtree -> substitution list -> ('a, string) sigtree = fun tree substitutions -> let rec aux = function | (tag, Leaf (name, {mli = mli; inner_path = inner_path}, comment)) -> let contents = extract_relevant_of_file mli inner_path substitutions in let filename = Filename.temp_file "ocamlbuild_distrib" ".mli" in let cout = open_out filename in output_string cout contents; (tag, Leaf (name, filename, comment)) | (tag, Node (name, tree, comment)) -> (tag, Node (name, List.map aux tree, comment)) | (tag, Other o) -> (tag, Other o) in aux tree (** Compute dependencies of each node of the tree. For each leaf of the tree - apply ocamldep - parse the result into a list of dependencies For each node, merge the dependencies of subtrees. *) let compute_dependencies: (unit, string) sigtree -> (StringSet.t, string) sigtree = fun tree -> let rec aux = function | ((), Other o) -> (StringSet.empty, Other o) | ((), Node (name, children, comment)) -> let (deps, rewritten) = List.fold_left (fun (deps, rewritten) child -> let ((child_deps, _) as child') = aux child in (StringSet.union deps child_deps, child'::rewritten)) (StringSet.empty, []) children in (deps, Node (name, rewritten, comment)) | ((), Leaf (name, file_name, comment))-> (stringset_of_ocamldep file_name, Leaf (name, file_name, comment)) in aux tree (** Sort a list of modules topologically. [sort_modules l rename] sorts the modules of list [l]. Each name is transformed using [rename] before taking dependencies into account ([rename] serves chiefly to add prefixes). *) let sort_modules: ((StringSet.t, _) sigtree list as 'a) -> (string -> string) -> 'a = fun list prefix -> let dependencies = Depsort.create () and modules = Hashtbl.create 16 and others = ref [] in List.iter (function ((depends_on, Leaf (name, _, _)) as node) | ((depends_on, Node (name, _, _)) as node)-> let name' = prefix name in (*Collect dependencies*) Hashtbl.add modules name node; Depsort.add_node dependencies name; StringSet.iter (fun dep -> Depsort.add_dependency dependencies name' dep) depends_on | other -> others := other :: !others) list; List.rev_append !others (List.map (fun name -> Hashtbl.find modules name) (Depsort.sort dependencies)) (**Recursively sort by dependencies each level of the tree. *) let sort_tree : (StringSet.t, string) sigtree -> (StringSet.t, string) sigtree = fun tree -> let rec aux prefix = function | (_, Other _) as o -> o | (set, Node (name, children, comment)) -> (*First sort each child*) let prefix' = prefix ^ name ^ "." in let children = List.map (aux prefix') children in let mkprefix = fun s -> prefix' ^ s in (*Then sort between children*) (set, Node (name, sort_modules children mkprefix, comment)) | (_, Leaf _) as l -> l in aux "" tree (**Write down the tree *) let serialize_tree : Format.formatter -> (_, string) sigtree -> unit = fun out -> let serialize_comment out l = List.iter (Format.fprintf out "%s@\n") l in let rec aux = function | (_, Leaf (name, content, comment)) -> Format.fprintf out "%a@\nmodule %s : sig@[%s@]@\n" serialize_comment comment name content | (_, Node (name, children, comment)) -> Format.fprintf out "%a@\nmodule %s = struct@[%a@]@\n" serialize_comment comment name (fun _ l -> List.iter aux l) children | (_, Other s) -> Format.fprintf out "%s@\n" s in aux (** Drive the process*) let driver name cin cout = let (tree,substitutions) = read_dist cin name in let deps = compute_dependencies (apply_substitutions tree substitutions) in serialize_tree cout (sort_tree deps) let _ = let out_file = ref "" and in_file = ref "" in Arg.parse [("-I", Arg.String (fun x -> include_dirs := x :: !include_dirs), "Add include directory"); ("-o", Arg.Set_string out_file, "Set output .mli (standard out by default)")] (fun file -> out_file := file) "Generate a .mli file from a .dist"; let cout = match !out_file with | "" -> Format.std_formatter | s -> Format.formatter_of_out_channel (open_out s) and cin = match !in_file with | "" -> stdin | s -> open_in s in driver !in_file cin cout; flush_all () batteries-included-3.4.0/build/preprocess_mli/preprocess_common.ml000066400000000000000000000156461415601150500255130ustar00rootroot00000000000000open Format open Camlp4.PreCast open Camlp4.Sig (* +------------------+ | Stream utilities | +------------------+ *) let map_stream f stream = Stream.from (fun _ -> Some(f (Stream.next stream))) let keywords = [ "open"; "module"; "struct"; "object"; "sig"; "end"; "."; "=" ] let filter_keywords = map_stream (function | ((LIDENT id, loc) | (SYMBOL id, loc)) when List.mem id keywords -> (KEYWORD id, loc) | x -> x) let njunk n stream = for i = 1 to n do Stream.junk stream done (* +------------------------------+ | Module signatures resolution | +------------------------------+ *) type path = string list (* A module path. It is the list of components *) let rec find_map f = function | [] -> None | x :: l -> match f x with | None -> find_map f l | y -> y let path_of_string string = Str.split (Str.regexp "\\.") string let string_of_path path = match path with | [] -> "" | h::t -> let buf = Buffer.create 32 in Buffer.add_string buf h; List.iter (Buffer.add_string buf) t; Buffer.contents buf (* +--------------------------------+ | Filtering (parsing + printing) | +--------------------------------+ *) external filter : 'a Gram.not_filtered -> 'a = "%identity" let tokens_of_channel filename ic = filter_keywords (filter (Gram.lex (Loc.mk filename) (Stream.of_channel ic))) let print_token ?(oc=Format.std_formatter) = function | KEYWORD kwd -> fprintf oc "%s" kwd | SYMBOL sym -> fprintf oc "%s" sym | LIDENT lid -> fprintf oc "%s" lid | UIDENT uid -> fprintf oc "%s" uid | ESCAPED_IDENT id -> fprintf oc "( %s )" id | INT(_, s) -> fprintf oc "%s" s | INT32(_, s) -> fprintf oc "%s%c" s 'l' | INT64(_, s) -> fprintf oc "%s%c" s 'L' | NATIVEINT(_, s) -> fprintf oc "%s%c" s 'n' | FLOAT(_, s) -> fprintf oc "%s" s | CHAR(_, s) -> fprintf oc "%s" s | STRING(_, s) -> fprintf oc "%S" s | LABEL lbl -> fprintf oc "~%s:" lbl | OPTLABEL lbl -> fprintf oc "?%s:" lbl | QUOTATION quot -> if quot.q_name = "" then fprintf oc "<<" else begin fprintf oc "<:%s" quot.q_name; if quot.q_loc <> "" then fprintf oc "%c%s" '@' quot.q_loc; fprintf oc "<" end; fprintf oc "%s>>" quot.q_contents | ANTIQUOT(n, s) -> fprintf oc "$"; if n <> "" then fprintf oc "%s:" n; fprintf oc "%s$" s | COMMENT comment -> fprintf oc "%s" comment | BLANKS s -> fprintf oc "%s" s | NEWLINE -> fprintf oc "\n" | LINE_DIRECTIVE(n, fname_opt) -> fprintf oc "# %d" n; begin match fname_opt with | Some fname -> fprintf oc " %S\n" fname | None -> fprintf oc "\n" end | EOI -> raise Exit let print_tokens oc stream = try Stream.iter (fun (tok, loc) -> print_token ~oc tok) stream with Exit -> () let rec skip_blanks stream = match Stream.peek stream with | Some((BLANKS _ | NEWLINE | COMMENT _), _) -> Stream.junk stream; skip_blanks stream | _ -> () let parse_uident stream = match Stream.next stream with | (UIDENT id, loc) -> id | (_, loc) -> Loc.raise loc (Failure "upper identifier expected") let parse_equal stream = match Stream.next stream with | (KEYWORD "=", _) -> () | (_, loc) -> Loc.raise loc (Failure "'=' expected") (* Search and print a module in a file: *) let rec search_print_module oc stream = function | [] -> (* Search "sig": *) while fst (Stream.next stream) <> KEYWORD "sig" do () done; (* Now print until we reach the corresponding "end": *) let rec loop level = match Stream.next stream with | (KEYWORD (("sig" | "object") as kwd), _) -> fprintf oc "%s" kwd; loop (level + 1) | (KEYWORD "end", _) -> if level = 0 then fprintf oc "\n" else begin fprintf oc "end\n"; loop (level - 1) end | (EOI, _) -> () | (tok, loc) -> print_token ~oc tok; loop level in loop 0 | name :: rest -> let rec skip_module level = match Stream.next stream with | (KEYWORD ("sig" | "object"), _) -> skip_module (level + 1) | (KEYWORD "end", _) -> if level = 1 then () else skip_module (level - 1) | (EOI, _) -> () | _ -> skip_module level in (* Find the next module *) let rec next_module last_comment = match Stream.next stream with | COMMENT str, _ -> next_module str | KEYWORD "module", _ -> skip_blanks stream; (last_comment, parse_uident stream) | EOI, loc -> Loc.raise loc (Failure(sprintf "module %S not found" name)) | _ -> next_module last_comment in let comment, id = next_module "" in if id = name then begin fprintf oc "end\n%s" comment; search_print_module oc stream rest end else begin skip_module 0; search_print_module oc stream (name :: rest) end let rec print_docs oc stream = match Stream.peek stream with | Some(COMMENT str, _) -> njunk 1 stream; if String.length str > 4 && str.[2] = '*' && str.[3] <> '*' then fprintf oc "%s" str; print_docs oc stream | Some((BLANKS _ | NEWLINE) as tok, _) -> njunk 1 stream; print_token ~oc tok; print_docs oc stream | _ -> () (* Extract a module signature from a file. [path] is the module path inside the file, the empty list means the whole file. *) let extract filename ic oc path = let stream = tokens_of_channel filename ic in let rec next i(*ignored*) = match Stream.npeek 3 stream with | (UIDENT id, _) :: (KEYWORD ".", _) :: _ when String.length id > 3 && String.sub id 0 3 = "Ext" -> njunk 2 stream; next i | (KEYWORD "open", _) :: (BLANKS _, _) :: (UIDENT id, _) :: _ when String.length id > 3 && String.sub id 0 3 = "Ext" -> njunk 3 stream; next i | _ -> Some(Stream.next stream) in let stream = Stream.from next in begin match path with | [] -> print_docs oc stream; print_tokens oc stream; | [_] -> print_docs oc stream; search_print_module oc stream path | _ -> search_print_module oc stream path end (* Parse a module path *) let rec parse_path stream = match Stream.npeek 2 stream with | [(UIDENT id, _); (KEYWORD ".", _)] -> njunk 2 stream; id :: parse_path stream | (UIDENT id, _) :: _ -> njunk 1 stream; [id] | (_, loc) :: l -> Loc.raise loc (Failure "invalid module path") | _ -> raise End_of_file batteries-included-3.4.0/check_raise000077500000000000000000000044621415601150500174570ustar00rootroot00000000000000#!/bin/bash # Simple sanity checking of documentation of exceptions. # Usage: go to src/ and run ../check_raise header() { info=$1 shift result=$(mktemp) $* >$result cw=$(wc -w $result | cut -f1 -d\ ) if [ "$cw" -ne "0" ] then echo $info cat $result echo fi } setminus() { diff --new-line-format= --unchanged-line-format= $1 $2 } # Capitalized Raise should be rare header "Interesting places:" \ grep -n Raise *.ml *.mli | grep -v " *Raised" #header "Needs source style:" \ # grep -n "Invalid_argument[[:space:]]\"" *.mli # Modules known to have documentation of exceptions OK already_ok=$(mktemp) echo " batteriesHelp batStack batSplay batReturn batRef batRandom batQueue batDeque batConcurrent batCharParser " | sort >$already_ok use_raise=$(mktemp) doc_raise=$(mktemp) poor_doc_raise=$(mktemp) to_be_verified=$(mktemp) # Crude check for presence of exceptions in implementations and interfaces grep -n "\(raise\|invalid_arg\|failwith\)" *.ml | cut -f1 -d. | uniq | sort >$use_raise grep -n @raise *.mli | cut -f1 -d. | uniq | sort >$doc_raise grep -ni raise *.mli | cut -f1 -d. | uniq | sort >$poor_doc_raise setminus $use_raise $already_ok >$to_be_verified suspicious=$(mktemp) setminus $to_be_verified $doc_raise >$suspicious need_doc=$(mktemp) setminus $suspicious $poor_doc_raise >$need_doc header "Documentation of the following modules mentions exceptions and awaits formal @raise clauses:" \ setminus $suspicious $need_doc header "The following modules need raised exceptions to be documented (quite likely):" \ cat $need_doc # A policy: don't expose string arguments of standard exceptions header "String arguments nobody should rely upon:" \ grep -n "Invalid_argument[[:space:]]\"" *.mli header "String arguments nobody should rely upon:" \ grep -n "Failure[[:space:]]\"" *.mli # Look for mistakes header "@raises instead of @raise:" \ grep -n @raises *.ml *.mli header "Square brackets that harm ocamldoc:" \ grep -n "@raise[[:space:]]\[" *.ml *.mli header Typos: \ grep -n "Invalid_arg[[:space:]]" `find . -type f -not -name batDynArray\*` header Typos: \ grep -n Invald_argument *.ml *.mli header "consisting in => consisting of" grep -n "consisting in" *.ml *.mli header "@since NEXT_RELEASE should be filled before release" grep "@since [^0123456789]" *.ml *.mli batteries-included-3.4.0/dune000066400000000000000000000002771415601150500161470ustar00rootroot00000000000000(rule (target META) (deps %{project_root}/build/mkconf.exe %{project_root}/_oasis META.in) (action (run %{project_root}/build/mkconf.exe %{project_root}/_oasis META.in %{target}))) batteries-included-3.4.0/dune-project000066400000000000000000000002101415601150500175760ustar00rootroot00000000000000(lang dune 2.7) (name batteries) (version NEXT_RELEASE) (allow_approximate_merlin) ; dune requires this due to the use of prefilter.exebatteries-included-3.4.0/examples/000077500000000000000000000000001415601150500171015ustar00rootroot00000000000000batteries-included-3.4.0/examples/README000066400000000000000000000012121415601150500177550ustar00rootroot00000000000000A few examples of short programs written using OCaml Batteries Included. Directory tools/ contains small tools. Directory snippets/ contains random code extracts. Directory euler/ contains solution programs to varous eulerproject.com puzzles Directory pleac/ contains the start of a PLEAC for batteries To build all these programs, install batteries and run make from each directory. If this doesn't work, steal the makefile, _tags and myocamlbuild from another example directory, make them work for the files in the new directory and send us the patch. :) Extra points for implementing a toplevel `make examples` that makes the examples. batteries-included-3.4.0/examples/_tags000066400000000000000000000000651415601150500201220ustar00rootroot00000000000000 : pkg_netstring : thread batteries-included-3.4.0/examples/benchmark/000077500000000000000000000000001415601150500210335ustar00rootroot00000000000000batteries-included-3.4.0/examples/benchmark/Makefile000066400000000000000000000033761415601150500225040ustar00rootroot00000000000000TESTS:=nth map folr map2 append flatten filter1 filter2 mapx folrx OPTS:=--max-i 10_000_000 all: t_enum.byte t_enum.byte t_enum.native: t_enum.ml ocamlbuild t_enum.byte t_enum.native pngs: $(addsuffix .png, $(TESTS)) t_list.byte t_list.native: t_list.ml ocamlbuild t_list.byte t_list.native %.gallium_byte: t_list.byte #The following doesn't succeed for large I -- not tail-recursive - ./t_list.byte $(OPTS) -g $(basename $@) > $@ %.extlib_byte: t_list.byte ./t_list.byte $(OPTS) -e $(basename $@) > $@ %.blue_byte: t_list.byte ./t_list.byte $(OPTS) -b $(basename $@) > $@ %.core_byte: t_list.byte ./t_list.byte $(OPTS) -c $(basename $@) > $@ %.gallium_native: t_list.native #The following doesn't succeed for large I -- not tail-recursive - ./t_list.native $(OPTS) -g $(basename $@) > $@ %.extlib_native: t_list.native ./t_list.native $(OPTS) -e $(basename $@) > $@ %.blue_native: t_list.native ./t_list.native $(OPTS) -b $(basename $@) > $@ %.core_native: t_list.native ./t_list.native $(OPTS) -c $(basename $@) > $@ %.png: %.gallium_byte %.extlib_byte %.blue_byte %.core_byte %.gallium_native %.extlib_native %.blue_native %.core_native TEST=$(basename $@) echo "set logscale x; set logscale y; set terminal png; set xlabel \"List Length\"; set ylabel \"List-operations per second\"; set output \"$@\"; plot \"$(basename $@).gallium_byte\" w lp, \"$(basename $@).extlib_byte\" w lp, \"$(basename $@).blue_byte\" w lp, \"$(basename $@).core_byte\" w lp, \"$(basename $@).gallium_native\" w lp, \"$(basename $@).extlib_native\" w lp, \"$(basename $@).blue_native\" w lp, \"$(basename $@).core_native\" w lp" | gnuplot t_byte: $(addsuffix .gallium_byte, $(TESTS)) $(addsuffix .extlib_byte, $(TESTS)) clean: ocamlbuild -clean - rm *.*_byte *.*_native - rm *.pngbatteries-included-3.4.0/examples/benchmark/_tags000066400000000000000000000002131415601150500220470ustar00rootroot00000000000000: pkg_bitstring : pkg_batteries,pkg_core,debug,pkg_threads,pkg_benchmark : pkg_batteries,pkg_core,pkg_threads batteries-included-3.4.0/examples/benchmark/arg2.ml000066400000000000000000000260301415601150500222210ustar00rootroot00000000000000(* O'Caml enhanced command line argument handling module *) (* by Travis Bemann and Eric Norige *) (* *) (* This program is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Lesser General Public *) (* License as published by the Free Software Foundation; either *) (* version 2 of the License, or (at your option) any later version. *) (* *) (* This program is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) type spec = Unit of (unit -> unit) (* Call the function with unit argument *) | Set of bool ref (* Set the reference to true *) | Clear of bool ref (* Set the reference to false *) | String of (string -> unit) (* Call the function with a string argument *) | Int of (int -> unit) (* Call the function with an int argument *) | Float of (float -> unit) (* Call the function with a float argument *) | String_var of string ref (* Set the reference to the string argument *) | Int_var of int ref (* Set the reference to the int argument *) | Float_var of float ref (* Set the reference to the float argument *) | Rest of (string -> unit);; (* Stop interpreting keywords and call the function with each remaining argument *) type switch = Char of char (* Character switch *) | Char_arg of char * string (* Character switch with argument name *) | Char_extra of char * string (* Character switch with extra non-simple argument information, * usually final argument list information *) | Name of string (* Name switch *) | Name_arg of string * string (* Name switch with argument name *) | Name_extra of string * string (* Name switch with extra non-simple argument information, * usually final argument list information *) | Both of char * string (* Both character and name switch *) | Both_arg of char * string * string (* Both character and name switch with argument name *) | Both_extra of char * string * string;; (* Both character and name switch with extra non-simple argument * information, usually final argument list information *) exception Bad of string;; exception Usage;; exception Parse_halt;; let descr_col = 29;; (* Column (with first column being zero) where description begins; if the switch information extends to or beyond this column, then the description is pushed to the next line *) let max_col = 79;; let switch_indent = 2;; (* Number of columns to indent switch information by *) let usage_head = "Usage: ";; let switch_format switch = match switch with Char ch -> Printf.sprintf "-%c" ch | Char_arg (ch, arg) -> Printf.sprintf "-%c %s" ch arg | Char_extra (ch, extra) -> Printf.sprintf "-%c %s" ch extra | Name name -> Printf.sprintf " --%s" name | Name_arg (name, arg) -> Printf.sprintf " --%s=%s" name arg | Name_extra (name, extra) -> Printf.sprintf " --%s %s" name extra | Both (ch, name) -> Printf.sprintf "-%c, --%s" ch name | Both_arg (ch, name, arg) -> Printf.sprintf "-%c %s, --%s=%s" ch arg name arg | Both_extra (ch, name, extra) -> Printf.sprintf "-%c, --%s %s" ch name extra;; let whitespace chars = String.make chars ' ';; let usage_indent_str = whitespace (String.length usage_head);; let switch_indent_str = whitespace switch_indent;; let descr_indent_str = whitespace descr_col;; let word_break str off_start len_start = let rec step off len space_off = if (len > 0) && (off < (String.length str)) then let ch = String.get str off in match ch with ' ' | '\t' | '\n' | '\r' -> step (off + 1) (len - 1) off | _ -> step (off + 1) (len - 1) space_off else if (off_start + len_start) >= (String.length str) then String.sub str off_start ((String.length str) - off_start), String.length str else if off_start <> space_off then String.sub str off_start (space_off - off_start), (space_off + 1) else String.sub str off_start len_start, (off_start + len_start) in step off_start len_start off_start;; let descr_format descr = let buf = Buffer.create (String.length descr) and len = String.length descr and line_len = max_col - descr_col in let rec step off = if (len - off) <= line_len then begin Buffer.add_string buf (String.sub descr off ((String.length descr) - off)); Buffer.contents buf end else let sub, off_next = word_break descr off line_len in Buffer.add_string buf sub; if off_next = (String.length descr) then Buffer.contents buf else begin Printf.bprintf buf "\n%s" descr_indent_str; step off_next end in step 0;; let usage_format usage = let buf = Buffer.create (String.length usage) and len = String.length usage and line_len = max_col - (String.length usage_head) in let rec step off = if (len - off) <= line_len then begin Buffer.add_string buf (String.sub usage off ((String.length usage) - off)); Buffer.contents buf end else let sub, off_next = word_break usage off line_len in Buffer.add_string buf sub; if off_next = (String.length usage) then Buffer.contents buf else begin Printf.bprintf buf "\n%s" usage_indent_str; step off_next end in step 0;; let keyword_char keywords char = let matches keyword = let switch, _, _, _ = keyword in match switch with Char sw_char | Char_arg (sw_char, _) | Char_extra (sw_char, _) | Both (sw_char, _) | Both_arg (sw_char, _, _) | Both_extra (sw_char, _, _) -> char = sw_char | _ -> false in match List.filter matches keywords with keyword :: _ -> keyword | [] -> raise Not_found;; let keyword_name keywords name = let matches keyword = let switch, _, _, _ = keyword in match switch with Name sw_name | Name_arg (sw_name, _) | Name_extra (sw_name, _) | Both (_, sw_name) | Both_arg (_, sw_name, _) | Both_extra (_, sw_name,_) -> name = sw_name | _ -> false in match List.filter matches keywords with keyword :: _ -> keyword | [] -> raise Not_found;; let usage_raise () = raise Usage;; let help_add keywords = try let _ = keyword_name keywords "help" in keywords with Not_found -> keywords @ [Name "help", [Unit usage_raise], [], "Display this help and exit"];; let usage ~keywords ~usage ~descr ~notes = let keywords = help_add keywords in Printf.printf "%s%s\n%s\n\n" usage_head (usage_format usage) descr; let print_switch keyword = let switch, _, _, descr = keyword in let switch_sh = switch_format switch in if (switch_indent + (String.length switch_sh)) < (descr_col - 1) then Printf.printf "%s%s%s%s\n" switch_indent_str switch_sh (whitespace (descr_col - ((String.length switch_sh) + switch_indent))) (descr_format descr) else Printf.printf "%s%s\n%s%s\n" switch_indent_str switch_sh descr_indent_str (descr_format descr) in List.iter print_switch keywords; print_newline (); if notes <> "" then if (String.get notes ((String.length notes) - 1)) <> '\n' then print_endline notes else print_string notes else ();; (* here starts the code written by eric *) type handler = Required of spec | Optional of spec * (unit -> unit);; type token = Argument of string | Long_switch of string | Short_switch_list of char list | Long_switch_with_arg of string * string let tokenize raw = try match (raw.[0], raw.[1]) with '-', '-' -> (* A long command *) begin try let split = String.index raw '=' in let name = String.sub raw 2 (split - 2) and data = String.sub raw (split + 1) ((String.length raw) - split-1) in Long_switch_with_arg (name, data) with Not_found -> Long_switch (String.sub raw 2 ((String.length raw) - 2)) end | '-', _ -> (* a sequence of short commands *) let char_list = ref [] in for i = 1 to (String.length raw) - 1 do char_list := raw.[i] :: !char_list done; Short_switch_list !char_list | _ -> Argument raw (* an argument to a command *) with Invalid_argument _ -> Argument raw let qflush hq = let noarg = function | Required (Unit uh) -> uh () | Required _ -> raise (Bad "no data left for required arguments") | Optional (_,unitfun) -> unitfun () in Queue.iter noarg hq; Queue.clear hq let parse ~keywords ~others ~usage:args ~descr ~notes = let keywords = help_add keywords in let handler_queue = Queue.create () and extra_arg_handler = ref others in let enqueue_require = function | Set ref -> ref := true | Clear ref -> ref := false | Rest sh -> extra_arg_handler := sh | h -> Queue.add (Required h) handler_queue and enqueue_option = function | (Set _,_) -> raise (Bad "Set arguments can't be optional") | (Clear _,_) -> raise (Bad "Clear options can't be optional") | (Rest sh,_) -> extra_arg_handler := sh | (s,u) -> Queue.add (Optional (s,u)) handler_queue in let push_char_handlers c = qflush handler_queue; try let (_, reqh, opth, _) = keyword_char keywords c in List.iter enqueue_require reqh; List.iter enqueue_option opth with Not_found -> raise (Bad (Printf.sprintf "char argument not found: %c" c)) and push_long_handlers name = qflush handler_queue; try let (_, reqh, opth, _) = keyword_name keywords name in List.iter enqueue_require reqh; List.iter enqueue_option opth with Not_found -> raise (Bad ("argument not found:" ^ name)) in let rec handle arg = try let handler = match Queue.take handler_queue with Required h -> h | Optional (h,_) -> h in match handler with String sh -> sh arg | Int ih -> ih (int_of_string arg) | Float fh -> fh (float_of_string arg) | String_var svh -> svh := arg | Int_var ivh -> ivh := (int_of_string arg) | Float_var fvh -> fvh := (float_of_string arg) | Unit uh -> uh (); handle arg | _ -> raise (Bad "Ran into bad argument handler") with Queue.Empty -> !extra_arg_handler arg | Failure x -> raise (Bad ("Failed converting: "^x)) in let act_on_arg arg = match tokenize arg with Long_switch name -> push_long_handlers name | Short_switch_list short_list -> List.iter push_char_handlers short_list | Argument arg -> handle arg | Long_switch_with_arg (name, arg) -> push_long_handlers name; handle arg in try let argv = Array.sub Sys.argv 1 ((Array.length Sys.argv) - 1) in Array.iter act_on_arg argv; qflush handler_queue with Bad msg -> usage keywords args descr notes; print_endline msg; raise Parse_halt | Usage -> usage keywords args descr notes; exit 0;; batteries-included-3.4.0/examples/benchmark/myocamlbuild.ml000066400000000000000000000167201415601150500240540ustar00rootroot00000000000000open Ocamlbuild_plugin open Command (* no longer needed for OCaml >= 3.10.2 *) (** Overview of tags: - [pkg_batteries] to use Batteries as a library, without syntax extensions - [use_batteries] and [use_batteries_r] to use both Batteries and all the non-destructive syntax extensions - [pkg_sexplib.syntax] with [syntax_camlp4o] or [syntax_camlp4r] for sexplib *) (** {1 OCamlFind} *) let run_and_read = Ocamlbuild_pack.My_unix.run_and_read let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings module OCamlFind = struct (* this lists all supported packages *) let find_packages () = blank_sep_strings & Lexing.from_string & run_and_read "ocamlfind list | cut -d' ' -f1" (* this is supposed to list available syntaxes, but I don't know how to do it. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] (* ocamlfind command *) let ocamlfind x = S[A"ocamlfind"; x] let before_options () = (* by using Before_options one let command line options have an higher priority *) (* on the contrary using After_options will guarantee to have the higher priority *) (* override default commands by ocamlfind ones *) Options.ocamlc := ocamlfind & A"ocamlc"; Options.ocamlopt := ocamlfind & A"ocamlopt"; Options.ocamldep := ocamlfind & A"ocamldep"; Options.ocamldoc := ocamlfind & A"ocamldoc"; Options.ocamlmktop := ocamlfind & A"ocamlmktop" let get_ocamldoc_directory () = let ocamldoc_directory = run_and_read "ocamlfind ocamldoc -customdir" in let length = String.length ocamldoc_directory in assert (length != 0); let char = ocamldoc_directory.[length - 1] in if (char = '\n') || (char = '\r') then String.sub ocamldoc_directory 0 (length - 1) else ocamldoc_directory let after_rules () = (* When one link an OCaml library/binary/package, one should use -linkpkg *) flag ["ocaml"; "byte"; "link"; "program"] & A"-linkpkg"; flag ["ocaml"; "native"; "link"; "program"] & A"-linkpkg"; flag ["ocaml"; "native"; "link"; "toplevel"] & A"-linkpkg"; (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) List.iter begin fun pkg -> flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; end (find_packages ()); (* Like -package but for extensions syntax. Morover -syntax is useless * when linking. *) List.iter begin fun syntax -> flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; end (find_syntaxes ()); (* The default "thread" tag is not compatible with ocamlfind. Indeed, the default rules add the "threads.cma" or "threads.cmxa" options when using this tag. When using the "-linkpkg" option with ocamlfind, this module will then be added twice on the command line. To solve this, one approach is to add the "-thread" option when using the "threads" package using the previous plugin. *) flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); end (** {1 OCaml Batteries Included} *) module Batteries = struct let before_options () = () let after_rules () = flag ["ocaml"; "link"; "byte"; "use_ocamldoc_info"] (S[A "-I"; A "+ocamldoc"; A "odoc_info.cma"]); flag ["ocaml"; "link"; "native"; "use_ocamldoc_info"] (S[A "-I"; A "+ocamldoc"(*; A "odoc_info.cmxa"*)]); flag ["ocaml"; "docfile"; "use_ocamldoc_info"] (S[A "-I"; A "+ocamldoc"]); flag ["ocaml"; "docdir"; "use_ocamldoc_info"] (S[A "-I"; A "+ocamldoc"]); flag ["ocaml"; "doc"; "use_ocamldoc_info"] (S[A "-I"; A "+ocamldoc"]); (*The command-line for [use_batteries] and [use_batteries_r]*) let cl_use_boilerplate = [A "-package"; A "batteries"] and cl_use_batteries = [A "-package"; A "batteries"] and cl_use_batteries_o = [] (*[cl_use_batteries_o]: extensions which only make sense in original syntax*) and cl_camlp4o = [A"-syntax"; A "camlp4o"] and cl_camlp4r = [A"-syntax"; A "camlp4r"] in let cl_boilerplate_original = cl_use_boilerplate @ cl_camlp4o and cl_boilerplate_revised = cl_use_boilerplate @ cl_camlp4r and cl_batteries_original = cl_use_batteries @ cl_use_batteries_o @ cl_camlp4o and cl_batteries_revised = cl_use_batteries @ cl_camlp4r in (** Tag [use_boilerplate] provides boilerplate syntax extensions, in original syntax*) flag ["ocaml"; "compile"; "use_boilerplate"] & S cl_boilerplate_original ; flag ["ocaml"; "ocamldep"; "use_boilerplate"] & S cl_boilerplate_original ; flag ["ocaml"; "doc"; "use_boilerplate"] & S cl_boilerplate_original ; flag ["ocaml"; "link"; "use_boilerplate"] & S cl_boilerplate_original ; (** Tag [use_boilerplate_r] provides boilerplate syntax extensions, in original syntax*) flag ["ocaml"; "compile"; "use_boilerplate_r"] & S cl_boilerplate_revised ; flag ["ocaml"; "ocamldep"; "use_boilerplate_r"] & S cl_boilerplate_revised ; flag ["ocaml"; "doc"; "use_boilerplate_r"] & S cl_boilerplate_revised ; flag ["ocaml"; "link"; "use_boilerplate_r"] & S cl_boilerplate_revised ; (** Tag [use_batteries] provides both package [batteries] and all syntax extensions, in original syntax. *) flag ["ocaml"; "compile"; "use_batteries"] & S cl_batteries_original ; flag ["ocaml"; "ocamldep"; "use_batteries"] & S cl_batteries_original ; flag ["ocaml"; "doc"; "use_batteries"] & S cl_batteries_original ; flag ["ocaml"; "link"; "use_batteries"] & S cl_batteries_original ; (** Tag [use_batteries_r] provides both package [batteries] and all syntax extensions, in revised syntax. *) flag ["ocaml"; "compile"; "use_batteries_r"] & S cl_batteries_revised; flag ["ocaml"; "ocamldep"; "use_batteries_r"] & S cl_batteries_revised; flag ["ocaml"; "doc"; "use_batteries_r"] & S cl_batteries_revised; flag ["ocaml"; "link"; "use_batteries_r"] & S cl_batteries_revised (* flag ["ocaml"; "compile"; "use_batteries"] & S[A "-verbose"; A"-package"; A "batteries.syntax.full"; A"-syntax"; A "batteries.syntax.full"]; flag ["ocaml"; "ocamldep"; "use_batteries"] & S[A "-verbose"; A"-package"; A "batteries.syntax.full"; A"-syntax"; A "batteries.syntax.full"]; flag ["ocaml"; "doc"; "use_batteries"] & S[A "-verbose"; A"-package"; A "batteries.syntax.full"; A"-syntax"; A "batteries.syntax.full"]; flag ["ocaml"; "link"; "use_batteries"] & S[A "-verbose"; A"-package"; A "batteries.syntax.full"; A"-syntax"; A "batteries.syntax.full"];*) end let _ = dispatch begin function | Before_options -> OCamlFind.before_options (); Batteries.before_options () | After_rules -> OCamlFind.after_rules (); Batteries.after_rules () | _ -> () end (** which ocamlrun -> header print_backtrace -> ajouter "-b" après le header **) batteries-included-3.4.0/examples/benchmark/run_tests.sh000077500000000000000000000010761415601150500234240ustar00rootroot00000000000000#!/bin/sh ocamlbuild t_list.byte TESTS="nth map mapx folr folrx map2" for a in byte do for b in $TESTS do # echo -n ${b}_g.$a, ./t_list.$a -s 200 ${b}_g | tee data/${b}_gallium.$a # echo -n ${b}_e.$a, ./t_list.$a -s 200 ${b}_e | tee data/${b}_extlib.$a done done cd data for a in byte do for b in $TESTS do G_PRE="set logscale x; set logscale y; set terminal png; set xlabel \"List Length\"; set ylabel \"actions per second\";" echo "$G_PRE set output \"$b.$a.png\"; plot \"${b}_extlib.$a\" w lp, \"${b}_gallium.$a\" w lp" | gnuplot done donebatteries-included-3.4.0/examples/benchmark/t_enum.ml000066400000000000000000000176611415601150500226670ustar00rootroot00000000000000open Batteries open Printf module ISet = Set.Make(struct type t = int let compare (x : int) y = if x > y then 1 else if x < y then -1 else 0 end) module IMap = Map.IntMap module G = struct module SetMap = struct type t = ISet.t IMap.t let find i t = try IMap.find i t with Not_found -> ISet.empty let add i j t = IMap.add i (ISet.add j (find i t)) t let del i j t = let s = ISet.remove j (find i t) in if ISet.is_empty s then IMap.remove i t else IMap.add i s t let del_check i j t = let s = ISet.remove j (find i t) in if ISet.is_empty s then raise Not_found else IMap.add i s t let empty = IMap.empty end type t = { i: SetMap.t; o: SetMap.t } let empty = { i = SetMap.empty; o = SetMap.empty } let nodes g = IMap.keys g.o let nodes_in g = IMap.keys g.i let list_of_iset s = ISet.fold (fun i a -> i :: a) s [] let nbrs_set g n = SetMap.find n g.o let in_nbrs_set g n = SetMap.find n g.i let fold_out g f v = IMap.fold f g.o v let fold_in g f v = IMap.fold f g.i v let get g i j = SetMap.find i g.o |> ISet.mem j let print_set i s = printf "%d) " i; ISet.print ~first:"{" ~sep:" " ~last:"}\n" Int.print stdout s let print g = printf "Out:\n"; IMap.iter print_set g.o; printf "In:\n"; IMap.iter print_set g.i let is_empty g = IMap.is_empty g.i let choose g = let (x,_) = IMap.choose g.o in x let add g x y = {o = SetMap.add x y g.o; i = SetMap.add y x g.i} let add_undir g x y = add (add g y x) x y let remove_out_ok g i = let nbrs = SetMap.find i g.o in { o = IMap.remove i g.o; i = ISet.fold (fun j a -> SetMap.del j i a) nbrs g.i } end let reduce_all g = let reduce_i i iset g = (* TODO: rewrite without enum *) let doms = ISet.enum iset |> Enum.map (G.in_nbrs_set g) in let rec loop acc = if ISet.is_empty acc then g else match Enum.get doms with None -> G.remove_out_ok g i | Some ns -> loop (ISet.inter acc ns) in match Enum.get doms with None -> assert false | Some ns -> loop (ISet.remove i ns) in G.fold_out g reduce_i g let data = "100 900 3 0 5 4 6 3 7 1 8 0 8 4 8 5 9 6 10 5 11 2 11 4 11 6 11 10 12 3 12 6 12 10 13 5 13 7 13 8 13 12 14 6 14 12 14 13 15 3 15 8 15 9 15 11 16 1 16 2 16 3 17 1 17 6 17 16 18 0 18 1 18 5 19 14 20 2 20 6 20 9 20 10 20 16 20 17 21 4 21 6 21 11 21 17 23 8 23 11 23 16 23 20 24 2 24 20 25 5 25 6 25 18 26 0 26 7 26 10 26 11 26 12 26 18 26 25 27 0 27 3 27 4 27 15 27 24 27 26 28 0 28 11 28 17 28 19 28 21 29 1 29 7 29 17 29 24 30 5 30 7 30 16 30 20 30 23 30 28 30 29 31 2 31 4 31 12 31 17 31 22 31 27 32 5 32 8 32 22 32 29 33 2 33 10 33 16 33 22 33 23 33 25 34 3 34 10 34 11 34 17 34 18 34 20 34 28 34 31 35 1 35 17 35 19 35 29 35 30 36 0 36 15 36 24 36 25 36 26 36 27 36 33 36 35 37 3 37 8 37 14 37 16 37 18 37 28 37 30 37 33 38 5 38 7 38 18 38 31 39 10 39 12 39 14 39 18 39 30 39 34 39 36 40 2 40 12 40 22 40 30 41 13 41 26 41 27 41 29 42 2 42 3 42 4 42 7 42 12 42 15 42 24 42 36 42 37 42 38 43 9 43 22 43 33 43 39 43 42 44 2 44 7 44 11 44 13 44 16 44 17 44 22 44 24 44 29 44 34 44 37 45 0 45 1 45 4 45 7 45 9 45 10 45 11 45 27 45 28 45 37 46 6 46 7 46 8 46 13 46 18 46 19 46 21 46 22 46 31 46 40 46 41 46 43 47 3 47 9 47 10 47 11 47 23 47 29 47 39 48 4 48 19 48 20 48 23 48 25 48 29 48 32 48 33 48 45 48 47 49 4 49 13 49 14 49 25 49 31 49 32 49 44 49 46 50 2 50 8 50 21 50 22 50 23 50 29 50 43 50 45 50 47 50 48 51 5 51 9 51 10 51 11 51 14 51 18 51 22 51 24 51 25 51 27 51 28 51 34 51 36 51 37 51 40 51 46 52 11 52 14 52 22 52 32 52 41 52 45 52 47 53 4 53 6 53 13 53 21 53 22 53 26 53 32 53 34 53 37 53 39 53 45 54 11 54 15 54 17 54 19 54 22 54 30 54 36 54 41 54 43 54 44 54 51 55 13 55 23 55 30 55 32 55 46 56 1 56 6 56 12 56 14 56 16 56 17 56 22 56 38 56 42 56 49 57 5 57 9 57 10 57 11 57 12 57 16 57 24 57 38 57 41 57 43 57 48 58 1 58 7 58 11 58 13 58 21 58 23 58 33 58 34 58 39 58 40 58 42 58 45 58 48 58 54 58 55 59 9 59 16 59 43 59 46 59 49 59 53 60 10 60 17 60 20 60 25 60 32 60 39 60 41 60 42 60 43 60 49 61 5 61 21 61 27 61 29 61 44 61 45 61 48 61 49 61 51 61 55 61 56 61 57 61 60 62 3 62 4 62 14 62 21 62 29 62 38 62 47 62 52 63 8 63 16 63 20 63 22 63 23 63 25 63 26 63 29 63 30 63 31 63 41 63 47 63 53 64 16 64 19 64 20 64 24 64 28 64 49 64 52 64 55 64 61 65 2 65 10 65 16 65 18 65 21 65 22 65 23 65 25 65 26 65 29 65 33 65 36 65 55 65 60 65 63 66 0 66 12 66 32 66 45 67 12 67 16 67 17 67 20 67 22 67 23 67 27 67 31 67 38 67 44 67 47 67 56 67 60 67 62 67 64 68 14 68 18 68 19 68 21 68 29 68 30 68 34 68 44 68 49 68 52 68 63 68 64 69 0 69 7 69 9 69 13 69 14 69 16 69 17 69 21 69 32 69 34 69 41 69 43 69 54 69 61 69 62 69 64 70 7 70 18 70 33 70 46 70 47 70 48 70 61 70 62 71 4 71 18 71 21 71 29 71 44 71 45 71 50 71 51 71 58 71 63 71 65 72 3 72 18 72 27 72 28 72 31 72 32 72 39 72 41 72 43 72 44 72 66 73 12 73 19 73 24 73 29 73 31 73 32 73 36 73 40 73 45 73 51 73 55 73 58 73 64 73 71 74 5 74 6 74 8 74 12 74 15 74 31 74 36 74 39 74 41 74 42 74 43 74 53 74 58 74 64 75 2 75 4 75 6 75 10 75 17 75 26 75 30 75 34 75 35 75 37 75 59 75 65 75 70 75 72 76 8 76 10 76 11 76 12 76 20 76 34 76 46 76 49 76 51 76 52 76 53 76 55 76 58 76 67 76 69 76 70 76 72 77 17 77 24 77 32 77 35 77 39 77 43 77 46 77 48 77 51 77 52 77 54 77 55 77 75 78 4 78 5 78 9 78 12 78 20 78 21 78 23 78 26 78 27 78 48 78 53 78 55 78 60 78 61 78 64 78 70 79 2 79 3 79 9 79 32 79 35 79 37 79 40 79 44 79 48 79 50 79 52 79 53 79 54 79 65 79 66 79 68 79 73 80 10 80 14 80 23 80 30 80 44 80 49 80 53 80 66 80 70 80 73 81 0 81 4 81 10 81 12 81 14 81 24 81 27 81 33 81 39 81 47 81 64 81 69 81 73 82 2 82 6 82 10 82 11 82 13 82 36 82 38 82 40 82 42 82 51 82 52 82 53 82 69 82 70 82 74 83 10 83 15 83 20 83 26 83 28 83 43 83 48 83 50 83 53 83 57 83 64 83 65 83 71 84 5 84 16 84 25 84 29 84 34 84 37 84 41 84 42 84 43 84 51 84 54 84 57 84 58 84 64 84 67 84 71 84 73 84 77 84 79 84 82 85 7 85 11 85 15 85 17 85 22 85 23 85 32 85 34 85 41 85 42 85 43 85 54 85 61 85 66 85 74 85 81 86 10 86 13 86 23 86 24 86 36 86 39 86 44 86 51 86 58 86 60 86 61 86 64 86 65 86 67 86 70 86 75 87 15 87 19 87 26 87 30 87 33 87 38 87 45 87 59 87 71 87 72 87 73 87 74 87 81 87 82 87 85 88 10 88 20 88 23 88 24 88 27 88 29 88 46 88 62 88 64 88 76 88 77 88 78 88 86 89 2 89 8 89 10 89 17 89 24 89 25 89 33 89 35 89 37 89 42 89 50 89 51 89 53 89 61 89 67 89 74 89 76 89 77 89 83 89 87 90 10 90 11 90 21 90 25 90 28 90 37 90 50 90 53 90 56 90 59 90 61 90 62 90 63 90 66 90 74 90 83 90 87 91 4 91 6 91 8 91 9 91 10 91 19 91 21 91 23 91 29 91 40 91 42 91 63 91 68 91 72 91 78 91 85 92 17 92 19 92 30 92 32 92 36 92 38 92 58 92 62 92 65 93 0 93 1 93 5 93 14 93 16 93 24 93 25 93 37 93 42 93 47 93 56 93 63 93 65 93 71 93 78 93 85 93 86 93 92 94 9 94 10 94 12 94 28 94 30 94 37 94 41 94 48 94 55 94 57 94 61 94 64 94 65 94 66 94 67 94 73 94 77 94 83 95 0 95 6 95 8 95 10 95 13 95 14 95 15 95 16 95 31 95 36 95 39 95 55 95 56 95 69 95 70 95 76 95 77 95 86 95 91 96 1 96 8 96 16 96 19 96 33 96 34 96 45 96 57 96 66 96 76 96 81 96 88 97 6 97 10 97 17 97 32 97 38 97 40 97 43 97 51 97 52 97 54 97 60 97 62 97 64 97 66 97 68 97 70 97 77 97 79 97 83 97 88 97 91 98 2 98 5 98 13 98 14 98 23 98 27 98 28 98 32 98 33 98 36 98 42 98 46 98 49 98 50 98 51 98 56 98 57 98 60 98 62 98 75 98 78 98 79 98 80 98 81 98 83 98 84 98 90 98 92 99 1 99 2 99 6 99 9 99 16 99 22 99 23 99 33 99 41 99 45 99 49 99 71 99 75 99 85 99 86 99 91 99 97 " let () = let in_f = Scanf.Scanning.from_string data in let n = Scanf.bscanf in_f "%d " identity in let full_g = ref G.empty in (* read the input file and produce full_g *) let read_edges n = for i = 1 to n do Scanf.bscanf in_f "%d %d " (fun x y -> full_g := G.add_undir !full_g x y) done in Scanf.bscanf in_f "%d " read_edges; (* extend the graph with loops and reduce *) let dg = fold (fun g i -> G.add g i i) !full_g (0--(n-1)) in let t0 = Sys.time () in for i = 1 to 1000 do ignore (reduce_all dg); done; printf "Time taken: %.3fs\n" (Sys.time () -. t0) batteries-included-3.4.0/examples/benchmark/t_list.ml000066400000000000000000000201351415601150500226640ustar00rootroot00000000000000open Printf open Batteries exception Done_measuring (*****************************************) (* PROBABILITY DISTRIBUTIONS *) (*****************************************) let d_rand n_min n_max seed = Random.init seed; printf "#Random: S%d Min%d Max%d\n" seed n_min n_max; fun () -> n_min + Random.int (n_max-n_min) let d_count n_min n_max _ = printf "#Count: Min%d Max%d\n" n_min n_max; let next_int = let i = ref n_min in fun () -> let ret = !i in incr i; if !i >= n_max then i := n_min; ret in fun () -> next_int () (*****************************************) (* ONE SECOND TESTING *) (*****************************************) let count_f f time trials rand_list = let list = ref [] in let list_len = ref 0 in printf "#Len\tIterations\n%!"; list := rand_list 10 []; let test_n n = list := rand_list (n - !list_len) !list; list_len := n; let t0 = Sys.time() in ignore(f n !list); (* ignore the first run *) if Sys.time () -. t0 > 1. then raise Done_measuring; printf "%d\t%!" n; let t0 = Sys.time() in let t1 = t0 +. time in let count = ref (-1) in while Sys.time () < t1 do incr count; ignore(f n !list); done; printf "%d\n%!" !count; if !count < 2 then raise Done_measuring in List.iter test_n trials (*****************************************) (* TESTS *) (*****************************************) let rec count_fall acc = function 1 -> acc | n when n land 1 = 0 -> if acc > 10_000 then acc else count_fall (acc+1) (n / 2) | n -> if acc > 10_000 then acc else count_fall (acc+1) (n * 3 + 1) let acc_cf x a = a + (count_fall 0 x) let sumprod h1 h2 a = a + (h1 * h2) let nth_test = "Nth", fun f n l -> ignore (f l (n/2)) and map_test1 = "Map: *2", fun f n l -> ignore (f (( * )2) l) and map_test2 = "Map: /2 or *3+1", fun f n l -> ignore (f (count_fall 0) l) and fold_right_test1 = "Fold_right: sum", fun f n l -> ignore (f (+) l 0) and fold_right_test2 = "Fold_right: sum fall", fun f n l -> ignore (f acc_cf l 0) and fold_right2_test1 = "Fold_right2: sum prod", fun f n l -> ignore (f sumprod l l 0) and map2_test = "Map2: +", fun f n l -> ignore (f (+) l l) and append_test = "Append self", fun f n l -> ignore (f l l) and flatten_test = "Flatten three-copies", fun f n l -> ignore (f [l; l; l]) and filter_test1 = "Filter less_than 100", fun f n l -> ignore (f (fun n -> n < 100) l) and filter_test2 = "Filter greater-than 100", fun f n l -> ignore (f (fun n -> n > 100) l) (*****************************************) (* IMPLEMENTATIONS *) (*****************************************) let fold_right_max = 1000 let fold_right_chunk_size = 500 let fold_right3 f li init = let rec fold_chunk li = let (n, init) = jump 0 li in partial_fold init li n and jump n = function | [] -> (n, init) | _::tl when n < fold_right_chunk_size -> jump (n + 1) tl | li -> (n, fold_chunk li) and partial_fold partial_init li = function | 0 -> partial_init | n -> match li with | [] -> assert false | hd::tl -> f hd (partial_fold partial_init tl (n -1)) in let rec loop n = function | [] -> init | h :: t when n < fold_right_max -> f h (loop (n+1) t) | li -> fold_chunk li in loop 0 li let core_map f l = Legacy.List.rev (Legacy.List.rev_map f l) let core_fold_right f l a = Legacy.List.fold_left f a (Legacy.List.rev l) type impl_type = [`Gallium | `Extlib | `Core | `Bluestorm] let nth_impls = [`Gallium, Legacy.List.nth; `Extlib, List.nth; (* `Core, Core.Std.List.nth_exn*) ] and map_impls = [`Gallium, Legacy.List.map; `Extlib, List.map; `Core, core_map ] and fold_right_impls = [`Gallium, Legacy.List.fold_right; `Extlib, List.fold_right; `Bluestorm, fold_right3; `Core, core_fold_right] and map2_impls = [`Gallium, Legacy.List.map2; `Extlib, List.map2; `Core, (fun f l1 l2 -> Legacy.List.rev (Legacy.List.rev_map2 f l1 l2)) ] and fold_right2_impls = [`Gallium, Legacy.List.fold_right2; `Extlib, List.fold_right2 ] and append_impls = [`Gallium, Legacy.List.append; `Extlib, List.append] and flatten_impls = [`Gallium, Legacy.List.flatten; `Extlib, List.flatten] and remove_assoc_impls = [`Gallium, Legacy.List.remove_assoc; `Extlib, List.remove_assoc] and remove_assq_impls = [`Gallium, Legacy.List.remove_assq; `Extlib, List.remove_assq] and split_impls = [`Gallium, Legacy.List.split; `Extlib, List.split] and filter_impls = [`Gallium, Legacy.List.filter; `Extlib, List.filter] and find_all_impls = [`Gallium, Legacy.List.find_all; `Extlib, List.find_all] and partition_impls = [`Gallium, Legacy.List.partition; `Extlib, List.partition] (*****************************************) (* FRAMEWORK *) (*****************************************) let desc_to_str = function `Gallium -> "Gallium" | `Extlib -> "Extlib" | `Bluestorm -> "Bluestorm" | `Core -> "Core" let make_tests (t_desc,test) impls = List.map (fun (i_desc,f) -> i_desc, count_f (test f)) impls let tests = [ "nth", make_tests nth_test nth_impls; "map", make_tests map_test1 map_impls; "mapx", make_tests map_test2 map_impls; "folr", make_tests fold_right_test1 fold_right_impls; "folrx", make_tests fold_right_test2 fold_right_impls; "map2", make_tests map2_test map2_impls; (* has more complex performance characteristics than above *) "foldr2", make_tests fold_right2_test1 fold_right2_impls; "append", make_tests append_test append_impls; "flatten", make_tests flatten_test flatten_impls; "filter1", make_tests filter_test1 filter_impls; "filter2", make_tests filter_test2 filter_impls; ] (*****************************************) (* GLOBALS FOR ARGUMENT HANDLING *) (*****************************************) module Ref_list = RefList let seed = ref (-1) let time = ref 1. let todo = Ref_list.empty() (* list of string test names *) let distro = ref (d_rand 0 5000) let int1 = ref 0 and int2 = ref 0 let impls : impl_type Ref_list.t = Ref_list.empty () (* list of impl_type values *) let max_i = ref max_int open Arg2 (*****************************************) (* MAIN *) (*****************************************) let () = let set_f x = Ref_list.push todo x in let args = [ (Both ('s', "seed"), [Int_var seed], [], "Set random number seed"); (Both ('g', "gallium"), [Unit (fun () -> Ref_list.push impls `Gallium)], [], "Test Gallium's implementation"); (Both ('e', "extlib"), [Unit (fun () -> Ref_list.push impls `Extlib)], [], "Test Extlib's implementation"); (Both ('b', "bluestorm"), [Unit (fun () -> Ref_list.push impls `Bluestorm)], [], "Test Bluestorm's implementation"); (Both ('c', "core"), [Unit (fun () -> Ref_list.push impls `Core)], [], "Test Jane Street's implementation"); (Both ('t', "time"), [Float_var time], [], "Set test duration (float)"); (Both ('i', "max-i"), [Int_var max_i], [], "Maximum list length to test"); (Both_extra ('R',"rand","min max"), [Int_var int1; Int_var int2; Unit (fun () -> distro := (d_rand !int1 !int2))], [], "Set Distribution of list values to a random min-max distribution") ] and usage_info = "t_list [-s seed] [test_name]" and descr = "Test various list function implementations" and notes = "by Eric Norige" in Arg2.parse args set_f usage_info descr notes; if !seed = -1 then (Random.self_init (); seed := Random.bits ()); let trials = (* generate list of trial counts *) let dup_by n l = l @ (List.map (( * ) n) l) in [1; 2; 4; 7] |> dup_by 10 |> dup_by 100 |> dup_by 10000 |> List.filter (fun n -> n < !max_i) in let get_f test_name = (* get the test function by its name *) List.assoc test_name tests |> List.filter (fun (t, _) -> List.mem t (Ref_list.to_list impls)) in let do_test (t,test) = try let rand_f = !distro !seed in let rec rand_list n li = if n <= 0 then li else rand_list (n-1) ((rand_f ())::li) in test !time trials rand_list with Done_measuring -> () in todo |> Ref_list.to_list |> List.rev_map get_f |> List.flatten |> List.iter do_test batteries-included-3.4.0/examples/benchmark/t_pow.ml000066400000000000000000000020221415601150500225110ustar00rootroot00000000000000let generic_pow ~zero ~one ~div_two ~mod_two ~mul:( * ) = let rec pow a n = if n = zero then one else if n = one then a else let b = pow a (div_two n) in b * b * (if mod_two n = zero then one else a) in pow let n = int_of_string (Sys.argv.(1)) let bases = Array.init n (fun _ -> Random.bits ()) and exps = Array.init n (fun _ -> Random.bits ()) let pow1 = generic_pow ~zero:0 ~one:1 ~div_two:(fun n -> n/2) ~mod_two:(fun n -> n mod 2) ~mul:( * ) let pow2 = generic_pow ~zero:0 ~one:1 ~div_two:(fun n -> n asr 1) ~mod_two:(fun n -> n land 1) ~mul:( * ) let pow3 = let rec pow a n = if n = 0 then 0 else if n = 1 then a else let b = pow a (n asr 1) in b * b * (if n land 1 = 0 then 1 else a) in pow let time f = let t0 = Sys.time () in for i = 0 to n-1 do ignore (f bases.(i) exps.(i)) done; Sys.time () -. t0 let () = Printf.printf "Time pow1: %f\n" (time pow1); Printf.printf "Time pow2: %f\n" (time pow2); Printf.printf "Time pow3: %f\n" (time pow3) batteries-included-3.4.0/examples/benchmark/t_read.log000066400000000000000000000055611415601150500230030ustar00rootroot00000000000000Latencies for 30 iterations of "mmap_fn", "pread", "batio", "cdk_orig", "cdk2k", "cdk4k", "vbu1k", "vbu2k", "vbu4k", "vbp1k", "vbp2k", "vbp4k", "bitstring", "str_only": mmap_fn: 18.83 WALL (18.23 usr + 0.60 sys = 18.83 CPU) @ 1.59/s (n=30) pread: 23.47 WALL (18.78 usr + 4.69 sys = 23.47 CPU) @ 1.28/s (n=30) batio: 28.79 WALL (27.05 usr + 1.74 sys = 28.79 CPU) @ 1.04/s (n=30) cdk_orig: 27.61 WALL (25.00 usr + 2.61 sys = 27.61 CPU) @ 1.09/s (n=30) cdk2k: 29.25 WALL (26.34 usr + 2.90 sys = 29.24 CPU) @ 1.03/s (n=30) cdk4k: 27.29 WALL (25.38 usr + 1.90 sys = 27.28 CPU) @ 1.10/s (n=30) vbu1k: 28.93 WALL (26.49 usr + 2.42 sys = 28.91 CPU) @ 1.04/s (n=30) vbu2k: 27.78 WALL (25.79 usr + 1.98 sys = 27.77 CPU) @ 1.08/s (n=30) vbu4k: 28.18 WALL (26.55 usr + 1.63 sys = 28.18 CPU) @ 1.06/s (n=30) vbp1k: 30.82 WALL (27.97 usr + 2.84 sys = 30.81 CPU) @ 0.97/s (n=30) vbp2k: 29.05 WALL (26.71 usr + 2.33 sys = 29.04 CPU) @ 1.03/s (n=30) vbp4k: 28.31 WALL (26.63 usr + 1.68 sys = 28.31 CPU) @ 1.06/s (n=30) bitstring: 28.33 WALL (26.57 usr + 1.76 sys = 28.33 CPU) @ 1.06/s (n=30) str_only: 24.43 WALL (21.22 usr + 3.20 sys = 24.42 CPU) @ 1.23/s (n=30) Rate vbp1k cdk2k vbp2k vbu1k batio bitstring vbp4k vbu4k vbu2k cdk_orig cdk4k str_only pread mmap_fn vbp1k 0.974/s -- -5% -6% -6% -7% -8% -8% -9% -10% -10% -11% -21% -24% -39% cdk2k 1.03/s 5% -- -1% -1% -2% -3% -3% -4% -5% -6% -7% -16% -20% -36% vbp2k 1.03/s 6% 1% -- -0% -1% -2% -3% -3% -4% -5% -6% -16% -19% -35% vbu1k 1.04/s 7% 1% 0% -- -0% -2% -2% -3% -4% -4% -6% -16% -19% -35% batio 1.04/s 7% 2% 1% 0% -- -2% -2% -2% -4% -4% -5% -15% -18% -35% bitstring 1.06/s 9% 3% 3% 2% 2% -- -0% -1% -2% -3% -4% -14% -17% -34% vbp4k 1.06/s 9% 3% 3% 2% 2% 0% -- -0% -2% -2% -4% -14% -17% -33% vbu4k 1.06/s 9% 4% 3% 3% 2% 1% 0% -- -1% -2% -3% -13% -17% -33% vbu2k 1.08/s 11% 5% 5% 4% 4% 2% 2% 1% -- -1% -2% -12% -15% -32% cdk_orig 1.09/s 12% 6% 5% 5% 4% 3% 3% 2% 1% -- -1% -12% -15% -32% cdk4k 1.10/s 13% 7% 6% 6% 6% 4% 4% 3% 2% 1% -- -10% -14% -31% str_only 1.23/s 26% 20% 19% 18% 18% 16% 16% 15% 14% 13% 12% -- -4% -23% pread 1.28/s 31% 25% 24% 23% 23% 21% 21% 20% 18% 18% 16% 4% -- -20% mmap_fn 1.59/s 64% 55% 54% 54% 53% 50% 50% 50% 47% 47% 45% 30% 25% -- batteries-included-3.4.0/examples/benchmark/t_read.ml000066400000000000000000000073161415601150500226320ustar00rootroot00000000000000(* Requires batteries, benchmark, bitstring To compile: ocamlopt t_read_stub.c ocamlfind ocamlopt -linkpkg -thread -package batteries,threads,benchmark,bitstring t_read.ml -o t_read_stub.o t_read *) open Benchmark (**** THIS CODE UNDER GPL LICENSE FROM CDK/extlib ****) let resize s newlen = let len = String.length s in if len > newlen then String.sub s 0 newlen else let str = String.create newlen in String.blit s 0 str 0 len; str let cdk_read buf_size name = let chan = open_in name in let buf = String.create buf_size in let rec iter buf nb_read = let buf_size = String.length buf in let tmp = input chan buf nb_read (buf_size - nb_read) in if tmp = 0 then String.sub buf 0 nb_read else let nb_read = nb_read + tmp in let buf = if nb_read = buf_size then resize buf (2 * buf_size) else buf in iter buf nb_read in let buf = iter buf 0 in close_in chan; buf (**** END CDK/extlib code ****) let varbuf_unix tmpsize fn = let fd = Unix.openfile fn [Unix.O_RDONLY] 0o600 in let buf = Buffer.create tmpsize in let tmp = String.create tmpsize in let rec loop () = let n = Unix.read fd tmp 0 tmpsize in if n > 0 then ( Buffer.add_substring buf tmp 0 n; loop () ) in loop (); Buffer.contents buf let varbuf_perv tmpsize fn = let fd = open_in fn in let buf = Buffer.create tmpsize in let tmp = String.create tmpsize in let rec loop () = let n = input fd tmp 0 tmpsize in if n > 0 then ( Buffer.add_substring buf tmp 0 n; loop () ) in loop (); Buffer.contents buf let read_file_as_str fn = let ic = Pervasives.open_in_bin fn in let len = (Pervasives.in_channel_length ic) in let old_gc = Gc.get() in Gc.set {old_gc with Gc.space_overhead = 0}; let ret = String.create len in Gc.set old_gc; Pervasives.really_input ic ret 0 len; Pervasives.close_in ic; ret open Bigarray type bigstring_t = { bigarr : (char, int8_unsigned_elt, c_layout) Array1.t; data : string; length : int } let map_file fd ?pos ?(shared=false) len = let ba = Array1.map_file fd ?pos char c_layout shared len in let s = (Obj.magic (Obj.field (Obj.repr ba) 1) : string) in { bigarr = ba; data = s; length = Array1.dim ba } let mmap_fn fn = let fd = Unix.openfile fn [Unix.O_RDONLY] 0o600 in let len = (Unix.stat fn).Unix.st_size in (map_file fd len).bigarr type buffer = (char, int8_unsigned_elt, c_layout) Array1.t external pread : Unix.file_descr -> buffer -> int64 -> int = "caml_maid_pread" let pread_file fn = let fd = Unix.openfile fn [Unix.O_RDONLY] 0o600 in let len = (Unix.stat fn).Unix.st_size in let buf = Array1.create char c_layout len in ignore(pread fd buf 0L); buf open Batteries let batio_read fn = File.with_file_in fn BatIO.read_all let check str = String.iter ignore str let check_bs (str,_,_) = String.iter ignore str let check_ba (ba: buffer) = for i = 0 to Array1.dim ba - 1 do Array1.unsafe_get ba i |> ignore done let tests fn = [ "mmap_fn", mmap_fn |- check_ba, fn; "pread", pread_file |- check_ba, fn; "batio", batio_read |- check, fn; "cdk_orig", cdk_read 1024 |- check, fn; "cdk2k", cdk_read 2048 |- check, fn; "cdk4k", cdk_read 4096 |- check, fn; "vbu1k", varbuf_unix 1024 |- check, fn; "vbu2k", varbuf_unix 2048 |- check, fn; "vbu4k", varbuf_unix 4096 |- check, fn; "vbp1k", varbuf_perv 1024 |- check, fn; "vbp2k", varbuf_perv 2048 |- check, fn; "vbp4k", varbuf_perv 4096 |- check, fn; "bitstring", Bitstring.bitstring_of_file |- check_bs, fn; "str_only", read_file_as_str |- check, fn; ] let () = let fn = Sys.argv.(1) in latencyN 30L (tests fn) |> tabulate batteries-included-3.4.0/examples/benchmark/t_read_stub.c000066400000000000000000000021141415601150500234700ustar00rootroot00000000000000#define _XOPEN_SOURCE 500 #include #include #include #include #include #include #include #include #include #include #include #include #include #include CAMLprim value caml_maid_pread(value ml_fd, value ml_buffer, value ml_off) { CAMLparam3(ml_fd, ml_buffer, ml_off); // fprintf(stderr, "### caml_maid_pread()\n"); int fd = Int_val(ml_fd); struct caml_ba_array *array = Caml_ba_array_val(ml_buffer); size_t len = caml_ba_byte_size(array); uint8_t *buf = Caml_ba_data_val(ml_buffer); off_t off = Int64_val(ml_off); ssize_t res = pread(fd, buf, len, off); // FIXME: throw exception on error? // Return -1 on EOF and 0 if there is nothing to read if (res == -1 && (errno == EAGAIN || errno == EWOULDBLOCK)) { res = 0; } else if (res == 0) { res = -1; } // fprintf(stderr, " res = %d\n", (int)res); CAMLreturn(Val_int(res)); } batteries-included-3.4.0/examples/benchmark/t_strstr.ml000066400000000000000000000035021415601150500232510ustar00rootroot00000000000000open Bigarray let stride = 8 (* bytes *) let ba_cat = int64 let blit_string_to_ba s = let ba = Array1.create ba_cat c_layout ((String.length s + stride - 1) / stride) in let s' = (Obj.magic (Obj.field (Obj.repr ba) 1) : string) in for i = 0 to String.length s - 1 do String.unsafe_set s' i (String.unsafe_get s i); done; ba let build_srch_ht n_ba = let len = Array1.dim n_ba in let ht = Hashtbl.create len in for i = 0 to len - 1 do Hashtbl.add ht (Array1.get n_ba i) i done; ht let volnit ~n_ba = let ht = build_srch_ht n_ba in let ret = ref [] in fun ~hs_ba verify -> for i = 0 to Array1.dim hs_ba - 1 do try let off = Hashtbl.find ht (Array1.unsafe_get hs_ba i) in let srch_off = i * stride - off in if verify ~off:srch_off then ret := srch_off :: !ret with Not_found -> () done; !ret let vol n = let s = volnit ~n_ba:(blit_string_to_ba n) in fun hs -> s ~hs_ba:(blit_string_to_ba hs) (fun ~off -> String.sub hs off (String.length n) = n) open Batteries let rec find_all_aux n hs last acc = match try Some (String.find_from hs (last+1) n) with Not_found -> None with | Some i -> find_all_aux n hs i (last::acc) | None -> List.rev (last::acc) let find_all n hs = try let i0 = String.find hs n in find_all_aux n hs i0 [] with Not_found -> [] let n1 = "abcde" let hs1 = "abcabcabdeabcdeabbaab" let na1 = blit_string_to_ba n1 let hsa1 = blit_string_to_ba hs1 let test_vol = let v = vol n1 in fun () -> v hs1 let test_vol_ba = let v = volnit ~n_ba:na1 in fun () -> v ~hs_ba:hsa1 (fun ~off -> String.sub hs1 off (String.length n1) = n1) let test_bf () = find_all n1 hs1 let tests = [ "vol", test_vol , (); "vol_ba", test_vol_ba, (); "batfind", test_bf, (); ] open Benchmark let () = latencyN 1_000_000L tests |> tabulate batteries-included-3.4.0/examples/euler/000077500000000000000000000000001415601150500202155ustar00rootroot00000000000000batteries-included-3.4.0/examples/euler/Makefile000066400000000000000000000005471415601150500216630ustar00rootroot00000000000000.PHONY: all clean SOURCES = $(wildcard euler*.ml) TARGETS = $(SOURCES:.ml=.byte) LIBRARIES = mathlib.ml all: $(TARGETS) clean: rm *.byte *.native *.cmi *.cmo %.byte: $(LIBRARIES) %.ml ocamlfind ocamlc -thread -package threads,batteries -linkpkg $^ -o $@ %.native: $(LIBRARIES) %.ml ocamlfind ocamlc -thread -package threads,batteries -linkpkg $^ -o $@batteries-included-3.4.0/examples/euler/dune000066400000000000000000000003071415601150500210730ustar00rootroot00000000000000(executables (names euler001 euler008 euler009 euler010 euler011 euler012 euler013 euler014 euler018 euler019 euler021 euler022 euler023 euler024 euler067) (libraries batteries)) batteries-included-3.4.0/examples/euler/euler001.ml000066400000000000000000000007251415601150500221100ustar00rootroot00000000000000open Batteries open Enum let say e = e |> map string_of_int |> print ~last:"\n" IO.nwrite stdout let print_sum e = e |> reduce (+) |> string_of_int |> print_endline let top = 999 let () = (1 -- top) |> filter (fun x -> x mod 3 = 0 || x mod 5 = 0) |> print_sum let () = let mul3 = (1 -- (top / 3)) |> map ( ( * ) 3) and mul5 = (1 -- (top / 5)) |> map ( ( * ) 5) in (* say (clone mul3); say (clone mul5); *) merge (<) mul3 mul5 |> uniq |> print_sum batteries-included-3.4.0/examples/euler/euler008.ml000066400000000000000000000025261415601150500221200ustar00rootroot00000000000000 let num = "73167176531330624919225119674426574742355349194934\ 96983520312774506326239578318016984801869478851843\ 85861560789112949495459501737958331952853208805511\ 12540698747158523863050715693290963295227443043557\ 66896648950445244523161731856403098711121722383113\ 62229893423380308135336276614282806444486645238749\ 30358907296290491560440772390713810515859307960866\ 70172427121883998797908792274921901699720888093776\ 65727333001053367881220235421809751254540594752243\ 52584907711670556013604839586446706324415722155397\ 53697817977846174064955149290862569321978468622482\ 83972241375657056057490261407972968652414535100474\ 82166370484403199890008895243450658541227588666881\ 16427171479924442928230863465674813919123162824586\ 17866458359124566529476545682848912883142607690042\ 24219022671055626321111109370544217506941658960408\ 07198403850962455444362981230987879927244284909188\ 84580156166097919133875499200524063689912560717606\ 05886116467109405077541002256983155200055935729725\ 71636269561882670428252483600823257530420752963450" let code0 = Char.code '0' let numarr = Array.init 1000 (fun i -> Char.code num.[i] - code0) let () = let best = ref 1 in for i = 0 to 999 - 5 do let prod5 = numarr.(i) * numarr.(i+1) * numarr.(i+2) * numarr.(i+3) * numarr.(i+4) in best := max !best prod5; done; print_int !best; print_newline () batteries-included-3.4.0/examples/euler/euler009.ml000066400000000000000000000006571415601150500221240ustar00rootroot00000000000000let () = let max_search = 100 in for n = 1 to max_search do for m = n+1 to max_search do let a = 2 * m * n and b = m * m - n * n and c = m * m + n * n in let s = a + b + c in if 1000 mod s = 0 then let m = (1000 / s) in Printf.printf "mult: %d\n" m; Printf.printf "a: %d b: %d c: %d\n" (a*m) (b*m) (c*m); print_int (a * b * c * m * m * m); print_newline (); exit 0 done; done batteries-included-3.4.0/examples/euler/euler010.ml000066400000000000000000000006451415601150500221110ustar00rootroot00000000000000open Batteries open Enum let max_val = 2_000_000 let max_test = max_val |> float |> sqrt |> Float.to_int let () = let primes = ref (2--max_val) in let s = ref 0 in let rec loop () = match get !primes with | None -> print_int !s; print_newline () | Some p -> s := !s + p; if p < max_test then primes := !primes // (fun x -> x mod p != 0); (* damn inefficient *) loop() in loop () batteries-included-3.4.0/examples/euler/euler011.ml000066400000000000000000000043071415601150500221110ustar00rootroot00000000000000let arr = [|08; 02; 22; 97; 38; 15; 00; 40; 00; 75; 04; 05; 07; 78; 52; 12; 50; 77; 91; 08; 49; 49; 99; 40; 17; 81; 18; 57; 60; 87; 17; 40; 98; 43; 69; 48; 04; 56; 62; 00; 81; 49; 31; 73; 55; 79; 14; 29; 93; 71; 40; 67; 53; 88; 30; 03; 49; 13; 36; 65; 52; 70; 95; 23; 04; 60; 11; 42; 69; 24; 68; 56; 01; 32; 56; 71; 37; 02; 36; 91; 22; 31; 16; 71; 51; 67; 63; 89; 41; 92; 36; 54; 22; 40; 40; 28; 66; 33; 13; 80; 24; 47; 32; 60; 99; 03; 45; 02; 44; 75; 33; 53; 78; 36; 84; 20; 35; 17; 12; 50; 32; 98; 81; 28; 64; 23; 67; 10; 26; 38; 40; 67; 59; 54; 70; 66; 18; 38; 64; 70; 67; 26; 20; 68; 02; 62; 12; 20; 95; 63; 94; 39; 63; 08; 40; 91; 66; 49; 94; 21; 24; 55; 58; 05; 66; 73; 99; 26; 97; 17; 78; 78; 96; 83; 14; 88; 34; 89; 63; 72; 21; 36; 23; 09; 75; 00; 76; 44; 20; 45; 35; 14; 00; 61; 33; 97; 34; 31; 33; 95; 78; 17; 53; 28; 22; 75; 31; 67; 15; 94; 03; 80; 04; 62; 16; 14; 09; 53; 56; 92; 16; 39; 05; 42; 96; 35; 31; 47; 55; 58; 88; 24; 00; 17; 54; 24; 36; 29; 85; 57; 86; 56; 00; 48; 35; 71; 89; 07; 05; 44; 44; 37; 44; 60; 21; 58; 51; 54; 17; 58; 19; 80; 81; 68; 05; 94; 47; 69; 28; 73; 92; 13; 86; 52; 17; 77; 04; 89; 55; 40; 04; 52; 08; 83; 97; 35; 99; 16; 07; 97; 57; 32; 16; 26; 26; 79; 33; 27; 98; 66; 88; 36; 68; 87; 57; 62; 20; 72; 03; 46; 33; 67; 46; 55; 12; 32; 63; 93; 53; 69; 04; 42; 16; 73; 38; 25; 39; 11; 24; 94; 72; 18; 08; 46; 29; 32; 40; 62; 76; 36; 20; 69; 36; 41; 72; 30; 23; 88; 34; 62; 99; 69; 82; 67; 59; 85; 74; 04; 36; 16; 20; 73; 35; 29; 78; 31; 90; 01; 74; 31; 49; 71; 48; 86; 81; 16; 23; 57; 05; 54; 01; 70; 54; 71; 83; 51; 54; 69; 16; 92; 33; 48; 61; 43; 52; 01; 89; 19; 67; 48; |] let get r c = arr.(r * 20 + c) let best_lr = let best = ref 1 in let test f = best := max !best (f 0 * f 1 * f 2 * f 3) in for row = 0 to 19 do for col = 0 to 19 do let lr i = get row (col + i) and tb i = get (row+i) col and d1 i = get (row+i) (col+i) and d2 i = get (row-i) (col+i) in if col + 3 <= 19 then test lr; if row + 3 <= 19 then test tb; if (row + 3 <= 19 && col + 3 <= 19) then test d1; if (row >= 3 && col >= 3) then test d2; done done; print_int !best; print_newline () batteries-included-3.4.0/examples/euler/euler012.ml000066400000000000000000000010231415601150500221020ustar00rootroot00000000000000open Batteries let num_div x = let count = ref 1 in (* already counted 1 *) let max_test = x |> float |> sqrt |> Float.to_int in for i = 2 to max_test do if x mod i = 0 then incr count done; count := !count * 2; (* every factor < max_test has a corresponding one > *) if x mod max_test = 0 then decr count; (* don't double count root if x square *) !count let rec loop i n = let d = num_div n in if d > 500 then begin print_int n; print_newline(); exit 0 end else loop (i+1) (n+i+1) let () = loop 1 1 batteries-included-3.4.0/examples/euler/euler013.ml000066400000000000000000000033121415601150500221060ustar00rootroot00000000000000open Batteries let data = [ 37107287533902; 46376937677490; 74324986199524; 91942213363574; 23067588207539; 89261670696623; 28112879812849; 44274228917432; 47451445736001; 70386486105843; 62176457141856; 64906352462741; 92575867718337; 58203565325359; 80181199384826; 35398664372827; 86515506006295; 71693888707715; 54370070576826; 53282654108756; 36123272525000; 45876576172410; 17423706905851; 81142660418086; 51934325451728; 62467221648435; 15732444386908; 55037687525678; 18336384825330; 80386287592878; 78182833757993; 16726320100436; 48403098129077; 87086987551392; 59959406895756; 69793950679652; 41052684708299; 65378607361501; 35829035317434; 94953759765105; 88902802571733; 25267680276078; 36270218540497; 24074486908231; 91430288197103; 34413065578016; 23053081172816; 11487696932154; 63783299490636; 67720186971698; 95548255300263; 76085327132285; 37774242535411; 23701913275725; 29798860272258; 18495701454879; 38298203783031; 34829543829199; 40957953066405; 29746152185502; 41698116222072; 62467957194401; 23189706772547; 86188088225875; 11306739708304; 82959174767140; 97623331044818; 42846280183517; 55121603546981; 32238195734329; 75506164965184; 62177842752192; 32924185707147; 99518671430235; 73267460800591; 76841822524674; 97142617910342; 87783646182799; 10848802521674; 71329612474782; 62184073572399; 66627891981488; 60661826293682; 85786944089552; 66024396409905; 64913982680032; 16730939319872; 94809377245048; 78639167021187; 15368713711936; 40789923115535; 44889911501440; 41503128880339; 81234880673210; 82616570773948; 22918802058777; 77158542502016; 72107838435069; 20849603980134; 53503534226472; ] let () = List.reduce (+) data |> print_int; print_newline () (* fix: print only the first 10 characters *) batteries-included-3.4.0/examples/euler/euler014.ml000066400000000000000000000005171415601150500221130ustar00rootroot00000000000000let rec seq i = function 1 -> i | n when n land 1 = 0 -> seq (i+1) (n asr 1) | n (* odd *) -> seq (i+1) (3*n+1) let () = let best_i = ref 1 and best_n0 = ref 1 in for n = 1 to 1_000_000 do let i = seq 1 n in if i > !best_i then ( best_i := i; best_n0 := n ); done; print_int !best_n0; print_newline () batteries-included-3.4.0/examples/euler/euler018.ml000066400000000000000000000021171415601150500221150ustar00rootroot00000000000000open Batteries let tri = [| [| 75 |]; [| 95; 64 |]; [| 17; 47; 82 |]; [| 18; 35; 87; 10 |]; [| 20; 04; 82; 47; 65 |]; [| 19; 01; 23; 75; 03; 34 |]; [| 88; 02; 77; 73; 07; 63; 67 |]; [| 99; 65; 04; 28; 06; 16; 70; 92 |]; [| 41; 41; 26; 56; 83; 40; 80; 70; 33 |]; [| 41; 48; 72; 33; 47; 32; 37; 16; 94; 29 |]; [| 53; 71; 44; 65; 25; 43; 91; 52; 97; 51; 14 |]; [| 70; 11; 33; 28; 77; 73; 17; 78; 39; 68; 17; 57 |]; [| 91; 71; 52; 38; 17; 14; 91; 43; 58; 50; 27; 29; 48 |]; [| 63; 66; 04; 68; 89; 53; 67; 30; 73; 16; 69; 87; 40; 31 |]; [| 04; 62; 98; 27; 23; 09; 70; 98; 73; 93; 38; 53; 60; 04; 23 |] |];; let () = let size = Array.length tri in print_int size; print_newline(); (* set each entry to the best possible result *) for n = 1 to size - 1 do tri.(n).(0) <- tri.(n).(0) + tri.(n-1).(0); for i = 1 to n-1 do tri.(n).(i) <- tri.(n).(i) + (max tri.(n-1).(i-1) tri.(n-1).(i)); done; tri.(n).(n) <- tri.(n).(n) + tri.(n-1).(n-1) done; Array.fold_left max (-1) tri.(size-1) |> print_int; print_newline() batteries-included-3.4.0/examples/euler/euler019.ml000066400000000000000000000026061415601150500221210ustar00rootroot00000000000000open Batteries let daysmonth = [ 31; 28; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 ] let daysleap = [ 31; 29; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 ] let year_shift_f days = (List.reduce (+) days) mod 7 let year_shift = year_shift_f daysmonth (* 1 *) let year_shiftleap = year_shift_f daysleap (* 2 *) let count_shift days = let ret = Array.make 7 0 in let rec loop day = function | _h :: [] -> let sh = 6 - day in ret.(sh) <- ret.(sh) + 1 (* and done *) | [] -> assert false | h :: t -> let sh = 6 - day in ret.(sh) <- ret.(sh) + 1; loop ((day + h) mod 7) t in loop 0 days; ret let count_year = count_shift daysmonth let count_leap = count_shift daysleap (* val count_year : int array = [|2; 2; 1; 3; 1; 1; 2|] *) (* val count_leap : int array = [|2; 1; 2; 2; 1; 1; 3|] *) let is_leap yr = if yr mod 4 <> 0 then false else if yr mod 100 <> 0 then true else if yr mod 400 <> 0 then false else true let rec count_sun (count, yr, endyr, dayone) = if yr >= endyr then count else let add, shift = if is_leap yr then count_leap.(dayone), year_shiftleap else count_year.(dayone), year_shift in count_sun ((count+add), (yr+1), endyr, ((dayone + shift) mod 7)) let () = let end_yr = 2001 and start_yr = 1901 and dayone = 1 (* monday *) in let count = count_sun (0, start_yr, end_yr, dayone) in print_int count; print_newline();; batteries-included-3.4.0/examples/euler/euler021.ml000066400000000000000000000016741415601150500221160ustar00rootroot00000000000000open Batteries let d n = Mathlib.sum_factors n module ISet = Set.Make(Int) let ret_amicable ~upto = let is_amic = ref ISet.empty and not_amic = ref ISet.empty and to_test = ref ((2--upto) |> ISet.of_enum) in let test n = (* cleanup - ugly code *) if n >= upto then () else if ISet.mem n !is_amic || ISet.mem n !not_amic then () else let dn = d n in if dn >= upto || dn = n then not_amic := !not_amic |> ISet.add n else let ddn = d dn in if n = ddn then is_amic := !is_amic |> ISet.add n |> ISet.add dn else not_amic := !not_amic |> ISet.add n in while not (ISet.is_empty !to_test) do let n = ISet.choose !to_test in to_test := !to_test |> ISet.remove n; test n done; ISet.enum !is_amic let print_int_enum e = Enum.print (fun stdout n -> IO.nwrite stdout (string_of_int n)) stdout e let () = ret_amicable ~upto:10_000 |> Enum.reduce (+) |> print_int; print_newline();; batteries-included-3.4.0/examples/euler/euler022.ml000066400000000000000000000000261415601150500221050ustar00rootroot00000000000000(* uses names.txt *) batteries-included-3.4.0/examples/euler/euler023.ml000066400000000000000000000007221415601150500221110ustar00rootroot00000000000000open Batteries let is_abundant n = n < Mathlib.sum_factors n let max_sum = if Array.length Sys.argv > 1 then int_of_string Sys.argv.(1) else 28123 let () = let x = BitSet.create_full max_sum in let found = RefList.empty () in for i = 12 to max_sum do if is_abundant i then begin RefList.push found i; RefList.iter (fun j -> BitSet.unset x (i+j)) found; end done; BitSet.enum x |> Enum.reduce (+) |> print_int; print_newline () batteries-included-3.4.0/examples/euler/euler024.ml000066400000000000000000000011651415601150500221140ustar00rootroot00000000000000open Batteries open Mathlib let pos = 1_000_000 let tokens = [0;1;2;3;4;5;6;7;8;9] let rec permute tokens acc pos = match tokens with [] -> List.rev (acc) | [x] -> List.rev (x :: acc) | t -> let len = List.length t in let sub_count = factorial (len-1) in let token_pos = pos / sub_count and next_pos = pos mod sub_count in let found = List.at t token_pos in Printf.printf "subperm %d: %d (pos %d clust %d) next: %d\n" pos found token_pos sub_count next_pos; permute (List.remove t found) (found::acc) next_pos let () = permute tokens [] (pos-1) |> List.iter (fun i -> print_int i); print_newline() batteries-included-3.4.0/examples/euler/euler067.ml000066400000000000000000000512201415601150500221200ustar00rootroot00000000000000open Batteries let tri = [| [| 59|]; [| 73; 41|]; [| 52; 40; 09|]; [| 26; 53; 06; 34|]; [| 10; 51; 87; 86; 81|]; [| 61; 95; 66; 57; 25; 68|]; [| 90; 81; 80; 38; 92; 67; 73|]; [| 30; 28; 51; 76; 81; 18; 75; 44|]; [| 84; 14; 95; 87; 62; 81; 17; 78; 58|]; [| 21; 46; 71; 58; 02; 79; 62; 39; 31; 09|]; [| 56; 34; 35; 53; 78; 31; 81; 18; 90; 93; 15|]; [| 78; 53; 04; 21; 84; 93; 32; 13; 97; 11; 37; 51|]; [| 45; 03; 81; 79; 05; 18; 78; 86; 13; 30; 63; 99; 95|]; [| 39; 87; 96; 28; 03; 38; 42; 17; 82; 87; 58; 07; 22; 57|]; [| 06; 17; 51; 17; 07; 93; 09; 07; 75; 97; 95; 78; 87; 08; 53|]; [| 67; 66; 59; 60; 88; 99; 94; 65; 55; 77; 55; 34; 27; 53; 78; 28|]; [| 76; 40; 41; 04; 87; 16; 09; 42; 75; 69; 23; 97; 30; 60; 10; 79; 87|]; [| 12; 10; 44; 26; 21; 36; 32; 84; 98; 60; 13; 12; 36; 16; 63; 31; 91; 35|]; [| 70; 39; 06; 05; 55; 27; 38; 48; 28; 22; 34; 35; 62; 62; 15; 14; 94; 89; 86|]; [| 66; 56; 68; 84; 96; 21; 34; 34; 34; 81; 62; 40; 65; 54; 62; 05; 98; 03; 02; 60|]; [| 38; 89; 46; 37; 99; 54; 34; 53; 36; 14; 70; 26; 02; 90; 45; 13; 31; 61; 83; 73; 47|]; [| 36; 10; 63; 96; 60; 49; 41; 05; 37; 42; 14; 58; 84; 93; 96; 17; 09; 43; 05; 43; 06; 59|]; [| 66; 57; 87; 57; 61; 28; 37; 51; 84; 73; 79; 15; 39; 95; 88; 87; 43; 39; 11; 86; 77; 74; 18|]; [| 54; 42; 05; 79; 30; 49; 99; 73; 46; 37; 50; 02; 45; 09; 54; 52; 27; 95; 27; 65; 19; 45; 26; 45|]; [| 71; 39; 17; 78; 76; 29; 52; 90; 18; 99; 78; 19; 35; 62; 71; 19; 23; 65; 93; 85; 49; 33; 75; 09; 02|]; [| 33; 24; 47; 61; 60; 55; 32; 88; 57; 55; 91; 54; 46; 57; 07; 77; 98; 52; 80; 99; 24; 25; 46; 78; 79; 05|]; [| 92; 09; 13; 55; 10; 67; 26; 78; 76; 82; 63; 49; 51; 31; 24; 68; 05; 57; 07; 54; 69; 21; 67; 43; 17; 63; 12|]; [| 24; 59; 06; 08; 98; 74; 66; 26; 61; 60; 13; 03; 09; 09; 24; 30; 71; 08; 88; 70; 72; 70; 29; 90; 11; 82; 41; 34|]; [| 66; 82; 67; 04; 36; 60; 92; 77; 91; 85; 62; 49; 59; 61; 30; 90; 29; 94; 26; 41; 89; 04; 53; 22; 83; 41; 09; 74; 90|]; [| 48; 28; 26; 37; 28; 52; 77; 26; 51; 32; 18; 98; 79; 36; 62; 13; 17; 08; 19; 54; 89; 29; 73; 68; 42; 14; 08; 16; 70; 37|]; [| 37; 60; 69; 70; 72; 71; 09; 59; 13; 60; 38; 13; 57; 36; 09; 30; 43; 89; 30; 39; 15; 02; 44; 73; 05; 73; 26; 63; 56; 86; 12|]; [| 55; 55; 85; 50; 62; 99; 84; 77; 28; 85; 03; 21; 27; 22; 19; 26; 82; 69; 54; 04; 13; 07; 85; 14; 01; 15; 70; 59; 89; 95; 10; 19|]; [| 04; 09; 31; 92; 91; 38; 92; 86; 98; 75; 21; 05; 64; 42; 62; 84; 36; 20; 73; 42; 21; 23; 22; 51; 51; 79; 25; 45; 85; 53; 03; 43; 22|]; [| 75; 63; 02; 49; 14; 12; 89; 14; 60; 78; 92; 16; 44; 82; 38; 30; 72; 11; 46; 52; 90; 27; 08; 65; 78; 03; 85; 41; 57; 79; 39; 52; 33; 48|]; [| 78; 27; 56; 56; 39; 13; 19; 43; 86; 72; 58; 95; 39; 07; 04; 34; 21; 98; 39; 15; 39; 84; 89; 69; 84; 46; 37; 57; 59; 35; 59; 50; 26; 15; 93|]; [| 42; 89; 36; 27; 78; 91; 24; 11; 17; 41; 05; 94; 07; 69; 51; 96; 03; 96; 47; 90; 90; 45; 91; 20; 50; 56; 10; 32; 36; 49; 04; 53; 85; 92; 25; 65|]; [| 52; 09; 61; 30; 61; 97; 66; 21; 96; 92; 98; 90; 06; 34; 96; 60; 32; 69; 68; 33; 75; 84; 18; 31; 71; 50; 84; 63; 03; 03; 19; 11; 28; 42; 75; 45; 45|]; [| 61; 31; 61; 68; 96; 34; 49; 39; 05; 71; 76; 59; 62; 67; 06; 47; 96; 99; 34; 21; 32; 47; 52; 07; 71; 60; 42; 72; 94; 56; 82; 83; 84; 40; 94; 87; 82; 46|]; [| 01; 20; 60; 14; 17; 38; 26; 78; 66; 81; 45; 95; 18; 51; 98; 81; 48; 16; 53; 88; 37; 52; 69; 95; 72; 93; 22; 34; 98; 20; 54; 27; 73; 61; 56; 63; 60; 34; 63|]; [| 93; 42; 94; 83; 47; 61; 27; 51; 79; 79; 45; 01; 44; 73; 31; 70; 83; 42; 88; 25; 53; 51; 30; 15; 65; 94; 80; 44; 61; 84; 12; 77; 02; 62; 02; 65; 94; 42; 14; 94|]; [| 32; 73; 09; 67; 68; 29; 74; 98; 10; 19; 85; 48; 38; 31; 85; 67; 53; 93; 93; 77; 47; 67; 39; 72; 94; 53; 18; 43; 77; 40; 78; 32; 29; 59; 24; 06; 02; 83; 50; 60; 66|]; [| 32; 01; 44; 30; 16; 51; 15; 81; 98; 15; 10; 62; 86; 79; 50; 62; 45; 60; 70; 38; 31; 85; 65; 61; 64; 06; 69; 84; 14; 22; 56; 43; 09; 48; 66; 69; 83; 91; 60; 40; 36; 61|]; [| 92; 48; 22; 99; 15; 95; 64; 43; 01; 16; 94; 02; 99; 19; 17; 69; 11; 58; 97; 56; 89; 31; 77; 45; 67; 96; 12; 73; 08; 20; 36; 47; 81; 44; 50; 64; 68; 85; 40; 81; 85; 52; 09|]; [| 91; 35; 92; 45; 32; 84; 62; 15; 19; 64; 21; 66; 06; 01; 52; 80; 62; 59; 12; 25; 88; 28; 91; 50; 40; 16; 22; 99; 92; 79; 87; 51; 21; 77; 74; 77; 07; 42; 38; 42; 74; 83; 02; 05|]; [| 46; 19; 77; 66; 24; 18; 05; 32; 02; 84; 31; 99; 92; 58; 96; 72; 91; 36; 62; 99; 55; 29; 53; 42; 12; 37; 26; 58; 89; 50; 66; 19; 82; 75; 12; 48; 24; 87; 91; 85; 02; 07; 03; 76; 86|]; [| 99; 98; 84; 93; 07; 17; 33; 61; 92; 20; 66; 60; 24; 66; 40; 30; 67; 05; 37; 29; 24; 96; 03; 27; 70; 62; 13; 04; 45; 47; 59; 88; 43; 20; 66; 15; 46; 92; 30; 04; 71; 66; 78; 70; 53; 99|]; [| 67; 60; 38; 06; 88; 04; 17; 72; 10; 99; 71; 07; 42; 25; 54; 05; 26; 64; 91; 50; 45; 71; 06; 30; 67; 48; 69; 82; 08; 56; 80; 67; 18; 46; 66; 63; 01; 20; 08; 80; 47; 07; 91; 16; 03; 79; 87|]; [| 18; 54; 78; 49; 80; 48; 77; 40; 68; 23; 60; 88; 58; 80; 33; 57; 11; 69; 55; 53; 64; 02; 94; 49; 60; 92; 16; 35; 81; 21; 82; 96; 25; 24; 96; 18; 02; 05; 49; 03; 50; 77; 06; 32; 84; 27; 18; 38|]; [| 68; 01; 50; 04; 03; 21; 42; 94; 53; 24; 89; 05; 92; 26; 52; 36; 68; 11; 85; 01; 04; 42; 02; 45; 15; 06; 50; 04; 53; 73; 25; 74; 81; 88; 98; 21; 67; 84; 79; 97; 99; 20; 95; 04; 40; 46; 02; 58; 87|]; [| 94; 10; 02; 78; 88; 52; 21; 03; 88; 60; 06; 53; 49; 71; 20; 91; 12; 65; 07; 49; 21; 22; 11; 41; 58; 99; 36; 16; 09; 48; 17; 24; 52; 36; 23; 15; 72; 16; 84; 56; 02; 99; 43; 76; 81; 71; 29; 39; 49; 17|]; [| 64; 39; 59; 84; 86; 16; 17; 66; 03; 09; 43; 06; 64; 18; 63; 29; 68; 06; 23; 07; 87; 14; 26; 35; 17; 12; 98; 41; 53; 64; 78; 18; 98; 27; 28; 84; 80; 67; 75; 62; 10; 11; 76; 90; 54; 10; 05; 54; 41; 39; 66|]; [| 43; 83; 18; 37; 32; 31; 52; 29; 95; 47; 08; 76; 35; 11; 04; 53; 35; 43; 34; 10; 52; 57; 12; 36; 20; 39; 40; 55; 78; 44; 07; 31; 38; 26; 08; 15; 56; 88; 86; 01; 52; 62; 10; 24; 32; 05; 60; 65; 53; 28; 57; 99|]; [| 03; 50; 03; 52; 07; 73; 49; 92; 66; 80; 01; 46; 08; 67; 25; 36; 73; 93; 07; 42; 25; 53; 13; 96; 76; 83; 87; 90; 54; 89; 78; 22; 78; 91; 73; 51; 69; 09; 79; 94; 83; 53; 09; 40; 69; 62; 10; 79; 49; 47; 03; 81; 30|]; [| 71; 54; 73; 33; 51; 76; 59; 54; 79; 37; 56; 45; 84; 17; 62; 21; 98; 69; 41; 95; 65; 24; 39; 37; 62; 03; 24; 48; 54; 64; 46; 82; 71; 78; 33; 67; 09; 16; 96; 68; 52; 74; 79; 68; 32; 21; 13; 78; 96; 60; 09; 69; 20; 36|]; [| 73; 26; 21; 44; 46; 38; 17; 83; 65; 98; 07; 23; 52; 46; 61; 97; 33; 13; 60; 31; 70; 15; 36; 77; 31; 58; 56; 93; 75; 68; 21; 36; 69; 53; 90; 75; 25; 82; 39; 50; 65; 94; 29; 30; 11; 33; 11; 13; 96; 02; 56; 47; 07; 49; 02|]; [| 76; 46; 73; 30; 10; 20; 60; 70; 14; 56; 34; 26; 37; 39; 48; 24; 55; 76; 84; 91; 39; 86; 95; 61; 50; 14; 53; 93; 64; 67; 37; 31; 10; 84; 42; 70; 48; 20; 10; 72; 60; 61; 84; 79; 69; 65; 99; 73; 89; 25; 85; 48; 92; 56; 97; 16|]; [| 03; 14; 80; 27; 22; 30; 44; 27; 67; 75; 79; 32; 51; 54; 81; 29; 65; 14; 19; 04; 13; 82; 04; 91; 43; 40; 12; 52; 29; 99; 07; 76; 60; 25; 01; 07; 61; 71; 37; 92; 40; 47; 99; 66; 57; 01; 43; 44; 22; 40; 53; 53; 09; 69; 26; 81; 07|]; [| 49; 80; 56; 90; 93; 87; 47; 13; 75; 28; 87; 23; 72; 79; 32; 18; 27; 20; 28; 10; 37; 59; 21; 18; 70; 04; 79; 96; 03; 31; 45; 71; 81; 06; 14; 18; 17; 05; 31; 50; 92; 79; 23; 47; 09; 39; 47; 91; 43; 54; 69; 47; 42; 95; 62; 46; 32; 85|]; [| 37; 18; 62; 85; 87; 28; 64; 05; 77; 51; 47; 26; 30; 65; 05; 70; 65; 75; 59; 80; 42; 52; 25; 20; 44; 10; 92; 17; 71; 95; 52; 14; 77; 13; 24; 55; 11; 65; 26; 91; 01; 30; 63; 15; 49; 48; 41; 17; 67; 47; 03; 68; 20; 90; 98; 32; 04; 40; 68|]; [| 90; 51; 58; 60; 06; 55; 23; 68; 05; 19; 76; 94; 82; 36; 96; 43; 38; 90; 87; 28; 33; 83; 05; 17; 70; 83; 96; 93; 06; 04; 78; 47; 80; 06; 23; 84; 75; 23; 87; 72; 99; 14; 50; 98; 92; 38; 90; 64; 61; 58; 76; 94; 36; 66; 87; 80; 51; 35; 61; 38|]; [| 57; 95; 64; 06; 53; 36; 82; 51; 40; 33; 47; 14; 07; 98; 78; 65; 39; 58; 53; 06; 50; 53; 04; 69; 40; 68; 36; 69; 75; 78; 75; 60; 03; 32; 39; 24; 74; 47; 26; 90; 13; 40; 44; 71; 90; 76; 51; 24; 36; 50; 25; 45; 70; 80; 61; 80; 61; 43; 90; 64; 11|]; [| 18; 29; 86; 56; 68; 42; 79; 10; 42; 44; 30; 12; 96; 18; 23; 18; 52; 59; 02; 99; 67; 46; 60; 86; 43; 38; 55; 17; 44; 93; 42; 21; 55; 14; 47; 34; 55; 16; 49; 24; 23; 29; 96; 51; 55; 10; 46; 53; 27; 92; 27; 46; 63; 57; 30; 65; 43; 27; 21; 20; 24; 83|]; [| 81; 72; 93; 19; 69; 52; 48; 01; 13; 83; 92; 69; 20; 48; 69; 59; 20; 62; 05; 42; 28; 89; 90; 99; 32; 72; 84; 17; 08; 87; 36; 03; 60; 31; 36; 36; 81; 26; 97; 36; 48; 54; 56; 56; 27; 16; 91; 08; 23; 11; 87; 99; 33; 47; 02; 14; 44; 73; 70; 99; 43; 35; 33|]; [| 90; 56; 61; 86; 56; 12; 70; 59; 63; 32; 01; 15; 81; 47; 71; 76; 95; 32; 65; 80; 54; 70; 34; 51; 40; 45; 33; 04; 64; 55; 78; 68; 88; 47; 31; 47; 68; 87; 03; 84; 23; 44; 89; 72; 35; 08; 31; 76; 63; 26; 90; 85; 96; 67; 65; 91; 19; 14; 17; 86; 04; 71; 32; 95|]; [| 37; 13; 04; 22; 64; 37; 37; 28; 56; 62; 86; 33; 07; 37; 10; 44; 52; 82; 52; 06; 19; 52; 57; 75; 90; 26; 91; 24; 06; 21; 14; 67; 76; 30; 46; 14; 35; 89; 89; 41; 03; 64; 56; 97; 87; 63; 22; 34; 03; 79; 17; 45; 11; 53; 25; 56; 96; 61; 23; 18; 63; 31; 37; 37; 47|]; [| 77; 23; 26; 70; 72; 76; 77; 04; 28; 64; 71; 69; 14; 85; 96; 54; 95; 48; 06; 62; 99; 83; 86; 77; 97; 75; 71; 66; 30; 19; 57; 90; 33; 01; 60; 61; 14; 12; 90; 99; 32; 77; 56; 41; 18; 14; 87; 49; 10; 14; 90; 64; 18; 50; 21; 74; 14; 16; 88; 05; 45; 73; 82; 47; 74; 44|]; [| 22; 97; 41; 13; 34; 31; 54; 61; 56; 94; 03; 24; 59; 27; 98; 77; 04; 09; 37; 40; 12; 26; 87; 09; 71; 70; 07; 18; 64; 57; 80; 21; 12; 71; 83; 94; 60; 39; 73; 79; 73; 19; 97; 32; 64; 29; 41; 07; 48; 84; 85; 67; 12; 74; 95; 20; 24; 52; 41; 67; 56; 61; 29; 93; 35; 72; 69|]; [| 72; 23; 63; 66; 01; 11; 07; 30; 52; 56; 95; 16; 65; 26; 83; 90; 50; 74; 60; 18; 16; 48; 43; 77; 37; 11; 99; 98; 30; 94; 91; 26; 62; 73; 45; 12; 87; 73; 47; 27; 01; 88; 66; 99; 21; 41; 95; 80; 02; 53; 23; 32; 61; 48; 32; 43; 43; 83; 14; 66; 95; 91; 19; 81; 80; 67; 25; 88|]; [| 08; 62; 32; 18; 92; 14; 83; 71; 37; 96; 11; 83; 39; 99; 05; 16; 23; 27; 10; 67; 02; 25; 44; 11; 55; 31; 46; 64; 41; 56; 44; 74; 26; 81; 51; 31; 45; 85; 87; 09; 81; 95; 22; 28; 76; 69; 46; 48; 64; 87; 67; 76; 27; 89; 31; 11; 74; 16; 62; 03; 60; 94; 42; 47; 09; 34; 94; 93; 72|]; [| 56; 18; 90; 18; 42; 17; 42; 32; 14; 86; 06; 53; 33; 95; 99; 35; 29; 15; 44; 20; 49; 59; 25; 54; 34; 59; 84; 21; 23; 54; 35; 90; 78; 16; 93; 13; 37; 88; 54; 19; 86; 67; 68; 55; 66; 84; 65; 42; 98; 37; 87; 56; 33; 28; 58; 38; 28; 38; 66; 27; 52; 21; 81; 15; 08; 22; 97; 32; 85; 27|]; [| 91; 53; 40; 28; 13; 34; 91; 25; 01; 63; 50; 37; 22; 49; 71; 58; 32; 28; 30; 18; 68; 94; 23; 83; 63; 62; 94; 76; 80; 41; 90; 22; 82; 52; 29; 12; 18; 56; 10; 08; 35; 14; 37; 57; 23; 65; 67; 40; 72; 39; 93; 39; 70; 89; 40; 34; 07; 46; 94; 22; 20; 05; 53; 64; 56; 30; 05; 56; 61; 88; 27|]; [| 23; 95; 11; 12; 37; 69; 68; 24; 66; 10; 87; 70; 43; 50; 75; 07; 62; 41; 83; 58; 95; 93; 89; 79; 45; 39; 02; 22; 05; 22; 95; 43; 62; 11; 68; 29; 17; 40; 26; 44; 25; 71; 87; 16; 70; 85; 19; 25; 59; 94; 90; 41; 41; 80; 61; 70; 55; 60; 84; 33; 95; 76; 42; 63; 15; 09; 03; 40; 38; 12; 03; 32|]; [| 09; 84; 56; 80; 61; 55; 85; 97; 16; 94; 82; 94; 98; 57; 84; 30; 84; 48; 93; 90; 71; 05; 95; 90; 73; 17; 30; 98; 40; 64; 65; 89; 07; 79; 09; 19; 56; 36; 42; 30; 23; 69; 73; 72; 07; 05; 27; 61; 24; 31; 43; 48; 71; 84; 21; 28; 26; 65; 65; 59; 65; 74; 77; 20; 10; 81; 61; 84; 95; 08; 52; 23; 70|]; [| 47; 81; 28; 09; 98; 51; 67; 64; 35; 51; 59; 36; 92; 82; 77; 65; 80; 24; 72; 53; 22; 07; 27; 10; 21; 28; 30; 22; 48; 82; 80; 48; 56; 20; 14; 43; 18; 25; 50; 95; 90; 31; 77; 08; 09; 48; 44; 80; 90; 22; 93; 45; 82; 17; 13; 96; 25; 26; 08; 73; 34; 99; 06; 49; 24; 06; 83; 51; 40; 14; 15; 10; 25; 01|]; [| 54; 25; 10; 81; 30; 64; 24; 74; 75; 80; 36; 75; 82; 60; 22; 69; 72; 91; 45; 67; 03; 62; 79; 54; 89; 74; 44; 83; 64; 96; 66; 73; 44; 30; 74; 50; 37; 05; 09; 97; 70; 01; 60; 46; 37; 91; 39; 75; 75; 18; 58; 52; 72; 78; 51; 81; 86; 52; 08; 97; 01; 46; 43; 66; 98; 62; 81; 18; 70; 93; 73; 08; 32; 46; 34|]; [| 96; 80; 82; 07; 59; 71; 92; 53; 19; 20; 88; 66; 03; 26; 26; 10; 24; 27; 50; 82; 94; 73; 63; 08; 51; 33; 22; 45; 19; 13; 58; 33; 90; 15; 22; 50; 36; 13; 55; 06; 35; 47; 82; 52; 33; 61; 36; 27; 28; 46; 98; 14; 73; 20; 73; 32; 16; 26; 80; 53; 47; 66; 76; 38; 94; 45; 02; 01; 22; 52; 47; 96; 64; 58; 52; 39|]; [| 88; 46; 23; 39; 74; 63; 81; 64; 20; 90; 33; 33; 76; 55; 58; 26; 10; 46; 42; 26; 74; 74; 12; 83; 32; 43; 09; 02; 73; 55; 86; 54; 85; 34; 28; 23; 29; 79; 91; 62; 47; 41; 82; 87; 99; 22; 48; 90; 20; 05; 96; 75; 95; 04; 43; 28; 81; 39; 81; 01; 28; 42; 78; 25; 39; 77; 90; 57; 58; 98; 17; 36; 73; 22; 63; 74; 51|]; [| 29; 39; 74; 94; 95; 78; 64; 24; 38; 86; 63; 87; 93; 06; 70; 92; 22; 16; 80; 64; 29; 52; 20; 27; 23; 50; 14; 13; 87; 15; 72; 96; 81; 22; 08; 49; 72; 30; 70; 24; 79; 31; 16; 64; 59; 21; 89; 34; 96; 91; 48; 76; 43; 53; 88; 01; 57; 80; 23; 81; 90; 79; 58; 01; 80; 87; 17; 99; 86; 90; 72; 63; 32; 69; 14; 28; 88; 69|]; [| 37; 17; 71; 95; 56; 93; 71; 35; 43; 45; 04; 98; 92; 94; 84; 96; 11; 30; 31; 27; 31; 60; 92; 03; 48; 05; 98; 91; 86; 94; 35; 90; 90; 08; 48; 19; 33; 28; 68; 37; 59; 26; 65; 96; 50; 68; 22; 07; 09; 49; 34; 31; 77; 49; 43; 06; 75; 17; 81; 87; 61; 79; 52; 26; 27; 72; 29; 50; 07; 98; 86; 01; 17; 10; 46; 64; 24; 18; 56|]; [| 51; 30; 25; 94; 88; 85; 79; 91; 40; 33; 63; 84; 49; 67; 98; 92; 15; 26; 75; 19; 82; 05; 18; 78; 65; 93; 61; 48; 91; 43; 59; 41; 70; 51; 22; 15; 92; 81; 67; 91; 46; 98; 11; 11; 65; 31; 66; 10; 98; 65; 83; 21; 05; 56; 05; 98; 73; 67; 46; 74; 69; 34; 08; 30; 05; 52; 07; 98; 32; 95; 30; 94; 65; 50; 24; 63; 28; 81; 99; 57|]; [| 19; 23; 61; 36; 09; 89; 71; 98; 65; 17; 30; 29; 89; 26; 79; 74; 94; 11; 44; 48; 97; 54; 81; 55; 39; 66; 69; 45; 28; 47; 13; 86; 15; 76; 74; 70; 84; 32; 36; 33; 79; 20; 78; 14; 41; 47; 89; 28; 81; 05; 99; 66; 81; 86; 38; 26; 06; 25; 13; 60; 54; 55; 23; 53; 27; 05; 89; 25; 23; 11; 13; 54; 59; 54; 56; 34; 16; 24; 53; 44; 06|]; [| 13; 40; 57; 72; 21; 15; 60; 08; 04; 19; 11; 98; 34; 45; 09; 97; 86; 71; 03; 15; 56; 19; 15; 44; 97; 31; 90; 04; 87; 87; 76; 08; 12; 30; 24; 62; 84; 28; 12; 85; 82; 53; 99; 52; 13; 94; 06; 65; 97; 86; 09; 50; 94; 68; 69; 74; 30; 67; 87; 94; 63; 07; 78; 27; 80; 36; 69; 41; 06; 92; 32; 78; 37; 82; 30; 05; 18; 87; 99; 72; 19; 99|]; [| 44; 20; 55; 77; 69; 91; 27; 31; 28; 81; 80; 27; 02; 07; 97; 23; 95; 98; 12; 25; 75; 29; 47; 71; 07; 47; 78; 39; 41; 59; 27; 76; 13; 15; 66; 61; 68; 35; 69; 86; 16; 53; 67; 63; 99; 85; 41; 56; 08; 28; 33; 40; 94; 76; 90; 85; 31; 70; 24; 65; 84; 65; 99; 82; 19; 25; 54; 37; 21; 46; 33; 02; 52; 99; 51; 33; 26; 04; 87; 02; 08; 18; 96|]; [| 54; 42; 61; 45; 91; 06; 64; 79; 80; 82; 32; 16; 83; 63; 42; 49; 19; 78; 65; 97; 40; 42; 14; 61; 49; 34; 04; 18; 25; 98; 59; 30; 82; 72; 26; 88; 54; 36; 21; 75; 03; 88; 99; 53; 46; 51; 55; 78; 22; 94; 34; 40; 68; 87; 84; 25; 30; 76; 25; 08; 92; 84; 42; 61; 40; 38; 09; 99; 40; 23; 29; 39; 46; 55; 10; 90; 35; 84; 56; 70; 63; 23; 91; 39|]; [| 52; 92; 03; 71; 89; 07; 09; 37; 68; 66; 58; 20; 44; 92; 51; 56; 13; 71; 79; 99; 26; 37; 02; 06; 16; 67; 36; 52; 58; 16; 79; 73; 56; 60; 59; 27; 44; 77; 94; 82; 20; 50; 98; 33; 09; 87; 94; 37; 40; 83; 64; 83; 58; 85; 17; 76; 53; 02; 83; 52; 22; 27; 39; 20; 48; 92; 45; 21; 09; 42; 24; 23; 12; 37; 52; 28; 50; 78; 79; 20; 86; 62; 73; 20; 59|]; [| 54; 96; 80; 15; 91; 90; 99; 70; 10; 09; 58; 90; 93; 50; 81; 99; 54; 38; 36; 10; 30; 11; 35; 84; 16; 45; 82; 18; 11; 97; 36; 43; 96; 79; 97; 65; 40; 48; 23; 19; 17; 31; 64; 52; 65; 65; 37; 32; 65; 76; 99; 79; 34; 65; 79; 27; 55; 33; 03; 01; 33; 27; 61; 28; 66; 08; 04; 70; 49; 46; 48; 83; 01; 45; 19; 96; 13; 81; 14; 21; 31; 79; 93; 85; 50; 05|]; [| 92; 92; 48; 84; 59; 98; 31; 53; 23; 27; 15; 22; 79; 95; 24; 76; 05; 79; 16; 93; 97; 89; 38; 89; 42; 83; 02; 88; 94; 95; 82; 21; 01; 97; 48; 39; 31; 78; 09; 65; 50; 56; 97; 61; 01; 07; 65; 27; 21; 23; 14; 15; 80; 97; 44; 78; 49; 35; 33; 45; 81; 74; 34; 05; 31; 57; 09; 38; 94; 07; 69; 54; 69; 32; 65; 68; 46; 68; 78; 90; 24; 28; 49; 51; 45; 86; 35|]; [| 41; 63; 89; 76; 87; 31; 86; 09; 46; 14; 87; 82; 22; 29; 47; 16; 13; 10; 70; 72; 82; 95; 48; 64; 58; 43; 13; 75; 42; 69; 21; 12; 67; 13; 64; 85; 58; 23; 98; 09; 37; 76; 05; 22; 31; 12; 66; 50; 29; 99; 86; 72; 45; 25; 10; 28; 19; 06; 90; 43; 29; 31; 67; 79; 46; 25; 74; 14; 97; 35; 76; 37; 65; 46; 23; 82; 06; 22; 30; 76; 93; 66; 94; 17; 96; 13; 20; 72|]; [| 63; 40; 78; 08; 52; 09; 90; 41; 70; 28; 36; 14; 46; 44; 85; 96; 24; 52; 58; 15; 87; 37; 05; 98; 99; 39; 13; 61; 76; 38; 44; 99; 83; 74; 90; 22; 53; 80; 56; 98; 30; 51; 63; 39; 44; 30; 91; 91; 04; 22; 27; 73; 17; 35; 53; 18; 35; 45; 54; 56; 27; 78; 48; 13; 69; 36; 44; 38; 71; 25; 30; 56; 15; 22; 73; 43; 32; 69; 59; 25; 93; 83; 45; 11; 34; 94; 44; 39; 92|]; [| 12; 36; 56; 88; 13; 96; 16; 12; 55; 54; 11; 47; 19; 78; 17; 17; 68; 81; 77; 51; 42; 55; 99; 85; 66; 27; 81; 79; 93; 42; 65; 61; 69; 74; 14; 01; 18; 56; 12; 01; 58; 37; 91; 22; 42; 66; 83; 25; 19; 04; 96; 41; 25; 45; 18; 69; 96; 88; 36; 93; 10; 12; 98; 32; 44; 83; 83; 04; 72; 91; 04; 27; 73; 07; 34; 37; 71; 60; 59; 31; 01; 54; 54; 44; 96; 93; 83; 36; 04; 45|]; [| 30; 18; 22; 20; 42; 96; 65; 79; 17; 41; 55; 69; 94; 81; 29; 80; 91; 31; 85; 25; 47; 26; 43; 49; 02; 99; 34; 67; 99; 76; 16; 14; 15; 93; 08; 32; 99; 44; 61; 77; 67; 50; 43; 55; 87; 55; 53; 72; 17; 46; 62; 25; 50; 99; 73; 05; 93; 48; 17; 31; 70; 80; 59; 09; 44; 59; 45; 13; 74; 66; 58; 94; 87; 73; 16; 14; 85; 38; 74; 99; 64; 23; 79; 28; 71; 42; 20; 37; 82; 31; 23|]; [| 51; 96; 39; 65; 46; 71; 56; 13; 29; 68; 53; 86; 45; 33; 51; 49; 12; 91; 21; 21; 76; 85; 02; 17; 98; 15; 46; 12; 60; 21; 88; 30; 92; 83; 44; 59; 42; 50; 27; 88; 46; 86; 94; 73; 45; 54; 23; 24; 14; 10; 94; 21; 20; 34; 23; 51; 04; 83; 99; 75; 90; 63; 60; 16; 22; 33; 83; 70; 11; 32; 10; 50; 29; 30; 83; 46; 11; 05; 31; 17; 86; 42; 49; 01; 44; 63; 28; 60; 07; 78; 95; 40|]; [| 44; 61; 89; 59; 04; 49; 51; 27; 69; 71; 46; 76; 44; 04; 09; 34; 56; 39; 15; 06; 94; 91; 75; 90; 65; 27; 56; 23; 74; 06; 23; 33; 36; 69; 14; 39; 05; 34; 35; 57; 33; 22; 76; 46; 56; 10; 61; 65; 98; 09; 16; 69; 04; 62; 65; 18; 99; 76; 49; 18; 72; 66; 73; 83; 82; 40; 76; 31; 89; 91; 27; 88; 17; 35; 41; 35; 32; 51; 32; 67; 52; 68; 74; 85; 80; 57; 07; 11; 62; 66; 47; 22; 67|]; [| 65; 37; 19; 97; 26; 17; 16; 24; 24; 17; 50; 37; 64; 82; 24; 36; 32; 11; 68; 34; 69; 31; 32; 89; 79; 93; 96; 68; 49; 90; 14; 23; 04; 04; 67; 99; 81; 74; 70; 74; 36; 96; 68; 09; 64; 39; 88; 35; 54; 89; 96; 58; 66; 27; 88; 97; 32; 14; 06; 35; 78; 20; 71; 06; 85; 66; 57; 02; 58; 91; 72; 05; 29; 56; 73; 48; 86; 52; 09; 93; 22; 57; 79; 42; 12; 01; 31; 68; 17; 59; 63; 76; 07; 77|]; [| 73; 81; 14; 13; 17; 20; 11; 09; 01; 83; 08; 85; 91; 70; 84; 63; 62; 77; 37; 07; 47; 01; 59; 95; 39; 69; 39; 21; 99; 09; 87; 02; 97; 16; 92; 36; 74; 71; 90; 66; 33; 73; 73; 75; 52; 91; 11; 12; 26; 53; 05; 26; 26; 48; 61; 50; 90; 65; 01; 87; 42; 47; 74; 35; 22; 73; 24; 26; 56; 70; 52; 05; 48; 41; 31; 18; 83; 27; 21; 39; 80; 85; 26; 08; 44; 02; 71; 07; 63; 22; 05; 52; 19; 08; 20|]; [| 17; 25; 21; 11; 72; 93; 33; 49; 64; 23; 53; 82; 03; 13; 91; 65; 85; 02; 40; 05; 42; 31; 77; 42; 05; 36; 06; 54; 04; 58; 07; 76; 87; 83; 25; 57; 66; 12; 74; 33; 85; 37; 74; 32; 20; 69; 03; 97; 91; 68; 82; 44; 19; 14; 89; 28; 85; 85; 80; 53; 34; 87; 58; 98; 88; 78; 48; 65; 98; 40; 11; 57; 10; 67; 70; 81; 60; 79; 74; 72; 97; 59; 79; 47; 30; 20; 54; 80; 89; 91; 14; 05; 33; 36; 79; 39|]; [| 60; 85; 59; 39; 60; 07; 57; 76; 77; 92; 06; 35; 15; 72; 23; 41; 45; 52; 95; 18; 64; 79; 86; 53; 56; 31; 69; 11; 91; 31; 84; 50; 44; 82; 22; 81; 41; 40; 30; 42; 30; 91; 48; 94; 74; 76; 64; 58; 74; 25; 96; 57; 14; 19; 03; 99; 28; 83; 15; 75; 99; 01; 89; 85; 79; 50; 03; 95; 32; 67; 44; 08; 07; 41; 62; 64; 29; 20; 14; 76; 26; 55; 48; 71; 69; 66; 19; 72; 44; 25; 14; 01; 48; 74; 12; 98; 07|]; [| 64; 66; 84; 24; 18; 16; 27; 48; 20; 14; 47; 69; 30; 86; 48; 40; 23; 16; 61; 21; 51; 50; 26; 47; 35; 33; 91; 28; 78; 64; 43; 68; 04; 79; 51; 08; 19; 60; 52; 95; 06; 68; 46; 86; 35; 97; 27; 58; 04; 65; 30; 58; 99; 12; 12; 75; 91; 39; 50; 31; 42; 64; 70; 04; 46; 07; 98; 73; 98; 93; 37; 89; 77; 91; 64; 71; 64; 65; 66; 21; 78; 62; 81; 74; 42; 20; 83; 70; 73; 95; 78; 45; 92; 27; 34; 53; 71; 15|]; [| 30; 11; 85; 31; 34; 71; 13; 48; 05; 14; 44; 03; 19; 67; 23; 73; 19; 57; 06; 90; 94; 72; 57; 69; 81; 62; 59; 68; 88; 57; 55; 69; 49; 13; 07; 87; 97; 80; 89; 05; 71; 05; 05; 26; 38; 40; 16; 62; 45; 99; 18; 38; 98; 24; 21; 26; 62; 74; 69; 04; 85; 57; 77; 35; 58; 67; 91; 79; 79; 57; 86; 28; 66; 34; 72; 51; 76; 78; 36; 95; 63; 90; 08; 78; 47; 63; 45; 31; 22; 70; 52; 48; 79; 94; 15; 77; 61; 67; 68|]; [| 23; 33; 44; 81; 80; 92; 93; 75; 94; 88; 23; 61; 39; 76; 22; 03; 28; 94; 32; 06; 49; 65; 41; 34; 18; 23; 08; 47; 62; 60; 03; 63; 33; 13; 80; 52; 31; 54; 73; 43; 70; 26; 16; 69; 57; 87; 83; 31; 03; 93; 70; 81; 47; 95; 77; 44; 29; 68; 39; 51; 56; 59; 63; 07; 25; 70; 07; 77; 43; 53; 64; 03; 94; 42; 95; 39; 18; 01; 66; 21; 16; 97; 20; 50; 90; 16; 70; 10; 95; 69; 29; 06; 25; 61; 41; 26; 15; 59; 63; 35|] |] let () = let size = Array.length tri in (* set each entry to the best possible result *) for n = 1 to size - 1 do tri.(n).(0) <- tri.(n).(0) + tri.(n-1).(0); for i = 1 to n-1 do tri.(n).(i) <- tri.(n).(i) + (max tri.(n-1).(i-1) tri.(n-1).(i)); done; tri.(n).(n) <- tri.(n).(n) + tri.(n-1).(n-1) done; Array.fold_left max (-1) tri.(size-1) |> print_int; print_newline() batteries-included-3.4.0/examples/euler/mathlib.ml000066400000000000000000000102271415601150500221710ustar00rootroot00000000000000open Batteries let rec factorial = function 1 -> 1 | n -> n * factorial (n-1) let rec big_factorial acc = function | 1 -> acc | n -> big_factorial (Big_int.mult_int_big_int n acc) (n-1) let big_factorial n = big_factorial Big_int.unit_big_int n let factors i f x = let acc = ref i in (* already counted 1 *) let max_test = x |> float |> sqrt |> Float.to_int in for i = 2 to max_test-1 do if x mod i = 0 then acc := f (x/i) (f i !acc) done; if x mod max_test = 0 && max_test <> 1 then if max_test * max_test = x then f max_test !acc (* square - don't double count *) else f (x/max_test) (f max_test !acc) else !acc let list_factors n = factors [1] List.cons n let sum_factors n = factors 1 (+) n (* list of small primes *) let easy = [2; 3; 5; 7] (* let patt = [2; 4; 2; 4; 6; 2; 6; 4; 2; 4; 6; 6; 2; 6; 4; 2; 6; 4; 6; 8; 4; 2; 4; 2; 4; 8; 6; 4; 6; 2; 4; 6; 2; 6; 6; 4; 2; 4; 6; 2; 6; 4; 2; 4; 2; 10; 2; 10] *) (* The following code builds a pattern list of skip sizes that can be used when searching for primes. The idea is an extension of checking only odd numbers (greater than 2) for primality. Knowing that [2;3;5] are prime, we can check [x; x+4; x+6; x+10; x+12; x+16; x+22; x+24; x+30] for primality (given an appropriate start value x), as we can know ahead of time that [x+1; x+2; x+3; x+5; x+7; ...] are composite by the same reasoning that we know that [x+1; x+3; x+5] are composite for odd [x]. Instead of storing the offsets from [x], we store the offset from the previous, so the sequence above is represented by the pattern [4;2;4;2;4;6;2;6]. We derive this sequence from a list of [n] small primes by first inspecting integers 2--10^n for being relatively prime to our small primes. We then take the differences between subsequent values, and search for a periodic pattern in the results. The smallest sequence that repeats is our desired testing pattern. *) (* Find relative primes *) let primes easy = let pattsearch_max = List.fold_left (fun a _ -> a * 10) 1 easy in let filter l n = Enum.filter (fun i -> i mod n > 0) l in List.fold_left filter (2--pattsearch_max) easy |> List.of_enum (* compute successive differences *) let diffs list = let rec loop acc = function a :: b :: t -> loop ((b-a)::acc) (b::t) | _ -> List.rev acc in loop [] list (* test whether the elements of l1 and l2 are the same, ignoring any extra elements in one list *) let rec list_eq_head l1 l2 = match l1,l2 with | h1::t1, h2::t2 -> h1 == h2 && list_eq_head t1 t2 | [],[] | [],_ | _,[] -> true (* test whether the sublist [sub] repeats to form the rest of [l] *) let rec is_rep sub n lst = try let head,rest = List.split_nth n lst in head = sub && is_rep sub n rest with Invalid_argument _ -> list_eq_head lst sub (* given a list, find the smallest sublist that repeats to create that list *) let find_sub lst = let half_len = List.length lst / 2 in let rec loop n = if n > half_len then failwith "No repeating subsequence found, need more test primes"; let sub = List.take n lst in if is_rep sub n lst then sub else loop (n+1) in loop 1 (* combines the above routines to build a primality testing skip pattern *) let patt, patt_init = let ps = primes easy in let patt = diffs ps |> find_sub in patt, List.hd ps open Return (* use batReturn for flow control *) let test_sequence () = Enum.scanl (+) patt_init (List.enum patt |> Enum.cycle) (* factor [comp], calling [found] on each prime factor *) let factor found n = (* factor out as many factors of [t] from [n] *) label (fun label -> let rec test n t = (* exit from infinite fold here *) if t * t > n then (if n > t then found n; return label ()) else if n mod t = 0 then let quot = n / t in (found t; test quot t) else n in (* test/reduce small primes *) let n = List.fold_left test n easy in (* infinite fold for rest of divisors, no return value *) test_sequence () |> Enum.fold test n |> ignore ) let factors n = let ret = RefList.empty () in factor (RefList.push ret) n; assert (RefList.fold_left ( * ) 1 ret = n); List.rev (RefList.to_list ret) batteries-included-3.4.0/examples/euler/names.txt000066400000000000000000001325571415601150500220760ustar00rootroot00000000000000"MARY","PATRICIA","LINDA","BARBARA","ELIZABETH","JENNIFER","MARIA","SUSAN","MARGARET","DOROTHY","LISA","NANCY","KAREN","BETTY","HELEN","SANDRA","DONNA","CAROL","RUTH","SHARON","MICHELLE","LAURA","SARAH","KIMBERLY","DEBORAH","JESSICA","SHIRLEY","CYNTHIA","ANGELA","MELISSA","BRENDA","AMY","ANNA","REBECCA","VIRGINIA","KATHLEEN","PAMELA","MARTHA","DEBRA","AMANDA","STEPHANIE","CAROLYN","CHRISTINE","MARIE","JANET","CATHERINE","FRANCES","ANN","JOYCE","DIANE","ALICE","JULIE","HEATHER","TERESA","DORIS","GLORIA","EVELYN","JEAN","CHERYL","MILDRED","KATHERINE","JOAN","ASHLEY","JUDITH","ROSE","JANICE","KELLY","NICOLE","JUDY","CHRISTINA","KATHY","THERESA","BEVERLY","DENISE","TAMMY","IRENE","JANE","LORI","RACHEL","MARILYN","ANDREA","KATHRYN","LOUISE","SARA","ANNE","JACQUELINE","WANDA","BONNIE","JULIA","RUBY","LOIS","TINA","PHYLLIS","NORMA","PAULA","DIANA","ANNIE","LILLIAN","EMILY","ROBIN","PEGGY","CRYSTAL","GLADYS","RITA","DAWN","CONNIE","FLORENCE","TRACY","EDNA","TIFFANY","CARMEN","ROSA","CINDY","GRACE","WENDY","VICTORIA","EDITH","KIM","SHERRY","SYLVIA","JOSEPHINE","THELMA","SHANNON","SHEILA","ETHEL","ELLEN","ELAINE","MARJORIE","CARRIE","CHARLOTTE","MONICA","ESTHER","PAULINE","EMMA","JUANITA","ANITA","RHONDA","HAZEL","AMBER","EVA","DEBBIE","APRIL","LESLIE","CLARA","LUCILLE","JAMIE","JOANNE","ELEANOR","VALERIE","DANIELLE","MEGAN","ALICIA","SUZANNE","MICHELE","GAIL","BERTHA","DARLENE","VERONICA","JILL","ERIN","GERALDINE","LAUREN","CATHY","JOANN","LORRAINE","LYNN","SALLY","REGINA","ERICA","BEATRICE","DOLORES","BERNICE","AUDREY","YVONNE","ANNETTE","JUNE","SAMANTHA","MARION","DANA","STACY","ANA","RENEE","IDA","VIVIAN","ROBERTA","HOLLY","BRITTANY","MELANIE","LORETTA","YOLANDA","JEANETTE","LAURIE","KATIE","KRISTEN","VANESSA","ALMA","SUE","ELSIE","BETH","JEANNE","VICKI","CARLA","TARA","ROSEMARY","EILEEN","TERRI","GERTRUDE","LUCY","TONYA","ELLA","STACEY","WILMA","GINA","KRISTIN","JESSIE","NATALIE","AGNES","VERA","WILLIE","CHARLENE","BESSIE","DELORES","MELINDA","PEARL","ARLENE","MAUREEN","COLLEEN","ALLISON","TAMARA","JOY","GEORGIA","CONSTANCE","LILLIE","CLAUDIA","JACKIE","MARCIA","TANYA","NELLIE","MINNIE","MARLENE","HEIDI","GLENDA","LYDIA","VIOLA","COURTNEY","MARIAN","STELLA","CAROLINE","DORA","JO","VICKIE","MATTIE","TERRY","MAXINE","IRMA","MABEL","MARSHA","MYRTLE","LENA","CHRISTY","DEANNA","PATSY","HILDA","GWENDOLYN","JENNIE","NORA","MARGIE","NINA","CASSANDRA","LEAH","PENNY","KAY","PRISCILLA","NAOMI","CAROLE","BRANDY","OLGA","BILLIE","DIANNE","TRACEY","LEONA","JENNY","FELICIA","SONIA","MIRIAM","VELMA","BECKY","BOBBIE","VIOLET","KRISTINA","TONI","MISTY","MAE","SHELLY","DAISY","RAMONA","SHERRI","ERIKA","KATRINA","CLAIRE","LINDSEY","LINDSAY","GENEVA","GUADALUPE","BELINDA","MARGARITA","SHERYL","CORA","FAYE","ADA","NATASHA","SABRINA","ISABEL","MARGUERITE","HATTIE","HARRIET","MOLLY","CECILIA","KRISTI","BRANDI","BLANCHE","SANDY","ROSIE","JOANNA","IRIS","EUNICE","ANGIE","INEZ","LYNDA","MADELINE","AMELIA","ALBERTA","GENEVIEVE","MONIQUE","JODI","JANIE","MAGGIE","KAYLA","SONYA","JAN","LEE","KRISTINE","CANDACE","FANNIE","MARYANN","OPAL","ALISON","YVETTE","MELODY","LUZ","SUSIE","OLIVIA","FLORA","SHELLEY","KRISTY","MAMIE","LULA","LOLA","VERNA","BEULAH","ANTOINETTE","CANDICE","JUANA","JEANNETTE","PAM","KELLI","HANNAH","WHITNEY","BRIDGET","KARLA","CELIA","LATOYA","PATTY","SHELIA","GAYLE","DELLA","VICKY","LYNNE","SHERI","MARIANNE","KARA","JACQUELYN","ERMA","BLANCA","MYRA","LETICIA","PAT","KRISTA","ROXANNE","ANGELICA","JOHNNIE","ROBYN","FRANCIS","ADRIENNE","ROSALIE","ALEXANDRA","BROOKE","BETHANY","SADIE","BERNADETTE","TRACI","JODY","KENDRA","JASMINE","NICHOLE","RACHAEL","CHELSEA","MABLE","ERNESTINE","MURIEL","MARCELLA","ELENA","KRYSTAL","ANGELINA","NADINE","KARI","ESTELLE","DIANNA","PAULETTE","LORA","MONA","DOREEN","ROSEMARIE","ANGEL","DESIREE","ANTONIA","HOPE","GINGER","JANIS","BETSY","CHRISTIE","FREDA","MERCEDES","MEREDITH","LYNETTE","TERI","CRISTINA","EULA","LEIGH","MEGHAN","SOPHIA","ELOISE","ROCHELLE","GRETCHEN","CECELIA","RAQUEL","HENRIETTA","ALYSSA","JANA","KELLEY","GWEN","KERRY","JENNA","TRICIA","LAVERNE","OLIVE","ALEXIS","TASHA","SILVIA","ELVIRA","CASEY","DELIA","SOPHIE","KATE","PATTI","LORENA","KELLIE","SONJA","LILA","LANA","DARLA","MAY","MINDY","ESSIE","MANDY","LORENE","ELSA","JOSEFINA","JEANNIE","MIRANDA","DIXIE","LUCIA","MARTA","FAITH","LELA","JOHANNA","SHARI","CAMILLE","TAMI","SHAWNA","ELISA","EBONY","MELBA","ORA","NETTIE","TABITHA","OLLIE","JAIME","WINIFRED","KRISTIE","MARINA","ALISHA","AIMEE","RENA","MYRNA","MARLA","TAMMIE","LATASHA","BONITA","PATRICE","RONDA","SHERRIE","ADDIE","FRANCINE","DELORIS","STACIE","ADRIANA","CHERI","SHELBY","ABIGAIL","CELESTE","JEWEL","CARA","ADELE","REBEKAH","LUCINDA","DORTHY","CHRIS","EFFIE","TRINA","REBA","SHAWN","SALLIE","AURORA","LENORA","ETTA","LOTTIE","KERRI","TRISHA","NIKKI","ESTELLA","FRANCISCA","JOSIE","TRACIE","MARISSA","KARIN","BRITTNEY","JANELLE","LOURDES","LAUREL","HELENE","FERN","ELVA","CORINNE","KELSEY","INA","BETTIE","ELISABETH","AIDA","CAITLIN","INGRID","IVA","EUGENIA","CHRISTA","GOLDIE","CASSIE","MAUDE","JENIFER","THERESE","FRANKIE","DENA","LORNA","JANETTE","LATONYA","CANDY","MORGAN","CONSUELO","TAMIKA","ROSETTA","DEBORA","CHERIE","POLLY","DINA","JEWELL","FAY","JILLIAN","DOROTHEA","NELL","TRUDY","ESPERANZA","PATRICA","KIMBERLEY","SHANNA","HELENA","CAROLINA","CLEO","STEFANIE","ROSARIO","OLA","JANINE","MOLLIE","LUPE","ALISA","LOU","MARIBEL","SUSANNE","BETTE","SUSANA","ELISE","CECILE","ISABELLE","LESLEY","JOCELYN","PAIGE","JONI","RACHELLE","LEOLA","DAPHNE","ALTA","ESTER","PETRA","GRACIELA","IMOGENE","JOLENE","KEISHA","LACEY","GLENNA","GABRIELA","KERI","URSULA","LIZZIE","KIRSTEN","SHANA","ADELINE","MAYRA","JAYNE","JACLYN","GRACIE","SONDRA","CARMELA","MARISA","ROSALIND","CHARITY","TONIA","BEATRIZ","MARISOL","CLARICE","JEANINE","SHEENA","ANGELINE","FRIEDA","LILY","ROBBIE","SHAUNA","MILLIE","CLAUDETTE","CATHLEEN","ANGELIA","GABRIELLE","AUTUMN","KATHARINE","SUMMER","JODIE","STACI","LEA","CHRISTI","JIMMIE","JUSTINE","ELMA","LUELLA","MARGRET","DOMINIQUE","SOCORRO","RENE","MARTINA","MARGO","MAVIS","CALLIE","BOBBI","MARITZA","LUCILE","LEANNE","JEANNINE","DEANA","AILEEN","LORIE","LADONNA","WILLA","MANUELA","GALE","SELMA","DOLLY","SYBIL","ABBY","LARA","DALE","IVY","DEE","WINNIE","MARCY","LUISA","JERI","MAGDALENA","OFELIA","MEAGAN","AUDRA","MATILDA","LEILA","CORNELIA","BIANCA","SIMONE","BETTYE","RANDI","VIRGIE","LATISHA","BARBRA","GEORGINA","ELIZA","LEANN","BRIDGETTE","RHODA","HALEY","ADELA","NOLA","BERNADINE","FLOSSIE","ILA","GRETA","RUTHIE","NELDA","MINERVA","LILLY","TERRIE","LETHA","HILARY","ESTELA","VALARIE","BRIANNA","ROSALYN","EARLINE","CATALINA","AVA","MIA","CLARISSA","LIDIA","CORRINE","ALEXANDRIA","CONCEPCION","TIA","SHARRON","RAE","DONA","ERICKA","JAMI","ELNORA","CHANDRA","LENORE","NEVA","MARYLOU","MELISA","TABATHA","SERENA","AVIS","ALLIE","SOFIA","JEANIE","ODESSA","NANNIE","HARRIETT","LORAINE","PENELOPE","MILAGROS","EMILIA","BENITA","ALLYSON","ASHLEE","TANIA","TOMMIE","ESMERALDA","KARINA","EVE","PEARLIE","ZELMA","MALINDA","NOREEN","TAMEKA","SAUNDRA","HILLARY","AMIE","ALTHEA","ROSALINDA","JORDAN","LILIA","ALANA","GAY","CLARE","ALEJANDRA","ELINOR","MICHAEL","LORRIE","JERRI","DARCY","EARNESTINE","CARMELLA","TAYLOR","NOEMI","MARCIE","LIZA","ANNABELLE","LOUISA","EARLENE","MALLORY","CARLENE","NITA","SELENA","TANISHA","KATY","JULIANNE","JOHN","LAKISHA","EDWINA","MARICELA","MARGERY","KENYA","DOLLIE","ROXIE","ROSLYN","KATHRINE","NANETTE","CHARMAINE","LAVONNE","ILENE","KRIS","TAMMI","SUZETTE","CORINE","KAYE","JERRY","MERLE","CHRYSTAL","LINA","DEANNE","LILIAN","JULIANA","ALINE","LUANN","KASEY","MARYANNE","EVANGELINE","COLETTE","MELVA","LAWANDA","YESENIA","NADIA","MADGE","KATHIE","EDDIE","OPHELIA","VALERIA","NONA","MITZI","MARI","GEORGETTE","CLAUDINE","FRAN","ALISSA","ROSEANN","LAKEISHA","SUSANNA","REVA","DEIDRE","CHASITY","SHEREE","CARLY","JAMES","ELVIA","ALYCE","DEIRDRE","GENA","BRIANA","ARACELI","KATELYN","ROSANNE","WENDI","TESSA","BERTA","MARVA","IMELDA","MARIETTA","MARCI","LEONOR","ARLINE","SASHA","MADELYN","JANNA","JULIETTE","DEENA","AURELIA","JOSEFA","AUGUSTA","LILIANA","YOUNG","CHRISTIAN","LESSIE","AMALIA","SAVANNAH","ANASTASIA","VILMA","NATALIA","ROSELLA","LYNNETTE","CORINA","ALFREDA","LEANNA","CAREY","AMPARO","COLEEN","TAMRA","AISHA","WILDA","KARYN","CHERRY","QUEEN","MAURA","MAI","EVANGELINA","ROSANNA","HALLIE","ERNA","ENID","MARIANA","LACY","JULIET","JACKLYN","FREIDA","MADELEINE","MARA","HESTER","CATHRYN","LELIA","CASANDRA","BRIDGETT","ANGELITA","JANNIE","DIONNE","ANNMARIE","KATINA","BERYL","PHOEBE","MILLICENT","KATHERYN","DIANN","CARISSA","MARYELLEN","LIZ","LAURI","HELGA","GILDA","ADRIAN","RHEA","MARQUITA","HOLLIE","TISHA","TAMERA","ANGELIQUE","FRANCESCA","BRITNEY","KAITLIN","LOLITA","FLORINE","ROWENA","REYNA","TWILA","FANNY","JANELL","INES","CONCETTA","BERTIE","ALBA","BRIGITTE","ALYSON","VONDA","PANSY","ELBA","NOELLE","LETITIA","KITTY","DEANN","BRANDIE","LOUELLA","LETA","FELECIA","SHARLENE","LESA","BEVERLEY","ROBERT","ISABELLA","HERMINIA","TERRA","CELINA","TORI","OCTAVIA","JADE","DENICE","GERMAINE","SIERRA","MICHELL","CORTNEY","NELLY","DORETHA","SYDNEY","DEIDRA","MONIKA","LASHONDA","JUDI","CHELSEY","ANTIONETTE","MARGOT","BOBBY","ADELAIDE","NAN","LEEANN","ELISHA","DESSIE","LIBBY","KATHI","GAYLA","LATANYA","MINA","MELLISA","KIMBERLEE","JASMIN","RENAE","ZELDA","ELDA","MA","JUSTINA","GUSSIE","EMILIE","CAMILLA","ABBIE","ROCIO","KAITLYN","JESSE","EDYTHE","ASHLEIGH","SELINA","LAKESHA","GERI","ALLENE","PAMALA","MICHAELA","DAYNA","CARYN","ROSALIA","SUN","JACQULINE","REBECA","MARYBETH","KRYSTLE","IOLA","DOTTIE","BENNIE","BELLE","AUBREY","GRISELDA","ERNESTINA","ELIDA","ADRIANNE","DEMETRIA","DELMA","CHONG","JAQUELINE","DESTINY","ARLEEN","VIRGINA","RETHA","FATIMA","TILLIE","ELEANORE","CARI","TREVA","BIRDIE","WILHELMINA","ROSALEE","MAURINE","LATRICE","YONG","JENA","TARYN","ELIA","DEBBY","MAUDIE","JEANNA","DELILAH","CATRINA","SHONDA","HORTENCIA","THEODORA","TERESITA","ROBBIN","DANETTE","MARYJANE","FREDDIE","DELPHINE","BRIANNE","NILDA","DANNA","CINDI","BESS","IONA","HANNA","ARIEL","WINONA","VIDA","ROSITA","MARIANNA","WILLIAM","RACHEAL","GUILLERMINA","ELOISA","CELESTINE","CAREN","MALISSA","LONA","CHANTEL","SHELLIE","MARISELA","LEORA","AGATHA","SOLEDAD","MIGDALIA","IVETTE","CHRISTEN","ATHENA","JANEL","CHLOE","VEDA","PATTIE","TESSIE","TERA","MARILYNN","LUCRETIA","KARRIE","DINAH","DANIELA","ALECIA","ADELINA","VERNICE","SHIELA","PORTIA","MERRY","LASHAWN","DEVON","DARA","TAWANA","OMA","VERDA","CHRISTIN","ALENE","ZELLA","SANDI","RAFAELA","MAYA","KIRA","CANDIDA","ALVINA","SUZAN","SHAYLA","LYN","LETTIE","ALVA","SAMATHA","ORALIA","MATILDE","MADONNA","LARISSA","VESTA","RENITA","INDIA","DELOIS","SHANDA","PHILLIS","LORRI","ERLINDA","CRUZ","CATHRINE","BARB","ZOE","ISABELL","IONE","GISELA","CHARLIE","VALENCIA","ROXANNA","MAYME","KISHA","ELLIE","MELLISSA","DORRIS","DALIA","BELLA","ANNETTA","ZOILA","RETA","REINA","LAURETTA","KYLIE","CHRISTAL","PILAR","CHARLA","ELISSA","TIFFANI","TANA","PAULINA","LEOTA","BREANNA","JAYME","CARMEL","VERNELL","TOMASA","MANDI","DOMINGA","SANTA","MELODIE","LURA","ALEXA","TAMELA","RYAN","MIRNA","KERRIE","VENUS","NOEL","FELICITA","CRISTY","CARMELITA","BERNIECE","ANNEMARIE","TIARA","ROSEANNE","MISSY","CORI","ROXANA","PRICILLA","KRISTAL","JUNG","ELYSE","HAYDEE","ALETHA","BETTINA","MARGE","GILLIAN","FILOMENA","CHARLES","ZENAIDA","HARRIETTE","CARIDAD","VADA","UNA","ARETHA","PEARLINE","MARJORY","MARCELA","FLOR","EVETTE","ELOUISE","ALINA","TRINIDAD","DAVID","DAMARIS","CATHARINE","CARROLL","BELVA","NAKIA","MARLENA","LUANNE","LORINE","KARON","DORENE","DANITA","BRENNA","TATIANA","SAMMIE","LOUANN","LOREN","JULIANNA","ANDRIA","PHILOMENA","LUCILA","LEONORA","DOVIE","ROMONA","MIMI","JACQUELIN","GAYE","TONJA","MISTI","JOE","GENE","CHASTITY","STACIA","ROXANN","MICAELA","NIKITA","MEI","VELDA","MARLYS","JOHNNA","AURA","LAVERN","IVONNE","HAYLEY","NICKI","MAJORIE","HERLINDA","GEORGE","ALPHA","YADIRA","PERLA","GREGORIA","DANIEL","ANTONETTE","SHELLI","MOZELLE","MARIAH","JOELLE","CORDELIA","JOSETTE","CHIQUITA","TRISTA","LOUIS","LAQUITA","GEORGIANA","CANDI","SHANON","LONNIE","HILDEGARD","CECIL","VALENTINA","STEPHANY","MAGDA","KAROL","GERRY","GABRIELLA","TIANA","ROMA","RICHELLE","RAY","PRINCESS","OLETA","JACQUE","IDELLA","ALAINA","SUZANNA","JOVITA","BLAIR","TOSHA","RAVEN","NEREIDA","MARLYN","KYLA","JOSEPH","DELFINA","TENA","STEPHENIE","SABINA","NATHALIE","MARCELLE","GERTIE","DARLEEN","THEA","SHARONDA","SHANTEL","BELEN","VENESSA","ROSALINA","ONA","GENOVEVA","COREY","CLEMENTINE","ROSALBA","RENATE","RENATA","MI","IVORY","GEORGIANNA","FLOY","DORCAS","ARIANA","TYRA","THEDA","MARIAM","JULI","JESICA","DONNIE","VIKKI","VERLA","ROSELYN","MELVINA","JANNETTE","GINNY","DEBRAH","CORRIE","ASIA","VIOLETA","MYRTIS","LATRICIA","COLLETTE","CHARLEEN","ANISSA","VIVIANA","TWYLA","PRECIOUS","NEDRA","LATONIA","LAN","HELLEN","FABIOLA","ANNAMARIE","ADELL","SHARYN","CHANTAL","NIKI","MAUD","LIZETTE","LINDY","KIA","KESHA","JEANA","DANELLE","CHARLINE","CHANEL","CARROL","VALORIE","LIA","DORTHA","CRISTAL","SUNNY","LEONE","LEILANI","GERRI","DEBI","ANDRA","KESHIA","IMA","EULALIA","EASTER","DULCE","NATIVIDAD","LINNIE","KAMI","GEORGIE","CATINA","BROOK","ALDA","WINNIFRED","SHARLA","RUTHANN","MEAGHAN","MAGDALENE","LISSETTE","ADELAIDA","VENITA","TRENA","SHIRLENE","SHAMEKA","ELIZEBETH","DIAN","SHANTA","MICKEY","LATOSHA","CARLOTTA","WINDY","SOON","ROSINA","MARIANN","LEISA","JONNIE","DAWNA","CATHIE","BILLY","ASTRID","SIDNEY","LAUREEN","JANEEN","HOLLI","FAWN","VICKEY","TERESSA","SHANTE","RUBYE","MARCELINA","CHANDA","CARY","TERESE","SCARLETT","MARTY","MARNIE","LULU","LISETTE","JENIFFER","ELENOR","DORINDA","DONITA","CARMAN","BERNITA","ALTAGRACIA","ALETA","ADRIANNA","ZORAIDA","RONNIE","NICOLA","LYNDSEY","KENDALL","JANINA","CHRISSY","AMI","STARLA","PHYLIS","PHUONG","KYRA","CHARISSE","BLANCH","SANJUANITA","RONA","NANCI","MARILEE","MARANDA","CORY","BRIGETTE","SANJUANA","MARITA","KASSANDRA","JOYCELYN","IRA","FELIPA","CHELSIE","BONNY","MIREYA","LORENZA","KYONG","ILEANA","CANDELARIA","TONY","TOBY","SHERIE","OK","MARK","LUCIE","LEATRICE","LAKESHIA","GERDA","EDIE","BAMBI","MARYLIN","LAVON","HORTENSE","GARNET","EVIE","TRESSA","SHAYNA","LAVINA","KYUNG","JEANETTA","SHERRILL","SHARA","PHYLISS","MITTIE","ANABEL","ALESIA","THUY","TAWANDA","RICHARD","JOANIE","TIFFANIE","LASHANDA","KARISSA","ENRIQUETA","DARIA","DANIELLA","CORINNA","ALANNA","ABBEY","ROXANE","ROSEANNA","MAGNOLIA","LIDA","KYLE","JOELLEN","ERA","CORAL","CARLEEN","TRESA","PEGGIE","NOVELLA","NILA","MAYBELLE","JENELLE","CARINA","NOVA","MELINA","MARQUERITE","MARGARETTE","JOSEPHINA","EVONNE","DEVIN","CINTHIA","ALBINA","TOYA","TAWNYA","SHERITA","SANTOS","MYRIAM","LIZABETH","LISE","KEELY","JENNI","GISELLE","CHERYLE","ARDITH","ARDIS","ALESHA","ADRIANE","SHAINA","LINNEA","KAROLYN","HONG","FLORIDA","FELISHA","DORI","DARCI","ARTIE","ARMIDA","ZOLA","XIOMARA","VERGIE","SHAMIKA","NENA","NANNETTE","MAXIE","LOVIE","JEANE","JAIMIE","INGE","FARRAH","ELAINA","CAITLYN","STARR","FELICITAS","CHERLY","CARYL","YOLONDA","YASMIN","TEENA","PRUDENCE","PENNIE","NYDIA","MACKENZIE","ORPHA","MARVEL","LIZBETH","LAURETTE","JERRIE","HERMELINDA","CAROLEE","TIERRA","MIRIAN","META","MELONY","KORI","JENNETTE","JAMILA","ENA","ANH","YOSHIKO","SUSANNAH","SALINA","RHIANNON","JOLEEN","CRISTINE","ASHTON","ARACELY","TOMEKA","SHALONDA","MARTI","LACIE","KALA","JADA","ILSE","HAILEY","BRITTANI","ZONA","SYBLE","SHERRYL","RANDY","NIDIA","MARLO","KANDICE","KANDI","DEB","DEAN","AMERICA","ALYCIA","TOMMY","RONNA","NORENE","MERCY","JOSE","INGEBORG","GIOVANNA","GEMMA","CHRISTEL","AUDRY","ZORA","VITA","VAN","TRISH","STEPHAINE","SHIRLEE","SHANIKA","MELONIE","MAZIE","JAZMIN","INGA","HOA","HETTIE","GERALYN","FONDA","ESTRELLA","ADELLA","SU","SARITA","RINA","MILISSA","MARIBETH","GOLDA","EVON","ETHELYN","ENEDINA","CHERISE","CHANA","VELVA","TAWANNA","SADE","MIRTA","LI","KARIE","JACINTA","ELNA","DAVINA","CIERRA","ASHLIE","ALBERTHA","TANESHA","STEPHANI","NELLE","MINDI","LU","LORINDA","LARUE","FLORENE","DEMETRA","DEDRA","CIARA","CHANTELLE","ASHLY","SUZY","ROSALVA","NOELIA","LYDA","LEATHA","KRYSTYNA","KRISTAN","KARRI","DARLINE","DARCIE","CINDA","CHEYENNE","CHERRIE","AWILDA","ALMEDA","ROLANDA","LANETTE","JERILYN","GISELE","EVALYN","CYNDI","CLETA","CARIN","ZINA","ZENA","VELIA","TANIKA","PAUL","CHARISSA","THOMAS","TALIA","MARGARETE","LAVONDA","KAYLEE","KATHLENE","JONNA","IRENA","ILONA","IDALIA","CANDIS","CANDANCE","BRANDEE","ANITRA","ALIDA","SIGRID","NICOLETTE","MARYJO","LINETTE","HEDWIG","CHRISTIANA","CASSIDY","ALEXIA","TRESSIE","MODESTA","LUPITA","LITA","GLADIS","EVELIA","DAVIDA","CHERRI","CECILY","ASHELY","ANNABEL","AGUSTINA","WANITA","SHIRLY","ROSAURA","HULDA","EUN","BAILEY","YETTA","VERONA","THOMASINA","SIBYL","SHANNAN","MECHELLE","LUE","LEANDRA","LANI","KYLEE","KANDY","JOLYNN","FERNE","EBONI","CORENE","ALYSIA","ZULA","NADA","MOIRA","LYNDSAY","LORRETTA","JUAN","JAMMIE","HORTENSIA","GAYNELL","CAMERON","ADRIA","VINA","VICENTA","TANGELA","STEPHINE","NORINE","NELLA","LIANA","LESLEE","KIMBERELY","ILIANA","GLORY","FELICA","EMOGENE","ELFRIEDE","EDEN","EARTHA","CARMA","BEA","OCIE","MARRY","LENNIE","KIARA","JACALYN","CARLOTA","ARIELLE","YU","STAR","OTILIA","KIRSTIN","KACEY","JOHNETTA","JOEY","JOETTA","JERALDINE","JAUNITA","ELANA","DORTHEA","CAMI","AMADA","ADELIA","VERNITA","TAMAR","SIOBHAN","RENEA","RASHIDA","OUIDA","ODELL","NILSA","MERYL","KRISTYN","JULIETA","DANICA","BREANNE","AUREA","ANGLEA","SHERRON","ODETTE","MALIA","LORELEI","LIN","LEESA","KENNA","KATHLYN","FIONA","CHARLETTE","SUZIE","SHANTELL","SABRA","RACQUEL","MYONG","MIRA","MARTINE","LUCIENNE","LAVADA","JULIANN","JOHNIE","ELVERA","DELPHIA","CLAIR","CHRISTIANE","CHAROLETTE","CARRI","AUGUSTINE","ASHA","ANGELLA","PAOLA","NINFA","LEDA","LAI","EDA","SUNSHINE","STEFANI","SHANELL","PALMA","MACHELLE","LISSA","KECIA","KATHRYNE","KARLENE","JULISSA","JETTIE","JENNIFFER","HUI","CORRINA","CHRISTOPHER","CAROLANN","ALENA","TESS","ROSARIA","MYRTICE","MARYLEE","LIANE","KENYATTA","JUDIE","JANEY","IN","ELMIRA","ELDORA","DENNA","CRISTI","CATHI","ZAIDA","VONNIE","VIVA","VERNIE","ROSALINE","MARIELA","LUCIANA","LESLI","KARAN","FELICE","DENEEN","ADINA","WYNONA","TARSHA","SHERON","SHASTA","SHANITA","SHANI","SHANDRA","RANDA","PINKIE","PARIS","NELIDA","MARILOU","LYLA","LAURENE","LACI","JOI","JANENE","DOROTHA","DANIELE","DANI","CAROLYNN","CARLYN","BERENICE","AYESHA","ANNELIESE","ALETHEA","THERSA","TAMIKO","RUFINA","OLIVA","MOZELL","MARYLYN","MADISON","KRISTIAN","KATHYRN","KASANDRA","KANDACE","JANAE","GABRIEL","DOMENICA","DEBBRA","DANNIELLE","CHUN","BUFFY","BARBIE","ARCELIA","AJA","ZENOBIA","SHAREN","SHAREE","PATRICK","PAGE","MY","LAVINIA","KUM","KACIE","JACKELINE","HUONG","FELISA","EMELIA","ELEANORA","CYTHIA","CRISTIN","CLYDE","CLARIBEL","CARON","ANASTACIA","ZULMA","ZANDRA","YOKO","TENISHA","SUSANN","SHERILYN","SHAY","SHAWANDA","SABINE","ROMANA","MATHILDA","LINSEY","KEIKO","JOANA","ISELA","GRETTA","GEORGETTA","EUGENIE","DUSTY","DESIRAE","DELORA","CORAZON","ANTONINA","ANIKA","WILLENE","TRACEE","TAMATHA","REGAN","NICHELLE","MICKIE","MAEGAN","LUANA","LANITA","KELSIE","EDELMIRA","BREE","AFTON","TEODORA","TAMIE","SHENA","MEG","LINH","KELI","KACI","DANYELLE","BRITT","ARLETTE","ALBERTINE","ADELLE","TIFFINY","STORMY","SIMONA","NUMBERS","NICOLASA","NICHOL","NIA","NAKISHA","MEE","MAIRA","LOREEN","KIZZY","JOHNNY","JAY","FALLON","CHRISTENE","BOBBYE","ANTHONY","YING","VINCENZA","TANJA","RUBIE","RONI","QUEENIE","MARGARETT","KIMBERLI","IRMGARD","IDELL","HILMA","EVELINA","ESTA","EMILEE","DENNISE","DANIA","CARL","CARIE","ANTONIO","WAI","SANG","RISA","RIKKI","PARTICIA","MUI","MASAKO","MARIO","LUVENIA","LOREE","LONI","LIEN","KEVIN","GIGI","FLORENCIA","DORIAN","DENITA","DALLAS","CHI","BILLYE","ALEXANDER","TOMIKA","SHARITA","RANA","NIKOLE","NEOMA","MARGARITE","MADALYN","LUCINA","LAILA","KALI","JENETTE","GABRIELE","EVELYNE","ELENORA","CLEMENTINA","ALEJANDRINA","ZULEMA","VIOLETTE","VANNESSA","THRESA","RETTA","PIA","PATIENCE","NOELLA","NICKIE","JONELL","DELTA","CHUNG","CHAYA","CAMELIA","BETHEL","ANYA","ANDREW","THANH","SUZANN","SPRING","SHU","MILA","LILLA","LAVERNA","KEESHA","KATTIE","GIA","GEORGENE","EVELINE","ESTELL","ELIZBETH","VIVIENNE","VALLIE","TRUDIE","STEPHANE","MICHEL","MAGALY","MADIE","KENYETTA","KARREN","JANETTA","HERMINE","HARMONY","DRUCILLA","DEBBI","CELESTINA","CANDIE","BRITNI","BECKIE","AMINA","ZITA","YUN","YOLANDE","VIVIEN","VERNETTA","TRUDI","SOMMER","PEARLE","PATRINA","OSSIE","NICOLLE","LOYCE","LETTY","LARISA","KATHARINA","JOSELYN","JONELLE","JENELL","IESHA","HEIDE","FLORINDA","FLORENTINA","FLO","ELODIA","DORINE","BRUNILDA","BRIGID","ASHLI","ARDELLA","TWANA","THU","TARAH","SUNG","SHEA","SHAVON","SHANE","SERINA","RAYNA","RAMONITA","NGA","MARGURITE","LUCRECIA","KOURTNEY","KATI","JESUS","JESENIA","DIAMOND","CRISTA","AYANA","ALICA","ALIA","VINNIE","SUELLEN","ROMELIA","RACHELL","PIPER","OLYMPIA","MICHIKO","KATHALEEN","JOLIE","JESSI","JANESSA","HANA","HA","ELEASE","CARLETTA","BRITANY","SHONA","SALOME","ROSAMOND","REGENA","RAINA","NGOC","NELIA","LOUVENIA","LESIA","LATRINA","LATICIA","LARHONDA","JINA","JACKI","HOLLIS","HOLLEY","EMMY","DEEANN","CORETTA","ARNETTA","VELVET","THALIA","SHANICE","NETA","MIKKI","MICKI","LONNA","LEANA","LASHUNDA","KILEY","JOYE","JACQULYN","IGNACIA","HYUN","HIROKO","HENRY","HENRIETTE","ELAYNE","DELINDA","DARNELL","DAHLIA","COREEN","CONSUELA","CONCHITA","CELINE","BABETTE","AYANNA","ANETTE","ALBERTINA","SKYE","SHAWNEE","SHANEKA","QUIANA","PAMELIA","MIN","MERRI","MERLENE","MARGIT","KIESHA","KIERA","KAYLENE","JODEE","JENISE","ERLENE","EMMIE","ELSE","DARYL","DALILA","DAISEY","CODY","CASIE","BELIA","BABARA","VERSIE","VANESA","SHELBA","SHAWNDA","SAM","NORMAN","NIKIA","NAOMA","MARNA","MARGERET","MADALINE","LAWANA","KINDRA","JUTTA","JAZMINE","JANETT","HANNELORE","GLENDORA","GERTRUD","GARNETT","FREEDA","FREDERICA","FLORANCE","FLAVIA","DENNIS","CARLINE","BEVERLEE","ANJANETTE","VALDA","TRINITY","TAMALA","STEVIE","SHONNA","SHA","SARINA","ONEIDA","MICAH","MERILYN","MARLEEN","LURLINE","LENNA","KATHERIN","JIN","JENI","HAE","GRACIA","GLADY","FARAH","ERIC","ENOLA","EMA","DOMINQUE","DEVONA","DELANA","CECILA","CAPRICE","ALYSHA","ALI","ALETHIA","VENA","THERESIA","TAWNY","SONG","SHAKIRA","SAMARA","SACHIKO","RACHELE","PAMELLA","NICKY","MARNI","MARIEL","MAREN","MALISA","LIGIA","LERA","LATORIA","LARAE","KIMBER","KATHERN","KAREY","JENNEFER","JANETH","HALINA","FREDIA","DELISA","DEBROAH","CIERA","CHIN","ANGELIKA","ANDREE","ALTHA","YEN","VIVAN","TERRESA","TANNA","SUK","SUDIE","SOO","SIGNE","SALENA","RONNI","REBBECCA","MYRTIE","MCKENZIE","MALIKA","MAIDA","LOAN","LEONARDA","KAYLEIGH","FRANCE","ETHYL","ELLYN","DAYLE","CAMMIE","BRITTNI","BIRGIT","AVELINA","ASUNCION","ARIANNA","AKIKO","VENICE","TYESHA","TONIE","TIESHA","TAKISHA","STEFFANIE","SINDY","SANTANA","MEGHANN","MANDA","MACIE","LADY","KELLYE","KELLEE","JOSLYN","JASON","INGER","INDIRA","GLINDA","GLENNIS","FERNANDA","FAUSTINA","ENEIDA","ELICIA","DOT","DIGNA","DELL","ARLETTA","ANDRE","WILLIA","TAMMARA","TABETHA","SHERRELL","SARI","REFUGIO","REBBECA","PAULETTA","NIEVES","NATOSHA","NAKITA","MAMMIE","KENISHA","KAZUKO","KASSIE","GARY","EARLEAN","DAPHINE","CORLISS","CLOTILDE","CAROLYNE","BERNETTA","AUGUSTINA","AUDREA","ANNIS","ANNABELL","YAN","TENNILLE","TAMICA","SELENE","SEAN","ROSANA","REGENIA","QIANA","MARKITA","MACY","LEEANNE","LAURINE","KYM","JESSENIA","JANITA","GEORGINE","GENIE","EMIKO","ELVIE","DEANDRA","DAGMAR","CORIE","COLLEN","CHERISH","ROMAINE","PORSHA","PEARLENE","MICHELINE","MERNA","MARGORIE","MARGARETTA","LORE","KENNETH","JENINE","HERMINA","FREDERICKA","ELKE","DRUSILLA","DORATHY","DIONE","DESIRE","CELENA","BRIGIDA","ANGELES","ALLEGRA","THEO","TAMEKIA","SYNTHIA","STEPHEN","SOOK","SLYVIA","ROSANN","REATHA","RAYE","MARQUETTA","MARGART","LING","LAYLA","KYMBERLY","KIANA","KAYLEEN","KATLYN","KARMEN","JOELLA","IRINA","EMELDA","ELENI","DETRA","CLEMMIE","CHERYLL","CHANTELL","CATHEY","ARNITA","ARLA","ANGLE","ANGELIC","ALYSE","ZOFIA","THOMASINE","TENNIE","SON","SHERLY","SHERLEY","SHARYL","REMEDIOS","PETRINA","NICKOLE","MYUNG","MYRLE","MOZELLA","LOUANNE","LISHA","LATIA","LANE","KRYSTA","JULIENNE","JOEL","JEANENE","JACQUALINE","ISAURA","GWENDA","EARLEEN","DONALD","CLEOPATRA","CARLIE","AUDIE","ANTONIETTA","ALISE","ALEX","VERDELL","VAL","TYLER","TOMOKO","THAO","TALISHA","STEVEN","SO","SHEMIKA","SHAUN","SCARLET","SAVANNA","SANTINA","ROSIA","RAEANN","ODILIA","NANA","MINNA","MAGAN","LYNELLE","LE","KARMA","JOEANN","IVANA","INELL","ILANA","HYE","HONEY","HEE","GUDRUN","FRANK","DREAMA","CRISSY","CHANTE","CARMELINA","ARVILLA","ARTHUR","ANNAMAE","ALVERA","ALEIDA","AARON","YEE","YANIRA","VANDA","TIANNA","TAM","STEFANIA","SHIRA","PERRY","NICOL","NANCIE","MONSERRATE","MINH","MELYNDA","MELANY","MATTHEW","LOVELLA","LAURE","KIRBY","KACY","JACQUELYNN","HYON","GERTHA","FRANCISCO","ELIANA","CHRISTENA","CHRISTEEN","CHARISE","CATERINA","CARLEY","CANDYCE","ARLENA","AMMIE","YANG","WILLETTE","VANITA","TUYET","TINY","SYREETA","SILVA","SCOTT","RONALD","PENNEY","NYLA","MICHAL","MAURICE","MARYAM","MARYA","MAGEN","LUDIE","LOMA","LIVIA","LANELL","KIMBERLIE","JULEE","DONETTA","DIEDRA","DENISHA","DEANE","DAWNE","CLARINE","CHERRYL","BRONWYN","BRANDON","ALLA","VALERY","TONDA","SUEANN","SORAYA","SHOSHANA","SHELA","SHARLEEN","SHANELLE","NERISSA","MICHEAL","MERIDITH","MELLIE","MAYE","MAPLE","MAGARET","LUIS","LILI","LEONILA","LEONIE","LEEANNA","LAVONIA","LAVERA","KRISTEL","KATHEY","KATHE","JUSTIN","JULIAN","JIMMY","JANN","ILDA","HILDRED","HILDEGARDE","GENIA","FUMIKO","EVELIN","ERMELINDA","ELLY","DUNG","DOLORIS","DIONNA","DANAE","BERNEICE","ANNICE","ALIX","VERENA","VERDIE","TRISTAN","SHAWNNA","SHAWANA","SHAUNNA","ROZELLA","RANDEE","RANAE","MILAGRO","LYNELL","LUISE","LOUIE","LOIDA","LISBETH","KARLEEN","JUNITA","JONA","ISIS","HYACINTH","HEDY","GWENN","ETHELENE","ERLINE","EDWARD","DONYA","DOMONIQUE","DELICIA","DANNETTE","CICELY","BRANDA","BLYTHE","BETHANN","ASHLYN","ANNALEE","ALLINE","YUKO","VELLA","TRANG","TOWANDA","TESHA","SHERLYN","NARCISA","MIGUELINA","MERI","MAYBELL","MARLANA","MARGUERITA","MADLYN","LUNA","LORY","LORIANN","LIBERTY","LEONORE","LEIGHANN","LAURICE","LATESHA","LARONDA","KATRICE","KASIE","KARL","KALEY","JADWIGA","GLENNIE","GEARLDINE","FRANCINA","EPIFANIA","DYAN","DORIE","DIEDRE","DENESE","DEMETRICE","DELENA","DARBY","CRISTIE","CLEORA","CATARINA","CARISA","BERNIE","BARBERA","ALMETA","TRULA","TEREASA","SOLANGE","SHEILAH","SHAVONNE","SANORA","ROCHELL","MATHILDE","MARGARETA","MAIA","LYNSEY","LAWANNA","LAUNA","KENA","KEENA","KATIA","JAMEY","GLYNDA","GAYLENE","ELVINA","ELANOR","DANUTA","DANIKA","CRISTEN","CORDIE","COLETTA","CLARITA","CARMON","BRYNN","AZUCENA","AUNDREA","ANGELE","YI","WALTER","VERLIE","VERLENE","TAMESHA","SILVANA","SEBRINA","SAMIRA","REDA","RAYLENE","PENNI","PANDORA","NORAH","NOMA","MIREILLE","MELISSIA","MARYALICE","LARAINE","KIMBERY","KARYL","KARINE","KAM","JOLANDA","JOHANA","JESUSA","JALEESA","JAE","JACQUELYNE","IRISH","ILUMINADA","HILARIA","HANH","GENNIE","FRANCIE","FLORETTA","EXIE","EDDA","DREMA","DELPHA","BEV","BARBAR","ASSUNTA","ARDELL","ANNALISA","ALISIA","YUKIKO","YOLANDO","WONDA","WEI","WALTRAUD","VETA","TEQUILA","TEMEKA","TAMEIKA","SHIRLEEN","SHENITA","PIEDAD","OZELLA","MIRTHA","MARILU","KIMIKO","JULIANE","JENICE","JEN","JANAY","JACQUILINE","HILDE","FE","FAE","EVAN","EUGENE","ELOIS","ECHO","DEVORAH","CHAU","BRINDA","BETSEY","ARMINDA","ARACELIS","APRYL","ANNETT","ALISHIA","VEOLA","USHA","TOSHIKO","THEOLA","TASHIA","TALITHA","SHERY","RUDY","RENETTA","REIKO","RASHEEDA","OMEGA","OBDULIA","MIKA","MELAINE","MEGGAN","MARTIN","MARLEN","MARGET","MARCELINE","MANA","MAGDALEN","LIBRADA","LEZLIE","LEXIE","LATASHIA","LASANDRA","KELLE","ISIDRA","ISA","INOCENCIA","GWYN","FRANCOISE","ERMINIA","ERINN","DIMPLE","DEVORA","CRISELDA","ARMANDA","ARIE","ARIANE","ANGELO","ANGELENA","ALLEN","ALIZA","ADRIENE","ADALINE","XOCHITL","TWANNA","TRAN","TOMIKO","TAMISHA","TAISHA","SUSY","SIU","RUTHA","ROXY","RHONA","RAYMOND","OTHA","NORIKO","NATASHIA","MERRIE","MELVIN","MARINDA","MARIKO","MARGERT","LORIS","LIZZETTE","LEISHA","KAILA","KA","JOANNIE","JERRICA","JENE","JANNET","JANEE","JACINDA","HERTA","ELENORE","DORETTA","DELAINE","DANIELL","CLAUDIE","CHINA","BRITTA","APOLONIA","AMBERLY","ALEASE","YURI","YUK","WEN","WANETA","UTE","TOMI","SHARRI","SANDIE","ROSELLE","REYNALDA","RAGUEL","PHYLICIA","PATRIA","OLIMPIA","ODELIA","MITZIE","MITCHELL","MISS","MINDA","MIGNON","MICA","MENDY","MARIVEL","MAILE","LYNETTA","LAVETTE","LAURYN","LATRISHA","LAKIESHA","KIERSTEN","KARY","JOSPHINE","JOLYN","JETTA","JANISE","JACQUIE","IVELISSE","GLYNIS","GIANNA","GAYNELLE","EMERALD","DEMETRIUS","DANYELL","DANILLE","DACIA","CORALEE","CHER","CEOLA","BRETT","BELL","ARIANNE","ALESHIA","YUNG","WILLIEMAE","TROY","TRINH","THORA","TAI","SVETLANA","SHERIKA","SHEMEKA","SHAUNDA","ROSELINE","RICKI","MELDA","MALLIE","LAVONNA","LATINA","LARRY","LAQUANDA","LALA","LACHELLE","KLARA","KANDIS","JOHNA","JEANMARIE","JAYE","HANG","GRAYCE","GERTUDE","EMERITA","EBONIE","CLORINDA","CHING","CHERY","CAROLA","BREANN","BLOSSOM","BERNARDINE","BECKI","ARLETHA","ARGELIA","ARA","ALITA","YULANDA","YON","YESSENIA","TOBI","TASIA","SYLVIE","SHIRL","SHIRELY","SHERIDAN","SHELLA","SHANTELLE","SACHA","ROYCE","REBECKA","REAGAN","PROVIDENCIA","PAULENE","MISHA","MIKI","MARLINE","MARICA","LORITA","LATOYIA","LASONYA","KERSTIN","KENDA","KEITHA","KATHRIN","JAYMIE","JACK","GRICELDA","GINETTE","ERYN","ELINA","ELFRIEDA","DANYEL","CHEREE","CHANELLE","BARRIE","AVERY","AURORE","ANNAMARIA","ALLEEN","AILENE","AIDE","YASMINE","VASHTI","VALENTINE","TREASA","TORY","TIFFANEY","SHERYLL","SHARIE","SHANAE","SAU","RAISA","PA","NEDA","MITSUKO","MIRELLA","MILDA","MARYANNA","MARAGRET","MABELLE","LUETTA","LORINA","LETISHA","LATARSHA","LANELLE","LAJUANA","KRISSY","KARLY","KARENA","JON","JESSIKA","JERICA","JEANELLE","JANUARY","JALISA","JACELYN","IZOLA","IVEY","GREGORY","EUNA","ETHA","DREW","DOMITILA","DOMINICA","DAINA","CREOLA","CARLI","CAMIE","BUNNY","BRITTNY","ASHANTI","ANISHA","ALEEN","ADAH","YASUKO","WINTER","VIKI","VALRIE","TONA","TINISHA","THI","TERISA","TATUM","TANEKA","SIMONNE","SHALANDA","SERITA","RESSIE","REFUGIA","PAZ","OLENE","NA","MERRILL","MARGHERITA","MANDIE","MAN","MAIRE","LYNDIA","LUCI","LORRIANE","LORETA","LEONIA","LAVONA","LASHAWNDA","LAKIA","KYOKO","KRYSTINA","KRYSTEN","KENIA","KELSI","JUDE","JEANICE","ISOBEL","GEORGIANN","GENNY","FELICIDAD","EILENE","DEON","DELOISE","DEEDEE","DANNIE","CONCEPTION","CLORA","CHERILYN","CHANG","CALANDRA","BERRY","ARMANDINA","ANISA","ULA","TIMOTHY","TIERA","THERESSA","STEPHANIA","SIMA","SHYLA","SHONTA","SHERA","SHAQUITA","SHALA","SAMMY","ROSSANA","NOHEMI","NERY","MORIAH","MELITA","MELIDA","MELANI","MARYLYNN","MARISHA","MARIETTE","MALORIE","MADELENE","LUDIVINA","LORIA","LORETTE","LORALEE","LIANNE","LEON","LAVENIA","LAURINDA","LASHON","KIT","KIMI","KEILA","KATELYNN","KAI","JONE","JOANE","JI","JAYNA","JANELLA","JA","HUE","HERTHA","FRANCENE","ELINORE","DESPINA","DELSIE","DEEDRA","CLEMENCIA","CARRY","CAROLIN","CARLOS","BULAH","BRITTANIE","BOK","BLONDELL","BIBI","BEAULAH","BEATA","ANNITA","AGRIPINA","VIRGEN","VALENE","UN","TWANDA","TOMMYE","TOI","TARRA","TARI","TAMMERA","SHAKIA","SADYE","RUTHANNE","ROCHEL","RIVKA","PURA","NENITA","NATISHA","MING","MERRILEE","MELODEE","MARVIS","LUCILLA","LEENA","LAVETA","LARITA","LANIE","KEREN","ILEEN","GEORGEANN","GENNA","GENESIS","FRIDA","EWA","EUFEMIA","EMELY","ELA","EDYTH","DEONNA","DEADRA","DARLENA","CHANELL","CHAN","CATHERN","CASSONDRA","CASSAUNDRA","BERNARDA","BERNA","ARLINDA","ANAMARIA","ALBERT","WESLEY","VERTIE","VALERI","TORRI","TATYANA","STASIA","SHERISE","SHERILL","SEASON","SCOTTIE","SANDA","RUTHE","ROSY","ROBERTO","ROBBI","RANEE","QUYEN","PEARLY","PALMIRA","ONITA","NISHA","NIESHA","NIDA","NEVADA","NAM","MERLYN","MAYOLA","MARYLOUISE","MARYLAND","MARX","MARTH","MARGENE","MADELAINE","LONDA","LEONTINE","LEOMA","LEIA","LAWRENCE","LAURALEE","LANORA","LAKITA","KIYOKO","KETURAH","KATELIN","KAREEN","JONIE","JOHNETTE","JENEE","JEANETT","IZETTA","HIEDI","HEIKE","HASSIE","HAROLD","GIUSEPPINA","GEORGANN","FIDELA","FERNANDE","ELWANDA","ELLAMAE","ELIZ","DUSTI","DOTTY","CYNDY","CORALIE","CELESTA","ARGENTINA","ALVERTA","XENIA","WAVA","VANETTA","TORRIE","TASHINA","TANDY","TAMBRA","TAMA","STEPANIE","SHILA","SHAUNTA","SHARAN","SHANIQUA","SHAE","SETSUKO","SERAFINA","SANDEE","ROSAMARIA","PRISCILA","OLINDA","NADENE","MUOI","MICHELINA","MERCEDEZ","MARYROSE","MARIN","MARCENE","MAO","MAGALI","MAFALDA","LOGAN","LINN","LANNIE","KAYCE","KAROLINE","KAMILAH","KAMALA","JUSTA","JOLINE","JENNINE","JACQUETTA","IRAIDA","GERALD","GEORGEANNA","FRANCHESCA","FAIRY","EMELINE","ELANE","EHTEL","EARLIE","DULCIE","DALENE","CRIS","CLASSIE","CHERE","CHARIS","CAROYLN","CARMINA","CARITA","BRIAN","BETHANIE","AYAKO","ARICA","AN","ALYSA","ALESSANDRA","AKILAH","ADRIEN","ZETTA","YOULANDA","YELENA","YAHAIRA","XUAN","WENDOLYN","VICTOR","TIJUANA","TERRELL","TERINA","TERESIA","SUZI","SUNDAY","SHERELL","SHAVONDA","SHAUNTE","SHARDA","SHAKITA","SENA","RYANN","RUBI","RIVA","REGINIA","REA","RACHAL","PARTHENIA","PAMULA","MONNIE","MONET","MICHAELE","MELIA","MARINE","MALKA","MAISHA","LISANDRA","LEO","LEKISHA","LEAN","LAURENCE","LAKENDRA","KRYSTIN","KORTNEY","KIZZIE","KITTIE","KERA","KENDAL","KEMBERLY","KANISHA","JULENE","JULE","JOSHUA","JOHANNE","JEFFREY","JAMEE","HAN","HALLEY","GIDGET","GALINA","FREDRICKA","FLETA","FATIMAH","EUSEBIA","ELZA","ELEONORE","DORTHEY","DORIA","DONELLA","DINORAH","DELORSE","CLARETHA","CHRISTINIA","CHARLYN","BONG","BELKIS","AZZIE","ANDERA","AIKO","ADENA","YER","YAJAIRA","WAN","VANIA","ULRIKE","TOSHIA","TIFANY","STEFANY","SHIZUE","SHENIKA","SHAWANNA","SHAROLYN","SHARILYN","SHAQUANA","SHANTAY","SEE","ROZANNE","ROSELEE","RICKIE","REMONA","REANNA","RAELENE","QUINN","PHUNG","PETRONILA","NATACHA","NANCEY","MYRL","MIYOKO","MIESHA","MERIDETH","MARVELLA","MARQUITTA","MARHTA","MARCHELLE","LIZETH","LIBBIE","LAHOMA","LADAWN","KINA","KATHELEEN","KATHARYN","KARISA","KALEIGH","JUNIE","JULIEANN","JOHNSIE","JANEAN","JAIMEE","JACKQUELINE","HISAKO","HERMA","HELAINE","GWYNETH","GLENN","GITA","EUSTOLIA","EMELINA","ELIN","EDRIS","DONNETTE","DONNETTA","DIERDRE","DENAE","DARCEL","CLAUDE","CLARISA","CINDERELLA","CHIA","CHARLESETTA","CHARITA","CELSA","CASSY","CASSI","CARLEE","BRUNA","BRITTANEY","BRANDE","BILLI","BAO","ANTONETTA","ANGLA","ANGELYN","ANALISA","ALANE","WENONA","WENDIE","VERONIQUE","VANNESA","TOBIE","TEMPIE","SUMIKO","SULEMA","SPARKLE","SOMER","SHEBA","SHAYNE","SHARICE","SHANEL","SHALON","SAGE","ROY","ROSIO","ROSELIA","RENAY","REMA","REENA","PORSCHE","PING","PEG","OZIE","ORETHA","ORALEE","ODA","NU","NGAN","NAKESHA","MILLY","MARYBELLE","MARLIN","MARIS","MARGRETT","MARAGARET","MANIE","LURLENE","LILLIA","LIESELOTTE","LAVELLE","LASHAUNDA","LAKEESHA","KEITH","KAYCEE","KALYN","JOYA","JOETTE","JENAE","JANIECE","ILLA","GRISEL","GLAYDS","GENEVIE","GALA","FREDDA","FRED","ELMER","ELEONOR","DEBERA","DEANDREA","DAN","CORRINNE","CORDIA","CONTESSA","COLENE","CLEOTILDE","CHARLOTT","CHANTAY","CECILLE","BEATRIS","AZALEE","ARLEAN","ARDATH","ANJELICA","ANJA","ALFREDIA","ALEISHA","ADAM","ZADA","YUONNE","XIAO","WILLODEAN","WHITLEY","VENNIE","VANNA","TYISHA","TOVA","TORIE","TONISHA","TILDA","TIEN","TEMPLE","SIRENA","SHERRIL","SHANTI","SHAN","SENAIDA","SAMELLA","ROBBYN","RENDA","REITA","PHEBE","PAULITA","NOBUKO","NGUYET","NEOMI","MOON","MIKAELA","MELANIA","MAXIMINA","MARG","MAISIE","LYNNA","LILLI","LAYNE","LASHAUN","LAKENYA","LAEL","KIRSTIE","KATHLINE","KASHA","KARLYN","KARIMA","JOVAN","JOSEFINE","JENNELL","JACQUI","JACKELYN","HYO","HIEN","GRAZYNA","FLORRIE","FLORIA","ELEONORA","DWANA","DORLA","DONG","DELMY","DEJA","DEDE","DANN","CRYSTA","CLELIA","CLARIS","CLARENCE","CHIEKO","CHERLYN","CHERELLE","CHARMAIN","CHARA","CAMMY","BEE","ARNETTE","ARDELLE","ANNIKA","AMIEE","AMEE","ALLENA","YVONE","YUKI","YOSHIE","YEVETTE","YAEL","WILLETTA","VONCILE","VENETTA","TULA","TONETTE","TIMIKA","TEMIKA","TELMA","TEISHA","TAREN","TA","STACEE","SHIN","SHAWNTA","SATURNINA","RICARDA","POK","PASTY","ONIE","NUBIA","MORA","MIKE","MARIELLE","MARIELLA","MARIANELA","MARDELL","MANY","LUANNA","LOISE","LISABETH","LINDSY","LILLIANA","LILLIAM","LELAH","LEIGHA","LEANORA","LANG","KRISTEEN","KHALILAH","KEELEY","KANDRA","JUNKO","JOAQUINA","JERLENE","JANI","JAMIKA","JAME","HSIU","HERMILA","GOLDEN","GENEVIVE","EVIA","EUGENA","EMMALINE","ELFREDA","ELENE","DONETTE","DELCIE","DEEANNA","DARCEY","CUC","CLARINDA","CIRA","CHAE","CELINDA","CATHERYN","CATHERIN","CASIMIRA","CARMELIA","CAMELLIA","BREANA","BOBETTE","BERNARDINA","BEBE","BASILIA","ARLYNE","AMAL","ALAYNA","ZONIA","ZENIA","YURIKO","YAEKO","WYNELL","WILLOW","WILLENA","VERNIA","TU","TRAVIS","TORA","TERRILYN","TERICA","TENESHA","TAWNA","TAJUANA","TAINA","STEPHNIE","SONA","SOL","SINA","SHONDRA","SHIZUKO","SHERLENE","SHERICE","SHARIKA","ROSSIE","ROSENA","RORY","RIMA","RIA","RHEBA","RENNA","PETER","NATALYA","NANCEE","MELODI","MEDA","MAXIMA","MATHA","MARKETTA","MARICRUZ","MARCELENE","MALVINA","LUBA","LOUETTA","LEIDA","LECIA","LAURAN","LASHAWNA","LAINE","KHADIJAH","KATERINE","KASI","KALLIE","JULIETTA","JESUSITA","JESTINE","JESSIA","JEREMY","JEFFIE","JANYCE","ISADORA","GEORGIANNE","FIDELIA","EVITA","EURA","EULAH","ESTEFANA","ELSY","ELIZABET","ELADIA","DODIE","DION","DIA","DENISSE","DELORAS","DELILA","DAYSI","DAKOTA","CURTIS","CRYSTLE","CONCHA","COLBY","CLARETTA","CHU","CHRISTIA","CHARLSIE","CHARLENA","CARYLON","BETTYANN","ASLEY","ASHLEA","AMIRA","AI","AGUEDA","AGNUS","YUETTE","VINITA","VICTORINA","TYNISHA","TREENA","TOCCARA","TISH","THOMASENA","TEGAN","SOILA","SHILOH","SHENNA","SHARMAINE","SHANTAE","SHANDI","SEPTEMBER","SARAN","SARAI","SANA","SAMUEL","SALLEY","ROSETTE","ROLANDE","REGINE","OTELIA","OSCAR","OLEVIA","NICHOLLE","NECOLE","NAIDA","MYRTA","MYESHA","MITSUE","MINTA","MERTIE","MARGY","MAHALIA","MADALENE","LOVE","LOURA","LOREAN","LEWIS","LESHA","LEONIDA","LENITA","LAVONE","LASHELL","LASHANDRA","LAMONICA","KIMBRA","KATHERINA","KARRY","KANESHA","JULIO","JONG","JENEVA","JAQUELYN","HWA","GILMA","GHISLAINE","GERTRUDIS","FRANSISCA","FERMINA","ETTIE","ETSUKO","ELLIS","ELLAN","ELIDIA","EDRA","DORETHEA","DOREATHA","DENYSE","DENNY","DEETTA","DAINE","CYRSTAL","CORRIN","CAYLA","CARLITA","CAMILA","BURMA","BULA","BUENA","BLAKE","BARABARA","AVRIL","AUSTIN","ALAINE","ZANA","WILHEMINA","WANETTA","VIRGIL","VI","VERONIKA","VERNON","VERLINE","VASILIKI","TONITA","TISA","TEOFILA","TAYNA","TAUNYA","TANDRA","TAKAKO","SUNNI","SUANNE","SIXTA","SHARELL","SEEMA","RUSSELL","ROSENDA","ROBENA","RAYMONDE","PEI","PAMILA","OZELL","NEIDA","NEELY","MISTIE","MICHA","MERISSA","MAURITA","MARYLN","MARYETTA","MARSHALL","MARCELL","MALENA","MAKEDA","MADDIE","LOVETTA","LOURIE","LORRINE","LORILEE","LESTER","LAURENA","LASHAY","LARRAINE","LAREE","LACRESHA","KRISTLE","KRISHNA","KEVA","KEIRA","KAROLE","JOIE","JINNY","JEANNETTA","JAMA","HEIDY","GILBERTE","GEMA","FAVIOLA","EVELYNN","ENDA","ELLI","ELLENA","DIVINA","DAGNY","COLLENE","CODI","CINDIE","CHASSIDY","CHASIDY","CATRICE","CATHERINA","CASSEY","CAROLL","CARLENA","CANDRA","CALISTA","BRYANNA","BRITTENY","BEULA","BARI","AUDRIE","AUDRIA","ARDELIA","ANNELLE","ANGILA","ALONA","ALLYN","DOUGLAS","ROGER","JONATHAN","RALPH","NICHOLAS","BENJAMIN","BRUCE","HARRY","WAYNE","STEVE","HOWARD","ERNEST","PHILLIP","TODD","CRAIG","ALAN","PHILIP","EARL","DANNY","BRYAN","STANLEY","LEONARD","NATHAN","MANUEL","RODNEY","MARVIN","VINCENT","JEFFERY","JEFF","CHAD","JACOB","ALFRED","BRADLEY","HERBERT","FREDERICK","EDWIN","DON","RICKY","RANDALL","BARRY","BERNARD","LEROY","MARCUS","THEODORE","CLIFFORD","MIGUEL","JIM","TOM","CALVIN","BILL","LLOYD","DEREK","WARREN","DARRELL","JEROME","FLOYD","ALVIN","TIM","GORDON","GREG","JORGE","DUSTIN","PEDRO","DERRICK","ZACHARY","HERMAN","GLEN","HECTOR","RICARDO","RICK","BRENT","RAMON","GILBERT","MARC","REGINALD","RUBEN","NATHANIEL","RAFAEL","EDGAR","MILTON","RAUL","BEN","CHESTER","DUANE","FRANKLIN","BRAD","RON","ROLAND","ARNOLD","HARVEY","JARED","ERIK","DARRYL","NEIL","JAVIER","FERNANDO","CLINTON","TED","MATHEW","TYRONE","DARREN","LANCE","KURT","ALLAN","NELSON","GUY","CLAYTON","HUGH","MAX","DWAYNE","DWIGHT","ARMANDO","FELIX","EVERETT","IAN","WALLACE","KEN","BOB","ALFREDO","ALBERTO","DAVE","IVAN","BYRON","ISAAC","MORRIS","CLIFTON","WILLARD","ROSS","ANDY","SALVADOR","KIRK","SERGIO","SETH","KENT","TERRANCE","EDUARDO","TERRENCE","ENRIQUE","WADE","STUART","FREDRICK","ARTURO","ALEJANDRO","NICK","LUTHER","WENDELL","JEREMIAH","JULIUS","OTIS","TREVOR","OLIVER","LUKE","HOMER","GERARD","DOUG","KENNY","HUBERT","LYLE","MATT","ALFONSO","ORLANDO","REX","CARLTON","ERNESTO","NEAL","PABLO","LORENZO","OMAR","WILBUR","GRANT","HORACE","RODERICK","ABRAHAM","WILLIS","RICKEY","ANDRES","CESAR","JOHNATHAN","MALCOLM","RUDOLPH","DAMON","KELVIN","PRESTON","ALTON","ARCHIE","MARCO","WM","PETE","RANDOLPH","GARRY","GEOFFREY","JONATHON","FELIPE","GERARDO","ED","DOMINIC","DELBERT","COLIN","GUILLERMO","EARNEST","LUCAS","BENNY","SPENCER","RODOLFO","MYRON","EDMUND","GARRETT","SALVATORE","CEDRIC","LOWELL","GREGG","SHERMAN","WILSON","SYLVESTER","ROOSEVELT","ISRAEL","JERMAINE","FORREST","WILBERT","LELAND","SIMON","CLARK","IRVING","BRYANT","OWEN","RUFUS","WOODROW","KRISTOPHER","MACK","LEVI","MARCOS","GUSTAVO","JAKE","LIONEL","GILBERTO","CLINT","NICOLAS","ISMAEL","ORVILLE","ERVIN","DEWEY","AL","WILFRED","JOSH","HUGO","IGNACIO","CALEB","TOMAS","SHELDON","ERICK","STEWART","DOYLE","DARREL","ROGELIO","TERENCE","SANTIAGO","ALONZO","ELIAS","BERT","ELBERT","RAMIRO","CONRAD","NOAH","GRADY","PHIL","CORNELIUS","LAMAR","ROLANDO","CLAY","PERCY","DEXTER","BRADFORD","DARIN","AMOS","MOSES","IRVIN","SAUL","ROMAN","RANDAL","TIMMY","DARRIN","WINSTON","BRENDAN","ABEL","DOMINICK","BOYD","EMILIO","ELIJAH","DOMINGO","EMMETT","MARLON","EMANUEL","JERALD","EDMOND","EMIL","DEWAYNE","WILL","OTTO","TEDDY","REYNALDO","BRET","JESS","TRENT","HUMBERTO","EMMANUEL","STEPHAN","VICENTE","LAMONT","GARLAND","MILES","EFRAIN","HEATH","RODGER","HARLEY","ETHAN","ELDON","ROCKY","PIERRE","JUNIOR","FREDDY","ELI","BRYCE","ANTOINE","STERLING","CHASE","GROVER","ELTON","CLEVELAND","DYLAN","CHUCK","DAMIAN","REUBEN","STAN","AUGUST","LEONARDO","JASPER","RUSSEL","ERWIN","BENITO","HANS","MONTE","BLAINE","ERNIE","CURT","QUENTIN","AGUSTIN","MURRAY","JAMAL","ADOLFO","HARRISON","TYSON","BURTON","BRADY","ELLIOTT","WILFREDO","BART","JARROD","VANCE","DENIS","DAMIEN","JOAQUIN","HARLAN","DESMOND","ELLIOT","DARWIN","GREGORIO","BUDDY","XAVIER","KERMIT","ROSCOE","ESTEBAN","ANTON","SOLOMON","SCOTTY","NORBERT","ELVIN","WILLIAMS","NOLAN","ROD","QUINTON","HAL","BRAIN","ROB","ELWOOD","KENDRICK","DARIUS","MOISES","FIDEL","THADDEUS","CLIFF","MARCEL","JACKSON","RAPHAEL","BRYON","ARMAND","ALVARO","JEFFRY","DANE","JOESPH","THURMAN","NED","RUSTY","MONTY","FABIAN","REGGIE","MASON","GRAHAM","ISAIAH","VAUGHN","GUS","LOYD","DIEGO","ADOLPH","NORRIS","MILLARD","ROCCO","GONZALO","DERICK","RODRIGO","WILEY","RIGOBERTO","ALPHONSO","TY","NOE","VERN","REED","JEFFERSON","ELVIS","BERNARDO","MAURICIO","HIRAM","DONOVAN","BASIL","RILEY","NICKOLAS","MAYNARD","SCOT","VINCE","QUINCY","EDDY","SEBASTIAN","FEDERICO","ULYSSES","HERIBERTO","DONNELL","COLE","DAVIS","GAVIN","EMERY","WARD","ROMEO","JAYSON","DANTE","CLEMENT","COY","MAXWELL","JARVIS","BRUNO","ISSAC","DUDLEY","BROCK","SANFORD","CARMELO","BARNEY","NESTOR","STEFAN","DONNY","ART","LINWOOD","BEAU","WELDON","GALEN","ISIDRO","TRUMAN","DELMAR","JOHNATHON","SILAS","FREDERIC","DICK","IRWIN","MERLIN","CHARLEY","MARCELINO","HARRIS","CARLO","TRENTON","KURTIS","HUNTER","AURELIO","WINFRED","VITO","COLLIN","DENVER","CARTER","LEONEL","EMORY","PASQUALE","MOHAMMAD","MARIANO","DANIAL","LANDON","DIRK","BRANDEN","ADAN","BUFORD","GERMAN","WILMER","EMERSON","ZACHERY","FLETCHER","JACQUES","ERROL","DALTON","MONROE","JOSUE","EDWARDO","BOOKER","WILFORD","SONNY","SHELTON","CARSON","THERON","RAYMUNDO","DAREN","HOUSTON","ROBBY","LINCOLN","GENARO","BENNETT","OCTAVIO","CORNELL","HUNG","ARRON","ANTONY","HERSCHEL","GIOVANNI","GARTH","CYRUS","CYRIL","RONNY","LON","FREEMAN","DUNCAN","KENNITH","CARMINE","ERICH","CHADWICK","WILBURN","RUSS","REID","MYLES","ANDERSON","MORTON","JONAS","FOREST","MITCHEL","MERVIN","ZANE","RICH","JAMEL","LAZARO","ALPHONSE","RANDELL","MAJOR","JARRETT","BROOKS","ABDUL","LUCIANO","SEYMOUR","EUGENIO","MOHAMMED","VALENTIN","CHANCE","ARNULFO","LUCIEN","FERDINAND","THAD","EZRA","ALDO","RUBIN","ROYAL","MITCH","EARLE","ABE","WYATT","MARQUIS","LANNY","KAREEM","JAMAR","BORIS","ISIAH","EMILE","ELMO","ARON","LEOPOLDO","EVERETTE","JOSEF","ELOY","RODRICK","REINALDO","LUCIO","JERROD","WESTON","HERSHEL","BARTON","PARKER","LEMUEL","BURT","JULES","GIL","ELISEO","AHMAD","NIGEL","EFREN","ANTWAN","ALDEN","MARGARITO","COLEMAN","DINO","OSVALDO","LES","DEANDRE","NORMAND","KIETH","TREY","NORBERTO","NAPOLEON","JEROLD","FRITZ","ROSENDO","MILFORD","CHRISTOPER","ALFONZO","LYMAN","JOSIAH","BRANT","WILTON","RICO","JAMAAL","DEWITT","BRENTON","OLIN","FOSTER","FAUSTINO","CLAUDIO","JUDSON","GINO","EDGARDO","ALEC","TANNER","JARRED","DONN","TAD","PRINCE","PORFIRIO","ODIS","LENARD","CHAUNCEY","TOD","MEL","MARCELO","KORY","AUGUSTUS","KEVEN","HILARIO","BUD","SAL","ORVAL","MAURO","ZACHARIAH","OLEN","ANIBAL","MILO","JED","DILLON","AMADO","NEWTON","LENNY","RICHIE","HORACIO","BRICE","MOHAMED","DELMER","DARIO","REYES","MAC","JONAH","JERROLD","ROBT","HANK","RUPERT","ROLLAND","KENTON","DAMION","ANTONE","WALDO","FREDRIC","BRADLY","KIP","BURL","WALKER","TYREE","JEFFEREY","AHMED","WILLY","STANFORD","OREN","NOBLE","MOSHE","MIKEL","ENOCH","BRENDON","QUINTIN","JAMISON","FLORENCIO","DARRICK","TOBIAS","HASSAN","GIUSEPPE","DEMARCUS","CLETUS","TYRELL","LYNDON","KEENAN","WERNER","GERALDO","COLUMBUS","CHET","BERTRAM","MARKUS","HUEY","HILTON","DWAIN","DONTE","TYRON","OMER","ISAIAS","HIPOLITO","FERMIN","ADALBERTO","BO","BARRETT","TEODORO","MCKINLEY","MAXIMO","GARFIELD","RALEIGH","LAWERENCE","ABRAM","RASHAD","KING","EMMITT","DARON","SAMUAL","MIQUEL","EUSEBIO","DOMENIC","DARRON","BUSTER","WILBER","RENATO","JC","HOYT","HAYWOOD","EZEKIEL","CHAS","FLORENTINO","ELROY","CLEMENTE","ARDEN","NEVILLE","EDISON","DESHAWN","NATHANIAL","JORDON","DANILO","CLAUD","SHERWOOD","RAYMON","RAYFORD","CRISTOBAL","AMBROSE","TITUS","HYMAN","FELTON","EZEQUIEL","ERASMO","STANTON","LONNY","LEN","IKE","MILAN","LINO","JAROD","HERB","ANDREAS","WALTON","RHETT","PALMER","DOUGLASS","CORDELL","OSWALDO","ELLSWORTH","VIRGILIO","TONEY","NATHANAEL","DEL","BENEDICT","MOSE","JOHNSON","ISREAL","GARRET","FAUSTO","ASA","ARLEN","ZACK","WARNER","MODESTO","FRANCESCO","MANUAL","GAYLORD","GASTON","FILIBERTO","DEANGELO","MICHALE","GRANVILLE","WES","MALIK","ZACKARY","TUAN","ELDRIDGE","CRISTOPHER","CORTEZ","ANTIONE","MALCOM","LONG","KOREY","JOSPEH","COLTON","WAYLON","VON","HOSEA","SHAD","SANTO","RUDOLF","ROLF","REY","RENALDO","MARCELLUS","LUCIUS","KRISTOFER","BOYCE","BENTON","HAYDEN","HARLAND","ARNOLDO","RUEBEN","LEANDRO","KRAIG","JERRELL","JEROMY","HOBERT","CEDRICK","ARLIE","WINFORD","WALLY","LUIGI","KENETH","JACINTO","GRAIG","FRANKLYN","EDMUNDO","SID","PORTER","LEIF","JERAMY","BUCK","WILLIAN","VINCENZO","SHON","LYNWOOD","JERE","HAI","ELDEN","DORSEY","DARELL","BRODERICK","ALONSO"batteries-included-3.4.0/examples/pleac/000077500000000000000000000000001415601150500201655ustar00rootroot00000000000000batteries-included-3.4.0/examples/pleac/strings.ml000066400000000000000000000653301415601150500222170ustar00rootroot00000000000000(*** Chapter 1 of PLEAC rewritten for OCaml Batteries Included. Note: to obtain Unicode version replace every occurrence of [String] with [Rope] and prepend [u] before any string literal. *) (** {3 Strings}*) (** {4 Introduction}*) open String (*---------------------------*) let string = "\\n" (* two characters, \ and an n*) let string = "Jon 'Maddog' Orwant" (* literal single quotes*) (*---------------------------*) let string = "\n" (* a "newline" character *) let string = "Jon \"Maddog\" Orwant" (* literal double quotes *) let a = " This is a multiline here document terminated by one double quote " (** {4 Accessing Substrings}*) let value offset count = sub string offset count let value offset count = sub string offset (length string - offset) (* or *) let value offset = right string offset (*-----------------------------*) (* get a 5-byte string, skip 3, then grab 2 8-byte strings, then the rest*) let foo s = open Enum in let e = enum s in [? List : of_enum (f e) | f <- List : [take 5; skip 3 |- take 5; take 5 ; identity]] (* split at 'sz' byte boundaries *) let split_every_n_chars sz s = open Enum in let e = enum s in from_while (fun _ -> if is_empty e then None else Some ( String.of_enum (take sz e) )) let fivers = split_every_n_chars 5 string (* chop string into individual characters *) let chars = explode string (*-----------------------------*) let string = "This is what you have";; (* Indexes are left to right. There is no possibility to index *) (* directly from right to left *) (* "T" *) let first = slice string ~first:0 ~last:1 (* "is" *) let start = slice string ~last:4 ~first:2 (* "you have" *) let rest = tail string 13 (* "e" *) let last = right string 1 (* "have" *) let theend = right string 4 (* "you" *) let piece = slice string ~first:(-8) ~last:(-5) (*-----------------------------*) let string = "This is what you have";; print_endline string (*This is what you have*) (* Change "is" to "wasn't"*) let string = splice string 5 2 "wasn't" (*This wasn't what you have *) (*This wasn't wonderous *) let string = splice string (-11) max_int "ondrous";; (* delete first character *) let string = lchop string (*his wasn't wondrous*) (* delete last 10 characters *) let string = String.sub string 0 (String.length string - 10);; (*his wasn'*) (*-----------------------------*) (**{4 Testing substrings}*) (* (**{4 Establishing a Default Value}*) (* Because OCaml doesn't have the same notion of truth or definedness as Perl, * most of these examples just can't be done as they are in Perl. Some can be * approximated via the use of options, but remember, unbound variables are not * automatically assigned the value of None -- the variable has to have been * explicitly bound to None (or Some x) beforehand. *) (* use b if b is not None, else use c *) let a = match b with None -> c | _ -> b;; (* set x to y if x is currently None *) let x = match x with None -> y | _ -> x;; (* Note that these are much closer to Perls notion of definedness than truth *) (* We can set foo to either bar or "DEFAULT VALUE" in one of two ways *) (* keep foo as a string option *) let foo = match bar with Some x -> bar | _ -> Some "DEFAULT VALUE";; (* Use foo as a string *) let foo = match bar with Some x -> x | _ -> "DEFAULT VALUE";; let dir = if Array.length Sys.argv > 1 then argv.(1) else "/tmp";; (* None of the other examples really make sense in OCaml terms... *) Exchanging Values Without Using Temporary Variables (*-----------------------------*) let var1, var2 = var2, var1 (*-----------------------------*) let temp = a let a = b let b = temp (*-----------------------------*) let a = "alpha" let b = "omega" let a, b = b, a (* the first shall be last -- and versa vice *) (*-----------------------------*) let alpha, beta, production = "January", "March", "August" (* move beta to alpha, * move production to beta, * move alpha to production *) let alpha, beta, production = beta, production, alpha (*-----------------------------*) Converting Between ASCII Characters and Values (*-----------------------------*) let num = Char.code char let char = Char.chr num (*-----------------------------*) (* char and int are distinct datatypes in OCaml *) printf "Number %d is character %c\n" num (Char.chr num) (* Number 101 is character e *) (*-----------------------------*) (* convert string to list of chars *) let explode s = let rec f acc = function | -1 -> acc | k -> f (s.[k] :: acc) (k - 1) in f [] (String.length s - 1) (* convert list of chars to string *) let implode l = let s = String.create (List.length l) in let rec f n = function | x :: xs -> s.[n] <- x; f (n + 1) xs | [] -> s in f 0 l (* ascii is list of ints. *) let ascii = List.map Char.code (explode string) let string = implode (List.map Char.ord ascii) (*-----------------------------*) let ascii_value = Char.code 'e' (* now 101 *) let character = Char.chr 101 (* now 'e' *) (*-----------------------------*) printf "Number %d is character %c\n" 101 (Char.chr 101) (*-----------------------------*) let ascii_character_numbers = List.map Char.code (explode "sample");; List.iter (printf "%d ") ascii_character_numbers; printf "\n" 115 97 109 112 108 101 let word = implode (List.map Char.chr ascii_character_numbers) let word = implode (List.map Char.chr [115; 97; 109; 112; 108; 101]);; (* same *) printf "%s\n" word sample (*-----------------------------*) let hal = "HAL" let ascii = List.map Char.code (explode hal) let ascii = List.map (( + ) 1) ascii (* add one to each ASCII value *) let ibm = implode (List.map Char.chr ascii);; printf "%s\n" ibm (* prints "IBM" *) (*-----------------------------*) Processing a String One Character at a Time (* One can split a string into an array of character, or corresponding ASCII * codes as follows, but this is not necessary to process the strings a * character at a time: *) let array_of_chars = Array.init (String.length s) (fun i -> s.[i]);; let array_of_codes = Array.init (String.length s) (fun i -> Char.code s.[i]);; (* or one can just use String.iter *) String.iter (fun i -> (*do something with s.[i], the ith char of the string*)) s;; (* The following function can be used to return a list of all unique keys in a * hashtable *) let keys h = let k = Hashtbl.fold (fun k v b -> k::b) h [] in (* filter out duplicates *) List.fold_left (fun b x -> if List.mem x b then b else x::b) [] k;; (* and this function is a shorthand for adding a key,value pair to a hashtable *) let ( <<+ ) h (k,v) = Hashtbl.add h k v;; let seen = Hashtbl.create 13;; let s = "an apple a day";; let array_of_chars = Array.init (String.length s) (fun i -> s.[i]);; Array.iter (fun x -> seen <<+ (x,1)) array_of_chars; print_string "unique chars are:\t"; List.iter print_char (List.sort compare (keys seen)); print_newline ();; (* or, without the unnecessary and innefficient step of converting the string * into an array of chars *) let seen = Hashtbl.create 13;; let s = "an apple a day";; String.iter (fun x -> seen <<+ (x,1)) s; print_string "unique chars are:\t"; List.iter print_char (List.sort compare (keys seen)); print_newline ();; (* To compute the simple 31-bit checksum of a string *) let cksum s = let sum = ref 0 in String.iter (fun x -> sum := !sum + (Char.code x)) s; !sum;; (* # cksum "an apple a day";; - : int = 1248 *) (* to emulate the SysV 16-bit checksum, we will first write two routines sort of * similar to Perl's (<>), that will return the contents of a file either as a * list of strings or as a single string - not that the list of strings version * throws away the \n at the end of each line *) let slurp_to_list filename = let ic = open_in filename and l = ref [] in let rec loop () = let line = input_line ic in l := line::!l; loop () in try loop () with End_of_file -> close_in ic; List.rev !l;; let slurp_to_string filename = let ic = open_in filename and buf = Buffer.create 4096 in let rec loop () = let line = input_line ic in Buffer.add_string buf line; Buffer.add_string buf "\n"; loop () in try loop () with End_of_file -> close_in ic; Buffer.contents buf;; let cksum16 fn = let addString sum s = let sm = ref sum in String.iter (fun c -> sm := !sm + (Char.code c)) (s ^ "\n"); !sm mod 65537 (* 2^16 - 1 *)in List.fold_left addString 0 (slurp_to_list fn);; (* or *) let cksum16 fn = let sum = ref 0 and s = slurp_to_string fn in String.iter (fun c -> sum := (!sum + (Char.code c)) mod 65537) s; !sum;; (* Note: slowcat as written is meant to be run from the command line, not in the * toplevel *) #!/usr/local/bin/ocaml (* slowcat - emulate a s l o w line printer *) (* usage: slowcat [-DELAY] [files ...] *) #load "unix.cma";; (* make sure you have the code for the slurp_to_string function in this file as * well... *) let _ = let delay,fs = try (float_of_string Sys.argv.(1)),2 with Failure _ -> 1.,1 in let files = Array.sub Sys.argv fs (Array.length Sys.argv - fs) in let print_file f = let s = slurp_to_string f in String.iter (fun c -> print_char c; ignore(Unix.select [] [] [] (0.005 *. delay))) s in Array.iter print_file files;; Reversing a String by Word or Character (* To flip the characters of a string, we can use a for loop. * Note that this version does not destructively update the string *) let reverse s = let len = String.length s - 1 in let s' = String.create (len + 1) in for i = 0 to len do s'.[i] <- s.[len - i] done; s';; (* to modify the string in place, we can use the following function *) let reverse_in_place s = let len = String.length s - 1 in for i = 0 to (len + 1)/ 2 - 1 do let t = s.[i] in s.[i] <- s.[len - i]; s.[len - i] <- t done;; (* To reverse the words in a string, we can use String.concat, Str.split and * List.rev. Note that this requires us to load in the Str module -- * use `#load "str.cma"' in* the toplevel, or be sure to include str.cma in the * list of object files when compiling your code. E.g.: * ocamlc other options str.cma other files -or- * ocamlopt other options str.cmxa other files *) let reverse_words s = String.concat " " (List.rev (Str.split (Str.regexp " ") s));; let is_palindrome s = s = reverse s;; (* We do need to do a bit more work that Perl to find the big palindromes in * /usr/share/dict/words ... *) let findBigPals () = let words = open_in "/usr/share/dict/words" in let rec loop () = let w = input_line words in if String.length w > 5 && w = reverse w then print_endline w; loop () in try loop () with End_of_file -> close_in words;; Expanding and Compressing Tabs let expand_tabs ?(spaces = 8) s = Str.global_replace (Str.regexp "\t") (String.make spaces ' ') s;; let compress_tabs ?(spaces = 8) s = Str.global_replace (Str.regexp (String.make spaces ' ')) "\t" s;; (* # let st = "\tyo baby!\n\t\tWhat the shizzle?\t(Mack)";; val st : string = "\tyo baby!\n\t\tWhat the shizzle?\t(Mack)" # let etst = expand_tabs st;; val etst : string = " yo baby!\n What the shizzle? (Mack)" # let etst = expand_tabs ~spaces:4 st;; val etst : string = " yo baby!\n What the shizzle? (Mack)" # let etst = expand_tabs ~spaces:8 st;; val etst : string = " yo baby!\n What the shizzle? (Mack)" # let rest = compress_tabs etst;; val rest : string = "\tyo baby!\n\t\tWhat the shizzle?\t(Mack)" # let rest = compress_tabs ~spaces:4 etst;; val rest : string = "\t\tyo baby!\n\t\t\t\tWhat the shizzle?\t\t(Mack)" # let rest = compress_tabs ~spaces:3 etst;; val rest : string = "\t\t yo baby!\n\t\t\t\t\t What the shizzle?\t\t (Mack)" *) Expanding Variables in User Input (* As far as I know there is no way to do this in OCaml due to type-safety constraints built into the OCaml compiler -- it may be feasible with *much* juju, but don't expect to see this anytime soon... If you don't mind supplying a data structure rather than capturing local variables, you can use Buffer.add_substitute to get a similar effect. *) let buffer = Buffer.create 16 let vars = [("debt", "$700 billion")] let () = Buffer.add_substitute buffer (fun name -> List.assoc name vars) "You owe $debt to me."; print_endline (Buffer.contents buffer) Controlling Case (* Just use the String module's uppercase, lowercase, capitalize and * uncapitalize *) let big = String.uppercase little;; (* "bo peep" -> "BO PEEP" *) let little = String.lowercase big;; (* "JOHN" -> "john" *) let big = String.capitalize little;; (* "bo" -> "Bo" *) let little = String.uncapitalize big;; (* "BoPeep" -> "boPeep" *) (* Capitalize each word's first character, downcase the rest *) let text = "thIS is a loNG liNE";; let text = String.capitalize (String.lowercase text);; print_endline text;; (* This is a long line *) (* To do case insensitive comparisons *) if String.uppercase a = String.uppercase b then print_endline "a and b are the same\n";; let randcap fn = let s = slurp_to_string fn in for i = 0 to String.length s - 1 do if Random.int 100 < 20 then String.blit (String.capitalize (String.sub s i 1)) 0 s i 1 done; print_string s;; (* # randcap "/etc/passwd";; ## # User DatAbAse # # Note That this fIle is consuLTed wHen the sysTeM Is runninG In single-user # modE. At other times this iNformAtion is handlEd by one or moRe oF: # lOokupD DIrectorYServicEs # By default, lOOkupd getS inFormaTion frOm NetInFo, so thiS fIle will # not be cOnsultEd unless you hAvE cHaNged LOokupd's COnfiguratiOn. # This fiLe is usEd while in siNgle UseR Mode. # # TO Use this file for noRmal aUthEnticatIon, you may eNable it With # /ApPlicatiOns/Utilities/DiRectory AccEss. ## < ... snip ... > *) Interpolating Functions and Expressions Within Strings (* Again, because of OCaml's type-safe nature, actual interpolation cannot be * done inside of strings -- one must use either string concatenation or sprintf * to get the results we're looking for *) let phrase = "I have " ^ (string_of_int (n+1)) ^ " guanacos.";; let prhase = sprintf "I have %d guanacos." (n+1);; Indenting Here Documents #load "str.cma";; let var = Str.global_replace (Str.regexp "^[\t ]+") "" "\ your text goes here ";; Reformatting Paragraphs (* We can emulate the Perl wrap function with the following function *) let wrap width s = let l = Str.split (Str.regexp " ") s in Format.pp_set_margin Format.str_formatter width; Format.pp_open_box Format.str_formatter 0; List.iter (fun x -> Format.pp_print_string Format.str_formatter x; Format.pp_print_break Format.str_formatter 1 0;) l; Format.flush_str_formatter ();; (* # let st = "May I say how lovely you are looking today... this wrapping has done wonders for your figure!\n";; val st : string = "May I say how lovely you are looking today... this wrapping has done wonders for your figure!\n" # print_string (wrap 50 st);; May I say how lovely you are looking today... this wrapping has done wonders for your figure! # print_string (wrap 30 st);; May I say how lovely you are looking today... this wrapping has done wonders for your figure! *) (* Note that this version doesn't allow you to specify an opening or standard * indentation (I am having trouble getting the Format module to behave as I * think it should...). However, if one only wants to print spaces there * instead of arbitrary line leaders, we can use the following version *) let wrap ?(lead=0) ?(indent=0) width s = let l = Str.split (Str.regexp " ") s in Format.pp_set_margin Format.str_formatter width; Format.pp_open_box Format.str_formatter 0; Format.pp_print_break Format.str_formatter lead indent; List.iter (fun x -> Format.pp_print_string Format.str_formatter x; Format.pp_print_break Format.str_formatter 1 indent;) l; Format.flush_str_formatter ();; (* # print_string (wrap 20 st);; May I say how lovely you are looking today... this wrapping has done wonders for your figure! - : unit = () # print_string (wrap ~lead:6 ~indent:2 20 st);; May I say how lovely you are looking today... this wrapping has done wonders for your figure! # print_string (wrap ~lead:2 20 st);; May I say how lovely you are looking today... this wrapping has done wonders for your figure! *) Escaping Characters (* ** The Str module is deistributed with the standard Ocaml compiler ** suit but it is not automatically pulled in by the command line ** interpreter or the compilers. ** ** The "#load" line is only needed if you are running this in the ** command interpreter. ** ** If you are using either of the ocaml compilers, you will need ** to remove the "#load" line and link in str.cmxa in the final ** compile command. *) #load "str.cma" ;; open Str let escape charlist str = let rx = Str.regexp ("\\([" ^ charlist ^ "]\\)") in Str.global_replace rx "\\\\\\1" str let text = "Mom said, \"Don't do that.\"" ;; print_endline text ;; let text = escape "'\"" text ;; print_endline text ;; Trimming Blanks from the Ends of a String let trim s = let s' = Str.replace_first (Str.regexp "^[ \t\n]+") "" s in Str.replace_first (Str.regexp "[ \t\n]+$") "" s';; let chop s = if s = "" then s else String.sub s 0 (String.length s - 1);; let chomp ?(c='\n') s = if s = "" then s else let len = String.length s - 1 in if s.[len] = c then String.sub s 0 len else s;; Parsing Comma-Separated Data let parse_csv = let regexp = Str.regexp (String.concat "\\|" [ "\"\\([^\"\\\\]*\\(\\\\.[^\"\\\\]*\\)*\\)\",?"; "\\([^,]+\\),?"; ","; ]) in fun text -> let rec loop start result = if Str.string_match regexp text start then let result = (try Str.matched_group 1 text with Not_found -> try Str.matched_group 3 text with Not_found -> "") :: result in loop (Str.match_end ()) result else result in List.rev ((if try String.rindex text ',' = String.length text - 1 with Not_found -> false then [""] else []) @ loop 0 []) let line = "XYZZY,\"\",\"O'Reilly, Inc\",\"Wall, Larry\",\"a \\\"glug\\\" bit,\",5,\"Error, Core Dumped\"" let () = Array.iteri (fun i x -> Printf.printf "%d : %s\n" i x) (Array.of_list (parse_csv line)) Soundex Matching let soundex = let code_1 = Char.code '1' in let code_A = Char.code 'A' in let code_Z = Char.code 'Z' in let trans = Array.make (code_Z - code_A + 1) 0 in let add_letters number letters = let add letter = trans.(Char.code letter - code_A) <- (number + code_1) in String.iter add letters in Array.iteri add_letters [| "BFPV"; "CGJKQSXZ"; "DT"; "L"; "MN"; "R" |]; fun ?(length=4) s -> let slength = String.length s in let soundex = String.make length '0' in let rec loop i j last = if i < slength && j < length then begin let code = Char.code (Char.uppercase s.[i]) in if code >= code_A && code <= code_Z then (if j = 0 then (soundex.[j] <- Char.chr code; loop (i + 1) (j + 1) trans.(code - code_A)) else (match trans.(code - code_A) with | 0 -> loop (i + 1) j 0 | code when code <> last -> soundex.[j] <- Char.chr code; loop (i + 1) (j + 1) code | _ -> loop (i + 1) j last)) else loop (i + 1) j last end in loop 0 0 0; soundex (*-----------------------------*) let code = soundex string;; let codes = List.map soundex list;; (*-----------------------------*) #load "str.cma" #load "unix.cma" let () = print_string "Lookup user: "; let user = read_line () in if user <> "" then begin let name_code = soundex user in let regexp = Str.regexp ("\\([a-zA-Z_0-9]+\\)[^,]*[^a-zA-Z_0-9]+" ^ "\\([a-zA-Z_0-9]+\\)") in let passwd = open_in "/etc/passwd" in try while true do let line = input_line passwd in let name = String.sub line 0 (String.index line ':') in let {Unix.pw_gecos=gecos} = Unix.getpwnam name in let (firstname, lastname) = if Str.string_match regexp gecos 0 then (Str.matched_group 1 gecos, Str.matched_group 2 gecos) else ("", "") in if (name_code = soundex name || name_code = soundex lastname || name_code = soundex firstname) then Printf.printf "%s: %s %s\n" name firstname lastname done with End_of_file -> close_in passwd end Program: fixstyle (* fixstyle - switch first set of data strings to second set *) #load "str.cma";; let data = Hashtbl.create 0 let keys = ref [] let () = let ( => ) key value = keys := key :: !keys; Hashtbl.replace data key value in ( "analysed" => "analyzed"; "built-in" => "builtin"; "chastized" => "chastised"; "commandline" => "command-line"; "de-allocate" => "deallocate"; "dropin" => "drop-in"; "hardcode" => "hard-code"; "meta-data" => "metadata"; "multicharacter" => "multi-character"; "multiway" => "multi-way"; "non-empty" => "nonempty"; "non-profit" => "nonprofit"; "non-trappable" => "nontrappable"; "pre-define" => "predefine"; "preextend" => "pre-extend"; "re-compiling" => "recompiling"; "reenter" => "re-enter"; "turnkey" => "turn-key"; ) let pattern_text = "\\(" ^ (String.concat "\\|" (List.map Str.quote !keys)) ^ "\\)" let pattern = Str.regexp pattern_text let args = ref (List.tl (Array.to_list Sys.argv)) let verbose = match !args with | "-v" :: rest -> args := rest; true | _ -> false let () = if !args = [] then (Printf.eprintf "%s: reading from stdin\n" Sys.argv.(0); args := ["-"]) let replace_all text line file = String.concat "" (List.map (function | Str.Text s -> s | Str.Delim s -> if verbose then Printf.eprintf "%s => %s at %s line %d.\n" s (Hashtbl.find data s) file line; Hashtbl.find data s) (Str.full_split pattern text)) let () = List.iter (fun file -> let in_channel = if file = "-" then stdin else open_in file in let line = ref 0 in try while true do let text = input_line in_channel in incr line; print_endline (replace_all text !line file) done with End_of_file -> close_in in_channel) !args Program: psgrep #!/usr/bin/ocaml (* psgrep - print selected lines of ps output by compiling user queries into code *) #load "unix.cma";; (* Warning: In order to closely approximate the original recipe, this example performs dynamic evaluation using the toplevel. This mechanism is undocumented and not type-safe. Use at your own risk. The "psgrep" utility, defined below, can be used to filter the results of the command-line "ps" program. Here are some examples: Processes whose command names start with "sh": % psgrep 'String.sub command 0 2 = "sh"' Processes running with a user ID below 10: % psgrep 'uid < 10' Login shells with active ttys: % psgrep "command.[0] = '-'" 'tty <> "?"' Processes running on pseudo-ttys: % psgrep 'String.contains "pqrst" tty.[0]' Non-superuser processes running detached: % psgrep 'uid > 0 && tty = "?"' Huge processes that aren't owned by the superuser: % psgrep 'vsz > 50000' 'uid <> 0' *) (* Eval recipe thanks to Clément Capel. *) let () = Toploop.initialize_toplevel_env () let eval text = let lexbuf = (Lexing.from_string text) in let phrase = !Toploop.parse_toplevel_phrase lexbuf in ignore (Toploop.execute_phrase false Format.std_formatter phrase) let get name = Obj.obj (Toploop.getvalue name) let set name value = Toploop.setvalue name (Obj.repr value) (* Type for "ps" results. *) type ps = {f : int; uid : int; pid : int; ppid : int; pri : int; ni : string; vsz : int; rss : int; wchan : string; stat : string; tty : string; time : string; command : string} (* Based on the GNU ps from Debian Linux. Other OSs will most likely require changes to this format. *) let parse_ps_line line = Scanf.sscanf line "%d %d %d %d %d %s %d %d %6s %4s %10s %4s %s@\000" (fun f uid pid ppid pri ni vsz rss wchan stat tty time command -> {f=f; uid=uid; pid=pid; ppid=ppid; pri=pri; ni=ni; vsz=vsz; rss=rss; wchan=wchan; stat=stat; tty=tty; time=time; command=command}) let eval_predicate ps pred = (* Use "eval" to initialize each variable's name and type, then use "set" to set a value. *) eval "let f = 0;;"; set "f" ps.f; eval "let uid = 0;;"; set "uid" ps.uid; eval "let pid = 0;;"; set "pid" ps.pid; eval "let ppid = 0;;"; set "ppid" ps.ppid; eval "let pri = 0;;"; set "pri" ps.pri; eval "let ni = \"\";;"; set "ni" ps.ni; eval "let vsz = 0;;"; set "vsz" ps.vsz; eval "let rss = 0;;"; set "rss" ps.rss; eval "let wchan = \"\";;"; set "wchan" ps.wchan; eval "let stat = \"\";;"; set "stat" ps.stat; eval "let tty = \"\";;"; set "tty" ps.tty; eval "let time = \"\";;"; set "time" ps.time; eval "let command = \"\";;"; set "command" ps.command; (* Evaluate expression and return result as boolean. *) eval ("let result = (" ^ pred ^ ");;"); (get "result" : bool) exception TypeError of string exception SyntaxError of string let preds = List.tl (Array.to_list Sys.argv) let () = if preds = [] then (Printf.eprintf "usage: %s criterion ... Each criterion is an OCaml expression involving: f uid pid ppid pri ni vsz rss wchan stat tty time command All criteria must be met for a line to be printed. " Sys.argv.(0); exit 0) let () = let proc = Unix.open_process_in "ps wwaxl" in try print_endline (input_line proc); while true do let line = input_line proc in let ps = parse_ps_line line in if List.for_all (fun pred -> try eval_predicate ps pred with e -> (* Convert exceptions to strings to avoid depending on additional toplevel libraries. *) match Printexc.to_string e with | "Typecore.Error(_, _)" -> raise (TypeError pred) | "Syntaxerr.Error(_)" | "Lexer.Error(1, _)" | "Lexer.Error(_, _)" -> raise (SyntaxError pred) | "Misc.Fatal_error" -> failwith pred | _ -> raise e) preds then print_endline line done with | End_of_file -> ignore (Unix.close_process_in proc) | e -> ignore (Unix.close_process_in proc); raise e *) batteries-included-3.4.0/examples/snippets/000077500000000000000000000000001415601150500207465ustar00rootroot00000000000000batteries-included-3.4.0/examples/snippets/_tags000066400000000000000000000001621415601150500217650ustar00rootroot00000000000000<*>: pkg_batteries, syntax_camlp4o, pkg_batteries.syntax, debug : pkg_netstring : threadbatteries-included-3.4.0/examples/snippets/accumulator.ml000066400000000000000000000015731415601150500236250ustar00rootroot00000000000000(*A problem I found some time ago on Paul Graham's website. "Revenge of the Nerds yielded a collection of canonical solutions to the same problem in a number of languages. The problem: Write a function foo that takes a number n and returns a function that takes a number i, and returns n incremented by i. Note: (a) that's number, not integer, (b) that's incremented by, not plus." Solutions in other languages are available at http://www.paulgraham.com/accgen.html *) (** [adder t n] is an adder for elements of [numeric] typeclass [t], initialized with [n]*) let adder t n i = open Numeric in Ref.post r (t.add i) where r = ref n (*Examples:*) let adder_of_floats : float -> float = adder Float.operations 5. let adder_of_ints : int -> int = adder Int.operations 5 let adder_of_complexes: Complex.t -> Complex.t = adder Complex.operations Complex.i batteries-included-3.4.0/examples/snippets/myocamlbuild.ml000077700000000000000000000000001415601150500305142../../build/myocamlbuild.mlustar00rootroot00000000000000batteries-included-3.4.0/examples/snippets/netchan_cat.ml000066400000000000000000000010201415601150500235400ustar00rootroot00000000000000(* Yet another (slower) "cat" implementation, it is just meant to be a showcase for integration with ocamlnet's Netchannels. *) let oc = Netchannels.lift_out (`Rec (new Netchannels.channel_of_output IO.stdout :> Netchannels.rec_out_channel)) let _ = Netchannels.with_in_obj_channel (Netchannels.lift_in (`Rec (new Netchannels.channel_of_input IO.stdin))) (fun ic -> try while true do oc # output_string (ic # input_line () ^ "\n"); oc # flush () done with End_of_file -> ()) batteries-included-3.4.0/examples/snippets/parallelsort.ml000066400000000000000000000012731415601150500240070ustar00rootroot00000000000000open Threads, Event let tasks = 5 let main = let input = Sys.argv in let input_len = Array.length input in let channels = Array.init tasks (fun _ -> new_channel ()) in let part_size = input_len / tasks in let gen_part i = let len = if i=tasks-1 then (input_len) - (i * part_size) else part_size in Array.sub input (i*part_size) len in let partitions = Array.init tasks gen_part in let task (c,arr) = Array.sort compare arr; send c arr |> sync in let make_thread c arr = ignore (Thread.create task (c,arr)) in Array.iter2 make_thread channels partitions; let get_print c = c |> receive |> sync |> Array.iter print_endline in Array.iter get_print channels batteries-included-3.4.0/examples/snippets/ropes_vs_strings.ml000066400000000000000000000011141415601150500247060ustar00rootroot00000000000000open Rope let (^^^) = append let test_strings num = let x = ref "" and s = "a" in for i = 1 to num do x := !x ^ s done let test_ropes num = let x = ref (r"") and s = r"a" in for i = 1 to num do x := !x ^^^ s done let delta f x = let t0 = Sys.time () in let _ = f x in let t1 = Sys.time () in t1 -. t0 let _ = Printf.printf "Strings: %fms\n" (delta (fun () -> for i = 1 to 10 do test_strings 10000 done ) ()); Printf.printf "Ropes: %fms\n" (delta (fun () -> for i = 1 to 10 do test_ropes 1000000 done ) ()) batteries-included-3.4.0/examples/snippets/snippets.itarget000066400000000000000000000001561415601150500241760ustar00rootroot00000000000000netchan_cat.byte netchan_cat.native parallelsort.byte parallelsort.native test_printf.byte test_printf.native batteries-included-3.4.0/examples/snippets/test_printf.ml000066400000000000000000000020221415601150500236350ustar00rootroot00000000000000open Batteries open Print let _ = (* Simple test *) printf p"x = (%d, %s)\n" 1 "a"; (* With flags: *) printf p"x = %04x\n" 42; (* Test with labelled directives: *) printf p"Hello %(name:s), i am ocaml version %(version:s)\n%!" ~name:(try Sys.getenv "USER" with _ -> "toto") ~version:Sys.ocaml_version; (* Printing an object: *) printf p"o = %obj\n" (object(self) method print oc = fprintf oc p"" (Oo.id self) end); (* Printing a list: *) printf p"l = %{int option list}\n" [Some 1; None; Some 2]; (* A custom directive, printing pair of integers: *) let printer_foo k (x, y) = k (fun oc -> fprintf oc p"(%d, %d)" x y) in printf p"pair = %foo\n" (42, 1024); (* A custom directive, taking multiple arguments: *) let printer_test k x y z = k (fun oc -> fprintf oc p"(%d, %d, %d)" x y z) in printf p"x = %test\n" 1 2 3; (* Labelled directives with multiple argument: *) printf p"x = %(x,y,z:test)\n" ~x:1 ~y:2 ~z:2; printf p"x = %(x,_,z:test)\n" ~x:1 2 ~z:2 batteries-included-3.4.0/examples/snippets/unicode.ml000066400000000000000000000014151415601150500227270ustar00rootroot00000000000000 let say x = IO.nwrite IO.stdout x; IO.write IO.stdout '\n' let usay = IO.write_uline IO.stdout let s1 = "Simple ASCII string" and s2 = "Complex: " let u1 = UTF8.of_string s1 let rope1 = Rope.of_ustring u1 and rope2 = Rope.of_latin1 s2 let rec exp_dup n r = if n <= 0 then r else exp_dup (n-1) (Rope.append r r) let r16 = exp_dup 4 rope2 let () = usay rope1; usay rope2 let () = usay r16 let r3 = Rope.sub r16 15 36 let () = say "Characters 15 to 41 of r16: "; usay r3 let c11 = Rope.get rope2 11 let () = say "Character 11: "; IO.write_uchar IO.stdout c11; say "\n" let bad_rope = try usay (Rope.of_ustring (UTF8.of_string s2)) with UTF8.Malformed_code -> say "Non-utf8 input -- caught Malformed_code\n (don't worry, that's part of the example)\n" batteries-included-3.4.0/examples/snippets/unicode2.ml000066400000000000000000000015101415601150500230050ustar00rootroot00000000000000 (* A version of unicode.ml rewritten to take advantage of 3.11-only syntax extensions *) let say x = IO.nwrite IO.stdout x; IO.write IO.stdout '\n' let usay = IO.write_uline IO.stdout let rope1 = Rope.of_ustring (u"Simple ASCII string") and rope2 = r"Complex: " let rec exp_dup n r = if n <= 0 then r else exp_dup (n-1) (Rope.append r r) let r16 = exp_dup 4 rope2 let () = usay rope1; usay rope2 let () = usay r16 let r3 = Rope.sub r16 15 36 let () = say "Characters 15 to 41 of r16: "; usay r3 let c11 = Rope.get rope2 11 let () = say "Character 11: "; IO.write_uchar IO.stdout c11; say "\n" let bad_rope = try usay (Rope.of_ustring (u "Some text not encoded in utf8: ")) with UTF8.Malformed_code -> say "Non-utf8 input -- caught Malformed_code\n (don't worry, that's part of the example)\n" batteries-included-3.4.0/examples/tools/000077500000000000000000000000001415601150500202415ustar00rootroot00000000000000batteries-included-3.4.0/examples/tools/_tags000066400000000000000000000000431415601150500212560ustar00rootroot00000000000000not(<*_dyn*>): pkg_batteries,debug batteries-included-3.4.0/examples/tools/browser.ml000066400000000000000000000002421415601150500222540ustar00rootroot00000000000000(** Call your favorite browser to browse each of the URLs entered on the command-line. *) open Batteries_config iter (fun x -> ignore **> browse x) (args ()) batteries-included-3.4.0/examples/tools/cat.ml000077500000000000000000000004431415601150500213460ustar00rootroot00000000000000(** Implementation of a cat-like tool: read each file whose name is given on the command-line and print the contents to stdout. Compilation: ocamlbuild cat.byte Usage: ./cat.byte *.ml *) open Batteries;; iter (fun x -> IO.copy (File.open_in x) stdout) (args ());; batteries-included-3.4.0/examples/tools/cat2.ml000066400000000000000000000013261415601150500214260ustar00rootroot00000000000000(** Implementation of a cat-like tool: read each file whose name is given on the command-line and print the contents to stdout. Usage: ./cat2.byte *.ml Variants based on function composition *) (* For reference write_lines : unit output -> string Enum.t -> unit stdout : unit output args : unit -> string Enum.t () : unit concat : string Enum.t Enum.t -> string Enum.t map : (string -> string Enum.t) -> string Enum.t -> string Enum.t Enum.t File.lines_of:string -> string Enum.t *) (*(*Variant 1*) let _ = write_lines stdout -| concat <| map lines_of (args ()) *) (*Variant 2*) let _ = () |> args |> (File.lines_of |> map) |> concat |> (stdout |> IO.write_lines) batteries-included-3.4.0/examples/tools/conv.ml000066400000000000000000000013711415601150500215420ustar00rootroot00000000000000(* Convert encodings. Everything received from the standard input is converted and written onto the standard output, using the encodings specified on the command-line. Usage: ./conv ASCII UTF-8 < README *) open CharEncodings, Sys, IO try (*V1: Convert output: copy stdin (encoded_as (transcode_out (as_encoded stdout (`named argv.(1))) (`named argv.(2))))*) (*V2: Convert input*) copy (encoded_as **> transcode_in (as_encoded stdin **> `named argv.(1)) (`named argv.(2))) stdout; flush_all () with Not_found -> Print.eprintf p"Sorry, unknown encoding.\n%!" | Malformed_code -> Print.eprintf p"Error: This text is not encoded with encoding %S\n" (argv.(1)) | e -> Print.eprintf p"Error:\n%s\n%!" (Printexc.to_string e) batteries-included-3.4.0/examples/tools/gunzip.ml000066400000000000000000000007771415601150500221220ustar00rootroot00000000000000(* Open a .gz file and decompress it on the spot. Usage: ./gunzip.byte some_file.gz (produces some_file, removes some_file.gz) *) open File, IO, Filename iter f (args ()) where let f name = if check_suffix name ".gz" then with_file_in name (fun inp -> with_file_out (chop_suffix name ".gz") (fun out -> Gzip.with_in inp (fun inp'-> copy inp' out; Sys.remove name))) else prerr_endline ("I don't know what to do with file "^name) batteries-included-3.4.0/examples/tools/mygzip.ml000066400000000000000000000005041415601150500221110ustar00rootroot00000000000000(* Compress a file to .gz on the spot Usage: ./gzip.byte some_file (produces some_file.gz, removes some_file) *) open File, IO, Filename iter f (args ()) where let f name = with_file_out (name ^ ".gz") (fun out -> with_file_in name (fun inp -> copy inp (Gzip.compress out); Sys.remove name )) batteries-included-3.4.0/examples/tools/myocamlbuild.ml000077700000000000000000000000001415601150500300072../../build/myocamlbuild.mlustar00rootroot00000000000000batteries-included-3.4.0/examples/tools/pair.ml000066400000000000000000000022231415601150500215250ustar00rootroot00000000000000(* Print the contents of two files, optionally using a printf-style format argument. I found this useful to write module CharEncodings, and it was a three-liner at the time (before I made it parametric). Usage: ./pair file_1 file_2 ./pair file_1 file_2 "%s -> %S\n" The first usage prints the first line of file_1 followed by the first line of file_2, then the second line of file_1 followed by the second line of file_2, etc. until either file_1 or file_2 ends. The second usage does the same thing but adds characters " -> " between each line of file_1 and the corresponding line of file file_2 and puts the contents of each line of file_2 between quotes. *) open Sys (*Read the format -- this is the most complicated part of the program*) let default_format : (_, _, _, _) format4 = "%s %s\n" if Array.length argv < 2 then failwith "Missing arguments" let format = if Array.length argv = 3 then default_format else Scanf.format_from_string argv.(3) default_format in (*Actually do the deed*) Enum.iter2 (fun x y -> Printf.printf format x y) (File.lines_of argv.(1)) (File.lines_of argv.(2)) batteries-included-3.4.0/examples/tools/shuffle.ml000066400000000000000000000003461415601150500222320ustar00rootroot00000000000000(* Randomly reorder the elements given on the command-line. Usage: ./shuffle 1 2 3 4 5 6 7 8 9 *) open Random with self_init () let _ = Array.print ~sep:" " ~first:"" ~last:"\n" output_string stdout (shuffle (args ()));; batteries-included-3.4.0/examples/tools/shuffle2.ml000066400000000000000000000003551415601150500223140ustar00rootroot00000000000000(*Randomly reorder the elements given on stdin. Usage: ./shuffle2.byte < some_file.txt *) open Random with self_init () open IO, Printf let shift x = x + 1;; Array.iteri (shift |- printf "%-2d: %s\n") (shuffle (lines_of stdin)) batteries-included-3.4.0/examples/tools/tools.itarget000066400000000000000000000003311415601150500227570ustar00rootroot00000000000000conv.byte conv.native now.byte now.native cat.byte cat.native cat2.byte cat2.native shuffle.byte shuffle.native shuffle2.byte shuffle2.native gzip.byte gzip.native gunzip.byte gunzip.native browser.byte browser.nativebatteries-included-3.4.0/howto/000077500000000000000000000000001415601150500164235ustar00rootroot00000000000000batteries-included-3.4.0/howto/release.md000066400000000000000000000110061415601150500203630ustar00rootroot00000000000000Make a release -------------- # Quality checking - `make test` on a 64 bits machine - `make test` on a 32 bits machine (in practice, we have a hard time finding 32 bits machine these days, so it's okay to skip this test) - `make test` with the oldest ocaml compiler version we are supporting (for example, in an opam 3.12.1 switch) - install the to-be-released version with `opam pin add -k git .`, and then run the post-install tests with `make test-build-from-install` (If you do not want to provoke a rebuild of batteries-depending software in your main development switch, feel free to move to a fresh new switch to test this.) - instead of the previous, you can also run the fully automatic 'make test_install'. This will force a rebuild and install of batteries (make clean && make install); then go to a temporary directory and try to compile and run a test program using batteries. After, you may want to 'opam reinstall batteries' in order to get rid of this development version of batteries from your current opam switch. # Release marking These steps can be redone as many times as necessary, and do not need to be performed by someone with commit rights. - inspect commits and sources to find @since tags to add/substitute (especially @since NEXT_RELEASE); `sh scripts/find_since.sh` can help. ./scripts/replace_since.sh helps even more. - update the changelog with release notes The changelog should contain an entry for each notable change that went in the release, with proper crediting of contributors. You may want to use `git log` to check that nothing was forgotten. You should write a summary of the release in a few sentences, which will serve as release notes, and include it at the top of the Changelog for the new release. - Bump version in source (in `_oasis`) - change ocamlfind dependencies in `META` if necessary - check that `make release` correctly produces a release tarball ## opam preparation work Performing the release will require sending a pull-request against the public opam repository with an `opam` metadata file for the new version. Here is how you should prepare this `opam` file. There are two sources of inspiration for the new opam file: - there is a local `opam` file at the root of the ocamlbuild repository, that is used for pinning the development version. - there are the `opam` files for previous OCamlbuild releases in the public opam repository: https://github.com/ocaml/opam-repository/tree/master/packages/batteries In theory the two should be in synch: the `opam` file we send to the public opam repository is derived from the local `opam` file. However, upstream opam repository curators may have made changes to the public opam files, to reflect new packaging best practices and policies. You should check for any change to the latest version's `opam` file; if there is any, it should probably be reproduced into our local `opam` file, and committed. Note that the local file may have changed during the release lifetime to reflect new dependencies or changes in packaging policies. These changes should also be preserved in the opam file for the new version. To summarize, you should first update the local `opam` file to contain interesting changes from the in-repository versions. You can then prepare an `opam` file for the new version, derived from the local `opam` file. When editing an opam file (locally or in the package repository), you should use use `opam lint` to check that the opam file follows best practices. # Performing the actual release - Commit and add a tag (`git tag -a `; `git push --tags origin`) Tag names are usually of the form "vM.m.b", for example "v2.5.3", use `git tag --list` to see existing tags. - run `make release` to produce a tarball - on the Github "Releases" [page](https://github.com/ocaml-batteries-team/batteries-included/releases) you should see the just-pushed tag. You should `edit` the release to include the release notes (the general blurb you wrote and the detailed Changelog, in markdown format), and upload the release tarball. - Upload the documentation (`make upload-docs`). You can check that the documentation is appropriately updated at http://ocaml-batteries-team.github.io/batteries-included/hdoc2/ - send a pull-request against the public opam repository with the opam file prepared for the new version # Post-release work - create a Changelog section for NEXT_RELEASE, use NEXT_RELEASE in the _oasis version field - once the new opam package is merged, announce on the mailing-list. batteries-included-3.4.0/myocamlbuild.ml000066400000000000000000000165031415601150500203030ustar00rootroot00000000000000(* ocamlbuild plugin for building Batteries. * Copyright (C) 2010 Michael Ekstrand * * Portions (hopefully trivial) from build/myocamlbuild.ml and the * Gallium wiki. *) open Ocamlbuild_plugin module Pack = Ocamlbuild_pack let ocamlfind x = S[A"ocamlfind"; A x] let packs = "bigarray,num,str" let doc_intro = "build/intro.text" let mkconf = "build/mkconf.byte" let mkconf_command src dst = let oasis_path = Filename.concat Filename.parent_dir_name "_oasis" in Cmd(S[A"ocamlrun"; P mkconf; P oasis_path; P src; P dst]) let compiler_libs = if Sys.ocaml_version.[0] = '4' then [A"-I"; A"+compiler-libs"] else [] let _ = dispatch begin function | Before_options -> (* Set up to use ocamlfind *) Options.ocamlc := ocamlfind "ocamlc"; Options.ocamlopt := ocamlfind "ocamlopt"; Options.ocamldep := ocamlfind "ocamldep"; Options.ocamldoc := ocamlfind "ocamldoc"; Options.ocamlmktop := ocamlfind "ocamlmktop" | Before_rules -> rule "build shared module" ~prod:"%.cmxs" ~dep:"%.cmxa" begin fun env build -> let tags = Tags.union (tags_of_pathname (env "%.cmxs")) (tags_of_pathname (env "%.cmxa")) ++ "ocaml" ++ "link" ++ "module" in Cmd(S[!Options.ocamlopt; A"-shared"; A"-linkall"; T tags; A"-o"; P(env "%.cmxs"); P(env "%.cmxa")]) end; rule "process config file" ~prod:"%.ml" ~deps:["%.mlp"; mkconf] begin fun env build -> mkconf_command (env "%.mlp") (env "%.ml") end; rule "process meta file" ~prod:"META" ~deps:["META.in"; mkconf] begin fun env build -> mkconf_command "META.in" "META" end | After_rules -> (* use the home-made prefilter preprocessor, which looks for lines starting with ##Vx##, and delete just the tag or the whole line depending whether the x matches the ocaml major version *) let prefilter_rule ext = let src = "%." ^ ext ^ "v" in let tgt = "%." ^ ext in rule (Printf.sprintf "prefilter: %s --> %s" src tgt) ~prod:tgt ~deps:[src; "build/prefilter.byte"] (fun env _build -> Cmd (S [P "build/prefilter.byte"; P (env src); Sh ">"; Px (env tgt)])) in prefilter_rule "ml"; prefilter_rule "mli"; let ocaml_version = try Scanf.sscanf Sys.ocaml_version "%d.%d" (fun m n -> (m, n)) with _ -> (* an arbitrary choice is better than failing here *) (4, 0) in begin (* BatConcreteQueue is either BatConcreteQueue_40x *) let queue_implementation = let major, minor = ocaml_version in if major < 4 || major = 4 && minor <= 2 then "src/batConcreteQueue_402.ml" else "src/batConcreteQueue_403.ml" in copy_rule "queue implementation" queue_implementation "src/batConcreteQueue.ml"; end; (* Rules to create libraries from .mllib instead of .cmo. We need this because src/batteries.mllib is hidden by src/batteries.ml *) rule ".mllib --> .cma" ~insert:`top ~prod:"%.cma" ~dep:"%.mllib" (Pack.Ocaml_compiler.byte_library_link_mllib "%.mllib" "%.cma"); rule ".mllib --> .cmxa" ~insert:`top ~prod:"%.cmxa" ~dep:"%.mllib" (Pack.Ocaml_compiler.native_library_link_mllib "%.mllib" "%.cmxa"); for n = 1 to 30 do List.iter (fun symbol -> flag ["ocaml"; "compile"; Printf.sprintf "warn_%s%d" symbol n] (S[A"-w"; A (Printf.sprintf "%s%d" symbol n)]); flag ["ocaml"; "compile"; Printf.sprintf "warn_error_%s%d" symbol n] (S[A"-warn-error"; A (Printf.sprintf "%s%d" symbol n)]) ) ["+"; "-"; "@"] done; (* When one links an OCaml program, one should use -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; (* Causes build to fail on armel under ocaml 3.10.2 flag ["ocaml"; "native"; "compile"] & A"-annot"; *) (* A bad idea for future compatibility if OCaml introduces new warnings; we should use an explicit list of warnings here flag ["ocaml"; "compile"] & S[A"-warn-error"; A"A"]; *) flag ["ocaml"; "compile"] & S[A"-package"; A packs]; flag ["ocaml"; "ocamldep"] & S[A"-package"; A packs]; flag ["ocaml"; "doc"] & S[A"-package"; A packs]; flag ["ocaml"; "link"] & S[A"-package"; A packs]; flag ["ocaml"; "infer_interface"] & S[A"-package"; A packs]; List.iter (fun pkg -> flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; ()) ["oUnit"; "benchmark"]; (* DON'T USE TAG 'thread', USE 'threads' for compatibility with ocamlbuild *) flag ["ocaml"; "compile"; "threads"] & A"-thread"; flag ["ocaml"; "link"; "threads"] & A"-thread"; flag ["ocaml"; "doc"; "threads"] & S[A"-I"; A "+threads"]; flag ["ocaml"; "doc"] & S[A"-hide-warnings"; A"-sort"]; flag ["ocaml"; "compile"; "camlp4rf"] & S[A"-package"; A"camlp4.lib"; A"-pp"; A"camlp4rf"]; flag ["ocaml"; "ocamldep"; "camlp4rf"] & S[A"-package"; A"camlp4.lib"; A"-pp"; A"camlp4rf"]; flag ["ocaml"; "compile"; "camlp4of"] & S[A"-package"; A"camlp4.lib"; A"-pp"; A"camlp4of"]; flag ["ocaml"; "ocamldep"; "camlp4of"] & S[A"-package"; A"camlp4.lib"; A"-pp"; A"camlp4of"]; flag ["ocaml"; "compile"; "syntax_camlp4o"] & S[A"-syntax"; A"camlp4o"; A"-package"; A"camlp4"]; flag ["ocaml"; "ocamldep"; "syntax_camlp4o"] & S[A"-syntax"; A"camlp4o"; A"-package"; A"camlp4"]; ocaml_lib "src/batteries"; ocaml_lib "src/batteriesThread"; flag ["ocaml"; "compile"; "compiler-libs"] & S compiler_libs; flag ["ocaml"; "link"; "compiler-libs"] & S compiler_libs; flag ["ocaml"; "ocamldep"; "compiler-libs"] & S compiler_libs; flag ["ocaml"; "link"; "linkall"] & S[A"-linkall"]; if ocaml_version = (4, 0) then begin (* OCaml 4.00 has -bin-annot but no ocamlbuild flag *) flag ["ocaml"; "bin_annot"; "compile"] (A "-bin-annot"); flag ["ocaml"; "bin_annot"; "pack"] (A "-bin-annot"); end; (* dep ["ocaml"; "link"; "include_tests"; "byte"] & [Pathname.mk "qtest/test_mods.cma"]; dep ["ocaml"; "link"; "include_tests"; "native"] & [Pathname.mk "qtest/test_mods.cmxa"]; *) (* Some .mli files use INCLUDE "foo.mli" to avoid interface duplication; The problem is that the automatic dependency detector of ocamlbuild doesn't detect the implicit dependency on the included .mli, and doesn't copy it into _build before preprocessing the including file. Here, we add flags denoting explicit dependencies on the included .mli. This solution comes from the following explanation of Xavier Clerc: http://caml.inria.fr/mantis/print_bug_page.php?bug_id=5162 *) dep ["ocaml"; "doc"; "extension:html"] & [doc_intro]; flag ["ocaml"; "doc"; "extension:html"] & (S[A"-t"; A"Batteries user guide"; A"-intro"; P doc_intro; A"-colorize-code"]); | _ -> () end batteries-included-3.4.0/plot000077500000000000000000000025451415601150500161750ustar00rootroot00000000000000#!/bin/bash [ $# -eq 0 ] || { echo 'unexpected command line arguments' echo 'usage: $0' echo 'Expects a stream on the standard input and draws' echo 'gnuplot graphs when it recognizes some gnuplot data' exit 1 } trap cleanup EXIT SIGINT cleanup() { rm -f "$tmp" } tmp="$(mktemp)" while read line; do case "$line" in '#'*) # reading blocks of line starting with a line # starting with a sharp and ending with an empty line # this line has format #title size\tname1\tname2 etc. names=$(echo "$line" | cut -d ' ' -f 2-) title=$(echo "$line" | sed 's/^#\([^ ]*\) .*$/\1/') > "$tmp" # emptying the file while read line && [ "$line" != "" ]; do echo "$line" >> "$tmp" done gnuplot -p <( echo set key left top echo set logscale x echo set title "'$title'" echo -n 'plot ' counter=1 for name in $names; do counter=$((counter+1)) if [ $counter -ne 2 ]; then echo -e -n ', \\\n ' fi echo -n \'"$tmp"\' using 1:$counter title \'"$name"\' with linespoints done echo ) esac done batteries-included-3.4.0/qtest/000077500000000000000000000000001415601150500164235ustar00rootroot00000000000000batteries-included-3.4.0/qtest/README.md000066400000000000000000000003121415601150500176760ustar00rootroot00000000000000# qTest ## Info: The inline tests are generated and run here. The qTest code itself has moved to a new location: https://github.com/vincent-hugot/iTeML ## Files: _tags : necessary to run the tests batteries-included-3.4.0/qtest/_tags000066400000000000000000000006601415601150500174450ustar00rootroot00000000000000true: threads, debug # Warning 52 warnings against patterns of the form # # try .. with Invalid_argument "foo" -> ... # # because they are fragile. But we want to have them in tests, for the # Invalid_argument payloads corresponding to exceptions *we* raise, as # the fact that those fragile tests break then tells us that fragile # user code would also break (and we want to be alerted when that is # a risk). true: warn(-52) batteries-included-3.4.0/qtest/qtest_preamble.ml000066400000000000000000000006441415601150500217700ustar00rootroot00000000000000(* this file is part of Batteries 'qtest' usage; it will be included at the top of the generated test runner, and is therefore a good location to add functions that would be convenient to write tests but have not yet found their place into Batteries proper. *) open Batteries module Pervasives = Pervasives[@warning "-3"] [@@@warning "-52"] (* allow to match the constant payload of exception constructors *) batteries-included-3.4.0/scripts/000077500000000000000000000000001415601150500167525ustar00rootroot00000000000000batteries-included-3.4.0/scripts/find_since.sh000077500000000000000000000001701415601150500214100ustar00rootroot00000000000000#!/usr/bin/env sh # Find remaining NEXT_RELEASE tags find src/ -name '*.ml*' -exec grep NEXT_RELEASE -n {} \; -print batteries-included-3.4.0/scripts/replace_since.sh000077500000000000000000000006661415601150500221150ustar00rootroot00000000000000#!/usr/bin/env sh # Replace annotations of the form @since NEXT_RELEASE by the # version number given on the command line VERSION="$1" echo "version number: $VERSION" if [ -z "$VERSION" ] ; then echo "please give a version number, for example:" echo "sh scripts/replace_since.sh 2.8.0" exit 1 fi sed -e "s/NEXT_RELEASE/$VERSION/g" -i '' _oasis find src/ -name '*.ml*' -exec sed -e "s/NEXT_RELEASE/$VERSION/g" -i '' {} \; batteries-included-3.4.0/scripts/test_install.sh000077500000000000000000000007141415601150500220200ustar00rootroot00000000000000#!/bin/bash #set -x temp_dir=`mktemp -d` cat< $temp_dir/install_test.ml open Batteries let () = assert(List.takedrop 2 [1;2;3;4] = ([1;2], [3;4])); Printf.printf "install_test: OK\n" EOF make clean # force rebuild next make install && \ cd $temp_dir && \ rm -f install_test.native && \ ocamlbuild -pkg batteries install_test.native && \ ./install_test.native cd - # go back where we were before rm -rf $temp_dir # clean our mess batteries-included-3.4.0/setup.ml000066400000000000000000005630611415601150500167700ustar00rootroot00000000000000(* setup.ml generated for the first time by OASIS v0.2.0 *) (* OASIS_START *) (* DO NOT EDIT (digest: 7e9f296707979be8fccccc47a478e4e0) *) (* Regenerated by OASIS v0.4.11 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str: ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISString = struct (* # 22 "src/oasis/OASISString.ml" *) (** Various string utilities. Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) let nsplitf str f = if str = "" then [] else let buf = Buffer.create 13 in let lst = ref [] in let push () = lst := Buffer.contents buf :: !lst; Buffer.clear buf in let str_len = String.length str in for i = 0 to str_len - 1 do if f str.[i] then push () else Buffer.add_char buf str.[i] done; push (); List.rev !lst (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) let find ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else what_idx := 0; incr str_idx done; if !what_idx <> String.length what then raise Not_found else !str_idx - !what_idx let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then "" else String.sub str 0 (str_len - len) let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else ok := false; incr str_idx done; !what_idx = String.length what let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx else ok := false; decr str_idx done; !what_idx = -1 let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found let replace_chars f s = let buf = Buffer.create (String.length s) in String.iter (fun c -> Buffer.add_char buf (f c)) s; Buffer.contents buf let lowercase_ascii = replace_chars (fun c -> if (c >= 'A' && c <= 'Z') then Char.chr (Char.code c + 32) else c) let uncapitalize_ascii s = if s <> "" then (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) else s let uppercase_ascii = replace_chars (fun c -> if (c >= 'a' && c <= 'z') then Char.chr (Char.code c - 32) else c) let capitalize_ascii s = if s <> "" then (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) else s end module OASISUtils = struct (* # 22 "src/oasis/OASISUtils.ml" *) open OASISGettext module MapExt = struct module type S = sig include Map.S val add_list: 'a t -> (key * 'a) list -> 'a t val of_list: (key * 'a) list -> 'a t val to_list: 'a t -> (key * 'a) list end module Make (Ord: Map.OrderedType) = struct include Map.Make(Ord) let rec add_list t = function | (k, v) :: tl -> add_list (add k v t) tl | [] -> t let of_list lst = add_list empty lst let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] end end module MapString = MapExt.Make(String) module SetExt = struct module type S = sig include Set.S val add_list: t -> elt list -> t val of_list: elt list -> t val to_list: t -> elt list end module Make (Ord: Set.OrderedType) = struct include Set.Make(Ord) let rec add_list t = function | e :: tl -> add_list (add e t) tl | [] -> t let of_list lst = add_list empty lst let to_list = elements end end module SetString = SetExt.Make(String) let compare_csl s1 s2 = String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) module HashStringCsl = Hashtbl.Make (struct type t = string let equal s1 s2 = (compare_csl s1 s2) = 0 let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) end) module SetStringCsl = SetExt.Make (struct type t = string let compare = compare_csl end) let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin invalid_arg "varname_of_string" end else begin let buf = OASISString.replace_chars (fun c -> if ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') || ('0' <= c && c <= '9') then c else hyphen) s; in let buf = (* Start with a _ if digit *) if '0' <= s.[0] && s.[0] <= '9' then "_"^buf else buf in OASISString.lowercase_ascii buf end let varname_concat ?(hyphen='_') p s = let what = String.make 1 hyphen in let p = try OASISString.strip_ends_with ~what p with Not_found -> p in let s = try OASISString.strip_starts_with ~what s with Not_found -> s in p^what^s let is_varname str = str = varname_of_string str let failwithf fmt = Printf.ksprintf failwith fmt let rec file_location ?pos1 ?pos2 ?lexbuf () = match pos1, pos2, lexbuf with | Some p, None, _ | None, Some p, _ -> file_location ~pos1:p ~pos2:p ?lexbuf () | Some p1, Some p2, _ -> let open Lexing in let fn, lineno = p1.pos_fname, p1.pos_lnum in let c1 = p1.pos_cnum - p1.pos_bol in let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 | _, _, Some lexbuf -> file_location ~pos1:(Lexing.lexeme_start_p lexbuf) ~pos2:(Lexing.lexeme_end_p lexbuf) () | None, None, None -> s_ "" let failwithpf ?pos1 ?pos2 ?lexbuf fmt = let loc = file_location ?pos1 ?pos2 ?lexbuf () in Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt end module OASISUnixPath = struct (* # 22 "src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string type host_filename = string type host_dirname = string let current_dir_name = "." let parent_dir_name = ".." let is_current_dir fn = fn = current_dir_name || fn = "" let concat f1 f2 = if is_current_dir f1 then f2 else let f1' = try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 in f1'^"/"^f2 let make = function | hd :: tl -> List.fold_left (fun f p -> concat f p) hd tl | [] -> invalid_arg "OASISUnixPath.make" let dirname f = try String.sub f 0 (String.rindex f '/') with Not_found -> current_dir_name let basename f = try let pos_start = (String.rindex f '/') + 1 in String.sub f pos_start ((String.length f) - pos_start) with Not_found -> f let chop_extension f = try let last_dot = String.rindex f '.' in let sub = String.sub f 0 last_dot in try let last_slash = String.rindex f '/' in if last_slash < last_dot then sub else f with Not_found -> sub with Not_found -> f let capitalize_file f = let dir = dirname f in let base = basename f in concat dir (OASISString.capitalize_ascii base) let uncapitalize_file f = let dir = dirname f in let base = basename f in concat dir (OASISString.uncapitalize_ascii base) end module OASISHostPath = struct (* # 22 "src/oasis/OASISHostPath.ml" *) open Filename open OASISGettext module Unix = OASISUnixPath let make = function | [] -> invalid_arg "OASISHostPath.make" | hd :: tl -> List.fold_left Filename.concat hd tl let of_unix ufn = match Sys.os_type with | "Unix" | "Cygwin" -> ufn | "Win32" -> make (List.map (fun p -> if p = Unix.current_dir_name then current_dir_name else if p = Unix.parent_dir_name then parent_dir_name else p) (OASISString.nsplit ufn '/')) | os_type -> OASISUtils.failwithf (f_ "Don't know the path format of os_type %S when translating unix \ filename. %S") os_type ufn end module OASISFileSystem = struct (* # 22 "src/oasis/OASISFileSystem.ml" *) (** File System functions @author Sylvain Le Gall *) type 'a filename = string class type closer = object method close: unit end class type reader = object inherit closer method input: Buffer.t -> int -> unit end class type writer = object inherit closer method output: Buffer.t -> unit end class type ['a] fs = object method string_of_filename: 'a filename -> string method open_out: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> writer method open_in: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> reader method file_exists: 'a filename -> bool method remove: 'a filename -> unit end module Mode = struct let default_in = [Open_rdonly] let default_out = [Open_wronly; Open_creat; Open_trunc] let text_in = Open_text :: default_in let text_out = Open_text :: default_out let binary_in = Open_binary :: default_in let binary_out = Open_binary :: default_out end let std_length = 4096 (* Standard buffer/read length. *) let binary_out = Mode.binary_out let binary_in = Mode.binary_in let of_unix_filename ufn = (ufn: 'a filename) let to_unix_filename fn = (fn: string) let defer_close o f = try let r = f o in o#close; r with e -> o#close; raise e let stream_of_reader rdr = let buf = Buffer.create std_length in let pos = ref 0 in let eof = ref false in let rec next idx = let bpos = idx - !pos in if !eof then begin None end else if bpos < Buffer.length buf then begin Some (Buffer.nth buf bpos) end else begin pos := !pos + Buffer.length buf; Buffer.clear buf; begin try rdr#input buf std_length; with End_of_file -> if Buffer.length buf = 0 then eof := true end; next idx end in Stream.from next let read_all buf rdr = try while true do rdr#input buf std_length done with End_of_file -> () class ['a] host_fs rootdir : ['a] fs = object (self) method private host_filename fn = Filename.concat rootdir fn method string_of_filename = self#host_filename method open_out ?(mode=Mode.text_out) ?(perm=0o666) fn = let chn = open_out_gen mode perm (self#host_filename fn) in object method close = close_out chn method output buf = Buffer.output_buffer chn buf end method open_in ?(mode=Mode.text_in) ?(perm=0o666) fn = (* TODO: use Buffer.add_channel when minimal version of OCaml will * be >= 4.03.0 (previous version was discarding last chars). *) let chn = open_in_gen mode perm (self#host_filename fn) in let strm = Stream.of_channel chn in object method close = close_in chn method input buf len = let read = ref 0 in try for _i = 0 to len do Buffer.add_char buf (Stream.next strm); incr read done with Stream.Failure -> if !read = 0 then raise End_of_file end method file_exists fn = Sys.file_exists (self#host_filename fn) method remove fn = Sys.remove (self#host_filename fn) end end module OASISContext = struct (* # 22 "src/oasis/OASISContext.ml" *) open OASISGettext type level = [ `Debug | `Info | `Warning | `Error] type source type source_filename = source OASISFileSystem.filename let in_srcdir ufn = OASISFileSystem.of_unix_filename ufn type t = { (* TODO: replace this by a proplist. *) quiet: bool; info: bool; debug: bool; ignore_plugins: bool; ignore_unknown_fields: bool; printf: level -> string -> unit; srcfs: source OASISFileSystem.fs; load_oasis_plugin: string -> bool; } let printf lvl str = let beg = match lvl with | `Error -> s_ "E: " | `Warning -> s_ "W: " | `Info -> s_ "I: " | `Debug -> s_ "D: " in prerr_endline (beg^str) let default = ref { quiet = false; info = false; debug = false; ignore_plugins = false; ignore_unknown_fields = false; printf = printf; srcfs = new OASISFileSystem.host_fs(Sys.getcwd ()); load_oasis_plugin = (fun _ -> false); } let quiet = {!default with quiet = true} let fspecs () = (* TODO: don't act on default. *) let ignore_plugins = ref false in ["-quiet", Arg.Unit (fun () -> default := {!default with quiet = true}), s_ " Run quietly"; "-info", Arg.Unit (fun () -> default := {!default with info = true}), s_ " Display information message"; "-debug", Arg.Unit (fun () -> default := {!default with debug = true}), s_ " Output debug message"; "-ignore-plugins", Arg.Set ignore_plugins, s_ " Ignore plugin's field."; "-C", Arg.String (fun str -> Sys.chdir str; default := {!default with srcfs = new OASISFileSystem.host_fs str}), s_ "dir Change directory before running (affects setup.{data,log})."], fun () -> {!default with ignore_plugins = !ignore_plugins} end module PropList = struct (* # 22 "src/oasis/PropList.ml" *) open OASISGettext type name = string exception Not_set of name * string option exception No_printer of name exception Unknown_field of name * name let () = Printexc.register_printer (function | Not_set (nm, Some rsn) -> Some (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) | Not_set (nm, None) -> Some (Printf.sprintf (f_ "Field '%s' is not set") nm) | No_printer nm -> Some (Printf.sprintf (f_ "No default printer for value %s") nm) | Unknown_field (nm, schm) -> Some (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) | _ -> None) module Data = struct type t = (name, unit -> unit) Hashtbl.t let create () = Hashtbl.create 13 let clear t = Hashtbl.clear t (* # 77 "src/oasis/PropList.ml" *) end module Schema = struct type ('ctxt, 'extra) value = { get: Data.t -> string; set: Data.t -> ?context:'ctxt -> string -> unit; help: (unit -> string) option; extra: 'extra; } type ('ctxt, 'extra) t = { name: name; fields: (name, ('ctxt, 'extra) value) Hashtbl.t; order: name Queue.t; name_norm: string -> string; } let create ?(case_insensitive=false) nm = { name = nm; fields = Hashtbl.create 13; order = Queue.create (); name_norm = (if case_insensitive then OASISString.lowercase_ascii else fun s -> s); } let add t nm set get extra help = let key = t.name_norm nm in if Hashtbl.mem t.fields key then failwith (Printf.sprintf (f_ "Field '%s' is already defined in schema '%s'") nm t.name); Hashtbl.add t.fields key { set = set; get = get; help = help; extra = extra; }; Queue.add nm t.order let mem t nm = Hashtbl.mem t.fields nm let find t nm = try Hashtbl.find t.fields (t.name_norm nm) with Not_found -> raise (Unknown_field (nm, t.name)) let get t data nm = (find t nm).get data let set t data nm ?context x = (find t nm).set data ?context x let fold f acc t = Queue.fold (fun acc k -> let v = find t k in f acc k v.extra v.help) acc t.order let iter f t = fold (fun () -> f) () t let name t = t.name end module Field = struct type ('ctxt, 'value, 'extra) t = { set: Data.t -> ?context:'ctxt -> 'value -> unit; get: Data.t -> 'value; sets: Data.t -> ?context:'ctxt -> string -> unit; gets: Data.t -> string; help: (unit -> string) option; extra: 'extra; } let new_id = let last_id = ref 0 in fun () -> incr last_id; !last_id let create ?schema ?name ?parse ?print ?default ?update ?help extra = (* Default value container *) let v = ref None in (* If name is not given, create unique one *) let nm = match name with | Some s -> s | None -> Printf.sprintf "_anon_%d" (new_id ()) in (* Last chance to get a value: the default *) let default () = match default with | Some d -> d | None -> raise (Not_set (nm, Some (s_ "no default value"))) in (* Get data *) let get data = (* Get value *) try (Hashtbl.find data nm) (); match !v with | Some x -> x | None -> default () with Not_found -> default () in (* Set data *) let set data ?context x = let x = match update with | Some f -> begin try f ?context (get data) x with Not_set _ -> x end | None -> x in Hashtbl.replace data nm (fun () -> v := Some x) in (* Parse string value, if possible *) let parse = match parse with | Some f -> f | None -> fun ?context s -> failwith (Printf.sprintf (f_ "Cannot parse field '%s' when setting value %S") nm s) in (* Set data, from string *) let sets data ?context s = set ?context data (parse ?context s) in (* Output value as string, if possible *) let print = match print with | Some f -> f | None -> fun _ -> raise (No_printer nm) in (* Get data, as a string *) let gets data = print (get data) in begin match schema with | Some t -> Schema.add t nm sets gets extra help | None -> () end; { set = set; get = get; sets = sets; gets = gets; help = help; extra = extra; } let fset data t ?context x = t.set data ?context x let fget data t = t.get data let fsets data t ?context s = t.sets data ?context s let fgets data t = t.gets data end module FieldRO = struct let create ?schema ?name ?parse ?print ?default ?update ?help extra = let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in fun data -> Field.fget data fld end end module OASISMessage = struct (* # 22 "src/oasis/OASISMessage.ml" *) open OASISGettext open OASISContext let generic_message ~ctxt lvl fmt = let cond = if ctxt.quiet then false else match lvl with | `Debug -> ctxt.debug | `Info -> ctxt.info | _ -> true in Printf.ksprintf (fun str -> if cond then begin ctxt.printf lvl str end) fmt let debug ~ctxt fmt = generic_message ~ctxt `Debug fmt let info ~ctxt fmt = generic_message ~ctxt `Info fmt let warning ~ctxt fmt = generic_message ~ctxt `Warning fmt let error ~ctxt fmt = generic_message ~ctxt `Error fmt end module OASISVersion = struct (* # 22 "src/oasis/OASISVersion.ml" *) open OASISGettext type t = string type comparator = | VGreater of t | VGreaterEqual of t | VEqual of t | VLesser of t | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator (* Range of allowed characters *) let is_digit c = '0' <= c && c <= '9' let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false let rec version_compare v1 v2 = if v1 <> "" || v2 <> "" then begin (* Compare ascii string, using special meaning for version * related char *) let val_ascii c = if c = '~' then -1 else if is_digit c then 0 else if c = '\000' then 0 else if is_alpha c then Char.code c else (Char.code c) + 256 in let len1 = String.length v1 in let len2 = String.length v2 in let p = ref 0 in (** Compare ascii part *) let compare_vascii () = let cmp = ref 0 in while !cmp = 0 && !p < len1 && !p < len2 && not (is_digit v1.[!p] && is_digit v2.[!p]) do cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); incr p done; if !cmp = 0 && !p < len1 && !p = len2 then val_ascii v1.[!p] else if !cmp = 0 && !p = len1 && !p < len2 then - (val_ascii v2.[!p]) else !cmp in (** Compare digit part *) let compare_digit () = let extract_int v p = let start_p = !p in while !p < String.length v && is_digit v.[!p] do incr p done; let substr = String.sub v !p ((String.length v) - !p) in let res = match String.sub v start_p (!p - start_p) with | "" -> 0 | s -> int_of_string s in res, substr in let i1, tl1 = extract_int v1 (ref !p) in let i2, tl2 = extract_int v2 (ref !p) in i1 - i2, tl1, tl2 in match compare_vascii () with | 0 -> begin match compare_digit () with | 0, tl1, tl2 -> if tl1 <> "" && is_digit tl1.[0] then 1 else if tl2 <> "" && is_digit tl2.[0] then -1 else version_compare tl1 tl2 | n, _, _ -> n end | n -> n end else begin 0 end let version_of_string str = str let string_of_version t = t let chop t = try let pos = String.rindex t '.' in String.sub t 0 pos with Not_found -> t let rec comparator_apply v op = match op with | VGreater cv -> (version_compare v cv) > 0 | VGreaterEqual cv -> (version_compare v cv) >= 0 | VLesser cv -> (version_compare v cv) < 0 | VLesserEqual cv -> (version_compare v cv) <= 0 | VEqual cv -> (version_compare v cv) = 0 | VOr (op1, op2) -> (comparator_apply v op1) || (comparator_apply v op2) | VAnd (op1, op2) -> (comparator_apply v op1) && (comparator_apply v op2) let rec string_of_comparator = function | VGreater v -> "> "^(string_of_version v) | VEqual v -> "= "^(string_of_version v) | VLesser v -> "< "^(string_of_version v) | VGreaterEqual v -> ">= "^(string_of_version v) | VLesserEqual v -> "<= "^(string_of_version v) | VOr (c1, c2) -> (string_of_comparator c1)^" || "^(string_of_comparator c2) | VAnd (c1, c2) -> (string_of_comparator c1)^" && "^(string_of_comparator c2) let rec varname_of_comparator = let concat p v = OASISUtils.varname_concat p (OASISUtils.varname_of_string (string_of_version v)) in function | VGreater v -> concat "gt" v | VLesser v -> concat "lt" v | VEqual v -> concat "eq" v | VGreaterEqual v -> concat "ge" v | VLesserEqual v -> concat "le" v | VOr (c1, c2) -> (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) | VAnd (c1, c2) -> (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) end module OASISLicense = struct (* # 22 "src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall *) type license = string type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion type license_dep_5_unit = { license: license; excption: license_exception option; version: license_version; } type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) end module OASISExpr = struct (* # 22 "src/oasis/OASISExpr.ml" *) open OASISGettext open OASISUtils type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end module OASISText = struct (* # 22 "src/oasis/OASISText.ml" *) type elt = | Para of string | Verbatim of string | BlankLine type t = elt list end module OASISSourcePatterns = struct (* # 22 "src/oasis/OASISSourcePatterns.ml" *) open OASISUtils open OASISGettext module Templater = struct (* TODO: use this module in BaseEnv.var_expand and BaseFileAB, at least. *) type t = { atoms: atom list; origin: string } and atom = | Text of string | Expr of expr and expr = | Ident of string | String of string | Call of string * expr type env = { variables: string MapString.t; functions: (string -> string) MapString.t; } let eval env t = let rec eval_expr env = function | String str -> str | Ident nm -> begin try MapString.find nm env.variables with Not_found -> (* TODO: add error location within the string. *) failwithf (f_ "Unable to find variable %S in source pattern %S") nm t.origin end | Call (fn, expr) -> begin try (MapString.find fn env.functions) (eval_expr env expr) with Not_found -> (* TODO: add error location within the string. *) failwithf (f_ "Unable to find function %S in source pattern %S") fn t.origin end in String.concat "" (List.map (function | Text str -> str | Expr expr -> eval_expr env expr) t.atoms) let parse env s = let lxr = Genlex.make_lexer [] in let parse_expr s = let st = lxr (Stream.of_string s) in match Stream.npeek 3 st with | [Genlex.Ident fn; Genlex.Ident nm] -> Call(fn, Ident nm) | [Genlex.Ident fn; Genlex.String str] -> Call(fn, String str) | [Genlex.String str] -> String str | [Genlex.Ident nm] -> Ident nm (* TODO: add error location within the string. *) | _ -> failwithf (f_ "Unable to parse expression %S") s in let parse s = let lst_exprs = ref [] in let ss = let buff = Buffer.create (String.length s) in Buffer.add_substitute buff (fun s -> lst_exprs := (parse_expr s) :: !lst_exprs; "\000") s; Buffer.contents buff in let rec join = function | hd1 :: tl1, hd2 :: tl2 -> Text hd1 :: Expr hd2 :: join (tl1, tl2) | [], tl -> List.map (fun e -> Expr e) tl | tl, [] -> List.map (fun e -> Text e) tl in join (OASISString.nsplit ss '\000', List.rev (!lst_exprs)) in let t = {atoms = parse s; origin = s} in (* We rely on a simple evaluation for checking variables/functions. It works because there is no if/loop statement. *) let _s : string = eval env t in t (* # 144 "src/oasis/OASISSourcePatterns.ml" *) end type t = Templater.t let env ~modul () = { Templater. variables = MapString.of_list ["module", modul]; functions = MapString.of_list [ "capitalize_file", OASISUnixPath.capitalize_file; "uncapitalize_file", OASISUnixPath.uncapitalize_file; ]; } let all_possible_files lst ~path ~modul = let eval = Templater.eval (env ~modul ()) in List.fold_left (fun acc pat -> OASISUnixPath.concat path (eval pat) :: acc) [] lst let to_string t = t.Templater.origin end module OASISTypes = struct (* # 22 "src/oasis/OASISTypes.ml" *) type name = string type package_name = string type url = string type unix_dirname = string type unix_filename = string (* TODO: replace everywhere. *) type host_dirname = string (* TODO: replace everywhere. *) type host_filename = string (* TODO: replace everywhere. *) type prog = string type arg = string type args = string list type command_line = (prog * arg list) type findlib_name = string type findlib_full = string type compiled_object = | Byte | Native | Best type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name type tool = | ExternalTool of name | InternalExecutable of name type vcs = | Darcs | Git | Svn | Cvs | Hg | Bzr | Arch | Monotone | OtherVCS of url type plugin_kind = [ `Configure | `Build | `Doc | `Test | `Install | `Extra ] type plugin_data_purpose = [ `Configure | `Build | `Install | `Clean | `Distclean | `Install | `Uninstall | `Test | `Doc | `Extra | `Other of string ] type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list type 'a conditional = 'a OASISExpr.choices type custom = { pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } type common_section = { cs_name: name; cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } type build_section = { bs_build: bool conditional; bs_install: bool conditional; bs_path: unix_dirname; bs_compiled_object: compiled_object; bs_build_depends: dependency list; bs_build_tools: tool list; bs_interface_patterns: OASISSourcePatterns.t list; bs_implementation_patterns: OASISSourcePatterns.t list; bs_c_sources: unix_filename list; bs_data_files: (unix_filename * unix_filename option) list; bs_findlib_extra_files: unix_filename list; bs_ccopt: args conditional; bs_cclib: args conditional; bs_dlllib: args conditional; bs_dllpath: args conditional; bs_byteopt: args conditional; bs_nativeopt: args conditional; } type library = { lib_modules: string list; lib_pack: bool; lib_internal_modules: string list; lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_directory: unix_dirname option; lib_findlib_containers: findlib_name list; } type object_ = { obj_modules: string list; obj_findlib_fullname: findlib_name list option; obj_findlib_directory: unix_dirname option; } type executable = { exec_custom: bool; exec_main_is: unix_filename; } type flag = { flag_description: string option; flag_default: bool conditional; } type source_repository = { src_repo_type: vcs; src_repo_location: url; src_repo_browser: url option; src_repo_module: string option; src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; } type test = { test_type: [`Test] plugin; test_command: command_line conditional; test_custom: custom; test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; } type doc_format = | HTML of unix_filename (* TODO: source filename. *) | DocText | PDF | PostScript | Info of unix_filename (* TODO: source filename. *) | DVI | OtherDoc type doc = { doc_type: [`Doc] plugin; doc_custom: custom; doc_build: bool conditional; doc_install: bool conditional; doc_install_dir: unix_filename; (* TODO: dest filename ?. *) doc_title: string; doc_authors: string list; doc_abstract: string option; doc_format: doc_format; (* TODO: src filename. *) doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; } type section = | Library of common_section * build_section * library | Object of common_section * build_section * object_ | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc type section_kind = [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { oasis_version: OASISVersion.t; ocaml_version: OASISVersion.comparator option; findlib_version: OASISVersion.comparator option; alpha_features: string list; beta_features: string list; name: package_name; version: OASISVersion.t; license: OASISLicense.t; license_file: unix_filename option; (* TODO: source filename. *) copyrights: string list; maintainers: string list; authors: string list; homepage: url option; bugreports: url option; synopsis: string; description: OASISText.t option; tags: string list; categories: url list; conf_type: [`Configure] plugin; conf_custom: custom; build_type: [`Build] plugin; build_custom: custom; install_type: [`Install] plugin; install_custom: custom; uninstall_custom: custom; clean_custom: custom; distclean_custom: custom; files_ab: unix_filename list; (* TODO: source filename. *) sections: section list; plugins: [`Extra] plugin list; disable_oasis_section: unix_filename list; (* TODO: source filename. *) schema_data: PropList.Data.t; plugin_data: plugin_data; } end module OASISFeatures = struct (* # 22 "src/oasis/OASISFeatures.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISVersion module MapPlugin = Map.Make (struct type t = plugin_kind * name let compare = Pervasives.compare end) module Data = struct type t = { oasis_version: OASISVersion.t; plugin_versions: OASISVersion.t option MapPlugin.t; alpha_features: string list; beta_features: string list; } let create oasis_version alpha_features beta_features = { oasis_version = oasis_version; plugin_versions = MapPlugin.empty; alpha_features = alpha_features; beta_features = beta_features } let of_package pkg = create pkg.OASISTypes.oasis_version pkg.OASISTypes.alpha_features pkg.OASISTypes.beta_features let add_plugin (plugin_kind, plugin_name, plugin_version) t = {t with plugin_versions = MapPlugin.add (plugin_kind, plugin_name) plugin_version t.plugin_versions} let plugin_version plugin_kind plugin_name t = MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions let to_string t = Printf.sprintf "oasis_version: %s; alpha_features: %s; beta_features: %s; \ plugins_version: %s" (OASISVersion.string_of_version (t:t).oasis_version) (String.concat ", " t.alpha_features) (String.concat ", " t.beta_features) (String.concat ", " (MapPlugin.fold (fun (_, plg) ver_opt acc -> (plg^ (match ver_opt with | Some v -> " "^(OASISVersion.string_of_version v) | None -> "")) :: acc) t.plugin_versions [])) end type origin = | Field of string * string | Section of string | NoOrigin type stage = Alpha | Beta let string_of_stage = function | Alpha -> "alpha" | Beta -> "beta" let field_of_stage = function | Alpha -> "AlphaFeatures" | Beta -> "BetaFeatures" type publication = InDev of stage | SinceVersion of OASISVersion.t type t = { name: string; plugin: all_plugin option; publication: publication; description: unit -> string; } (* TODO: mutex protect this. *) let all_features = Hashtbl.create 13 let since_version ver_str = SinceVersion (version_of_string ver_str) let alpha = InDev Alpha let beta = InDev Beta let to_string t = Printf.sprintf "feature: %s; plugin: %s; publication: %s" (t:t).name (match t.plugin with | None -> "" | Some (_, nm, _) -> nm) (match t.publication with | InDev stage -> string_of_stage stage | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) let data_check t data origin = let no_message = "no message" in let check_feature features stage = let has_feature = List.mem (t:t).name features in if not has_feature then match (origin:origin) with | Field (fld, where) -> Some (Printf.sprintf (f_ "Field %s in %s is only available when feature %s \ is in field %s.") fld where t.name (field_of_stage stage)) | Section sct -> Some (Printf.sprintf (f_ "Section %s is only available when features %s \ is in field %s.") sct t.name (field_of_stage stage)) | NoOrigin -> Some no_message else None in let version_is_good ~min_version version fmt = let version_is_good = OASISVersion.comparator_apply version (OASISVersion.VGreaterEqual min_version) in Printf.ksprintf (fun str -> if version_is_good then None else Some str) fmt in match origin, t.plugin, t.publication with | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha | _, _, InDev Beta -> check_feature data.Data.beta_features Beta | Field(fld, where), None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Field %s in %s is only valid since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking \ OASIS changelog.") fld where (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Field(fld, where), Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Field %s in %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") fld where plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Field %s in %s is only valid when the OASIS plugin %s \ is defined.") fld where plugin_name in version_is_good ~min_version plugin_version_current (f_ "Field %s in %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") fld where plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | Section sct, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Section %s is only valid for since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking OASIS \ changelog.") sct (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Section sct, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Section %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") sct plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Section %s is only valid when the OASIS plugin %s \ is defined.") sct plugin_name in version_is_good ~min_version plugin_version_current (f_ "Section %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") sct plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | NoOrigin, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version "%s" no_message | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> raise Not_found in version_is_good ~min_version plugin_version_current "%s" no_message with Not_found -> Some no_message end let data_assert t data origin = match data_check t data origin with | None -> () | Some str -> failwith str let data_test t data = match data_check t data NoOrigin with | None -> true | Some _ -> false let package_test t pkg = data_test t (Data.of_package pkg) let create ?plugin name publication description = let () = if Hashtbl.mem all_features name then failwithf "Feature '%s' is already declared." name in let t = { name = name; plugin = plugin; publication = publication; description = description; } in Hashtbl.add all_features name t; t let get_stage name = try (Hashtbl.find all_features name).publication with Not_found -> failwithf (f_ "Feature %s doesn't exist.") name let list () = Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] (* * Real flags. *) let features = create "features_fields" (since_version "0.4") (fun () -> s_ "Enable to experiment not yet official features.") let flag_docs = create "flag_docs" (since_version "0.3") (fun () -> s_ "Make building docs require '-docs' flag at configure.") let flag_tests = create "flag_tests" (since_version "0.3") (fun () -> s_ "Make running tests require '-tests' flag at configure.") let pack = create "pack" (since_version "0.3") (fun () -> s_ "Allow to create packed library.") let section_object = create "section_object" beta (fun () -> s_ "Implement an object section.") let dynrun_for_release = create "dynrun_for_release" alpha (fun () -> s_ "Make '-setup-update dynamic' suitable for releasing project.") let compiled_setup_ml = create "compiled_setup_ml" alpha (fun () -> s_ "Compile the setup.ml and speed-up actions done with it.") let disable_oasis_section = create "disable_oasis_section" alpha (fun () -> s_ "Allow the OASIS section comments and digests to be omitted in \ generated files.") let no_automatic_syntax = create "no_automatic_syntax" alpha (fun () -> s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ that matches the internal heuristic (if a dependency ends with \ a .syntax or is a well known syntax).") let findlib_directory = create "findlib_directory" beta (fun () -> s_ "Allow to install findlib libraries in sub-directories of the target \ findlib directory.") let findlib_extra_files = create "findlib_extra_files" beta (fun () -> s_ "Allow to install extra files for findlib libraries.") let source_patterns = create "source_patterns" alpha (fun () -> s_ "Customize mapping between module name and source file.") end module OASISSection = struct (* # 22 "src/oasis/OASISSection.ml" *) open OASISTypes let section_kind_common = function | Library (cs, _, _) -> `Library, cs | Object (cs, _, _) -> `Object, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> `Flag, cs | SrcRepo (cs, _) -> `SrcRepo, cs | Test (cs, _) -> `Test, cs | Doc (cs, _) -> `Doc, cs let section_common sct = snd (section_kind_common sct) let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) | Object (_, bs, obj) -> Object (cs, bs, obj) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) | Test (_, tst) -> Test (cs, tst) | Doc (_, doc) -> Doc (cs, doc) (** Key used to identify section *) let section_id sct = let k, cs = section_kind_common sct in k, cs.cs_name let string_of_section_kind = function | `Library -> "library" | `Object -> "object" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" | `Test -> "test" | `Doc -> "doc" let string_of_section sct = let k, nm = section_id sct in (string_of_section_kind k)^" "^nm let section_find id scts = List.find (fun sct -> id = section_id sct) scts module CSection = struct type t = section let id = section_id let compare t1 t2 = compare (id t1) (id t2) let equal t1 t2 = (id t1) = (id t2) let hash t = Hashtbl.hash (id t) end module MapSection = Map.Make(CSection) module SetSection = Set.Make(CSection) end module OASISBuildSection = struct (* # 22 "src/oasis/OASISBuildSection.ml" *) open OASISTypes (* Look for a module file, considering capitalization or not. *) let find_module source_file_exists bs modul = let possible_lst = OASISSourcePatterns.all_possible_files (bs.bs_interface_patterns @ bs.bs_implementation_patterns) ~path:bs.bs_path ~modul in match List.filter source_file_exists possible_lst with | (fn :: _) as fn_lst -> `Sources (OASISUnixPath.chop_extension fn, fn_lst) | [] -> let open OASISUtils in let _, rev_lst = List.fold_left (fun (set, acc) fn -> let base_fn = OASISUnixPath.chop_extension fn in if SetString.mem base_fn set then set, acc else SetString.add base_fn set, base_fn :: acc) (SetString.empty, []) possible_lst in `No_sources (List.rev rev_lst) end module OASISExecutable = struct (* # 22 "src/oasis/OASISExecutable.ml" *) open OASISTypes let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = let dir = OASISUnixPath.concat bs.bs_path (OASISUnixPath.dirname exec.exec_main_is) in let is_native_exec = match bs.bs_compiled_object with | Native -> true | Best -> is_native () | Byte -> false in OASISUnixPath.concat dir (cs.cs_name^(suffix_program ())), if not is_native_exec && not exec.exec_custom && bs.bs_c_sources <> [] then Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) else None end module OASISLibrary = struct (* # 22 "src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISGettext let find_module ~ctxt source_file_exists cs bs modul = match OASISBuildSection.find_module source_file_exists bs modul with | `Sources _ as res -> res | `No_sources _ as res -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching module '%s' in library %s.") modul cs.cs_name; OASISMessage.warning ~ctxt (f_ "Use InterfacePatterns or ImplementationPatterns to define \ this file with feature %S.") (OASISFeatures.source_patterns.OASISFeatures.name); res let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> match find_module ~ctxt source_file_exists cs bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> acc) [] (lib.lib_modules @ lib.lib_internal_modules) let generated_unix_files ~ctxt ~is_native ~has_native_dynlink ~ext_lib ~ext_dll ~source_file_exists (cs, bs, lib) = let find_modules lst ext = let find_module modul = match find_module ~ctxt source_file_exists cs bs modul with | `Sources (_, [fn]) when ext <> "cmi" && Filename.check_suffix fn ".mli" -> None (* No implementation files for pure interface. *) | `Sources (base_fn, _) -> Some [base_fn] | `No_sources lst -> Some lst in List.fold_left (fun acc nm -> match find_module nm with | None -> acc | Some base_fns -> List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) [] lst in (* The .cmx that be compiled along *) let cmxs = let should_be_built = match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then if lib.lib_pack then find_modules [cs.cs_name] "cmx" else find_modules (lib.lib_modules @ lib.lib_internal_modules) "cmx" else [] in let acc_nopath = [] in (* The headers and annot/cmt files that should be compiled along *) let headers = let sufx = if lib.lib_pack then [".cmti"; ".cmt"; ".annot"] else [".cmi"; ".cmti"; ".cmt"; ".annot"] in List.map (List.fold_left (fun accu s -> let dot = String.rindex s '.' in let base = String.sub s 0 dot in List.map ((^) base) sufx @ accu) []) (find_modules lib.lib_modules "cmi") in (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc else acc in let byte acc = add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = let acc = add_pack_header (if has_native_dynlink then [cs.cs_name^".cmxs"] :: acc else acc) in [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in match bs.bs_compiled_object with | Native -> byte (native acc_nopath) | Best when is_native -> byte (native acc_nopath) | Byte | Best -> byte acc_nopath in (* Add C library to be built *) let acc_nopath = if bs.bs_c_sources <> [] then begin ["lib"^cs.cs_name^"_stubs"^ext_lib] :: if has_native_dynlink then ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath else acc_nopath end else begin acc_nopath end in (* All the files generated *) List.rev_append (List.rev_map (List.rev_map (OASISUnixPath.concat bs.bs_path)) acc_nopath) (headers @ cmxs) end module OASISObject = struct (* # 22 "src/oasis/OASISObject.ml" *) open OASISTypes open OASISGettext let find_module ~ctxt source_file_exists cs bs modul = match OASISBuildSection.find_module source_file_exists bs modul with | `Sources _ as res -> res | `No_sources _ as res -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching module '%s' in object %s.") modul cs.cs_name; OASISMessage.warning ~ctxt (f_ "Use InterfacePatterns or ImplementationPatterns to define \ this file with feature %S.") (OASISFeatures.source_patterns.OASISFeatures.name); res let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = List.fold_left (fun acc modul -> match find_module ~ctxt source_file_exists cs bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> acc) [] obj.obj_modules let generated_unix_files ~ctxt ~is_native ~source_file_exists (cs, bs, obj) = let find_module ext modul = match find_module ~ctxt source_file_exists cs bs modul with | `Sources (base_fn, _) -> [base_fn ^ ext] | `No_sources lst -> lst in let header, byte, native, c_object, f = match obj.obj_modules with | [ m ] -> (find_module ".cmi" m, find_module ".cmo" m, find_module ".cmx" m, find_module ".o" m, fun x -> x) | _ -> ([cs.cs_name ^ ".cmi"], [cs.cs_name ^ ".cmo"], [cs.cs_name ^ ".cmx"], [cs.cs_name ^ ".o"], OASISUnixPath.concat bs.bs_path) in List.map (List.map f) ( match bs.bs_compiled_object with | Native -> native :: c_object :: byte :: header :: [] | Best when is_native -> native :: c_object :: byte :: header :: [] | Byte | Best -> byte :: header :: []) end module OASISFindlib = struct (* # 22 "src/oasis/OASISFindlib.ml" *) open OASISTypes open OASISUtils open OASISGettext type library_name = name type findlib_part_name = name type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t exception InternalLibraryNotFound of library_name exception FindlibPackageNotFound of findlib_name type group_t = | Container of findlib_name * group_t list | Package of (findlib_name * common_section * build_section * [`Library of library | `Object of object_] * unix_dirname option * group_t list) type data = common_section * build_section * [`Library of library | `Object of object_] type tree = | Node of (data option) * (tree MapString.t) | Leaf of data let findlib_mapping pkg = (* Map from library name to either full findlib name or parts + parent. *) let fndlb_parts_of_lib_name = let fndlb_parts cs lib = let name = match lib.lib_findlib_name with | Some nm -> nm | None -> cs.cs_name in let name = String.concat "." (lib.lib_findlib_containers @ [name]) in name in List.fold_left (fun mp -> function | Library (cs, _, lib) -> begin let lib_name = cs.cs_name in let fndlb_parts = fndlb_parts cs lib in if MapString.mem lib_name mp then failwithf (f_ "The library name '%s' is used more than once.") lib_name; match lib.lib_findlib_parent with | Some lib_name_parent -> MapString.add lib_name (`Unsolved (lib_name_parent, fndlb_parts)) mp | None -> MapString.add lib_name (`Solved fndlb_parts) mp end | Object (cs, _, obj) -> begin let obj_name = cs.cs_name in if MapString.mem obj_name mp then failwithf (f_ "The object name '%s' is used more than once.") obj_name; let findlib_full_name = match obj.obj_findlib_fullname with | Some ns -> String.concat "." ns | None -> obj_name in MapString.add obj_name (`Solved findlib_full_name) mp end | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty pkg.sections in (* Solve the above graph to be only library name to full findlib name. *) let fndlb_name_of_lib_name = let rec solve visited mp lib_name lib_name_child = if SetString.mem lib_name visited then failwithf (f_ "Library '%s' is involved in a cycle \ with regard to findlib naming.") lib_name; let visited = SetString.add lib_name visited in try match MapString.find lib_name mp with | `Solved fndlb_nm -> fndlb_nm, mp | `Unsolved (lib_nm_parent, post_fndlb_nm) -> let pre_fndlb_nm, mp = solve visited mp lib_nm_parent lib_name in let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp with Not_found -> failwithf (f_ "Library '%s', which is defined as the findlib parent of \ library '%s', doesn't exist.") lib_name lib_name_child in let mp = MapString.fold (fun lib_name status mp -> match status with | `Solved _ -> (* Solved initialy, no need to go further *) mp | `Unsolved _ -> let _, mp = solve SetString.empty mp lib_name "" in mp) fndlb_parts_of_lib_name fndlb_parts_of_lib_name in MapString.map (function | `Solved fndlb_nm -> fndlb_nm | `Unsolved _ -> assert false) mp in (* Convert an internal library name to a findlib name. *) let findlib_name_of_library_name lib_nm = try MapString.find lib_nm fndlb_name_of_lib_name with Not_found -> raise (InternalLibraryNotFound lib_nm) in (* Add a library to the tree. *) let add sct mp = let fndlb_fullname = let cs, _, _ = sct in let lib_name = cs.cs_name in findlib_name_of_library_name lib_name in let rec add_children nm_lst (children: tree MapString.t) = match nm_lst with | (hd :: tl) -> begin let node = try add_node tl (MapString.find hd children) with Not_found -> (* New node *) new_node tl in MapString.add hd node children end | [] -> (* Should not have a nameless library. *) assert false and add_node tl node = if tl = [] then begin match node with | Node (None, children) -> Node (Some sct, children) | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> (* TODO: allow to merge Package, i.e. * archive(byte) = "foo.cma foo_init.cmo" *) let cs, _, _ = sct in failwithf (f_ "Library '%s' and '%s' have the same findlib name '%s'") cs.cs_name cs'.cs_name fndlb_fullname end else begin match node with | Leaf data -> Node (Some data, add_children tl MapString.empty) | Node (data_opt, children) -> Node (data_opt, add_children tl children) end and new_node = function | [] -> Leaf sct | hd :: tl -> Node (None, MapString.add hd (new_node tl) MapString.empty) in add_children (OASISString.nsplit fndlb_fullname '.') mp in let unix_directory dn lib = let directory = match lib with | `Library lib -> lib.lib_findlib_directory | `Object obj -> obj.obj_findlib_directory in match dn, directory with | None, None -> None | None, Some dn | Some dn, None -> Some dn | Some dn1, Some dn2 -> Some (OASISUnixPath.concat dn1 dn2) in let rec group_of_tree dn mp = MapString.fold (fun nm node acc -> let cur = match node with | Node (Some (cs, bs, lib), children) -> let current_dn = unix_directory dn lib in Package (nm, cs, bs, lib, current_dn, group_of_tree current_dn children) | Node (None, children) -> Container (nm, group_of_tree dn children) | Leaf (cs, bs, lib) -> let current_dn = unix_directory dn lib in Package (nm, cs, bs, lib, current_dn, []) in cur :: acc) mp [] in let group_mp = List.fold_left (fun mp -> function | Library (cs, bs, lib) -> add (cs, bs, `Library lib) mp | Object (cs, bs, obj) -> add (cs, bs, `Object obj) mp | _ -> mp) MapString.empty pkg.sections in let groups = group_of_tree None group_mp in let library_name_of_findlib_name = lazy begin (* Revert findlib_name_of_library_name. *) MapString.fold (fun k v mp -> MapString.add v k mp) fndlb_name_of_lib_name MapString.empty end in let library_name_of_findlib_name fndlb_nm = try MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) with Not_found -> raise (FindlibPackageNotFound fndlb_nm) in groups, findlib_name_of_library_name, library_name_of_findlib_name let findlib_of_group = function | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _, _) -> fndlb_nm let root_of_group grp = let rec root_lib_aux = (* We do a DFS in the group. *) function | Container (_, children) -> List.fold_left (fun res grp -> if res = None then root_lib_aux grp else res) None children | Package (_, cs, bs, lib, _, _) -> Some (cs, bs, lib) in match root_lib_aux grp with | Some res -> res | None -> failwithf (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) end module OASISFlag = struct (* # 22 "src/oasis/OASISFlag.ml" *) end module OASISPackage = struct (* # 22 "src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct (* # 22 "src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct (* # 22 "src/oasis/OASISTest.ml" *) end module OASISDocument = struct (* # 22 "src/oasis/OASISDocument.ml" *) end module OASISExec = struct (* # 22 "src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils open OASISMessage (* TODO: I don't like this quote, it is there because $(rm) foo expands to * 'rm -f' foo... *) let run ~ctxt ?f_exit_code ?(quote=true) cmd args = let cmd = if quote then if Sys.os_type = "Win32" then if String.contains cmd ' ' then (* Double the 1st double quote... win32... sigh *) "\""^(Filename.quote cmd) else cmd else Filename.quote cmd else cmd in let cmdline = String.concat " " (cmd :: args) in info ~ctxt (f_ "Running command '%s'") cmdline; match f_exit_code, Sys.command cmdline with | None, 0 -> () | None, i -> failwithf (f_ "Command '%s' terminated with error code %d") cmdline i | Some f, i -> f i let run_read_output ~ctxt ?f_exit_code cmd args = let fn = Filename.temp_file "oasis-" ".txt" in try begin let () = run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) in let chn = open_in fn in let routput = ref [] in begin try while true do routput := (input_line chn) :: !routput done with End_of_file -> () end; close_in chn; Sys.remove fn; List.rev !routput end with e -> (try Sys.remove fn with _ -> ()); raise e let run_read_one_line ~ctxt ?f_exit_code cmd args = match run_read_output ~ctxt ?f_exit_code cmd args with | [fst] -> fst | lst -> failwithf (f_ "Command return unexpected output %S") (String.concat "\n" lst) end module OASISFileUtil = struct (* # 22 "src/oasis/OASISFileUtil.ml" *) open OASISGettext let file_exists_case fn = let dirname = Filename.dirname fn in let basename = Filename.basename fn in if Sys.file_exists dirname then if basename = Filename.current_dir_name then true else List.mem basename (Array.to_list (Sys.readdir dirname)) else false let find_file ?(case_sensitive=true) paths exts = (* Cardinal product of two list *) let ( * ) lst1 lst2 = List.flatten (List.map (fun a -> List.map (fun b -> a, b) lst2) lst1) in let rec combined_paths lst = match lst with | p1 :: p2 :: tl -> let acc = (List.map (fun (a, b) -> Filename.concat a b) (p1 * p2)) in combined_paths (acc :: tl) | [e] -> e | [] -> [] in let alternatives = List.map (fun (p, e) -> if String.length e > 0 && e.[0] <> '.' then p ^ "." ^ e else p ^ e) ((combined_paths paths) * exts) in List.find (fun file -> (if case_sensitive then file_exists_case file else Sys.file_exists file) && not (Sys.is_directory file) ) alternatives let which ~ctxt prg = let path_sep = match Sys.os_type with | "Win32" -> ';' | _ -> ':' in let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in let exec_ext = match Sys.os_type with | "Win32" -> "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) | _ -> [""] in find_file ~case_sensitive:false [path_lst; [prg]] exec_ext (**/**) let rec fix_dir dn = (* Windows hack because Sys.file_exists "src\\" = false when * Sys.file_exists "src" = true *) let ln = String.length dn in if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then fix_dir (String.sub dn 0 (ln - 1)) else dn let q = Filename.quote (**/**) let cp ~ctxt ?(recurse=false) src tgt = if recurse then match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "xcopy" [q src; q tgt; "/E"] | _ -> OASISExec.run ~ctxt "cp" ["-r"; q src; q tgt] else OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "copy" | _ -> "cp") [q src; q tgt] let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "md" | _ -> "mkdir") [q tgt] let rec mkdir_parent ~ctxt f tgt = let tgt = fix_dir tgt in if Sys.file_exists tgt then begin if not (Sys.is_directory tgt) then OASISUtils.failwithf (f_ "Cannot create directory '%s', a file of the same name already \ exists") tgt end else begin mkdir_parent ~ctxt f (Filename.dirname tgt); if not (Sys.file_exists tgt) then begin f tgt; mkdir ~ctxt tgt end end let rmdir ~ctxt tgt = if Sys.readdir tgt = [||] then begin match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "rd" [q tgt] | _ -> OASISExec.run ~ctxt "rm" ["-r"; q tgt] end else begin OASISMessage.error ~ctxt (f_ "Cannot remove directory '%s': not empty.") tgt end let glob ~ctxt fn = let basename = Filename.basename fn in if String.length basename >= 2 && basename.[0] = '*' && basename.[1] = '.' then begin let ext_len = (String.length basename) - 2 in let ext = String.sub basename 2 ext_len in let dirname = Filename.dirname fn in Array.fold_left (fun acc fn -> try let fn_ext = String.sub fn ((String.length fn) - ext_len) ext_len in if fn_ext = ext then (Filename.concat dirname fn) :: acc else acc with Invalid_argument _ -> acc) [] (Sys.readdir dirname) end else begin if file_exists_case fn then [fn] else [] end end # 3159 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = let line = ref 1 in let lexer st = let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in Genlex.make_lexer ["="] st_line in let rec read_file lxr mp = match Stream.npeek 3 lxr with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; read_file lxr (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in match stream with | Some st -> read_file (lexer st) MapString.empty | None -> if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in try let mp = read_file (lexer st) MapString.empty in close_in chn; mp with e -> close_in chn; raise e end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 3239 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) (* TODO: get rid of this module. *) open OASISContext let args () = fst (fspecs ()) let default = default end module BaseMessage = struct (* # 22 "src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall *) open OASISMessage open BaseContext let debug fmt = debug ~ctxt:!default fmt let info fmt = info ~ctxt:!default fmt let warning fmt = warning ~ctxt:!default fmt let error fmt = error ~ctxt:!default fmt end module BaseEnv = struct (* # 22 "src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils open OASISContext open PropList module MapString = BaseEnvLight.MapString type origin_t = | ODefault | OGetEnv | OFileLoad | OCommandLine type cli_handle_t = | CLINone | CLIAuto | CLIWith | CLIEnable | CLIUser of (Arg.key * Arg.spec * Arg.doc) list type definition_t = { hide: bool; dump: bool; cli: cli_handle_t; arg_help: string option; group: string option; } let schema = Schema.create "environment" (* Environment data *) let env = Data.create () (* Environment data from file *) let env_from_file = ref MapString.empty (* Lexer for var *) let var_lxr = Genlex.make_lexer [] let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try (* TODO: this is a quick hack to allow calling Test.Command * without defining executable name really. I.e. if there is * an exec Executable toto, then $(toto) should be replace * by its real name. It is however useful to have this function * for other variable that depend on the host and should be * written better than that. *) let st = var_lxr (Stream.of_string var) in match Stream.npeek 3 st with | [Genlex.Ident "utoh"; Genlex.Ident nm] -> OASISHostPath.of_unix (var_get nm) | [Genlex.Ident "utoh"; Genlex.String s] -> OASISHostPath.of_unix s | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> String.escaped (var_get nm) | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> String.escaped s | [Genlex.Ident nm] -> var_get nm | _ -> failwithf (f_ "Unknown expression '%s' in variable expansion of %s.") var str with | Unknown_field (_, _) -> failwithf (f_ "No variable %s defined when trying to expand %S.") var str | Stream.Error e -> failwithf (f_ "Syntax error when parsing '%s' when trying to \ expand %S: %s") var str e) str; Buffer.contents buff and var_get name = let vl = try Schema.get schema env name with Unknown_field _ as e -> begin try MapString.find name !env_from_file with Not_found -> raise e end in var_expand vl let var_choose ?printer ?name lst = OASISExpr.choose ?printer ?name var_get lst let var_protect vl = let buff = Buffer.create (String.length vl) in String.iter (function | '$' -> Buffer.add_string buff "\\$" | c -> Buffer.add_char buff c) vl; Buffer.contents buff let var_define ?(hide=false) ?(dump=true) ?short_desc ?(cli=CLINone) ?arg_help ?group name (* TODO: type constraint on the fact that name must be a valid OCaml id *) dflt = let default = [ OFileLoad, (fun () -> MapString.find name !env_from_file); ODefault, dflt; OGetEnv, (fun () -> Sys.getenv name); ] in let extra = { hide = hide; dump = dump; cli = cli; arg_help = arg_help; group = group; } in (* Try to find a value that can be defined *) let var_get_low lst = let errors, res = List.fold_left (fun (errors, res) (_, v) -> if res = None then begin try errors, Some (v ()) with | Not_found -> errors, res | Failure rsn -> (rsn :: errors), res | e -> (Printexc.to_string e) :: errors, res end else errors, res) ([], None) (List.sort (fun (o1, _) (o2, _) -> Pervasives.compare o2 o1) lst) in match res, errors with | Some v, _ -> v | None, [] -> raise (Not_set (name, None)) | None, lst -> raise (Not_set (name, Some (String.concat (s_ ", ") lst))) in let help = match short_desc with | Some fs -> Some fs | None -> None in let var_get_lst = FieldRO.create ~schema ~name ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) ~print:var_get_low ~default ~update:(fun ?context:_ x old_x -> x @ old_x) ?help extra in fun () -> var_expand (var_get_low (var_get_lst env)) let var_redefine ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt = if Schema.mem schema name then begin (* TODO: look suspsicious, we want to memorize dflt not dflt () *) Schema.set schema env ~context:ODefault name (dflt ()); fun () -> var_get name end else begin var_define ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt end let var_ignore (_: unit -> string) = () let print_hidden = var_define ~hide:true ~dump:false ~cli:CLIAuto ~arg_help:"Print even non-printable variable. (debug)" "print_hidden" (fun () -> "false") let var_all () = List.rev (Schema.fold (fun acc nm def _ -> if not def.hide || bool_of_string (print_hidden ()) then nm :: acc else acc) [] schema) let default_filename = in_srcdir "setup.data" let load ~ctxt ?(allow_empty=false) ?(filename=default_filename) () = let open OASISFileSystem in env_from_file := let repr_filename = ctxt.srcfs#string_of_filename filename in if ctxt.srcfs#file_exists filename then begin let buf = Buffer.create 13 in defer_close (ctxt.srcfs#open_in ~mode:binary_in filename) (read_all buf); defer_close (ctxt.srcfs#open_in ~mode:binary_in filename) (fun rdr -> OASISMessage.info ~ctxt "Loading environment from %S." repr_filename; BaseEnvLight.load ~allow_empty ~filename:(repr_filename) ~stream:(stream_of_reader rdr) ()) end else if allow_empty then begin BaseEnvLight.MapString.empty end else begin failwith (Printf.sprintf (f_ "Unable to load environment, the file '%s' doesn't exist.") repr_filename) end let unload () = env_from_file := MapString.empty; Data.clear env let dump ~ctxt ?(filename=default_filename) () = let open OASISFileSystem in defer_close (ctxt.OASISContext.srcfs#open_out ~mode:binary_out filename) (fun wrtr -> let buf = Buffer.create 63 in let output nm value = Buffer.add_string buf (Printf.sprintf "%s=%S\n" nm value) in let mp_todo = (* Dump data from schema *) Schema.fold (fun mp_todo nm def _ -> if def.dump then begin try output nm (Schema.get schema env nm) with Not_set _ -> () end; MapString.remove nm mp_todo) !env_from_file schema in (* Dump data defined outside of schema *) MapString.iter output mp_todo; wrtr#output buf) let print () = let printable_vars = Schema.fold (fun acc nm def short_descr_opt -> if not def.hide || bool_of_string (print_hidden ()) then begin try let value = Schema.get schema env nm in let txt = match short_descr_opt with | Some s -> s () | None -> nm in (txt, value) :: acc with Not_set _ -> acc end else acc) [] schema in let max_length = List.fold_left max 0 (List.rev_map String.length (List.rev_map fst printable_vars)) in let dot_pad str = String.make ((max_length - (String.length str)) + 3) '.' in Printf.printf "\nConfiguration:\n"; List.iter (fun (name, value) -> Printf.printf "%s: %s" name (dot_pad name); if value = "" then Printf.printf "\n" else Printf.printf " %s\n" value) (List.rev printable_vars); Printf.printf "\n%!" let args () = let arg_concat = OASISUtils.varname_concat ~hyphen:'-' in [ "--override", Arg.Tuple ( let rvr = ref "" in let rvl = ref "" in [ Arg.Set_string rvr; Arg.Set_string rvl; Arg.Unit (fun () -> Schema.set schema env ~context:OCommandLine !rvr !rvl) ] ), "var+val Override any configuration variable."; ] @ List.flatten (Schema.fold (fun acc name def short_descr_opt -> let var_set s = Schema.set schema env ~context:OCommandLine name s in let arg_name = OASISUtils.varname_of_string ~hyphen:'-' name in let hlp = match short_descr_opt with | Some txt -> txt () | None -> "" in let arg_hlp = match def.arg_help with | Some s -> s | None -> "str" in let default_value = try Printf.sprintf (f_ " [%s]") (Schema.get schema env name) with Not_set _ -> "" in let args = match def.cli with | CLINone -> [] | CLIAuto -> [ arg_concat "--" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIWith -> [ arg_concat "--with-" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIEnable -> let dflt = if default_value = " [true]" then s_ " [default: enabled]" else s_ " [default: disabled]" in [ arg_concat "--enable-" arg_name, Arg.Unit (fun () -> var_set "true"), Printf.sprintf (f_ " %s%s") hlp dflt; arg_concat "--disable-" arg_name, Arg.Unit (fun () -> var_set "false"), Printf.sprintf (f_ " %s%s") hlp dflt ] | CLIUser lst -> lst in args :: acc) [] schema) end module BaseArgExt = struct (* # 22 "src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext let parse argv args = (* Simulate command line for Arg *) let current = ref 0 in try Arg.parse_argv ~current:current (Array.concat [[|"none"|]; argv]) (Arg.align args) (failwithf (f_ "Don't know what to do with arguments: '%s'")) (s_ "configure options:") with | Arg.Help txt -> print_endline txt; exit 0 | Arg.Bad txt -> prerr_endline txt; exit 1 end module BaseCheck = struct (* # 22 "src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage open OASISUtils open OASISGettext let prog_best prg prg_lst = var_redefine prg (fun () -> let alternate = List.fold_left (fun res e -> match res with | Some _ -> res | None -> try Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) with Not_found -> None) None prg_lst in match alternate with | Some prg -> prg | None -> raise Not_found) let prog prg = prog_best prg [prg] let prog_opt prg = prog_best prg [prg^".opt"; prg] let ocamlfind = prog "ocamlfind" let version var_prefix cmp fversion () = (* Really compare version provided *) let var = var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) in var_redefine ~hide:true var (fun () -> let version_str = match fversion () with | "[Distributed with OCaml]" -> begin try (var_get "ocaml_version") with Not_found -> warning (f_ "Variable ocaml_version not defined, fallback \ to default"); Sys.ocaml_version end | res -> res in let version = OASISVersion.version_of_string version_str in if OASISVersion.comparator_apply version cmp then version_str else failwithf (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") var_prefix (OASISVersion.string_of_comparator cmp) version_str) () let package_version pkg = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%v"; pkg] let package ?version_comparator pkg () = let var = OASISUtils.varname_concat "pkg_" (OASISUtils.varname_of_string pkg) in let findlib_dir pkg = let dir = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%d"; pkg] in if Sys.file_exists dir && Sys.is_directory dir then dir else failwithf (f_ "When looking for findlib package %s, \ directory %s return doesn't exist") pkg dir in let vl = var_redefine var (fun () -> findlib_dir pkg) () in ( match version_comparator with | Some ver_cmp -> ignore (version var ver_cmp (fun _ -> package_version pkg) ()) | None -> () ); vl end module BaseOCamlcConfig = struct (* # 22 "src/base/BaseOCamlcConfig.ml" *) open BaseEnv open OASISUtils open OASISGettext module SMap = Map.Make(String) let ocamlc = BaseCheck.prog_opt "ocamlc" let ocamlc_config_map = (* Map name to value for ocamlc -config output (name ^": "^value) *) let rec split_field mp lst = match lst with | line :: tl -> let mp = try let pos_semicolon = String.index line ':' in if pos_semicolon > 1 then ( let name = String.sub line 0 pos_semicolon in let linelen = String.length line in let value = if linelen > pos_semicolon + 2 then String.sub line (pos_semicolon + 2) (linelen - pos_semicolon - 2) else "" in SMap.add name value mp ) else ( mp ) with Not_found -> ( mp ) in split_field mp tl | [] -> mp in let cache = lazy (var_protect (Marshal.to_string (split_field SMap.empty (OASISExec.run_read_output ~ctxt:!BaseContext.default (ocamlc ()) ["-config"])) [])) in var_redefine "ocamlc_config_map" ~hide:true ~dump:false (fun () -> (* TODO: update if ocamlc change !!! *) Lazy.force cache) let var_define nm = (* Extract data from ocamlc -config *) let avlbl_config_get () = Marshal.from_string (ocamlc_config_map ()) 0 in let chop_version_suffix s = try String.sub s 0 (String.index s '+') with _ -> s in let nm_config, value_config = match nm with | "ocaml_version" -> "version", chop_version_suffix | _ -> nm, (fun x -> x) in var_redefine nm (fun () -> try let map = avlbl_config_get () in let value = SMap.find nm_config map in value_config value with Not_found -> failwithf (f_ "Cannot find field '%s' in '%s -config' output") nm (ocamlc ())) end module BaseStandardVar = struct (* # 22 "src/base/BaseStandardVar.ml" *) open OASISGettext open OASISTypes open BaseCheck open BaseEnv let ocamlfind = BaseCheck.ocamlfind let ocamlc = BaseOCamlcConfig.ocamlc let ocamlopt = prog_opt "ocamlopt" let ocamlbuild = prog "ocamlbuild" (**/**) let rpkg = ref None let pkg_get () = match !rpkg with | Some pkg -> pkg | None -> failwith (s_ "OASIS Package is not set") let var_cond = ref [] let var_define_cond ~since_version f dflt = let holder = ref (fun () -> dflt) in let since_version = OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) in var_cond := (fun ver -> if OASISVersion.comparator_apply ver since_version then holder := f ()) :: !var_cond; fun () -> !holder () (**/**) let pkg_name = var_define ~short_desc:(fun () -> s_ "Package name") "pkg_name" (fun () -> (pkg_get ()).name) let pkg_version = var_define ~short_desc:(fun () -> s_ "Package version") "pkg_version" (fun () -> (OASISVersion.string_of_version (pkg_get ()).version)) let c = BaseOCamlcConfig.var_define let os_type = c "os_type" let system = c "system" let architecture = c "architecture" let ccomp_type = c "ccomp_type" let ocaml_version = c "ocaml_version" (* TODO: Check standard variable presence at runtime *) let standard_library_default = c "standard_library_default" let standard_library = c "standard_library" let standard_runtime = c "standard_runtime" let bytecomp_c_compiler = c "bytecomp_c_compiler" let native_c_compiler = c "native_c_compiler" let model = c "model" let ext_obj = c "ext_obj" let ext_asm = c "ext_asm" let ext_lib = c "ext_lib" let ext_dll = c "ext_dll" let default_executable_name = c "default_executable_name" let systhread_supported = c "systhread_supported" let flexlink = BaseCheck.prog "flexlink" let flexdll_version = var_define ~short_desc:(fun () -> "FlexDLL version (Win32)") "flexdll_version" (fun () -> let lst = OASISExec.run_read_output ~ctxt:!BaseContext.default (flexlink ()) ["-help"] in match lst with | line :: _ -> Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) | [] -> raise Not_found) (**/**) let p name hlp dflt = var_define ~short_desc:hlp ~cli:CLIAuto ~arg_help:"dir" name dflt let (/) a b = if os_type () = Sys.os_type then Filename.concat a b else if os_type () = "Unix" || os_type () = "Cygwin" then OASISUnixPath.concat a b else OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") (os_type ()) (**/**) let prefix = p "prefix" (fun () -> s_ "Install architecture-independent files dir") (fun () -> match os_type () with | "Win32" -> let program_files = Sys.getenv "PROGRAMFILES" in program_files/(pkg_name ()) | _ -> "/usr/local") let exec_prefix = p "exec_prefix" (fun () -> s_ "Install architecture-dependent files in dir") (fun () -> "$prefix") let bindir = p "bindir" (fun () -> s_ "User executables") (fun () -> "$exec_prefix"/"bin") let sbindir = p "sbindir" (fun () -> s_ "System admin executables") (fun () -> "$exec_prefix"/"sbin") let libexecdir = p "libexecdir" (fun () -> s_ "Program executables") (fun () -> "$exec_prefix"/"libexec") let sysconfdir = p "sysconfdir" (fun () -> s_ "Read-only single-machine data") (fun () -> "$prefix"/"etc") let sharedstatedir = p "sharedstatedir" (fun () -> s_ "Modifiable architecture-independent data") (fun () -> "$prefix"/"com") let localstatedir = p "localstatedir" (fun () -> s_ "Modifiable single-machine data") (fun () -> "$prefix"/"var") let libdir = p "libdir" (fun () -> s_ "Object code libraries") (fun () -> "$exec_prefix"/"lib") let datarootdir = p "datarootdir" (fun () -> s_ "Read-only arch-independent data root") (fun () -> "$prefix"/"share") let datadir = p "datadir" (fun () -> s_ "Read-only architecture-independent data") (fun () -> "$datarootdir") let infodir = p "infodir" (fun () -> s_ "Info documentation") (fun () -> "$datarootdir"/"info") let localedir = p "localedir" (fun () -> s_ "Locale-dependent data") (fun () -> "$datarootdir"/"locale") let mandir = p "mandir" (fun () -> s_ "Man documentation") (fun () -> "$datarootdir"/"man") let docdir = p "docdir" (fun () -> s_ "Documentation root") (fun () -> "$datarootdir"/"doc"/"$pkg_name") let htmldir = p "htmldir" (fun () -> s_ "HTML documentation") (fun () -> "$docdir") let dvidir = p "dvidir" (fun () -> s_ "DVI documentation") (fun () -> "$docdir") let pdfdir = p "pdfdir" (fun () -> s_ "PDF documentation") (fun () -> "$docdir") let psdir = p "psdir" (fun () -> s_ "PS documentation") (fun () -> "$docdir") let destdir = p "destdir" (fun () -> s_ "Prepend a path when installing package") (fun () -> raise (PropList.Not_set ("destdir", Some (s_ "undefined by construct")))) let findlib_version = var_define "findlib_version" (fun () -> BaseCheck.package_version "findlib") let is_native = var_define "is_native" (fun () -> try let _s: string = ocamlopt () in "true" with PropList.Not_set _ -> let _s: string = ocamlc () in "false") let ext_program = var_define "suffix_program" (fun () -> match os_type () with | "Win32" | "Cygwin" -> ".exe" | _ -> "") let rm = var_define ~short_desc:(fun () -> s_ "Remove a file.") "rm" (fun () -> match os_type () with | "Win32" -> "del" | _ -> "rm -f") let rmdir = var_define ~short_desc:(fun () -> s_ "Remove a directory.") "rmdir" (fun () -> match os_type () with | "Win32" -> "rd" | _ -> "rm -rf") let debug = var_define ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") ~cli:CLIEnable "debug" (fun () -> "true") let profile = var_define ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") ~cli:CLIEnable "profile" (fun () -> "false") let tests = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Compile tests executable and library and run them") ~cli:CLIEnable "tests" (fun () -> "false")) "true" let docs = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Create documentations") ~cli:CLIEnable "docs" (fun () -> "true")) "true" let native_dynlink = var_define ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") ~cli:CLINone "native_dynlink" (fun () -> let res = let ocaml_lt_312 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (ocaml_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "3.12.0")) in let flexdll_lt_030 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (flexdll_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "0.30")) in let has_native_dynlink = let ocamlfind = ocamlfind () in try let fn = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ocamlfind ["query"; "-predicates"; "native"; "dynlink"; "-format"; "%d/%a"] in Sys.file_exists fn with _ -> false in if not has_native_dynlink then false else if ocaml_lt_312 () then false else if (os_type () = "Win32" || os_type () = "Cygwin") && flexdll_lt_030 () then begin BaseMessage.warning (f_ ".cmxs generation disabled because FlexDLL needs to be \ at least 0.30. Please upgrade FlexDLL from %s to 0.30.") (flexdll_version ()); false end else true in string_of_bool res) let init pkg = rpkg := Some pkg; List.iter (fun f -> f pkg.oasis_version) !var_cond end module BaseFileAB = struct (* # 22 "src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext open BaseMessage open OASISContext let to_filename fn = if not (Filename.check_suffix fn ".ab") then warning (f_ "File '%s' doesn't have '.ab' extension") fn; OASISFileSystem.of_unix_filename (Filename.chop_extension fn) let replace ~ctxt fn_lst = let open OASISFileSystem in let ibuf, obuf = Buffer.create 13, Buffer.create 13 in List.iter (fun fn -> Buffer.clear ibuf; Buffer.clear obuf; defer_close (ctxt.srcfs#open_in (of_unix_filename fn)) (read_all ibuf); Buffer.add_string obuf (var_expand (Buffer.contents ibuf)); defer_close (ctxt.srcfs#open_out (to_filename fn)) (fun wrtr -> wrtr#output obuf)) fn_lst end module BaseLog = struct (* # 22 "src/base/BaseLog.ml" *) open OASISUtils open OASISContext open OASISGettext open OASISFileSystem let default_filename = in_srcdir "setup.log" let load ~ctxt () = let module SetTupleString = Set.Make (struct type t = string * string let compare (s11, s12) (s21, s22) = match String.compare s11 s21 with | 0 -> String.compare s12 s22 | n -> n end) in if ctxt.srcfs#file_exists default_filename then begin defer_close (ctxt.srcfs#open_in default_filename) (fun rdr -> let line = ref 1 in let lxr = Genlex.make_lexer [] (stream_of_reader rdr) in let rec read_aux (st, lst) = match Stream.npeek 2 lxr with | [Genlex.String e; Genlex.String d] -> let t = e, d in Stream.junk lxr; Stream.junk lxr; if SetTupleString.mem t st then read_aux (st, lst) else read_aux (SetTupleString.add t st, t :: lst) | [] -> List.rev lst | _ -> failwithf (f_ "Malformed log file '%s' at line %d") (ctxt.srcfs#string_of_filename default_filename) !line in read_aux (SetTupleString.empty, [])) end else begin [] end let register ~ctxt event data = defer_close (ctxt.srcfs#open_out ~mode:[Open_append; Open_creat; Open_text] ~perm:0o644 default_filename) (fun wrtr -> let buf = Buffer.create 13 in Printf.bprintf buf "%S %S\n" event data; wrtr#output buf) let unregister ~ctxt event data = let lst = load ~ctxt () in let buf = Buffer.create 13 in List.iter (fun (e, d) -> if e <> event || d <> data then Printf.bprintf buf "%S %S\n" e d) lst; if Buffer.length buf > 0 then defer_close (ctxt.srcfs#open_out default_filename) (fun wrtr -> wrtr#output buf) else ctxt.srcfs#remove default_filename let filter ~ctxt events = let st_events = SetString.of_list events in List.filter (fun (e, _) -> SetString.mem e st_events) (load ~ctxt ()) let exists ~ctxt event data = List.exists (fun v -> (event, data) = v) (load ~ctxt ()) end module BaseBuilt = struct (* # 22 "src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) | BObj (* Library *) | BDoc (* Document *) let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" | BObj -> "obj" | BDoc -> "doc")^ "_"^nm let to_log_event_done t nm = "is_"^(to_log_event_file t nm) let register ~ctxt t nm lst = BaseLog.register ~ctxt (to_log_event_done t nm) "true"; List.iter (fun alt -> let registered = List.fold_left (fun registered fn -> if OASISFileUtil.file_exists_case fn then begin BaseLog.register ~ctxt (to_log_event_file t nm) (if Filename.is_relative fn then Filename.concat (Sys.getcwd ()) fn else fn); true end else begin registered end) false alt in if not registered then warning (f_ "Cannot find an existing alternative files among: %s") (String.concat (s_ ", ") alt)) lst let unregister ~ctxt t nm = List.iter (fun (e, d) -> BaseLog.unregister ~ctxt e d) (BaseLog.filter ~ctxt [to_log_event_file t nm; to_log_event_done t nm]) let fold ~ctxt t nm f acc = List.fold_left (fun acc (_, fn) -> if OASISFileUtil.file_exists_case fn then begin f acc fn end else begin warning (f_ "File '%s' has been marked as built \ for %s but doesn't exist") fn (Printf.sprintf (match t with | BExec | BExecLib -> (f_ "executable %s") | BLib -> (f_ "library %s") | BObj -> (f_ "object %s") | BDoc -> (f_ "documentation %s")) nm); acc end) acc (BaseLog.filter ~ctxt [to_log_event_file t nm]) let is_built ~ctxt t nm = List.fold_left (fun _ (_, d) -> try bool_of_string d with _ -> false) false (BaseLog.filter ~ctxt [to_log_event_done t nm]) let of_executable ffn (cs, bs, exec) = let unix_exec_is, unix_dll_opt = OASISExecutable.unix_exec_is (cs, bs, exec) (fun () -> bool_of_string (is_native ())) ext_dll ext_program in let evs = (BExec, cs.cs_name, [[ffn unix_exec_is]]) :: (match unix_dll_opt with | Some fn -> [BExecLib, cs.cs_name, [[ffn fn]]] | None -> []) in evs, unix_exec_is, unix_dll_opt let of_library ffn (cs, bs, lib) = let unix_lst = OASISLibrary.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) ~has_native_dynlink:(bool_of_string (native_dynlink ())) ~ext_lib:(ext_lib ()) ~ext_dll:(ext_dll ()) (cs, bs, lib) in let evs = [BLib, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst let of_object ffn (cs, bs, obj) = let unix_lst = OASISObject.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) (cs, bs, obj) in let evs = [BObj, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst end module BaseCustom = struct (* # 22 "src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let run cmd args extra_args = OASISExec.run ~ctxt:!BaseContext.default ~quote:false (var_expand cmd) (List.map var_expand (args @ (Array.to_list extra_args))) let hook ?(failsafe=false) cstm f e = let optional_command lst = let printer = function | Some (cmd, args) -> String.concat " " (cmd :: args) | None -> s_ "No command" in match var_choose ~name:(s_ "Pre/Post Command") ~printer lst with | Some (cmd, args) -> begin try run cmd args [||] with e when failsafe -> warning (f_ "Command '%s' fail with error: %s") (String.concat " " (cmd :: args)) (match e with | Failure msg -> msg | e -> Printexc.to_string e) end | None -> () in let res = optional_command cstm.pre_command; f e in optional_command cstm.post_command; res end module BaseDynVar = struct (* # 22 "src/base/BaseDynVar.ml" *) open OASISTypes open OASISGettext open BaseEnv open BaseBuilt let init ~ctxt pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) List.iter (function | Executable (cs, bs, _) -> if var_choose bs.bs_build then var_ignore (var_redefine (* We don't save this variable *) ~dump:false ~short_desc:(fun () -> Printf.sprintf (f_ "Filename of executable '%s'") cs.cs_name) (OASISUtils.varname_of_string cs.cs_name) (fun () -> let fn_opt = fold ~ctxt BExec cs.cs_name (fun _ fn -> Some fn) None in match fn_opt with | Some fn -> fn | None -> raise (PropList.Not_set (cs.cs_name, Some (Printf.sprintf (f_ "Executable '%s' not yet built.") cs.cs_name))))) | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct (* # 22 "src/base/BaseTest.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let test ~ctxt lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = if var_choose ~name:(Printf.sprintf (f_ "test %s run") cs.cs_name) ~printer:string_of_bool test.test_run then begin let () = info (f_ "Running test '%s'") cs.cs_name in let back_cwd = match test.test_working_directory with | Some dir -> let cwd = Sys.getcwd () in let chdir d = info (f_ "Changing directory to '%s'") d; Sys.chdir d in chdir dir; fun () -> chdir cwd | None -> fun () -> () in try let failure_percent = BaseCustom.hook test.test_custom (test_plugin ~ctxt pkg (cs, test)) extra_args in back_cwd (); (failure_percent +. failure, n + 1) with e -> begin back_cwd (); raise e end end else begin info (f_ "Skipping test '%s'") cs.cs_name; (failure, n) end in let failed, n = List.fold_left one_test (0.0, 0) lst in let failure_percent = if n = 0 then 0.0 else failed /. (float_of_int n) in let msg = Printf.sprintf (f_ "Tests had a %.2f%% failure rate") (100. *. failure_percent) in if failure_percent > 0.0 then failwith msg else info "%s" msg; (* Possible explanation why the tests where not run. *) if OASISFeatures.package_test OASISFeatures.flag_tests pkg && not (bool_of_string (BaseStandardVar.tests ())) && lst <> [] then BaseMessage.warning "Tests are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-tests'" end module BaseDoc = struct (* # 22 "src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let doc ~ctxt lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = if var_choose ~name:(Printf.sprintf (f_ "documentation %s build") cs.cs_name) ~printer:string_of_bool doc.doc_build then begin info (f_ "Building documentation '%s'") cs.cs_name; BaseCustom.hook doc.doc_custom (doc_plugin ~ctxt pkg (cs, doc)) extra_args end in List.iter one_doc lst; if OASISFeatures.package_test OASISFeatures.flag_docs pkg && not (bool_of_string (BaseStandardVar.docs ())) && lst <> [] then BaseMessage.warning "Docs are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-docs'" end module BaseSetup = struct (* # 22 "src/base/BaseSetup.ml" *) open OASISContext open BaseEnv open BaseMessage open OASISTypes open OASISGettext open OASISUtils type std_args_fun = ctxt:OASISContext.t -> package -> string array -> unit type ('a, 'b) section_args_fun = name * (ctxt:OASISContext.t -> package -> (common_section * 'a) -> string array -> 'b) type t = { configure: std_args_fun; build: std_args_fun; doc: ((doc, unit) section_args_fun) list; test: ((test, float) section_args_fun) list; install: std_args_fun; uninstall: std_args_fun; clean: std_args_fun list; clean_doc: (doc, unit) section_args_fun list; clean_test: (test, unit) section_args_fun list; distclean: std_args_fun list; distclean_doc: (doc, unit) section_args_fun list; distclean_test: (test, unit) section_args_fun list; package: package; oasis_fn: string option; oasis_version: string; oasis_digest: Digest.t option; oasis_exec: string option; oasis_setup_args: string list; setup_update: bool; } (* Associate a plugin function with data from package *) let join_plugin_sections filter_map lst = List.rev (List.fold_left (fun acc sct -> match filter_map sct with | Some e -> e :: acc | None -> acc) [] lst) (* Search for plugin data associated with a section name *) let lookup_plugin_section plugin action nm lst = try List.assoc nm lst with Not_found -> failwithf (f_ "Cannot find plugin %s matching section %s for %s action") plugin nm action let configure ~ctxt t args = (* Run configure *) BaseCustom.hook t.package.conf_custom (fun () -> (* Reload if preconf has changed it *) begin try unload (); load ~ctxt (); with _ -> () end; (* Run plugin's configure *) t.configure ~ctxt t.package args; (* Dump to allow postconf to change it *) dump ~ctxt ()) (); (* Reload environment *) unload (); load ~ctxt (); (* Save environment *) print (); (* Replace data in file *) BaseFileAB.replace ~ctxt t.package.files_ab let build ~ctxt t args = BaseCustom.hook t.package.build_custom (t.build ~ctxt t.package) args let doc ~ctxt t args = BaseDoc.doc ~ctxt (join_plugin_sections (function | Doc (cs, e) -> Some (lookup_plugin_section "documentation" (s_ "build") cs.cs_name t.doc, cs, e) | _ -> None) t.package.sections) t.package args let test ~ctxt t args = BaseTest.test ~ctxt (join_plugin_sections (function | Test (cs, e) -> Some (lookup_plugin_section "test" (s_ "run") cs.cs_name t.test, cs, e) | _ -> None) t.package.sections) t.package args let all ~ctxt t args = let rno_doc = ref false in let rno_test = ref false in let arg_rest = ref [] in Arg.parse_argv ~current:(ref 0) (Array.of_list ((Sys.executable_name^" all") :: (Array.to_list args))) [ "-no-doc", Arg.Set rno_doc, s_ "Don't run doc target"; "-no-test", Arg.Set rno_test, s_ "Don't run test target"; "--", Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), s_ "All arguments for configure."; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; configure ~ctxt t (Array.of_list (List.rev !arg_rest)); info "Running build step"; build ~ctxt t [||]; (* Load setup.log dynamic variables *) BaseDynVar.init ~ctxt t.package; if not !rno_doc then begin info "Running doc step"; doc ~ctxt t [||] end else begin info "Skipping doc step" end; if not !rno_test then begin info "Running test step"; test ~ctxt t [||] end else begin info "Skipping test step" end let install ~ctxt t args = BaseCustom.hook t.package.install_custom (t.install ~ctxt t.package) args let uninstall ~ctxt t args = BaseCustom.hook t.package.uninstall_custom (t.uninstall ~ctxt t.package) args let reinstall ~ctxt t args = uninstall ~ctxt t args; install ~ctxt t args let clean, distclean = let failsafe f a = try f a with e -> warning (f_ "Action fail with error: %s") (match e with | Failure msg -> msg | e -> Printexc.to_string e) in let generic_clean ~ctxt t cstm mains docs tests args = BaseCustom.hook ~failsafe:true cstm (fun () -> (* Clean section *) List.iter (function | Test (cs, test) -> let f = try List.assoc cs.cs_name tests with Not_found -> fun ~ctxt:_ _ _ _ -> () in failsafe (f ~ctxt t.package (cs, test)) args | Doc (cs, doc) -> let f = try List.assoc cs.cs_name docs with Not_found -> fun ~ctxt:_ _ _ _ -> () in failsafe (f ~ctxt t.package (cs, doc)) args | Library _ | Object _ | Executable _ | Flag _ | SrcRepo _ -> ()) t.package.sections; (* Clean whole package *) List.iter (fun f -> failsafe (f ~ctxt t.package) args) mains) () in let clean ~ctxt t args = generic_clean ~ctxt t t.package.clean_custom t.clean t.clean_doc t.clean_test args in let distclean ~ctxt t args = (* Call clean *) clean ~ctxt t args; (* Call distclean code *) generic_clean ~ctxt t t.package.distclean_custom t.distclean t.distclean_doc t.distclean_test args; (* Remove generated source files. *) List.iter (fun fn -> if ctxt.srcfs#file_exists fn then begin info (f_ "Remove '%s'") (ctxt.srcfs#string_of_filename fn); ctxt.srcfs#remove fn end) ([BaseEnv.default_filename; BaseLog.default_filename] @ (List.rev_map BaseFileAB.to_filename t.package.files_ab)) in clean, distclean let version ~ctxt:_ (t: t) _ = print_endline t.oasis_version let update_setup_ml, no_update_setup_ml_cli = let b = ref true in b, ("-no-update-setup-ml", Arg.Clear b, s_ " Don't try to update setup.ml, even if _oasis has changed.") (* TODO: srcfs *) let default_oasis_fn = "_oasis" let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn | None -> default_oasis_fn in let oasis_exec = match t.oasis_exec with | Some fn -> fn | None -> "oasis" in let ocaml = Sys.executable_name in let setup_ml, args = match Array.to_list Sys.argv with | setup_ml :: args -> setup_ml, args | [] -> failwith (s_ "Expecting non-empty command line arguments.") in let ocaml, setup_ml = if Sys.executable_name = Sys.argv.(0) then (* We are not running in standard mode, probably the script * is precompiled. *) "ocaml", "setup.ml" else ocaml, setup_ml in let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in let do_update () = let oasis_exec_version = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | 1 -> failwithf (f_ "Executable '%s' is probably an old version \ of oasis (< 0.3.0), please update to version \ v%s.") oasis_exec t.oasis_version | 127 -> failwithf (f_ "Cannot find executable '%s', please install \ oasis v%s.") oasis_exec t.oasis_version | n -> failwithf (f_ "Command '%s version' exited with code %d.") oasis_exec n) oasis_exec ["version"] in if OASISVersion.comparator_apply (OASISVersion.version_of_string oasis_exec_version) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string t.oasis_version)) then begin (* We have a version >= for the executable oasis, proceed with * update. *) (* TODO: delegate this check to 'oasis setup'. *) if Sys.os_type = "Win32" then failwithf (f_ "It is not possible to update the running script \ setup.ml on Windows. Please update setup.ml by \ running '%s'.") (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) else begin OASISExec.run ~ctxt:!BaseContext.default ~f_exit_code: (fun n -> if n <> 0 then failwithf (f_ "Unable to update setup.ml using '%s', \ please fix the problem and retry.") oasis_exec) oasis_exec ("setup" :: t.oasis_setup_args); OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) end end else failwithf (f_ "The version of '%s' (v%s) doesn't match the version of \ oasis used to generate the %s file. Please install at \ least oasis v%s.") oasis_exec oasis_exec_version setup_ml t.oasis_version in if !update_setup_ml then begin try match t.oasis_digest with | Some dgst -> if Sys.file_exists oasis_fn && dgst <> Digest.file default_oasis_fn then begin do_update (); true end else false | None -> false with e -> error (f_ "Error when updating setup.ml. If you want to avoid this error, \ you can bypass the update of %s by running '%s %s %s %s'") setup_ml ocaml setup_ml no_update_setup_ml_cli (String.concat " " args); raise e end else false let setup t = let catch_exn = ref true in let act_ref = ref (fun ~ctxt:_ _ -> failwithf (f_ "No action defined, run '%s %s -help'") Sys.executable_name Sys.argv.(0)) in let extra_args_ref = ref [] in let allow_empty_env_ref = ref false in let arg_handle ?(allow_empty_env=false) act = Arg.Tuple [ Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); Arg.Unit (fun () -> allow_empty_env_ref := allow_empty_env; act_ref := act); ] in try let () = Arg.parse (Arg.align ([ "-configure", arg_handle ~allow_empty_env:true configure, s_ "[options*] Configure the whole build process."; "-build", arg_handle build, s_ "[options*] Build executables and libraries."; "-doc", arg_handle doc, s_ "[options*] Build documents."; "-test", arg_handle test, s_ "[options*] Run tests."; "-all", arg_handle ~allow_empty_env:true all, s_ "[options*] Run configure, build, doc and test targets."; "-install", arg_handle install, s_ "[options*] Install libraries, data, executables \ and documents."; "-uninstall", arg_handle uninstall, s_ "[options*] Uninstall libraries, data, executables \ and documents."; "-reinstall", arg_handle reinstall, s_ "[options*] Uninstall and install libraries, data, \ executables and documents."; "-clean", arg_handle ~allow_empty_env:true clean, s_ "[options*] Clean files generated by a build."; "-distclean", arg_handle ~allow_empty_env:true distclean, s_ "[options*] Clean files generated by a build and configure."; "-version", arg_handle ~allow_empty_env:true version, s_ " Display version of OASIS used to generate this setup.ml."; "-no-catch-exn", Arg.Clear catch_exn, s_ " Don't catch exception, useful for debugging."; ] @ (if t.setup_update then [no_update_setup_ml_cli] else []) @ (BaseContext.args ()))) (failwithf (f_ "Don't know what to do with '%s'")) (s_ "Setup and run build process current package\n") in (* Instantiate the context. *) let ctxt = !BaseContext.default in (* Build initial environment *) load ~ctxt ~allow_empty:!allow_empty_env_ref (); (** Initialize flags *) List.iter (function | Flag (cs, {flag_description = hlp; flag_default = choices}) -> begin let apply ?short_desc () = var_ignore (var_define ~cli:CLIEnable ?short_desc (OASISUtils.varname_of_string cs.cs_name) (fun () -> string_of_bool (var_choose ~name:(Printf.sprintf (f_ "default value of flag %s") cs.cs_name) ~printer:string_of_bool choices))) in match hlp with | Some hlp -> apply ~short_desc:(fun () -> hlp) () | None -> apply () end | _ -> ()) t.package.sections; BaseStandardVar.init t.package; BaseDynVar.init ~ctxt t.package; if not (t.setup_update && update_setup_ml t) then !act_ref ~ctxt t (Array.of_list (List.rev !extra_args_ref)) with e when !catch_exn -> error "%s" (Printexc.to_string e); exit 1 end module BaseCompat = struct (* # 22 "src/base/BaseCompat.ml" *) (** Compatibility layer to provide a stable API inside setup.ml. This layer allows OASIS to change in between minor versions (e.g. 0.4.6 -> 0.4.7) but still provides a stable API inside setup.ml. This enables to write functions that manipulate setup_t inside setup.ml. See deps.ml for an example. The module opened by default will depend on the version of the _oasis. E.g. if we have "OASISFormat: 0.3", the module Compat_0_3 will be opened and the function Compat_0_3 will be called. If setup.ml is generated with the -nocompat, no module will be opened. @author Sylvain Le Gall *) module Compat_0_4 = struct let rctxt = ref !BaseContext.default module BaseSetup = struct module Original = BaseSetup open OASISTypes type std_args_fun = package -> string array -> unit type ('a, 'b) section_args_fun = name * (package -> (common_section * 'a) -> string array -> 'b) type t = { configure: std_args_fun; build: std_args_fun; doc: ((doc, unit) section_args_fun) list; test: ((test, float) section_args_fun) list; install: std_args_fun; uninstall: std_args_fun; clean: std_args_fun list; clean_doc: (doc, unit) section_args_fun list; clean_test: (test, unit) section_args_fun list; distclean: std_args_fun list; distclean_doc: (doc, unit) section_args_fun list; distclean_test: (test, unit) section_args_fun list; package: package; oasis_fn: string option; oasis_version: string; oasis_digest: Digest.t option; oasis_exec: string option; oasis_setup_args: string list; setup_update: bool; } let setup t = let mk_std_args_fun f = fun ~ctxt pkg args -> rctxt := ctxt; f pkg args in let mk_section_args_fun l = List.map (fun (nm, f) -> nm, (fun ~ctxt pkg sct args -> rctxt := ctxt; f pkg sct args)) l in let t' = { Original. configure = mk_std_args_fun t.configure; build = mk_std_args_fun t.build; doc = mk_section_args_fun t.doc; test = mk_section_args_fun t.test; install = mk_std_args_fun t.install; uninstall = mk_std_args_fun t.uninstall; clean = List.map mk_std_args_fun t.clean; clean_doc = mk_section_args_fun t.clean_doc; clean_test = mk_section_args_fun t.clean_test; distclean = List.map mk_std_args_fun t.distclean; distclean_doc = mk_section_args_fun t.distclean_doc; distclean_test = mk_section_args_fun t.distclean_test; package = t.package; oasis_fn = t.oasis_fn; oasis_version = t.oasis_version; oasis_digest = t.oasis_digest; oasis_exec = t.oasis_exec; oasis_setup_args = t.oasis_setup_args; setup_update = t.setup_update; } in Original.setup t' end let adapt_setup_t setup_t = let module O = BaseSetup.Original in let mk_std_args_fun f = fun pkg args -> f ~ctxt:!rctxt pkg args in let mk_section_args_fun l = List.map (fun (nm, f) -> nm, (fun pkg sct args -> f ~ctxt:!rctxt pkg sct args)) l in { BaseSetup. configure = mk_std_args_fun setup_t.O.configure; build = mk_std_args_fun setup_t.O.build; doc = mk_section_args_fun setup_t.O.doc; test = mk_section_args_fun setup_t.O.test; install = mk_std_args_fun setup_t.O.install; uninstall = mk_std_args_fun setup_t.O.uninstall; clean = List.map mk_std_args_fun setup_t.O.clean; clean_doc = mk_section_args_fun setup_t.O.clean_doc; clean_test = mk_section_args_fun setup_t.O.clean_test; distclean = List.map mk_std_args_fun setup_t.O.distclean; distclean_doc = mk_section_args_fun setup_t.O.distclean_doc; distclean_test = mk_section_args_fun setup_t.O.distclean_test; package = setup_t.O.package; oasis_fn = setup_t.O.oasis_fn; oasis_version = setup_t.O.oasis_version; oasis_digest = setup_t.O.oasis_digest; oasis_exec = setup_t.O.oasis_exec; oasis_setup_args = setup_t.O.oasis_setup_args; setup_update = setup_t.O.setup_update; } end module Compat_0_3 = struct include Compat_0_4 end end # 5662 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall *) open BaseEnv open OASISTypes open OASISUtils open OASISGettext open BaseMessage (** Configure build using provided series of check to be done and then output corresponding file. *) let configure ~ctxt:_ pkg argv = let var_ignore_eval var = let _s: string = var () in () in let errors = ref SetString.empty in let buff = Buffer.create 13 in let add_errors fmt = Printf.kbprintf (fun b -> errors := SetString.add (Buffer.contents b) !errors; Buffer.clear b) buff fmt in let warn_exception e = warning "%s" (Printexc.to_string e) in (* Check tools *) let check_tools lst = List.iter (function | ExternalTool tool -> begin try var_ignore_eval (BaseCheck.prog tool) with e -> warn_exception e; add_errors (f_ "Cannot find external tool '%s'") tool end | InternalExecutable nm1 -> (* Check that matching tool is built *) List.iter (function | Executable ({cs_name = nm2; _}, {bs_build = build; _}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal executable \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) lst in let build_checks sct bs = if var_choose bs.bs_build then begin if bs.bs_compiled_object = Native then begin try var_ignore_eval BaseStandardVar.ocamlopt with e -> warn_exception e; add_errors (f_ "Section %s requires native compilation") (OASISSection.string_of_section sct) end; (* Check tools *) check_tools bs.bs_build_tools; (* Check depends *) List.iter (function | FindlibPackage (findlib_pkg, version_comparator) -> begin try var_ignore_eval (BaseCheck.package ?version_comparator findlib_pkg) with e -> warn_exception e; match version_comparator with | None -> add_errors (f_ "Cannot find findlib package %s") findlib_pkg | Some ver_cmp -> add_errors (f_ "Cannot find findlib package %s (%s)") findlib_pkg (OASISVersion.string_of_comparator ver_cmp) end | InternalLibrary nm1 -> (* Check that matching library is built *) List.iter (function | Library ({cs_name = nm2; _}, {bs_build = build; _}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal library \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) bs.bs_build_depends end in (* Parse command line *) BaseArgExt.parse argv (BaseEnv.args ()); (* OCaml version *) begin match pkg.ocaml_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "ocaml" ver_cmp BaseStandardVar.ocaml_version) with e -> warn_exception e; add_errors (f_ "OCaml version %s doesn't match version constraint %s") (BaseStandardVar.ocaml_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Findlib version *) begin match pkg.findlib_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "findlib" ver_cmp BaseStandardVar.findlib_version) with e -> warn_exception e; add_errors (f_ "Findlib version %s doesn't match version constraint %s") (BaseStandardVar.findlib_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Make sure the findlib version is fine for the OCaml compiler. *) begin let ocaml_ge4 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.ocaml_version ())) (OASISVersion.version_of_string "4.0.0") >= 0 in if ocaml_ge4 then let findlib_lt132 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) (OASISVersion.version_of_string "1.3.2") < 0 in if findlib_lt132 then add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" end; (* FlexDLL *) if BaseStandardVar.os_type () = "Win32" || BaseStandardVar.os_type () = "Cygwin" then begin try var_ignore_eval BaseStandardVar.flexlink with e -> warn_exception e; add_errors (f_ "Cannot find 'flexlink'") end; (* Check build depends *) List.iter (function | Executable (_, bs, _) | Library (_, bs, _) as sct -> build_checks sct bs | Doc (_, doc) -> if var_choose doc.doc_build then check_tools doc.doc_build_tools | Test (_, test) -> if var_choose test.test_run then check_tools test.test_tools | _ -> ()) pkg.sections; (* Check if we need native dynlink (presence of libraries that compile to native) *) begin let has_cmxa = List.exists (function | Library (_, bs, _) -> var_choose bs.bs_build && (bs.bs_compiled_object = Native || (bs.bs_compiled_object = Best && bool_of_string (BaseStandardVar.is_native ()))) | _ -> false) pkg.sections in if has_cmxa then var_ignore_eval BaseStandardVar.native_dynlink end; (* Check errors *) if SetString.empty != !errors then begin List.iter (fun e -> error "%s" e) (SetString.elements !errors); failwithf (fn_ "%d configuration error" "%d configuration errors" (SetString.cardinal !errors)) (SetString.cardinal !errors) end end module InternalInstallPlugin = struct (* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall *) (* TODO: rewrite this module with OASISFileSystem. *) open BaseEnv open BaseStandardVar open BaseMessage open OASISTypes open OASISFindlib open OASISGettext open OASISUtils let exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) let lib_hook = ref (fun (cs, bs, dn, lib) -> cs, bs, dn, lib, []) let obj_hook = ref (fun (cs, bs, dn, obj) -> cs, bs, dn, obj, []) let doc_hook = ref (fun (cs, doc) -> cs, doc) let install_file_ev = "install-file" let install_dir_ev = "install-dir" let install_findlib_ev = "install-findlib" (* TODO: this can be more generic and used elsewhere. *) let win32_max_command_line_length = 8000 let split_install_command ocamlfind findlib_name meta files = if Sys.os_type = "Win32" then (* Arguments for the first command: *) let first_args = ["install"; findlib_name; meta] in (* Arguments for remaining commands: *) let other_args = ["install"; findlib_name; "-add"] in (* Extract as much files as possible from [files], [len] is the current command line length: *) let rec get_files len acc files = match files with | [] -> (List.rev acc, []) | file :: rest -> let len = len + 1 + String.length file in if len > win32_max_command_line_length then (List.rev acc, files) else get_files len (file :: acc) rest in (* Split the command into several commands. *) let rec split args files = match files with | [] -> [] | _ -> (* Length of "ocamlfind install [META|-add]" *) let len = List.fold_left (fun len arg -> len + 1 (* for the space *) + String.length arg) (String.length ocamlfind) args in match get_files len [] files with | ([], _) -> failwith (s_ "Command line too long.") | (firsts, others) -> let cmd = args @ firsts in (* Use -add for remaining commands: *) let () = let findlib_ge_132 = OASISVersion.comparator_apply (OASISVersion.version_of_string (BaseStandardVar.findlib_version ())) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string "1.3.2")) in if not findlib_ge_132 then failwithf (f_ "Installing the library %s require to use the \ flag '-add' of ocamlfind because the command \ line is too long. This flag is only available \ for findlib 1.3.2. Please upgrade findlib from \ %s to 1.3.2") findlib_name (BaseStandardVar.findlib_version ()) in let cmds = split other_args others in cmd :: cmds in (* The first command does not use -add: *) split first_args files else ["install" :: findlib_name :: meta :: files] let install = let in_destdir fn = try (* Practically speaking destdir is prepended at the beginning of the target filename *) (destdir ())^fn with PropList.Not_set _ -> fn in let install_file ~ctxt ?(prepend_destdir=true) ?tgt_fn src_file envdir = let tgt_dir = if prepend_destdir then in_destdir (envdir ()) else envdir () in let tgt_file = Filename.concat tgt_dir (match tgt_fn with | Some fn -> fn | None -> Filename.basename src_file) in (* Create target directory if needed *) OASISFileUtil.mkdir_parent ~ctxt (fun dn -> info (f_ "Creating directory '%s'") dn; BaseLog.register ~ctxt install_dir_ev dn) (Filename.dirname tgt_file); (* Really install files *) info (f_ "Copying file '%s' to '%s'") src_file tgt_file; OASISFileUtil.cp ~ctxt src_file tgt_file; BaseLog.register ~ctxt install_file_ev tgt_file in (* Install the files for a library. *) let install_lib_files ~ctxt findlib_name files = let findlib_dir = let dn = let findlib_destdir = OASISExec.run_read_one_line ~ctxt (ocamlfind ()) ["printconf" ; "destdir"] in Filename.concat findlib_destdir findlib_name in fun () -> dn in let () = if not (OASISFileUtil.file_exists_case (findlib_dir ())) then failwithf (f_ "Directory '%s' doesn't exist for findlib library %s") (findlib_dir ()) findlib_name in let f dir file = let basename = Filename.basename file in let tgt_fn = Filename.concat dir basename in (* Destdir is already include in printconf. *) install_file ~ctxt ~prepend_destdir:false ~tgt_fn file findlib_dir in List.iter (fun (dir, files) -> List.iter (f dir) files) files ; in (* Install data into defined directory *) let install_data ~ctxt srcdir lst tgtdir = let tgtdir = OASISHostPath.of_unix (var_expand tgtdir) in List.iter (fun (src, tgt_opt) -> let real_srcs = OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat srcdir src) in if real_srcs = [] then failwithf (f_ "Wildcard '%s' doesn't match any files") src; List.iter (fun fn -> install_file ~ctxt fn (fun () -> match tgt_opt with | Some s -> OASISHostPath.of_unix (var_expand s) | None -> tgtdir)) real_srcs) lst in let make_fnames modul sufx = List.fold_right begin fun sufx accu -> (OASISString.capitalize_ascii modul ^ sufx) :: (OASISString.uncapitalize_ascii modul ^ sufx) :: accu end sufx [] in (** Install all libraries *) let install_libs ~ctxt pkg = let find_first_existing_files_in_path bs lst = let path = OASISHostPath.of_unix bs.bs_path in List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) lst) in let files_of_modules new_files typ cs bs modules = List.fold_left (fun acc modul -> begin try (* Add uncompiled header from the source tree *) [find_first_existing_files_in_path bs (make_fnames modul [".mli"; ".ml"])] with Not_found -> warning (f_ "Cannot find source header for module %s \ in %s %s") typ modul cs.cs_name; [] end @ List.fold_left (fun acc fn -> try find_first_existing_files_in_path bs [fn] :: acc with Not_found -> acc) acc (make_fnames modul [".annot";".cmti";".cmt"])) new_files modules in let files_of_build_section (f_data, new_files) typ cs bs = let extra_files = List.map (fun fn -> try find_first_existing_files_in_path bs [fn] with Not_found -> failwithf (f_ "Cannot find extra findlib file %S in %s %s ") fn typ cs.cs_name) bs.bs_findlib_extra_files in let f_data () = (* Install data associated with the library *) install_data ~ctxt bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in f_data, new_files @ extra_files in let files_of_library (f_data, acc) data_lib = let cs, bs, lib, dn, lib_extra = !lib_hook data_lib in if var_choose bs.bs_install && BaseBuilt.is_built ~ctxt BaseBuilt.BLib cs.cs_name then begin (* Start with lib_extra *) let new_files = lib_extra in let new_files = files_of_modules new_files "library" cs bs lib.lib_modules in let f_data, new_files = files_of_build_section (f_data, new_files) "library" cs bs in let new_files = (* Get generated files *) BaseBuilt.fold ~ctxt BaseBuilt.BLib cs.cs_name (fun acc fn -> fn :: acc) new_files in let acc = (dn, new_files) :: acc in let f_data () = (* Install data associated with the library *) install_data ~ctxt bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in (f_data, acc) end else begin (f_data, acc) end and files_of_object (f_data, acc) data_obj = let cs, bs, obj, dn, obj_extra = !obj_hook data_obj in if var_choose bs.bs_install && BaseBuilt.is_built ~ctxt BaseBuilt.BObj cs.cs_name then begin (* Start with obj_extra *) let new_files = obj_extra in let new_files = files_of_modules new_files "object" cs bs obj.obj_modules in let f_data, new_files = files_of_build_section (f_data, new_files) "object" cs bs in let new_files = (* Get generated files *) BaseBuilt.fold ~ctxt BaseBuilt.BObj cs.cs_name (fun acc fn -> fn :: acc) new_files in let acc = (dn, new_files) :: acc in let f_data () = (* Install data associated with the object *) install_data ~ctxt bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in (f_data, acc) end else begin (f_data, acc) end in (* Install one group of library *) let install_group_lib grp = (* Iterate through all group nodes *) let rec install_group_lib_aux data_and_files grp = let data_and_files, children = match grp with | Container (_, children) -> data_and_files, children | Package (_, cs, bs, `Library lib, dn, children) -> files_of_library data_and_files (cs, bs, lib, dn), children | Package (_, cs, bs, `Object obj, dn, children) -> files_of_object data_and_files (cs, bs, obj, dn), children in List.fold_left install_group_lib_aux data_and_files children in (* Findlib name of the root library *) let findlib_name = findlib_of_group grp in (* Determine root library *) let root_lib = root_of_group grp in (* All files to install for this library *) let f_data, files = install_group_lib_aux (ignore, []) grp in (* Really install, if there is something to install *) if files = [] then begin warning (f_ "Nothing to install for findlib library '%s'") findlib_name end else begin let meta = (* Search META file *) let _, bs, _ = root_lib in let res = Filename.concat bs.bs_path "META" in if not (OASISFileUtil.file_exists_case res) then failwithf (f_ "Cannot find file '%s' for findlib library %s") res findlib_name; res in let files = (* Make filename shorter to avoid hitting command max line length * too early, esp. on Windows. *) (* TODO: move to OASISHostPath as make_relative. *) let remove_prefix p n = let plen = String.length p in let nlen = String.length n in if plen <= nlen && String.sub n 0 plen = p then begin let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in let cutpoint = plen + (if plen < nlen && n.[plen] = fn_sep then 1 else 0) in String.sub n cutpoint (nlen - cutpoint) end else begin n end in List.map (fun (dir, fn) -> (dir, List.map (remove_prefix (Sys.getcwd ())) fn)) files in let ocamlfind = ocamlfind () in let nodir_files, dir_files = List.fold_left (fun (nodir, dir) (dn, lst) -> match dn with | Some dn -> nodir, (dn, lst) :: dir | None -> lst @ nodir, dir) ([], []) (List.rev files) in info (f_ "Installing findlib library '%s'") findlib_name; List.iter (OASISExec.run ~ctxt ocamlfind) (split_install_command ocamlfind findlib_name meta nodir_files); install_lib_files ~ctxt findlib_name dir_files; BaseLog.register ~ctxt install_findlib_ev findlib_name end; (* Install data files *) f_data (); in let group_libs, _, _ = findlib_mapping pkg in (* We install libraries in groups *) List.iter install_group_lib group_libs in let install_execs ~ctxt pkg = let install_exec data_exec = let cs, bs, _ = !exec_hook data_exec in if var_choose bs.bs_install && BaseBuilt.is_built ~ctxt BaseBuilt.BExec cs.cs_name then begin let exec_libdir () = Filename.concat (libdir ()) pkg.name in BaseBuilt.fold ~ctxt BaseBuilt.BExec cs.cs_name (fun () fn -> install_file ~ctxt ~tgt_fn:(cs.cs_name ^ ext_program ()) fn bindir) (); BaseBuilt.fold ~ctxt BaseBuilt.BExecLib cs.cs_name (fun () fn -> install_file ~ctxt fn exec_libdir) (); install_data ~ctxt bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name) end in List.iter (function | Executable (cs, bs, exec)-> install_exec (cs, bs, exec) | _ -> ()) pkg.sections in let install_docs ~ctxt pkg = let install_doc data = let cs, doc = !doc_hook data in if var_choose doc.doc_install && BaseBuilt.is_built ~ctxt BaseBuilt.BDoc cs.cs_name then begin let tgt_dir = OASISHostPath.of_unix (var_expand doc.doc_install_dir) in BaseBuilt.fold ~ctxt BaseBuilt.BDoc cs.cs_name (fun () fn -> install_file ~ctxt fn (fun () -> tgt_dir)) (); install_data ~ctxt Filename.current_dir_name doc.doc_data_files doc.doc_install_dir end in List.iter (function | Doc (cs, doc) -> install_doc (cs, doc) | _ -> ()) pkg.sections in fun ~ctxt pkg _ -> install_libs ~ctxt pkg; install_execs ~ctxt pkg; install_docs ~ctxt pkg (* Uninstall already installed data *) let uninstall ~ctxt _ _ = let uninstall_aux (ev, data) = if ev = install_file_ev then begin if OASISFileUtil.file_exists_case data then begin info (f_ "Removing file '%s'") data; Sys.remove data end else begin warning (f_ "File '%s' doesn't exist anymore") data end end else if ev = install_dir_ev then begin if Sys.file_exists data && Sys.is_directory data then begin if Sys.readdir data = [||] then begin info (f_ "Removing directory '%s'") data; OASISFileUtil.rmdir ~ctxt data end else begin warning (f_ "Directory '%s' is not empty (%s)") data (String.concat ", " (Array.to_list (Sys.readdir data))) end end else begin warning (f_ "Directory '%s' doesn't exist anymore") data end end else if ev = install_findlib_ev then begin info (f_ "Removing findlib library '%s'") data; OASISExec.run ~ctxt (ocamlfind ()) ["remove"; data] end else begin failwithf (f_ "Unknown log event '%s'") ev; end; BaseLog.unregister ~ctxt ev data in (* We process event in reverse order *) List.iter uninstall_aux (List.rev (BaseLog.filter ~ctxt [install_file_ev; install_dir_ev])); List.iter uninstall_aux (List.rev (BaseLog.filter ~ctxt [install_findlib_ev])) end # 6465 "setup.ml" module CustomPlugin = struct (* # 22 "src/plugins/custom/CustomPlugin.ml" *) (** Generate custom configure/build/doc/test/install system @author *) open BaseEnv open OASISGettext open OASISTypes type t = { cmd_main: command_line conditional; cmd_clean: (command_line option) conditional; cmd_distclean: (command_line option) conditional; } let run = BaseCustom.run let main ~ctxt:_ t _ extra_args = let cmd, args = var_choose ~name:(s_ "main command") t.cmd_main in run cmd args extra_args let clean ~ctxt:_ t _ extra_args = match var_choose t.cmd_clean with | Some (cmd, args) -> run cmd args extra_args | _ -> () let distclean ~ctxt:_ t _ extra_args = match var_choose t.cmd_distclean with | Some (cmd, args) -> run cmd args extra_args | _ -> () module Build = struct let main ~ctxt t pkg extra_args = main ~ctxt t pkg extra_args; List.iter (fun sct -> let evs = match sct with | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, _ = BaseBuilt.of_library OASISHostPath.of_unix (cs, bs, lib) in evs end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, _, _ = BaseBuilt.of_executable OASISHostPath.of_unix (cs, bs, exec) in evs end | _ -> [] in List.iter (fun (bt, bnm, lst) -> BaseBuilt.register ~ctxt bt bnm lst) evs) pkg.sections let clean ~ctxt t pkg extra_args = clean ~ctxt t pkg extra_args; (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild * considering moving this to BaseSetup? *) List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister ~ctxt BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister ~ctxt BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister ~ctxt BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections let distclean ~ctxt t pkg extra_args = distclean ~ctxt t pkg extra_args end module Test = struct let main ~ctxt t pkg (cs, _) extra_args = try main ~ctxt t pkg extra_args; 0.0 with Failure s -> BaseMessage.warning (f_ "Test '%s' fails: %s") cs.cs_name s; 1.0 let clean ~ctxt t pkg _ extra_args = clean ~ctxt t pkg extra_args let distclean ~ctxt t pkg _ extra_args = distclean ~ctxt t pkg extra_args end module Doc = struct let main ~ctxt t pkg (cs, _) extra_args = main ~ctxt t pkg extra_args; BaseBuilt.register ~ctxt BaseBuilt.BDoc cs.cs_name [] let clean ~ctxt t pkg (cs, _) extra_args = clean ~ctxt t pkg extra_args; BaseBuilt.unregister ~ctxt BaseBuilt.BDoc cs.cs_name let distclean ~ctxt t pkg _ extra_args = distclean ~ctxt t pkg extra_args end end # 6597 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; build = CustomPlugin.Build.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$make", ["all"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; test = [ ("main", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$make", ["test"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; doc = [ ("manual", CustomPlugin.Doc.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$make", ["doc"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; install = CustomPlugin.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$make", ["install"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; uninstall = CustomPlugin.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$make", ["uninstall"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; clean = [ CustomPlugin.Build.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$make", ["all"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; CustomPlugin.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$make", ["install"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; CustomPlugin.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$make", ["uninstall"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] } ]; clean_test = [ ("main", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$make", ["test"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; clean_doc = [ ("manual", CustomPlugin.Doc.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$make", ["doc"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; distclean = [ CustomPlugin.Build.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$make", ["all"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; CustomPlugin.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$make", ["install"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; CustomPlugin.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$make", ["uninstall"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] } ]; distclean_test = [ ("main", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$make", ["test"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; distclean_doc = [ ("manual", CustomPlugin.Doc.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$make", ["doc"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; package = { oasis_version = "0.4"; ocaml_version = Some (OASISVersion.VGreaterEqual "3.12.1"); version = "3.4.0"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit { OASISLicense.license = "LGPL"; excption = Some "OCaml linking"; version = OASISLicense.Version "2.1" }); findlib_version = None; alpha_features = []; beta_features = []; name = "batteries"; license_file = Some "LICENSE"; copyrights = []; maintainers = []; authors = ["Batteries Included Team"]; homepage = None; bugreports = None; synopsis = "Extended OCaml Standard Library"; description = None; tags = []; categories = []; files_ab = []; sections = [ Doc ({ cs_name = "manual"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { doc_type = (`Doc, "custom", Some "0.2"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); (OASISExpr.EFlag "docs", true) ]; doc_install = [(OASISExpr.EBool true, true)]; doc_install_dir = "$docdir"; doc_title = "Ocaml Batteries Documentation"; doc_authors = []; doc_abstract = None; doc_format = OtherDoc; doc_data_files = []; doc_build_tools = [ExternalTool "make"] }); Test ({ cs_name = "main"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { test_type = (`Test, "custom", Some "0.2"); test_command = [(OASISExpr.EBool true, ("$make", ["test"]))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; test_working_directory = None; test_run = [ (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); (OASISExpr.EFlag "tests", true) ]; test_tools = [ExternalTool "make"] }); SrcRepo ({ cs_name = "master"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { src_repo_type = Git; src_repo_location = "git://github.com/ocaml-batteries-team/batteries-included.git"; src_repo_browser = Some "https://github.com/ocaml-batteries-team/batteries-included"; src_repo_module = None; src_repo_branch = Some "master"; src_repo_tag = None; src_repo_subdir = None }); Library ({ cs_name = "batteries"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }) ]; disable_oasis_section = []; conf_type = (`Configure, "internal", Some "0.4"); conf_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; build_type = (`Build, "custom", Some "0.2"); build_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; install_type = (`Install, "custom", Some "0.2"); install_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; uninstall_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; clean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; distclean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; plugins = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; oasis_version = "0.4.11"; oasis_digest = Some "\\\021u\244\235\nf_\169\189k\210(\231K\155"; oasis_exec = None; oasis_setup_args = []; setup_update = false };; let setup () = BaseSetup.setup setup_t;; # 7031 "setup.ml" let setup_t = BaseCompat.Compat_0_4.adapt_setup_t setup_t open BaseCompat.Compat_0_4 (* OASIS_STOP *) let () = setup ();; batteries-included-3.4.0/src/000077500000000000000000000000001415601150500160525ustar00rootroot00000000000000batteries-included-3.4.0/src/_tags000066400000000000000000000005031415601150500170700ustar00rootroot00000000000000true: debug true: warn_error(-50) <{batMutex,batRMutex}.{ml,mli}>: threads : threads <{batMap,batVect,batFile,batPervasives,batParserCo,batSet,batLogger,batPathGen,batSplay}.ml>: warn_z <{batPervasives,batIMap,batLog}.ml>: warn_-9 : inline(3) # necessary to inline ofs_of_layout on V<4.2 batteries-included-3.4.0/src/batArray.mliv000066400000000000000000001114721415601150500205160ustar00rootroot00000000000000(* * BatArray - additional and modified functions for arrays. * Copyright (C) 1996 Xavier Leroy * 2005 Richard W.M. Jones (rich @ annexia.org) * 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** {6 Array operations} Arrays are mutable data structures with a fixed size, which support fast access and modification, and are used pervasively in imperative computing. While arrays are completely supported in OCaml, it is often a good idea to investigate persistent alternatives, such as lists or hash maps. This module replaces Stdlib's {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Array.html}Array} module. A variant of arrays, arrays with capabilities, is provided in module {!BatArray.Cap}. This notion of capabilities permit the transformation of a mutable array into a read-only or a write-only arrays, without loss of speed and with the possibility of distributing different capabilities to different expressions. @author Xavier Leroy @author Richard W.M. Jones @author David Teller *) type 'a t = 'a array (** The type of arrays. *) include BatEnum.Enumerable with type 'a enumerable = 'a t include BatInterfaces.Mappable with type 'a mappable = 'a t external length : 'a array -> int = "%array_length" (** Return the length (number of elements) of the given array. *) external get : 'a array -> int -> 'a = "%array_safe_get" (** [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 if [n] is outside the range 0 to [(Array.length a - 1)]. *) external set : 'a array -> int -> 'a -> unit = "%array_safe_set" (** [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 if [n] is outside the range 0 to [Array.length a - 1]. *) external make : int -> 'a -> 'a array = "caml_make_vect" (** [Array.make n x] returns a fresh array of length [n], initialized with [x]. All the elements of this new array are initially physically equal to [x] (in the sense of the [==] predicate). Consequently, if [x] is mutable, it is shared among all elements of the array, and modifying [x] through one of the array entries will modify all other entries at the same time. @raise Invalid_argument if [n < 0] or [n > Sys.max_array_length]. If the value of [x] is a floating-point number, then the maximum size is only [Sys.max_array_length / 2].*) ##V<4.2##val create_float: int -> float array ##V<4.2##val make_float: int -> float array ##V=4.2##external make_float: int -> float array = "caml_make_float_vect" ##V=4.2##val create_float: int -> float array ##V>=4.3##external create_float: int -> float array = "caml_make_float_vect" ##V>=4.3##val make_float: int -> float array (** [Array.make_float n] returns a fresh float array of length [n], with uninitialized data. @since 2.3.0 *) ##V>=4.07##val of_seq: 'a Seq.t -> 'a array ##V>=4.07##val to_seq: 'a array -> 'a Seq.t ##V>=4.07##val to_seqi: 'a array -> (int * 'a) Seq.t external create : int -> 'a -> 'a array = "caml_make_vect" (** @deprecated [Array.create] is an alias for {!Array.make}. *) val init : int -> (int -> 'a) -> 'a array (** [Array.init n f] returns a fresh array of length [n], with element number [i] initialized to the result of [f i]. In other terms, [Array.init n f] tabulates the results of [f] applied to the integers [0] to [n-1]. @raise Invalid_argument if [n < 0] or [n > Sys.max_array_length]. If the return type of [f] is [float], then the maximum size is only [Sys.max_array_length / 2].*) val make_matrix : int -> int -> 'a -> 'a array array (** [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 [Sys.max_array_length]. If the value of [e] is a floating-point number, then the maximum size is only [Sys.max_array_length / 2]. *) val create_matrix : int -> int -> 'a -> 'a array array (** @deprecated [Array.create_matrix] is an alias for {!Array.make_matrix}. *) val append : 'a array -> 'a array -> 'a array (** [Array.append v1 v2] returns a fresh array containing the concatenation of the arrays [v1] and [v2]. *) val concat : 'a array list -> 'a array (** Same as [Array.append], but concatenates a list of arrays. *) val sub : 'a array -> int -> int -> 'a array (** [Array.sub a start len] returns a fresh array of length [len], containing the elements number [start] to [start + len - 1] of array [a]. @raise Invalid_argument if [start] and [len] do not designate a valid subarray of [a]; that is, if [start < 0], or [len < 0], or [start + len > Array.length a]. *) val copy : 'a array -> 'a array (** [Array.copy a] returns a copy of [a], that is, a fresh array containing the same elements as [a]. *) val fill : 'a array -> int -> int -> 'a -> unit (** [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 if [ofs] and [len] do not designate a valid subarray of [a]. *) val blit : 'a array -> int -> 'a array -> int -> int -> 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 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]. *) val to_list : 'a array -> 'a list (** [Array.to_list a] returns the list of all the elements of [a]. *) val split : ('a * 'b) array -> 'a array * 'b array (** [Array.split a] converts the array of pairs [a] into a pair of arrays. *) val combine : 'a array -> 'b array -> ('a * 'b) array (** [combine [|a1; ...; an|] [|b1; ...; bn|]] is [[|(a1,b1); ...; (an,bn)|]]. Raise [Invalid_argument] if the two arrays have different lengths. @since 3.4.0 *) val of_list : 'a list -> 'a array (** [Array.of_list l] returns a fresh array containing the elements of [l]. *) val max : 'a array -> 'a (** [max a] returns the largest value in [a] as judged by [Pervasives.compare] @raise Invalid_argument on empty input *) val min : 'a array -> 'a (** [min a] returns the smallest value in [a] as judged by [Pervasives.compare] @raise Invalid_argument on empty input *) val min_max : 'a array -> 'a * 'a (** [min_max a] returns the (smallest, largest) pair of values from [a] as judged by [Pervasives.compare] @raise Invalid_argument on empty input *) val sum : int array -> int (** [sum l] returns the sum of the integers of [l] *) val fsum : float array -> float (** [fsum l] returns the sum of the floats of [l] *) val kahan_sum : float array -> float (** [kahan_sum l] returns a numerically-accurate sum of the floats of [l]. You should consider using Kahan summation when you really care about very small differences in the result, while the result or one of the intermediate sums can be very large (which usually results in loss of precision of floating-point addition). The worst-case rounding error is constant, instead of growing with (the square root of) the length of the input array as with {! fsum}. On the other hand, processing each element requires four floating-point operations instead of one. See {{: https://en.wikipedia.org/wiki/Kahan_summation_algorithm } the wikipedia article} on Kahan summation for more details. @since 2.2.0 *) val avg : int array -> float (** [avg l] returns the average of [l] @since 2.1 *) val favg : float array -> float (** [favg l] returns the average of [l] @since 2.1 *) val left : 'a array -> int -> 'a array (**[left r len] returns the array containing the [len] first characters of [r]. If [r] contains less than [len] characters, it returns [r]. Examples: [Array.left [|0;1;2;3;4;5;6|] 4 = [|0;1;2;3|]] [Array.left [|1;2;3|] 0 = [||]] [Array.left [|1;2;3|] 10 = [|1;2;3|]] *) val right : 'a array -> int -> 'a array (**[left r len] returns the array containing the [len] last characters of [r]. If [r] contains less than [len] characters, it returns [r]. Example: [Array.right [|1;2;3;4;5;6|] 4 = [|3;4;5;6|]] *) val head : 'a array -> int -> 'a array (**as {!left}*) val tail : 'a array -> int -> 'a array (**[tail r pos] returns the array containing all but the [pos] first characters of [r] Example: [Array.tail [|1;2;3;4;5;6|] 4 = [|5;6|]] *) val iter : ('a -> unit) -> 'a array -> unit (** [Array.iter f a] applies function [f] in turn to all the elements of [a]. It is equivalent to [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *) val map : ('a -> 'b) -> 'a array -> 'b array (** [Array.map f a] applies function [f] to all the elements of [a], and builds an array with the results returned by [f]: [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *) val iteri : (int -> 'a -> unit) -> 'a array -> unit (** Same as {!Array.iter}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array (** Same as {!Array.map}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a (** [Array.fold_left f x a] computes [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], where [n] is the length of the array [a]. *) val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array (** [fold_left_map] is a combination of {!fold_left} and {!map} that threads an accumulator through calls to [f]. @since 3.4.0 *) val fold_while : ('acc -> 'a -> bool) -> ('acc -> 'a -> 'acc) -> 'acc -> 'a array -> ('acc * int) (** [fold_while p f init a], accumulates elements [x] of array [a] using function [f], as long as the predicate [p acc x] holds. At the end, the accumulated value along with the first index i where [p acc a.(i)] does not hold is returned. If the returned index is equal to [length a], the whole array was folded. *) val fold : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a (** Alias for [fold_left]. *) val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a (** [Array.fold_right f a x] computes [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))], where [n] is the length of the array [a]. *) val modify : ('a -> 'a) -> 'a array -> unit (** [modify f a] replaces every element [x] of [a] with [f x]. *) val modifyi : (int -> 'a -> 'a) -> 'a array -> unit (** Same as {!modify}, but the function is applied to the index of the element as the first argument, and the element itself as the second argument. *) val fold_lefti : ('a -> int -> 'b -> 'a) -> 'a -> 'b array -> 'a (** As [fold_left], but with the index of the element as additional argument *) val fold_righti : (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a (** As [fold_right], but with the index of the element as additional argument *) val reduce : ('a -> 'a -> 'a) -> 'a array -> 'a (** [Array.reduce f a] is [fold_left f a.(0) [|a.(1); ..; a.(n-1)|]]. This is useful for merging a group of things that have no reasonable default value to return if the group is empty. @raise Invalid_argument on empty arrays. *) val singleton : 'a -> 'a array (** Create an array consisting of exactly one element. @since 2.1 *) (** {6 Sorting} *) val sort : ('a -> 'a -> int) -> 'a array -> unit (** Sort an array 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 below for a complete specification). For example, {!Pervasives.compare} is a suitable comparison function, provided there are no floating-point NaN values in the data. After calling [Array.sort], the array is sorted in place in increasing order. [Array.sort] is guaranteed to run in constant heap space and (at most) logarithmic stack space. The current implementation uses Heap Sort. It runs in constant stack space. Specification of the comparison function: Let [a] be the array and [cmp] the comparison function. The following must be true for all x, y, z in a : - [cmp x y] > 0 if and only if [cmp y x] < 0 - if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0 When [Array.sort] returns, [a] contains the same elements as before, reordered in such a way that for all i and j valid indices of [a] : - [cmp a.(i) a.(j)] >= 0 if and only if i >= j *) val stable_sort : ('a -> 'a -> int) -> 'a array -> unit (** Same as {!Array.sort}, but the sorting algorithm is stable (i.e. elements that compare equal are kept in their original order) and not guaranteed to run in constant heap space. The current implementation uses Merge Sort. It uses [n/2] words of heap space, where [n] is the length of the array. It is usually faster than the current implementation of {!Array.sort}. *) val fast_sort : ('a -> 'a -> int) -> 'a array -> unit (** Same as {!Array.sort} or {!Array.stable_sort}, whichever is faster on typical input. *) val decorate_stable_sort : ('a -> 'b) -> 'a array -> 'a array (** [decorate_stable_sort f a] returns a sorted copy of [a] such that if [f x < f y] then [x] is earlier in the result than [y]. This function is useful when [f] is expensive, as it only computes [f x] once for each element in the array. See {{:http://en.wikipedia.org/wiki/Schwartzian_transform}Schwartzian Transform}. It is unnecessary to have an additional comparison function as argument, as the builtin [Pervasives.compare] is used to compare the ['b] values. This is deemed sufficient. *) val decorate_fast_sort : ('a -> 'b) -> 'a array -> 'a array (** As {!Array.decorate_stable_sort}, but uses fast_sort internally. *) val bsearch : 'a BatOrd.ord -> 'a array -> 'a -> [ `All_lower | `All_bigger | `Just_after of int | `Empty | `At of int ] (** [bsearch cmp arr x] finds the index of the object [x] in the array [arr], provided [arr] is {b sorted} using [cmp]. If the array is not sorted, the result is not specified (may raise Invalid_argument). Complexity: O(log n) where n is the length of the array (dichotomic search). @return - [`At i] if [cmp arr.(i) x = 0] (for some i) - [`All_lower] if all elements of [arr] are lower than [x] - [`All_bigger] if all elements of [arr] are bigger than [x] - [`Just_after i] if [arr.(i) < x < arr.(i+1)] - [`Empty] if the array is empty @raise Invalid_argument if the array is found to be unsorted w.r.t [cmp] @since 2.2.0 *) val pivot_split : 'a BatOrd.ord -> 'a array -> 'a -> int * int (** [pivot_split cmp arr x] assumes that [arr] is {b sorted} w.r.t [cmp]. It splits an array [arr] of length [len] into three parts, by returning a couple (i,j) such as: - all elements with indices 0..i-1 ([sub arr 0 i]) are lower than [x] - all elements with indices i..j-1 ([sub arr i (j-i)]) are equal to [x] - all elements with indices j..len-1 ([sub arr j (len-j)]) are bigger than [x] In particular, it returns: - (0, 0) if all elements of [arr] are bigger than [x] - (len, len) if all elements are lower than [x] - (0, len) if all elements are equal to [x] Complexity: logarithmic in the size of the array @raise Invalid_argument if the array is found not to be sorted *) (**{6 Operations on two arrays}*) val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit (** [Array.iter2 f [|a0; a1; ...; an|] [|b0; b1; ...; bn|]] performs calls [f a0 b0; f a1 b1; ...; f an bn] in that order. @raise Invalid_argument if the two arrays have different lengths. *) val iter2i : (int -> 'a -> 'b -> unit) -> 'a array -> 'b array -> unit (** [Array.iter2i f [|a0; a1; ...; an|] [|b0; b1; ...; bn|]] performs calls [f 0 a0 b0; f 1 a1 b1; ...; f n an bn] in that order. @raise Invalid_argument if the two arrays have different lengths. *) val for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool (** As {!Array.for_all} but on two arrays. @raise Invalid_argument if the two arrays have different lengths.*) val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool (** As {!Array.exists} but on two arrays. @raise Invalid_argument if the two arrays have different lengths. *) val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array (** As {!Array.map} but on two arrays. @raise Invalid_argument if the two arrays have different lengths. *) val cartesian_product : 'a array -> 'b array -> ('a * 'b) array (** Cartesian product of the two arrays. @since 2.2.0 *) (**{6 Predicates}*) val for_all : ('a -> bool) -> 'a array -> bool (** [for_all p [|a0; a1; ...; an|]] checks if all elements of the array satisfy the predicate [p]. That is, it returns [ (p a0) && (p a1) && ... && (p an)]. *) val exists : ('a -> bool) -> 'a array -> bool (** [exists p [|a0; a1; ...; an|]] checks if at least one element of the array satisfies the predicate [p]. That is, it returns [(p a0) || (p a1) || ... || (p an)]. *) val find : ('a -> bool) -> 'a array -> 'a (** [find p a] returns the first element of array [a] that satisfies the predicate [p]. @raise Not_found if there is no value that satisfies [p] in the array [a]. *) val find_opt : ('a -> bool) -> 'a array -> 'a option (** [find_opt p a] returns the first element of the array [a] that satisfies the predicate [p], or [None] if there is no such element. @since 3.4.0 *) val find_map : ('a -> 'b option) -> 'a array -> 'b option (** [find_map f a] applies [f] to the elements of [a] in order, and returns the first result of the form [Some v], or [None] if none exist. @since 3.4.0 *) val mem : 'a -> 'a array -> bool (** [mem m a] is true if and only if [m] is equal to an element of [a]. *) val memq : 'a -> 'a array -> bool (** Same as {!Array.mem} but uses physical equality instead of structural equality to compare array elements. *) val findi : ('a -> bool) -> 'a array -> int (** [findi p a] returns the index of the first element of array [a] that satisfies the predicate [p]. @raise Not_found if there is no value that satisfies [p] in the array [a]. *) val filter : ('a -> bool) -> 'a array -> 'a array (** [filter p a] returns all the elements of the array [a] that satisfy the predicate [p]. The order of the elements in the input array is preserved. *) val filteri : (int -> 'a -> bool) -> 'a array -> 'a array (** As [filter] but with the index passed to the predicate. *) val filter_map : ('a -> 'b option) -> 'a array -> 'b array (** [filter_map f e] returns an array consisting of all elements [x] such that [f y] returns [Some x] , where [y] is an element of [e]. *) val count_matching : ('a -> bool) -> 'a array -> int (** [count_matching p a] returns the number of elements of [a] satisfying predicate [p]. *) val find_all : ('a -> bool) -> 'a array -> 'a array (** [find_all] is another name for {!Array.filter}. *) val partition : ('a -> bool) -> 'a array -> 'a array * 'a array (** [partition p a] returns a pair of arrays [(a1, a2)], where [a1] is the array of all the elements of [a] that satisfy the predicate [p], and [a2] is the array of all the elements of [a] that do not satisfy [p]. The order of the elements in the input array is preserved. *) (** {6 Array transformations} *) val rev : 'a array -> 'a array (** Array reversal.*) val rev_in_place : 'a array -> unit (** In-place array reversal. The array argument is updated. *) (** {6 Conversions} *) val enum : 'a array -> 'a BatEnum.t (** Returns an enumeration of the elements of an array. Behavior of the enumeration is undefined if the contents of the array changes afterwards.*) val of_enum : 'a BatEnum.t -> 'a array (** Build an array from an enumeration. *) val backwards : 'a array -> 'a BatEnum.t (** Returns an enumeration of the elements of an array, from last to first. *) val of_backwards : 'a BatEnum.t -> 'a array (** Build an array from an enumeration, with the first element of the enumeration as the last element of the array and vice versa. *) (** {6 Utilities} *) val range : 'a array -> int BatEnum.t (** [range a] returns an enumeration of all valid indexes into the given array. For example, [range [|2;4;6;8|] = 0--3].*) val insert : 'a array -> 'a -> int -> 'a array (** [insert xs x i] returns a copy of [xs] except the value [x] is inserted in position [i] (and all later indices are shifted to the right). @raise Invalid_argument if [i < 0 || i > Array.length xs]. *) val remove_at : int -> 'a array -> 'a array (** [remove_at i a] returns the array [a] without the element at index [i]. @raise Invalid_argument if [i] is outside of [a] bounds. @since 3.3.0 *) (** {6 Boilerplate code}*) val print : ?first:string -> ?last:string -> ?sep:string -> ('a, 'b) BatIO.printer -> ('a t, 'b) BatIO.printer (** Print the contents of an array, with [~first] preceding the first item (default: "\[|"), [~last] following the last item (default: "|\]") and [~sep] separating items (default: "; "). A printing function must be provided to print the items in the array. Example: IO.to_string (Array.print Int.print) [|2;4;66|] = "[|2; 4; 66|]" *) val compare : 'a BatOrd.comp -> 'a array BatOrd.comp (** [compare c] generates the lexicographical order on arrays induced by [c]. That is, given a comparison function for the elements of an array, this will return a comparison function for arrays of that type. *) val ord : 'a BatOrd.ord -> 'a array BatOrd.ord (** Hoist an element comparison function to compare arrays of those elements, with shorter arrays less than longer ones, and lexicographically for arrays of the same size. This is a different ordering than [compare], but is often faster. *) val shuffle : ?state:Random.State.t -> 'a array -> unit (** [shuffle ~state:rs a] randomly shuffles in place the elements of [a]. The optional random state [rs] allows to control the random numbers being used during shuffling (for reproducibility). Shuffling is implemented using the Fisher-Yates algorithm and works in O(n), where n is the number of elements of [a]. @since 2.6.0 *) val equal : 'a BatOrd.eq -> 'a array BatOrd.eq (** Hoist a equality test for elements to arrays. Arrays are only equal if their lengths are the same and corresponding elements test equal. *) (** {6 Override modules}*) (** The following modules replace functions defined in {!Array} with functions behaving slightly differently but having the same name. This is by design: the functions are meant to override the corresponding functions of {!Array}. *) (** Operations on {!Array} without exceptions.*) module Exceptionless : sig val find : ('a -> bool) -> 'a t -> 'a option (** [find p a] returns [Some x], where [x] is the first element of array [a] that satisfies the predicate [p], or [None] if there is no such element.*) val findi : ('a -> bool) -> 'a t -> int option (** [findi p a] returns [Some n], where [n] is the index of the first element of array [a] that satisfies the predicate [p], or [None] if there is no such element.*) end (** Operations on {!Array} with labels. This module overrides a number of functions of {!Array} by functions in which some arguments require labels. These labels are there to improve readability and safety and to let you change the order of arguments to functions. In every case, the behavior of the function is identical to that of the corresponding function of {!Array}. *) module Labels : sig val init : int -> f:(int -> 'a) -> 'a array val create: int -> init:'a -> 'a array val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array val sub : 'a array -> pos:int -> len:int -> 'a array val fill : 'a array -> pos:int -> len:int -> 'a -> unit val blit : src:'a array -> src_pos:int -> dst:'a array -> dst_pos:int -> len:int -> unit val iter : f:('a -> unit) -> 'a array -> unit val map : f:('a -> 'b) -> 'a array -> 'b array val iteri : f:(int -> 'a -> unit) -> 'a array -> unit val mapi : f:(int -> 'a -> 'b) -> 'a array -> 'b array val modify : f:('a -> 'a) -> 'a array -> unit val modifyi : f:(int -> 'a -> 'a) -> 'a array -> unit val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b array -> 'a val fold : f:('a -> 'b -> 'a) -> init:'a -> 'b array -> 'a val fold_right : f:('b -> 'a -> 'a) -> 'b array -> init:'a -> 'a val fold_while : p:('acc -> 'a -> bool) -> f:('acc -> 'a -> 'acc) -> init:'acc -> 'a array -> ('acc * int) val sort : cmp:('a -> 'a -> int) -> 'a array -> unit val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit val iter2: f:('a -> 'b -> unit) -> 'a t -> 'b t -> unit val exists: f:('a -> bool) -> 'a t -> bool val for_all: f:('a -> bool) -> 'a t -> bool val iter2i: f:( int -> 'a -> 'b -> unit) -> 'a t -> 'b t -> unit val find: f:('a -> bool) -> 'a t -> 'a val find_opt: f:('a -> bool) -> 'a t -> 'a option val find_map: f:('a -> 'b option) -> 'a array -> 'b option val findi: f:('a -> bool) -> 'a t -> int val map: f:('a -> 'b) -> 'a t -> 'b t val mapi: f:(int -> 'a -> 'b) -> 'a t -> 'b t val filter: f:('a -> bool) -> 'a t -> 'a t val filter_map: f:('a -> 'b option) -> 'a t -> 'b t val count_matching: f:('a -> bool) -> 'a t -> int module LExceptionless : sig val find: f:('a -> bool) -> 'a t -> 'a option val findi: f:('a -> bool) -> 'a t -> int option end end (** {5 Capabilities for arrays.} This modules provides the same set of features as {!Array}, but with the added twist that arrays can be made read-only or write-only. Read-only arrays may then be safely shared and distributed. There is no loss of performance involved. *) module Cap : sig (** Only the capability-specific functions are documented here. See the complete [Array] module for the documentation of other functions. *) type ('a, 'b) t constraint 'b = [< `Read | `Write] (**The type of arrays with capabilities. An [('a, [`Read | `Write])] array behaves as a regular ['a array], while a [('a, [`Read]) array] only has read-only capabilities and a [('a, [`Write]) array] only has write-only capabilities.*) (**{6 Base operations}*) external length : ('a, [> ]) t -> int = "%array_length" external get : ('a, [> `Read]) t -> int -> 'a = "%array_safe_get" external set : ('a, [> `Write]) t -> int -> 'a -> unit = "%array_safe_set" (**{6 Constructors}*) external make : int -> 'a -> ('a, _) t = "caml_make_vect" external create : int -> 'a -> ('a, _) t = "caml_make_vect" ##V<4.2## val make_float : int -> (float, _) t ##V>=4.2## external make_float : int -> (float, _) t = "caml_make_float_vect" (** [Array.make_float n] returns a fresh float array of length [n], with uninitialized data. @since 2.3.0 and OCaml 4.2.0 *) external of_array : 'a array -> ('a, _ ) t = "%identity" (** Adopt a regular array as a capability array, allowing to decrease capabilities if necessary. This operation involves no copying. In other words, in [let cap = of_array a in ...], any modification in [a] will also have effect on [cap] and reciprocally.*) external to_array : ('a, [`Read | `Write]) t -> 'a array = "%identity" (** Return a capability array as an array. This operation requires both read and write permissions on the capability array and involves no copying. In other words, in [let a = of_array cap in ...], any modification in [a] will also have effect on [cap] and reciprocally.*) external read_only : ('a, [>`Read]) t -> ('a, [`Read]) t = "%identity" (** Drop to read-only permissions. This operation involves no copying.*) external write_only : ('a, [>`Write]) t -> ('a, [`Write]) t = "%identity" (** Drop to write-only permissions. This operation involves no copying.*) val init : int -> (int -> 'a) -> ('a, _) t val make_matrix : int -> int -> 'a -> (('a, _)t, _) t val create_matrix : int -> int -> 'a -> (('a, _)t, _) t (** {6 Iterators}*) val iter : ('a -> unit) -> ('a, [> `Read]) t -> unit val map : ('a -> 'b) -> ('a, [>`Read]) t -> ('b, _) t val iteri : (int -> 'a -> unit) -> ('a, [> `Read]) t -> unit val mapi : (int -> 'a -> 'b) -> ('a, [> `Read]) t -> ('b, _) t val modify : ('a -> 'a) -> ('a, [`Read | `Write]) t -> unit val modifyi : (int -> 'a -> 'a) -> ('a, [`Read | `Write]) t -> unit val fold_left : ('a -> 'b -> 'a) -> 'a -> ('b, [> `Read]) t -> 'a val fold : ('a -> 'b -> 'a) -> 'a -> ('b, [> `Read]) t -> 'a val fold_right : ('b -> 'a -> 'a) -> ('b, [> `Read]) t -> 'a -> 'a val fold_while : ('acc -> 'a -> bool) -> ('acc -> 'a -> 'acc) -> 'acc -> ('a, [> `Read]) t -> ('acc * int) (**{6 Operations on two arrays}*) val iter2 : ('a -> 'b -> unit) -> ('a, [> `Read]) t -> ('b, [> `Read]) t -> unit val iter2i : (int -> 'a -> 'b -> unit) -> ('a, [> `Read]) t -> ('b, [> `Read]) t -> unit (**{6 Predicates}*) val for_all : ('a -> bool) -> ('a, [> `Read]) t -> bool val exists : ('a -> bool) -> ('a, [> `Read]) t -> bool val find : ('a -> bool) -> ('a, [> `Read]) t -> 'a val find_opt : ('a -> bool) -> ('a, [> `Read]) t -> 'a option val find_map : ('a -> 'b option) -> ('a, [> `Read]) t -> 'b option val mem : 'a -> ('a, [> `Read]) t -> bool val memq : 'a -> ('a, [> `Read]) t -> bool val findi : ('a -> bool) -> ('a, [> `Read]) t -> int val filter : ('a -> bool) -> ('a, [> `Read]) t -> ('a, _) t val filter_map : ('a -> 'b option) -> ('a, [> `Read]) t -> ('b, _) t val count_matching: ('a -> bool) -> ('a, [> `Read]) t -> int val find_all : ('a -> bool) -> ('a, [> `Read]) t -> ('a, _) t val partition : ('a -> bool) -> ('a, [> `Read]) t -> ('a, _) t * ('a, _)t (** {6 Array transformations} *) val rev : ('a, [> `Read]) t -> ('a, _) t val rev_in_place : ('a, [`Read | `Write]) t -> unit val append : ('a, [> `Read]) t -> ('a, [> `Read]) t -> ('a, _) t val concat : ('a, [> `Read]) t list -> ('a, _) t val sub : ('a, [> `Read]) t -> int -> int -> ('a, _) t val copy : ('a, [> `Read]) t -> 'a array val fill : ('a, [> `Write]) t -> int -> int -> 'a -> unit val blit : ('a, [> `Read]) t -> int -> ('a, [>`Write]) t -> int -> int -> unit (** {6 Conversions} *) val enum : ('a, [> `Read]) t -> 'a BatEnum.t val of_enum : 'a BatEnum.t -> ('a, _) t val backwards : ('a, [> `Read]) t -> 'a BatEnum.t val of_backwards : 'a BatEnum.t -> ('a, _) t val to_list : ('a, [> `Read]) t -> 'a list val split : ('a * 'b, [> `Read]) t -> ('a, _) t * ('b, _) t val combine : ('a, [> `Read]) t -> ('b, [> `Read]) t -> ('a * 'b, [> `Read]) t val pivot_split : 'a BatOrd.ord -> ('a, [> `Read]) t -> 'a -> int * int val of_list : 'a list -> ('a, _) t (** {6 Utilities} *) val sort : ('a -> 'a -> int) -> ('a, [> `Read | `Write]) t -> unit val stable_sort : ('a -> 'a -> int) -> ('a, [ `Read | `Write]) t -> unit val fast_sort : ('a -> 'a -> int) -> ('a, [`Read | `Write]) t -> unit (** {6 Boilerplate code}*) val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatIO.output -> 'b -> unit) -> 'a BatIO.output -> ('b, [>`Read]) t -> unit val compare : 'a BatOrd.comp -> ('a, [> `Read]) t BatOrd.comp val ord : 'a BatOrd.ord -> ('a, [> `Read]) t BatOrd.ord val equal : 'a BatOrd.eq -> ('a, [> `Read]) t BatOrd.eq (** {6 Override modules}*) (** Operations on {!BatArray.Cap} without exceptions.*) module Exceptionless : sig val find : ('a -> bool) -> ('a, [> `Read]) t -> 'a option val findi : ('a -> bool) -> ('a, [> `Read]) t -> int option end (** Operations on {!BatArray.Cap} with labels. *) module Labels : sig val init : int -> f:(int -> 'a) -> ('a, _) t val make: int -> init:'a -> ('a, _) t val create: int -> init:'a -> ('a, _) t val make_matrix : dimx:int -> dimy:int -> 'a -> (('a, _)t, _) t val create_matrix : dimx:int -> dimy:int -> 'a -> (('a, _)t, _) t val sub : ('a, [> `Read]) t -> pos:int -> len:int -> ('a, _) t val fill : ('a, [> `Write]) t -> pos:int -> len:int -> 'a -> unit val blit : src:('a, [> `Read]) t -> src_pos:int -> dst:('a, [>`Write]) t -> dst_pos:int -> len:int -> unit val iter : f:('a -> unit) -> ('a, [> `Read]) t -> unit val map : f:('a -> 'b) -> ('a, [>`Read]) t -> ('b, _) t val iteri : f:(int -> 'a -> unit) -> ('a, [> `Read]) t -> unit val mapi : f:(int -> 'a -> 'b) -> ('a, [> `Read]) t -> ('b, _) t val modify : f:('a -> 'a) -> ('a, [`Read | `Write]) t -> unit val modifyi : f:(int -> 'a -> 'a) -> ('a, [`Read | `Write]) t -> unit val fold_left : f:('a -> 'b -> 'a) -> init:'a -> ('b, [> `Read]) t -> 'a val fold : f:('a -> 'b -> 'a) -> init:'a -> ('b, [> `Read]) t -> 'a val fold_right : f:('b -> 'a -> 'a) -> ('b, [> `Read]) t -> init:'a -> 'a val fold_while : p:('acc -> 'a -> bool) -> f:('acc -> 'a -> 'acc) -> init:'acc -> 'a array -> ('acc * int) val sort : cmp:('a -> 'a -> int) -> ('a, [> `Read | `Write]) t -> unit val stable_sort : cmp:('a -> 'a -> int) -> ('a, [ `Read | `Write]) t -> unit val fast_sort : cmp:('a -> 'a -> int) -> ('a, [`Read | `Write]) t -> unit val iter2: f:('a -> 'b -> unit) -> ('a, [> `Read]) t -> ('b, [> `Read]) t -> unit val iter2i: f:( int -> 'a -> 'b -> unit) -> ('a, [> `Read]) t -> ('b, [> `Read]) t -> unit val exists: f:('a -> bool) -> ('a, [> `Read]) t -> bool val for_all: f:('a -> bool) -> ('a, [> `Read]) t -> bool val find: f:('a -> bool) -> ('a, [> `Read]) t -> 'a val find_opt: f:('a -> bool) -> ('a, [> `Read]) t -> 'a option val find_map: f:('a -> 'b option) -> ('a, [> `Read]) t -> 'b option val map: f:('a -> 'b) -> ('a, [>`Read]) t -> ('b, _) t val mapi: f:(int -> 'a -> 'b) -> ('a, [>`Read]) t -> ('b, _) t val filter: f:('a -> bool) -> ('a, [>`Read]) t -> ('a, _) t val filter_map: f:('a -> 'b option) -> ('a, [>`Read]) t -> ('b, _) t val count_matching: f:('a -> bool) -> ('a, [>`Read]) t -> int end (**/**) (** {6 Undocumented functions} *) external unsafe_get : ('a, [> `Read]) t -> int -> 'a = "%array_unsafe_get" external unsafe_set : ('a, [> `Write])t -> int -> 'a -> unit = "%array_unsafe_set" (**/**) end module Incubator : sig module Eq (T : BatOrd.Eq) : sig type t = T.t array val eq : T.t array BatOrd.eq end module Ord (T : BatOrd.Ord) : sig type t = T.t array val ord : T.t array BatOrd.ord end end (**/**) (** {6 Undocumented functions} *) (* for tests *) val is_sorted_by : ('a -> 'b) -> 'a array -> bool (* The following is for system use only. Do not call directly. *) external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" ##V>=4.6##module Floatarray : sig ##V>=4.6## external create : int -> floatarray = "caml_floatarray_create" ##V>=4.6## external length : floatarray -> int = "%floatarray_length" ##V>=4.6## external get : floatarray -> int -> float = "%floatarray_safe_get" ##V>=4.6## external set : floatarray -> int -> float -> unit = "%floatarray_safe_set" ##V>=4.6## external unsafe_get : floatarray -> int -> float = "%floatarray_unsafe_get" ##V>=4.6## external unsafe_set : floatarray -> int -> float -> unit ##V>=4.6## = "%floatarray_unsafe_set" ##V>=4.6##end (**/**) batteries-included-3.4.0/src/batArray.mlv000066400000000000000000001015371415601150500203460ustar00rootroot00000000000000(* * BatArray - additional and modified functions for arrays. * Copyright (C) 2005 Richard W.M. Jones (rich @ annexia.org) * 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) include Array type 'a t = 'a array type 'a enumerable = 'a t type 'a mappable = 'a t ##V<4.2##let create_float n = make n 0. ##V<4.2##let make_float = create_float ##V=4.2##external make_float: int -> float array = "caml_make_float_vect" ##V=4.2##external create_float: int -> float array = "caml_make_float_vect" ##V>=4.3##external create_float: int -> float array = "caml_make_float_vect" ##V>=4.3##let make_float = create_float let singleton x = [|x|] (*$Q singleton Q.int (fun x -> let s = singleton x in s.(0) = x && length s = 1) *) let modify f a = for i = 0 to length a - 1 do unsafe_set a i (f (unsafe_get a i)) done let modifyi f a = for i = 0 to length a - 1 do unsafe_set a i (f i (unsafe_get a i)) done (*$T modify let a = [|3;2;1|] in modify (fun x -> x + 1) a; a = [|4;3;2|] *)(*$T modifyi let a = [|3;2;1|] in modifyi (fun i x -> i * x) a; a = [|0;2;2|] *) let fold = fold_left let fold_left_map f init a = let n = length a in if n = 0 then (init, [||]) else let acc = ref init in let f' x = let acc', y = f !acc x in acc := acc'; y in let res = map f' a in (!acc, res) (*$T fold_left_map fold_left_map (fun acc x -> (acc + x, x)) 0 [|0;1;2;3|] = (6, [|0;1;2;3|]) fold_left_map (fun acc x -> (acc + x, x)) 0 [||] = (0, [||]) *) let fold_lefti f x a = let r = ref x in for i = 0 to length a - 1 do r := f !r i (unsafe_get a i) done; !r (*$T fold_lefti fold_lefti (fun a i x -> a + i * x) 1 [|2;4;5|] = 1 + 0 + 4 + 10 fold_lefti (fun a i x -> a + i * x) 1 [||] = 1 *) let fold_righti f a x = let r = ref x in for i = length a - 1 downto 0 do r := f i (unsafe_get a i) !r done; !r (*$T fold_righti fold_righti (fun i x a -> a + i * x) [|2;4;5|] 1 = 1 + 0 + 4 + 10 fold_righti (fun i x a -> a + i * x) [||] 1 = 1 *) let rev_in_place xs = let n = length xs in let j = ref (n-1) in for i = 0 to n/2-1 do (* let c = xs.(i) in *) let c = unsafe_get xs i in (* xs.(i) <- xs.(!j); *) unsafe_set xs i (unsafe_get xs !j); (* xs.(!j) <- c; *) unsafe_set xs !j c; decr j done (*$T rev_in_place let a = [|1;2;3;4|] in rev_in_place a; a = [|4;3;2;1|] let a = [|1;2;3|] in rev_in_place a; a = [|3;2;1|] let a = [||] in rev_in_place a; a=[||] *) let rev xs = let ys = copy xs in rev_in_place ys; ys (*$Q rev (Q.array Q.int) ~count:5 (fun l -> rev l |> rev = l) *) let for_all p xs = let n = length xs in let rec loop i = if i = n then true else if p (unsafe_get xs i) then loop (succ i) else false in loop 0 (*$T for_all for_all (fun x -> x mod 2 = 0) [|2;4;6|] for_all (fun x -> x mod 2 = 0) [|2;3;6|] = false for_all (fun _ -> false) [||] *) let exists p xs = let n = length xs in let rec loop i = if i = n then false else if p (unsafe_get xs i) then true else loop (succ i) in loop 0 (*$T exists exists (fun x -> x mod 2 = 0) [|1;4;5|] exists (fun x -> x mod 2 = 0) [|1;3;5|] = false exists (fun _ -> false) [||] = false *) let mem a xs = let n = length xs in let rec loop i = if i = n then false else if a = unsafe_get xs i then true else loop (succ i) in loop 0 (*$T mem mem 2 [|1;2;3|] mem 2 [||] = false mem (ref 3) [|ref 1; ref 2; ref 3|] *) let memq a xs = let n = length xs in let rec loop i = if i = n then false else if a == unsafe_get xs i then true else loop (succ i) in loop 0 (*$T memq memq 2 [|1;2;3|] memq 2 [||] = false memq (ref 3) [|ref 1; ref 2; ref 3|] = false *) let findi p xs = let n = length xs in let rec loop i = if i = n then raise Not_found else if p (unsafe_get xs i) then i else loop (succ i) in loop 0 (*$Q findi (Q.pair (Q.array Q.small_int) (Q.fun1 Q.Observable.int Q.bool)) (fun (a, Q.Fun(_,f)) -> \ try let index = findi f a in \ let i = ref (-1) in \ for_all (fun elt -> incr i; \ if !i < index then not (f elt) \ else if !i = index then f elt else true)\ a \ with Not_found -> for_all (fun elt -> not (f elt)) a) *) let find p xs = xs.(findi p xs) (*$Q find (Q.pair (Q.array Q.small_int) (Q.fun1 Q.Observable.int Q.bool)) (fun (a, Q.Fun(_,f)) -> \ let a = map (fun x -> `a x) a in \ let f (`a x) = f x in\ try let elt = find f a in \ let past = ref false in \ for_all (fun x -> if x == elt then (past := true; f x) \ else !past || not (f x)) \ a \ with Not_found -> for_all (fun elt -> not (f elt)) a) *) let find_opt p a = let n = length a in let rec loop i = if i = n then None else let x = unsafe_get a i in if p x then Some x else loop (succ i) in loop 0 (*$T find_opt find_opt (fun x -> x < 0) [||] = None find_opt (fun x -> x < 0) [|0;1;2;3|] = None find_opt (fun x -> x >= 3) [|0;1;2;3|] = Some 3 *) let find_map f a = let n = length a in let rec loop i = if i = n then None else match f (unsafe_get a i) with | None -> loop (succ i) | Some _ as r -> r in loop 0 (*$T find_map find_map (fun x -> if x < 0 then Some x else None) [||] = None find_map (fun x -> if x < 0 then Some x else None) [|0;-1;2|] = (Some (-1)) find_map (fun x -> if x < 0 then Some x else None) [|0;1;-2|] = (Some (-2)) *) (* Use of BitSet suggested by Brian Hurt. *) let filter p xs = let n = length xs in (* Use a bitset to store which elements will be in the final array. *) let bs = BatBitSet.create n in for i = 0 to n-1 do if p (unsafe_get xs i) then BatBitSet.set bs i done; (* Allocate the final array and copy elements into it. *) let n' = BatBitSet.count bs in let j = ref 0 in init n' (fun _ -> match BatBitSet.next_set_bit bs !j with | Some i -> j := i+1; unsafe_get xs i | None -> (* not enough 1 bits - incorrect count? *) assert false ) (*$Q filter (Q.pair (Q.array Q.small_int) (Q.fun1 Q.Observable.int Q.bool)) (fun (a, Q.Fun(_,f)) -> \ let b = to_list (filter f a) in \ let b' = List.filter f (to_list a) in \ List.for_all (fun (x,y) -> x = y) (List.combine b b') \ ) *) exception End of int let fold_while p f init xs = let acc = ref init in try let n = length xs in for i = 0 to n - 1 do let x = unsafe_get xs i in if p !acc x then acc := f !acc x else raise (End i) done; (!acc, n) with End i -> (!acc, i) (*$T fold_while fold_while (fun _ x -> x mod 2 = 0) (+) 0 [|1;2|] = (0, 0) fold_while (fun _ x -> x mod 2 = 1) (+) 0 [|1;2|] = (1, 1) fold_while (fun _ x -> x < 4) (+) 0 [|1;2;3;4|] = (6, 3) fold_while (fun _ x -> x < 4) (+) 0 [|1;2;3|] = (6, 3) fold_while (fun _ x -> x < 4) (+) 0 [||] = (0, 0) *) let count_matching p xs = let n = length xs in let count = ref 0 in for i = 0 to n - 1 do if p (unsafe_get xs i) then incr count done; !count (*$T count_matching count_matching (fun _ -> true) [||] = 0 count_matching (fun x -> x = -1) [|-1|] = 1 count_matching (fun x -> x = -1) [|-1;0;-1|] = 2 *) let filteri p xs = let n = length xs in (* Use a bitset to store which elements will be in the final array. *) let bs = BatBitSet.create n in for i = 0 to n-1 do if p i (unsafe_get xs i) then BatBitSet.set bs i done; (* Allocate the final array and copy elements into it. *) let n' = BatBitSet.count bs in let j = ref 0 in init n' (fun _ -> match BatBitSet.next_set_bit bs !j with | Some i -> j := i+1; unsafe_get xs i | None -> (* not enough 1 bits - incorrect count? *) assert false ) (*$T filteri filteri (fun i x -> (i+x) mod 2 = 0) [|1;2;3;4;0;1;2;3|] = [|0;1;2;3|] *) let find_all = filter (* <=> List.partition *) let partition p a = let n = length a in if n = 0 then ([||], [||]) else let ok_count = ref 0 in let mask = init n (fun i -> let pi = p (unsafe_get a i) in if pi then incr ok_count; pi) in let ko_count = n - !ok_count in let init = unsafe_get a 0 in let ok = make !ok_count init in let ko = make ko_count init in let j = ref 0 in let k = ref 0 in for i = 0 to n - 1 do let x = unsafe_get a i in let px = unsafe_get mask i in if px then (unsafe_set ok !j x; incr j) else (unsafe_set ko !k x; incr k) done; (ok, ko) (*$Q partition (Q.pair (Q.array Q.small_int) (Q.fun1 Q.Observable.int Q.bool)) (fun (a, Q.Fun(_,f)) -> \ let b1, b2 = partition f a in \ let b1, b2 = to_list b1, to_list b2 in \ let b1', b2' = List.partition f (to_list a) in \ List.for_all (fun (x,y) -> x = y) (List.combine b1 b1') && \ List.for_all (fun (x,y) -> x = y) (List.combine b2 b2') \ ) *) let enum xs = let rec make start xs = let n = length xs in (* inside the loop, as [make] may later be called with another array *) BatEnum.make ~next:(fun () -> if !start < n then unsafe_get xs (BatRef.post_incr start) else raise BatEnum.No_more_elements) ~count:(fun () -> n - !start) ~clone:(fun () -> make (BatRef.copy start) xs) in make (ref 0) xs (*$Q enum (Q.array Q.small_int) (fun a -> \ let e = enum a in \ for i = 0 to length a / 2 - 1 do\ assert (a.(i) = BatEnum.get_exn e)\ done; \ let e' = BatEnum.clone e in \ assert (BatEnum.count e = BatEnum.count e'); \ for i = length a / 2 to length a - 1 do \ assert (a.(i) = BatEnum.get_exn e && a.(i) = BatEnum.get_exn e') \ done; \ BatEnum.is_empty e && BatEnum.is_empty e' \ ) *) let backwards xs = let rec make start xs = BatEnum.make ~next:(fun () -> if !start > 0 then unsafe_get xs (BatRef.pre_decr start) else raise BatEnum.No_more_elements) ~count:(fun () -> !start) ~clone:(fun () -> make (BatRef.copy start) xs) in make (ref (length xs)) xs (*$Q backwards (Q.array Q.small_int) (fun a -> \ let e = backwards a in \ let n = length a in \ for i = 0 to length a / 2 - 1 do\ assert (a.(n - 1 - i) = BatEnum.get_exn e)\ done; \ let e' = BatEnum.clone e in \ assert (BatEnum.count e = BatEnum.count e'); \ for i = length a / 2 to length a - 1 do \ assert (a.(n - 1 - i) = BatEnum.get_exn e && \ a.(n - 1 - i) = BatEnum.get_exn e') \ done; \ BatEnum.is_empty e && BatEnum.is_empty e' \ ) *) let of_enum e = let n = BatEnum.count e in (* This assumes, reasonably, that init traverses the array in order. *) init n (fun _i -> match BatEnum.get e with | Some x -> x | None -> assert false) let of_backwards e = of_list (BatList.of_backwards e) let range xs = BatEnum.(--^) 0 (length xs) (*$Q range (Q.array Q.small_int) (fun a -> \ BatEnum.equal (=) (range a) \ (enum (init (length a) (fun i -> i)))) *) let filter_map p xs = of_enum (BatEnum.filter_map p (enum xs)) (*$Q filter_map (Q.pair (Q.array Q.small_int) (Q.fun1 Q.Observable.int (Q.option Q.int))) \ (fun (a, Q.Fun (_,f)) -> \ let a' = filter (fun elt -> f elt <> None) a in \ let a' = map (f %> BatOption.get) a' in \ let a = filter_map f a in \ a = a' \ ) *) let iter2 f a1 a2 = if length a1 <> length a2 then invalid_arg "Array.iter2"; for i = 0 to length a1 - 1 do (* f a1.(i) a2.(i) *) f (unsafe_get a1 i) (unsafe_get a2 i) done (*$Q iter2 (Q.array Q.small_int) (fun a -> \ let a' = map (fun a -> a + 1) a in \ let i = ref (-1) in \ let b = make (length a) (max_int, max_int) in \ let f x1 x2 = incr i; b.(!i) <- (x1, x2) in \ let b' = map (fun a -> (a, a + 1)) a in \ iter2 f a a'; \ b = b' \ ) *) (*$T iter2 try iter2 (fun _ _ -> ()) [|1|] [|1;2;3|]; false \ with Invalid_argument _ -> true try iter2 (fun _ _ -> ()) [|1|] [||]; false \ with Invalid_argument _ -> true *) let iter2i f a1 a2 = if length a1 <> length a2 then invalid_arg "Array.iter2i"; for i = 0 to length a1 - 1 do (* f i a1.(i) a2.(i) *) f i (unsafe_get a1 i) (unsafe_get a2 i) done (*$Q iter2i (Q.array Q.small_int) (fun a -> \ let a' = map (fun a -> a + 1) a in \ let i = ref (-1) in \ let b = make (length a) (max_int, max_int) in \ let f idx x1 x2 = incr i; assert (!i = idx); b.(!i) <- (x1, x2) in \ let b' = map (fun a -> (a, a + 1)) a in \ iter2i f a a'; \ b = b' \ ) *) (*$T iter2i try iter2i (fun _ _ _ -> ()) [|1|] [|1;2;3|]; false \ with Invalid_argument _ -> true try iter2i (fun _ _ _ -> ()) [|1|] [||]; false \ with Invalid_argument _ -> true *) ##V>=4.11##let for_all2 = Array.for_all2 ##V<4.11##let for_all2 p xs ys = ##V<4.11## let n = length xs in ##V<4.11## if length ys <> n then invalid_arg "Array.for_all2"; ##V<4.11## let rec loop i = ##V<4.11## if i = n then true ##V<4.11## else if p (unsafe_get xs i) (unsafe_get ys i) then loop (succ i) ##V<4.11## else false ##V<4.11## in ##V<4.11## loop 0 (*$T for_all2 for_all2 (=) [|1;2;3|] [|3;2;1|] = false for_all2 (=) [|1;2;3|] [|1;2;3|] for_all2 (<>) [|1;2;3|] [|3;2;1|] = false try ignore (for_all2 (=) [|1;2;3|] [|1;2;3;4|]); false \ with Invalid_argument _ -> true try ignore (for_all2 (=) [|1;2|] [||]); false \ with Invalid_argument _ -> true *) ##V>=4.11##let exists2 = Array.exists2 ##V<4.11##let exists2 p xs ys = ##V<4.11## let n = length xs in ##V<4.11## if length ys <> n then invalid_arg "Array.exists2"; ##V<4.11## let rec loop i = ##V<4.11## if i = n then false ##V<4.11## else if p (unsafe_get xs i) (unsafe_get ys i) then true ##V<4.11## else loop (succ i) ##V<4.11## in ##V<4.11## loop 0 (*$T exists2 exists2 (=) [|1;2;3|] [|3;2;1|] exists2 (<>) [|1;2;3|] [|1;2;3|] = false try ignore (exists2 (=) [|1;2|] [|3|]); false \ with Invalid_argument _ -> true *) let map2 f xs ys = let n = length xs in if length ys <> n then invalid_arg "Array.map2"; init n (fun i -> f (unsafe_get xs i) (unsafe_get ys i)) (*$T map2 map2 (-) [|1;2;3|] [|6;3;1|] = [|-5;-1;2|] map2 (-) [|2;4;6|] [|1;2;3|] = [|1;2;3|] try ignore (map2 (-) [|2;4|] [|1;2;3|]); false \ with Invalid_argument _ -> true try ignore (map2 (-) [|2;4|] [|3|]); false \ with Invalid_argument _ -> true *) let cartesian_product a b = let na = length a in let nb = length b in init (na * nb) (fun j -> let i = j / nb in (unsafe_get a i, unsafe_get b (j - i * nb))) (*$T cartesian_product let a = cartesian_product [|1;2|] [|"a";"b"|] in \ sort Pervasives.compare a; \ a = [|1,"a"; 1,"b"; 2,"a"; 2, "b" |] *) (*$Q cartesian_product (Q.pair (Q.list Q.small_int) (Q.list Q.small_int)) (fun(la,lb) -> \ let a = of_list (List.take 5 la) and b = of_list (List.take 4 lb) in \ length (cartesian_product a b) = length a * length b) *) let compare cmp a b = let length_a = length a in let length_b = length b in let length = BatInt.min length_a length_b in let rec aux i = if i < length then let result = cmp (unsafe_get a i) (unsafe_get b i) in if result = 0 then aux (i + 1) else result else if length_a = length_b then 0 else if length_a < length_b then -1 else 1 in aux 0 (*$T compare compare Pervasives.compare [|1;2;3|] [|1;2|] = 1 compare Pervasives.compare [|1;2|] [|1;2;4|] = -1 compare Pervasives.compare [|1|] [||] = 1 compare Pervasives.compare [||] [||] = 0 compare Pervasives.compare [|1;2|] [|1;2|] = 0 compare (fun x y -> -(Pervasives.compare x y)) [|2;1|] [|1;2|] = -1 *) let print ?(first="[|") ?(last="|]") ?(sep="; ") print_a out t = match length t with | 0 -> BatInnerIO.nwrite out first; BatInnerIO.nwrite out last | n -> BatInnerIO.nwrite out first; print_a out (unsafe_get t 0); for i = 1 to n - 1 do BatInnerIO.nwrite out sep; print_a out (unsafe_get t i); done; BatInnerIO.nwrite out last (*$T BatIO.to_string (print ~sep:"," ~first:"[" ~last:"]" BatInt.print) \ [|2;4;66|] = "[2,4,66]" BatIO.to_string (print ~sep:"," ~first:"[" ~last:"]" BatInt.print) \ [|2|] = "[2]" BatIO.to_string (print ~sep:"," ~first:"[" ~last:"]" BatInt.print) \ [||] = "[]" *) let reduce f a = if length a = 0 then invalid_arg "Array.reduce: empty array" else let acc = ref (unsafe_get a 0) in for i = 1 to length a - 1 do acc := f !acc (unsafe_get a i) done; !acc (*$T reduce reduce (+) [|1;2;3|] = 6 reduce (fun _ -> assert false) [|1|] = 1 try reduce (fun _ _ -> ()) [||]; false \ with Invalid_argument _ -> true *) let min a = reduce Pervasives.min a let max a = reduce Pervasives.max a (*$T min min [|1;2;3|] = 1 min [|2;3;1|] = 1 *)(*$T max max [|1;2;3|] = 3 max [|2;3;1|] = 3 *) let min_max a = let n = length a in if n = 0 then invalid_arg "Array.min_max: empty array" else let mini = ref (unsafe_get a 0) in let maxi = ref (unsafe_get a 0) in for i = 1 to n - 1 do if (unsafe_get a i) > !maxi then maxi := (unsafe_get a i); if (unsafe_get a i) < !mini then mini := (unsafe_get a i) done; (!mini, !maxi) (*$T min_max min_max [|1|] = (1, 1) min_max [|1;-2;10;3|] = (-2, 10) try ignore (min_max [||]); false with Invalid_argument _ -> true *) let sum = fold_left (+) 0 let fsum = fold_left (+.) 0. (*$T sum sum [|1;2;3|] = 6 sum [|0|] = 0 sum [||] = 0 *) (*$T fsum fsum [|1.0;2.0;3.0|] = 6.0 fsum [|0.0|] = 0.0 *) let kahan_sum arr = let sum = ref 0. in let err = ref 0. in for i = 0 to length arr - 1 do let x = (unsafe_get arr i) -. !err in let new_sum = !sum +. x in err := (new_sum -. !sum) -. x; sum := new_sum +. 0.; (* this suspicious +. 0. is added to help the hand of the somewhat flaky unboxing optimizer; it hopefully won't be necessary anymore in a few OCaml versions *) done; !sum +. 0. (*$T kahan_sum kahan_sum [| |] = 0. kahan_sum [| 1.; 2. |] = 3. let n, x = 1_000, 1.1 in \ Float.approx_equal (float n *. x) \ (kahan_sum (make n x)) *) let flength a = float_of_int (length a) let avg a = (float_of_int (sum a)) /. (flength a) let favg a = (fsum a) /. (flength a) ;; (*$T avg avg [|1; 2; 3|] = 2. avg [|0|] = 0. *) (*$T favg favg [|1.0; 2.0; 3.0|] = 2.0 favg [|0.0|] = 0.0 *) (* meant for tests, don't care about side effects being repeated or not failing early *) let is_sorted_by f xs = let ok = ref true in for i = 0 to length xs - 2 do ok := !ok && (f (unsafe_get xs i)) <= (f (unsafe_get xs (i + 1))) done; !ok (* TODO: Investigate whether a second array is better than pairs *) let decorate_stable_sort f xs = let decorated = map (fun x -> (f x, x)) xs in let () = stable_sort (fun (i,_) (j,_) -> Pervasives.compare i j) decorated in map (fun (_,x) -> x) decorated (*$T decorate_stable_sort decorate_stable_sort fst [|(1,2);(1,3);(0,2);(1,4)|] \ = [|(0,2);(1,2);(1,3);(1,4)|] *) (*$Q decorate_stable_sort (Q.pair (Q.array Q.small_int) (Q.fun1 Q.Observable.int (Q.option Q.int))) \ (fun (a, Q.Fun(_,f)) -> is_sorted_by f (decorate_stable_sort f a)) *) let decorate_fast_sort f xs = let decorated = map (fun x -> (f x, x)) xs in let () = fast_sort (fun (i,_) (j,_) -> Pervasives.compare i j) decorated in map (fun (_,x) -> x) decorated (*$Q decorate_fast_sort (Q.pair (Q.array Q.small_int) (Q.fun1 Q.Observable.int (Q.option Q.int))) \ (fun (a, Q.Fun(_,f)) -> is_sorted_by f (decorate_fast_sort f a)) *) let bsearch cmp arr x = let rec bsearch i j = if i > j then `Just_after j else let middle = i + (j - i) / 2 in (* avoid overflow *) match cmp x (unsafe_get arr middle) with | BatOrd.Eq -> `At middle | BatOrd.Lt -> bsearch i (middle - 1) | BatOrd.Gt -> bsearch (middle + 1) j in if length arr = 0 then `Empty else match (cmp (unsafe_get arr 0) x, cmp (unsafe_get arr (length arr - 1)) x) with | BatOrd.Gt, _ -> `All_bigger | _, BatOrd.Lt -> `All_lower | _ -> bsearch 0 (length arr - 1) (*$T bsearch bsearch BatInt.ord [|1; 2; 2; 3; 4; 10|] 3 = `At 3 bsearch BatInt.ord [|1; 2; 2; 3; 4; 10|] 5 = `Just_after 4 bsearch BatInt.ord [|1; 2; 5; 5; 11; 12|] 1 = `At 0 bsearch BatInt.ord [|1; 2; 5; 5; 11; 12|] 12 = `At 5 bsearch BatInt.ord [|1; 2; 2; 3; 4; 9|] 10 = `All_lower bsearch BatInt.ord [|1; 2; 2; 3; 4; 9|] 0 = `All_bigger bsearch BatInt.ord [| |] 3 = `Empty *) let pivot_split cmp arr x = let open BatOrd in let n = length arr in (* find left edge between i and j *) let rec search_left i j = if i > j then i else let middle = i + (j-i)/2 in match cmp (unsafe_get arr middle) x with | Lt -> search_left (middle+1) j | Gt -> search_left i (middle-1) | Eq -> (* check whether [middle] is the edge, ie the leftmost index where arr.(_) = x *) let neighbor = middle - 1 in if neighbor < 0 || cmp (unsafe_get arr neighbor) x = Lt then middle (* found! *) else search_left i neighbor (* go further on left *) (* find right edge, between i and j *) and search_right i j = if i > j then i else let middle = i + (j-i)/2 in match cmp (unsafe_get arr middle) x with | Lt -> search_right (middle+1) j | Gt -> search_right i (middle-1) | Eq -> let neighbor = middle + 1 in if neighbor = n || cmp (unsafe_get arr neighbor) x = Gt then middle + 1 (* found! *) else search_right neighbor j (* go further on right *) in (search_left 0 (n-1), search_right 0 (n-1)) (*$T pivot_split pivot_split BatInt.ord [| |] 1 = (0, 0) pivot_split BatInt.ord [|1;2;2;3;3;4;5|] 3 = (3,5) pivot_split BatInt.ord [|1;1;1;2;3;3;4;5|] 1 = (0,3) pivot_split BatInt.ord [|1;2;2;3;3;4;5|] 10 = (7,7) pivot_split BatInt.ord [|1;2;2;3;3;4;5|] 0 = (0,0) pivot_split BatInt.ord [|2;2;2|] 2 = (0,3) pivot_split BatInt.ord [|1;2;2;4;5|] 3 = (3,3) *) let insert xs x i = let len = length xs in if i < 0 || i > len then invalid_arg "Array.insert: offset out of range"; init (len+1) (fun j -> if j < i then unsafe_get xs j else if j > i then unsafe_get xs (j-1) else x) (*$T insert insert [|1;2;3|] 4 0 = [|4;1;2;3|] insert [|1;2;3|] 4 3 = [|1;2;3;4|] insert [|1;2;3|] 4 2 = [|1;2;4;3|] try ignore (insert [|1;2;3|] 4 100); false \ with Invalid_argument _ -> true try ignore (insert [|1;2;3|] 4 (-40)); false \ with Invalid_argument _ -> true *) let remove_at i src = let x = src.(i) in (* keep the bound check in there *) let n = length src in let dst = make (n - 1) x in blit src 0 dst 0 i; blit src (i + 1) dst i (n - i - 1); dst (*$T remove_at try remove_at 0 [||] = [|1|] \ with Invalid_argument _ -> true remove_at 0 [|1;2;3|] = [|2;3|] remove_at 1 [|1;2;3|] = [|1;3|] remove_at 2 [|1;2;3|] = [|1;2|] try remove_at 3 [|1;2;3|] = [|1|] \ with Invalid_argument _ -> true *) (* helper function; only works for arrays of equal length *) let eq_elements eq_elt a1 a2 = for_all2 eq_elt a1 a2 (* helper function to compare arrays *) let rec ord_aux eq_elt i a1 a2 = let open BatOrd in if i >= length a1 then Eq else match eq_elt (unsafe_get a1 i) (unsafe_get a2 i) with | (Lt | Gt) as res -> res | Eq -> ord_aux eq_elt (i+1) a1 a2 let ord_elements eq_elt a1 a2 = ord_aux eq_elt 0 a1 a2 let equal eq a1 a2 = BatOrd.bin_eq BatInt.equal (length a1) (length a2) (eq_elements eq) a1 a2 (*$T equal equal (=) [|1;2;3|] [|1;2;3|] not (equal (=) [|1;2;3|] [|1;2;3;4|]) not (equal (=) [|1;2;3;4|] [|1;2;3|]) equal (=) [||] [||] equal (<>) [|1;2;3|] [|2;3;4|] not (equal (<>) [|1;2;3|] [|3;2;1|]) *) let ord ord_elt a1 a2 = BatOrd.bin_ord BatInt.ord (length a1) (length a2) (ord_elements ord_elt) a1 a2 (*$T ord ord BatInt.ord [|2|] [|1;2|] = BatOrd.Lt ord BatInt.ord [|1;1|] [|2|] = BatOrd.Gt ord BatInt.ord [|1;1;1|] [|1;1;2|] = BatOrd.Lt ord BatInt.ord [|1;1;1|] [|1;1;1|] = BatOrd.Eq *) let shuffle ?state a = BatInnerShuffle.array_shuffle ?state a (*$T shuffle let s = Random.State.make [|11|] in \ let a = [|1;2;3;4;5;6;7;8;9|] in \ shuffle ~state:s a; \ a = [|7; 2; 9; 5; 3; 6; 4; 1; 8|] let b = [||] in \ shuffle b; \ b = [||] *) (* equivalent of List.split *) let split a = let n = length a in if n = 0 then ([||], [||]) else let l, r = unsafe_get a 0 in let left = make n l in let right = make n r in for i = 1 to n - 1 do let l, r = unsafe_get a i in unsafe_set left i l; unsafe_set right i r done; (left, right) (*$T split split [||] = ([||], [||]) split [|(1,2);(3,4);(5,6)|] = ([|1;3;5|], [|2;4;6|]) *) let combine a b = let m = length a in let n = length b in if m <> n then invalid_arg "Array.combine"; map2 (fun x y -> (x, y)) a b (*$T combine combine [||] [||] = [||] try combine [|1;2;3|] [||] = [||] with Invalid_argument _ -> true combine [|1;2;3|] [|4;5;6|] = [|(1,4);(2,5);(3,6)|] *) module Incubator = struct module Eq (T : BatOrd.Eq) = struct type t = T.t array let eq = equal T.eq end module Ord (T : BatOrd.Ord) = struct type t = T.t array let ord = ord T.ord end end let left a len = if len >= length a then a else sub a 0 len let right a len = let alen = length a in if len >= alen then a else sub a (alen - len) len let head a pos = left a pos let tail a pos = let alen = length a in if pos >= alen then [||] else sub a pos (alen - pos) (*$= left & ~printer:(IO.to_string (print Int.print)) (left [|1;2;3|] 1) [|1|] (left [|1;2|] 3) [|1;2|] (left [|1;2;3|] 3) [|1;2;3|] (left [|1;2;3|] 10)[|1;2;3|] (left [|1;2;3|] 0) [||] *) (*$= right & ~printer:(IO.to_string (print Int.print)) (right [|1;2;3|] 1) [|3|] (right [|1;2|] 3) [|1;2|] (right [|1;2;3|] 3) [|1;2;3|] (right [|1;2;3|] 10) [|1;2;3|] (right [|1;2;3|] 0) [||] *) (*$= tail & ~printer:(IO.to_string (print Int.print)) (tail [|1;2;3|] 1) [|2;3|] [||] (tail [|1;2;3|] 10) (tail [|1;2;3|] 0) [|1;2;3|] *) (*$= head & ~printer:(IO.to_string (print Int.print)) (head [|1;2;3|] 1) [|1|] (head [|1;2;3|] 10) [|1;2;3|] (head [|1;2;3|] 0) [||] *) module Cap = struct (** Implementation note: in [('a, 'b) t], ['b] serves only as a phantom type, to mark which operations are only legitimate on readable arrays or writeable arrays.*) type ('a, 'b) t = 'a array constraint 'b = [< `Read | `Write] external of_array : 'a array -> ('a, _ ) t = "%identity" external to_array : ('a, [`Read | `Write]) t -> 'a array = "%identity" external read_only : ('a, [>`Read]) t -> ('a, [`Read]) t = "%identity" external write_only : ('a, [>`Write]) t -> ('a, [`Write]) t = "%identity" external length : ('a, [> ]) t -> int = "%array_length" external get : ('a, [> `Read]) t -> int -> 'a = "%array_safe_get" external set : ('a, [> `Write]) t -> int -> 'a -> unit = "%array_safe_set" external make : int -> 'a -> ('a, _) t = "caml_make_vect" external create : int -> 'a -> ('a, _) t = "caml_make_vect" ##V>=4.2## external make_float: int -> (float, _) t = "caml_make_float_vect" ##V<4.2## let make_float n = make n 0. let init = init let make_matrix = make_matrix let create_matrix= make_matrix let iter = iter let map = map let filter = filter let filter_map = filter_map let count_matching = count_matching let iteri = iteri let mapi = mapi let modify = modify let modifyi = modifyi let fold_left = fold_left let fold = fold_left let fold_left_map = fold_left_map let fold_right = fold_right let fold_while = fold_while let iter2 = iter2 let iter2i = iter2i let for_all = for_all let exists = exists let find = find let find_opt = find_opt let find_map = find_map let mem = mem let memq = memq let findi = findi let find_all = find_all let partition = partition let rev = rev let rev_in_place = rev_in_place let append = append let concat = concat let sub = sub let copy = copy let fill = fill let blit = blit let enum = enum let of_enum = of_enum let backwards = backwards let of_backwards = of_backwards let to_list = to_list let split = split let combine = combine let pivot_split = pivot_split let of_list = of_list let sort = sort let stable_sort = stable_sort let fast_sort = fast_sort let compare = compare let print = print let ord = ord let equal = equal external unsafe_get : ('a, [> `Read]) t -> int -> 'a = "%array_unsafe_get" external unsafe_set : ('a, [> `Write])t -> int -> 'a -> unit = "%array_unsafe_set" module Labels = struct let init i ~f = init i f let create len ~init = create len init let make = create let make_matrix ~dimx ~dimy x = make_matrix dimx dimy x let create_matrix = make_matrix let sub a ~pos ~len = sub a pos len let fill a ~pos ~len x = fill a pos len x let blit ~src ~src_pos ~dst ~dst_pos ~len = blit src src_pos dst dst_pos len let iter ~f a = iter f a let map ~f a = map f a let iteri ~f a = iteri f a let mapi ~f a = mapi f a let modify ~f a = modify f a let modifyi ~f a = modifyi f a let fold_left ~f ~init a = fold_left f init a let fold_left_map ~f ~init a = fold_left_map f init a let fold = fold_left let fold_right ~f a ~init= fold_right f a init let fold_while ~p ~f ~init a = fold_while p f init a let sort ~cmp a = sort cmp a let stable_sort ~cmp a = stable_sort cmp a let fast_sort ~cmp a = fast_sort cmp a let iter2 ~f a b = iter2 f a b let exists ~f a = exists f a let for_all ~f a = for_all f a let iter2i ~f a b = iter2i f a b let find ~f a = find f a let find_opt ~f a = find_opt f a let find_map ~f a = find_map f a let filter ~f a = filter f a let filter_map ~f a = filter_map f a let count_matching ~f a = count_matching f a end module Exceptionless = struct let find f e = try Some (find f e) with Not_found -> None let findi f e = try Some (findi f e) with Not_found -> None end end module Exceptionless = struct let find f e = try Some (find f e) with Not_found -> None let findi f e = try Some (findi f e) with Not_found -> None end module Labels = struct let init i ~f = init i f let create len ~init = make len init let make = create let make_matrix ~dimx ~dimy x = make_matrix dimx dimy x let create_matrix = make_matrix let sub a ~pos ~len = sub a pos len let fill a ~pos ~len x = fill a pos len x let blit ~src ~src_pos ~dst ~dst_pos ~len = blit src src_pos dst dst_pos len let iter ~f a = iter f a let map ~f a = map f a let iteri ~f a = iteri f a let mapi ~f a = mapi f a let modify ~f a = modify f a let modifyi ~f a = modifyi f a let fold_left ~f ~init a = fold_left f init a let fold_left_map ~f ~init a = fold_left_map f init a let fold = fold_left let fold_right ~f a ~init= fold_right f a init let fold_while ~p ~f ~init a = fold_while p f init a let sort ~cmp a = sort cmp a let stable_sort ~cmp a = stable_sort cmp a let fast_sort ~cmp a = fast_sort cmp a let iter2 ~f a b = iter2 f a b let exists ~f a = exists f a let for_all ~f a = for_all f a let iter2i ~f a b = iter2i f a b let find ~f a = find f a let find_opt ~f a = find_opt f a let find_map ~f a = find_map f a let findi ~f e = findi f e let filter ~f a = filter f a let filter_map ~f a = filter_map f a let count_matching ~f a = count_matching f a module LExceptionless = struct include Exceptionless let find ~f e = find f e let findi ~f e = findi f e end end batteries-included-3.4.0/src/batAvlTree.ml000066400000000000000000000120211415601150500204310ustar00rootroot00000000000000(* Copyright 2003 Yamagata Yoriyuki. distributed with LGPL *) (* Modified by Edgar Friendly *) type 'a tree = | Empty | Node of 'a tree * 'a * 'a tree * int (* height *) let empty = Empty let is_empty = function | Empty -> true | Node _ -> false let singleton_tree x = Node (Empty, x, Empty, 1) let left_branch = function | Empty -> raise Not_found | Node (l, _, _, _) -> l let right_branch = function | Empty -> raise Not_found | Node (_, _, r, _) -> r let root = function | Empty -> raise Not_found | Node (_, v, _, _) -> v let height = function | Empty -> 0 | Node (_, _, _, h) -> h let create l v r = let h' = 1 + BatInt.max (height l) (height r) in assert (abs (height l - height r ) < 2); Node (l, v, r, h') (* Assume |hl - hr| < 3 *) let bal l v r = let hl = height l in let hr = height r in if hl >= hr + 2 then match l with | Empty -> assert false | Node (ll, lv, lr, _) -> if height ll >= height lr then create ll lv (create lr v r) else match lr with | Empty -> assert false | 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 | Node (rl, rv, rr, _) -> if height rr >= height rl then create (create l v rl) rv rr else match rl with | Empty -> assert false | Node (rll, rlv, rlr, _) -> create (create l v rll) rlv (create rlr rv rr) else create l v r let rec add_left v = function | Empty -> Node (Empty, v, Empty, 1) | Node (l, v', r, _) -> bal (add_left v l) v' r let rec add_right v = function | Empty -> Node (Empty, v, Empty, 1) | Node (l, v', r, _) -> bal l v' (add_right v r) (* No assumption of height of l and r. *) let rec make_tree l v r = match l , r with | Empty, _ -> add_left v r | _, Empty -> add_right v l | Node (ll, lv, lr, lh), Node (rl, rv, rr, rh) -> if lh > rh + 1 then bal ll lv (make_tree lr v r) else if rh > lh + 1 then bal (make_tree l v rl) rv rr else create l v r (* Generate pseudo-random trees in an imbalanced fashion using function [f]. The trees generated are determined solely by the input list. *) (*${*) let rec of_list_for_test f = function | [] -> empty | h :: t -> let len = BatList.length t in let (l, r) = BatList.split_at (abs (h mod (len+1))) t in f (of_list_for_test f l) h (of_list_for_test f r) (*$}*) (* This tests three aspects of [make_tree] and the rebalancing algorithm: - The height value in a node is accurate. - The height of two subnodes differs at most by one (main AVL tree invariant). - All elements put into a tree stay in a tree even if it is rebalanced. *) (*$Q make_tree & ~small:List.length (Q.list Q.small_int) (fun l -> \ let t = of_list_for_test make_tree l in \ check_height_cache t && check_height_balance t \ ) (Q.list Q.small_int) (fun l -> \ let t = of_list_for_test make_tree l in \ (enum t |> List.of_enum |> List.sort compare) = List.sort compare l \ ) *) (* Utilities *) let rec split_leftmost = function | Empty -> raise Not_found | Node (Empty, v, r, _) -> (v, r) | Node (l, v, r, _) -> let v0, l' = split_leftmost l in (v0, make_tree l' v r) let rec split_rightmost = function | Empty -> raise Not_found | Node (l, v, Empty, _) -> (v, l) | Node (l, v, r, _) -> let v0, r' = split_rightmost r in (v0, make_tree l v r') let rec concat t1 t2 = match t1, t2 with | Empty, _ -> t2 | _, Empty -> t1 | Node (l1, v1, r1, h1), Node (l2, v2, r2, h2) -> if h1 < h2 then make_tree (concat t1 l2) v2 r2 else make_tree l1 v1 (concat r1 t2) let rec iter proc = function | Empty -> () | Node (l, v, r, _) -> iter proc l; proc v; iter proc r let rec fold f t init = match t with | Empty -> init | Node (l, v, r, _) -> let x = fold f l init in let x = f v x in fold f r x (* FIXME: this is nlog n because of the left nesting of appends *) let rec enum = function | Empty -> BatEnum.empty () | Node (l, v, r, _) -> BatEnum.append (enum l) (BatEnum.delay (fun () -> BatEnum.append (BatEnum.singleton v) (enum r))) (* Helpers for testing *) (* Check that the height value in a node is correct. *) let check_height_cache t = let rec go = function | Empty -> Some 0 | Node (l, _, r, h) -> let open BatOption.Monad in bind (go l) (fun lh -> bind (go r) (fun rh -> if max lh rh + 1 = h then Some h else None ) ) in BatOption.is_some (go t) (* Check that the difference of the height of the left and right subnode is 0 or 1 based on the height value in the nodes. *) let check_height_balance t = let balanced l r = match (l, r) with | (Node (_, _, _, hl), Node (_, _, _, hr)) -> abs (hl - hr) < 2 | _ -> true in let rec go = function | Empty -> true | Node (l, _, r, _) -> go l && go r && balanced l r in go t (* Sanity checks *) let check t = check_height_cache t && check_height_balance t batteries-included-3.4.0/src/batAvlTree.mli000066400000000000000000000030311415601150500206030ustar00rootroot00000000000000(* $Id: avlTree.mli,v 1.3 2003/06/18 15:11:07 yori Exp $ *) (* Copyright 2003 Yamagata Yoriyuki. distributed with LGPL *) (* Modified by Edgar Friendly *) (** Internals of ISet and IMap, usable as generic tree library *) type +'a tree val empty : 'a tree val is_empty : 'a tree -> bool val make_tree : 'a tree -> 'a -> 'a tree -> 'a tree val create : 'a tree -> 'a -> 'a tree -> 'a tree (** [create l v r] is similar to [make_tree l v r] but performs no rebalancing; in other words, you should use this only when you {e know} that [l] and [r] are already balanced. *) val height : 'a tree -> int val left_branch : 'a tree -> 'a tree (** @raise Not_found if the tree is empty *) val right_branch : 'a tree -> 'a tree (** @raise Not_found if the tree is empty *) val root : 'a tree -> 'a (** @raise Not_found if the tree is empty *) (* Utilities *) val singleton_tree : 'a -> 'a tree val split_leftmost : 'a tree -> 'a * 'a tree val split_rightmost : 'a tree -> 'a * 'a tree val concat : 'a tree -> 'a tree -> 'a tree val iter : ('a -> unit) -> 'a tree -> unit val fold : ('a -> 'b -> 'b) -> 'a tree -> 'b -> 'b val enum : 'a tree -> 'a BatEnum.t (* Sanity checks *) val check : 'a tree -> bool (** Check that the tree is balanced according to the AVL tree rules. An AVL tree is balanced when for every node the height of the subnodes differs by at most 1. @since 2.3.0 *) (**/**) (* Helpers for testing *) val check_height_cache : 'a tree -> bool val check_height_balance : 'a tree -> bool (**/**) batteries-included-3.4.0/src/batBase64.ml000066400000000000000000000103771415601150500201270ustar00rootroot00000000000000(* * Base64 - Base64 codec * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) exception Invalid_char exception Invalid_table (* UNUSED exception Invalid_padding *) external unsafe_char_of_int : int -> char = "%identity" type encoding_table = char array type decoding_table = int array let chars = [| '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';'0';'1';'2';'3';'4';'5';'6';'7';'8';'9';'+';'/' |] let make_decoding_table tbl = if Array.length tbl <> 64 then raise Invalid_table; let d = Array.make 256 (-1) in for i = 0 to 63 do Array.unsafe_set d (int_of_char (Array.unsafe_get tbl i)) i; done; d let inv_chars = make_decoding_table chars let encode ?(tbl=chars) ch = if Array.length tbl <> 64 then raise Invalid_table; let data = ref 0 in let count = ref 0 in let flush() = if !count > 0 then begin let d = (!data lsl (6 - !count)) land 63 in BatIO.write ch (Array.unsafe_get tbl d); end; count := 0; in let write c = let c = int_of_char c in data := (!data lsl 8) lor c; count := !count + 8; while !count >= 6 do count := !count - 6; let d = (!data asr !count) land 63 in BatIO.write ch (Array.unsafe_get tbl d) done; in let output s p l = for i = p to p + l - 1 do write (Bytes.unsafe_get s i) done; l in BatIO.create_out ~write ~output ~flush:(fun () -> flush(); BatIO.flush ch) ~close:(fun() -> flush(); BatIO.close_out ch) let decode ?(tbl=inv_chars) ch = if Array.length tbl <> 256 then raise Invalid_table; let data = ref 0 in let count = ref 0 in let rec fetch() = if !count >= 8 then begin count := !count - 8; let d = (!data asr !count) land 0xFF in unsafe_char_of_int d end else let c = int_of_char (BatIO.read ch) in let c = Array.unsafe_get tbl c in if c = -1 then raise Invalid_char; data := (!data lsl 6) lor c; count := !count + 6; fetch() in let read = fetch in let input s p l = let i = ref 0 in try while !i < l do Bytes.unsafe_set s (p + !i) (fetch()); incr i; done; l with BatIO.No_more_input when !i > 0 -> !i in let close() = count := 0; BatIO.close_in ch in BatIO.create_in ~read ~input ~close let str_encode ?(tbl=chars) s = let ch = encode ~tbl (BatIO.output_string()) in BatIO.nwrite ch s; BatIO.close_out ch let str_decode ?(tbl=inv_chars) s = let ch = decode ~tbl (BatIO.input_string s) in BatIO.nread ch ((String.length s * 6) / 8) (*$Q str_decode; str_encode (Q.string) (fun s -> s = str_decode (str_encode s)) (Q.string) (fun s -> let e = str_encode s in e = str_encode (str_decode e)) *) (*$T make_decoding_table try ignore (make_decoding_table [|'1'|]); false \ with Invalid_table -> true try ignore (make_decoding_table (Array.make 2000 '1')); false \ with Invalid_table -> true *) (*$T str_encode try ignore (str_encode ~tbl:[|'1'|] "mlk"); false \ with Invalid_table -> true try ignore (str_encode ~tbl:(Array.make 2000 '1') "mlk"); false \ with Invalid_table -> true *) (*$T str_decode try ignore (str_decode ~tbl:[|1|] "mlk"); false \ with Invalid_table -> true try ignore (str_decode ~tbl:(Array.make 2000 1) "mlk"); false \ with Invalid_table -> true *) batteries-included-3.4.0/src/batBase64.mli000066400000000000000000000042751415601150500203000ustar00rootroot00000000000000(* * Base64 - Base64 codec * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Base64 codec. 8-bit characters are encoded into 6-bit ones using ASCII lookup tables. Default tables maps 0..63 values on characters A-Z, a-z, 0-9, '+' and '/' (in that order). @documents Base64 @author Nicolas Cannasse *) (** This exception is raised when reading an invalid character from a base64 input. *) exception Invalid_char (** This exception is raised if the encoding or decoding table size is not correct. *) exception Invalid_table (** An encoding table maps integers 0..63 to the corresponding char. *) type encoding_table = char array (** A decoding table maps chars 0..255 to the corresponding 0..63 value or -1 if the char is not accepted. *) type decoding_table = int array (** Encode a string into Base64. *) val str_encode : ?tbl:encoding_table -> string -> string (** Decode a string encoded into Base64, raise [Invalid_char] if a character in the input string is not a valid one. *) val str_decode : ?tbl:decoding_table -> string -> string (** Generic base64 encoding over an output. *) val encode : ?tbl:encoding_table -> 'a BatIO.output -> 'a BatIO.output (** Generic base64 decoding over an input. *) val decode : ?tbl:decoding_table -> BatIO.input -> BatIO.input (** Create a valid decoding table from an encoding one. *) val make_decoding_table : encoding_table -> decoding_table batteries-included-3.4.0/src/batBig_int.mliv000066400000000000000000000361741415601150500210200ustar00rootroot00000000000000(* * BatBig_int - Extended operations on big integers * Copyright (C) 2008 Gabriel Scherer * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Operations on arbitrary-precision integers. Big integers (type {!big_int} or equivalently {!Big_int.t}) are signed integers of arbitrary size. This module lets you compute with huge numbers, whose size is limited only by the amount of memory given to OCaml. The downside is speed, as big integers are much slower than any other type of integer known to OCaml. This module replaces Stdlib's {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Big_int.html}Big_int} module. @author Valerie Menissier-Morain (base module) @author Gabriel Scherer @author David Teller *) type big_int = Big_int.big_int (** The type of big integers. *) val zero : big_int val zero_big_int : big_int (** The big integer [0]. *) val one : big_int val unit_big_int : big_int (** The big integer [1]. *) (** {6 Arithmetic operations} *) val neg : big_int -> big_int val succ : big_int -> big_int val pred : big_int -> big_int val abs : big_int -> big_int val add : big_int -> big_int -> big_int val sub : big_int -> big_int -> big_int val mul : big_int -> big_int -> big_int val div : big_int -> big_int -> big_int val modulo : big_int -> big_int -> big_int val pow : big_int -> big_int -> big_int type t = big_int val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t val ( ** ) : t -> t -> t val minus_big_int : big_int -> big_int (** Unary negation. *) val abs_big_int : big_int -> big_int (** Absolute value. *) val add_big_int : big_int -> big_int -> big_int (** Addition. *) val succ_big_int : big_int -> big_int (** Successor (add 1). *) val add_int_big_int : int -> big_int -> big_int (** Addition of a small integer to a big integer. *) val sub_big_int : big_int -> big_int -> big_int (** Subtraction. *) val pred_big_int : big_int -> big_int (** Predecessor (subtract 1). *) val mult_big_int : big_int -> big_int -> big_int (** Multiplication of two big integers. *) val mult_int_big_int : int -> big_int -> big_int (** Multiplication of a big integer by a small integer *) val square_big_int: big_int -> big_int (** Return the square of the given big integer *) val sqrt_big_int: big_int -> big_int (** [sqrt_big_int a] returns the integer square root of [a], that is, the largest big integer [r] such that [r * r <= a]. @raise Invalid_argument if [a] is negative. *) val quomod_big_int : big_int -> big_int -> big_int * big_int (** Euclidean division of two big integers. The first part of the result is the quotient, the second part is the remainder. Writing [(q,r) = quomod_big_int a b], we have [a = q * b + r] and [0 <= r < |b|]. @raise Division_by_zero if the divisor is zero. *) val div_big_int : big_int -> big_int -> big_int (** Euclidean quotient of two big integers. This is the first result [q] of [quomod_big_int] (see above). *) val mod_big_int : big_int -> big_int -> big_int (** Euclidean modulus of two big integers. This is the second result [r] of [quomod_big_int] (see above). *) val gcd_big_int : big_int -> big_int -> big_int (** Greatest common divisor of two big integers. *) val power_int_positive_int: int -> int -> big_int val power_big_int_positive_int: big_int -> int -> big_int val power_int_positive_big_int: int -> big_int -> big_int val power_big_int_positive_big_int: big_int -> big_int -> big_int (** Exponentiation functions. Return the big integer representing the first argument [a] raised to the power [b] (the second argument). Depending on the function, [a] and [b] can be either small integers or big integers. @raise Invalid_argument if [b] is negative. *) val operations : t BatNumber.numeric (** {6 Generators} *) val ( -- ) : big_int -> big_int -> big_int BatEnum.t val ( --- ): big_int -> big_int -> big_int BatEnum.t (** {6 Comparisons and tests} *) val compare : big_int -> big_int -> int val ord : big_int -> big_int -> BatOrd.order val equal : big_int -> big_int -> bool (* Available only in `Compare` submodule val ( <> ) : t -> t -> bool val ( >= ) : t -> t -> bool val ( <= ) : t -> t -> bool val ( > ) : t -> t -> bool val ( < ) : t -> t -> bool val ( = ) : t -> t -> bool *) val sign_big_int : big_int -> int (** Return [0] if the given big integer is zero, [1] if it is positive, and [-1] if it is negative. *) val compare_big_int : big_int -> big_int -> int (** [compare_big_int a b] returns [0] if [a] and [b] are equal, [1] if [a] is greater than [b], and [-1] if [a] is smaller than [b]. *) val eq_big_int : big_int -> big_int -> bool val le_big_int : big_int -> big_int -> bool val ge_big_int : big_int -> big_int -> bool val lt_big_int : big_int -> big_int -> bool val gt_big_int : big_int -> big_int -> bool (** Usual boolean comparisons between two big integers. *) val max_big_int : big_int -> big_int -> big_int (** Return the greater of its two arguments. *) val min_big_int : big_int -> big_int -> big_int (** Return the smaller of its two arguments. *) val num_digits_big_int : big_int -> int (** Return the number of machine words used to store the given big integer. *) ##V>=4.3##val num_bits_big_int : big_int -> int ##V>=4.3## (** Return the number of significant bits in the absolute ##V>=4.3## value of the given big integer. [num_bits_big_int a] ##V>=4.3## returns 0 if [a] is 0; otherwise it returns a positive ##V>=4.3## integer [n] such that [2^(n-1) <= |a| < 2^n]. ##V>=4.3## @since 2.5.0 and OCaml 4.03 *) (** {6 Conversions to and from strings} *) val to_string : big_int -> string val string_of_big_int : big_int -> string (** Return the string representation of the given big integer, in decimal (base 10). *) val of_string : string -> big_int val big_int_of_string : string -> big_int (** Convert a string to a big integer, in decimal. The string consists of an optional [-] or [+] sign, followed by one or several decimal digits. *) val big_int_of_string_opt: string -> big_int option (** Convert a string to a big integer, in decimal. The string consists of an optional [-] or [+] sign, followed by one or several decimal digits. Other the function returns [None]. @since 2.7.0 *) val to_string_in_binary : big_int -> string (** as [string_of_big_int], but in base 2 *) val to_string_in_octal : big_int -> string (** as [string_of_big_int], but in base 8 *) val to_string_in_hexa : big_int -> string (** as [string_of_big_int], but in base 16 *) val to_string_in_base : int -> big_int -> string (** [to_string_in_base b n] returns the string representation in base [b] of the given big integer [n]. Should you have advanced needs (arbitrarily large bases, or custom digits instead of the usual [0,1,...9,a,b,...,z]), use [to_string_in_custom_base] instead. @raise Invalid_argument if b is not in [2 .. 36]. *) val to_string_in_custom_base : string -> int -> big_int -> string (** First argument, called [symbols], is the vector of the symbols used to represent the digits in base [b]. [to_string_in_base] is almost equivalent to [to_string_in_custom_base big_int_base_default_symbols], the difference being that [to_string_in_custom_base] allows the base to be arbitrarily large, provided that [symbols] can accommodate it. Concretely, the base [b] must be at least [2], and [symbols] must be of size at least [b]. The default value of [big_int_base_default_symbols] contains 62 symbols, as it uses lowercase and uppercase letters both. See below for more information. @raise Invalid_argument if [b] is incorrect. *) val big_int_base_default_symbols : string (** Default vector of symbols used by [to_string_in_base] and its fixed-base derivatives [to_string_in_binary], [to_string_in_octal] and [to_string_in_hexa] to represent digits. The symbol at position [p] encodes the value [p]. The original value of this vector is, schematically, [['0'..'9' 'a' 'b'..'z' 'A' 'B'..'Z']], which is sufficient for bases up to and including 62. The basic [to_string_in_base] function is capped to base 36 to avoid unexpected behaviours do to the case-sensitivity of the output in bases 37 to 62. You technically {i can} mutate the vector, for instance if you prefer to exchange lower- and upper-case symbols program-wide. As usual where mutability is concerned, discretion is advised. Most of the time, it is better to build custom functions using [to_string_in_custom_base]. *) (** {6 Conversions to and from other numerical types} *) val of_int : int -> big_int val big_int_of_int : int -> big_int (** Convert a small integer to a big integer. *) val is_int_big_int : big_int -> bool (** Test whether the given big integer is small enough to be representable as a small integer (type [int]) without loss of precision. On a 32-bit platform, [is_int_big_int a] returns [true] if and only if [a] is between -2{^30} and 2{^30}-1. On a 64-bit platform, [is_int_big_int a] returns [true] if and only if [a] is between -2{^62} and 2{^62}-1. *) val to_int : big_int -> int val int_of_big_int : big_int -> int (** Convert a big integer to a small integer (type [int]). @raise Failure if the big integer is not representable as a small integer. *) val int_of_big_int_opt: big_int -> int option (** Convert a big integer to a small integer (type [int]). Return [None] if the big integer is not representable as a small integer. @since 2.7.0 *) val big_int_of_int32 : int32 -> big_int (** Convert a 32-bit integer to a big integer. *) val big_int_of_nativeint : nativeint -> big_int (** Convert a native integer to a big integer. *) val big_int_of_int64 : int64 -> big_int (** Convert a 64-bit integer to a big integer. *) val int32_of_big_int : big_int -> int32 (** Convert a big integer to a 32-bit integer. @raise Failure if the big integer is outside the range [[-2{^31}, 2{^31}-1]]. *) val int32_of_big_int_opt: big_int -> int32 option (** Convert a big integer to a 32-bit integer. Return [None] if the big integer is outside the range \[-2{^31}, 2{^31}-1\]. @since 2.7.0 *) val nativeint_of_big_int : big_int -> nativeint (** Convert a big integer to a native integer. @raise Failure if the big integer is outside the range [[Nativeint.min_int, Nativeint.max_int]]. *) val nativeint_of_big_int_opt: big_int -> nativeint option (** Convert a big integer to a native integer. Return [None] if the big integer is outside the range [[Nativeint.min_int, Nativeint.max_int]]; @since 2.7.0 *) val int64_of_big_int : big_int -> int64 (** Convert a big integer to a 64-bit integer. @raise Failure if the big integer is outside the range [[-2{^63}, 2{^63}-1]]. *) val int64_of_big_int_opt: big_int -> int64 option (** Convert a big integer to a 64-bit integer. Return [None] if the big integer is outside the range \[-2{^63}, 2{^63}-1\]. @since 2.7.0 *) val float_of_big_int : big_int -> float (** Returns a floating-point number approximating the given big integer. *) val of_float: float -> big_int (** rounds to the nearest integer @raise Invalid_argument when given NaN or +/-infinity *) val to_float: big_int -> float (** {6 Bit-oriented operations} *) val and_big_int : big_int -> big_int -> big_int (** Bitwise logical ``and''. The arguments must be positive or zero. *) val or_big_int : big_int -> big_int -> big_int (** Bitwise logical ``or''. The arguments must be positive or zero. *) val xor_big_int : big_int -> big_int -> big_int (** Bitwise logical ``exclusive or''. The arguments must be positive or zero. *) val shift_left_big_int : big_int -> int -> big_int (** [shift_left_big_int b n] returns [b] shifted left by [n] bits. Equivalent to multiplication by [2^n]. *) val shift_right_big_int : big_int -> int -> big_int (** [shift_right_big_int b n] returns [b] shifted right by [n] bits. Equivalent to division by [2^n] with the result being rounded towards minus infinity. *) val shift_right_towards_zero_big_int : big_int -> int -> big_int (** [shift_right_towards_zero_big_int b n] returns [b] shifted right by [n] bits. The shift is performed on the absolute value of [b], and the result has the same sign as [b]. Equivalent to division by [2^n] with the result being rounded towards zero. *) val extract_big_int : big_int -> int -> int -> big_int (** [extract_big_int bi ofs n] returns a nonnegative number corresponding to bits [ofs] to [ofs + n - 1] of the binary representation of [bi]. If [bi] is negative, a two's complement representation is used. *) (** {6 Submodules grouping all infix operators} *) module Infix : BatNumber.Infix with type bat__infix_t = t module Compare : BatNumber.Compare with type bat__compare_t = t (**/**) (** {6 For internal use} *) val nat_of_big_int : big_int -> Nat.nat val big_int_of_nat : Nat.nat -> big_int val base_power_big_int: int -> int -> big_int -> big_int val sys_big_int_of_string: string -> int -> int -> big_int val round_futur_last_digit : Bytes.t -> int -> int -> bool val approx_big_int: int -> big_int -> string ##V>=4.3##val round_big_int_to_float: big_int -> bool -> float (** {6 Obsolete}*) val zero_big_int : big_int (** The big integer [0]. *) val unit_big_int : big_int (** The big integer [1]. *) val minus_big_int : big_int -> big_int (** Unary negation. *) val abs_big_int : big_int -> big_int (** Absolute value. *) val add_big_int : big_int -> big_int -> big_int val succ_big_int : big_int -> big_int (** Successor (add 1). *) val sub_big_int : big_int -> big_int -> big_int (** Subtraction. *) val pred_big_int : big_int -> big_int (** Predecessor (subtract 1). *) val mult_big_int : big_int -> big_int -> big_int (** Multiplication of two big integers. *) val mult_int_big_int : int -> big_int -> big_int (** Multiplication of a big integer by a small integer *) val div_big_int : big_int -> big_int -> big_int (** Euclidean quotient of two big integers. This is the first result [q] of [quomod_big_int] (see above). *) val mod_big_int : big_int -> big_int -> big_int (** Euclidean modulus of two big integers. This is the second result [r] of [quomod_big_int] (see above). *) val gcd_big_int : big_int -> big_int -> big_int (** Greatest common divisor of two big integers. *) (**/**) (** {6 Boilerplate code} *) (** {7 Printing} *) val print : 'a BatIO.output -> t -> unit batteries-included-3.4.0/src/batBig_int.mlv000066400000000000000000000164171415601150500206450ustar00rootroot00000000000000(* * BatInt32 - Extended Big integers * Copyright (C) 2007 Bluestorm * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) let big_int_base_default_symbols = let symbol offset base k = char_of_int (k - offset + (int_of_char base)) in BatBytesCompat.string_init (10 + 26*2) (fun k -> if k < 10 then symbol 0 '0' k else if k < 36 then symbol 10 'a' k else symbol 36 'A' k ) let to_string_in_custom_base symbols (* vector of digit symbols 0,1,...,a,b,... *) b (* base, int > 1 and <= number of defined symbols *) n (* big integer *) = let open Big_int in if b <= 1 then invalid_arg "Big_int.to_string_in_custom_base: base must be > 1"; if b > String.length symbols then invalid_arg ( "Big_int.to_string_in_custom_base: big_int_base_default_symbols too small for base " ^ (string_of_int b) ^ ": only " ^ string_of_int (String.length symbols)); let isnegative = sign_big_int n < 0 in (* generously over-approximate number of binary digits of n; num_digits_big_int actually returns the number of _words_ *) let base2digits = Sys.word_size * num_digits_big_int n in (* over-approximate resulting digits in base b, using following theorem, where k = base2digits : k k k * Log[2] digits in base b <= Ceiling[Log[b, 2 ]] and Log[b, 2 ] == ----------- Log[b] *) let basebdigits = int_of_float (ceil ( ((float_of_int base2digits) *. (log 2.)) /. (log (float_of_int b)))) + (if isnegative then 1 else 0) (* the pesky '-' sign *) in let buff = Bytes.create basebdigits in (* we know the buffer is large enough *) let curr = ref (basebdigits - 1) and count = ref 0 in let addchar c = Bytes.set buff !curr c ; incr count; decr curr in (* switch base to big int representation and n to mutable, and loop *) let b = big_int_of_int b and n = ref (abs_big_int n) in while compare_big_int !n b >= 0 do let q,d = quomod_big_int !n b in n := q; addchar symbols.[int_of_big_int d]; done; addchar symbols.[int_of_big_int !n]; if isnegative then addchar '-'; Bytes.sub_string buff (!curr + 1) !count let to_string_in_base b n = if b <= 1 || b > 36 then invalid_arg "Big_int.to_string_in_base: base must be in 2..36" else to_string_in_custom_base big_int_base_default_symbols b n let to_string_in_binary = to_string_in_base 2 let to_string_in_octal = to_string_in_base 8 let to_string_in_hexa = to_string_in_base 16 (*$= to_string_in_base & ~printer:identity (to_string_in_base 16 (big_int_of_int 9485)) "250d" (to_string_in_base 16 (big_int_of_int (-9485))) "-250d" (to_string_in_base 10 (big_int_of_int 9485)) "9485" (to_string_in_base 8 (big_int_of_int 9485)) "22415" (to_string_in_base 2 (big_int_of_int 9485)) "10010100001101" (to_string_in_base 36 (big_int_of_int 948565)) "kbx1" (to_string_in_base 3 (big_int_of_int 2765353)) "12012111100111" *) (*$= to_string_in_custom_base & ~printer:identity (to_string_in_custom_base "*/!" 3 (big_int_of_int 2765353)) "/!*/!////**///" *) (*$= to_string_in_binary & ~printer:identity (to_string_in_binary (big_int_of_int 9485)) "10010100001101" *) (*$= to_string_in_octal & ~printer:identity (to_string_in_octal (big_int_of_int 9485)) "22415" *) (*$= to_string_in_hexa & ~printer:identity (to_string_in_hexa (big_int_of_int 9485)) "250d" *) (*$T to_string_in_base try ignore (to_string_in_base 37 (big_int_of_int 948565)); false \ with Invalid_argument _ -> true try ignore (to_string_in_base 1 (big_int_of_int 948565)); false \ with Invalid_argument _ -> true *) (*$Q to_string_in_base Q.int (fun i-> let bi = big_int_of_int i in \ to_string_in_base 10 bi = string_of_big_int bi) *) open BatNumber module BaseBig_int : NUMERIC_BASE with type t = Big_int.big_int = struct open Big_int type t = big_int let zero = zero_big_int let one = unit_big_int let succ = succ_big_int let pred = pred_big_int let neg = minus_big_int let abs = abs_big_int let add = add_big_int let sub = sub_big_int let mul = mult_big_int let div = div_big_int let modulo = mod_big_int let pow = power_big_int_positive_big_int let to_string = string_of_big_int let of_string = big_int_of_string let to_int = int_of_big_int let of_int = big_int_of_int let compare = compare_big_int let of_float f = try of_string (Printf.sprintf "%.0f" f) with Failure _ -> invalid_arg "Big_int.of_float" (*$T of_float to_int (of_float 4.46) = 4 to_int (of_float 4.56) = 5 to_int (of_float (-4.46)) = -4 to_int (of_float (-4.56)) = -5 try ignore (of_float nan); false with Invalid_argument _ -> true try ignore (of_float (1. /. 0.)); false with Invalid_argument _ -> true try ignore (of_float (-1. /. 0.)); false with Invalid_argument _ -> true *) let to_float = float_of_big_int end include Big_int include MakeNumeric(BaseBig_int) let print out t = BatIO.nwrite out (to_string t) (*$T print BatIO.to_string print (of_int 456) = "456" BatIO.to_string print (power_int_positive_int 10 31) = "10000000000000000000000000000000" BatIO.to_string print (power_int_positive_int (-10) 31) = "-10000000000000000000000000000000" *) (* Tests for infix operators. Those are a little trickier than usual * for big_ints because the generic comparison functions do not work * for big_ints and therefore we have to take care the proper ones are * used. Cf issue #674. Same reason prevent qcheck to compare big_ints * so we convert to int: *) (*$< Infix *) (*$= (--) & ~printer:(IO.to_string (List.print Int.print)) ((of_int 1 -- of_int 3) /@ to_int |> List.of_enum) [1; 2; 3] *) (*$= (---) & ~printer:(IO.to_string (List.print Int.print)) ((of_int 1 --- of_int 3) /@ to_int |> List.of_enum) [1; 2; 3] ((of_int 3 --- of_int 1) /@ to_int |> List.of_enum) [3; 2; 1] *) (*$>*) ##V<4.5##let big_int_of_string_opt s = try Some (big_int_of_string s) with _ -> None ##V<4.5##let int_of_big_int_opt n = try Some (int_of_big_int n) with _ -> None ##V<4.5##let int32_of_big_int_opt n = try Some (int32_of_big_int n) with _ -> None ##V<4.5##let int64_of_big_int_opt n = try Some (int64_of_big_int n) with _ -> None ##V<4.5##let nativeint_of_big_int_opt n = try Some (nativeint_of_big_int n) with _ -> None batteries-included-3.4.0/src/batBigarray.mliv000066400000000000000000001473631415601150500212100ustar00rootroot00000000000000(* * BatBigarray - additional and modified functions for big arrays. * Copyright (C) 2000 Michel Serrano * 2000 Xavier Leroy * 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Additional and modified functions for big arrays. *) (** Large, multi-dimensional, numerical arrays. This module implements multi-dimensional arrays of integers and floating-point numbers, thereafter referred to as ``big arrays''. The implementation allows efficient sharing of large numerical arrays between OCaml code and C or Fortran numerical libraries. Concerning the naming conventions, users of this module are encouraged to do [open Bigarray] in their source, then refer to array types and operations via short dot notation, e.g. [Array1.t] or [Array2.sub]. Big arrays support all the OCaml ad-hoc polymorphic operations: - comparisons ([=], [<>], [<=], etc, as well as {!Pervasives.compare}); - hashing (module [Hash]); - and structured input-output ({!Pervasives.output_value} and {!Pervasives.input_value}, as well as the functions from the {!Marshal} module). This module replaces Stdlib's {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Bigarray.html}Bigarray} module. @author Michel Serrano (Base library) @author Xavier Leroy (Base library) @author David Teller *) (** {6 Element kinds} *) (** Big arrays can contain elements of the following kinds: - IEEE single precision (32 bits) floating-point numbers ({!Bigarray.float32_elt}), - IEEE double precision (64 bits) floating-point numbers ({!Bigarray.float64_elt}), - IEEE single precision (2 * 32 bits) floating-point complex numbers ({!Bigarray.complex32_elt}), - IEEE double precision (2 * 64 bits) floating-point complex numbers ({!Bigarray.complex64_elt}), - 8-bit integers (signed or unsigned) ({!Bigarray.int8_signed_elt} or {!Bigarray.int8_unsigned_elt}), - 16-bit integers (signed or unsigned) ({!Bigarray.int16_signed_elt} or {!Bigarray.int16_unsigned_elt}), - OCaml integers (signed, 31 bits on 32-bit architectures, 63 bits on 64-bit architectures) ({!Bigarray.int_elt}), - 32-bit signed integer ({!Bigarray.int32_elt}), - 64-bit signed integers ({!Bigarray.int64_elt}), - platform-native signed integers (32 bits on 32-bit architectures, 64 bits on 64-bit architectures) ({!Bigarray.nativeint_elt}). Each element kind is represented at the type level by one of the abstract types defined below. *) (* The V>=4.2 lines are not necessary for typing, but they are necessary for the compatibility test in batteries_compattest.ml which are of the form: module _ = (BatBigarray : module type of Bigarray) because of the somewhat strange interpretation of strengthening in (module type of), we need to explicitly equate each type with its constructor *) type float32_elt = Bigarray.float32_elt ##V>=4.2## = Float32_elt type float64_elt = Bigarray.float64_elt ##V>=4.2## = Float64_elt type complex32_elt = Bigarray.complex32_elt ##V>=4.2## = Complex32_elt type complex64_elt = Bigarray.complex64_elt ##V>=4.2## = Complex64_elt type int8_signed_elt = Bigarray.int8_signed_elt ##V>=4.2## = Int8_signed_elt type int8_unsigned_elt = Bigarray.int8_unsigned_elt ##V>=4.2## = Int8_unsigned_elt type int16_signed_elt = Bigarray.int16_signed_elt ##V>=4.2## = Int16_signed_elt type int16_unsigned_elt = Bigarray.int16_unsigned_elt ##V>=4.2## = Int16_unsigned_elt type int_elt = Bigarray.int_elt ##V>=4.2## = Int_elt type int32_elt = Bigarray.int32_elt ##V>=4.2## = Int32_elt type int64_elt = Bigarray.int64_elt ##V>=4.2## = Int64_elt type nativeint_elt = Bigarray.nativeint_elt ##V>=4.2## = Nativeint_elt type ('a, 'b) kind = ('a,'b) Bigarray.kind ##V>=4.2## = Float32 : (float, float32_elt) kind ##V>=4.2## | Float64 : (float, float64_elt) kind ##V>=4.2## | Int8_signed : (int, int8_signed_elt) kind ##V>=4.2## | Int8_unsigned : (int, int8_unsigned_elt) kind ##V>=4.2## | Int16_signed : (int, int16_signed_elt) kind ##V>=4.2## | Int16_unsigned : (int, int16_unsigned_elt) kind ##V>=4.2## | Int32 : (int32, int32_elt) kind ##V>=4.2## | Int64 : (int64, int64_elt) kind ##V>=4.2## | Int : (int, int_elt) kind ##V>=4.2## | Nativeint : (nativeint, nativeint_elt) kind ##V>=4.2## | Complex32 : (Complex.t, complex32_elt) kind ##V>=4.2## | Complex64 : (Complex.t, complex64_elt) kind ##V>=4.2## | Char : (char, int8_unsigned_elt) kind (**) (** To each element kind is associated an OCaml type, which is the type of OCaml values that can be stored in the big array or read back from it. This type is not necessarily the same as the type of the array elements proper: for instance, a big array whose elements are of kind [float32_elt] contains 32-bit single precision floats, but reading or writing one of its elements from OCaml uses the OCaml type [float], which is 64-bit double precision floats. ##V<4.2## The abstract type [('a, 'b) kind] captures this association ##V<4.2## of an OCaml type ['a] for values read or written in the big array, ##V<4.2## and of an element kind ['b] which represents the actual contents ##V<4.2## of the big array. The following predefined values of type ##V<4.2## [kind] list all possible associations of OCaml types with ##V<4.2## element kinds: ##V>=4.2## The GADT type [('a, 'b) kind] captures this association ##V>=4.2## of an OCaml type ['a] for values read or written in the big array, ##V>=4.2## and of an element kind ['b] which represents the actual contents ##V>=4.2## of the big array. Its constructors list all possible associations ##V>=4.2## of OCaml types with element kinds, and are re-exported below for ##V>=4.2## backward-compatibility reasons. ##V>=4.2## ##V>=4.2## Using a generalized algebraic datatype (GADT) here allows to write ##V>=4.2## well-typed polymorphic functions whose return type depend on the ##V>=4.2## argument type, such as: ##V>=4.2##{[ ##V>=4.2## let zero : type a b. (a, b) kind -> a = function ##V>=4.2## | Float32 -> 0.0 | Complex32 -> Complex.zero ##V>=4.2## | Float64 -> 0.0 | Complex64 -> Complex.zero ##V>=4.2## | Int8_signed -> 0 | Int8_unsigned -> 0 ##V>=4.2## | Int16_signed -> 0 | Int16_unsigned -> 0 ##V>=4.2## | Int32 -> 0l | Int64 -> 0L ##V>=4.2## | Int -> 0 | Nativeint -> 0n ##V>=4.2## | Char -> '\000' ##V>=4.2##]} *) val float32 : (float, float32_elt) kind (** See {!Bigarray.char}. *) val float64 : (float, float64_elt) kind (** See {!Bigarray.char}. *) val complex32 : (Complex.t, complex32_elt) kind (** See {!Bigarray.char}. *) val complex64 : (Complex.t, complex64_elt) kind (** See {!Bigarray.char}. *) val int8_signed : (int, int8_signed_elt) kind (** See {!Bigarray.char}. *) val int8_unsigned : (int, int8_unsigned_elt) kind (** See {!Bigarray.char}. *) val int16_signed : (int, int16_signed_elt) kind (** See {!Bigarray.char}. *) val int16_unsigned : (int, int16_unsigned_elt) kind (** See {!Bigarray.char}. *) val int : (int, int_elt) kind (** See {!Bigarray.char}. *) val int32 : (int32, int32_elt) kind (** See {!Bigarray.char}. *) val int64 : (int64, int64_elt) kind (** See {!Bigarray.char}. *) val nativeint : (nativeint, nativeint_elt) kind (** See {!Bigarray.char}. *) val char : (char, int8_unsigned_elt) kind (** As shown by the types of the values above, big arrays of kind [float32_elt] and [float64_elt] are accessed using the OCaml type [float]. Big arrays of complex kinds [complex32_elt], [complex64_elt] are accessed with the OCaml type {!Complex.t}. Big arrays of integer kinds are accessed using the smallest OCaml integer type large enough to represent the array elements: [int] for 8- and 16-bit integer bigarrays, as well as OCaml-integer bigarrays; [int32] for 32-bit integer bigarrays; [int64] for 64-bit integer bigarrays; and [nativeint] for platform-native integer bigarrays. Finally, big arrays of kind [int8_unsigned_elt] can also be accessed as arrays of characters instead of arrays of small integers, by using the kind value [char] instead of [int8_unsigned]. *) val kind_size_in_bytes : ('a, 'b) kind -> int (** [kind_size_in_bytes k] is the number of bytes used to store an element of type [k]. @since 2.5.0 *) (** {6 Array layouts} *) type c_layout = Bigarray.c_layout ##V>=4.2## = C_layout_typ (**) (** See {!Bigarray.fortran_layout}.*) type fortran_layout = Bigarray.fortran_layout ##V>=4.2## = Fortran_layout_typ (**) (** To facilitate interoperability with existing C and Fortran code, this library supports two different memory layouts for big arrays, one compatible with the C conventions, the other compatible with the Fortran conventions. In the C-style layout, array indices start at 0, and multi-dimensional arrays are laid out in row-major format. That is, for a two-dimensional array, all elements of row 0 are contiguous in memory, followed by all elements of row 1, etc. In other terms, the array elements at [(x,y)] and [(x, y+1)] are adjacent in memory. In the Fortran-style layout, array indices start at 1, and multi-dimensional arrays are laid out in column-major format. That is, for a two-dimensional array, all elements of column 0 are contiguous in memory, followed by all elements of column 1, etc. In other terms, the array elements at [(x,y)] and [(x+1, y)] are adjacent in memory. Each layout style is identified at the type level by the abstract types {!Bigarray.c_layout} and [fortran_layout] respectively. *) type 'a layout = 'a Bigarray.layout ##V>=4.2## = C_layout : c_layout layout ##V>=4.2## | Fortran_layout : fortran_layout layout (**) (** The type ['a layout] represents one of the two supported memory layouts: C-style if ['a] is {!Bigarray.c_layout}, Fortran-style if ['a] is {!Bigarray.fortran_layout}. *) (** {7 Supported layouts} The abstract values [c_layout] and [fortran_layout] represent the two supported layouts at the level of values. *) val c_layout : c_layout layout val fortran_layout : fortran_layout layout (**Generic arrays (of arbitrarily many dimensions) *) module Genarray : sig type ('a, 'b, 'c) t = ('a, 'b, 'c) Bigarray.Genarray.t (** The type [Genarray.t] is the type of big arrays with variable numbers of dimensions. Any number of dimensions between 1 and 16 is supported. The three type parameters to [Genarray.t] identify the array element kind and layout, as follows: - the first parameter, ['a], is the OCaml type for accessing array elements ([float], [int], [int32], [int64], [nativeint]); - the second parameter, ['b], is the actual kind of array elements ([float32_elt], [float64_elt], [int8_signed_elt], [int8_unsigned_elt], etc); - the third parameter, ['c], identifies the array layout ([c_layout] or [fortran_layout]). For instance, [(float, float32_elt, fortran_layout) Genarray.t] is the type of generic big arrays containing 32-bit floats in Fortran layout; reads and writes in this array use the OCaml type [float]. *) external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t = "caml_ba_create" (** [Genarray.create kind layout dimensions] returns a new big array whose element kind is determined by the parameter [kind] (one of [float32], [float64], [int8_signed], etc) and whose layout is determined by the parameter [layout] (one of [c_layout] or [fortran_layout]). The [dimensions] parameter is an array of integers that indicate the size of the big array in each dimension. The length of [dimensions] determines the number of dimensions of the bigarray. For instance, [Genarray.create int32 c_layout [|4;6;8|]] returns a fresh big array of 32-bit integers, in C layout, having three dimensions, the three dimensions being 4, 6 and 8 respectively. Big arrays returned by [Genarray.create] are not initialized: the initial values of array elements is unspecified. @raise Invalid_argument if the number of dimensions is not in the range 1 to 16 inclusive, or if one of the dimensions is negative. *) external num_dims: ('a, 'b, 'c) t -> int = "caml_ba_num_dims" (** Return the number of dimensions of the given big array. *) val dims : ('a, 'b, 'c) t -> int array (** [Genarray.dims a] returns all dimensions of the big array [a], as an array of integers of length [Genarray.num_dims a]. *) external nth_dim: ('a, 'b, 'c) t -> int -> int = "caml_ba_dim" (** [Genarray.nth_dim a n] returns the [n]-th dimension of the big array [a]. The first dimension corresponds to [n = 0]; the second dimension corresponds to [n = 1]; the last dimension, to [n = Genarray.num_dims a - 1]. @raise Invalid_argument if [n] is less than 0 or greater or equal than [Genarray.num_dims a]. *) external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" (** Return the kind of the given big array. *) external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" (** Return the layout of the given big array. *) ##V>=4.4## external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t ##V>=4.4## = "caml_ba_change_layout" ##V>=4.4## (** [Genarray.change_layout a layout] returns a bigarray with the ##V>=4.4## specified [layout], sharing the data with [a] (and hence having ##V>=4.4## the same dimensions as [a]). No copying of elements is involved: the ##V>=4.4## new array and the original array share the same storage space. ##V>=4.4## The dimensions are reversed, such that [get v [| a; b |]] in ##V>=4.4## C layout becomes [get v [| b+1; a+1 |]] in Fortran layout. ##V>=4.4## ##V>=4.4## @since 2.5.3 and OCaml 4.04.0 ##V>=4.4## *) val size_in_bytes : ('a, 'b, 'c) t -> int (** [size_in_bytes a] is the number of elements in [a] multiplied by [a]'s {!kind_size_in_bytes}. @since 2.5.0 *) external get: ('a, 'b, 'c) t -> int array -> 'a = "caml_ba_get_generic" (** Read an element of a generic big array. [Genarray.get a [|i1; ...; iN|]] returns the element of [a] whose coordinates are [i1] in the first dimension, [i2] in the second dimension, ..., [iN] in the [N]-th dimension. If [a] has C layout, the coordinates must be greater or equal than 0 and strictly less than the corresponding dimensions of [a]. If [a] has Fortran layout, the coordinates must be greater or equal than 1 and less or equal than the corresponding dimensions of [a]. @raise Invalid_argument if the array [a] does not have exactly [N] dimensions, or if the coordinates are outside the array bounds. If [N > 3], alternate syntax is provided: you can write [a.{i1, i2, ..., iN}] instead of [Genarray.get a [|i1; ...; iN|]]. (The syntax [a.{...}] with one, two or three coordinates is reserved for accessing one-, two- and three-dimensional arrays as described below.) *) external set: ('a, 'b, 'c) t -> int array -> 'a -> unit = "caml_ba_set_generic" (** Assign an element of a generic big array. [Genarray.set a [|i1; ...; iN|] v] stores the value [v] in the element of [a] whose coordinates are [i1] in the first dimension, [i2] in the second dimension, ..., [iN] in the [N]-th dimension. The array [a] must have exactly [N] dimensions, and all coordinates must lie inside the array bounds, as described for [Genarray.get]; @raise Invalid_argument otherwise. If [N > 3], alternate syntax is provided: you can write [a.{i1, i2, ..., iN} <- v] instead of [Genarray.set a [|i1; ...; iN|] v]. (The syntax [a.{...} <- v] with one, two or three coordinates is reserved for updating one-, two- and three-dimensional arrays as described below.) *) external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "caml_ba_sub" (** Extract a sub-array of the given big array by restricting the first (left-most) dimension. [Genarray.sub_left a ofs len] returns a big array with the same number of dimensions as [a], and the same dimensions as [a], except the first dimension, which corresponds to the interval [[ofs ... ofs + len - 1]] of the first dimension of [a]. No copying of elements is involved: the sub-array and the original array share the same storage space. In other terms, the element at coordinates [[|i1; ...; iN|]] of the sub-array is identical to the element at coordinates [[|i1+ofs; ...; iN|]] of the original array [a]. [Genarray.sub_left] applies only to big arrays in C layout. @raise Invalid_argument if [ofs] and [len] do not designate a valid sub-array of [a], that is, if [ofs < 0], or [len < 0], or [ofs + len > Genarray.nth_dim a 0]. *) external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "caml_ba_sub" (** Extract a sub-array of the given big array by restricting the last (right-most) dimension. [Genarray.sub_right a ofs len] returns a big array with the same number of dimensions as [a], and the same dimensions as [a], except the last dimension, which corresponds to the interval [[ofs ... ofs + len - 1]] of the last dimension of [a]. No copying of elements is involved: the sub-array and the original array share the same storage space. In other terms, the element at coordinates [[|i1; ...; iN|]] of the sub-array is identical to the element at coordinates [[|i1; ...; iN+ofs|]] of the original array [a]. [Genarray.sub_right] applies only to big arrays in Fortran layout. @raise Invalid_argument if [ofs] and [len] do not designate a valid sub-array of [a], that is, if [ofs < 1], or [len < 0], or [ofs + len > Genarray.nth_dim a (Genarray.num_dims a - 1)]. *) external slice_left: ('a, 'b, c_layout) t -> int array -> ('a, 'b, c_layout) t = "caml_ba_slice" (** Extract a sub-array of lower dimension from the given big array by fixing one or several of the first (left-most) coordinates. [Genarray.slice_left a [|i1; ... ; iM|]] returns the ``slice'' of [a] obtained by setting the first [M] coordinates to [i1], ..., [iM]. If [a] has [N] dimensions, the slice has dimension [N - M], and the element at coordinates [[|j1; ...; j(N-M)|]] in the slice is identical to the element at coordinates [[|i1; ...; iM; j1; ...; j(N-M)|]] in the original array [a]. No copying of elements is involved: the slice and the original array share the same storage space. [Genarray.slice_left] applies only to big arrays in C layout. @raise Invalid_argument if [M >= N], or if [[|i1; ... ; iM|]] is outside the bounds of [a]. *) external slice_right: ('a, 'b, fortran_layout) t -> int array -> ('a, 'b, fortran_layout) t = "caml_ba_slice" (** Extract a sub-array of lower dimension from the given big array by fixing one or several of the last (right-most) coordinates. [Genarray.slice_right a [|i1; ... ; iM|]] returns the ``slice'' of [a] obtained by setting the last [M] coordinates to [i1], ..., [iM]. If [a] has [N] dimensions, the slice has dimension [N - M], and the element at coordinates [[|j1; ...; j(N-M)|]] in the slice is identical to the element at coordinates [[|j1; ...; j(N-M); i1; ...; iM|]] in the original array [a]. No copying of elements is involved: the slice and the original array share the same storage space. [Genarray.slice_right] applies only to big arrays in Fortran layout. @raise Invalid_argument if [M >= N], or if [[|i1; ... ; iM|]] is outside the bounds of [a]. *) external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" (** Copy all elements of a big array in another big array. [Genarray.blit src dst] copies all elements of [src] into [dst]. Both arrays [src] and [dst] must have the same number of dimensions and equal dimensions. Copying a sub-array of [src] to a sub-array of [dst] can be achieved by applying [Genarray.blit] to sub-array or slices of [src] and [dst]. *) external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" (** Set all elements of a big array to a given value. [Genarray.fill a v] stores the value [v] in all elements of the big array [a]. Setting only some elements of [a] to [v] can be achieved by applying [Genarray.fill] to a sub-array or a slice of [a]. *) val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout -> bool -> int array -> ('a, 'b, 'c) t (** Memory mapping of a file as a big array. [Genarray.map_file fd kind layout shared dims] returns a big array of kind [kind], layout [layout], and dimensions as specified in [dims]. The data contained in this big array are the contents of the file referred to by the file descriptor [fd] (as opened previously with [Unix.openfile], for example). The optional [pos] parameter is the byte offset in the file of the data being mapped; it default to 0 (map from the beginning of the file). If [shared] is [true], all modifications performed on the array are reflected in the file. This requires that [fd] be opened with write permissions. If [shared] is [false], modifications performed on the array are done in memory only, using copy-on-write of the modified pages; the underlying file is not affected. [Genarray.map_file] is much more efficient than reading the whole file in a big array, modifying that big array, and writing it afterwards. To adjust automatically the dimensions of the big array to the actual size of the file, the major dimension (that is, the first dimension for an array with C layout, and the last dimension for an array with Fortran layout) can be given as [-1]. [Genarray.map_file] then determines the major dimension from the size of the file. The file must contain an integral number of sub-arrays as determined by the non-major dimensions, @raise Failure otherwise. If all dimensions of the big array are given, the file size is matched against the size of the big array. If the file is larger than the big array, only the initial portion of the file is mapped to the big array. If the file is smaller than the big array, the file is automatically grown to the size of the big array. This requires write permissions on [fd]. *) val iter : ('a -> unit) -> ('a, 'b, 'c) t -> unit (** [iter f a] applies function [f] in turn to all the elements of [a]. *) val iteri : ((int, [`Read]) BatArray.Cap.t -> 'a -> unit) -> ('a, 'b, 'c) t -> unit (** Same as {!iter}, but the function is applied to the index of the element as the first argument, and the element itself as the second argument. *) val modify : ('a -> 'a) -> ('a, 'b, 'c) t -> unit (** [modify f a] changes each element [x] in [a] to [f x] in-place. *) val modifyi : ((int, [`Read]) BatArray.Cap.t -> 'a -> 'a) -> ('a, 'b, 'c) t -> unit (** Same as {!modify}, but the function is applied to the index of the coordinates as the first argument, and the element itself as the second argument. *) val enum : ('a, 'b, 'c) t -> 'a BatEnum.t (** [enum e] returns an enumeration on the elements of [e]. The order of enumeration is unspecified.*) val map : ('a -> 'b) -> ('b, 'c) Bigarray.kind -> ('a, 'd, 'e) t -> ('b, 'c, 'e) t (** [map f kind a] applies function [f] to all the elements of [a], and builds a {!Bigarray.t} of kind [kind] with the results returned by [f]. *) val mapi : ((int, [`Read]) BatArray.Cap.t -> 'a -> 'b) -> ('b, 'c) Bigarray.kind -> ('a, 'd, 'e) t -> ('b, 'c, 'e) t (** Same as {!map}, but the function is applied to the index of the coordinates as the first argument, and the element itself as the second argument. *) end ##V>=4.5##(** {6 Zero-dimensional arrays} *) ##V>=4.5## ##V>=4.5##(** Zero-dimensional arrays. The [Array0] structure provides operations ##V>=4.5## similar to those of {!Bigarray.Genarray}, but specialized to the case ##V>=4.5## of zero-dimensional arrays that only contain a single scalar value. ##V>=4.5## Statically knowing the number of dimensions of the array allows ##V>=4.5## faster operations, and more precise static type-checking. ##V>=4.5## @since 2.7.0 and OCaml 4.05.0 *) ##V>=4.5##module Array0 : sig ##V>=4.5## type ('a, 'b, 'c) t = ('a, 'b, 'c) Bigarray.Array0.t ##V>=4.5## (** The type of zero-dimensional big arrays whose elements have ##V>=4.5## OCaml type ['a], representation kind ['b], and memory layout ['c]. *) ##V>=4.5## ##V>=4.5## val create: ('a, 'b) kind -> 'c layout -> ('a, 'b, 'c) t ##V>=4.5## (** [Array0.create kind layout] returns a new bigarray of zero dimension. ##V>=4.5## [kind] and [layout] determine the array element kind and the array ##V>=4.5## layout as described for {!Genarray.create}. *) ##V>=4.5## ##V>=4.5## external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" ##V>=4.5## (** Return the kind of the given big array. *) ##V>=4.5## ##V>=4.5## external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" ##V>=4.5## (** Return the layout of the given big array. *) ##V>=4.5## ##V>=4.6## val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t ##V>=4.6## (** [Array0.change_layout a layout] returns a big array with the ##V>=4.6## specified [layout], sharing the data with [a]. No copying of elements ##V>=4.6## is involved: the new array and the original array share the same ##V>=4.6## storage space. ##V>=4.6## ##V>=4.6## @since 4.06.0 ##V>=4.6## *) ##V>=4.5## ##V>=4.5## val size_in_bytes : ('a, 'b, 'c) t -> int ##V>=4.5## (** [size_in_bytes a] is [a]'s {!kind_size_in_bytes}. *) ##V>=4.5## ##V>=4.5## val get: ('a, 'b, 'c) t -> 'a ##V>=4.5## (** [Array0.get a] returns the only element in [a]. *) ##V>=4.5## ##V>=4.5## val set: ('a, 'b, 'c) t -> 'a -> unit ##V>=4.5## (** [Array0.set a x v] stores the value [v] in [a]. *) ##V>=4.5## ##V>=4.5## external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" ##V>=4.5## (** Copy the first big array to the second big array. ##V>=4.5## See {!Genarray.blit} for more details. *) ##V>=4.5## ##V>=4.5## external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" ##V>=4.5## (** Fill the given big array with the given value. ##V>=4.5## See {!Genarray.fill} for more details. *) ##V>=4.5## ##V>=4.5## val of_value: ('a, 'b) kind -> 'c layout -> 'a -> ('a, 'b, 'c) t ##V>=4.5## (** Build a zero-dimensional big array initialized from the ##V>=4.5## given value. *) ##V>=4.5## ##V>=4.5##end (** {6 One-dimensional arrays} *) (** One-dimensional arrays. The [Array1] structure provides operations similar to those of {!Bigarray.Genarray}, but specialized to the case of one-dimensional arrays. (The [Array2] and [Array3] structures below provide operations specialized for two- and three-dimensional arrays.) Statically knowing the number of dimensions of the array allows faster operations, and more precise static type-checking. *) module Array1 : sig type ('a, 'b, 'c) t = ('a, 'b, 'c) Bigarray.Array1. t (** The type of one-dimensional big arrays whose elements have OCaml type ['a], representation kind ['b], and memory layout ['c]. *) val create: ('a, 'b) kind -> 'c layout -> int -> ('a, 'b, 'c) t (** [Array1.create kind layout dim] returns a new bigarray of one dimension, whose size is [dim]. [kind] and [layout] determine the array element kind and the array layout as described for [Genarray.create]. *) ##V<4.1## val dim: ('a, 'b, 'c) t -> int ##V>=4.1## external dim: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1" (** Return the size (dimension) of the given one-dimensional big array. *) external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" (** Return the kind of the given big array. *) external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" (** Return the layout of the given big array. *) ##V>=4.6## val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t ##V>=4.6## (** [Array1.change_layout a layout] returns a bigarray with the ##V>=4.6## specified [layout], sharing the data with [a] (and hence having ##V>=4.6## the same dimension as [a]). No copying of elements is involved: the ##V>=4.6## new array and the original array share the same storage space. ##V>=4.6## ##V>=4.6## @since 4.06.0 ##V>=4.6## *) val size_in_bytes : ('a, 'b, 'c) t -> int (** [size_in_bytes a] is the number of elements in [a] multiplied by [a]'s {!kind_size_in_bytes}. @since 2.5.0 *) external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1" (** [Array1.get a x], or alternatively [a.{x}], returns the element of [a] at index [x]. [x] must be greater or equal than [0] and strictly less than [Array1.dim a] if [a] has C layout. If [a] has Fortran layout, [x] must be greater or equal than [1] and less or equal than [Array1.dim a]. @raise Invalid_argument otherwise. *) external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_set_1" (** [Array1.set a x v], also written [a.{x} <- v], stores the value [v] at index [x] in [a]. [x] must be inside the bounds of [a] as described in {!Bigarray.Array1.get}; @raise Invalid_argument otherwise. *) external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "caml_ba_sub" (** Extract a sub-array of the given one-dimensional big array. See [Genarray.sub_left] for more details. *) ##V>=4.5## val slice: ('a, 'b, 'c) t -> int -> ('a, 'b, 'c) Array0.t ##V>=4.5## (** Extract a scalar (zero-dimensional slice) of the given one-dimensional ##V>=4.5## big array. The integer parameter is the index of the scalar to ##V>=4.5## extract. See {!Bigarray.Genarray.slice_left} and ##V>=4.5## {!Bigarray.Genarray.slice_right} for more details. ##V>=4.5## @since 2.7.0 and OCaml 4.05.0 *) external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" (** Copy the first big array to the second big array. See [Genarray.blit] for more details. *) external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" (** Fill the given big array with the given value. See [Genarray.fill] for more details. *) val of_array: ('a, 'b) kind -> 'c layout -> 'a array -> ('a, 'b, 'c) t (** Build a one-dimensional big array initialized from the given array. *) val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout -> bool -> int -> ('a, 'b, 'c) t (** Memory mapping of a file as a one-dimensional big array. See {!Bigarray.Genarray.map_file} for more details. *) val enum : ('a, 'b, 'c) t -> 'a BatEnum.t (** [Array1.enum e] returns an enumeration on the elements of [e]. Contrarily to the multi-dimensional case, order of elements is specified: elements are in sequential order, from smaller to larger indices. *) val of_enum : ('a, 'b) kind -> 'c layout -> 'a BatEnum.t -> ('a, 'b, 'c) t (** [Array1.of_enum kind layout enum] returns a new one-dimensional big array of kind [kind] and layout [layout], with elements taken from the enumeration [enum] in order. @since 2.1 *) val map : ('a -> 'b) -> ('b, 'c) Bigarray.kind -> ('a, 'd, 'e) t -> ('b, 'c, 'e) t (** [Array1.map f a] applies function [f] to all the elements of [a], and builds a {!Bigarray.Array1.t} with the results returned by [f]. *) val mapi : (int -> 'a -> 'b) -> ('b, 'c) Bigarray.kind -> ('a, 'd, 'e) t -> ('b, 'c, 'e) t (** Same as {!Bigarray.Array1.map}, but the function is applied to the index of the element as the first argument, and the element itself as the second argument. *) val modify : ('a -> 'a) -> ('a, 'b, 'c) t -> unit (** [modify f a] changes each element [x] in [a] to [f x] in-place. *) val modifyi : (int -> 'a -> 'a) -> ('a, 'b, 'c) t -> unit (** Same as {!Bigarray.Array1.modify}, but the function is applied to the index of the element as the first argument, and the element itself as the second argument. *) val to_array : ('a, 'b, 'c) t -> 'a array (** Build a one-dimensional array initialized from the given big array. *) (**{6 Unsafe operations} In case of doubt, don't use them.*) external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1" (** Like {!Bigarray.Array1.get}, but bounds checking is not always performed. Use with caution and only when the program logic guarantees that the access is within bounds. *) external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_unsafe_set_1" (** Like {!Bigarray.Array1.set}, but bounds checking is not always performed. Use with caution and only when the program logic guarantees that the access is within bounds. *) end (** {6 Two-dimensional arrays} *) (** Two-dimensional arrays. The [Array2] structure provides operations similar to those of {!Bigarray.Genarray}, but specialized to the case of two-dimensional arrays. *) module Array2 : sig type ('a, 'b, 'c) t = ('a, 'b, 'c) Bigarray.Array2. t (** The type of two-dimensional big arrays whose elements have OCaml type ['a], representation kind ['b], and memory layout ['c]. *) val create: ('a, 'b) kind -> 'c layout -> int -> int -> ('a, 'b, 'c) t (** [Array2.create kind layout dim1 dim2] returns a new bigarray of two dimension, whose size is [dim1] in the first dimension and [dim2] in the second dimension. [kind] and [layout] determine the array element kind and the array layout as described for {!Bigarray.Genarray.create}. *) ##V<4.1## val dim1: ('a, 'b, 'c) t -> int ##V>=4.1## external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1" (** Return the first dimension of the given two-dimensional big array. *) ##V<4.1## val dim2: ('a, 'b, 'c) t -> int ##V>=4.1## external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2" (** Return the second dimension of the given two-dimensional big array. *) external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" (** Return the kind of the given big array. *) external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" (** Return the layout of the given big array. *) ##V>=4.6## val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t ##V>=4.6## (** [Array2.change_layout a layout] returns a bigarray with the ##V>=4.6## specified [layout], sharing the data with [a] (and hence having ##V>=4.6## the same dimensions as [a]). No copying of elements is involved: the ##V>=4.6## new array and the original array share the same storage space. ##V>=4.6## The dimensions are reversed, such that [get v [| a; b |]] in ##V>=4.6## C layout becomes [get v [| b+1; a+1 |]] in Fortran layout. ##V>=4.6## ##V>=4.6## @since 4.06.0 ##V>=4.6## *) val size_in_bytes : ('a, 'b, 'c) t -> int (** [size_in_bytes a] is the number of elements in [a] multiplied by [a]'s {!kind_size_in_bytes}. @since 2.5.0 *) external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2" (** [Array2.get a x y], also written [a.{x,y}], returns the element of [a] at coordinates ([x], [y]). [x] and [y] must be within the bounds of [a], as described for {!Bigarray.Genarray.get}; @raise Invalid_argument otherwise. *) external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_set_2" (** [Array2.set a x y v], or alternatively [a.{x,y} <- v], stores the value [v] at coordinates ([x], [y]) in [a]. [x] and [y] must be within the bounds of [a], as described for {!Bigarray.Genarray.set}; @raise Invalid_argument otherwise. *) external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "caml_ba_sub" (** Extract a two-dimensional sub-array of the given two-dimensional big array by restricting the first dimension. See {!Bigarray.Genarray.sub_left} for more details. [Array2.sub_left] applies only to arrays with C layout. *) external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "caml_ba_sub" (** Extract a two-dimensional sub-array of the given two-dimensional big array by restricting the second dimension. See {!Bigarray.Genarray.sub_right} for more details. [Array2.sub_right] applies only to arrays with Fortran layout. *) val slice_left: ('a, 'b, c_layout) t -> int -> ('a, 'b, c_layout) Array1.t (** Extract a row (one-dimensional slice) of the given two-dimensional big array. The integer parameter is the index of the row to extract. See {!Bigarray.Genarray.slice_left} for more details. [Array2.slice_left] applies only to arrays with C layout. *) val slice_right: ('a, 'b, fortran_layout) t -> int -> ('a, 'b, fortran_layout) Array1.t (** Extract a column (one-dimensional slice) of the given two-dimensional big array. The integer parameter is the index of the column to extract. See {!Bigarray.Genarray.slice_right} for more details. [Array2.slice_right] applies only to arrays with Fortran layout. *) external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" (** Copy the first big array to the second big array. See {!Bigarray.Genarray.blit} for more details. *) external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" (** Fill the given big array with the given value. See {!Bigarray.Genarray.fill} for more details. *) val of_array: ('a, 'b) kind -> 'c layout -> 'a array array -> ('a, 'b, 'c) t (** Build a two-dimensional big array initialized from the given array of arrays. *) val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout -> bool -> int -> int -> ('a, 'b, 'c) t (** Memory mapping of a file as a two-dimensional big array. See {!Bigarray.Genarray.map_file} for more details. *) val enum : ('a, 'b, 'c) t -> 'a BatEnum.t (** [enum e] returns an enumeration on the elements of [e]. The order of enumeration is unspecified.*) val map : ('a -> 'b) -> ('b, 'c) Bigarray.kind -> ('a, 'd, 'e) t -> ('b, 'c, 'e) t (** [Array2.map f a] applies function [f] to all the elements of [a], and builds a {!Bigarray.Array2.t} with the results returned by [f]. *) val mapij : (int -> int -> 'a -> 'b) -> ('b, 'c) Bigarray.kind -> ('a, 'd, 'e) t -> ('b, 'c, 'e) t (** Same as {!Bigarray.Array2.map}, but the function is applied to the index of the element as the first two arguments, and the element itself as the third argument. *) val modify : ('a -> 'a) -> ('a, 'b, 'c) t -> unit (** [modify f a] changes each element [x] in [a] to [f x] in-place. *) val modifyij : (int -> int -> 'a -> 'a) -> ('a, 'b, 'c) t -> unit (** Same as {!Bigarray.Array2.modify}, but the function is applied to the index of the element as the first two arguments, and the element itself as the third argument. *) val to_array : ('a, 'b, 'c) t -> 'a array array (** Build a two-dimensional array initialized from the given big array. *) (**{6 Unsafe operations} In case of doubt, don't use them.*) external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_unsafe_ref_2" (** Like {!Bigarray.Array2.get}, but bounds checking is not always performed. *) external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_unsafe_set_2" (** Like {!Bigarray.Array2.set}, but bounds checking is not always performed. *) end (** {6 Three-dimensional arrays} *) (** Three-dimensional arrays. The [Array3] structure provides operations similar to those of {!Bigarray.Genarray}, but specialized to the case of three-dimensional arrays. *) module Array3 : sig type ('a, 'b, 'c) t = ('a, 'b, 'c) Bigarray.Array3. t (** The type of three-dimensional big arrays whose elements have OCaml type ['a], representation kind ['b], and memory layout ['c]. *) val create: ('a, 'b) kind -> 'c layout -> int -> int -> int -> ('a, 'b, 'c) t (** [Array3.create kind layout dim1 dim2 dim3] returns a new bigarray of three dimension, whose size is [dim1] in the first dimension, [dim2] in the second dimension, and [dim3] in the third. [kind] and [layout] determine the array element kind and the array layout as described for {!Bigarray.Genarray.create}. *) ##V<4.1## val dim1: ('a, 'b, 'c) t -> int ##V>=4.1## external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1" (** Return the first dimension of the given three-dimensional big array. *) ##V<4.1## val dim2: ('a, 'b, 'c) t -> int ##V>=4.1## external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2" (** Return the second dimension of the given three-dimensional big array. *) ##V<4.1## val dim3: ('a, 'b, 'c) t -> int ##V>=4.1## external dim3: ('a, 'b, 'c) t -> int = "%caml_ba_dim_3" (** Return the third dimension of the given three-dimensional big array. *) external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" (** Return the kind of the given big array. *) external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" (** Return the layout of the given big array. *) ##V>=4.6## val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t ##V>=4.6## (** [Array3.change_layout a layout] returns a bigarray with the ##V>=4.6## specified [layout], sharing the data with [a] (and hence having ##V>=4.6## the same dimensions as [a]). No copying of elements is involved: the ##V>=4.6## new array and the original array share the same storage space. ##V>=4.6## The dimensions are reversed, such that [get v [| a; b; c |]] in ##V>=4.6## C layout becomes [get v [| c+1; b+1; a+1 |]] in Fortran layout. ##V>=4.6## ##V>=4.6## @since 4.06.0 ##V>=4.6## *) val size_in_bytes : ('a, 'b, 'c) t -> int (** [size_in_bytes a] is the number of elements in [a] multiplied by [a]'s {!kind_size_in_bytes}. @since 2.5.0 *) external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_ref_3" (** [Array3.get a x y z], also written [a.{x,y,z}], returns the element of [a] at coordinates ([x], [y], [z]). [x], [y] and [z] must be within the bounds of [a], as described for {!Bigarray.Genarray.get}; @raise Invalid_argument otherwise. *) external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "%caml_ba_set_3" (** [Array3.set a x y v], or alternatively [a.{x,y,z} <- v], stores the value [v] at coordinates ([x], [y], [z]) in [a]. [x], [y] and [z] must be within the bounds of [a], as described for {!Bigarray.Genarray.set}; @raise Invalid_argument otherwise. *) external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "caml_ba_sub" (** Extract a three-dimensional sub-array of the given three-dimensional big array by restricting the first dimension. See {!Bigarray.Genarray.sub_left} for more details. [Array3.sub_left] applies only to arrays with C layout. *) external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "caml_ba_sub" (** Extract a three-dimensional sub-array of the given three-dimensional big array by restricting the second dimension. See {!Bigarray.Genarray.sub_right} for more details. [Array3.sub_right] applies only to arrays with Fortran layout. *) val slice_left_1: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) Array1.t (** Extract a one-dimensional slice of the given three-dimensional big array by fixing the first two coordinates. The integer parameters are the coordinates of the slice to extract. See {!Bigarray.Genarray.slice_left} for more details. [Array3.slice_left_1] applies only to arrays with C layout. *) val slice_right_1: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) Array1.t (** Extract a one-dimensional slice of the given three-dimensional big array by fixing the last two coordinates. The integer parameters are the coordinates of the slice to extract. See {!Bigarray.Genarray.slice_right} for more details. [Array3.slice_right_1] applies only to arrays with Fortran layout. *) val slice_left_2: ('a, 'b, c_layout) t -> int -> ('a, 'b, c_layout) Array2.t (** Extract a two-dimensional slice of the given three-dimensional big array by fixing the first coordinate. The integer parameter is the first coordinate of the slice to extract. See {!Bigarray.Genarray.slice_left} for more details. [Array3.slice_left_2] applies only to arrays with C layout. *) val slice_right_2: ('a, 'b, fortran_layout) t -> int -> ('a, 'b, fortran_layout) Array2.t (** Extract a two-dimensional slice of the given three-dimensional big array by fixing the last coordinate. The integer parameter is the coordinate of the slice to extract. See {!Bigarray.Genarray.slice_right} for more details. [Array3.slice_right_2] applies only to arrays with Fortran layout. *) external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" (** Copy the first big array to the second big array. See {!Bigarray.Genarray.blit} for more details. *) external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" (** Fill the given big array with the given value. See {!Bigarray.Genarray.fill} for more details. *) val of_array: ('a, 'b) kind -> 'c layout -> 'a array array array -> ('a, 'b, 'c) t (** Build a three-dimensional big array initialized from the given array of arrays of arrays. *) val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout -> bool -> int -> int -> int -> ('a, 'b, 'c) t (** Memory mapping of a file as a three-dimensional big array. See {!Bigarray.Genarray.map_file} for more details. *) val enum : ('a, 'b, 'c) t -> 'a BatEnum.t (** [enum e] returns an enumeration on the elements of [e]. The order of enumeration is unspecified.*) val map : ('a -> 'b) -> ('b, 'c) Bigarray.kind -> ('a, 'd, 'e) t -> ('b, 'c, 'e) t (** [Array3.map f a] applies function [f] to all the elements of [a], and builds a {!Bigarray.Array3.t} with the results returned by [f]. *) val mapijk : (int -> int -> int -> 'a -> 'b) -> ('b, 'c) Bigarray.kind -> ('a, 'd, 'e) t -> ('b, 'c, 'e) t (** Same as {!Bigarray.Array3.map}, but the function is applied to the index of the element as the first three arguments, and the element itself as the fourth argument. *) val modify : ('a -> 'a) -> ('a, 'b, 'c) t -> unit (** [modify f a] changes each element [x] in [a] to [f x] in-place. *) val modifyijk : (int -> int -> int -> 'a -> 'a) -> ('a, 'b, 'c) t -> unit (** Same as {!Bigarray.Array3.modify}, but the function is applied to the index of the coordinates as the first three arguments, and the element itself as the fourth argument. *) val to_array : ('a, 'b, 'c) t -> 'a array array array (** Build a three-dimensional array initialized from the given big array. *) (**{6 Unsafe operations} In case of doubt, don't use them.*) external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_unsafe_ref_3" (** Like {!Bigarray.Array3.get}, but bounds checking is not always performed. *) external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "%caml_ba_unsafe_set_3" (** Like {!Bigarray.Array3.set}, but bounds checking is not always performed. *) end (** {6 Coercions between generic big arrays and fixed-dimension big arrays} *) ##V>=4.5##external genarray_of_array0 : ##V>=4.5## ('a, 'b, 'c) Array0.t -> ('a, 'b, 'c) Genarray.t = "%identity" ##V>=4.5##(** Return the generic big array corresponding to the given zero-dimensional ##V>=4.5## big array. @since 2.7.0 and OCaml 4.05.0 *) external genarray_of_array1 : ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t = "%identity" (** Return the generic big array corresponding to the given one-dimensional big array. *) external genarray_of_array2 : ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t = "%identity" (** Return the generic big array corresponding to the given two-dimensional big array. *) external genarray_of_array3 : ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t = "%identity" (** Return the generic big array corresponding to the given three-dimensional big array. *) ##V>=4.5##val array0_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array0.t ##V>=4.5##(** Return the zero-dimensional big array corresponding to the given ##V>=4.5## generic big array. Raise [Invalid_argument] if the generic big array ##V>=4.5## does not have exactly zero dimension. ##V>=4.5## @since 2.7.0 and OCaml 4.05.0 *) val array1_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array1.t (** Return the one-dimensional big array corresponding to the given generic big array. @raise Invalid_argument if the generic big array does not have exactly one dimension. *) val array2_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array2.t (** Return the two-dimensional big array corresponding to the given generic big array. @raise Invalid_argument if the generic big array does not have exactly two dimensions. *) val array3_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array3.t (** Return the three-dimensional big array corresponding to the given generic big array. @raise Invalid_argument if the generic big array does not have exactly three dimensions. *) (** {6 Re-shaping big arrays} *) val reshape : ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t (** [reshape b [|d1;...;dN|]] converts the big array [b] to a [N]-dimensional array of dimensions [d1]...[dN]. The returned array and the original array [b] share their data and have the same layout. For instance, assuming that [b] is a one-dimensional array of dimension 12, [reshape b [|3;4|]] returns a two-dimensional array [b'] of dimensions 3 and 4. If [b] has C layout, the element [(x,y)] of [b'] corresponds to the element [x * 3 + y] of [b]. If [b] has Fortran layout, the element [(x,y)] of [b'] corresponds to the element [x + (y - 1) * 4] of [b]. The returned big array must have exactly the same number of elements as the original big array [b]. That is, the product of the dimensions of [b] must be equal to [i1 * ... * iN]. @raise Invalid_argument otherwise. *) ##V>=4.5##val reshape_0 : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array0.t ##V>=4.5##(** Specialized version of {!Bigarray.reshape} for reshaping to ##V>=4.5## zero-dimensional arrays. ##V>=4.5## @since 2.7.0 and OCaml 4.05.0 *) val reshape_1 : ('a, 'b, 'c) Genarray.t -> int -> ('a, 'b, 'c) Array1.t (** Specialized version of {!Bigarray.reshape} for reshaping to one-dimensional arrays. *) val reshape_2 : ('a, 'b, 'c) Genarray.t -> int -> int -> ('a, 'b, 'c) Array2.t (** Specialized version of {!Bigarray.reshape} for reshaping to two-dimensional arrays. *) val reshape_3 : ('a, 'b, 'c) Genarray.t -> int -> int -> int -> ('a, 'b, 'c) Array3.t (** Specialized version of {!Bigarray.reshape} for reshaping to three-dimensional arrays. *) batteries-included-3.4.0/src/batBigarray.mlv000066400000000000000000000465121415601150500210310ustar00rootroot00000000000000(* * BatBigarray - additional and modified functions for big arrays. * Copyright (C) 2000 Michel Serrano * 2000 Xavier Leroy * 2009 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module A = struct include BatArray include BatArray.Labels end (* The V>=4.2 lines are not necessary for typing, but they are necessary for the compatibility test in batteries_compattest.ml which are of the form: module _ = (BatBigarray : module type of Bigarray) because of the somewhat strange interpretation of strengthening in (module type of), we need to explicitly equate each type with its constructor *) type float32_elt = Bigarray.float32_elt ##V>=4.2## = Float32_elt type float64_elt = Bigarray.float64_elt ##V>=4.2## = Float64_elt type complex32_elt = Bigarray.complex32_elt ##V>=4.2## = Complex32_elt type complex64_elt = Bigarray.complex64_elt ##V>=4.2## = Complex64_elt type int8_signed_elt = Bigarray.int8_signed_elt ##V>=4.2## = Int8_signed_elt type int8_unsigned_elt = Bigarray.int8_unsigned_elt ##V>=4.2## = Int8_unsigned_elt type int16_signed_elt = Bigarray.int16_signed_elt ##V>=4.2## = Int16_signed_elt type int16_unsigned_elt = Bigarray.int16_unsigned_elt ##V>=4.2## = Int16_unsigned_elt type int_elt = Bigarray.int_elt ##V>=4.2## = Int_elt type int32_elt = Bigarray.int32_elt ##V>=4.2## = Int32_elt type int64_elt = Bigarray.int64_elt ##V>=4.2## = Int64_elt type nativeint_elt = Bigarray.nativeint_elt ##V>=4.2## = Nativeint_elt type ('a, 'b) kind = ('a,'b) Bigarray.kind ##V>=4.2## = Float32 : (float, float32_elt) kind ##V>=4.2## | Float64 : (float, float64_elt) kind ##V>=4.2## | Int8_signed : (int, int8_signed_elt) kind ##V>=4.2## | Int8_unsigned : (int, int8_unsigned_elt) kind ##V>=4.2## | Int16_signed : (int, int16_signed_elt) kind ##V>=4.2## | Int16_unsigned : (int, int16_unsigned_elt) kind ##V>=4.2## | Int32 : (int32, int32_elt) kind ##V>=4.2## | Int64 : (int64, int64_elt) kind ##V>=4.2## | Int : (int, int_elt) kind ##V>=4.2## | Nativeint : (nativeint, nativeint_elt) kind ##V>=4.2## | Complex32 : (Complex.t, complex32_elt) kind ##V>=4.2## | Complex64 : (Complex.t, complex64_elt) kind ##V>=4.2## | Char : (char, int8_unsigned_elt) kind (* this type is local to Batteries, it is meant to make it easier to port code written against (>= 4.2) GADT style into older versions: we know that a kind value (on < 4.2) can be directly converted to one of those by just the identity *) ##V<4.2##type untyped_kind = ##V<4.2## | Float32 ##V<4.2## | Float64 ##V<4.2## | Int8_signed ##V<4.2## | Int8_unsigned ##V<4.2## | Int16_signed ##V<4.2## | Int16_unsigned ##V<4.2## | Int32 ##V<4.2## | Int64 ##V<4.2## | Int ##V<4.2## | Nativeint ##V<4.2## | Complex32 ##V<4.2## | Complex64 ##V<4.2## | Char ##V<4.2##external untyped_kind_of_kind : (_, _) kind -> untyped_kind = "%identity" type c_layout = Bigarray.c_layout ##V>=4.2## = C_layout_typ type fortran_layout = Bigarray.fortran_layout ##V>=4.2## = Fortran_layout_typ type 'a layout = 'a Bigarray.layout ##V>=4.2## = C_layout : c_layout layout ##V>=4.2## | Fortran_layout : fortran_layout layout let float32 = Bigarray.float32 let float64 = Bigarray.float64 let complex32 = Bigarray.complex32 let complex64 = Bigarray.complex64 let int8_signed = Bigarray.int8_signed let int8_unsigned = Bigarray.int8_unsigned let int16_signed = Bigarray.int16_signed let int16_unsigned = Bigarray.int16_unsigned let int = Bigarray.int let int32 = Bigarray.int32 let int64 = Bigarray.int64 let nativeint = Bigarray.nativeint let char = Bigarray.char (* kind_size_in_bytes was introduced upstream in 4.03 *) ##V>=4.3##let kind_size_in_bytes = Bigarray.kind_size_in_bytes ##V=4.2##let kind_size_in_bytes : type a b. (a, b) kind -> int = function ##V<4.2##let kind_size_in_bytes (kind : (_, _) kind) : int = ##V<4.2## match untyped_kind_of_kind kind with ##V<=4.2##(* the clauses below are shared before 4.02 and at 4.02 *) ##V<=4.2## | Float32 -> 4 ##V<=4.2## | Float64 -> 8 ##V<=4.2## | Int8_signed -> 1 ##V<=4.2## | Int8_unsigned -> 1 ##V<=4.2## | Int16_signed -> 2 ##V<=4.2## | Int16_unsigned -> 2 ##V<=4.2## | Int32 -> 4 ##V<=4.2## | Int64 -> 8 ##V<=4.2## | Int -> Sys.word_size / 8 ##V<=4.2## | Nativeint -> Sys.word_size / 8 ##V<=4.2## | Complex32 -> 8 ##V<=4.2## | Complex64 -> 16 ##V<=4.2## | Char -> 1 let c_layout = Bigarray.c_layout let fortran_layout = Bigarray.fortran_layout ##V<4.2##let ofs_of_layout (layout : _ Bigarray.layout) = ##V<4.2## match (Obj.magic layout : int) with ##V<4.2## | 0 -> 0 ##V<4.2## | 0x100 -> 1 (* constants to be found in caml_ba_layout in bigarray.h *) ##V<4.2## | _ -> failwith "Unknown layout" ##V>=4.2##let ofs_of_layout : type a . a Bigarray.layout -> int = function ##V>=4.2## | Bigarray.C_layout -> 0 ##V>=4.2## | Bigarray.Fortran_layout -> 1 module Genarray = struct include Bigarray.Genarray ##V>=4.8##let map_file = Unix.map_file let ofs e = ofs_of_layout (layout e) ##V<4.3## let size_in_bytes arr = ##V<4.3## (kind_size_in_bytes (kind arr)) * (Array.fold_left ( * ) 1 (dims arr)) (** Emulate multi-dimensional coordinates. @param index The index of the element. @param dims The dimensions of the array. @param coor A buffer in which to write the various coordinates *) (* let index_to_coor index ~dims ~coor = (* [| a; b; c; d |] 0 -> 0 0 0 0 1 -> 0 0 0 1 2 -> 0 0 0 2 3 -> 0 0 0 3 d -> 0 0 1 0 d+1->0 0 1 1 d+2->0 0 1 2 2*d->0 0 1 0 c*d->0 1 0 0 -> d' = index mod a * b * c * d c' = index mod a * b * c *) let product = ref 1 in for i = 0 to Array.length dims - 1 do indices.(i) <- done*) (** Determine the coordinates of the item following this one. @param coor Coordinates to increment. @param dims The set of coordinates of the array. @return [true] if everything happened correctly, [false] if we've passed the last element. *) let inplace_next ~ofs ~dims ~coor = let rec aux i = if i < 0 then false else let new_value = coor.(i) + 1 in if new_value = dims.(i) + ofs then (*Propagate carry*) begin coor.(i) <- ofs; aux (i - 1) end else begin coor.(i) <- new_value; true end in aux (Array.length dims - 1) let iter f e = let dims = dims e in let offset = ofs e in let coor = A.create (num_dims e) ~init:offset in f (get e coor); while inplace_next ~ofs:offset ~dims ~coor do f (get e coor) done let iteri f e = let dims = dims e in let offset = ofs e in let coor = A.create (num_dims e) ~init:offset in f (A.Cap.of_array coor) (get e coor); while inplace_next ~ofs:offset ~dims ~coor do f (A.Cap.of_array coor) (get e coor) done let modify f e = let dims = dims e in let offset = ofs e in let change c = set e c (f (get e c)) in let coor = A.create (num_dims e) ~init:offset in change coor; while inplace_next ~ofs:offset ~dims ~coor do change coor done let modifyi f e = let dims = dims e in let offset = ofs e in let change c = set e c (f (A.Cap.of_array c) (get e c)) in let coor = A.create (num_dims e) ~init:offset in change coor; while inplace_next ~ofs:offset ~dims ~coor do change coor done let enum e = let dims = dims e and offset = ofs e in let coor = A.create (num_dims e) ~init:offset and status = ref `ongoing in BatEnum.from (fun () -> match !status with | `ongoing -> begin try let result = get e coor in let update = inplace_next ~ofs:offset ~dims ~coor in if not update then status := `dry; result with _ -> status := `dry; raise BatEnum.No_more_elements end | `dry -> raise BatEnum.No_more_elements ) let map f b_kind a = let d = dims a in let b = create b_kind (layout a) d in iteri (fun i x -> set b (A.Cap.to_array i) (f x)) a; b let mapi f b_kind a = let d = dims a in let b = create b_kind (layout a) d in iteri (fun i x -> set b (A.Cap.to_array i) (f (A.Cap.read_only i) x)) a; b end ##V>=4.5##external genarray_of_array0: ('a, 'b, 'c) Bigarray.Array0.t -> ('a, 'b, 'c) Genarray.t ##V>=4.5## = "%identity" external genarray_of_array1: ('a, 'b, 'c) Bigarray.Array1.t -> ('a, 'b, 'c) Genarray.t = "%identity" external genarray_of_array2: ('a, 'b, 'c) Bigarray.Array2.t -> ('a, 'b, 'c) Genarray.t = "%identity" external genarray_of_array3: ('a, 'b, 'c) Bigarray.Array3.t -> ('a, 'b, 'c) Genarray.t = "%identity" external reshape: ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t = "caml_ba_reshape" let reshape_3 = Bigarray.reshape_3 let reshape_2 = Bigarray.reshape_2 let reshape_1 = Bigarray.reshape_1 ##V>=4.5##let reshape_0 = Bigarray.reshape_0 let array3_of_genarray = Bigarray.array3_of_genarray let array2_of_genarray = Bigarray.array2_of_genarray let array1_of_genarray = Bigarray.array1_of_genarray ##V>=4.5##let array0_of_genarray = Bigarray.array0_of_genarray ##V>=4.5##module Array0 = struct ##V>=4.5## include Bigarray.Array0 ##V>=4.5##end module Array1 = struct include Bigarray.Array1 ##V>=4.8##let map_file fd ?pos kind layout shared dim = ##V>=4.8## Bigarray.array1_of_genarray ##V>=4.8## (Unix.map_file fd ?pos kind layout shared [|dim|]) let ofs e = ofs_of_layout (layout e) ##V<4.3## let size_in_bytes arr = ##V<4.3## (kind_size_in_bytes (kind arr)) * (dim arr) let enum t = let offset = ofs t in BatEnum.init (dim t) (fun i -> t.{offset + i}) let of_enum kind layout enum = let b_dim = BatEnum.count enum in let b = create kind layout b_dim in for i = ofs b to ofs b + b_dim - 1 do b.{i} <- BatEnum.get_exn enum done; b (*$Q Q.string (fun s -> s = String.of_enum (Array1.enum \ (Array1.of_enum char c_layout (String.enum s)))) Q.string (fun s -> s = String.of_enum (Array1.enum \ (Array1.of_enum char fortran_layout (String.enum s)))) (Q.list Q.int) (fun li -> li = List.of_enum (Array1.enum \ (Array1.of_enum int c_layout (List.enum li)))) *) let map f b_kind a = let b_dim = dim a in let b = create b_kind (layout a) b_dim in for i = ofs a to ofs a + b_dim - 1 do b.{i} <- f a.{i} done; b let mapi f b_kind a = let b_dim = dim a in let b = create b_kind (layout a) b_dim in for i = ofs a to ofs a + b_dim - 1 do b.{i} <- f i a.{i} done; b let modify f a = for i = ofs a to ofs a + dim a - 1 do unsafe_set a i (f (unsafe_get a i)) done let modifyi f a = for i = ofs a to ofs a + dim a - 1 do unsafe_set a i (f i (unsafe_get a i)) done let to_array a = Array.init (dim a) (fun i -> a.{i+(ofs a)}) end module Array2 = struct include Bigarray.Array2 ##V>=4.8##let map_file fd ?pos kind layout shared dim1 dim2 = ##V>=4.8## Bigarray.array2_of_genarray ##V>=4.8## (Unix.map_file fd ?pos kind layout shared [|dim1; dim2|]) let ofs e = ofs_of_layout (layout e) ##V<4.3## let size_in_bytes arr = ##V<4.3## (kind_size_in_bytes (kind arr)) * (dim1 arr) * (dim2 arr) let enum t = Genarray.enum (genarray_of_array2 t) let map f b_kind a = let b_dim1 = dim1 a in let b_dim2 = dim2 a in let b = create b_kind (layout a) b_dim1 b_dim2 in for i = ofs a to ofs a + b_dim1 - 1 do for j = ofs a to ofs a + b_dim2 - 1 do b.{i, j} <- f a.{i, j} done done; b let mapij f b_kind a = let b_dim1 = dim1 a in let b_dim2 = dim2 a in let b = create b_kind (layout a) b_dim1 b_dim2 in for i = ofs a to ofs a + b_dim1 - 1 do for j = ofs a to ofs a + b_dim2 - 1 do b.{i, j} <- f i j a.{i, j} done done; b let modify f a = for i = ofs a to ofs a + dim1 a - 1 do for j = ofs a to ofs a + dim2 a - 1 do unsafe_set a i j (f (unsafe_get a i j)) done done let modifyij f a = for i = ofs a to ofs a + dim1 a - 1 do for j = ofs a to ofs a + dim2 a - 1 do unsafe_set a i j (f i j (unsafe_get a i j)) done done let to_array a = Array.init (dim1 a) ( fun i -> Array.init (dim2 a) ( fun j -> a.{i + ofs a, j + ofs a} ) ) end module Array3 = struct include Bigarray.Array3 ##V>=4.8##let map_file fd ?pos kind layout shared dim1 dim2 dim3 = ##V>=4.8## Bigarray.array3_of_genarray ##V>=4.8## (Unix.map_file fd ?pos kind layout shared [|dim1; dim2; dim3|]) let ofs e = ofs_of_layout (layout e) ##V<4.3## let size_in_bytes arr = ##V<4.3## (kind_size_in_bytes (kind arr)) * (dim1 arr) * (dim2 arr) * (dim3 arr) let enum t = Genarray.enum (genarray_of_array3 t) let map f b_kind a = let b_dim1 = dim1 a in let b_dim2 = dim2 a in let b_dim3 = dim3 a in let b = create b_kind (layout a) b_dim1 b_dim2 b_dim3 in for i = 0 to b_dim1 - 1 do for j = 0 to b_dim2 - 1 do for k = 0 to b_dim3 - 1 do b.{i, j, k} <- f a.{i, j, k} done done done; b let mapijk f b_kind a = let b_dim1 = dim1 a in let b_dim2 = dim2 a in let b_dim3 = dim3 a in let b = create b_kind (layout a) b_dim1 b_dim2 b_dim3 in for i = 0 to b_dim1 - 1 do for j = 0 to b_dim2 - 1 do for k = 0 to b_dim3 - 1 do b.{i, j, k} <- f i j k a.{i, j, k} done done done; b let modify f a = for i = ofs a to ofs a + dim1 a - 1 do for j = ofs a to ofs a + dim2 a - 1 do for k = ofs a to ofs a + dim3 a - 1 do unsafe_set a i j k (f (unsafe_get a i j k)) done done done let modifyijk f a = for i = ofs a to ofs a + dim1 a - 1 do for j = ofs a to ofs a + dim2 a - 1 do for k = ofs a to ofs a + dim3 a - 1 do unsafe_set a i j k (f i j k (unsafe_get a i j k)) done done done let to_array a = Array.init (dim1 a) ( fun i -> Array.init (dim2 a) ( fun j -> Array.init (dim3 a) ( fun k -> a.{i, j, k} ) ) ) end (*$R let a = Genarray.create int c_layout [|2;3;4;5;6|] in let n_elt = 2 * 3 * 4 * 5 * 6 in let value_index = function | [|i1; i2; i3; i4; i5|] -> i1+2*(i2+3*(i3+4*(i4+5*i5))) | _ -> assert false in let value_index2 : (int, [`Read]) BatArray.Cap.t -> int = fun a -> value_index (Obj.magic a) in for i1 = 0 to 2 - 1 do for i2 = 0 to 3 - 1 do for i3 = 0 to 4 - 1 do for i4 = 0 to 5 - 1 do for i5 = 0 to 6 - 1 do let index = [|i1;i2;i3;i4;i5|] in Genarray.set a index (value_index index) done done done done done; let total = n_elt * (n_elt - 1) / 2 in let sum = ref 0 in Genarray.iter (fun i -> sum := !sum + i) a; assert_equal !sum total; sum := 0; Genarray.iteri (fun index i -> assert_equal i (value_index2 index); sum := !sum + i ) a; assert_equal !sum total; Genarray.modify (fun i -> i + 1) a; Genarray.iteri (fun index i -> assert_equal (value_index2 index + 1) i) a; Genarray.modifyi (fun index i -> i - 1 + value_index2 index) a; Genarray.iteri (fun index i -> assert_equal (2 * value_index2 index) i) a; let a2 = Genarray.map (fun i -> i / 2) int a in Genarray.iteri (fun index i -> assert_equal (2 * value_index2 index) i) a; Genarray.iteri (fun index i -> assert_equal (value_index2 index) i) a2; let a3 = Genarray.mapi (fun index i -> value_index2 index - i) int a2 in Genarray.iteri (fun index i -> assert_equal (value_index2 index) i) a2; Genarray.iter (fun i -> assert_equal 0 i) a3 *) (*$R let a = Array1.create int c_layout 6 in let n_elt = 6 in let value_index n = n + 1 in for i1 = 0 to 6 - 1 do Array1.set a i1 (value_index i1) done; let iteri f a = for i = 0 to n_elt - 1 do f i a.{i} done in Array1.modify (fun i -> i + 1) a; iteri (fun index i -> assert_equal (value_index index + 1) i) a; Array1.modifyi (fun index i -> i - 1 + value_index index) a; iteri (fun index i -> assert_equal (2 * value_index index) i) a; let a2 = Array1.map (fun i -> i / 2) int a in iteri (fun index i -> assert_equal (2 * value_index index) i) a; iteri (fun index i -> assert_equal (value_index index) i) a2; let a3 = Array1.mapi (fun index i -> value_index index - i) int a2 in iteri (fun index i -> assert_equal (value_index index) i) a2; iteri (fun _ i -> assert_equal 0 i) a3 *) (*$R let a = Array2.create int c_layout 5 6 in let value_index i j = i * 5 + j in let iterij f a = for i = 0 to 5 - 1 do for j = 0 to 6 - 1 do f i j a.{i,j} done done in iterij (fun i j _undef -> a.{i,j} <- value_index i j) a; Array2.modify (fun i -> i + 1) a; iterij (fun i j elt -> assert_equal (value_index i j + 1) elt) a; Array2.modifyij (fun i j elt -> elt - 1 + value_index i j) a; iterij (fun i j elt -> assert_equal (2 * value_index i j) elt) a; let a2 = Array2.map (fun elt -> elt / 2) int a in iterij (fun i j elt -> assert_equal (2 * value_index i j) elt) a; iterij (fun i j elt -> assert_equal (value_index i j) elt) a2; let a3 = Array2.mapij (fun i j elt -> value_index i j - elt) int a2 in iterij (fun i j elt -> assert_equal (value_index i j) elt) a2; iterij (fun _ _ elt -> assert_equal 0 elt) a3 *) (*$R let a = Array3.create int c_layout 4 5 6 in let value_index i j k = i + 4 * (j + 5 * k) in let iterijk f a = for i = 0 to 4 - 1 do for j = 0 to 5 - 1 do for k = 0 to 6 - 1 do f i j k a.{i,j,k} done done done in iterijk (fun i j k _undef -> a.{i,j,k} <- value_index i j k) a; Array3.modify (fun i -> i + 1) a; iterijk (fun i j k elt -> assert_equal (value_index i j k + 1) elt) a; Array3.modifyijk (fun i j k elt -> elt - 1 + value_index i j k) a; iterijk (fun i j k elt -> assert_equal (2 * value_index i j k) elt) a; let a2 = Array3.map (fun elt -> elt / 2) int a in iterijk (fun i j k elt -> assert_equal (2 * value_index i j k) elt) a; iterijk (fun i j k elt -> assert_equal (value_index i j k) elt) a2; let a3 = Array3.mapijk (fun i j k elt -> value_index i j k - elt) int a2 in iterijk (fun i j k elt -> assert_equal (value_index i j k) elt) a2; iterijk (fun _ _ _ elt -> assert_equal 0 elt) a3 *) batteries-included-3.4.0/src/batBitSet.ml000066400000000000000000000216211415601150500202670ustar00rootroot00000000000000(* * Bitset - Efficient bit sets * Copyright (C) 2003 Nicolas Cannasse * Copyright (C) 2009 David Teller, LIFO, Universite d'Orleans * Copyright (C) 2012 Sylvain Le Gall * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type t = Bytes.t ref let print_array = let buf = Buffer.create 8 in let print_bchar c = let rc = ref c in Buffer.clear buf; for _i = 1 to 8 do Buffer.add_char buf (if !rc land 1 == 1 then '1' else '0'); rc := !rc lsr 1 done; Buffer.contents buf in Array.init 256 print_bchar let print out t = let buf = !t in for i = 0 to (Bytes.length buf) - 1 do BatInnerIO.nwrite out (Array.unsafe_get print_array (Char.code (Bytes.unsafe_get buf i))) done let capacity t = (Bytes.length !t) * 8 let empty () = ref (Bytes.create 0) let create_ sfun c n = (* n is in bits *) if n < 0 then invalid_arg ("BitSet." ^ sfun ^ ": negative size"); let size = n / 8 + (if n mod 8 = 0 then 0 else 1) in ref (Bytes.make size c) let create = create_ "create" '\000' let copy t = ref (Bytes.copy !t) let extend t n = (* len in bits *) if n > capacity t then let t' = create n in Bytes.blit !t 0 !t' 0 (Bytes.length !t); t := !t' type bit_op = | Set | Unset | Toggle let rec apply_bit_op sfun op t x = let pos = x / 8 in if pos < 0 then invalid_arg ("BitSet." ^ sfun ^ ": negative index") else if pos < Bytes.length !t then let delta = x mod 8 in let c = Char.code (Bytes.unsafe_get !t pos) in let mask = 1 lsl delta in let v = (c land mask) <> 0 in let bset c = Bytes.unsafe_set !t pos (Char.unsafe_chr c) in match op with | Set -> if not v then bset (c lor mask) | Unset -> if v then bset (c lxor mask) (* TODO: shrink *) | Toggle -> bset (c lxor mask); else match op with | Set | Toggle -> extend t (x+1); apply_bit_op sfun op t x | Unset -> () let set t x = apply_bit_op "set" Set t x let unset t x = apply_bit_op "unset" Unset t x let toggle t x = apply_bit_op "toggle" Toggle t x let mem t x = let pos = x / 8 in if pos < 0 then invalid_arg "BitSet.mem: negative index" else if pos < Bytes.length !t then let delta = x mod 8 in let c = Char.code (Bytes.unsafe_get !t pos) in (c land (1 lsl delta)) <> 0 else false let add x t = let dup = copy t in set dup x; dup let remove x t = let dup = copy t in unset dup x; dup (*$T let b = empty() in ignore(add 1 b); count b = 0 let b = empty() in count(add 1 b) = 1 let b = create_full 5 in ignore(remove 1 b); count b = 5 let b = create_full 5 in count(remove 1 b) = 4 *) let put t = function | true -> set t | false -> unset t let create_full n = let t = create_ "create_full" '\255' n in (* Fix the tail *) for i = n to (capacity t) - 1 do unset t i done; t (*$Q Q.small_int (fun n -> count (create_full n) = n) *) let compare t1 t2 = let len1 = Bytes.length !t1 in let len2 = Bytes.length !t2 in if len1 = len2 then Bytes.compare !t1 !t2 else let diff = ref 0 in let idx = ref 0 in let clen = min len1 len2 in while !diff = 0 && !idx < clen do diff := Char.compare (Bytes.unsafe_get !t1 !idx) (Bytes.unsafe_get !t2 !idx); incr idx done; if len1 < len2 then while !diff = 0 && !idx < len2 do diff := Char.compare '\000' (Bytes.unsafe_get !t2 !idx); incr idx done else while !diff = 0 && !idx < len1 do diff := Char.compare (Bytes.unsafe_get !t1 !idx) '\000'; incr idx done; !diff (*$T compare (of_list [1;2]) (of_list [1]) > 0 *) let equal t1 t2 = compare t1 t2 = 0 let ord = BatOrd.ord compare (*$Q (Q.pair (Q.list Q.small_int) (Q.list Q.small_int)) (fun (l1,l2) -> \ let of_list' l = of_list (List.map abs l) in \ let b1 = of_list' l1 and b2 = of_list' l2 in \ ord b1 b2 = BatOrd.rev_ord0 (ord b2 b1)) *) (* Array that return the count of bits for a char *) let count_array = let rec count_bits i = if i = 0 then 0 else (count_bits (i / 2)) + (i mod 2) in Array.init 256 count_bits let count t = let c = ref 0 in for i = 0 to (Bytes.length !t) - 1 do c := !c + Array.unsafe_get count_array (Char.code (Bytes.unsafe_get !t i)) done; !c (* Array of array that given a char and a delta return the delta of the next * set bit. *) let next_set_bit_array = let eighth_bit = 1 lsl 7 in let mk c = let arr = Array.make 8 ~-1 in let rec mk' last_set_bit i v = if i >= 0 then let last_set_bit = if v land eighth_bit <> 0 then i else last_set_bit in arr.(i) <- last_set_bit; mk' last_set_bit (i - 1) (v lsl 1) in mk' ~-1 7 c; arr in Array.init 256 mk (* DEBUG bit arrays. let () = Array.iteri (fun idx arr -> let buf = Buffer.create 8 in for i = 0 to 7 do let c = if (idx land (1 lsl (7 - i))) = 0 then '0' else '1' in Buffer.add_char buf c done; Buffer.add_string buf ": "; for i = 0 to 7 do Buffer.add_string buf (Printf.sprintf "%d -> %d; " i arr.(i)) done; Buffer.add_char buf '\n'; Buffer.output_buffer stderr buf) next_set_bit_array; flush stderr *) (* Find the first set bit in the bit array *) let rec next_set_bit t x = if x < 0 then invalid_arg "BitSet.next_set_bit" else let pos = x / 8 in if pos < Bytes.length !t then begin let delta = x mod 8 in let c = Char.code (Bytes.unsafe_get !t pos) in let delta_next = Array.unsafe_get (Array.unsafe_get next_set_bit_array c) delta in if delta_next < 0 then next_set_bit t ((pos + 1) * 8) else Some (pos * 8 + delta_next) end else begin None end let enum t = let rec make n cnt = let cur = ref n in let cnt = ref cnt in let next () = match next_set_bit t !cur with Some elem -> decr cnt; cur := (elem+1); elem | None -> raise BatEnum.No_more_elements in BatEnum.make ~next ~count:(fun () -> !cnt) ~clone:(fun () -> make !cur !cnt) in make 0 (count t) (*$T BitSet.of_list [5;3;2;1] |> BitSet.enum |> Enum.skip 1 |> Enum.count = 3 let e = BitSet.of_list [5;3;2;1] |> enum in \ Enum.junk e; Enum.iter (fun _ -> ()) (Enum.clone e); (Enum.count e = 3) *) (*$Q (Q.list Q.small_int) (fun l -> \ let b = BitSet.of_list (List.map abs l) in \ b |> BitSet.enum |> BitSet.of_enum |> equal b) *) let of_enum ?(cap=128) e = let bs = create cap in BatEnum.iter (set bs) e; bs let of_list ?(cap=128) lst = let bs = create cap in List.iter (set bs) lst; bs type set_op = | Inter | Diff | Unite | DiffSym let apply_set_op op t1 t2 = let idx = ref 0 in let len1 = Bytes.length !t1 in let len2 = Bytes.length !t2 in let clen = min len1 len2 in while !idx < clen do let c1 = Char.code (Bytes.unsafe_get !t1 !idx) in let c2 = Char.code (Bytes.unsafe_get !t2 !idx) in let cr = match op with | Inter -> c1 land c2 | Diff -> c1 land (lnot c2) | Unite -> c1 lor c2 | DiffSym -> c1 lxor c2 in Bytes.unsafe_set !t1 !idx (Char.unsafe_chr cr); incr idx done; if op = Unite && len1 < len2 then begin extend t1 (len2 * 8); Bytes.blit !t2 len1 !t1 len1 (len2 - len1) end else if op = DiffSym && len1 < len2 then begin let tmp = Bytes.copy !t2 in Bytes.blit !t1 0 tmp 0 len1; t1 := tmp end let intersect t1 t2 = apply_set_op Inter t1 t2 let differentiate t1 t2 = apply_set_op Diff t1 t2 let unite t1 t2 = apply_set_op Unite t1 t2 let differentiate_sym t1 t2 = apply_set_op DiffSym t1 t2 let biop_with_copy f a b = let a' = copy a in f a' b; a' let inter a b = biop_with_copy intersect a b let union a b = biop_with_copy unite a b let diff a b = biop_with_copy differentiate a b let sym_diff a b = biop_with_copy differentiate_sym a b batteries-included-3.4.0/src/batBitSet.mli000066400000000000000000000147661415601150500204540ustar00rootroot00000000000000(* * Bitset - Efficient bit sets * Copyright (C) 2003 Nicolas Cannasse * Copyright (C) 2008 David Teller * Copyright (C) 2012 Sylvain Le Gall * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Efficient bit sets. A bitset is an array of boolean values that can be accessed with indexes like an array but provides a better memory usage (divided by Sys.word_size; either 32 or 64) for a very small speed trade-off. It can provide efficient storage of dense sets of nonnegative integers near zero. Sparse sets should use {!BatSet}, sets with large ranges of contiguous ints should use {!BatISet}. @author Nicolas Cannasse @author David Teller (Boilerplate code) *) type t val empty : unit -> t (** Create an empty bitset of capacity 0, the bitset will automatically expand when needed. Example: [BitSet.empty ()] *) val create : int -> t (** Create an empty bitset with at least an initial capacity (in number of bits). Example: [BitSet.create 0 = BitSet.empty ()] @raise Invalid_argument on negative capacity *) val create_full : int -> t (** Create a full bitset with at least initial capacity (in number of bits). All the bit under the defined capacity will be set. Example: [BitSet.count (BitSet.create_full n) = n] @raise Invalid_argument on negative capacity *) val copy : t -> t (** Copy a bitset : further modifications of first one will not affect the copy. Example: [ let a = Bitset.create 8 in let b = BitSet.copy a in BitSet.set a 6; BitSet.mem a 6 && not (BitSet.mem b 6)] *) val mem : t -> int -> bool (** [mem s n] returns true if nth-bit in the bitset [s] is set, or false otherwise. Example: [let a = BitSet.create_full 256 in not (BitSet.mem a 300)] @raise Invalid_argument on negative index ([n < 0]) *) val count : t -> int (** [count s] returns the number of bits set in the bitset [s]. Also known as Population Count, or [cardinal] for sets. Example: [BitSet.count (BitSet.of_list [6;4;2;2;1]) = 4] *) val next_set_bit : t -> int -> int option (** [next_set_bit s n] returns [Some m] when [m] is the next set element with index greater than or equal [n], or None if no such element exists (i.e. [n] is greater than the largest element) More efficient than scanning with repeated [BitSet.mem]. @raise Invalid_argument on negative index ([n < 0]) *) (** {6 In-place Update} *) (** These functions modify an existing bitset. *) val set : t -> int -> unit (** [set s n] sets the [n]th-bit in the bitset [s] to true. @raise Invalid_argument on negative index ([n < 0]) *) val unset : t -> int -> unit (** [unset s n] sets the [n]th-bit in the bitset [s] to false. @raise Invalid_argument on negative index ([n < 0]) *) val put : t -> bool -> int -> unit (** [put s v n] sets the nth-bit in the bitset [s] to [v]. @raise Invalid_argument on negative index ([n < 0]) *) val toggle : t -> int -> unit (** [toggle s n] changes the nth-bit value in the bitset [s]. @raise Invalid_argument on negative index ([n < 0]) *) val intersect : t -> t -> unit (** [intersect s t] sets [s] to the intersection of the sets [s] and [t]. *) val unite : t -> t -> unit (** [unite s t] sets [s] to the union of the sets [s] and [t]. *) val differentiate : t -> t -> unit (** [differentiate s t] removes the elements of [t] from [s]. *) val differentiate_sym : t -> t -> unit (** [differentiate_sym s t] sets [s] to the symmetrical difference of the sets [s] and [t]. *) (** {6 Return new bitset} *) (** These functions return a new bitset that shares nothing with the input bitset. This is not as efficient as the in-place update. *) val add : int -> t -> t (** [add n s] returns a copy of [s] with bit [n] true. @raise Invalid_argument on negative index ([n < 0]) *) val remove : int -> t -> t (** [remove n s] returns a copy of [s] with bit [n] false. @raise Invalid_argument on negative index ([n < 0]) *) val inter : t -> t -> t (** [inter s t] returns the intersection of sets [s] and [t]. *) val union : t -> t -> t (** [union s t] return the union of sets [s] and [t]. *) val diff : t -> t -> t (** [diff s t] returns [s]-[t]. *) val sym_diff : t -> t -> t (** [sym_diff s t] returns the symmetrical difference of [s] and [t]. *) (** {6 Boilerplate code}*) val print: 'a BatInnerIO.output -> t -> unit (* Print the given BitSet to the given output channel. This function prints a BitSet as a boolean vector, and pads to a multiple of 8 bits with zeros. Thus, the bitset containing only 1 and 3 is printed as ["01010000"]. *) val enum : t -> int BatEnum.t (** [enum s] returns an enumeration of bits which are set in the bitset [s]. *) val of_enum : ?cap:int -> int BatEnum.t -> t (** [of_enum ~cap e] builds a bitset of capacity [cap] an enumeration of ints [e]. Note: Performance of this function may be poor if enumeration is in increasing order and the max. *) val of_list : ?cap:int -> int list -> t (** As [of_enum], but from a list *) val compare : t -> t -> int (** [compare s1 s2] compares two bitsets using a lexicographic ordering. Highest bit indexes are compared first. The capacity of the bitsets is not important for this comparison, only the bits starting with the highest set bit and going down. *) val equal : t -> t -> bool (** [equal s1 s2] returns true if, and only if, all bits values in s1 are the same as in s2. *) val ord : t -> t -> BatOrd.order (** [ord s1 s2] returns [BatOrd.Lt], [BatOrd.Eq] or [BatOrd.Gt] if [compare s1 s2] is, respectively, [< 0], [0] or [> 0]. *) (** {6 Internals} *) val capacity : t -> int (** [capacity s] returns the number of bits, both set and unset, stored in [s]. This is guaranteed to be larger than the largest element (set bit index) in [s]. *) batteries-included-3.4.0/src/batBool.ml000066400000000000000000000064171415601150500177760ustar00rootroot00000000000000(* * BatBool - Extended booleans * Copyright (C) 2007 Bluestorm * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module BaseBool : BatNumber.NUMERIC_BASE with type t = bool = struct type t = bool external not : bool -> bool = "%boolnot" (** The boolean negation. *) external ( && ) : bool -> bool -> bool = "%sequand" (** The boolean ``and''. Evaluation is sequential, left-to-right: in [e1 && e2], [e1] is evaluated first, and if it returns [false], [e2] is not evaluated at all. *) external ( || ) : bool -> bool -> bool = "%sequor" (** The boolean ``or''. Evaluation is sequential, left-to-right: in [e1 || e2], [e1] is evaluated first, and if it returns [true], [e2] is not evaluated at all. *) let zero, one = false, true let neg = not let succ _ = true let pred _ = false let abs x = x let add = ( || ) let mul = ( && ) let sub _ = not (*Weird extrapolation*) let div _ _= invalid_arg "Bool.div" let modulo _ _ = invalid_arg "Bool.modulo" let pow _ _ = invalid_arg "Bool.pow" let compare = compare let of_int = function | 0 -> false | _ -> true let to_int = function | false -> 0 | true -> 1 let of_float x = of_int (int_of_float x) let to_float x = float_of_int (to_int x) let of_string = function | "true" | "tt" | "1" -> true | "false"| "ff" | "0" -> false | _ -> invalid_arg "Bool.of_string" let to_string = string_of_bool end include BatNumber.MakeNumeric(BaseBool) (*$T succ succ true = true succ false = true *) (*$T pred pred true = false pred false = false *) (*$T abs abs true = true abs false = false *) (*$T sub sub true true = false sub true false = true sub false true = false sub false false = true *) (*$Q of_int (Q.int) (fun i -> (of_int i) = (Int.(<>) i 0)) *) (*$T of_int of_int 0 = false *) (*$T of_float (-1.) = true of_float 0. = false of_float nan = false to_float true = 1. to_float false = 0. of_string "true" = true of_string "false" = false try ignore (of_string "smurf"); false with Invalid_argument _ -> true *) external not : bool -> bool = "%boolnot" external ( && ) : bool -> bool -> bool = "%sequand" external ( || ) : bool -> bool -> bool = "%sequor" type bounded = t let min_num, max_num = false, true let print out t = BatInnerIO.nwrite out (to_string t) (*$T BatIO.to_string print true = "true" BatIO.to_string print false = "false" *) batteries-included-3.4.0/src/batBool.mli000066400000000000000000000063461415601150500201500ustar00rootroot00000000000000(* * BatBool - Extended booleans * Copyright (C) 2007 Bluestorm * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Operations on booleans @author Gabriel Scherer @author David Teller *) type t = bool (**The type of booleans. Formally, this is defined as [type t = true | false] *) external not : bool -> bool = "%boolnot" (** The boolean negation. *) external ( && ) : bool -> bool -> bool = "%sequand" (** The boolean ``and''. Evaluation is sequential, left-to-right: in [e1 && e2], [e1] is evaluated first, and if it returns [false], [e2] is not evaluated at all. *) external ( || ) : bool -> bool -> bool = "%sequor" (** The boolean ``or''. Evaluation is sequential, left-to-right: in [e1 || e2], [e1] is evaluated first, and if it returns [true], [e2] is not evaluated at all. *) val zero : bool val one : bool val neg : bool -> bool val succ : bool -> bool val pred : bool -> bool val abs : bool -> bool val add : bool -> bool -> bool val mul : bool -> bool -> bool val sub : bool -> bool -> bool val div : t -> t -> t val modulo : t -> t -> t val pow : t -> t -> t val min_num : bool val max_num : bool val compare : bool -> bool -> int val equal : bool -> bool -> bool val ord : bool -> bool -> BatOrd.order val of_int : int -> bool (** anything but [0] is [true] *) val to_int : bool -> int val of_string : string -> bool (** Convert the given string to a boolean. @raise Invalid_argument if the string is not ["true"], ["false"], ["0"], ["1"], ["tt"] or ["ff"]. *) val to_string : bool -> string val of_float : float -> bool (** [0.], [nan] [+infinity] and [-infiity] are [false]. The other values convert to [true] *) val to_float : bool -> float val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t val ( ** ) : t -> t -> t (* Available only in `Compare` submodule val ( <> ) : t -> t -> bool val ( >= ) : t -> t -> bool val ( <= ) : t -> t -> bool val ( > ) : t -> t -> bool val ( < ) : t -> t -> bool val ( = ) : t -> t -> bool *) val ( -- ): t -> t -> t BatEnum.t val ( --- ): t -> t -> t BatEnum.t val operations : t BatNumber.numeric include BatNumber.Bounded (** {6 Submodules grouping all infix operators} *) module Infix : BatNumber.Infix with type bat__infix_t = t module Compare : BatNumber.Compare with type bat__compare_t = t (** {6 Boilerplate code}*) (** {7 Printing}*) val print: 'a BatInnerIO.output -> t -> unit batteries-included-3.4.0/src/batBounded.ml000066400000000000000000000217701415601150500204620ustar00rootroot00000000000000module O = BatOrd exception Invalid_bounds type 'a bound_t = [ `o of 'a | `c of 'a | `u] type ('a, 'b) bounding_f = bounds:('a bound_t * 'a bound_t) -> 'a -> 'b let ret_some x = Some x let ret_none _ = None let const a _ = a external identity : 'a -> 'a = "%identity" let bounding_of_ord ~default_low ~default_high conv ord = fun ~(bounds : 'a bound_t * 'a bound_t) -> match bounds with | `c l, `c u -> begin if ord l u = O.Gt then raise Invalid_bounds; fun x -> match ord x l, ord x u with | O.Lt, _ -> default_low | _, O.Gt -> default_high | O.Eq, _ | _, O.Eq | O.Gt, _ -> conv x end | `u, `c u -> begin fun x -> match ord x u with | O.Gt -> default_high | O.Eq | O.Lt -> conv x end | `c l, `u -> begin fun x -> match ord x l with | O.Lt -> default_low | O.Gt | O.Eq -> conv x end | `u, `u -> conv | `o l, `o u -> begin if ord l u = O.Gt then raise Invalid_bounds; fun x -> match ord x l, ord x u with | O.Lt, _ | O.Eq, _ -> default_low | _, O.Gt | _, O.Eq -> default_high | O.Gt, _ -> conv x end | `u, `o u -> begin fun x -> match ord x u with | O.Gt | O.Eq -> default_high | O.Lt -> conv x end | `o l, `u -> begin fun x -> match ord x l with | O.Lt | O.Eq -> default_low | O.Gt -> conv x end | `c l, `o u -> begin if ord l u = O.Gt then raise Invalid_bounds; fun x -> match ord x l, ord x u with | O.Lt, _ -> default_low | _, O.Gt | _, O.Eq -> default_high | O.Eq, _ | O.Gt, _ -> conv x end | `o l, `c u -> begin if ord l u = O.Gt then raise Invalid_bounds; fun x -> match ord x l, ord x u with | O.Lt, _ | O.Eq, _ -> default_low | _, O.Gt -> default_high | _, O.Eq | O.Gt, _ -> conv x end (*$T bounding_of_ord bounding_of_ord ~default_low:None ~default_high:None (fun x -> Some x) BatInt.ord ~bounds:(`u, `u) 0 = Some 0 bounding_of_ord ~default_low:None ~default_high:None (fun x -> Some x) BatInt.ord ~bounds:(`c 0, `u) 0 = Some 0 bounding_of_ord ~default_low:None ~default_high:None (fun x -> Some x) BatInt.ord ~bounds:(`o 0, `u) 0 = None bounding_of_ord ~default_low:None ~default_high:None (fun x -> Some x) BatInt.ord ~bounds:(`u, `c 0) 0 = Some 0 bounding_of_ord ~default_low:None ~default_high:None (fun x -> Some x) BatInt.ord ~bounds:(`u, `o 0) 0 = None bounding_of_ord ~default_low:(Some ~-10) ~default_high:(Some 10) (fun x -> Some x) BatInt.ord ~bounds:(`u, `u) 0 = Some 0 bounding_of_ord ~default_low:(Some ~-10) ~default_high:(Some 10) (fun x -> Some x) BatInt.ord ~bounds:(`c 0, `u) 0 = Some 0 bounding_of_ord ~default_low:(Some ~-10) ~default_high:(Some 10) (fun x -> Some x) BatInt.ord ~bounds:(`o 0, `u) 0 = Some ~-10 bounding_of_ord ~default_low:(Some ~-10) ~default_high:(Some 10) (fun x -> Some x) BatInt.ord ~bounds:(`u, `c 0) 0 = Some 0 bounding_of_ord ~default_low:(Some ~-10) ~default_high:(Some 10) (fun x -> Some x) BatInt.ord ~bounds:(`u, `o 0) 0 = Some 10 *) let bounding_of_ord_chain ~low ~high conv ord = fun ~(bounds : 'a bound_t * 'a bound_t) -> match bounds with (* Closed bounds (inclusive) *) | `c l, `c u -> begin if ord l u = O.Gt then raise Invalid_bounds; fun x -> match ord x l, ord x u with | O.Lt, _ -> low x | _, O.Gt -> high x | O.Eq, _ | _, O.Eq | O.Gt, _ -> conv x end | `u, `c u -> begin fun x -> match ord x u with | O.Gt -> high x | O.Eq | O.Lt -> conv x end | `c l, `u -> begin fun x -> match ord x l with | O.Lt -> low x | O.Gt | O.Eq -> conv x end (* Open bounds (exclusive) *) | `o l, `o u -> begin if ord l u = O.Gt then raise Invalid_bounds; fun x -> match ord x l, ord x u with | O.Lt, _ | O.Eq, _ -> low x | _, O.Gt | _, O.Eq -> high x | O.Gt, _ -> conv x end | `u, `o u -> begin fun x -> match ord x u with | O.Gt | O.Eq -> high x | O.Lt -> conv x end | `o l, `u -> begin fun x -> match ord x l with | O.Lt | O.Eq -> low x | O.Gt -> conv x end (* Mixed open and closed bounds *) | `c l, `o u -> begin if ord l u = O.Gt then raise Invalid_bounds; fun x -> match ord x l, ord x u with | O.Lt, _ -> low x | _, O.Gt | _, O.Eq -> high x | O.Eq, _ | O.Gt, _ -> conv x end | `o l, `c u -> begin if ord l u = O.Gt then raise Invalid_bounds; fun x -> match ord x l, ord x u with | O.Lt, _ | O.Eq, _ -> low x | _, O.Gt -> high x | _, O.Eq | O.Gt, _ -> conv x end | `u, `u -> conv (*$T bounding_of_ord_chain as f f (fun x -> Some x) BatInt.ord ~low:(const None) ~high:(const None) ~bounds:(`u, `u) 0 = Some 0 f (fun x -> Some x) BatInt.ord ~low:(const None) ~high:(const None) ~bounds:(`c 0, `u) 0 = Some 0 f (fun x -> Some x) BatInt.ord ~low:(const None) ~high:(const None) ~bounds:(`o 0, `u) 0 = None f (fun x -> Some x) BatInt.ord ~low:(const None) ~high:(const None) ~bounds:(`u, `c 0) 0 = Some 0 f (fun x -> Some x) BatInt.ord ~low:(const None) ~high:(const None) ~bounds:(`u, `o 0) 0 = None f (fun x -> Some x) ~low:(fun _x -> Some ~-10) ~high:(fun _x -> Some 10) BatInt.ord ~bounds:(`u, `u) 0 = Some 0 f (fun x -> Some x) ~low:(fun _x -> Some ~-10) ~high:(fun _x -> Some 10) BatInt.ord ~bounds:(`c 0, `u) 0 = Some 0 f (fun x -> Some x) ~low:(fun _x -> Some ~-10) ~high:(fun _x -> Some 10) BatInt.ord ~bounds:(`o 0, `u) 0 = Some ~-10 f (fun x -> Some x) ~low:(fun _x -> Some ~-10) ~high:(fun _x -> Some 10) BatInt.ord ~bounds:(`u, `c 0) 0 = Some 0 f (fun x -> Some x) ~low:(fun _x -> Some ~-10) ~high:(fun _x -> Some 10) BatInt.ord ~bounds:(`u, `o 0) 0 = Some 10 *) let saturate_of_ord ~(bounds : 'a bound_t * 'a bound_t) ord = match bounds with | `o l, `o h | `c l, `c h | `o l, `c h | `c l, `o h -> bounding_of_ord_chain ~low:(const l) ~high:(const h) identity ord ~bounds | `u, `o h | `u, `c h -> bounding_of_ord_chain ~low:identity ~high:(const h) identity ord ~bounds | `o l, `u | `c l, `u -> bounding_of_ord_chain ~low:(const l) ~high:identity identity ord ~bounds | `u, `u -> bounding_of_ord_chain ~low:identity ~high:identity identity ord ~bounds let opt_of_ord ~(bounds : 'a bound_t * 'a bound_t) ord = bounding_of_ord_chain ~low:ret_none ~high:ret_none ret_some ord ~bounds module type BoundedType = sig type base_t type t val bounds : base_t bound_t * base_t bound_t val bounded : (base_t, t) bounding_f val base_of_t : t -> base_t option val base_of_t_exn : t -> base_t end module type BoundedNumericType = sig include BoundedType module Infix : BatNumber.Infix with type bat__infix_t := base_t end module type S = sig type base_u type u type t = private u val bounds : base_u bound_t * base_u bound_t val make : base_u -> t external extract : t -> u = "%identity" val map : (base_u -> base_u) -> t -> t option val map2 : (base_u -> base_u -> base_u) -> t -> t -> t option val map_exn : (base_u -> base_u) -> t -> t val map2_exn : (base_u -> base_u -> base_u) -> t -> t -> t end module type NumericSig = sig include S val ( + ) : t -> base_u -> t val ( - ) : t -> base_u -> t val ( * ) : t -> base_u -> t val ( / ) : t -> base_u -> t val ( +: ) : t -> t -> t val ( -: ) : t -> t -> t val ( *: ) : t -> t -> t val ( /: ) : t -> t -> t end module Make(M : BoundedType) : ( S with type base_u = M.base_t with type u = M.t with type t = private M.t ) = struct include M type base_u = base_t type u = t let make = bounded ~bounds external extract : t -> u = "%identity" let map f x = BatOption.map make (BatOption.map f (base_of_t x)) let map2 f x y = match base_of_t x, base_of_t y with | Some bx, Some by -> Some (make (f bx by)) | None, Some _ | Some _, None | None, None -> None let map_exn f x = make (f (base_of_t_exn x)) let map2_exn f x y = let bx = base_of_t_exn x in let by = base_of_t_exn y in make (f bx by) end module MakeNumeric(M : BoundedNumericType) = struct include Make(M) module I = M.Infix let ( + ) a b = map_exn (I.( + ) b) a let ( - ) a b = map_exn (I.( - ) b) a let ( * ) a b = map_exn (I.( * ) b) a let ( / ) a b = map_exn (I.( / ) b) a let ( +: ) = map2_exn I.( + ) let ( -: ) = map2_exn I.( - ) let ( *: ) = map2_exn I.( * ) let ( /: ) = map2_exn I.( / ) end batteries-included-3.4.0/src/batBounded.mli000066400000000000000000000110721415601150500206250ustar00rootroot00000000000000(** Bounded values This module implements values which must fall within given bounds. @author Hezekiah M. Carty @since 2.0 *) type 'a bound_t = [ `o of 'a | `c of 'a | `u] (** [`o]pen or [`c]losed or [`u]nbounded bounds *) type ('a, 'b) bounding_f = bounds:('a bound_t * 'a bound_t) -> 'a -> 'b (** The type of a bounding function with limits specified by [bounds] *) val bounding_of_ord : default_low:'b -> default_high:'b -> ('a -> 'b) -> ('a -> 'a -> BatOrd.order) -> ('a, 'b) bounding_f (** [bounding_of_ord ~default_low ~default_high conv ord] will returning a bounding function using [ord] for value comparison and [default_low] and [default_high] for values which fall outside of the requested range. [conv] is used to convert values which are in-range to the result type. *) val bounding_of_ord_chain : low:('a -> 'b) -> high:('a -> 'b) -> ('a -> 'b) -> ('a -> 'a -> BatOrd.order) -> ('a, 'b) bounding_f (** [bounding_of_ord_chain ?low ?high ord] is like {!bounding_of_ord} except that functions are used to handle out of range values rather than single default values. *) val saturate_of_ord : bounds:('a bound_t * 'a bound_t) -> ('a -> 'a -> BatOrd.order) -> 'a -> 'a (** [saturate_of_ord ~bounds:(low, high) ord] will returning a bounding function using [ord] for value comparison and [low] and [high] for values which fall outside of the requested range. *) val opt_of_ord : bounds:('a bound_t * 'a bound_t) -> ('a -> 'a -> BatOrd.order) -> 'a -> 'a option (** [opt_of_ord ~bounds:(low, high) ord] will returning a bounding function using [ord] for value comparison and [None] for values which fall outside of the requested range. *) module type BoundedType = sig type base_t (** The base/raw type *) type t (** The type that makes up the bounded range *) val bounds : base_t bound_t * base_t bound_t (** [bounds] defines the [(min, max)] bounds for the bounded range *) val bounded : (base_t, t) bounding_f (** [bounded ~bounds x] returns a bounded {!t} value derived from [x]. *) val base_of_t : t -> base_t option (** [base_of_t x] converts a value of type {!t} back to a {!base_t} if possible. *) val base_of_t_exn : t -> base_t (** [base_of_t_exn x] converts a value of type {!t} back to a {!base_t}. If a conversion is not possible then an exception will be raised. *) end module type BoundedNumericType = sig include BoundedType module Infix : BatNumber.Infix with type bat__infix_t := base_t end module type S = sig type base_u (** Raw unbounded type *) type u (** {!base_u} after bounding constraints have been applied *) type t = private u (** Private version of {!u} to avoid construction of {!t} values without using [make] below. *) val bounds : base_u bound_t * base_u bound_t (** [bounds] defines the [(min, max)] bounds for the bounded range *) val make : base_u -> t (** [make x] will return a value of type {!t} derived from [x]. *) external extract : t -> u = "%identity" (** [extract x] will return [x] as a value of type {!u}. A similar result could be achieved with [(x :> u)] *) val map : (base_u -> base_u) -> t -> t option (** [map f x] applies [f] to [x]. Returns [Some y] if [x] can be converted back to type {!base_u}, otherwise returns [None]. *) val map2 : (base_u -> base_u -> base_u) -> t -> t -> t option (** [map2 f x y] applies [f] to [x] and [y]. Returns [Some z] if [x] and [y] can be converted back to type {!base_u}, otherwise returns [None]. *) val map_exn : (base_u -> base_u) -> t -> t (** [map_exn f x] applies [f] to [x]. Returns [y] if [x] can be converted back to type {!base_u}, otherwise raise an exception. *) val map2_exn : (base_u -> base_u -> base_u) -> t -> t -> t (** [map2_exn f x y] applies [f] to [x] and [y]. Returns [z] if [x] and [y] can be converted back to type {!base_u}, otherwise raise an exception. *) end module type NumericSig = sig include S val ( + ) : t -> base_u -> t val ( - ) : t -> base_u -> t val ( * ) : t -> base_u -> t val ( / ) : t -> base_u -> t val ( +: ) : t -> t -> t val ( -: ) : t -> t -> t val ( *: ) : t -> t -> t val ( /: ) : t -> t -> t end module Make : functor (M : BoundedType) -> S with type base_u = M.base_t with type u = M.t with type t = private M.t (** Functor to build an implementation of a bounded type given the bounded values definition [M] *) module MakeNumeric : functor (M : BoundedNumericType) -> NumericSig with type base_u = M.base_t with type u = M.t with type t = private M.t batteries-included-3.4.0/src/batBuffer.mliv000066400000000000000000000302671415601150500206530ustar00rootroot00000000000000(* * BatBuffer - Additional buffer operations * Copyright (C) 1999 Pierre Weis, Xavier Leroy * 2009 David Teller, LIFO, Universite d'Orleans * 2009 Dawid Toton * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Extensible string buffers. This module implements string buffers that automatically expand as necessary. It provides accumulative concatenation of strings in quasi-linear time (instead of quadratic time when strings are concatenated pairwise). @author Pierre Weis (Base module) @author Xavier Leroy (Base module) @author David Teller @author Dawid Toton *) type t = Buffer.t (** The abstract type of buffers. *) val create : int -> t (** [create n] returns a fresh buffer, initially empty. The [n] parameter is the initial size of the internal string that holds the buffer contents. That string 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. If [n] is not between 1 and {!Sys.max_string_length}, it will be clipped to that interval. *) val contents : t -> string (** Return a copy of the current contents of the buffer. The buffer itself is unchanged. *) val to_bytes : t -> Bytes.t (** Return a copy of the current contents of the buffer. The buffer itself is unchanged. @since 2.3.0 *) val sub : t -> int -> int -> string (** [Buffer.sub b off len] returns a copy of [len] bytes from the current contents of the buffer [b], starting at offset [off]. Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid range of [b]. *) val blit : t -> int -> Bytes.t -> int -> int -> unit (** [Buffer.blit src srcoff dst dstoff len] copies [len] characters from the current contents of the buffer [src], starting at offset [srcoff] to string [dst], starting at character [dstoff]. @raise Invalid_argument if [srcoff] and [len] do not designate a valid substring of [src], or if [dstoff] and [len] do not designate a valid substring of [dst]. @since 3.11.2 *) val nth : t -> int -> char (** get the n-th character of the buffer. @raise Invalid_argument if index out of bounds *) val length : t -> int (** Return the number of characters currently contained in the buffer. *) val clear : t -> unit (** Empty the buffer. *) val reset : t -> unit (** Empty the buffer and deallocate the internal string holding the buffer contents, replacing it with the initial internal string of length [n] that was allocated by {!Buffer.create} [n]. For long-lived buffers that may have grown a lot, [reset] allows faster reclamation of the space used by the buffer. *) val add_char : t -> char -> unit (** [add_char b c] appends the character [c] at the end of the buffer [b]. *) val add_string : t -> string -> unit (** [add_string b s] appends the string [s] at the end of the buffer [b]. *) val add_bytes : t -> Bytes.t -> unit (** [add_bytes b s] appends the string [s] at the end of the buffer [b]. @since 2.3.0 *) val add_substring : t -> string -> int -> int -> unit (** [add_substring b s ofs len] takes [len] characters from offset [ofs] in string [s] and appends them at the end of the buffer [b]. *) val add_subbytes : t -> Bytes.t -> int -> int -> unit (** [add_subbytes b s ofs len] takes [len] characters from offset [ofs] in byte sequence [s] and appends them at the end of the buffer [b]. @since 2.3.0 *) val add_substitute : t -> (string -> string) -> string -> unit (** [add_substitute b f s] appends the string pattern [s] at the end of the buffer [b] with substitution. The substitution process looks for variables into the pattern and substitutes each variable name by its value, as obtained by applying the mapping [f] to the variable name. Inside the string pattern, a variable name immediately follows a non-escaped [$] character and is one of the following: - a non empty sequence of alphanumeric or [_] characters, - an arbitrary sequence of characters enclosed by a pair of matching parentheses or curly brackets. An escaped [$] character is a [$] that immediately follows a backslash character; it then stands for a plain [$]. @raise Not_found if the closing character of a parenthesized variable cannot be found. *) val add_buffer : t -> t -> unit (** [add_buffer b1 b2] appends the current contents of buffer [b2] at the end of buffer [b1]. [b2] is not modified. *) val add_input : t -> BatInnerIO.input -> int -> unit (** [add_input b ic n] reads exactly [n] character from the input [ic] and stores them at the end of buffer [b]. @raise End_of_file if the channel contains fewer than [n] characters. *) val add_channel : t -> BatInnerIO.input -> int -> unit (** @obsolete replaced by {!add_input}*) val output_buffer : t -> string BatInnerIO.output (** [output_buffer b] creates an output channel that writes to that buffer, and when closed, returns the contents of the buffer. *) ##V>=4.5##val truncate : t -> int -> unit ##V>=4.5##(** [truncate b len] truncates the length of [b] to [len] ##V>=4.5## Note: the internal byte sequence is not shortened. ##V>=4.5## Raises [Invalid_argument] if [len < 0] or [len > length b]. ##V>=4.5## @since 2.7.0 and OCaml 4.05.0 *) ##V>=4.6##val add_utf_8_uchar : t -> Uchar.t -> unit ##V>=4.6##(** [add_utf_8_uchar b u] appends the {{:https://tools.ietf.org/html/rfc3629} ##V>=4.6## UTF-8} encoding of [u] at the end of buffer [b]. ##V>=4.6## ##V>=4.6## @since 2.8.0 and OCaml 4.06.0 *) ##V>=4.6##val add_utf_16le_uchar : t -> Uchar.t -> unit ##V>=4.6##(** [add_utf_16le_uchar b u] appends the ##V>=4.6## {{:https://tools.ietf.org/html/rfc2781}UTF-16LE} encoding of [u] ##V>=4.6## at the end of buffer [b]. ##V>=4.6## ##V>=4.6## @since 2.8.0 and OCaml 4.06.0 *) ##V>=4.6##val add_utf_16be_uchar : t -> Uchar.t -> unit ##V>=4.6##(** [add_utf_16be_uchar b u] appends the ##V>=4.6## {{:https://tools.ietf.org/html/rfc2781}UTF-16BE} encoding of [u] ##V>=4.6## at the end of buffer [b]. ##V>=4.6## ##V>=4.6## @since 2.8.0 and OCaml 4.06.0 *) (** {6 Boilerplate code}*) val enum : t -> char BatEnum.t (** Returns an enumeration of the characters of a buffer. Contents of the enumeration is unspecified if the buffer is modified after the enumeration is returned.*) val of_enum : char BatEnum.t -> t (** Creates a buffer from a character enumeration. *) val print: 'a BatInnerIO.output -> t -> unit ##V>=4.07##(** {1 Iterators} *) ##V>=4.07## ##V>=4.07##val to_seq : t -> char Seq.t ##V>=4.07##(** Iterate on the buffer, in increasing order. ##V>=4.07## Modification of the buffer during iteration is undefined behavior. ##V>=4.07## @since 2.10.0 and OCaml 4.07 *) ##V>=4.07##val to_seqi : t -> (int * char) Seq.t ##V>=4.07##(** Iterate on the buffer, in increasing order, yielding indices along chars. ##V>=4.07## Modification of the buffer during iteration is undefined behavior. ##V>=4.07## @since 2.10.0 and OCaml 4.07 *) ##V>=4.07##val add_seq : t -> char Seq.t -> unit ##V>=4.07##(** Add chars to the buffer ##V>=4.07## @since 2.10.0 and OCaml 4.07 *) ##V>=4.07##val of_seq : char Seq.t -> t ##V>=4.07##(** Create a buffer from the generator ##V>=4.07## @since 2.10.0 and OCaml 4.07 *) ##V>=4.08##(** {1 Binary encoding of integers} *) ##V>=4.08## ##V>=4.08##(** The functions in this section append binary encodings of integers ##V>=4.08## to buffers. ##V>=4.08## ##V>=4.08## Little-endian (resp. big-endian) encoding means that least ##V>=4.08## (resp. most) significant bytes are stored first. Big-endian is ##V>=4.08## also known as network byte order. Native-endian encoding is ##V>=4.08## either little-endian or big-endian depending on {!Sys.big_endian}. ##V>=4.08## ##V>=4.08## 32-bit and 64-bit integers are represented by the [int32] and ##V>=4.08## [int64] types, which can be interpreted either as signed or ##V>=4.08## unsigned numbers. ##V>=4.08## ##V>=4.08## 8-bit and 16-bit integers are represented by the [int] type, ##V>=4.08## which has more bits than the binary encoding. Functions that ##V>=4.08## encode these values truncate their inputs to their least ##V>=4.08## significant bytes. ##V>=4.08##*) ##V>=4.08##val add_uint8 : t -> int -> unit ##V>=4.08##(** [add_uint8 b i] appends a binary unsigned 8-bit integer [i] to ##V>=4.08## [b]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val add_int8 : t -> int -> unit ##V>=4.08##(** [add_int8 b i] appends a binary signed 8-bit integer [i] to ##V>=4.08## [b]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val add_uint16_ne : t -> int -> unit ##V>=4.08##(** [add_uint16_ne b i] appends a binary native-endian unsigned 16-bit ##V>=4.08## integer [i] to [b]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val add_uint16_be : t -> int -> unit ##V>=4.08##(** [add_uint16_be b i] appends a binary big-endian unsigned 16-bit ##V>=4.08## integer [i] to [b]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val add_uint16_le : t -> int -> unit ##V>=4.08##(** [add_uint16_le b i] appends a binary little-endian unsigned 16-bit ##V>=4.08## integer [i] to [b]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val add_int16_ne : t -> int -> unit ##V>=4.08##(** [add_int16_ne b i] appends a binary native-endian signed 16-bit ##V>=4.08## integer [i] to [b]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val add_int16_be : t -> int -> unit ##V>=4.08##(** [add_int16_be b i] appends a binary big-endian signed 16-bit ##V>=4.08## integer [i] to [b]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val add_int16_le : t -> int -> unit ##V>=4.08##(** [add_int16_le b i] appends a binary little-endian signed 16-bit ##V>=4.08## integer [i] to [b]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val add_int32_ne : t -> int32 -> unit ##V>=4.08##(** [add_int32_ne b i] appends a binary native-endian 32-bit integer ##V>=4.08## [i] to [b]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val add_int32_be : t -> int32 -> unit ##V>=4.08##(** [add_int32_be b i] appends a binary big-endian 32-bit integer ##V>=4.08## [i] to [b]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val add_int32_le : t -> int32 -> unit ##V>=4.08##(** [add_int32_le b i] appends a binary little-endian 32-bit integer ##V>=4.08## [i] to [b]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val add_int64_ne : t -> int64 -> unit ##V>=4.08##(** [add_int64_ne b i] appends a binary native-endian 64-bit integer ##V>=4.08## [i] to [b]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val add_int64_be : t -> int64 -> unit ##V>=4.08##(** [add_int64_be b i] appends a binary big-endian 64-bit integer ##V>=4.08## [i] to [b]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val add_int64_le : t -> int64 -> unit ##V>=4.08##(** [add_int64_ne b i] appends a binary little-endian 64-bit integer ##V>=4.08## [i] to [b]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) batteries-included-3.4.0/src/batBuffer.mlv000066400000000000000000000071441415601150500205000ustar00rootroot00000000000000(* * BatBuffer - Additional buffer operations * Copyright (C) 1999 Pierre Weis, Xavier Leroy * 2009 David Teller, LIFO, Universite d'Orleans * 2009 Dawid Toton * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) include Buffer (** The underlying buffer type. *) type buffer = {mutable buffer : string;(** Contents of the buffer *) mutable position : int; (** The end of the buffer *) mutable length : int; (** The size of the buffer *) initial_buffer : string (** For resetting to the original size **)} external buffer_of_t : t -> buffer = "%identity" external t_of_buffer : buffer -> t = "%identity" let print out t = BatString.print out (contents t) (*$Q print (Q.string) (fun s -> let b = create 5 in add_string b "foo"; add_string b s; add_string b "bar"; BatIO.to_string print b = "foo" ^ s ^ "bar") *) let enum t = let buf = buffer_of_t t in BatEnum.take buf.position (BatString.enum buf.buffer) (*$Q enum (Q.string) (fun s -> let b = create 10 in add_string b s; BatEnum.equal Char.equal (enum b) (BatString.enum s)) *) let of_enum e = let buf = if BatEnum.fast_count e then create (BatEnum.count e) else create 128 in add_string buf (BatString.of_enum e); buf (*$Q of_enum (Q.string) (fun s -> let b = of_enum (BatString.enum s) in contents b = s) (Q.string) (fun s -> let e = BatString.enum s in \ let e = BatEnum.from (fun () -> BatEnum.get_exn e) in \ contents (of_enum e) = s) *) let add_input t inp n = add_string t (BatInnerIO.really_nread inp n) (*$Q add_input (Q.string) (fun s -> let b = create 10 in add_input b (BatIO.input_string s) (String.length s); contents b = s) *) let add_channel = add_input ##V<4.2##let add_bytes = add_string ##V<4.2##let add_subbytes = add_substring ##V<4.2##let to_bytes = contents let output_buffer buf = BatInnerIO.create_out ~write: (add_char buf) ~output:(fun s p l -> add_subbytes buf s p l; l) ~close: (fun () -> contents buf) ~flush: BatInnerIO.noop (*$Q output_buffer (Q.string) (fun s -> let b = create 10 in let oc = output_buffer b in IO.nwrite oc s; IO.close_out oc = s) *) ##V>=4.07##let to_seq = to_seq ##V>=4.07##let to_seqi = to_seqi ##V>=4.07##let add_seq = add_seq ##V>=4.07##let of_seq = of_seq ##V>=4.08##let add_uint8 = add_uint8 ##V>=4.08##let add_int8 = add_int8 ##V>=4.08##let add_uint16_ne = add_uint16_ne ##V>=4.08##let add_uint16_be = add_uint16_be ##V>=4.08##let add_uint16_le = add_uint16_le ##V>=4.08##let add_int16_ne = add_int16_ne ##V>=4.08##let add_int16_be = add_int16_be ##V>=4.08##let add_int16_le = add_int16_le ##V>=4.08##let add_int32_ne = add_int32_ne ##V>=4.08##let add_int32_be = add_int32_be ##V>=4.08##let add_int32_le = add_int32_le ##V>=4.08##let add_int64_ne = add_int64_ne ##V>=4.08##let add_int64_be = add_int64_be ##V>=4.08##let add_int64_le = add_int64_le batteries-included-3.4.0/src/batBytes.mliv000066400000000000000000000707341415601150500205330ustar00rootroot00000000000000(***********************************************************************) (* *) (* OCaml *) (* *) (* 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 GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (** Byte sequence operations. A byte sequence is a mutable data structure that contains a fixed-length sequence of bytes. Each byte can be indexed in constant time for reading or writing. Given a byte sequence [s] of length [l], we can access each of the [l] bytes of [s] via its index in the sequence. Indexes start at [0], and we will call an index valid in [s] if it falls within the range [[0...l-1]] (inclusive). A position is the point between two bytes or at the beginning or end of the sequence. We call a position valid in [s] if it falls within the range [[0...l]] (inclusive). Note that the byte at index [n] is between positions [n] and [n+1]. Two parameters [start] and [len] are said to designate a valid range of [s] if [len >= 0] and [start] and [start+len] are valid positions in [s]. Byte sequences can be modified in place, for instance via the [set] and [blit] functions described below. See also strings (module {!String}), which are almost the same data structure, but cannot be modified in place. Bytes are represented by the OCaml type [char]. @since Batteries 2.3.0 and OCaml 4.02.0 *) ##V<4.2##type t = string ##V>=4.2##type t = bytes (** An alias for the type of byte sequences. *) ##V<4.4##external length : t -> int = "%string_length" ##V>=4.4##external length : t -> int = "%bytes_length" (** Return the length (number of t) of the argument. *) ##V<4.4##external get : t -> int -> char = "%string_safe_get" ##V>=4.4##external get : t -> int -> char = "%bytes_safe_get" (** [get s n] returns the byte at index [n] in argument [s]. Raise [Invalid_argument] if [n] not a valid index in [s]. *) ##V<4.4##external set : t -> int -> char -> unit = "%string_safe_set" ##V>=4.4##external set : t -> int -> char -> unit = "%bytes_safe_set" (** [set s n c] modifies [s] in place, replacing the byte at index [n] with [c]. Raise [Invalid_argument] if [n] is not a valid index in [s]. *) ##V<4.4##external create : int -> t = "caml_create_string" ##V>=4.4##external create : int -> t = "caml_create_bytes" (** [create n] returns a new byte sequence of length [n]. The sequence is uninitialized and contains arbitrary bytes. Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) val make : int -> char -> t (** [make n c] returns a new byte sequence of length [n], filled with the byte [c]. Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) val init : int -> (int -> char) -> t (** [Bytes.init n f] returns a fresh byte sequence of length [n], with character [i] initialized to the result of [f i] (in increasing index order). Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) val empty : t (** A byte sequence of size 0. *) val copy : t -> t (** Return a new byte sequence that contains the same bytes as the argument. *) val of_string : string -> t (** Return a new byte sequence that contains the same bytes as the given string. *) val to_string : t -> string (** Return a new string that contains the same bytes as the given byte sequence. *) val sub : t -> int -> int -> t (** [sub s start len] returns a new byte sequence of length [len], containing the subsequence of [s] that starts at position [start] and has length [len]. Raise [Invalid_argument] if [start] and [len] do not designate a valid range of [s]. *) val sub_string : t -> int -> int -> string (** Same as [sub] but return a string instead of a byte sequence. *) val extend : t -> int -> int -> t (** [extend s left right] returns a new byte sequence that contains the bytes of [s], with [left] uninitialized bytes prepended and [right] uninitialized bytes appended to it. If [left] or [right] is negative, then bytes are removed (instead of appended) from the corresponding side of [s]. Raise [Invalid_argument] if the result length is negative or longer than {!Sys.max_string_length} bytes. *) val fill : t -> int -> int -> char -> unit (** [fill s start len c] modifies [s] in place, replacing [len] characters with [c], starting at [start]. Raise [Invalid_argument] if [start] and [len] do not designate a valid range of [s]. *) val blit : t -> int -> t -> int -> int -> unit (** [blit src srcoff dst dstoff len] copies [len] bytes from sequence [src], starting at index [srcoff], to sequence [dst], starting at index [dstoff]. It works correctly even if [src] and [dst] are the same byte sequence, and the source and destination intervals overlap. Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid range of [src], or if [dstoff] and [len] do not designate a valid range of [dst]. *) val blit_string : string -> int -> t -> int -> int -> unit (** [blit_string src srcoff dst dstoff len] copies [len] bytes from string [src], starting at index [srcoff], to byte sequence [dst], starting at index [dstoff]. Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid range of [src], or if [dstoff] and [len] do not designate a valid range of [dst]. *) val concat : t -> t list -> t (** [concat sep sl] concatenates the list of byte sequences [sl], inserting the separator byte sequence [sep] between each, and returns the result as a new byte sequence. Raise [Invalid_argument] if the result is longer than {!Sys.max_string_length} bytes. *) val cat : t -> t -> t (** [cat s1 s2] concatenates [s1] and [s2] and returns the result as new byte sequence. Raise [Invalid_argument] if the result is longer than {!Sys.max_string_length} bytes. *) val iter : (char -> unit) -> t -> unit (** [iter f s] applies function [f] in turn to all the bytes of [s]. It is equivalent to [f (get s 0); f (get s 1); ...; f (get s (length s - 1)); ()]. *) val iteri : (int -> char -> unit) -> t -> unit (** Same as {!Bytes.iter}, but the function is applied to the index of the byte as first argument and the byte itself as second argument. *) val map : (char -> char) -> t -> t (** [map f s] applies function [f] in turn to all the bytes of [s] (in increasing index order) and stores the resulting bytes in a new sequence that is returned as the result. *) val mapi : (int -> char -> char) -> t -> t (** [mapi f s] calls [f] with each character of [s] and its index (in increasing index order) and stores the resulting bytes in a new sequence that is returned as the result. *) val fold_left : ('a -> char -> 'a) -> 'a -> bytes -> 'a (** [fold_left f x s] computes [f (... (f (f x (get s 0)) (get s 1)) ...) (get s (n-1))], where [n] is the length of [s]. @since 3.4.0 *) val fold_right : (char -> 'a -> 'a) -> bytes -> 'a -> 'a (** [fold_right f s x] computes [f (get s 0) (f (get s 1) ( ... (f (get s (n-1)) x) ...))], where [n] is the length of [s]. @since 3.4.0 *) val for_all : (char -> bool) -> bytes -> bool (** [for_all p s] checks if all characters in [s] satisfy the predicate [p]. @since 3.4.0 *) val exists : (char -> bool) -> bytes -> bool (** [exists p s] checks if at least one character of [s] satisfies the predicate [p]. @since 3.4.0 *) val trim : t -> t (** Return a copy of the argument, without leading and trailing whitespace. The bytes regarded as whitespace are the ASCII characters [' '], ['\012'], ['\n'], ['\r'], and ['\t']. *) val escaped : t -> t (** Return a copy of the argument, with special characters represented by escape sequences, following the lexical conventions of OCaml. Raise [Invalid_argument] if the result is longer than {!Sys.max_string_length} bytes. *) val index : t -> char -> int (** [index s c] returns the index of the first occurrence of byte [c] in [s]. Raise [Not_found] if [c] does not occur in [s]. *) val index_opt: t -> char -> int option (** [index_opt s c] returns the index of the first occurrence of byte [c] in [s] or [None] if [c] does not occur in [s]. @since 2.7.0 *) val rindex : t -> char -> int (** [rindex s c] returns the index of the last occurrence of byte [c] in [s]. Raise [Not_found] if [c] does not occur in [s]. *) val rindex_opt: t -> char -> int option (** [rindex_opt s c] returns the index of the last occurrence of byte [c] in [s] or [None] if [c] does not occur in [s]. @since 2.7.0 *) val index_from : t -> int -> char -> int (** [index_from s i c] returns the index of the first occurrence of byte [c] in [s] after position [i]. [Bytes.index s c] is equivalent to [Bytes.index_from s 0 c]. Raise [Invalid_argument] if [i] is not a valid position in [s]. Raise [Not_found] if [c] does not occur in [s] after position [i]. *) val index_from_opt: t -> int -> char -> int option (** [index_from _opts i c] returns the index of the first occurrence of byte [c] in [s] after position [i] or [None] if [c] does not occur in [s] after position [i]. [Bytes.index_opt s c] is equivalent to [Bytes.index_from_opt s 0 c]. Raise [Invalid_argument] if [i] is not a valid position in [s]. @since 2.7.0 *) val rindex_from : t -> int -> char -> int (** [rindex_from s i c] returns the index of the last occurrence of byte [c] in [s] before position [i+1]. [rindex s c] is equivalent to [rindex_from s (Bytes.length s - 1) c]. Raise [Invalid_argument] if [i+1] is not a valid position in [s]. Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *) val rindex_from_opt: t -> int -> char -> int option (** [rindex_from_opt s i c] returns the index of the last occurrence of byte [c] in [s] before position [i+1] or [None] if [c] does not occur in [s] before position [i+1]. [rindex_opt s c] is equivalent to [rindex_from s (Bytes.length s - 1) c]. Raise [Invalid_argument] if [i+1] is not a valid position in [s]. @since 2.7.0 *) val starts_with: prefix:bytes -> bytes -> bool (** [starts_with ~prefix s] is [true] if and only if [s] starts with [prefix]. @since 3.4.0 *) val ends_with: suffix:bytes -> bytes -> bool (** [ends_with ~suffix s] is [true] if and only if [s] ends with [suffix]. @since 3.4.0 *) val contains : t -> char -> bool (** [contains s c] tests if byte [c] appears in [s]. *) val contains_from : t -> int -> char -> bool (** [contains_from s start c] tests if byte [c] appears in [s] after position [start]. [contains s c] is equivalent to [contains_from s 0 c]. Raise [Invalid_argument] if [start] is not a valid position in [s]. *) val rcontains_from : t -> int -> char -> bool (** [rcontains_from s stop c] tests if byte [c] appears in [s] before position [stop+1]. Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid position in [s]. *) val uppercase : t -> t (** Return a copy of the argument, with all lowercase letters translated to uppercase, including accented letters of the ISO Latin-1 (8859-1) character set. *) val lowercase : t -> t (** Return a copy of the argument, with all uppercase letters translated to lowercase, including accented letters of the ISO Latin-1 (8859-1) character set. *) val capitalize : t -> t (** Return a copy of the argument, with the first byte set to uppercase. *) val uncapitalize : t -> t (** Return a copy of the argument, with the first byte set to lowercase. *) val uppercase_ascii : t -> t (** Return a copy of the argument, with all lowercase letters translated to uppercase, using the US-ASCII character set. @since 2.5.0 *) val lowercase_ascii : t -> t (** Return a copy of the argument, with all uppercase letters translated to lowercase, using the US-ASCII character set. @since 2.5.0 *) val capitalize_ascii : t -> t (** Return a copy of the argument, with the first character set to uppercase, using the US-ASCII character set. @since 2.5.0 *) val uncapitalize_ascii : t -> t (** Return a copy of the argument, with the first character set to lowercase, using the US-ASCII character set. @since 2.5.0 *) val compare: t -> t -> int (** The comparison function for byte sequences, with the same specification as {!Pervasives.compare}. Along with the type [t], this function [compare] allows the module [Bytes] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) val equal: t -> t -> bool (** The equality function for byte sequences. @since 2.5.0 *) val split_on_char: char -> bytes -> bytes list (** [split_on_char sep s] returns the list of all (possibly empty) subsequences of [s] that are delimited by the [sep] character. The function's output is specified by the following invariants: - The list is not empty. - Concatenating its elements using [sep] as a separator returns a byte sequence equal to the input ([Bytes.concat (Bytes.make 1 sep) (Bytes.split_on_char sep s) = s]). - No byte sequence in the result contains the [sep] character. @since 3.4.0 *) (** {4 Unsafe conversions (for advanced users)} This section describes unsafe, low-level conversion functions between [bytes] and [string]. They do 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. *) val unsafe_to_string : t -> string (** 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: - 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 write 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 ownership of the returned string. There are two valid use-cases that respect this ownership discipline: 1. 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 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. 2. 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 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. *) val unsafe_of_string : string -> t (** 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]: you may use it if you were the owner of the [string] value, and you will own the return [bytes] in the same mode. In practice, unique ownership of string values is extremely difficult to reason about correctly. You 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. {[ let incorrect = Bytes.unsafe_of_string "hello" let s = Bytes.of_string "hello" ]} The first declaration is incorrect, because the string literal ["hello"] could be shared by the compiler with other parts of the program, and mutating [incorrect] is a bug. You must always use the second version, which performs a copy and is thus correct. Assuming unique ownership of strings that are not string literals, but are (partly) built from string literals, is also incorrect. For example, mutating [unsafe_of_string ("foo" ^ s)] could mutate the shared string ["foo"] -- assuming a rope-like representation of strings. More generally, functions operating on strings will assume shared ownership, they do not preserve unique ownership. It is thus incorrect to assume unique ownership of the result of [unsafe_of_string]. 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. *) ##V>=4.07##(** {1 Iterators} *) ##V>=4.07## ##V>=4.07##val to_seq : t -> char Seq.t ##V>=4.07##(** Iterate on the string, in increasing index order. Modifications of the ##V>=4.07## string during iteration will be reflected in the iterator. ##V>=4.07## @since 2.10.0 and OCaml 4.07 *) ##V>=4.07##val to_seqi : t -> (int * char) Seq.t ##V>=4.07##(** Iterate on the string, in increasing order, yielding indices along chars ##V>=4.07## @since 2.10.0 and OCaml 4.07 *) ##V>=4.07##val of_seq : char Seq.t -> t ##V>=4.07##(** Create a string from the generator ##V>=4.07## @since 2.10.0 and OCaml 4.07 *) ##V>=4.08##(** {1 Binary encoding/decoding of integers} *) ##V>=4.08## ##V>=4.08##(** The functions in this section binary encode and decode integers to ##V>=4.08## and from byte sequences. ##V>=4.08## ##V>=4.08## All following functions raise [Invalid_argument] if the space ##V>=4.08## needed at index [i] to decode or encode the integer is not ##V>=4.08## available. ##V>=4.08## ##V>=4.08## Little-endian (resp. big-endian) encoding means that least ##V>=4.08## (resp. most) significant bytes are stored first. Big-endian is ##V>=4.08## also known as network byte order. Native-endian encoding is ##V>=4.08## either little-endian or big-endian depending on {!Sys.big_endian}. ##V>=4.08## ##V>=4.08## 32-bit and 64-bit integers are represented by the [int32] and ##V>=4.08## [int64] types, which can be interpreted either as signed or ##V>=4.08## unsigned numbers. ##V>=4.08## ##V>=4.08## 8-bit and 16-bit integers are represented by the [int] type, ##V>=4.08## which has more bits than the binary encoding. These extra bits ##V>=4.08## are handled as follows: {ul ##V>=4.08## {- Functions that decode signed (resp. unsigned) 8-bit or 16-bit ##V>=4.08## integers represented by [int] values sign-extend ##V>=4.08## (resp. zero-extend) their result.} ##V>=4.08## {- Functions that encode 8-bit or 16-bit integers represented by ##V>=4.08## [int] values truncate their input to their least significant ##V>=4.08## bytes.}} ##V>=4.08##*) ##V>=4.08##val get_uint8 : bytes -> int -> int ##V>=4.08##(** [get_uint8 b i] is [b]'s unsigned 8-bit integer starting at byte index [i]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val get_int8 : bytes -> int -> int ##V>=4.08##(** [get_int8 b i] is [b]'s signed 8-bit integer starting at byte index [i]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val get_uint16_ne : bytes -> int -> int ##V>=4.08##(** [get_uint16_ne b i] is [b]'s native-endian unsigned 16-bit integer ##V>=4.08## starting at byte index [i]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val get_uint16_be : bytes -> int -> int ##V>=4.08##(** [get_uint16_be b i] is [b]'s big-endian unsigned 16-bit integer ##V>=4.08## starting at byte index [i]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val get_uint16_le : bytes -> int -> int ##V>=4.08##(** [get_uint16_le b i] is [b]'s little-endian unsigned 16-bit integer ##V>=4.08## starting at byte index [i]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val get_int16_ne : bytes -> int -> int ##V>=4.08##(** [get_int16_ne b i] is [b]'s native-endian signed 16-bit integer ##V>=4.08## starting at byte index [i]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val get_int16_be : bytes -> int -> int ##V>=4.08##(** [get_int16_be b i] is [b]'s big-endian signed 16-bit integer ##V>=4.08## starting at byte index [i]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val get_int16_le : bytes -> int -> int ##V>=4.08##(** [get_int16_le b i] is [b]'s little-endian signed 16-bit integer ##V>=4.08## starting at byte index [i]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val get_int32_ne : bytes -> int -> int32 ##V>=4.08##(** [get_int32_ne b i] is [b]'s native-endian 32-bit integer ##V>=4.08## starting at byte index [i]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val get_int32_be : bytes -> int -> int32 ##V>=4.08##(** [get_int32_be b i] is [b]'s big-endian 32-bit integer ##V>=4.08## starting at byte index [i]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val get_int32_le : bytes -> int -> int32 ##V>=4.08##(** [get_int32_le b i] is [b]'s little-endian 32-bit integer ##V>=4.08## starting at byte index [i]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val get_int64_ne : bytes -> int -> int64 ##V>=4.08##(** [get_int64_ne b i] is [b]'s native-endian 64-bit integer ##V>=4.08## starting at byte index [i]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val get_int64_be : bytes -> int -> int64 ##V>=4.08##(** [get_int64_be b i] is [b]'s big-endian 64-bit integer ##V>=4.08## starting at byte index [i]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val get_int64_le : bytes -> int -> int64 ##V>=4.08##(** [get_int64_le b i] is [b]'s little-endian 64-bit integer ##V>=4.08## starting at byte index [i]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val set_uint8 : bytes -> int -> int -> unit ##V>=4.08##(** [set_uint8 b i v] sets [b]'s unsigned 8-bit integer starting at byte index ##V>=4.08## [i] to [v]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val set_int8 : bytes -> int -> int -> unit ##V>=4.08##(** [set_int8 b i v] sets [b]'s signed 8-bit integer starting at byte index ##V>=4.08## [i] to [v]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val set_uint16_ne : bytes -> int -> int -> unit ##V>=4.08##(** [set_uint16_ne b i v] sets [b]'s native-endian unsigned 16-bit integer ##V>=4.08## starting at byte index [i] to [v]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val set_uint16_be : bytes -> int -> int -> unit ##V>=4.08##(** [set_uint16_be b i v] sets [b]'s big-endian unsigned 16-bit integer ##V>=4.08## starting at byte index [i] to [v]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val set_uint16_le : bytes -> int -> int -> unit ##V>=4.08##(** [set_uint16_le b i v] sets [b]'s little-endian unsigned 16-bit integer ##V>=4.08## starting at byte index [i] to [v]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val set_int16_ne : bytes -> int -> int -> unit ##V>=4.08##(** [set_int16_ne b i v] sets [b]'s native-endian signed 16-bit integer ##V>=4.08## starting at byte index [i] to [v]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val set_int16_be : bytes -> int -> int -> unit ##V>=4.08##(** [set_int16_be b i v] sets [b]'s big-endian signed 16-bit integer ##V>=4.08## starting at byte index [i] to [v]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val set_int16_le : bytes -> int -> int -> unit ##V>=4.08##(** [set_int16_le b i v] sets [b]'s little-endian signed 16-bit integer ##V>=4.08## starting at byte index [i] to [v]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val set_int32_ne : bytes -> int -> int32 -> unit ##V>=4.08##(** [set_int32_ne b i v] sets [b]'s native-endian 32-bit integer ##V>=4.08## starting at byte index [i] to [v]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val set_int32_be : bytes -> int -> int32 -> unit ##V>=4.08##(** [set_int32_be b i v] sets [b]'s big-endian 32-bit integer ##V>=4.08## starting at byte index [i] to [v]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val set_int32_le : bytes -> int -> int32 -> unit ##V>=4.08##(** [set_int32_le b i v] sets [b]'s little-endian 32-bit integer ##V>=4.08## starting at byte index [i] to [v]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val set_int64_ne : bytes -> int -> int64 -> unit ##V>=4.08##(** [set_int64_ne b i v] sets [b]'s native-endian 64-bit integer ##V>=4.08## starting at byte index [i] to [v]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val set_int64_be : bytes -> int -> int64 -> unit ##V>=4.08##(** [set_int64_be b i v] sets [b]'s big-endian 64-bit integer ##V>=4.08## starting at byte index [i] to [v]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) ##V>=4.08##val set_int64_le : bytes -> int -> int64 -> unit ##V>=4.08##(** [set_int64_le b i v] sets [b]'s little-endian 64-bit integer ##V>=4.08## starting at byte index [i] to [v]. ##V>=4.08## @since 2.10.0 and OCaml 4.08 ##V>=4.08##*) (**/**) (* The following is for system use only. Do not call directly. *) ##V<4.4##external unsafe_get : t -> int -> char = "%string_unsafe_get" ##V>=4.4##external unsafe_get : t -> int -> char = "%bytes_unsafe_get" ##V<4.4##external unsafe_set : t -> int -> char -> unit = "%string_unsafe_set" ##V>=4.4##external unsafe_set : t -> int -> char -> unit = "%bytes_unsafe_set" ##V<4.4##external unsafe_blit : t -> int -> t -> int -> int -> unit = "caml_blit_string" "noalloc" ##V>=4.4##external unsafe_blit : t -> int -> t -> int -> int -> unit = "caml_blit_bytes" [@@noalloc] ##V<4.4##external unsafe_fill : t -> int -> int -> char -> unit = "caml_fill_string" "noalloc" ##V>=4.4##external unsafe_fill: t -> int -> int -> char -> unit = "caml_fill_bytes" [@@noalloc] ##V>=4.09##external unsafe_blit_string : string -> int -> bytes -> int -> int -> unit = "caml_blit_string" [@@noalloc] batteries-included-3.4.0/src/batBytes.mlv000066400000000000000000000141101415601150500203440ustar00rootroot00000000000000include Bytes (*$T init init 5 (fun i -> Char.chr (i + int_of_char '0')) |> to_string = "01234"; *) (*$T mapi mapi (fun _ -> Char.uppercase_ascii) (of_string "Five") |> to_string = "FIVE" mapi (fun _ -> Char.uppercase_ascii) (of_string "") |> to_string = "" mapi (fun _ -> String.of_char %> failwith) (of_string "") |> to_string = "" mapi (fun i _c -> "0123456789".[9-i]) (of_string "0123456789") |> to_string = "9876543210" ignore (let last = ref (-1) in mapi (fun i _c -> assert (i > !last); last := i; '0') (of_string "012345")); true *) (* String.trim is @since 4.00 *) ##V<4.0##let trim b = Bytes.of_string (BatString.trim b) (*$T trim " \t foo\n " |> of_string |> trim |> to_string |> (=) "foo" " foo bar " |> of_string |> trim |> to_string |> (=) "foo bar" " \t " |> of_string |> trim |> to_string |> (=) "" "" |> of_string |> trim |> to_string |> (=) "" *) (* String.map is @since 4.00 *) ##V<4.0##let map f s = ##V<4.0## let len = length s in ##V<4.0## let sc = create len in ##V<4.0## for i = 0 to len - 1 do ##V<4.0## unsafe_set sc i (f (unsafe_get s i)) ##V<4.0## done; ##V<4.0## sc (*$T map "Five" |> of_string |> map Char.uppercase_ascii |> to_string |> (=) "FIVE" "" |> of_string |> map Char.uppercase_ascii |> to_string |> (=) "" "" |> of_string |> map (String.of_char %> failwith) |> to_string |> (=) "" *) (* String.iteri is @since 4.00 *) ##V<4.0##let iteri f s = ##V<4.0## for i = 0 to (Bytes.length s) - 1 do f i (Bytes.unsafe_get s i) done ##V<4.3##let equal b1 (b2 : Bytes.t) = (compare b1 b2 = 0) ##V<4.3##let uppercase_ascii s = map BatChar.uppercase_ascii s ##V<4.3##let lowercase_ascii s = map BatChar.lowercase_ascii s (*$T uppercase_ascii String.equal ("five" |> of_string |> uppercase_ascii |> to_string) "FIVE" String.equal ("école" |> of_string |> uppercase_ascii |> to_string) "éCOLE" *) (*$T lowercase_ascii String.equal ("FIVE" |> of_string |> lowercase_ascii |> to_string) "five" String.equal ("ÉCOLE" |> of_string |> lowercase_ascii |> to_string) "École" *) ##V<4.3##let map_first_char f s = ##V<4.3## let r = copy s in ##V<4.3## if length s > 0 then ##V<4.3## unsafe_set r 0 (f(unsafe_get s 0)); ##V<4.3## r ##V<4.3##let capitalize_ascii s = map_first_char BatChar.uppercase_ascii s ##V<4.3##let uncapitalize_ascii s = map_first_char BatChar.lowercase_ascii s (*$T capitalize_ascii String.equal ("five" |> of_string |> capitalize_ascii |> to_string) "Five" String.equal ("école" |> of_string |> capitalize_ascii |> to_string) "école" *) (*$T uncapitalize_ascii String.equal ("Five" |> of_string |> uncapitalize_ascii |> to_string) "five" String.equal ("École" |> of_string |> uncapitalize_ascii |> to_string) "École" *) ##V<4.5##let index_opt b c = try Some (index b c) with _ -> None ##V<4.5##let rindex_opt b c = try Some (rindex b c) with _ -> None ##V<4.5##let index_from_opt b i c = try Some (index_from b i c) with _ -> None ##V<4.5##let rindex_from_opt b i c = try Some (rindex_from b i c) with _ -> None ##V>=4.07##let to_seq = to_seq ##V>=4.07##let to_seqi = to_seqi ##V>=4.07##let of_seq = of_seq ##V>=4.08##let get_uint8 = get_uint8 ##V>=4.08##let get_int8 = get_int8 ##V>=4.08##let get_uint16_ne = get_uint16_ne ##V>=4.08##let get_uint16_be = get_uint16_be ##V>=4.08##let get_uint16_le = get_uint16_le ##V>=4.08##let get_int16_ne = get_int16_ne ##V>=4.08##let get_int16_be = get_int16_be ##V>=4.08##let get_int16_le = get_int16_le ##V>=4.08##let get_int32_ne = get_int32_ne ##V>=4.08##let get_int32_be = get_int32_be ##V>=4.08##let get_int32_le = get_int32_le ##V>=4.08##let get_int64_ne = get_int64_ne ##V>=4.08##let get_int64_be = get_int64_be ##V>=4.08##let get_int64_le = get_int64_le ##V>=4.08##let set_uint8 = set_uint8 ##V>=4.08##let set_int8 = set_int8 ##V>=4.08##let set_uint16_ne = set_uint16_ne ##V>=4.08##let set_uint16_be = set_uint16_be ##V>=4.08##let set_uint16_le = set_uint16_le ##V>=4.08##let set_int16_ne = set_int16_ne ##V>=4.08##let set_int16_be = set_int16_be ##V>=4.08##let set_int16_le = set_int16_le ##V>=4.08##let set_int32_ne = set_int32_ne ##V>=4.08##let set_int32_be = set_int32_be ##V>=4.08##let set_int32_le = set_int32_le ##V>=4.08##let set_int64_ne = set_int64_ne ##V>=4.08##let set_int64_be = set_int64_be ##V>=4.08##let set_int64_le = set_int64_le let fold_left f x a = let r = ref x in let n = length a in for i = 0 to n - 1 do r := f !r (unsafe_get a i) done; !r let fold_right f a x = let r = ref x in let n = length a in for i = n - 1 downto 0 do r := f (unsafe_get a i) !r done; !r let for_all p s = let n = length s in let rec loop i = if i = n then true else if p (unsafe_get s i) then loop (succ i) else false in loop 0 (*$T for_all for_all (fun c -> c <> '0') (of_string "123456789") false = for_all (fun c -> c <> '9') (of_string "123456789") *) let exists p s = let n = length s in let rec loop i = if i = n then false else if p (unsafe_get s i) then true else loop (succ i) in loop 0 (*$T exists exists (fun c -> c = '0') (of_string "1234567890") *) let starts_with ~prefix s = let len_s = length s and len_pre = length prefix in let rec aux i = if i = len_pre then true else if unsafe_get s i <> unsafe_get prefix i then false else aux (i + 1) in len_s >= len_pre && aux 0 (*$T starts_with starts_with ~prefix:(of_string "toto") (of_string "tototititata") *) let ends_with ~suffix s = let len_s = length s and len_suf = length suffix in let diff = len_s - len_suf in let rec aux i = if i = len_suf then true else if unsafe_get s (diff + i) <> unsafe_get suffix i then false else aux (i + 1) in diff >= 0 && aux 0 (*$T ends_with ends_with ~suffix:(of_string "tata") (of_string "tototititata") *) let split_on_char sep s = let r = ref [] in let n = length s in let j = ref n in for i = n - 1 downto 0 do if unsafe_get s i = sep then begin r := sub s (i + 1) (!j - i - 1) :: !r; j := i end done; sub s 0 !j :: !r (*$T split_on_char split_on_char ';' (of_string "toto;titi;tata") = \ [of_string "toto"; of_string "titi"; of_string "tata"] *) batteries-included-3.4.0/src/batBytesCompat.mlv000066400000000000000000000020341415601150500215120ustar00rootroot00000000000000(* This compatible module contains compatibility versions of stdlib functions that are commonly used when porting code to the (string / bytes) separation, but are not available in older OCaml versions that Batteries support. We could push each function in the corresponding Batteries module (Buffer.add_subbtypes into BatBuffer, etc.), but this would have the effect of turning dependencies on the stdlib into inter-Batteries-module dependencies: any module using Buffer.add_subbtypes would then depend on the whole BatBuffer, increasing binary sizes and risk of cycles. *) ##V>=4.2##let string_init = String.init ##V<4.2##let string_init len f = ##V<4.2## let s = Bytes.create len in ##V<4.2## for i = 0 to len - 1 do ##V<4.2## Bytes.unsafe_set s i (f i) ##V<4.2## done; ##V<4.2## Bytes.unsafe_to_string s ##V>=4.2##let buffer_add_subbytes = Buffer.add_subbytes ##V<4.2##let buffer_add_subbytes = Buffer.add_substring ##V>=4.2##let buffer_to_bytes = Buffer.to_bytes ##V<4.2##let buffer_to_bytes = Buffer.contents batteries-included-3.4.0/src/batCache.ml000066400000000000000000000072071415601150500201040ustar00rootroot00000000000000(* * Cache - Simple (and maybe complex) caching structures * Copyright (C) 2011 Batteries Included Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open BatInnerPervasives type ('a,'b) manual_cache = { get : 'a -> 'b; del : 'a -> unit; enum: unit -> ('a * 'b) BatEnum.t } let make_ht ~gen ~init_size = let ht = BatHashtbl.create init_size in {get = (fun k -> try BatHashtbl.find ht k with Not_found -> gen k |> tap (BatHashtbl.add ht k)); del = (fun k -> BatHashtbl.remove ht k); enum = (fun () -> BatHashtbl.enum ht) } (* For tests, use side effects to count number of times the function is run *) (*$T make_ht let runs = ref 0 in let c = make_ht ~gen:(fun x -> incr runs; x) ~init_size:5 in let s = c.get 3 + c.get 4 + c.get 3 in s = 10 && !runs = 2 *) let make_map ~gen = let m = ref BatMap.empty in {get = (fun k -> try BatMap.find k !m with Not_found -> gen k |> tap (fun v -> m := BatMap.add k v !m)); del = (fun k -> m := BatMap.remove k !m); enum = (fun () -> BatMap.enum !m) } (*$T make_map let runs = ref 0 in let c = make_map ~gen:(fun x -> incr runs; x) in let s = c.get 3 + c.get 4 + c.get 3 in s = 10 && !runs = 2 *) type ('a, 'b) auto_cache = 'a -> 'b let lru_cache ~gen ~cap = let entries = ref None in let auxentries = BatHashtbl.create cap in let len = ref 0 in let entry_gen k v = incr len; let n = BatDllist.create (k, v) in BatHashtbl.add auxentries k n; n in let entry_find k _dll = try let n = BatHashtbl.find auxentries k in BatDllist.remove n; n with Not_found -> entry_gen k (gen k) in let entry_remove n = let lru = BatDllist.prev n in let k = BatDllist.get lru |> fst in BatHashtbl.remove auxentries k; BatDllist.remove lru; decr len in let get k = match !entries with (* remove match by replacing get after first run? *) | Some dll -> (* not at head of list *) let (k0,v) = BatDllist.get dll in if k = k0 then v (* special case head of list *) else begin let n = entry_find k dll in (* Put n at the head of the list *) BatDllist.splice n dll; entries := Some n; (* Remove the tail if over capacity *) if !len > cap then entry_remove n; (* BatDllist.print (BatTuple.Tuple2.print BatPervasives.print_any BatPervasives.print_any) BatIO.stdout n; *) (* return the value *) BatDllist.get n |> snd end | None -> (* no list - generate it *) let v = gen k in entries := Some (entry_gen k v); v in get (* WARNING: s is evaluated right to left *) (*$T lru_cache let runs = ref 0 in let id = lru_cache ~gen:(fun x -> incr runs; x) ~cap:3 in \ let s = id 1 + id 1 + id 3 + id 3 + id 2 + id 1 in\ s = 11 && !runs = 3 let runs = ref 0 in let id = lru_cache ~gen:(fun x -> incr runs; x) ~cap:3 in \ let s = id 1 + id 1 + id 4 + id 3 + id 2 + id 1 in \ s = 12 && !runs = 5 *) batteries-included-3.4.0/src/batCache.mli000066400000000000000000000070041415601150500202500ustar00rootroot00000000000000(* * Cache - Simple (and maybe complex) caching structures * Copyright (C) 2011 Batteries Included Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** The data structure for a manual cache with keys ['a] and values ['b]. This cache gives access to some internals of a memoized function [f], called the generating function. This function is usually pure; always returning the same output for a given input. This module allows the results of complex functions to be cached so that the function does not need to be called again to get that result. When [c.get k] is called, an internal structure is first consulted to see if [f k] has been stored in that structure. If it has, then that previous result is returned, otherwise, [f k] is evaluated, the result stored in the caching structure and also returned to the user. The user is allowed to remove a value from the caching structure with [c.del k]. This allows the user to prevent unbounded growth of the cache by removing unneeded entries. If the user prefers an automatically managed cache, this module provides [!auto_cache]. Last, [c.enum ()] will enumerate all the currently memorized bindings as pairs. This allows inspection of what is currently cached. *) type ('a,'b) manual_cache = { get : 'a -> 'b; del : 'a -> unit; enum: unit -> ('a * 'b) BatEnum.t } val make_ht : gen:('a -> 'b) -> init_size:int -> ('a,'b) manual_cache (** Make a manual cache backed by a hashtable. The generating function is passed with [~gen] and the initial size of the hashtable is [~init_size]. The hashtable uses the polymorphic [hash] and [(=)].*) val make_map : gen:('a -> 'b) -> ('a,'b) manual_cache (** Make a manual cache for function [~gen] backed by a Set.t. This set uses the polymorphic [(<)] for comparison, so ['a] should be properly comparable by it. *) (** Automatically managed caches This type of cache is more transparent than the [!manual_cache] above. It does not provide inspection of the caching structure, but guarantees bounded memory usage through some policy of discarding some entries. Each auto-cache can have a different policy to decide which entry to discard. *) type ('a, 'b) auto_cache = 'a -> 'b val lru_cache : gen:('a -> 'b) -> cap:int -> ('a, 'b) auto_cache (* Make a simple LRU (least-recently-used) automatic cache for function [~gen] and with capacity [~cap]. When a new entry is added to the cache, if its capacity was [cap], then the least recently used entry in the cache will be removed to make room for it. *) (* TODO val rec_cache : gen:(('a -> 'b) -> 'a -> 'b) -> ('a, 'b) manual_cache val other_fancy_caching_strategy : (as lru_cache, probably) *) batteries-included-3.4.0/src/batChar.mli000066400000000000000000000125071415601150500201260ustar00rootroot00000000000000(* * BatChar - Additional character operations * Copyright (C) 1996 Xavier Leroy * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Operations on characters. Characters range upon Latin-1 encoding, i.e. languages used in Western Europe and North America. For international characters, another, richer, module is provided: {!UChar}. @author Xavier Leroy (base module) @author David Teller *) external code : char -> int = "%identity" (** Return the ASCII code of the argument. *) val chr : int -> char (** Return the character with the given ASCII code. @raise Invalid_argument if the argument is outside the range 0--255. *) val escaped : char -> string (** Return a string representing the given character, with special characters escaped following the lexical conventions of OCaml. *) val lowercase : char -> char (** Convert the given character to its equivalent lowercase character. *) val uppercase : char -> char (** Convert the given character to its equivalent uppercase character. *) val lowercase_ascii : char -> char (** Convert the given character to its equivalent lowercase character, using the US-ASCII character set. @since 2.5.0 *) val uppercase_ascii : char -> char (** Convert the given character to its equivalent uppercase character, using the US-ASCII character set. @since 2.5.0 *) type t = char (** An alias for the type of characters. *) val is_whitespace : char -> bool (** Determine if a character is a whitespace. Whitespace characters are defined as [' '], ['\010'], ['\013'], ['\009'], ['\026'] and ['\012']. *) val is_uppercase : char -> bool (** Determine if a character is uppercase ASCII. A character is uppercase ASCII if it is between ['A'] and ['Z'] *) val is_lowercase : char -> bool (** Determine if a character is lowercase ASCII. A character is lowercase ASCII if it is between ['a'] and ['z'] *) val is_uppercase_latin1: char -> bool (** Determine if a character is uppercase Latin 1. A character is uppercase Latin 1 if it is between ['A'] and ['Z'], between [''] and [''] or between [''] and [''] *) val is_lowercase_latin1: char -> bool (** Determine if a character is lowercase Latin 1. A character is lowercase Latin 1 if it is between ['a'] and ['z'], between [''] and [''] or between [''] and ['']*) val is_latin1: char -> bool (** Determine if a character is a Latin 1 letter. A character is a Latin 1 letter if it is either an uppercase or a lowercase Latin 1 character.*) val is_digit : char -> bool (** Determine if a character represents a digit. Digits are ['0'], ['1'], ... ['9']. *) val is_symbol : char -> bool (** Determine if a character represents a (OCaml-style) symbol. Symbols are ['!'], ['%'], ['&'], ['$'], ['#'], ['+'], ['-'], ['/'], [':'], ['<'], ['='] ['>'], ['?'], ['@'], ['\\'], ['~'], ['^'], ['|'], ['*'] *) val is_letter : char -> bool (** Determine if a character represents a ASCII letter.*) val is_newline : char -> bool (** Determine if a character is a newline. Newline characters are defined as ['\010'] and ['\013']*) val of_digit : int -> char (** Return the character representing a given digit. @raise Invalid_argument if the argument is outside the range 0--9*) val enum: unit -> char BatEnum.t (** Produce the enumeration of all characters *) val range: ?until:char -> char -> char BatEnum.t (** [range from ?until] produces an enumeration of the characters from [from] to [until] included [until] defaults to ['\255'] *) val ( -- ): char -> char -> char BatEnum.t (** Produce the enumeration of a segment of characters. ['a' -- 'z'] is the enumeration of all characters between ['a'] and ['z'] included.*) (** {6 Infix submodule regrouping all infix operators} *) module Infix : sig val ( -- ): char -> char -> char BatEnum.t end (** {6 Boilerplate code}*) val print: 'a BatInnerIO.output -> Char.t -> unit val compare: t -> t -> int (** The comparison function for characters, with the same specification as {!Pervasives.compare}. Along with the type [t], this function [compare] allows the module [Char] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) val equal : t -> t -> bool val hash : t -> int val ord : char BatOrd.ord module Incubator : sig module Comp : BatOrd.Comp with type t = char module Ord : BatOrd.Ord with type t = char module Eq : BatOrd.Eq with type t = char end (**/**) external unsafe_chr : int -> char = "%identity" external unsafe_int : char-> int = "%identity" (**/**) batteries-included-3.4.0/src/batChar.mlv000066400000000000000000000071531415601150500201440ustar00rootroot00000000000000(* * BatChar - Additional character operations * Copyright (C) 1996 Xavier Leroy * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) include Char ##V<4.3##let lowercase_ascii = function ##V<4.3## | ('A'..'Z') as c -> unsafe_chr (code c - code 'A' + code 'a') ##V<4.3## | c -> c ##V<4.3## ##V<4.3##let uppercase_ascii = function ##V<4.3## | ('a'..'z') as c -> unsafe_chr (code c - code 'a' + code 'A') ##V<4.3## | c -> c (*$T lowercase_ascii lowercase_ascii 'A' = 'a' lowercase_ascii '' = '' *) (*$T uppercase_ascii uppercase_ascii 'a' = 'A' uppercase_ascii '' = '' *) let is_whitespace = function | ' ' | '\010' | '\013' | '\009' | '\026' | '\012' -> true | _ -> false let is_newline = function | '\010' | '\013' -> true | _ -> false let is_digit = function | '0'..'9' -> true | _ -> false let is_uppercase c = 'A' <= c && c <= 'Z' let is_lowercase c = 'a' <= c && c <= 'z' let is_uppercase_latin1 c = is_uppercase c || ( '\192' (**)<= c && c <= '\214' (**) ) || ( '\216' (**) <= c && c <= '\221'(**) ) let is_lowercase_latin1 c = is_lowercase c || ( '\222' (**) <= c && c <= '\246'(**) ) || ( '\248'(**) <= c && c <= '\255' (*''*) ) let is_latin1 c = is_uppercase_latin1 c || is_lowercase_latin1 c let is_symbol = function | '!' | '%' | '&' | '$' | '#' | '+' | '-' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '\\' | '~' | '^' | '|' | '*' -> true | _ -> false let is_letter c = is_uppercase c || is_lowercase c external unsafe_int : char-> int = "%identity" external unsafe_chr : int -> char = "%identity" let of_digit i = if i >= 0 && i < 10 then Char.unsafe_chr (i + Char.code '0') else invalid_arg "Char.of_digit" (*$T of_digit of_digit 6 = '6' try ignore (of_digit (-2)); false with Invalid_argument _ -> true try ignore (of_digit (46)); false with Invalid_argument _ -> true *) let enum () = BatEnum.map unsafe_chr (BatEnum.( -- ) 0 255) (*$T enum let e = enum () in for i = 0 to 255 do assert (Char.chr i = BatEnum.get_exn e) done; BatEnum.is_empty e *) let ( -- ) from last = BatEnum.map unsafe_chr (BatEnum.( -- ) (unsafe_int from) (unsafe_int last)) (*$T (--) let e = Char.chr 12 -- Char.chr 52 in for i = 12 to 52 do assert (Char.chr i = BatEnum.get_exn e) done; BatEnum.is_empty e *) let range ?until:(last = unsafe_chr 255) from = from -- last module Infix = struct let (--) = (--) end let print out t = BatInnerIO.write out t (*$T print BatIO.to_string print 'a' = "a" BatIO.to_string print '\n' = "\n" *) let ord (x:char) y = if x > y then BatOrd.Gt else if y > x then BatOrd.Lt else BatOrd.Eq let equal (x:char) y = x == y (* safe because int-like value *) let hash = code module Incubator = struct module Comp = struct type t = char let compare = compare end module Ord = BatOrd.Ord(Comp) module Eq = BatOrd.EqComp(Comp) end batteries-included-3.4.0/src/batCharParser.ml000066400000000000000000000073231415601150500211320ustar00rootroot00000000000000(* * CharParser - Parsing character strings * Copyright (C) 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open BatParserCo (** {6 Entry point} *) type position = { offset: int; line: int } let start_position = { offset = 1; line = 1 } let advance c p = if BatChar.is_newline c then ((*Printf.eprintf "[Have reached line %i]\n%!" (p.line + 1);*) { offset = 1; line = p.line + 1}) else { (p) with offset = p.offset + 1} let source_of_enum s = Source.of_enum s start_position advance let source_of_string s = source_of_enum (BatString.enum s) let parse p s = run p (source_of_string s) (*let parse_enum p e = let latest = ref "" in let lines = lines_of (input_enum e) in let chars = BatEnum.concat (BatEnum.from (fun () -> match get lines with | None -> raise BatEnum.No_more_elements | Some l -> latest := l; String.enum l)) in let source = source_of_enum chars in match run p source with | Std.Ok _ as result -> result | Std.Error report -> Std.Error (report, ?(*Furthest position*), ?(*List of labels at that point*), !latest)*) (** {6 Utilities}*) let char c = label ("\"" ^ BatString.of_char c ^ "\"") (exactly c) let string s = label ("\"" ^ s ^ "\"") ( let len = String.length s in let rec aux i = if i < len then exactly s.[i] >>= fun _ -> aux (i+1) else return s in aux 0 ) let case_char c = if BatChar.is_letter c then one_of [Char.uppercase c; Char.lowercase c] else char c let case_string s = label ("case insensitive \"" ^ s ^ "\"") ( let s' = String.lowercase s in let len = String.length s' in let rec aux i = if i < len then case_char s'.[i] >>= fun _ -> aux (i+1) else return s in aux 0 ) let whitespace = satisfy BatChar.is_whitespace let uppercase = label "upper case char" (satisfy BatChar.is_uppercase) let lowercase = label "lower case char" (satisfy BatChar.is_lowercase) let letter = label "letter" (satisfy BatChar.is_letter) let uppercase_latin1 = label "upper case char (possibly accentuated)" ( satisfy BatChar.is_uppercase_latin1 ) let lowercase_latin1 = label "lower case char (possibly accentuated)" ( satisfy BatChar.is_lowercase_latin1 ) let latin1 = label "letter (possibly accentuated)" (satisfy BatChar.is_latin1) let digit = label "digit" ( satisfy BatChar.is_digit) let hex = label "hex" ( satisfy (fun x -> ( '0' <= x && x <= '9' ) || ('a' <= x && x <= 'f') || ('A' <= x && x <= 'F'))) let not_char c = label ("anything but '" ^ BatString.of_char c ^ "'") (satisfy (fun x -> x <> c) (*>>= fun x -> Printf.eprintf "(%c)\n" x; return x*) ) let none_of l = label ( BatString.of_list (BatVect.to_list (BatVect.append ']' (List.fold_left (fun acc x -> BatVect.append x acc) (BatVect.of_list (BatString.to_list "anything but ['")) l)))) (none_of l) let newline = satisfy BatChar.is_newline batteries-included-3.4.0/src/batCharParser.mli000066400000000000000000000073051415601150500213030ustar00rootroot00000000000000(* * CharParser - Parsing character strings * Copyright (C) 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Parsing character strings. This module defines common functions for parsing character strings, encoded in Latin-1. These functions are meant to be used in conjunction with the {!ParserCo} module. {b Note} As ParserCo, this module is still very rough and needs testing. @author David Teller *) open BatParserCo (** The position inside one file or one stream. *) type position = { offset: int;(**Offset on the line (starting at 0)*) line: int (**Line number (starting at 0)*) } val advance : char -> position -> position (**Advance by one char. [advance c p] returns a new position advanced by one char. If [c] is '\r' or '\n', the result is [{offset = 0; line = p.line + 1}]. Other wise, the result is [{offset = p.offset + 1; line = p.line}].*) val source_of_string : string -> (char, position) Source.t (** Create a source from a latin-1 character string.*) val source_of_enum : char BatEnum.t -> (char, position) Source.t (** Create a source from a latin-1 character.*) val parse : (char, 'a, position) t -> string -> ('a, position report) BatPervasives.result (**Apply a parser to a string.*) (**{6 Utilities}*) val char : char -> (char, char, position) t (** Recognize exactly one char*) val none_of : char list -> (char, char, position) t (**Accept any value not in a list As [ParserCo.none_of], just with improved error message.*) val not_char : char -> (char, char, position) t (**Accept any value not a given char As [none_of]. *) val string : string -> (char, string, position) t (** Recognize exactly one string*) val case_char : char -> (char, char, position) t (** As [char], but case-insensitive *) val case_string : string -> (char, string, position) t (** As [case_string], but case-insensitive *) val newline : (char, char, position) t (**Recognizes a newline*) val whitespace : (char, char, position) t (**Recognizes white-space*) val uppercase : (char, char, position) t (**Recognizes one upper-case ASCII character, including accentuated characters.*) val lowercase : (char, char, position) t (**Recognizes one lower-case ASCII character, including accentuated characters.*) val letter: (char, char, position) t (**Recognizes one lower- or upper-case ASCII character, including accentuated characters.*) val uppercase_latin1 : (char, char, position) t (**Recognizes one upper-case Latin-1 character, including accentuated characters.*) val lowercase_latin1 : (char, char, position) t (**Recognizes one lower-case Latin-1 character, including accentuated characters.*) val latin1: (char, char, position) t (**Recognizes one lower- or upper-case Latin1 character, including accentuated characters.*) val digit : (char, char, position) t (**Recognizes one decimal digit*) val hex : (char, char, position) t (**Recognizes one hexadecimal digit (case-insensitive)*) batteries-included-3.4.0/src/batComplex.ml000066400000000000000000000143321415601150500205050ustar00rootroot00000000000000(* * BatComplex - Extended Complex Numbers * Copyright (C) 2007 Bluestorm * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module BaseComplex = struct include Complex let modulo _ _ = failwith "BatComplex.modulo is meaningless" let to_string x = ( string_of_float x.re ) ^ " + i " ^ ( string_of_float x.im ) let pred x = {x with re = x.re -. 1.} let succ x = {x with re = x.re +. 1.} let to_int x = int_of_float x.re let of_int x = {re = float_of_int x; im = 0.} let to_float x = x.re let of_float x = {re = x; im = 0.} let abs x = { re = norm x; im = 0. } let compare t1 t2 = match compare t1.re t2.re with | 0 -> compare t1.im t2.im | c -> c let ord = BatOrd.ord compare let equal t1 t2 = t1.re = t2.re && t1.im = t2.im let of_string x = let fail s = failwith (Printf.sprintf "BatComplex.of_string %S: %s" x s) in let open Genlex in let enum = BatGenlex.to_enum_filter ( BatGenlex.of_list ["."; "i"; "+"; "-"; "*"] ) ( BatString.enum x ) in let rec parse_re () = match BatEnum.peek enum with | None -> fail "the string is empty" | Some (Int i) -> BatEnum.junk enum; parse_separation (float_of_int i) | Some (Float f) -> BatEnum.junk enum; parse_separation f | Some (Kwd "-") -> BatEnum.junk enum; parse_i_im ~multiplier:(-1.) 0. | Some (Kwd "+") -> BatEnum.junk enum; parse_i_im ~multiplier:1. 0. | Some _token -> parse_i_im ~multiplier:1. 0. and parse_separation re = match BatEnum.get enum with | None -> {re; im = 0.} | Some (Kwd "-") -> parse_i_im ~multiplier:(-1.) re | Some (Kwd "+") -> parse_i_im ~multiplier:1. re | Some _ -> fail "unexpected token after real part" and parse_i_im ~multiplier re = match BatEnum.get enum with | Some (Kwd "i") -> ( match BatEnum.peek enum with | None -> {re; im = multiplier} | Some (Kwd ".") | Some (Kwd "*") -> BatEnum.junk enum; parse_im ~multiplier re | Some _token -> parse_im ~multiplier re ) | _ -> fail "expected \"i\" before the imaginary part" and parse_im ~multiplier re = match BatEnum.peek enum with | Some (Int i) -> BatEnum.junk enum; parse_end {re; im = multiplier *. float_of_int i} | Some (Float f) -> BatEnum.junk enum; parse_end {re; im = multiplier *. f} | _ -> fail "expected a number for the imaginary part" and parse_end c = match BatEnum.peek enum with | None -> c | Some _ -> fail "unexpected trailing tokens" in parse_re () end (* need to fix problem with Functor return type being `type t = Complex.t` and needing `type t = Complex.t = {re: float; im:float}` *) module CN = BatNumber.MakeNumeric(BaseComplex) include BaseComplex let operations = CN.operations module Infix = BatNumber.MakeInfix(BaseComplex) include Infix module Compare = BatNumber.MakeCompare(BaseComplex) let inv = Complex.inv let i = Complex.i let conj = Complex.conj let sqrt = Complex.sqrt let norm2 = Complex.norm2 let norm = Complex.norm let arg = Complex.arg let polar = Complex.polar let exp = Complex.exp let log = Complex.log let pow = Complex.pow let print out t = BatInnerIO.nwrite out (to_string t) (*$T succ succ {re = 2.; im = 4.} = {re = 3.; im = 4.} *) (*$T pred pred {re = 2.; im = 4.} = {re = 1.; im = 4.} *) (*$T abs abs {re = 3.; im = 4.} = {re = 5.; im = 0.} *) (*$T to_int to_int {re = 2.; im = 3.} = 2 *) (*$T of_int of_int 2 = {re = 2.; im = 0.} *) (*$T to_float to_float {re = 2.; im = 3.} = 2. *) (*$T of_float of_float 2. = {re = 2.; im = 0.} *) (*$T compare compare {re = 2.; im = 3.} {re = 2.; im = 3.} = 0 compare {re = 2.; im = 3.} {re = 3.; im = 2.} = -1 compare {re = 3.; im = 3.} {re = 2.; im = 3.} = 1 compare {re = 3.; im = 4.} {re = 3.; im = 3.} = 1 compare {re = 3.; im = -4.} {re = 3.; im = 3.} = -1 *) (*$T equal equal {re = 2.; im = 3.} {re = 2.; im = 3.} not (equal {re = 2.; im = 3.} {re = 3.; im = 2.}) not (equal {re = 3.; im = 3.} {re = 2.; im = 3.}) not (equal {re = 3.; im = 4.} {re = 3.; im = 3.}) *) (*$T of_string of_string "1." = of_float 1. of_string "-1." = {re = -1.; im = 0.} of_string "1 + i 2." = {re = 1.; im = 2.} of_string "1 - i 2." = {re = 1.; im = -2.} of_string "1 - i 2e3" = {re = 1.; im = -2e3} of_string "-1. - i -2e3" = {re = -1.; im = 2e3} of_string "-1+i 2e3" = {re = -1.; im = 2e3} of_string "-1. - i. -2e3" = {re = -1.; im = 2e3} of_string "-1. - i * -2e3" = {re = -1.; im = 2e3} of_string " - i * -2e3" = {re = 0.; im = 2e3} of_string "+ i * -2e3" = {re = 0.; im = -2e3} of_string "i * -2e3" = {re = 0.; im = -2e3} of_string "i" = {re = 0.; im = 1.} of_string "-i" = {re = 0.; im = -1.} of_string "1 + i" = {re = 1.; im = 1.} try ignore (of_string " "); false with Failure _ -> true try ignore (of_string "("); false with BatGenlex.LexerError _ -> true try ignore (of_string "1 +"); false with Failure _ -> true try ignore (of_string "i +"); false with Failure _ -> true try ignore (of_string "1 + i * 3 4"); false with Failure _ -> true try ignore (of_string "1 2"); false with Failure _ -> true *) (*$T print BatIO.to_string print {re=3.4; im= -5.6} = "3.4 + i -5.6" *) batteries-included-3.4.0/src/batComplex.mli000066400000000000000000000112121415601150500206500ustar00rootroot00000000000000(* * BatComplex - Extended Complex * Copyright (C) 2007 Bluestorm * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Additional and modified functions for complex numbers.*) (** Complex numbers. This module provides arithmetic operations on complex numbers. Complex numbers are represented by their real and imaginary parts (cartesian representation). Each part is represented by a double-precision floating-point number (type {!float}). @author Xavier Leroy (base module) @author Gabriel Scherer @author David Teller *) type t = Complex.t = { re : float; im : float; } val zero: t (** The complex number [0]. *) val one: t (** The complex number [1]. *) val i: t (** The complex number [i]. *) val neg: t -> t (** Unary negation. *) val conj: t -> t (** Conjugate: given the complex [x + i.y], returns [x - i.y]. *) val add: t -> t -> t (** Addition *) val sub: t -> t -> t (** Subtraction *) val mul: t -> t -> t (** Multiplication *) val inv: t -> t (** Multiplicative inverse ([1/z]). *) val div: t -> t -> t (** Division *) val sqrt: t -> t (** Square root. The result [x + i.y] is such that [x > 0] or [x = 0] and [y >= 0]. This function has a discontinuity along the negative real axis. *) val norm2: t -> float (** Norm squared: given [x + i.y], returns [x^2 + y^2]. *) val norm: t -> float (** Norm: given [x + i.y], returns [sqrt(x^2 + y^2)]. *) val arg: t -> float (** Argument. The argument of a complex number is the angle in the complex plane between the positive real axis and a line passing through zero and the number. This angle ranges from [-pi] to [pi]. This function has a discontinuity along the negative real axis. *) val polar: float -> float -> t (** [polar norm arg] returns the complex having norm [norm] and argument [arg]. *) val exp: t -> t (** Exponentiation. [exp z] returns [e] to the [z] power. *) val log: t -> t (** Natural logarithm (in base [e]). *) val pow: t -> t -> t (** Power function. [pow z1 z2] returns [z1] to the [z2] power. *) val operations : t BatNumber.numeric val inv : t -> t (** [inv x] returns the value of [1/x]*) val succ : t -> t (** Add {!one} to this number.*) val pred : t -> t (** Remove {!one} from this number.*) val abs : t -> t (** [abs c] returns the module of this complex number, i.e. [abs c = Float.sqrt((re c) *. (re c) +. (im c) *. (im c) )]*) val modulo : t -> t -> t val pow : t -> t -> t val compare : t -> t -> int val ord : t -> t -> BatOrd.order val equal : t -> t -> bool val of_int : int -> t val to_int : t -> int (** [to_int c] is the integer part of the real part of [c] *) val of_string : string -> t (** [of_string s] accepts strings with the following formats: (|) (+|-) i ( * | . | ) (|) where (a|b|c) is either a or b or c. In addition the following degenerate formats are also accepted: (+|-) i ( * | . | ) (|) (|) (+|-) i (|) *) val to_string : t -> string val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t val ( ** ) : t -> t -> t (* Available only in `Compare` submodule val ( <> ) : t -> t -> bool val ( >= ) : t -> t -> bool val ( <= ) : t -> t -> bool val ( > ) : t -> t -> bool val ( < ) : t -> t -> bool val ( = ) : t -> t -> bool *) val ( -- ): t -> t -> t BatEnum.t val ( --- ): t -> t -> t BatEnum.t val of_float : float -> t (** [Complex.of_float x] returns the complex number [x+0i] *) val to_float : t -> float (** [Complex.to_float (a+bi)] returns the float [a] *) (** {6 Submodules grouping all infix operators} *) module Infix : BatNumber.Infix with type bat__infix_t = t module Compare : BatNumber.Compare with type bat__compare_t = t (** {6 Boilerplate code}*) (** {7 Printing}*) val print: 'a BatInnerIO.output -> t -> unit batteries-included-3.4.0/src/batConcreteQueue_402.ml000066400000000000000000000043341415601150500222330ustar00rootroot00000000000000(* Explanation from OCaml 4.02 source: A queue is a reference to either nothing or some cell of a cyclic list. By convention, that cell is to be viewed as the last cell in the queue. The first cell in the queue is then found in constant time: it is the next cell in the cyclic list. The queue's length is also recorded, so as to make [length] a constant-time operation. The [tail] field should really be of type ['a cell option], but then it would be [None] when [length] is 0 and [Some] otherwise, leading to redundant memory allocation and accesses. We avoid this overhead by filling [tail] with a dummy value when [length] is 0. Of course, this requires bending the type system's arm slightly, because it does not have dependent sums. The dummy value used by the stdlib is (Obj.magic None). *) type 'a cell = { content: 'a; mutable next: 'a cell } and 'a t = { mutable length: int; mutable tail: 'a cell } external of_abstr : 'a Queue.t -> 'a t = "%identity" external to_abstr : 'a t -> 'a Queue.t = "%identity" let filter_inplace f ({tail; _} as queue) = if not (Queue.is_empty (to_abstr queue)) then let rec filter' ({ next = { content; next } as current; _ } as prev) = if f content then (* Keep cell. Recursion to next cell unless we reached the tail *) (if current != tail then filter' current) else begin (* Remove cell. *) if current != tail then begin (* Easy case. We are not removing the tail cell. *) prev.next <- next; queue.length <- queue.length - 1; (* Recursion with the same cell, * because it is now pointing beyond current. *) filter' prev end else begin (* Removing the tail cell *) if prev == current (* Tail cell is the last cell. Just clear the queue. *) then begin Queue.clear (to_abstr queue) end else begin (* Tail cell is not the last cell. * prev is the new tail. *) prev.next <- next; queue.length <- queue.length - 1; queue.tail <- prev; end end end in filter' tail batteries-included-3.4.0/src/batConcreteQueue_402.mli000066400000000000000000000002501415601150500223750ustar00rootroot00000000000000type 'a t external of_abstr : 'a Queue.t -> 'a t = "%identity" external to_abstr : 'a t -> 'a Queue.t = "%identity" val filter_inplace : ('a -> bool) -> 'a t -> unit batteries-included-3.4.0/src/batConcreteQueue_403.ml000066400000000000000000000030431415601150500222300ustar00rootroot00000000000000type 'a cell = | Nil | Cons of { content: 'a; mutable next: 'a cell } [@@warning "-37"] (* Disable warning 37 (Unused constructor): Cons is never used to build values, but it is used implicitly in [of_abstr] *) type 'a t = { mutable length: int; mutable first: 'a cell; mutable last: 'a cell } external of_abstr : 'a Queue.t -> 'a t = "%identity" external to_abstr : 'a t -> 'a Queue.t = "%identity" let filter_inplace f queue = (* find_next returns the next 'true' cell, or Nil *) let rec find_next = function | Nil -> Nil | (Cons cell) as cons -> if f cell.content then cons else find_next cell.next in (* last is the last known 'true' Cons cell (may be Nil if no true cell has be found yet) next is the next candidate true cell (may be Nil if there is no next cell) *) let rec loop length last next = match next with | Nil -> (length, last) | (Cons cell) as cons -> let next = find_next cell.next in cell.next <- next; loop (length + 1) cons next in let first = find_next queue.first in (* returning a pair is unnecessary, the writes could be made at the end of 'loop', but the present style makes it obvious that all three writes are performed atomically, without allocation, function call or return (yield points) in between, guaranteeing some form of state consistency in the face of signals, threading or what not. *) let (length, last) = loop 0 Nil first in queue.length <- length; queue.first <- first; queue.last <- last; () batteries-included-3.4.0/src/batConcreteQueue_403.mli000066400000000000000000000002501415601150500223760ustar00rootroot00000000000000type 'a t external of_abstr : 'a Queue.t -> 'a t = "%identity" external to_abstr : 'a t -> 'a Queue.t = "%identity" val filter_inplace : ('a -> bool) -> 'a t -> unit batteries-included-3.4.0/src/batConcurrent.ml000066400000000000000000000050121415601150500212130ustar00rootroot00000000000000(* * Concurrent - Generic interface for concurrent operations * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type lock = {execute : 'a 'b. ('a -> 'b) -> 'a -> 'b} let nolock= {execute = (fun f x -> f x)} let sync lock = lock.execute let synchronize locker f x = sync (locker ()) f x let compose {execute = a} {execute = b} = { execute = (fun f x -> b (a f) x) } let create ~enter ~leave = { execute = (fun f x -> enter (); try let result = f x in leave (); result with e -> leave (); raise e ) } module type BaseLock = sig type t (** The type of a lock. *) val create:unit -> t val lock : t -> unit val unlock:t -> unit val try_lock:t -> bool end module type Lock = sig type t (** The type of a lock. *) val create: unit -> t val lock : t -> unit val unlock: t -> unit val try_lock:t -> bool val synchronize: ?lock:t -> ('a -> 'b) -> 'a -> 'b val make : unit -> lock end let base_create = create module MakeLock(M:BaseLock) : Lock with type t = M.t = struct type t = M.t let create = M.create let lock = M.lock let unlock = M.unlock let try_lock=M.try_lock let synchronize ?(lock=M.create ()) f x = try M.lock lock; let result = f x in M.unlock lock; result with e -> M.unlock lock; raise e let make () = let lock = M.create () in base_create ~enter:(fun () -> M.lock lock) ~leave:(fun () -> M.unlock lock) end module BaseNoLock = struct type t = unit external create: unit -> t = "%ignore" external lock : t -> unit = "%ignore" external unlock: t -> unit = "%ignore" let try_lock _t = true end module NoLock = MakeLock(BaseNoLock) batteries-included-3.4.0/src/batConcurrent.mli000066400000000000000000000056521415601150500213760ustar00rootroot00000000000000(* * Concurrent - Generic interface for concurrent operations * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Definition of concurrency primitives. @author David Teller *) type lock (** The light-weight type of a lock, i.e. a construction which may be used to guarantee that a section will not be interrupted by another thread. This light-weight type is independent of the underlying locking mechanism and can be used if you do not know whether your code will run with vmthreads, Posix threads, coThreads, etc. *) val create: enter:(unit -> unit) -> leave:(unit -> unit) -> lock (** Create a lock from a pair of locking/unlocking functions @param enter Enter critical section. @param leave Leave critical section. .*) val nolock : lock (** A lock which does nothing.*) val synchronize: (unit -> lock) -> ('a -> 'b) -> 'a -> 'b (** [synchronize locker f] returns a function [f'] which behaves as [f] but whose executions are protected by one lock obtained from [locker]. The same lock will be reused for all subsequent uses of [f']. For instance, [synchronize Mutex.make f] is a new function whose executions will by synchronized by a new lock. Conversely, [synchronize (const my_lock) f] is a new function whose executions will be synchronized by an existing lock [my_lock]. *) val sync:lock -> ('a -> 'b) -> 'a -> 'b (** Specialized version of [synchronized]. [sync lock f] behaves as [synchronize (const lock) f] but slightly faster *) val compose : lock -> lock -> lock (** Compose two lock systems into a third lock system. *) (** A signature for modules which implement locking.*) module type BaseLock = sig type t(**The type of a lock.*) val create:unit -> t val lock : t -> unit val unlock:t -> unit val try_lock:t -> bool end module type Lock = sig type t(**The type of a lock.*) val create: unit -> t val lock : t -> unit val unlock: t -> unit val try_lock:t -> bool val synchronize: ?lock:t -> ('a -> 'b) -> 'a -> 'b val make : unit -> lock end module MakeLock(M:BaseLock) : Lock with type t = M.t module NoLock : Lock batteries-included-3.4.0/src/batDeque.ml000066400000000000000000000207161415601150500201440ustar00rootroot00000000000000(* * Deque -- functional double-ended queues * Copyright (C) 2011 Batteries Included Development Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type 'a dq = { front : 'a list ; flen : int ; rear : 'a list ; rlen : int } let invariants t = assert (List.length t.front = t.flen); assert (List.length t.rear = t.rlen) type 'a t = 'a dq type 'a enumerable = 'a t type 'a mappable = 'a t let empty = { front = [ ] ; flen = 0 ; rear = [ ] ; rlen = 0 } let size q = q.flen + q.rlen let cons x q = { q with front = x :: q.front ; flen = q.flen + 1 } (*$T cons size (cons 1 empty) = 1 to_list(cons 1 empty) <> to_list(cons 2 empty) *) (*$Q cons (Q.list Q.pos_int) ~count:10 \ (fun l -> List.fold_left (fun q x -> cons x q) empty l |> to_list = List.rev l) *) let snoc q x = { q with rear = x :: q.rear ; rlen = q.rlen + 1 } (*$T cons; snoc to_list(cons 1 empty) = to_list(snoc empty 1) to_list(cons 1 (cons 2 empty)) = (to_list (snoc (snoc empty 2) 1) |> List.rev) *) (*$Q snoc (Q.list Q.int) (fun l -> List.fold_left snoc empty l |> to_list = l) *) let front q = match q with | {front = h :: front; flen = flen; _} -> Some (h, { q with front = front ; flen = flen - 1 }) | {rear = []; _} -> None | {rear = rear; rlen = rlen; _} -> (* beware: when rlen = 1, we must put the only element of * the deque at the front (ie new_flen = 1, new_rlen = 0) *) let new_flen = (rlen + 1) / 2 in let new_rlen = rlen / 2 in (* we split the non empty list in half because if we transfer * everything to the front, then a call to rear would also * transfer everything to the rear etc. -> no amortization * (but we could transfer 3/4 instead of 1/2 of the list for instance) *) let rear, rev_front = BatList.split_at new_rlen rear in let front = List.rev rev_front in Some (List.hd front, { front = List.tl front ; flen = new_flen - 1 ; rear = rear ; rlen = new_rlen }) (*$T front front(cons 1 empty) = Some(1,empty) front(snoc empty 1) = Some(1,empty) *) let rear q = match q with | {rear = t :: rear; rlen = rlen; _} -> Some ({ q with rear = rear ; rlen = rlen - 1 }, t) | {front = []; _} -> None | {front = front; flen = flen; _} -> let new_rlen = (flen + 1) / 2 in let new_flen = flen / 2 in let front, rev_rear = BatList.split_at new_flen front in let rear = List.rev rev_rear in Some ({ front = front ; flen = new_flen ; rear = List.tl rear ; rlen = new_rlen - 1 }, List.hd rear) (*$T rear match rear(empty |> cons 1 |> cons 2) with | Some(_, 1) -> true | _ -> false *) let eq ?(eq=(=)) q1 q2 = (* lexicographic comparison of the lists (front1 @ rev rear1) and (front2 @ rev rear2). If front1 is a prefix of front2, then (rev rear1) is used to continue. Reversing rear lists is only used if front lists are equal. *) let rec eq_lexico front1 rear1 front2 rear2 = match front1, front2 with | [], [] -> begin match rear1, rear2 with | [], [] -> true | _::_, _::_ -> eq_lexico rear1 [] rear2 [] | _ -> false end | _::_, [] -> begin match rear2 with | [] -> false | _::_ -> eq_lexico front1 rear1 (List.rev rear2) [] end | [], _::_ -> begin match rear1 with | [] -> false | _::_ -> eq_lexico (List.rev rear1) [] front2 rear2 end | x1::front1', x2::front2' -> eq x1 x2 && eq_lexico front1' rear1 front2' rear2 in q1.flen + q1.rlen = q2.flen + q2.rlen && eq_lexico q1.front q1.rear q2.front q2.rear let rev q = { front = q.rear ; flen = q.rlen ; rear = q.front ; rlen = q.flen } (*$Q rev (Q.list Q.pos_int) (fun l -> let q = of_list l in rev q |> to_list = List.rev l) *) (*$T eq eq (empty |> cons 1 |> cons 2 |> cons 3) (rev (empty |> cons 3 |> cons 2 |> cons 1)) not (eq (empty |> cons 1 |> cons 2) (empty |> cons 2 |> cons 1)) *) let of_list l = { front = l ; flen = List.length l ; rear = [] ; rlen = 0 } (*$Q eq (Q.list Q.pos_int) ~count:20 (fun l -> eq (of_list l) (rev (of_list (List.rev l)))) *) let is_empty q = size q = 0 let append q r = if size q > size r then { q with rlen = q.rlen + size r ; rear = BatList.append r.rear (List.rev_append r.front q.rear) } else { r with flen = r.flen + size q ; front = BatList.append q.front (List.rev_append q.rear r.front) } let append_list q l = let n = List.length l in { q with rear = List.rev_append l q.rear; rlen = q.rlen + n } let prepend_list l q = let n = List.length l in { q with front = BatList.append l q.front ; flen = q.flen + n } let rotate_forward q = match front q with | Some (h, d) -> snoc d h | None -> q (*$T rotate_forward to_list (rotate_forward empty) = [] to_list (rotate_forward (of_list [1; 2; 3])) = [2; 3; 1] *) let rotate_backward q = match rear q with | Some (t, d) -> cons d t | None -> q (*$T rotate_backward to_list (rotate_backward empty) = [] to_list (rotate_backward (of_list [1; 2; 3])) = [3; 1; 2] *) let at ?(backwards=false) q n = let size_front = q.flen in let size_rear = q.rlen in if n < 0 || n >= size_rear + size_front then None else Some ( if backwards then if n < size_rear then BatList.at q.rear n else BatList.at q.front (size_front - 1 - (n - size_rear)) else if n < size_front then BatList.at q.front n else BatList.at q.rear (size_rear - 1 - (n - size_front)) ) let map f q = let rec go q r = match front q with | None -> r | Some (x, q) -> go q (snoc r (f x)) in go q empty let mapi f q = let rec go n q r = match front q with | None -> r | Some (x, q) -> go (n + 1) q (snoc r (f n x)) in go 0 q empty let iter f q = let rec go q = match front q with | None -> () | Some (x, q) -> f x ; go q in go q let iteri f q = let rec go n q = match front q with | None -> () | Some (x, q) -> f n x ; go (n + 1) q in go 0 q let rec fold_left fn acc q = match front q with | None -> acc | Some (f, q) -> fold_left fn (fn acc f) q let rec fold_right fn q acc = match rear q with | None -> acc | Some (q, r) -> fold_right fn q (fn r acc) let to_list q = BatList.append q.front (BatList.rev q.rear) let find ?(backwards=false) test q = let rec spin k f r = match f with | [] -> begin match r with | [] -> None | _ -> spin k (List.rev r) [] end | x :: f -> if test x then Some (k, x) else spin (k + 1) f r in if backwards then spin 0 q.rear q.front else spin 0 q.front q.rear let rec enum q = let cur = ref q in let next () = match front !cur with | None -> raise BatEnum.No_more_elements | Some (x, q) -> cur := q ; x in let count () = size !cur in let clone () = enum !cur in BatEnum.make ~next ~count ~clone let of_enum e = BatEnum.fold snoc empty e (*$Q enum (Q.list Q.int) (fun l -> List.of_enum (enum (List.fold_left snoc empty l)) = l) *)(*$Q of_enum (Q.list Q.int) (fun l -> to_list (of_enum (List.enum l)) = l) *) let print ?(first="[") ?(last="]") ?(sep="; ") elepr out dq = let rec spin dq = match front dq with | None -> () | Some (a, dq) when size dq = 0 -> elepr out a | Some (a, dq) -> elepr out a ; BatInnerIO.nwrite out sep ; spin dq in BatInnerIO.nwrite out first ; spin dq ; BatInnerIO.nwrite out last (*$Q print (Q.list Q.int) (fun l -> \ BatIO.to_string (print ~first:"<" ~last:">" ~sep:"," Int.print) (of_list l) \ = BatIO.to_string (List.print ~first:"<" ~last:">" ~sep:"," Int.print) l) *) batteries-included-3.4.0/src/batDeque.mli000066400000000000000000000134011415601150500203060ustar00rootroot00000000000000(* * Deque -- functional double-ended queues * Copyright (C) 2011 Batteries Included Development Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Functional double-ended queues *) type +'a dq (** The type of double-ended queues *) type 'a t = 'a dq (** A synonym for convenience *) include BatEnum.Enumerable with type 'a enumerable = 'a t include BatInterfaces.Mappable with type 'a mappable = 'a t val size : 'a dq -> int (** [size dq] is the number of elements in the [dq]. O(1) *) (** {6 Construction} *) val empty : 'a dq (** The empty deque. *) val cons : 'a -> 'a dq -> 'a dq (** [cons x dq] adds [x] to the front of [dq]. O(1) *) val snoc : 'a dq -> 'a -> 'a dq (** [snoc x dq] adds [x] to the rear of [dq]. O(1) *) (** {6 Deconstruction} *) val front : 'a dq -> ('a * 'a dq) option (** [front dq] returns [Some (x, dq')] iff [x] is at the front of [dq] and [dq'] is the rest of [dq] excluding [x], and [None] if [dq] has no elements. O(1) amortized, O(n) worst case *) val rear : 'a dq -> ('a dq * 'a) option (** [rear dq] returns [Some (dq', x)] iff [x] is at the rear of [dq] and [dq'] is the rest of [dq] excluding [x], and [None] if [dq] has no elements. O(1) amortized, O(n) worst case *) (** {6 Basic operations} *) val eq : ?eq:('a -> 'a -> bool) -> 'a dq -> 'a dq -> bool (** [eq dq1 dq2] is true if [dq1] and [dq2] have the same sequence of elements. A custom function can be optionally provided with the [eq] parameter (default is {!Pervasives.(=)}). @since 2.2.0 *) val rev : 'a dq -> 'a dq (** [rev dq] reverses [dq]. O(1) *) val is_empty : 'a dq -> bool (** [is_empty dq] returns [true] iff [dq] has no elements. O(1) *) val at : ?backwards:bool -> 'a dq -> int -> 'a option (** [at ~backwards dq k] returns the [k]th element of [dq], from the front if [backwards] is false, and from the rear if [backwards] is true. By default, [backwards = false]. O(n) *) val map : ('a -> 'b) -> 'a dq -> 'b dq (** [map f dq] returns a deque where every element [x] of [dq] has been replaced with [f x]. O(n) *) val mapi : (int -> 'a -> 'b) -> 'a dq -> 'b dq (** [mapi f dq] returns a deque where every element [x] of [dq] has been replaced with [f n x], where [n] is the position of [x] from the front of [dq]. O(n) *) val iter : ('a -> unit) -> 'a dq -> unit (** [iter f dq] calls [f x] on each element [x] of [dq]. O(n) *) val iteri : (int -> 'a -> unit) -> 'a dq -> unit (** [iteri f dq] calls [f n x] on each element [x] of [dq]. The first argument to [f] is the position of the element from the front of [dq]. O(n) *) val find : ?backwards:bool -> ('a -> bool) -> 'a dq -> (int * 'a) option (** [find ~backwards f dq] returns [Some (n, x)] if [x] at position [n] is such that [f x] is true, or [None] if there is no such element. The position [n] is from the rear if [backwards] is true, and from the front if [backwards] is [false]. By default, [backwards] is [false]. O(n) *) val fold_left : ('acc -> 'a -> 'acc) -> 'acc -> 'a dq -> 'acc (** [fold_left f acc dq] is equivalent to [List.fold_left f acc (to_list dq)], but more efficient. O(n) *) val fold_right : ('a -> 'acc -> 'acc) -> 'a dq -> 'acc -> 'acc (** [fold_right f dq acc] is equivalent to [List.fold_right f (to_list dq) acc], but more efficient. O(n) *) val append : 'a dq -> 'a dq -> 'a dq (** [append dq1 dq2] represents the concatenateion of [dq1] and [dq2]. O(min(m, n))*) val append_list : 'a dq -> 'a list -> 'a dq (** [append_list dq l] is equivalent to [append dq (of_list l)], but more efficient. O(min(m, n)) *) val prepend_list : 'a list -> 'a dq -> 'a dq (** [prepend_list l dq] is equivalent to [append (of_list l) dq], but more efficient. O(min(m, n)) *) val rotate_forward : 'a dq -> 'a dq (** A cyclic shift of deque elements from rear to front by one position. As a result, the front element becomes the rear element. Time: O(1) amortized, O(n) worst-case. @since 2.3.0 *) val rotate_backward : 'a dq -> 'a dq (** A cyclic shift of deque elements from front to rear by one position. As a result, the rear element becomes the front element. Time: O(1) amortized, O(n) worst-case. @since 2.3.0 *) (** {6 Transformation} *) val of_list : 'a list -> 'a dq (** [of_list l] is a deque representation of the elements of [l]. O(n) *) val to_list : 'a dq -> 'a list (** [to_list dq] is a list representation of the elements of [dq]. O(n) *) val of_enum : 'a BatEnum.t -> 'a dq (** [of_enum e] is a deque representation of the elements of [e]. Consumes the enumeration [e]. O(n) *) val enum : 'a dq -> 'a BatEnum.t (** [enum dq] is an enumeration of the elements of [dq] from the front to the rear. This function is O(1), but generating each element of the enumeration is amortized O(1), and O(n) worst case. *) (** {6 Printing} *) val print : ?first:string -> ?last:string -> ?sep:string -> ('a, 'b) BatIO.printer -> ('a dq, 'b) BatIO.printer (** Print the contents of the deque. O(n) *) (**/**) val invariants : _ t -> unit (**/**) batteries-included-3.4.0/src/batDigest.mli000066400000000000000000000071311415601150500204650ustar00rootroot00000000000000(* * BatDigest - Additional functions for MD5 message digests * Copyright (C) 1996 Xavier Leroy, INRIA Rocquencourt * Copyright (C) 2009 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** MD5 message digest. This module provides functions to compute 128-bit ``digests'' of arbitrary-length strings or files. The digests are of cryptographic quality: it is very hard, given a digest, to forge a string having that digest. The algorithm used is MD5. @author Xavier Leroy (Base module) @author David Rajchenbach-Teller *) open BatIO type t = string (** The type of digests: 16-character strings. *) val string : string -> t (** Return the digest of the given string. *) val bytes : Bytes.t -> t (** Return the digest of the given byte sequence. @since 2.3.0 *) val substring : string -> int -> int -> t (** [Digest.substring s ofs len] returns the digest of the substring of [s] starting at character number [ofs] and containing [len] characters. *) val subbytes : Bytes.t -> int -> int -> t (** [Digest.subbytes s ofs len] returns the digest of the subsequence of [s] starting at index [ofs] and containing [len] bytes. @since 2.3.0 *) val file : string -> t (** Return the digest of the file whose name is given. *) val to_hex : t -> string (** Return the printable hexadecimal representation of the given digest. *) val from_hex : string -> t (** Convert a hexadecimal representation back into the corresponding digest. @raise Invalid_argument if the argument is not exactly 32 hexadecimal characters. @since 4.00.0 *) val channel : input -> int -> Digest.t (** If [len] is nonnegative, [Digest.channel ic len] reads [len] characters from channel [ic] and returns their digest, or @raise End_of_file if end-of-file is reached before [len] characters are read. If [len] is negative, [Digest.channel ic len] reads all characters from [ic] until end-of-file is reached and return their digest. {b Note} This version of [channel] is currently very inefficient if [len] < 0 and requires copying the whole input to a temporary file. *) val output : 'a output -> t -> unit (** Write a digest on the given output. *) val print : 'a output -> Digest.t -> unit (** Write a digest on the given output in hexadecimal. *) val input : input -> Digest.t (** Read a digest from the given input. *) val compare : t -> t -> int (** The comparison function for 16-character digest, with the same specification as {!Pervasives.compare} and the implementation shared with {!String.compare}. Along with the type [t], this function [compare] allows the module [Digest] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. @since Batteries 2.0 *) val equal : t -> t -> bool (** The equal function for digests. @since 2.5.0 *) batteries-included-3.4.0/src/batDigest.mlv000066400000000000000000000057401415601150500205060ustar00rootroot00000000000000(* * BatDigest - Additional functions for message digests * Copyright (C) 1996 Xavier Leroy, INRIA Rocquencourt * Copyright (C) 2009 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) include Digest (*Imported from [Digest.input] -- the functions used take advantage of [BatIO.input] rather than [in_channel]*) let input inp = BatIO.really_nread inp 16 (*$T let digest = Digest.string "azerty" in \ input (BatIO.input_string digest) = digest *) let output = BatIO.nwrite let print oc t = BatIO.nwrite oc (to_hex t) let channel inp len = (*TODO: Make efficient*) if len >= 0 then Digest.string (BatIO.really_nread inp len) else Digest.channel (BatIO.to_input_channel inp) len (*$T let digest = Digest.string "azerty" in \ channel (BatIO.input_string ("azertyuiop")) 6 = digest *) (*1. Compute the digest of this file using Legacy.Digest*) (*2. Compute the digest of this file using Batteries.Digest*) (*3. Compare*) (*$R channel let legacy_result () = let inp = Pervasives.open_in_bin Sys.argv.(0) in let result = Legacy.Digest.channel inp (-1) in Pervasives.close_in inp; result in let batteries_result () = let inp = BatFile.open_in Sys.argv.(0) in let result = channel inp (-1) in BatIO.close_in inp; result in assert_equal ~printer:(Printf.sprintf "%S") (legacy_result ()) (batteries_result ()) *) let from_hex s = if String.length s <> 32 then invalid_arg "Digest.from_hex"; let digit c = match c with | '0'..'9' -> Char.code c - Char.code '0' | 'A'..'F' -> Char.code c - Char.code 'A' + 10 | 'a'..'f' -> Char.code c - Char.code 'a' + 10 | _ -> invalid_arg "Digest.from_hex" in let byte i = digit s.[i] lsl 4 + digit s.[i+1] in BatBytesCompat.string_init 16 (fun i -> Char.chr (byte (2 * i))) (*$Q Q.string (fun s -> \ let h = string s in h |> to_hex |> from_hex = h) *) let compare = String.compare ##V<4.2##let bytes = string ##V<4.2##let subbytes = substring ##V<4.3##let equal d1 d2 = (compare d1 d2 = 0) (*$T equal (string "foo") (string "foo") equal (string "") (string "") not @@ equal (string "foo") (string "bar") not @@ equal (string "foo") (string "foo\000") not @@ equal (string "foo") (string "") *) batteries-included-3.4.0/src/batDllist.ml000066400000000000000000000225131415601150500203310ustar00rootroot00000000000000(* * Dllist- a mutable, circular, doubly linked list library * Copyright (C) 2004 Brian Hurt, Jesse Guardiani * Copyright (C) 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type 'a node_t = { mutable data : 'a; mutable next : 'a node_t; mutable prev : 'a node_t } type 'a enum_t = { mutable curr : 'a node_t; mutable valid : bool } type 'a t = 'a node_t type 'a mappable = 'a t type 'a enumerable = 'a t exception Empty let invariants t = assert (t.next.prev == t && t.prev.next == t); let current = ref t.next in while !current != t do let t = !current in assert (t.next.prev == t && t.prev.next == t); current := t.next done let create x = let rec nn = { data = x; next = nn; prev = nn} in nn let length node = let rec loop cnt n = if n == node then cnt else loop (cnt + 1) n.next in loop 1 node.next let add node elem = let nn = { data = elem; next = node.next; prev = node } in node.next.prev <- nn; node.next <- nn (*$T add let t = of_list [1;2;3] in add t 12; invariants t; to_list t = [1;12;2;3] let t = of_list [1] in add t 2; invariants t; to_list t = [1;2] *) let append node elem = let nn = { data = elem; next = node.next; prev = node } in node.next.prev <- nn; node.next <- nn; nn let prepend node elem = let nn = { data = elem; next = node; prev = node.prev } in node.prev.next <- nn; node.prev <- nn; nn let promote node = let next = node.next in let prev = node.prev in if next != prev then begin next.next.prev <- node; node.next <- next.next; node.prev <- next; next.next <- node; next.prev <- prev; prev.next <- next end (*$T promote let t = of_list [1;2;3;4] in promote t; invariants t; to_list t = [1;3;4;2] let t = of_list [1] in promote t; invariants t; to_list t = [1] *) let demote node = let next = node.next in let prev = node.prev in if next != prev then begin prev.prev.next <- node; node.prev <- prev.prev; node.next <- prev; prev.prev <- node; prev.next <- next; next.prev <- prev end (*$T demote let t = of_list [1;2;3;4] in demote t; invariants t; to_list t = [1;4;2;3] let t = of_list [1] in demote t; invariants t; to_list t = [1] *) let remove node = let next = node.next in if next == node then raise Empty; (* singleton list points to itself for next *) let prev = node.prev in (* Remove node from list by linking prev and next together *) prev.next <- next; next.prev <- prev; (* Make node a singleton list by setting its next and prev to itself *) node.next <- node; node.prev <- node (*$T remove let t = of_list [1;2;3;4] in let u = next t in remove t; invariants u; to_list u = [2;3;4] let t = of_list [1;2] in let u = next t in remove t; invariants u; to_list u = [2] let t = of_list [1;2] in let u = next t in remove t; try remove u; false with Empty -> true let t = of_list [1] in try remove t; false with Empty -> true *) let drop node = let next = node.next in if next == node then raise Empty; (* singleton list points to itself for next *) let prev = node.prev in prev.next <- next; next.prev <- prev; node.next <- node; node.prev <- node; next (*$T drop let t = of_list [1;2;3;4] in let t = drop t in invariants t; to_list t = [2;3;4] let t = of_list [1] in try ignore (drop t); false with Empty -> true *) let rev_drop node = let next = node.next in if next == node then raise Empty; (* singleton list points to itself for next *) let prev = node.prev in prev.next <- next; next.prev <- prev; node.next <- node; node.prev <- node; prev (*$T rev_drop let t = of_list [1;2;3;4] in let t = rev_drop t in invariants t; to_list t = [4;2;3] let t = of_list [1] in try ignore (rev_drop t); false with Empty -> true *) let splice node1 node2 = let next = node1.next in let prev = node2.prev in node1.next <- node2; node2.prev <- node1; next.prev <- prev; prev.next <- next let set node data = node.data <- data let get node = node.data let next node = node.next let prev node = node.prev let skip node idx = let f = if idx > 0 then next else prev in let rec loop idx n = if idx == 0 then n else loop (idx - 1) (f n) in loop (abs idx) node let rev node = let rec loop next n = begin let prev = n.prev in n.next <- prev; n.prev <- next; if n != node then loop n prev end in loop node node.prev (*$T rev let t = of_list [1] in rev t; invariants t; to_list t = [1] let t = of_list [1;2;3;4] in rev t; invariants t; to_list t = [1;4;3;2] *) let iter f node = let () = f node.data in let rec loop n = if n != node then let () = f n.data in loop n.next in loop node.next let for_all p node = let rec loop n = if n == node then true else p n.data && loop n.next in p node.data && loop node.next let find p node = let rec loop n = if n == node then raise Not_found else if p n.data then n else loop n.next in if p node.data then node else loop node.next (*$T find find (fun x -> x mod 2 = 0) (of_list [1;3;4;5;7;6]) |> get = 4 find (fun x -> x = 1) (of_list [1;3;4;5;7;6]) |> get = 1 find (fun x -> x > 3) (of_list [-1;3;9;1;1;1]) |> get = 9 try find (fun x -> x land 3 = 2) (of_list [1;4;3])|>ignore; false with Not_found -> true *) (*qtest TODO: migrate try into an exception test *) let exists p node = let rec loop n = if n == node then false else p n.data || loop n.next in p node.data || loop node.next let fold_left f init node = let rec loop accu n = if n == node then accu else loop (f accu n.data) n.next in loop (f init node.data) node.next let fold_right f node init = let rec loop accu n = if n == node then f n.data accu else loop (f n.data accu) n.prev in loop init node.prev let map f node = let first = create (f node.data) in let rec loop last n = if n == node then begin first.prev <- last; first end else begin let nn = { data = f n.data; next = first; prev = last } in last.next <- nn; loop nn n.next end in loop first node.next let copy node = map (fun x -> x) node let to_list node = fold_right (fun d l -> d::l) node [] let of_list lst = match lst with | [] -> raise Empty | h :: t -> let first = create h in let rec loop last = function | [] -> last.next <- first; first.prev <- last; first | h :: t -> let nn = { data = h; next = first; prev = last } in last.next <- nn; loop nn t in loop first t (*$T try ignore (of_list []); false with Empty -> true *) let enum node = let next e () = if not e.valid then raise BatEnum.No_more_elements else begin let rval = e.curr.data in e.curr <- e.curr.next; if (e.curr == node) then e.valid <- false; rval end and count e () = if not e.valid then 0 else let rec loop cnt n = if n == node then cnt else loop (cnt + 1) (n.next) in loop 1 (e.curr.next) in let rec clone e () = let e' = { curr = e.curr; valid = e.valid } in BatEnum.make ~next:(next e') ~count:(count e') ~clone:(clone e') in let e = { curr = node; valid = true } in BatEnum.make ~next:(next e) ~count:(count e) ~clone:(clone e) let rev_enum node = let prev e () = if not e.valid then raise BatEnum.No_more_elements else begin let rval = e.curr.data in e.curr <- e.curr.prev; if (e.curr == node) then e.valid <- false; rval end and count e () = if not e.valid then 0 else let rec loop cnt n = if n == node then cnt else loop (cnt + 1) (n.prev) in loop 1 (e.curr.prev) in let rec clone e () = let e' = { curr = e.curr; valid = e.valid } in BatEnum.make ~next:(prev e') ~count:(count e') ~clone:(clone e') in let e = { curr = node; valid = true } in BatEnum.make ~next:(prev e) ~count:(count e) ~clone:(clone e) let backwards t = rev_enum (prev t) let of_enum enm = match BatEnum.get enm with | None -> raise Empty | Some(d) -> let first = create d in let f n d = append n d in ignore(BatEnum.fold f first enm); first let print ?(first="[") ?(last="]") ?(sep="; ") print_a out t = BatEnum.print ~first ~last ~sep print_a out (enum t) let filter f node = (*TODO : make faster*) of_enum (BatEnum.filter f (enum node)) let filter_map f node = (*TODO : make faster*) of_enum (BatEnum.filter_map f (enum node)) batteries-included-3.4.0/src/batDllist.mli000066400000000000000000000207661415601150500205120ustar00rootroot00000000000000(* * Dllist- a mutable, circular, doubly linked list library * Copyright (C) 2004 Brian Hurt, Jesse Guardiani * Copyright (C) 2009 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** A mutable, imperative, circular, doubly linked list library This module implements a doubly linked list in a mutable or imperitive style (changes to the list are visible to all copies of the list). {b Note} This implementation of doubly-linked lists does not support empty lists. @author Brian Hurt @author Jesse Guardiani @author David Teller *) type 'a node_t (* abstract *) type 'a t = 'a node_t (*For uniformity*) (** The type of a non-empty doubly-linked list. *) include BatInterfaces.Mappable with type 'a mappable = 'a t include BatEnum.Enumerable with type 'a enumerable = 'a t exception Empty (** {6 node functions } *) (** Creates a node. This is an O(1) operation. *) val create : 'a -> 'a node_t (** Copy the list attached to the given node and return the copy of the given node. This is an O(N) operation. *) val copy : 'a node_t -> 'a node_t (** Returns the length of the list. This is an O(N) operation. *) val length : 'a node_t -> int (** List reversal. This is an O(N) operation. The given node still points to the same element, so [to_list (rev (of_list [1;2;3;4])) = [1;4;3;2]] *) val rev : 'a node_t -> unit (** [add n a] Creates a new node containing data [a] and inserts it into the list after node [n]. This is an O(1) operation. *) val add : 'a node_t -> 'a -> unit (** [append n a] Creates a new node containing data [a] and inserts it into the list after node [n]. Returns new node. This is an O(1) operation. *) val append : 'a node_t -> 'a -> 'a node_t (** [prepend n a] Creates a new node containing data [a] and inserts it into the list before node [n]. Returns new node. This is an O(1) operation. *) val prepend : 'a node_t -> 'a -> 'a node_t (** [promote n] Swaps [n] with [next n]. This is an O(1) operation. *) val promote : 'a node_t -> unit (** [demote n] Swaps [n] with [prev n]. This is an O(1) operation. *) val demote : 'a node_t -> unit (** Remove node from the list no matter where it is. This is an O(1) operation. @raise Empty when trying to remove an element from a list of length one. *) val remove : 'a node_t -> unit (** Remove node from the list no matter where it is. Return next node. This is an O(1) operation. @raise Empty when trying to remove an element from a list of length one. *) val drop : 'a node_t -> 'a node_t (** Remove node from the list no matter where it is. Return previous node. This is an O(1) operation. @raise Empty when trying to remove an element from a list of length one. *) val rev_drop : 'a node_t -> 'a node_t (** [splice n1 n2] Connects [n1] and [n2] so that [next n1 == n2 && prev n2 == n1]. This can be used to connect two discrete lists, or, if used on two nodes within the same list, it can be used to separate the nodes between [n1] and [n2] from the rest of the list. In this case, those nodes become a discrete list by themselves. This is an O(1) operation. *) val splice : 'a node_t -> 'a node_t -> unit (** Given a node, get the data associated with that node. This is an O(1) operation. *) val get : 'a node_t -> 'a (** Given a node, set the data associated with that node. This is an O(1) operation. *) val set : 'a node_t -> 'a -> unit (** Given a node, get the next element in the list after the node. The list is circular, so the last node of the list returns the first node of the list as it's next node. This is an O(1) operation. *) val next : 'a node_t -> 'a node_t (** Given a node, get the previous element in the list before the node. The list is circular, so the first node of the list returns the last element of the list as it's previous node. This is an O(1) operation. *) val prev : 'a node_t -> 'a node_t (** [skip n i] Return the node that is [i] nodes after node [n] in the list. If [i] is negative then return the node that is [i] nodes before node [n] in the list. This is an O(N) operation. *) val skip : 'a node_t -> int -> 'a node_t (** [iter f n] Apply [f] to every element in the list, starting at [n]. This is an O(N) operation. *) val iter : ('a -> unit) -> 'a node_t -> unit (** Accumulate a value over the entire list. This works like List.fold_left. This is an O(N) operation. *) val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b node_t -> 'a (** Accumulate a value over the entire list. This works like List.fold_right, but since the list is bidirectional, it doesn't suffer the performance problems of List.fold_right. This is an O(N) operation. *) val fold_right : ('a -> 'b -> 'b) -> 'a node_t -> 'b -> 'b val find : ('a -> bool) -> 'a node_t -> 'a node_t (** [find p l] returns the first element, [l] or after, for which [p] returns true. @raise Not_found if no such element exists @added 1.4.0 *) val for_all : ('a -> bool) -> 'a node_t -> bool (** Test whether a given predicate returns true for all members of the given list. O(N) *) val exists : ('a -> bool) -> 'a node_t -> bool (** Test whether there exists an element of the given list for which the predicate returns true. O(N) *) val map : ('a -> 'b) -> 'a node_t -> 'b node_t (** Allocate a new list, with entirely new nodes, whose values are the transforms of the values of the original list. Note that this does not modify the given list. This is an O(N) operation. *) val filter : ('a -> bool) -> 'a node_t -> 'a node_t (** [filter p l] returns a new list, with entirely new nodes, whose values are all the elements of the list [l] that satisfy the predicate [p]. The order of the elements in the input list is preserved. @raise Empty if the resulting list is empty.*) val filter_map : ('a -> 'b option) -> 'a node_t -> 'b node_t (** [filter_map f l] calls [(f a0) (f a1) ... (f an)] where [a0,a1...an] are the elements of [l]. It returns a new list of elements [bi] such as [f ai = Some bi] (when [f] returns [None], the corresponding element of [l] is discarded). @raise Empty if the resulting list is empty.*) (** {6 list conversion } *) (** Converts a dllist to a normal list. This is an O(N) operation. *) val to_list : 'a node_t -> 'a list (** Converts from a normal list to a Dllist and returns the first node. @raise Empty if given list is empty. This is an O(N) operation. *) val of_list : 'a list -> 'a node_t (** {6 enums } *) (** Create an enum of the list. Note that modifying the list while the enum exists will have undefined effects. This is an O(1) operation. *) val enum : 'a node_t -> 'a BatEnum.t (** Create a reverse enum of the list. The enumeration starts with the current element of the list: [rev_enum (of_list [1;2;3;4])] will generate the enumeration [[1;4;3;2]]. If you want it to start with the last one, see [backwards]. Note that modifying the list while the enum exists will have undefined effects. This is an O(1) operation. *) val rev_enum : 'a node_t -> 'a BatEnum.t val backwards : 'a node_t -> 'a BatEnum.t (** [backwards t] is similar to [rev_enum t] except that the enumeration starts at the node before the current one: [backwards (of_list [1;2;3;4])] will generate the enumeration [[4;3;2;1]]. *) (** Create a dllist from an enum. This consumes the enum, and allocates a whole new dllist. @raise Empty if given enum is empty. This is an O(N) operation. *) val of_enum : 'a BatEnum.t -> 'a node_t (** {6 Boilerplate code}*) (** {7 Printing}*) val print : ?first:string -> ?last:string -> ?sep:string ->('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> 'b t -> unit (**/**) val invariants : _ t -> unit (**/**) batteries-included-3.4.0/src/batDynArray.ml000066400000000000000000001146551415601150500206400ustar00rootroot00000000000000(* * DynArray - Resizeable Ocaml arrays * Copyright (C) 2003 Brian Hurt * Copyright (C) 2003 Nicolas Cannasse * Copyright (C) 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type resizer_t = currslots:int -> oldlength:int -> newlength:int -> int type 'a intern external ilen : 'a intern -> int = "%obj_size" let idup (x : 'a intern) : 'a intern = Obj.magic (Obj.dup (Obj.repr x)) let imake len = (Obj.magic (Obj.new_block 0 len) : 'a intern) external iget : 'a intern -> int -> 'a = "%obj_field" external iset : 'a intern -> int -> 'a -> unit = "%obj_set_field" type 'a t = { mutable arr : 'a intern; mutable len : int; mutable resize: resizer_t; } let dummy_for_gc = Obj.magic 0 let bool_invariants t = t.len >= 0 && t.len <= ilen t.arr && (* check that elements beyond t.len are free'd, no memory leak *) let rec check i = if i >= ilen t.arr - 1 then true else iget t.arr i == dummy_for_gc && check (i+1) in check t.len let invariants t = assert (bool_invariants t) type 'a mappable = 'a t type 'a enumerable = 'a t exception Invalid_arg of int * string * string let invalid_arg n f p = raise (Invalid_arg (n,f,p)) let length d = d.len let exponential_resizer ~currslots ~oldlength:_ ~newlength = let rec doubler x = if x >= newlength then x else doubler (x * 2) in let rec halfer x = if x / 2 < newlength then x else halfer (x / 2) in if newlength = 1 then 1 else if currslots = 0 then doubler 1 else if currslots < newlength then doubler currslots else halfer currslots let step_resizer step = if step <= 0 then invalid_arg step "step_resizer" "step"; (fun ~currslots ~oldlength:_ ~newlength -> if currslots < newlength || newlength < (currslots - step) then (newlength + step - (newlength mod step)) else currslots) let conservative_exponential_resizer ~currslots ~oldlength ~newlength = let rec doubler x = if x >= newlength then x else doubler (x * 2) in let rec halfer x = if x / 2 < newlength then x else halfer (x / 2) in if currslots < newlength then begin if newlength = 1 then 1 else if currslots = 0 then doubler 1 else doubler currslots end else if oldlength < newlength then halfer currslots else currslots let default_resizer = conservative_exponential_resizer let changelen (d : 'a t) newlen = let oldsize = ilen d.arr in let r = d.resize ~currslots:oldsize ~oldlength:d.len ~newlength:newlen in (* We require the size to be at least large enough to hold the number * of elements we know we need! *) let newsize = if r < newlen then newlen else r in if newsize <> oldsize then begin let newarr = imake newsize in let cpylen = (if newlen < d.len then newlen else d.len) in for i = 0 to cpylen - 1 do iset newarr i (iget d.arr i); done; d.arr <- newarr; end; d.len <- newlen let compact d = if d.len <> ilen d.arr then begin let newarr = imake d.len in for i = 0 to d.len - 1 do iset newarr i (iget d.arr i) done; d.arr <- newarr; end let create_with resize= { resize; len=0; arr=imake 0; } (*$Q (Q.list Q.small_int) (fun l -> \ let v = create_with exponential_resizer in List.iter (add v) l; \ bool_invariants v) (Q.list Q.small_int) (fun l -> \ let v = create_with conservative_exponential_resizer in List.iter (add v) l; \ bool_invariants v) (Q.list Q.small_int) (fun l -> \ let v = create_with (step_resizer 5) in List.iter (add v) l; \ bool_invariants v) *) let create() = { resize = default_resizer; len = 0; arr = imake 0; } (*$Q (Q.list Q.small_int) (fun l -> \ let v = create() in List.iter (add v) l; \ bool_invariants v) *) let singleton x = let a = { resize = default_resizer; len = 1; arr = imake 1; } in iset a.arr 0 x; a (*$T to_list @@ singleton 42 = [42] *) let make initlen = if initlen < 0 then invalid_arg initlen "make" "size"; { resize = default_resizer; len = 0; arr = imake initlen; } let init initlen f = if initlen < 0 then invalid_arg initlen "init" "len"; let arr = imake initlen in for i = 0 to initlen-1 do iset arr i (f i) done; { resize = default_resizer; len = initlen; arr = arr; } (*$T init 5 identity |> to_list = [0;1;2;3;4] *) let set_resizer d resizer = d.resize <- resizer let get_resizer d = d.resize let empty d = d.len = 0 let get d idx = if idx < 0 || idx >= d.len then invalid_arg idx "get" "index"; iget d.arr idx let set d idx v = if idx < 0 || idx >= d.len then invalid_arg idx "set" "index"; iset d.arr idx v (* upd a i f = set a i (f @@ get a i) Faster (avoids duplication of bounds checks) and more convenient. *) let upd d idx f = if idx < 0 || idx >= d.len then invalid_arg idx "set" "index"; iset d.arr idx (f @@ iget d.arr idx) let first d = if d.len = 0 then invalid_arg 0 "first" ""; iget d.arr 0 let last d = if d.len = 0 then invalid_arg 0 "last" ""; iget d.arr (d.len - 1) (*$T let v = of_list [1;2;3;4] in set v 1 42; get v 1 = 42 let v = of_list [1;2;3;4] in set v 1 42; last v = 4 let v = of_list [1;2;3;4] in set v 1 42; first v = 1 let v = of_list [1;2;3;4] in upd v 1 succ; get v 1 = 3 *) let left a n = if n < 0 || n > a.len then invalid_arg n "left" "len"; let arr = imake n in for i = 0 to n - 1 do iset arr i (iget a.arr i) done; { resize = a.resize; len = n; arr = arr; } let right a n = if n < 0 || n > a.len then invalid_arg n "right" "len"; let arr = imake n in (* for i = a.len - n to a.len - 1 do *) let i = ref 0 in let j = ref (a.len - n) in while !i < n do iset arr !i (iget a.arr !j); incr i; incr j; done; { resize = a.resize; len = n; arr = arr; } (*$T let v = left (of_list [1;2;3;4;5;6;7;8]) 3 in to_list v = [1;2;3] let v = right (of_list [1;2;3;4;5;6;7;8]) 3 in to_list v = [6;7;8] try let v = left (of_list [1;2;3]) 9 in ignore v; false with Invalid_arg _ -> true try let v = right (of_list [1;2;3]) 9 in ignore v; false with Invalid_arg _ -> true try let v = left (of_list [1;2;3]) (-1) in ignore v; false with Invalid_arg _ -> true try let v = right (of_list [1;2;3]) (-1) in ignore v; false with Invalid_arg _ -> true *) let head = left let tail a n = if n < 0 || n > a.len then invalid_arg n "tail" "pos"; let len = a.len - n in let arr = imake len in (* for i = n to a.len - 1 do *) let i = ref 0 in let j = ref n in while !j < a.len do iset arr !i (iget a.arr !j); incr i; incr j; done; { resize = a.resize; len = len; arr = arr; } (*$T let v = head (of_list [1;2;3;4;5;6;7;8]) 3 in to_list v = [1;2;3] let v = tail (of_list [1;2;3;4;5;6;7;8]) 3 in to_list v = [4;5;6;7;8] try let v = tail (of_list [1;2;3]) 9 in ignore v; false with Invalid_arg _ -> true try let v = tail (of_list [1;2;3]) (-1) in ignore v; false with Invalid_arg _ -> true *) let insert d idx v = if idx < 0 || idx > d.len then invalid_arg idx "insert" "index"; if d.len = ilen d.arr then changelen d (d.len + 1) else d.len <- d.len + 1; if idx < d.len - 1 then begin for i = d.len - 2 downto idx do iset d.arr (i+1) (iget d.arr i) done; end; iset d.arr idx v (*$T let v = of_list [1;2;3;4] in insert v 2 10; to_list v = [1;2;10;3;4] *) let add d v = if d.len = ilen d.arr then changelen d (d.len + 1) else d.len <- d.len + 1; iset d.arr (d.len - 1) v let delete d idx = if idx < 0 || idx >= d.len then invalid_arg idx "delete" "index"; let oldsize = ilen d.arr in (* we don't call changelen because we want to blit *) let r = d.resize ~currslots:oldsize ~oldlength:d.len ~newlength:(d.len - 1) in let newsize = (if r < d.len - 1 then d.len - 1 else r) in if oldsize <> newsize then begin let newarr = imake newsize in for i = 0 to idx - 1 do iset newarr i (iget d.arr i); done; for i = idx to d.len - 2 do iset newarr i (iget d.arr (i+1)); done; d.arr <- newarr; end else begin for i = idx to d.len - 2 do iset d.arr i (iget d.arr (i+1)); done; iset d.arr (d.len - 1) dummy_for_gc end; d.len <- d.len - 1 (*$T let v = of_list [1;2;3;4] in delete v 1; to_list v = [1;3;4] *) let remove_at idx d = delete d idx let delete_range d idx len = if len < 0 then invalid_arg len "delete_range" "length"; if idx < 0 || idx + len > d.len then invalid_arg idx "delete_range" "index"; let oldsize = ilen d.arr in (* we don't call changelen because we want to blit *) let r = d.resize ~currslots:oldsize ~oldlength:d.len ~newlength:(d.len - len) in let newsize = (if r < d.len - len then d.len - len else r) in if oldsize <> newsize then begin let newarr = imake newsize in for i = 0 to idx - 1 do iset newarr i (iget d.arr i); done; for i = idx to d.len - len - 1 do iset newarr i (iget d.arr (i+len)); done; d.arr <- newarr; end else begin for i = idx to d.len - len - 1 do iset d.arr i (iget d.arr (i+len)); done; for i = d.len - len to d.len - 1 do iset d.arr i dummy_for_gc done; end; d.len <- d.len - len (*$T let v = of_list [1;2;3;4] in delete_range v 1 2; to_list v = [1;4] let v = of_list [1;2;3;4] in delete_range v 1 0; to_list v = [1;2;3;4] let v = of_list [1;2;3;4] in try delete_range v 4 2; false \ with Invalid_arg _ -> true *) let clear d = d.len <- 0; d.arr <- imake 0 (*$T let v = of_list [1;2;3;4;5] in clear v; to_list v = [] *) let delete_last d = if d.len <= 0 then invalid_arg 0 "delete_last" ""; (* erase for GC, in case changelen don't resize our array *) iset d.arr (d.len - 1) dummy_for_gc; changelen d (d.len - 1) (*$T let v = of_list [1;2;3;4;5] in delete_last v; to_list v = [1;2;3;4] *) let blit src srcidx dst dstidx len = if len < 0 then invalid_arg len "blit" "len"; if srcidx < 0 || srcidx + len > src.len then invalid_arg srcidx "blit" "source index"; if dstidx < 0 || dstidx > dst.len then invalid_arg dstidx "blit" "dest index"; let newlen = dstidx + len in if newlen > ilen dst.arr then begin (* this case could be inlined so we don't blit on just-copied elements *) changelen dst newlen end else begin if newlen > dst.len then dst.len <- newlen; end; (* same array ! we need to copy in reverse order *) if src.arr == dst.arr && dstidx > srcidx then for i = len - 1 downto 0 do iset dst.arr (dstidx+i) (iget src.arr (srcidx+i)); done else for i = 0 to len - 1 do iset dst.arr (dstidx+i) (iget src.arr (srcidx+i)); done (*$T let v = of_list [1;2;3;4;5] and v2 = of_list [10;11] in \ blit v2 0 v 1 2; to_list v = [1;10;11;4;5] *) let append src dst = blit src 0 dst dst.len src.len (*$T let v = of_list [1;2;3;4;5] and v2 = of_list [10;11] in \ append v2 v; to_list v = [1;2;3;4;5;10;11] *) let to_list d = let rec loop idx accum = if idx < 0 then accum else loop (idx - 1) (iget d.arr idx :: accum) in loop (d.len - 1) [] let to_array d = if d.len = 0 then begin (* since the empty array is an atom, we don't care if float or not *) [||] end else begin let arr = Array.make d.len (iget d.arr 0) in for i = 1 to d.len - 1 do Array.unsafe_set arr i (iget d.arr i) done; arr; end let of_list lst = let size = List.length lst in let arr = imake size in let rec loop idx = function | h :: t -> iset arr idx h; loop (idx + 1) t | [] -> () in loop 0 lst; { resize = default_resizer; len = size; arr = arr; } let of_array src = let size = Array.length src in let is_float = Obj.tag (Obj.repr src) = Obj.double_array_tag in let arr = (if is_float then begin let arr = imake size in for i = 0 to size - 1 do iset arr i (Array.unsafe_get src i); done; arr end else (* copy the fields *) idup (Obj.magic src : 'a intern)) in { resize = default_resizer; len = size; arr = arr; } let copy src = { resize = src.resize; len = src.len; arr = idup src.arr; } (*$T let v = of_list [1;2;3] in let v2 = copy v in \ set v 0 42; get v2 0 = 1 *) let sub src start len = if len < 0 then invalid_arg len "sub" "len"; if start < 0 || start + len > src.len then invalid_arg start "sub" "start"; let arr = imake len in for i = 0 to len - 1 do iset arr i (iget src.arr (i+start)); done; { resize = src.resize; len = len; arr = arr; } (*$T let v = of_list [1;2;3;4;5] in \ let v2 = sub v 1 3 in to_list v2 = [2;3;4] let v = of_list [1;2;3;4;5] in \ let v2 = sub v 0 1 in to_list v2 = [1] let v = of_list [1;2;3;4;5] in \ let v2 = sub v 4 1 in to_list v2 = [5] let v = of_list [1;2;3;4;5] in \ let v2 = sub v 2 0 in to_list v2 = [] let v = of_list [1;2;3;4;5] in \ try ignore @@ sub v (-1) 2; false with Invalid_arg _ -> true let v = of_list [1;2;3;4;5] in \ try ignore @@ sub v 5 2; false with Invalid_arg _ -> true let v = of_list [1;2;3;4;5] in \ try ignore @@ sub v 3 3; false with Invalid_arg _ -> true let v = of_list [1;2;3;4;5] in \ try ignore @@ sub v 3 (-1); false with Invalid_arg _ -> true *) let fill a start len x = if len < 0 then invalid_arg len "fill" "len"; if start < 0 || start+len > a.len then invalid_arg start "fill" "start"; for i = start to start + len - 1 do iset a.arr i x done (*$T let v = of_list [1;2;3;4;5] in \ fill v 1 3 0; to_list v = [1;0;0;0;5] let v = of_list [1;2;3;4;5] in \ fill v 0 1 0; to_list v = [0;2;3;4;5] let v = of_list [1;2;3;4;5] in \ fill v 4 1 0; to_list v = [1;2;3;4;0] let v = of_list [1;2;3;4;5] in \ fill v 2 0 0; to_list v = [1;2;3;4;5] let v = of_list [1;2;3;4;5] in \ try fill v (-1) 2 0; false with Invalid_arg _ -> true let v = of_list [1;2;3;4;5] in \ try fill v 5 2 0; false with Invalid_arg _ -> true let v = of_list [1;2;3;4;5] in \ try fill v 3 3 0; false with Invalid_arg _ -> true let v = of_list [1;2;3;4;5] in \ try fill v 3 (-1) 0; false with Invalid_arg _ -> true let v = of_list [1;2;3;4;5] in \ try fill v (-1) 2 0; false with Invalid_arg _ -> true let v = of_list [1;2;3;4;5] in \ try fill v 5 2 0; false with Invalid_arg _ -> true let v = of_list [1;2;3;4;5] in \ try fill v 3 3 0; false with Invalid_arg _ -> true let v = of_list [1;2;3;4;5] in \ try fill v 3 (-1) 0; false with Invalid_arg _ -> true *) let split a = let n = a.len in let left = make n in let right = make n in for i = 0 to n-1 do let a,b = iget a.arr i in iset left.arr i a; iset right.arr i b done; left.len <- n; right.len <- n; (left, right) (*$T let v = of_list [] in let l,r = split v in \ (to_list l, to_list r) = ([], []) let v = of_list [(1,"a");(2,"b");(3,"c")] in let l,r = split v in \ (to_list l, to_list r) = ([1;2;3], ["a";"b";"c"]) *) let combine a1 a2 = if a1.len <> a2.len then invalid_arg a1.len "DynArray.combine" "array lengths differ"; let arr = imake a1.len in for i = 0 to a1.len - 1 do iset arr i (iget a1.arr i, iget a2.arr i) done; { resize = a1.resize; len = a1.len; arr = arr; } (*$T let l,r = (of_list [], of_list []) in let c = combine l r in \ to_list c = [] let l, r = (of_list [1;2;3], of_list ["a";"b";"c"]) in let c = combine l r in \ to_list c = [(1,"a");(2,"b");(3,"c")] try let l, r = (of_list [1;2;3], of_list ['a']) in \ ignore(combine l r); false \ with Invalid_arg _ -> true *) let iter f d = let i = ref 0 in while !i < d.len do f (iget d.arr !i); incr i done (*$T let v = of_list [1;2;3] and v2 = create() in \ iter (add v2) v; to_list v2 = [1;2;3] *) (* string_of_int and int_of_string seems useless but it is because if you only manipulate integers, you aren't likely to have segfaults even if the code is wrong *) (*$R iter let n = 20 in let acc = ref 0 in let d = init n (fun i -> string_of_int i) in iter (fun s -> assert (Obj.tag (Obj.repr s) = Obj.string_tag); acc := !acc + int_of_string s) d; assert_bool "iter" (!acc = (n - 1) * n / 2) *) (* checking the absence of segfault when the array shrinks *) (*$R iter let n = 40 in let d = init n (fun i -> string_of_int i) in let i = ref (-1) in iter (fun s -> assert (Obj.tag (Obj.repr s) = Obj.string_tag); incr i; if !i = 0 then for _count = 0 to n * 4 / 5 do delete_last d done ) d *) (* checking the absence of segfault when the array grows *) (*$R iter let n = 40 in let d = init n (fun i -> string_of_int i) in let i = ref (-1) in iter (fun s -> assert (Obj.tag (Obj.repr s) = Obj.string_tag); incr i; if !i = 0 then for _count = 0 to n * 4 do add d "poi" done ) d *) let iteri f d = let i = ref 0 in while !i < d.len do f !i (iget d.arr !i); incr i done (*$R iteri let n = 20 in let acc = ref 0 in let d = init n (fun i -> string_of_int i) in let i = ref (-1) in iteri (fun idx s -> assert (Obj.tag (Obj.repr s) = Obj.string_tag); incr i; assert (idx = !i); acc := !acc + int_of_string s) d; assert_bool "iteri" (!acc = (n - 1) * n / 2) *) (*$R iteri let n = 40 in let d = init n (fun i -> string_of_int i) in let i = ref (-1) in iteri (fun idx s -> assert (Obj.tag (Obj.repr s) = Obj.string_tag); incr i; assert (idx = !i); if !i = 0 then for _count = 0 to n * 4 / 5 do delete_last d done ) d *) (*$R iteri let n = 40 in let d = init n (fun i -> string_of_int i) in let i = ref (-1) in iteri (fun idx s -> assert (Obj.tag (Obj.repr s) = Obj.string_tag); incr i; assert (idx = !i); if !i = 0 then for _count = 0 to n * 4 do add d "poi" done ) d *) (* Old implementation *) (*let filter f d = let l = d.len in let dest = make l in let a2 = d.arr in let p = ref 0 in (* p is index of next unused element *) let i = ref 0 in while !i < d.len && !i < l do (* beware that the call to f might make lengthen d in which case, if we iterate on the new elements dest.array may be too short so when some elements are added, we do not iterate on them (test !i < len) if some elements are removed, we are also careful not to iterate on the removed elements (test !i < d.len) *) let x = iget a2 !i in if f x then begin iset dest.arr !p x; incr p; end; incr i done; dest.len <- !p; changelen dest !p; dest*) (* Efficient implementation using BitSet, lifted from BatArray implementation of filter *) let filter p a = let n = a.len in (* Use a bitset to store which elements will be in the final array. *) let bs = BatBitSet.create n in for i = 0 to n-1 do if p @@ iget a.arr i then BatBitSet.set bs i done; (* Allocate the final array and copy elements into it. *) let n' = BatBitSet.count bs in let j = ref 0 in init n' (fun _ -> match BatBitSet.next_set_bit bs !j with | Some i -> j := i+1; iget a.arr i | None -> (* not enough 1 bits - incorrect count? *) assert false ) (*$T filter let v = filter (fun x -> x mod 3 = 0) (of_list @@ BatList.range 1 `To 10) in \ to_list v = [3;6;9] let v = filter (fun _ -> assert false) (create()) in \ to_list v = [] *) let find_all = filter let filteri p a = let n = a.len in (* Use a bitset to store which elements will be in the final array. *) let bs = BatBitSet.create n in for i = 0 to n-1 do if p i @@ iget a.arr i then BatBitSet.set bs i done; (* Allocate the final array and copy elements into it. *) let n' = BatBitSet.count bs in let j = ref 0 in init n' (fun _ -> match BatBitSet.next_set_bit bs !j with | Some i -> j := i+1; iget a.arr i | None -> (* not enough 1 bits - incorrect count? *) assert false ) (*$T filteri let v = filteri (fun i x -> (i+x) mod 2 = 0) (of_list [1;2;3;4;0;1;2;3]) in \ to_list v = [0;1;2;3] let v = filteri (fun _ _ -> assert false) (create()) in \ to_list v = [] *) let keep f d = let result = filter f d in d.arr <- result.arr; d.len <- result.len (*$R keep let e = create () in add e "a"; add e "b"; keep ((=) "a") e; assert_equal ~printer:(fun x -> x) (get e 0) "a" *) let filter_map f d = let l = d.len in let dest = make l in (*Create the destination array with size [l]*) let a2 = d.arr in let p = ref 0 in let i = ref 0 in while !i < d.len && !i < l do (match f (iget a2 !i) with | None -> () | Some x -> begin iset dest.arr !p x; incr p; end); incr i done; dest.len <- !p; changelen dest !p; (*Trim the destination array to the right size*) dest (*$R filter_map let n = 20 in let d = init n (fun i -> string_of_int i) in let i = ref (-1) in let d = filter_map (fun s -> assert (Obj.tag (Obj.repr s) = Obj.string_tag); incr i; if !i mod 2 = 0 then Some (s ^ s) else None) d in assert_bool "filter_map" (length d = n / 2); let acc = ref true in iteri (fun idx s -> acc := (!acc && (s = string_of_int (2 * idx) ^ string_of_int (2 * idx)))) d; assert_bool "filter_map" !acc *) (*$R filter_map let n = 40 in let d = init n (fun i -> string_of_int i) in let i = ref (-1) in ignore (filter_map (fun s -> assert (Obj.tag (Obj.repr s) = Obj.string_tag); incr i; if !i = 0 then for _count = 0 to n * 4 / 5 do delete_last d done; Some s ) d) *) (*$R filter_map let n = 40 in let d = init n (fun i -> string_of_int i) in let i = ref (-1) in ignore (filter_map (fun s -> assert (Obj.tag (Obj.repr s) = Obj.string_tag); incr i; if !i = 0 then for _count = 0 to n * 4 do add d "poi" done; Some s ) d) *) let partition p a = let n = a.len in (* Use a bitset to store which elements will be in the final array. *) let bs = BatBitSet.create n in for i = 0 to n-1 do if p @@ iget a.arr i then BatBitSet.set bs i done; (* Allocate the arrays and copy elements into them. *) let n' = BatBitSet.count bs in let pos = make n' in let neg = make (n-n') in for i = 0 to n-1 do if BatBitSet.mem bs i then add pos @@ iget a.arr i else add neg @@ iget a.arr i done; (pos, neg) (*$T partition let v,w = partition (fun x -> x mod 3 = 0) (of_list @@ BatList.range 1 `To 10) in \ (to_list v, to_list w) = ([3;6;9], [1;2;4;5;7;8;10]) let v,w = partition (fun _ -> assert false) (create()) in \ empty v && empty w *) let for_all p a = let n = a.len in let rec loop i = if i = n then true else if p (iget a.arr i) then loop (succ i) else false in loop 0 (*$T for_all for_all (fun x -> x mod 2 = 0) (of_list [2;4;6]) = true for_all (fun x -> x mod 2 = 0) (of_list [2;3;6]) = false for_all (fun _ -> false) (create()) = true *) let exists p a = let n = a.len in let rec loop i = if i = n then false else if p (iget a.arr i) then true else loop (succ i) in loop 0 (*$T exists exists (fun x -> x mod 2 = 0) (of_list [1;4;5]) = true exists (fun x -> x mod 2 = 0) (of_list [1;3;5]) = false exists (fun _ -> false) (create()) = false *) let mem x a = let n = a.len in let rec loop i = if i = n then false else if x = iget a.arr i then true else loop (succ i) in loop 0 (*$T mem mem 2 (of_list [1;2;3]) = true mem 2 (create()) = false mem (ref 3) (of_list [ref 1; ref 2; ref 3]) = true *) let memq x a = let n = a.len in let rec loop i = if i = n then false else if x == iget a.arr i then true else loop (succ i) in loop 0 (*$T memq memq 2 (of_list [1;2;3]) = true memq 2 (create()) = false memq (ref 3) (of_list [ref 1; ref 2; ref 3]) = false *) let index_of p a = let rec loop i = if i = a.len then raise Not_found else if p (iget a.arr i) then i else loop (succ i) in loop 0 let findi = index_of (*$T findi findi (fun x -> x mod 3 = 0) (of_list [1;2;3;4;5;6]) = 2 try ignore @@ findi (fun x -> x mod 3 = 0) (of_list [1;2;4;5]); false \ with Not_found -> true try ignore @@ findi (fun _ -> assert false) (create()); false \ with Not_found -> true *) (* let find p a = iget a.arr (findi p a) *) let find p a = let rec loop i = if i = a.len then raise Not_found else let x = iget a.arr i in if p x then x else loop (succ i) in loop 0 (*$T find find (fun x -> x mod 3 = 0) (of_list [1;2;3;4;5;6]) = 3 try ignore @@ find (fun x -> x mod 3 = 0) (of_list [1;2;4;5]); false \ with Not_found -> true try ignore @@ find (fun _ -> assert false) (create()); false \ with Not_found -> true *) let map f src = let len = src.len in let arr = imake len in let i = ref 0 in while !i < src.len && !i < len do iset arr !i (f (iget src.arr !i)); incr i done; { resize = src.resize; len = BatInt.min len src.len; arr = arr; } (*$R map let n = 20 in let d = init n (fun i -> string_of_int i) in let i = ref (-1) in let res = map (fun s -> assert_bool "DynArray.map1" (Obj.tag (Obj.repr s) = Obj.string_tag); incr i; s ^ s) d in assert_bool "DynArray.map2" (length res = n); iteri (fun idx s -> assert_bool "DynArray.map3" (s ^ s = get res idx)) d *) (*$R map let n = 40 in let newlen = n / 5 in let d = init n (fun i -> string_of_int i) in let i = ref (-1) in let res = map (fun s -> assert (Obj.tag (Obj.repr s) = Obj.string_tag); incr i; if !i = 0 then for _count = 0 to n - 1 - newlen do delete_last d done; true ) d in assert_bool "DynArray.map4" (length res = newlen) (* could be something else if the implementation changed *) *) (*$R map let n = 40 in let d = init n (fun i -> string_of_int i) in let i = ref (-1) in let res = map (fun s -> assert (Obj.tag (Obj.repr s) = Obj.string_tag); incr i; if !i = 0 then for _count = 0 to n * 4 do add d "poi" done; true ) d in assert_bool "DynArray.map5" (length res = n) (* could be something else if the implementation changed *) *) let mapi f src = let len = src.len in let arr = imake len in let i = ref 0 in while !i < src.len && !i < len do iset arr !i (f !i (iget src.arr !i)); incr i done; { resize = src.resize; len = BatInt.min len src.len; arr = arr; } (*$R mapi let n = 20 in let d = init n (fun i -> string_of_int i) in let i = ref (-1) in let res = mapi (fun idx s -> assert_bool "DynArray.map1" (Obj.tag (Obj.repr s) = Obj.string_tag); incr i; assert_bool "DynArray.map2" (!i = idx); s ^ s) d in assert_bool "DynArray.map3" (length res = n); iteri (fun idx s -> assert_bool "DynArray.map3" (s ^ s = get res idx)) d *) (*$R mapi let n = 40 in let newlen = n / 5 in let d = init n (fun i -> string_of_int i) in let i = ref (-1) in let res = mapi (fun idx s -> assert (Obj.tag (Obj.repr s) = Obj.string_tag); incr i; assert_bool "DynArray.mapi4" (!i = idx); if !i = 0 then for _count = 0 to n - 1 - newlen do delete_last d done; true ) d in assert_bool "DynArray.mapi5" (length res = newlen) (* could be something else if the implementation changed *) *) (*$R mapi let n = 40 in let d = init n (fun i -> string_of_int i) in let i = ref (-1) in let res = mapi (fun idx s -> assert (Obj.tag (Obj.repr s) = Obj.string_tag); incr i; assert_bool "DynArray.mapi6" (!i = idx); if !i = 0 then for _count = 0 to n * 4 do add d "poi" done; true ) d in assert_bool "DynArray.mapi7" (length res = n) (* could be something else if the implementation changed *) *) let modify f a = for i = 0 to length a - 1 do iset a.arr i (f (iget a.arr i)) done (*$T modify let a = (of_list [3;2;1]) in \ modify (fun x -> x + 1) a; to_list a = [4;3;2] *) let modifyi f a = for i = 0 to length a - 1 do iset a.arr i (f i (iget a.arr i)) done (*$T modifyi let a = (of_list [3;2;1]) in \ modifyi (fun i x -> i * x) a; to_list a = [0;2;2] *) let fold_left f x a = let rec loop idx x = if idx >= a.len then x else loop (idx + 1) (f x (iget a.arr idx)) in loop 0 x let fold_right f a x = let rec loop idx x = if idx < 0 || idx >= a.len then x else loop (idx - 1) (f (iget a.arr idx) x) in loop (a.len - 1) x (*$R fold_right let n = 20 in let d = init n (fun i -> string_of_int i) in let buffer = Buffer.create 10 in let buffer2 = Buffer.create 10 in let len = fold_right (fun s count -> assert_bool "DynArray.fold_right1" (Obj.tag (Obj.repr s) = Obj.string_tag); Buffer.add_string buffer s; count + 1) d 0 in assert_bool "DynArray.fold_right2" (len = length d); List.iter (fun s -> Buffer.add_string buffer2 s) (List.rev (to_list d)); assert_bool "DynArray.fold_right3" (Buffer.contents buffer = Buffer.contents buffer2) *) (*$R fold_right let n = 40 in let newlen = n / 5 in let d = init n (fun i -> string_of_int i) in let i = ref (-1) in ignore (fold_right (fun s () -> assert (Obj.tag (Obj.repr s) = Obj.string_tag); incr i; if !i = 0 then for _count = 0 to n - 1 - newlen do delete_last d done ) d ()) *) let fold_lefti f x a = let r = ref x in for i = 0 to a.len - 1 do r := f !r i (iget a.arr i) done; !r (*$T fold_lefti fold_lefti (fun a i x -> a + i * x) 1 (of_list [2;4;5]) = 1 + 0 + 4 + 10 fold_lefti (fun a i x -> a + i * x) 1 (create()) = 1 *) let fold_righti f a x = let r = ref x in for i = a.len - 1 downto 0 do r := f i (iget a.arr i) !r done; !r (*$T fold_righti fold_righti (fun i x a -> a + i * x) (of_list [2;4;5]) 1 = 1 + 0 + 4 + 10 fold_righti (fun i x a -> a + i * x) (create()) 1 = 1 *) let reduce f a = if a.len = 0 then invalid_arg a.len "DynArray.reduce" "empty array"; let acc = ref (iget a.arr 0) in for i = 1 to a.len-1 do acc := f !acc (iget a.arr i) done; !acc (*$T reduce reduce (+) (of_list [1;2;3]) = 6 reduce (fun _ -> assert false) (of_list [1]) = 1 try reduce (fun _ _ -> ()) (create()); false \ with Invalid_arg _ -> true *) let rev a = let n = a.len - 1 in let newarr = imake (n+1) in for i = 0 to n do iset newarr i (iget a.arr (n-i)) done; { resize = a.resize; len = a.len; arr = newarr; } (*$T let a = rev (of_list [1;3;2;5]) in to_list a = [5;2;3;1] let a = rev (of_list [1;3;2;5;-1]) in to_list a = [-1;5;2;3;1] let a = rev (create()) in empty a *) let rev_in_place a = let n = a.len - 1 in let lim = a.len/2 - 1 in for i = 0 to lim do let x = iget a.arr (n-i) in iset a.arr (n-i) (iget a.arr i); iset a.arr i x done (*$T let a = of_list [1;3;2;5] in rev_in_place a; \ to_list a = [5;2;3;1] let a = of_list [1;3;2;5;-1] in rev_in_place a; \ to_list a = [-1;5;2;3;1] let a = create() in rev_in_place a; \ empty a *) let max a = reduce Pervasives.max a (*$T max (of_list [1;2;3]) = 3 max (of_list [2;3;1]) = 3 try ignore (max (create())); false \ with Invalid_arg _ -> true *) let min a = reduce Pervasives.min a (*$T min (of_list [1;2;3]) = 1 min (of_list [2;3;1]) = 1 try ignore (min (create())); false \ with Invalid_arg _ -> true *) let min_max a = let n = a.len in if n = 0 then invalid_arg a.len "DynArray.min_max" "empty array"; let mini = ref @@ iget a.arr 0 in let maxi = ref @@ iget a.arr 0 in for i = 1 to n-1 do let x = iget a.arr i in if x > !maxi then maxi := x; if x < !mini then mini := x done; (!mini, !maxi) (*$T min_max min_max (of_list [1]) = (1, 1) min_max (of_list [1;-2;10;3]) = (-2, 10) try ignore (min_max (create())); false \ with Invalid_arg _ -> true *) let sum = fold_left (+) 0 (*$T sum sum (of_list [1;2;3]) = 6 sum (of_list [0]) = 0 *) let fsum = fold_left (+.) 0. (*$T fsum fsum (of_list [1.0;2.0;3.0]) = 6.0 fsum (of_list [0.0]) = 0.0 *) let kahan_sum a = let sum = ref 0. in let err = ref 0. in let n = a.len - 1 in for i = 0 to n do let x = iget a.arr i -. !err in let new_sum = !sum +. x in err := (new_sum -. !sum) -. x; sum := new_sum +. 0.; (* this suspicious +. 0. is added to help the hand of the somewhat flaky unboxing optimizer; it hopefully won't be necessary anymore in a few OCaml versions *) done; !sum +. 0. (*$T kahan_sum kahan_sum (create()) = 0. kahan_sum (of_list [1.;2.]) = 3. let n, x = 1_000, 1.1 in \ Float.approx_equal (float n *. x) (kahan_sum (init n (fun _ -> x))) *) let avg a = (float_of_int @@ sum a) /. (float_of_int @@ length a) (*$T avg avg (of_list [1;2;3]) = 2. avg (of_list [0]) = 0. *) let favg a = (fsum a) /. (float_of_int @@ length a) (*$T favg favg (of_list [1.0; 2.0; 3.0]) = 2.0 favg (of_list [0.0]) = 0.0 *) let iter2 f a1 a2 = if a1.len <> a2.len then invalid_arg a1.len "DynArray.iter2" "array lengths differ"; for i = 0 to a1.len - 1 do f (iget a1.arr i) (iget a2.arr i); done (*$T iter2 let x = ref 0 in \ iter2 (fun a b -> x := !x + a*b) (of_list [1;2;3]) (of_list [4;-5;6]); \ !x = 12 try iter2 (fun _ _ -> ()) (of_list [1]) (of_list [1;2;3]); false \ with Invalid_arg _ -> true try iter2 (fun _ _ -> ()) (of_list [1]) (of_list []); false \ with Invalid_arg _ -> true *) let iter2i f a1 a2 = if a1.len <> a2.len then invalid_arg a1.len "DynArray.iter2i" "array lengths differ"; for i = 0 to a1.len - 1 do f i (iget a1.arr i) (iget a2.arr i); done (*$T iter2i let x = ref 0 in \ iter2i (fun i a b -> x := !x + a*b + i) (of_list [1;2;3]) (of_list [4;-5;6]); \ !x = 15 try iter2i (fun _ _ _ -> ()) (of_list [1]) (of_list [1;2;3]); false \ with Invalid_arg _ -> true try iter2i (fun _ _ _ -> ()) (of_list [1]) (of_list []); false \ with Invalid_arg _ -> true *) let for_all2 p a1 a2 = let n = a1.len in if a2.len <> n then invalid_arg a1.len "DynArray.for_all2" "array lengths differ"; let rec loop i = if i = n then true else if p (iget a1.arr i) (iget a2.arr i) then loop (succ i) else false in loop 0 (*$T for_all2 for_all2 (=) (of_list [1;2;3]) (of_list [3;2;1]) = false for_all2 (=) (of_list [1;2;3]) (of_list [1;2;3]) = true for_all2 (<>) (of_list [1;2;3]) (of_list [3;2;1]) = false try ignore (for_all2 (=) (of_list [1;2;3]) (of_list [1;2;3;4])); false \ with Invalid_arg _ -> true try ignore (for_all2 (=) (of_list [1;2]) (of_list [])); false \ with Invalid_arg _ -> true *) let exists2 p a1 a2 = let n = a1.len in if a2.len <> n then invalid_arg a1.len "DynArray.exists2" "array lengths differ"; let rec loop i = if i = n then false else if p (iget a1.arr i) (iget a2.arr i) then true else loop (succ i) in loop 0 (*$T exists2 exists2 (=) (of_list [1;2;3]) (of_list [3;2;1]) exists2 (<>) (of_list [1;2;3]) (of_list [1;2;3]) = false try ignore (exists2 (=) (of_list [1;2]) (of_list [3])); false \ with Invalid_arg _ -> true *) let map2 f a1 a2 = let n = a1.len in if a2.len <> n then invalid_arg a1.len "DynArray.map2" "array lengths differ"; init n (fun i -> f (iget a1.arr i) (iget a2.arr i)) (*$T map2 let v = map2 (-) (of_list [1;2;3]) (of_list [6;3;1]) in to_list v = [-5;-1;2] let v = map2 (-) (of_list [2;4;6]) (of_list [1;2;3]) in to_list v = [1;2;3] try ignore (map2 (-) (of_list [2;4]) (of_list [1;2;3])); false \ with Invalid_arg _ -> true try ignore (map2 (-) (of_list [2;4]) (of_list [3])); false \ with Invalid_arg _ -> true *) let map2i f a1 a2 = let n = a1.len in if a2.len <> n then invalid_arg a1.len "DynArray.map2i" "array lengths differ"; init n (fun i -> f i (iget a1.arr i) (iget a2.arr i)) (*$T map2i let v = map2i (fun i a b -> a-b + i) (of_list [1;2;3]) (of_list [6;3;1]) in to_list v = [-5;0;4] let v = map2i (fun i a b -> a-b + i) (of_list [2;4;6]) (of_list [1;2;3]) in to_list v = [1;3;5] try ignore (map2i (fun i a b -> a-b + i) (of_list [2;4]) (of_list [1;2;3])); false \ with Invalid_arg _ -> true try ignore (map2i (fun i a b -> a-b + i) (of_list [2;4]) (of_list [3])); false \ with Invalid_arg _ -> true *) let cartesian_product a1 a2 = let na = a1.len in let nb = a2.len in init (na * nb) (fun j -> let i = j / nb in (iget a1.arr i, iget a2.arr (j - i*nb)) ) (*$T cartesian_product let a = cartesian_product (of_list [1;2]) (of_list ["a";"b"]) in \ to_list a = [(1,"a"); (1,"b"); (2,"a"); (2,"b")] *) let enum d = let rec make start = let idxref = ref start in let next () = if !idxref >= d.len then raise BatEnum.No_more_elements else let retval = iget d.arr !idxref in incr idxref; retval and count () = if !idxref >= d.len then 0 else d.len - !idxref and clone () = make !idxref in BatEnum.make ~next:next ~count:count ~clone:clone in make 0 let of_enum e = if BatEnum.fast_count e then begin let c = BatEnum.count e in let arr = imake c in BatEnum.iteri (fun i x -> iset arr i x) e; { resize = default_resizer; len = c; arr = arr; } end else let d = make 0 in BatEnum.iter (add d) e; d (*$Q (Q.list Q.small_int) (fun l -> \ let v = of_list l in \ enum v |> of_enum |> to_list = l) *) let range xs = BatEnum.(--^) 0 (xs.len) module Exceptionless = struct let find p a = try Some (find p a) with Not_found -> None let findi p a = try Some (findi p a) with Not_found -> None end let unsafe_get a n = iget a.arr n let unsafe_set a n x = iset a.arr n x let unsafe_upd a n f = iset a.arr n (f @@ iget a.arr n) let print ?(first="[|") ?(last="|]") ?(sep="; ") print_a out t = BatEnum.print ~first ~last ~sep print_a out (enum t) (*$T Printf.sprintf2 "%a" (print Int.print) (of_list [1;2]) = "[|1; 2|]" Printf.sprintf2 "%a" (print Int.print) (of_list []) = "[||]" *) batteries-included-3.4.0/src/batDynArray.mli000066400000000000000000000563361415601150500210120ustar00rootroot00000000000000(* * DynArray - Resizeable Ocaml arrays * Copyright (C) 2003 Brian Hurt * Copyright (C) 2003 Nicolas Cannasse * Copyright (C) 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Dynamic arrays. A dynamic array is equivalent to an OCaml array that will resize itself when elements are added or removed, except that floats are boxed and that no initialization element is required. For all the traversal functions (iter, fold, map, etc.), what happens when the array that is being traversed is mutated is not defined. @author Brian Hurt @author Nicolas Cannasse @author David Teller (boilerplate code) @author andrepd *) type 'a t include BatEnum.Enumerable with type 'a enumerable = 'a t include BatInterfaces.Mappable with type 'a mappable = 'a t exception Invalid_arg of int * string * string (** When an operation on an array fails, [Invalid_arg] is raised. The integer is the value that made the operation fail, the first string contains the function name that has been called and the second string contains the parameter name that made the operation fail. *) (** {6 Array creation} *) val create : unit -> 'a t (** [create()] returns a new empty dynamic array. *) val make : int -> 'a t (** [make count] returns an array with some memory already allocated so up to [count] elements can be stored into it without resizing. @raise DynArray.Invalid_arg if make is called with a negative argument. *) val init : int -> (int -> 'a) -> 'a t (** [init n f] returns an array of [n] elements filled with values returned by [f 0 , f 1, ... f (n-1)]. @raise DynArray.Invalid_arg if init is called with a negative argument. *) val singleton : 'a -> 'a t (** Create an array consisting of exactly one element. @since 3.3.0 *) (** {6 Array manipulation functions} *) val get : 'a t -> int -> 'a (** [get darr idx] gets the element in [darr] at index [idx]. If [darr] has [len] elements in it, then the valid indexes range from [0] to [len-1]. @raise DynArray.Invalid_arg if called with an invalid index. *) val set : 'a t -> int -> 'a -> unit (** [set darr idx v] sets the element of [darr] at index [idx] to value [v]. The previous value is overwritten. @raise DynArray.Invalid_arg if called with an invalid index. *) val upd : 'a t -> int -> ('a -> 'a) -> unit (** [upd darr idx f] sets the element of [darr] at index [idx] to value [f (get darr idx)]). The previous value is overwritten. @raise DynArray.Invalid_arg if called with an invalid index. @since 3.3.0 *) val length : 'a t -> int (** Return the number of elements in the array. *) val empty : 'a t -> bool (** Return true if the number of elements in the array is 0. *) val first : 'a t -> 'a (** [first darr] returns the first element of [darr]. @raise DynArray.Invalid_arg if length of the array is 0. @since 3.3.0 *) val last : 'a t -> 'a (** [last darr] returns the last element of [darr]. @raise DynArray.Invalid_arg if length of the array is 0. *) val left : 'a t -> int -> 'a t (** [left r len] returns the array containing the [len] first characters of [r]. If [r] contains less than [len] characters, it returns [r]. @raise DynArray.Invalid_arg if called with an invalid index. @since 3.3.0 *) val right : 'a t -> int -> 'a t (** [right r len] returns the array containing the [len] last characters of [r]. If [r] contains less than [len] characters, it returns [r]. @raise DynArray.Invalid_arg if called with an invalid index. @since 3.3.0 *) val head : 'a t -> int -> 'a t (** Alias for {!left} @since 3.3.0 *) val tail : 'a t -> int -> 'a t (** [tail r pos] returns the array containing all but the [pos] first characters of [r]. @raise DynArray.Invalid_arg if called with an invalid index. @since 3.3.0 *) val insert : 'a t -> int -> 'a -> unit (** [insert darr idx v] inserts [v] into [darr] at index [idx]. All elements of [darr] with an index greater than or equal to [idx] have their index incremented (are moved up one place) to make room for the new element. @raise DynArray.Invalid_arg if called with an invalid index. *) val add : 'a t -> 'a -> unit (** [add darr v] appends [v] onto the end of [darr]. [v] becomes the new last element of [darr]. *) val append : 'a t -> 'a t -> unit (** [append src dst] adds all elements of [src] to the end of [dst]. *) (*val concat : 'a array list -> 'a array (** Same as [append], but concatenates a list of arrays. *)*) val delete : 'a t -> int -> unit (** [delete darr idx] deletes the element of [darr] at [idx]. All elements with an index greater than [idx] have their index decremented (are moved down one place) to fill in the hole. @raise DynArray.Invalid_arg if called with an invalid index. *) val delete_last : 'a t -> unit (** [delete_last darr] deletes the last element of [darr]. This is equivalent of doing [delete darr ((length darr) - 1)]. @raise DynArray.Invalid_arg if length of the array is 0. *) val delete_range : 'a t -> int -> int -> unit (** [delete_range darr idx len] deletes [len] elements starting at index [idx]. All elements with an index greater than [idx+len] are moved to fill in the hole. @raise DynArray.Invalid_arg if called with an invalid length or index. *) val remove_at : int -> 'a t -> unit (** Alias for [delete] with parameter order that follows [Array.remove_at]. @since 3.4.0 *) val clear : 'a t -> unit (** remove all elements from the array and resize it to 0. *) val blit : 'a t -> int -> 'a t -> int -> int -> unit (** [blit src srcidx dst dstidx len] copies [len] elements from [src] starting with index [srcidx] to [dst] starting at [dstidx]. @raise DynArray.Invalid_arg if called with an invalid length or indices. *) val compact : 'a t -> unit (** [compact darr] ensures that the space allocated by the array is minimal. *) (** {6 Array copy and conversion} *) val enum : 'a t -> 'a BatEnum.t (** [enum darr] returns the enumeration of [darr] elements. *) val of_enum : 'a BatEnum.t -> 'a t (** [of_enum e] returns an array that holds, in order, the elements of [e]. *) (* val backwards : 'a array -> 'a BatEnum.t (** Returns an enumeration of the elements of an array, from last to first. *) val of_backwards : 'a BatEnum.t -> 'a array (** Build an array from an enumeration, with the first element of the enumeration as the last element of the array and vice versa. *) *) val range : 'a t -> int BatEnum.t (** [range a] returns an enumeration of all valid indices of the given array, that is, [range a = 0 --^ ((length a) -1 )] @since 3.3.0 *) val to_list : 'a t -> 'a list (** [to_list darr] returns the elements of [darr] in order as a list. *) val of_list : 'a list -> 'a t (** [of_list lst] returns a dynamic array with the elements of [lst] in it in order. *) val to_array : 'a t -> 'a array (** [to_array darr] returns the elements of [darr] in order as an array. *) val of_array : 'a array -> 'a t (** [of_array arr] returns an array with the elements of [arr] in it in order. *) val copy : 'a t -> 'a t (** [copy a] returns a fresh copy of [a], such that no modification of [a] affects the copy, or vice versa (all new memory is allocated for the copy). *) val sub : 'a t -> int -> int -> 'a t (** [sub a start len] returns an array holding the subset of [len] elements from [a] starting with the element at index [idx]. @raise DynArray.Invalid_arg if [start] and [len] do not designate a valid subarray of [a]; that is, if [start < 0], or [len < 0], or [start + len > Array.length a]. *) val fill : 'a t -> int -> int -> 'a -> unit (** [fill a start len x] modifies the array [a] in place, storing [x] in elements number [start] to [start + len - 1]. @raise DynArray.Invalid_arg if [start] and [len] do not designate a valid subarray of [a]. @since 3.3.0 *) val split : ('a * 'b) t -> 'a t * 'b t (** [split a] converts the array of pairs [a] into a pair of arrays. @since 3.3.0 *) val combine : 'a t -> 'b t -> ('a * 'b) t (** [combine a b] converts arrays [[a0,...aN] [b0,...,bN]] into an array of pairs [[(a0,b0),...,(aN,bN)]]. @raise DynArray.Invalid_arg if the two arrays have different lengths. @since 3.3.0 *) (** {6 Array functional support} *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f darr] calls the function [f] on every element of [darr]. It is equivalent to [for i = 0 to length darr - 1 do f (get darr i) done;] *) val iteri : (int -> 'a -> unit) -> 'a t -> unit (** [iteri f darr] calls the function [f] on every element of [darr]. It is equivalent to [for i = 0 to length darr - 1 do f i (get darr i) done;] *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f darr] applies the function [f] to every element of [darr] and creates a dynamic array from the results - similar to [List.map] or [Array.map]. *) val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t (** [mapi f darr] applies the function [f] to every element of [darr] and creates a dynamic array from the results - similar to [List.mapi] or [Array.mapi]. *) val modify : ('a -> 'a) -> 'a t -> unit (** [modify f a] replaces every element [x] of [a] with [f x]. @since 3.3.0 *) val modifyi : (int -> 'a -> 'a) -> 'a t -> unit (** Same as {!modify}, but the function is applied to the index of the element as the first argument, and the element itself as the second argument. @since 3.3.0 *) val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (** [fold_left f x darr] computes [f ( ... ( f ( f a0 x) a1) ) ... ) aN], where [a0,a1..aN] are the indexed elements of [darr]. *) val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** [fold_right f darr x] computes [ f a0 (f a1 ( ... ( f aN x ) ... ) ) ], where [a0,a1..aN] are the indexed elements of [darr]. *) val fold_lefti : ('a -> int -> 'b -> 'a) -> 'a -> 'b t -> 'a (** As [fold_left], but with the index of the element as additional argument. @since 3.3.0 *) val fold_righti : (int -> 'b -> 'a -> 'a) -> 'b t -> 'a -> 'a (** As [fold_right], but with the index of the element as additional argument. @since 3.3.0 *) val reduce : ('a -> 'a -> 'a) -> 'a t -> 'a (** [reduce f a] is [fold_left f a0 [a1, ... aN]]. This is useful for merging a group of things that have no reasonable default value to return if the group is empty. @raise DynArray.Invalid_arg on empty arrays. @since 3.3.0 *) val keep : ('a -> bool) -> 'a t -> unit (** [keep p darr] removes in place all the element [x] of [darr] such that [p x = false] {b Note} In previous versions, this function used to be called {!filter}. As this caused incompatibilities with comprehension of dynamic arrays, the function name has been changed. *) val filter : ('a -> bool) -> 'a t -> 'a t (** [filter p a] returns all the elements of the array [a] that satisfy the predicate [p]. The order of the elements in the input array is preserved. {b Note} This function replaces another function called [filter], available in previous versions of the library. As the old function was incompatible with comprehension of dynamic arrays, its name was changed to {!keep}. *) val find_all : ('a -> bool) -> 'a t -> 'a t (** [find_all] is another name for [filter]. @since 3.3.0 *) val filteri : (int -> 'a -> bool) -> 'a t -> 'a t (** As [filter] but with the index passed to the predicate. @since 3.3.0 *) val filter_map : ('a -> 'b option) -> 'a t -> 'b t (** [filter_map f e] returns an array consisting of all elements [x] such that [f y] returns [Some x] , where [y] is an element of [e]. *) val partition : ('a -> bool) -> 'a t -> 'a t * 'a t (** [partition p a] returns a pair of arrays [(a1, a2)], where [a1] is the array of all the elements of [a] that satisfy the predicate [p], and [a2] is the array of all the elements of [a] that do not satisfy [p]. The order of the elements in the input array is preserved. @since 3.3.0 *) val for_all : ('a -> bool) -> 'a t -> bool (** [for_all p [a0; a1; ...; an]] checks if all elements of the array satisfy the predicate [p]. That is, it returns [ (p a0) && (p a1) && ... && (p an)]. @since 3.3.0 *) val exists : ('a -> bool) -> 'a t -> bool (** [exists p [a0; a1; ...; an]] checks if at least one element of the array satisfies the predicate [p]. That is, it returns [(p a0) || (p a1) || ... || (p an)]. @since 3.3.0 *) val find : ('a -> bool) -> 'a t -> 'a (** [find p a] returns the first element of array [a] that satisfies the predicate [p]. @raise Not_found if there is no value that satisfies [p] in the array [a]. @since 3.3.0 *) val findi : ('a -> bool) -> 'a t -> int (** [findi p a] returns the index of the first element of array [a] that satisfies the predicate [p]. @raise Not_found if there is no value that satisfies [p] in the array [a]. @since 3.3.0 *) val index_of : ('a -> bool) -> 'a t -> int (** Alias for {!findi} *) val mem : 'a -> 'a t -> bool (** [mem m a] is true if and only if [m] is equal to an element of [a]. @since 3.3.0 *) val memq : 'a -> 'a t -> bool (** Same as {!mem} but uses physical equality instead of structural equality to compare array elements. @since 3.3.0 *) val rev : 'a t -> 'a t (** Array reversal. @since 3.3.0 *) val rev_in_place : 'a t -> unit (** In-place array reversal. The given array is updated. @since 3.3.0 *) val max : 'a t -> 'a (** [max a] returns the largest value in [a] as judged by [Pervasives.compare] @raise DynArray.Invalid_arg on empty input. @since 3.3.0 *) val min : 'a t -> 'a (** [min a] returns the smallest value in [a] as judged by [Pervasives.compare] @raise DynArray.Invalid_arg on empty input. @since 3.3.0 *) val min_max : 'a t -> 'a * 'a (** [min_max a] returns the (smallest, largest) pair of values from [a] as judged by [Pervasives.compare] @raise DynArray.Invalid_arg on empty input. @since 3.3.0 *) val sum : int t -> int (** [sum l] returns the sum of the integers of [l]. @since 3.3.0 *) val fsum : float t -> float (** [fsum l] returns the sum of the floats of [l]. @since 3.3.0 *) val kahan_sum : float t -> float (** [kahan_sum l] returns a numerically-accurate sum of the floats of [l]. You should consider using Kahan summation when you really care about very small differences in the result, while the result or one of the intermediate sums can be very large (which usually results in loss of precision of floating-point addition). The worst-case rounding error is constant, instead of growing with (the square root of) the length of the input array as with {! fsum}. On the other hand, processing each element requires four floating-point operations instead of one. See {{: https://en.wikipedia.org/wiki/Kahan_summation_algorithm } the wikipedia article} on Kahan summation for more details. @since 3.3.0 *) val avg : int t -> float (** [avg l] returns the average of [l] @since 3.3.0 *) val favg : float t -> float (** [favg l] returns the average of [l] @since 3.3.0 *) (** {6 Operations on two arrays} *) val iter2 : ('a -> 'b -> unit) -> 'a t -> 'b t -> unit (** [iter2 f [a0, a1, ..., an] [b0, b1, ..., bn]] performs calls [f a0 b0, f a1 b1, ..., f an bn] in that order. @raise DynArray.Invalid_arg if the two arrays have different lengths. @since 3.3.0 *) val iter2i : (int -> 'a -> 'b -> unit) -> 'a t -> 'b t -> unit (** [iter2i f [a0, a1, ..., an] [b0, b1, ..., bn]] performs calls [f 0 a0 b0, f 1 a1 b1, ..., f n an bn] in that order. @raise DynArray.Invalid_arg if the two arrays have different lengths. @since 3.3.0 *) val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t (** As {!map} but on two arrays. @raise DynArray.Invalid_arg if the two arrays have different lengths. @since 3.3.0 *) val map2i : (int -> 'a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t (** As {!mapi} but on two arrays. @raise DynArray.Invalid_arg if the two arrays have different lengths. @since 3.3.0 *) val for_all2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool (** As {!for_all} but on two arrays. @raise DynArray.Invalid_arg if the two arrays have different lengths. @since 3.3.0 *) val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool (** As {!exists} but on two arrays. @raise DynArray.Invalid_arg if the two arrays have different lengths. @since 3.3.0 *) val cartesian_product : 'a t -> 'b t -> ('a * 'b) t (** Cartesian product of the two arrays. @since 3.3.0 *) (** {6 Array resizers} *) type resizer_t = currslots:int -> oldlength:int -> newlength:int -> int (** The type of a resizer function. Resizer functions are called whenever elements are added to or removed from the dynamic array to determine what the current number of storage spaces in the array should be. The three named arguments passed to a resizer are the current number of storage spaces in the array, the length of the array before the elements are added or removed, and the length the array will be after the elements are added or removed. If elements are being added, newlength will be larger than oldlength, if elements are being removed, newlength will be smaller than oldlength. If the resizer function returns exactly oldlength, the size of the array is only changed when adding an element while there is not enough space for it. By default, all dynamic arrays are created with the [default_resizer]. When a dynamic array is created from another dynamic array (using [copy], [map] , etc. ) the resizer of the copy will be the same as the original dynamic array resizer. To change the resizer, use the [set_resizer] function. *) val set_resizer : 'a t -> resizer_t -> unit (** Change the resizer for this array. *) val get_resizer : 'a t -> resizer_t (** Get the current resizer function for a given array *) val default_resizer : resizer_t (** The default resizer function the library is using - in this version of DynArray, this is the [exponential_resizer] but should change in next versions. *) val exponential_resizer : resizer_t (** The exponential resizer- The default resizer except when the resizer is being copied from some other darray. [exponential_resizer] works by doubling or halving the number of slots until they "fit". If the number of slots is less than the new length, the number of slots is doubled until it is greater than the new length (or Sys.max_array_size is reached). If the number of slots is more than four times the new length, the number of slots is halved until it is less than four times the new length. Allowing darrays to fall below 25% utilization before shrinking them prevents "thrashing". Consider the case where the caller is constantly adding a few elements, and then removing a few elements, causing the length to constantly cross above and below a power of two. Shrinking the array when it falls below 50% would causing the underlying array to be constantly allocated and deallocated. A few elements would be added, causing the array to be reallocated and have a usage of just above 50%. Then a few elements would be remove, and the array would fall below 50% utilization and be reallocated yet again. The bulk of the array, untouched, would be copied and copied again. By setting the threshold at 25% instead, such "thrashing" only occurs with wild swings- adding and removing huge numbers of elements (more than half of the elements in the array). [exponential_resizer] is a good performing resizer for most applications. A list allocates 2 words for every element, while an array (with large numbers of elements) allocates only 1 word per element (ignoring unboxed floats). On insert, [exponential_resizer] keeps the amount of wasted "extra" array elements below 50%, meaning that less than 2 words per element are used. Even on removals where the amount of wasted space is allowed to rise to 75%, that only means that darray is using 4 words per element. This is generally not a significant overhead. Furthermore, [exponential_resizer] minimizes the number of copies needed- appending n elements into an empty darray with initial size 0 requires between n and 2n elements of the array be copied- O(n) work, or O(1) work per element (on average). A similar argument can be made that deletes from the end of the array are O(1) as well (obviously deletes from anywhere else are O(n) work- you have to move the n or so elements above the deleted element down). *) val step_resizer : int -> resizer_t (** The stepwise resizer- another example of a resizer function, this time of a parameterized resizer. The resizer returned by [step_resizer step] returns the smallest multiple of [step] larger than [newlength] if [currslots] is less then [newlength]-[step] or greater than [newlength]. For example, to make an darray with a step of 10, a length of len, and a null of null, you would do: [make] ~resizer:([step_resizer] 10) len null *) val conservative_exponential_resizer : resizer_t (** [conservative_exponential_resizer] is an example resizer function which uses the oldlength parameter. It only shrinks the array on inserts- no deletes shrink the array, only inserts. It does this by comparing the oldlength and newlength parameters. Other than that, it acts like [exponential_resizer]. *) val create_with : resizer_t -> 'a t (** create a new dynamic array that uses the given resizer. @since 2.3.0 *) (** {6 Unsafe operations} **) val unsafe_get : 'a t -> int -> 'a val unsafe_set : 'a t -> int -> 'a -> unit val unsafe_upd : 'a t -> int -> ('a -> 'a) -> unit (** @since 3.3.0 *) (** {6 Boilerplate code} *) (** {7 Printing} *) val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> 'b t -> unit (** Operations on {!DynArray} without exceptions. *) module Exceptionless : sig val find : ('a -> bool) -> 'a t -> 'a option (** [find p a] returns [Some x], where [x] is the first element of array [a] that satisfies the predicate [p], or [None] if there is no such element. @since 3.3.0 *) val findi : ('a -> bool) -> 'a t -> int option (** [findi p a] returns [Some n], where [n] is the index of the first element of array [a] that satisfies the predicate [p], or [None] if there is no such element. @since 3.3.0 *) end (**/**) val invariants : _ t -> unit val bool_invariants : _ t -> bool (**/**) batteries-included-3.4.0/src/batEither.mliv000066400000000000000000000113551415601150500206570ustar00rootroot00000000000000(**************************************************************************) (* *) (* OCaml *) (* *) (* Gabriel Scherer, projet Parsifal, INRIA Saclay *) (* *) (* Copyright 2019 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) (** Either type. Either is the simplest and most generic sum/variant type: a value of [('a, 'b) Either.t] is either a [Left (v : 'a)] or a [Right (v : 'b)]. It is a natural choice in the API of generic functions where values could fall in two different cases, possibly at different types, without assigning a specific meaning to what each case should be. For example: {[List.partition_map: ('a -> ('b, 'c) Either.t) -> 'a list -> 'b list * 'c list]} If you are looking for a parametrized type where one alternative means success and the other means failure, you should use the more specific type {!Result.t}. @since 4.12 *) (* Unlike [result], no [either] type is made available in Stdlib, one needs to access [Either.t] explicitly: - This type is less common in typical OCaml codebases, which prefer domain-specific variant types whose constructors carry more meaning. - Adding this to Stdlib would raise warnings in existing codebases that already use a constructor named Left or Right: + when opening a module that exports such a name, warning 45 is raised + adding a second constructor of the same name in scope kicks in the disambiguation mechanisms, and warning 41 may now be raised by existing code. If the use becomes more common in the future we can always revisit this choice. *) type ('a, 'b) t = ##V>=4.12## ('a, 'b) Stdlib.Either.t = Left of 'a | Right of 'b (**) (** A value of [('a, 'b) Either.t] contains either a value of ['a] or a value of ['b] *) val left : 'a -> ('a, 'b) t (** [left v] is [Left v]. *) val right : 'b -> ('a, 'b) t (** [right v] is [Right v]. *) val is_left : ('a, 'b) t -> bool (** [is_left (Left v)] is [true], [is_left (Right v)] is [false]. *) val is_right : ('a, 'b) t -> bool (** [is_right (Left v)] is [false], [is_right (Right v)] is [true]. *) val find_left : ('a, 'b) t -> 'a option (** [find_left (Left v)] is [Some v], [find_left (Right _)] is [None] *) val find_right : ('a, 'b) t -> 'b option (** [find_right (Right v)] is [Some v], [find_right (Left _)] is [None] *) val map_left : ('a1 -> 'a2) -> ('a1, 'b) t -> ('a2, 'b) t (** [map_left f e] is [Left (f v)] if [e] is [Left v] and [e] if [e] is [Right _]. *) val map_right : ('b1 -> 'b2) -> ('a, 'b1) t -> ('a, 'b2) t (** [map_right f e] is [Right (f v)] if [e] is [Right v] and [e] if [e] is [Left _]. *) val map : left:('a1 -> 'a2) -> right:('b1 -> 'b2) -> ('a1, 'b1) t -> ('a2, 'b2) t (** [map ~left ~right (Left v)] is [Left (left v)], [map ~left ~right (Right v)] is [Right (right v)]. *) val fold : left:('a -> 'c) -> right:('b -> 'c) -> ('a, 'b) t -> 'c (** [fold ~left ~right (Left v)] is [left v], and [fold ~left ~right (Right v)] is [right v]. *) val iter : left:('a -> unit) -> right:('b -> unit) -> ('a, 'b) t -> unit (** [iter ~left ~right (Left v)] is [left v], and [iter ~left ~right (Right v)] is [right v]. *) val for_all : left:('a -> bool) -> right:('b -> bool) -> ('a, 'b) t -> bool (** [for_all ~left ~right (Left v)] is [left v], and [for_all ~left ~right (Right v)] is [right v]. *) val equal : left:('a -> 'a -> bool) -> right:('b -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t -> bool (** [equal ~left ~right e0 e1] tests equality of [e0] and [e1] using [left] and [right] to respectively compare values wrapped by [Left _] and [Right _]. *) val compare : left:('a -> 'a -> int) -> right:('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int (** [compare ~left ~right e0 e1] totally orders [e0] and [e1] using [left] and [right] to respectively compare values wrapped by [Left _ ] and [Right _]. [Left _] values are smaller than [Right _] values. *) batteries-included-3.4.0/src/batEither.mlv000066400000000000000000000041261415601150500205040ustar00rootroot00000000000000(**************************************************************************) (* *) (* OCaml *) (* *) (* Gabriel Scherer, projet Parsifal, INRIA Saclay *) (* *) (* Copyright 2019 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) type ('a, 'b) t = ##V>=4.12## ('a, 'b) Stdlib.Either.t = Left of 'a | Right of 'b (**) let left v = Left v let right v = Right v let is_left = function | Left _ -> true | Right _ -> false let is_right = function | Left _ -> false | Right _ -> true let find_left = function | Left v -> Some v | Right _ -> None let find_right = function | Left _ -> None | Right v -> Some v let map_left f = function | Left v -> Left (f v) | Right _ as e -> e let map_right f = function | Left _ as e -> e | Right v -> Right (f v) let map ~left ~right = function | Left v -> Left (left v) | Right v -> Right (right v) let fold ~left ~right = function | Left v -> left v | Right v -> right v let iter = fold let for_all = fold let equal ~left ~right e1 e2 = match e1, e2 with | Left v1, Left v2 -> left v1 v2 | Right v1, Right v2 -> right v1 v2 | Left _, Right _ | Right _, Left _ -> false let compare ~left ~right e1 e2 = match e1, e2 with | Left v1, Left v2 -> left v1 v2 | Right v1, Right v2 -> right v1 v2 | Left _, Right _ -> (-1) | Right _, Left _ -> 1 batteries-included-3.4.0/src/batEnum.ml000066400000000000000000001205311415601150500200010ustar00rootroot00000000000000(* * BatEnum - Enumeration over abstract collection of elements. * Copyright (C) 2003 Nicolas Cannasse * 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** {6 Representation} *) type 'a t = { mutable count : unit -> int; (** Return the number of remaining elements in the enumeration. *) mutable next : unit -> 'a; (** Return the next element of the enumeration or raise [No_more_elements].*) mutable clone : unit -> 'a t;(** Return a copy of the enumeration. *) mutable fast : bool; (** [true] if [count] can be done without reading all elements, [false] otherwise.*) } type 'a enumerable = 'a t type 'a mappable = 'a t external enum : 'a t -> 'a t = "%identity" external of_enum : 'a t -> 'a t = "%identity" (* raised by 'next' functions, should NOT go outside the API *) exception No_more_elements let make ~next ~count ~clone = { count = count; next = next; clone = clone; fast = true; } (** {6 Internal utilities}*) let _dummy () = assert false (* raised by 'count' functions, may go outside the API *) exception Infinite_enum let return_no_more_elements () = raise No_more_elements let return_no_more_count () = 0 let return_infinite_count () = raise Infinite_enum (* Inlined from ExtList to avoid circular dependencies. *) type 'a _mut_list = { hd : 'a; mutable tl : 'a _mut_list; } let rec empty () = { count = return_no_more_count; next = return_no_more_elements; clone = empty; fast = true; } let close e = e.next <- return_no_more_elements; e.count<- return_no_more_count; e.clone<- empty let force t = (* Transform [t] into a list *) let rec clone enum count = let enum = ref !enum and count = ref !count in { count = (fun () -> !count); next = (fun () -> match !enum with | [] -> raise No_more_elements | h :: t -> decr count; enum := t; h); clone = (fun () -> let enum = ref !enum and count = ref !count in clone enum count); fast = true; } in let count = ref 0 in let _empty = Obj.magic [] in let rec loop dst = let x = { hd = t.next(); tl = _empty } in incr count; dst.tl <- x; loop x in let enum = ref _empty in (try enum := { hd = t.next(); tl = _empty }; incr count; loop !enum; with No_more_elements -> ()); let tc = clone (Obj.magic enum) count in t.clone <- tc.clone; t.next <- tc.next; t.count <- tc.count; t.fast <- true (* Inlined from {!LazyList}. This lazy list permits cloning enumerations constructed with {!from} without having to actually force them.*) module MicroLazyList = struct type 'a ll_t = ('a node_t) Lazy.t and 'a node_t = | Nil | Cons of 'a * 'a ll_t let nil = lazy Nil let enum l = let rec aux (l:'a ll_t) : 'a t= let reference = ref l in let e = make ~next:(fun () -> match Lazy.force !reference with | Cons(x,t) -> reference := t; x | Nil -> raise No_more_elements ) ~count:_dummy ~clone:(fun () -> aux !reference) in e.count <- (fun () -> force e; e.count()); e.fast <- false; e in aux l let from f = let rec aux () = lazy ( let item = try Some (f ()) with No_more_elements -> None in match item with | Some x -> Cons (x, aux () ) | _ -> Nil ) in aux () end let from f = let e = { next = _dummy; count = _dummy; clone = _dummy; fast = false; } in e.next <- (fun () -> try f () with No_more_elements -> close e ; raise No_more_elements); e.count <- (fun () -> force e; e.count()); e.clone <- (fun () -> let e' = MicroLazyList.enum(MicroLazyList.from f) in e.next <- e'.next; e.clone<- e'.clone; e.count<- (fun () -> force e; e.count()); (* we can't use [e'.count] because that would force [e'], which doesn't update [e]. That would for example, cause e.fast to not be updated to true. A simple test to see the problem with [e'.count] is to do the following: (1) create a enum using this [from] function, (2) clone that enum, (3) grab the count of the original enum and then iterate over it. A discrepancy between the count and the elements will result. *) e.fast <- e'.fast; e.clone () ); e let from2 next clone = let e = { next = next; count = _dummy; clone = clone; fast = false; } in e.count <- (fun () -> force e; e.count()); e let init n f = (*Experimental fix for init*) if n < 0 then invalid_arg "Enum.init"; let count = ref n in let f' () = match !count with | 0 -> raise No_more_elements | _ -> decr count; f ( n - 1 - !count) in let e = from f' in e.fast <- true; e.count <- (fun () -> !count); e let get t = try Some (t.next()) with No_more_elements -> None let get_exn t = t.next () let push t e = let rec make t = let fnext = t.next in let fcount = t.count in let fclone = t.clone in let next_called = ref false in t.next <- (fun () -> next_called := true; t.next <- fnext; t.count <- fcount; t.clone <- fclone; e); t.count <- (fun () -> let n = fcount() in if !next_called then n else n+1); t.clone <- (fun () -> let tc = fclone() in if not !next_called then make tc; tc); in make t let peek t = match get t with | None -> None | Some x -> push t x; Some x module MicroList = (*Inlined from ExtList to avoid circular dependencies*) struct let enum l = let rec aux lr count = make ~next:(fun () -> match !lr with | [] -> raise No_more_elements | h :: t -> decr count; lr := t; h ) ~count:(fun () -> if !count < 0 then count := List.length !lr; !count ) ~clone:(fun () -> aux (ref !lr) (ref !count) ) in aux (ref l) (ref (-1)) end let take n e = let r = ref [] in begin try for _i = 1 to n do r := e.next () :: !r done with No_more_elements -> () end; MicroList.enum (List.rev !r) (*let take n e = (*Er... that looks quite weird.*) let remaining = ref n in let f () = if !remaining >= 0 then let result = e.next () in decr remaining; result else raise No_more_elements in let e = make ~next: f ~count:(fun () -> !remaining) ~clone:_dummy in e.clone <- (fun () -> force e; e.clone ()); e*) let junk t = try ignore(t.next()) with No_more_elements -> () let is_empty t = if t.fast then t.count() = 0 else peek t = None let count t = t.count() let fast_count t = t.fast let clone t = t.clone() let iter f t = let rec loop () = f (t.next()); loop(); in try loop(); with No_more_elements -> () let iteri f t = let rec loop idx = f idx (t.next()); loop (idx+1); in try loop 0; with No_more_elements -> () let iter2 f t u = let push_t = ref None in let rec loop () = push_t := None; let e = t.next() in push_t := Some e; f e (u.next()); loop () in try loop () with No_more_elements -> match !push_t with | None -> () | Some e -> push t e let iter2i f t u = let push_t = ref None in let rec loop idx = push_t := None; let e = t.next() in push_t := Some e; f idx e (u.next()); loop (idx + 1) in try loop 0 with No_more_elements -> match !push_t with | None -> () | Some e -> push t e let fold f init t = let acc = ref init in let rec loop() = acc := f !acc (t.next()); loop() in try loop() with No_more_elements -> !acc let reduce f t = match get t with None -> raise Not_found | Some init -> fold f init t let sum t = match get t with | None -> 0 | Some i -> fold (+) i t (* Kahan summing. [Enum.reduce (+.)] is 20% faster, but has cumulative error O(n) instead of O(1) *) let fsum t = match get t with | None -> 0. | Some i -> let sum = ref i in let c = ref 0. in iter (fun x -> let y = x -. !c in let t = !sum +. y in c := (t -. !sum) -. y; sum := t ) t; !sum let kahan_sum = fsum (* NEED A PROPER TEST OF ROUNDING ERROR *) (*$T fsum let arr = Array.make 10001 1e-10 in arr.(0) <- 1e10; \ Float.approx_equal (fsum (Array.enum arr)) (1e10 +. 1e-5) *) (*$T kahan_sum kahan_sum (Array.enum [| |]) = 0. kahan_sum (Array.enum [| 1.; 2. |]) = 3. let n, x = 1_000, 1.1 in \ Float.approx_equal (float n *. x) \ (kahan_sum (Array.enum (Array.make n x))) *) let exists f t = try let rec aux () = f (t.next()) || aux () in aux () with No_more_elements -> false let for_all f t = try let rec aux () = f (t.next()) && aux () in aux () with No_more_elements -> true (* test paired elements, ignore any extra elements from one enum *) let for_all2 f t1 t2 = try let rec aux () = f (t1.next()) (t2.next()) && aux () in aux () with No_more_elements -> true let scanl f init t = let acc = ref init in let gen () = acc := f !acc (t.next()); !acc in let e = from gen in push e init; e let scan f t = match get t with | Some x -> scanl f x t | None -> empty () let foldi f init t = let acc = ref init in let rec loop idx = acc := f idx (t.next()) !acc; loop (idx + 1) in try loop 0 with No_more_elements -> !acc let fold2 f init t u = let acc = ref init in let push_t = ref None in let rec loop() = push_t := None; let e = t.next() in push_t := Some e; acc := f e (u.next()) !acc; loop() in try loop() with No_more_elements -> match !push_t with | None -> !acc | Some e -> push t e; !acc let fold2i f init t u = let acc = ref init in let push_t = ref None in let rec loop idx = push_t := None; let e = t.next() in push_t := Some e; acc := f idx e (u.next()) !acc; loop (idx + 1) in try loop 0 with No_more_elements -> match !push_t with | None -> !acc | Some e -> push t e; !acc let find f t = let rec loop () = let x = t.next() in if f x then x else loop() in try loop() with No_more_elements -> raise Not_found (*$T find ((=) 5) (1 -- 10) = 5 try ignore (find ((=) 11) (1 -- 10) = 5); false with Not_found -> true *) let find_map f t = let rec loop () = match f (t.next ()) with | Some x -> x | None -> loop () in try loop () with No_more_elements -> raise Not_found (*$T find_map try let _ = empty () |> find_map (const (Some 1)) in false with Not_found -> true singleton 0 |> find_map (const (Some 1)) = 1 1 -- 5 |> find_map (function 2 -> Some 0 | _ -> None) = 0 1 -- 5 |> find_map (function 5 -> Some 0 | _ -> None) = 0 try let _ = 1 -- 5 |> find_map (function 6 -> Some 0 | _ -> None) in \ false with Not_found -> true *) (*qtest TODO: migrate try into an exception test *) let rec map f t = { count = t.count; next = (fun () -> f (t.next())); clone = (fun () -> map f (t.clone())); fast = t.fast; } let rec mapi f t = let idx = ref (-1) in { count = t.count; next = (fun () -> incr idx; f !idx (t.next())); clone = (fun () -> mapi f (t.clone())); fast = t.fast; } let rec filter f t = let rec next() = let x = t.next() in if f x then x else next() in from2 next (fun () -> filter f (t.clone())) let rec filter_map f t = let rec next () = match f (t.next()) with | None -> next() | Some x -> x in from2 next (fun () -> filter_map f (t.clone())) let rec append ta tb = let t = { count = (fun () -> ta.count() + tb.count()); next = _dummy; clone = (fun () -> append (ta.clone()) (tb.clone())); fast = ta.fast && tb.fast; } in t.next <- (fun () -> try ta.next() with No_more_elements -> (* add one indirection because tb can mute *) t.next <- (fun () -> tb.next()); t.count <- (fun () -> tb.count()); t.clone <- (fun () -> tb.clone()); t.fast <- tb.fast; t.next() ); t (*$T append (List.enum [1;2;3]) (List.enum [4;5]) |> List.of_enum = [1;2;3;4;5] append (List.enum [1;2;3]) (List.enum [4;5]) |> \ mapi (Tuple2.curry identity) |> List.of_enum = [0,1;1,2;2,3;3,4;4,5] *) let prefix_action f t = let full_action e = e.count <- (fun () -> t.count()); e.next <- (fun () -> t.next ()); e.clone <- (fun () -> t.clone()); f () in let rec t' = { count = (fun () -> full_action t'; t.count() ); next = (fun () -> full_action t'; t.next() ); clone = (fun () -> full_action t'; t.clone() ); fast = t.fast } in t' let suffix_action_without_raise (f:unit -> 'a) (t:'a t) = { count = t.count; next = (fun () -> try t.next () with No_more_elements -> f() ); clone = (fun () -> t.clone()); (* needs to be delayed because [t] may mutate and we want the newest clone function *) fast = t.fast } let suffix_action f t = let f' () = f (); close t; raise No_more_elements in suffix_action_without_raise f' t let rec concat t = let tn = ref (empty ()) in let rec next () = try (!tn).next () with No_more_elements -> tn := t.next(); next() in let clone () = append ((!tn).clone()) (concat (t.clone())) in from2 next clone (*$T concat let e = List.enum [ [| 1; 2; 3; 4|]; [| 5; 6 |] ] |> map Array.enum \ |> concat in drop 1 e; (count e) = (count (clone e)) *) let singleton x = init 1 (fun _ -> x) let switchn n f e = let queues = ArrayLabels.init n ~f:(fun _ -> Queue.create ()) in let gen i () = (*Generate the next value for the i^th enum*) let my_queue = queues.(i) in if Queue.is_empty my_queue then (*Need to fetch next*) let rec aux () = (*Keep fetching until an appropriate item has been found*) let next_item = e.next() in let position = f next_item in if i = position then next_item else ( Queue.push next_item queues.(position); aux () ) in aux () else Queue.take my_queue in ArrayLabels.init ~f:(fun i -> from (gen i)) n let switch f e = let a = switchn 2 (fun x -> if f x then 0 else 1) e in (a.(0), a.(1)) (*$T List.enum [1;2;3;4] |> switch (fun x -> x mod 2 = 0) |> \ Tuple2.mapn List.of_enum = ([2;4], [1;3]) *) let partition = switch (*$T partition let a,b = partition (fun x -> x > 3) (List.enum [1;2;3;4;5;1;5;0]) in \ List.of_enum a = [4;5;5] && List.of_enum b = [1;2;3;1;0] *) (*$Q partition (Q.list Q.small_int) (fun l -> let f x = x mod 2 = 1 in List.partition f l \ = (partition f (List.enum l) |> Tuple.Tuple2.mapn List.of_enum)) *) let seq init f cond = let acc = ref init in let aux () = if cond !acc then begin let result = !acc in acc := f !acc; result end else raise No_more_elements in from aux let repeat ?times x = match times with | None -> let rec aux = { count = return_infinite_count; next = (fun () -> x); clone = (fun () -> aux); fast = true; } in aux | Some n -> init n (fun _ -> x) (*$T repeat ~times:5 0 |> List.of_enum = [0;0;0;0;0] repeat 1 |> take 3 |> List.of_enum = [1;1;1] *) let cycle ?times x = let enum = match times with | None -> from (fun () -> clone x) | Some n -> init n (fun _ -> clone x) in concat enum (*$T cycle ~times:5 (singleton 1) |> List.of_enum = [1;1;1;1;1] cycle (List.enum [1;2]) |> take 5 |> List.of_enum = [1;2;1;2;1] *) let range ?until x = let cond = match until with | None -> ( fun _ -> true ) | Some n -> ( fun m -> m <= n ) in seq x ( ( + ) 1 ) cond (*$T range 1 ~until:5 |> List.of_enum = [1;2;3;4;5] *) let drop n e = for _i = 1 to n do junk e done let skip n e = drop n e; e let drop_while p e = let rec aux () = match get e with | Some x when p x -> aux () | Some x -> push e x | None -> () in prefix_action aux e (*let drop_while p e = let rec aux () = let x = e.next () in print_string "filtering\n"; if p x then (aux ()) else (push e x; raise No_more_elements) in append (from aux) e*) let take_while f t = let next () = let x = t.next () in if f x then x else (push t x; raise No_more_elements) in from next let span f t = (*Two possibilities: either the tail has been read already -- in which case all head data has been copied onto the queue -- or the tail hasn't been read -- in which case, stuff should be read from [t] *) let queue = Queue.create () and read_from_queue = ref false in let head () = if !read_from_queue then (*Everything from the head has been copied *) try Queue.take queue (*to the queue already *) with Queue.Empty -> raise No_more_elements else let x = t.next () in if f x then x else (push t x; raise No_more_elements) and tail () = if not !read_from_queue then (*Copy everything to the queue *) begin read_from_queue := true; let rec aux () = match get t with | None -> raise No_more_elements | Some x when f x -> Queue.push x queue; aux () | Some x -> x in aux () end else t.next() in (from head, from tail) (*$T span List.enum [1;2;3;4;5] |> span (fun x-> x<4) |> Tuple2.mapn List.of_enum = \ ([1;2;3], [4;5]) *) (*$Q (Q.list Q.small_int) (fun l -> \ let avg = List.fold_left (+) 0 l / (max 1 @@ List.length l) in \ let l' = List.sort Int.compare l in \ let f x = x < avg in \ Tuple2.mapn List.of_enum (span f @@ List.enum l' ) = \ (List.of_enum @@ take_while f @@ List.enum l', \ List.of_enum @@ drop_while f @@ List.enum l')) *) let while_do cont f e = let (head, tail) = span cont e in append (f head) tail let break test e = span (fun x -> not (test x)) e let uniq_by cmp e = match peek e with None -> empty () | Some first -> let prev = ref first in let not_last x = not (cmp (BatRef.post prev (fun _ -> x)) x) in let result = filter not_last e in push result first; result let uniq e = uniq_by (=) e let uniqq e = uniq_by (==) e (*$T List.enum [1;1;2;3;3;2] |> uniq |> List.of_enum = [1;2;3;2] List.enum [1;1;2;3;3;2] |> uniqq |> List.of_enum = [1;2;3;2] List.enum ["a";"a";"b";"c";"c";"b"] |> uniq |> List.of_enum = ["a";"b";"c";"b"] List.enum ["a";"A";"b";"c";"C";"b"] \ |> uniq_by (fun a b -> String.lowercase a = String.lowercase b) \ |> List.of_enum = ["a";"b";"c";"b"] *) let dup t = (t, t.clone()) (*$Q (Q.list Q.small_int) (fun l -> \ List.enum l |> dup |> Tuple2.mapn List.of_enum |> Tuple2.uncurry (=)) *) let min_count x y = let count x = try Some (x.count ()) with Infinite_enum -> None in match count x, count y with | None, None -> raise Infinite_enum | Some c, None | None, Some c -> c | Some c1, Some c2 -> min c1 c2 let combine x y = if x.fast && y.fast then (* Optimized case *) let rec aux (x,y) = { count = (fun () -> min_count x y) ; next = (fun () -> (x.next(), y.next())) ; clone = (fun () -> aux (x.clone(), y.clone())) ; fast = true } in aux (x,y) else from (fun () -> (x.next(), y.next())) (*$T combine (List.enum [1;2;3]) ( List.enum ["a";"b"]) \ |> List.of_enum = [1, "a"; 2, "b"] combine (List.enum [1;2;3]) ( repeat "a") \ |> List.of_enum = [1,"a"; 2,"a"; 3,"a"] combine (List.enum [1;2;3]) ( repeat "a") \ |> Enum.count = 3 *) let uncombine e = let advance = ref `first and queue_snd = Queue.create () and queue_fst = Queue.create () in let first () = match !advance with | `first -> let (x,y) = e.next() in Queue.push y queue_snd; x | `second-> (*Second element has been read further*) try Queue.pop queue_fst with Queue.Empty -> let (x,y) = e.next() in Queue.push y queue_snd; advance := `first; x and second() = match !advance with | `second -> let (x,y) = e.next() in Queue.push x queue_fst; y | `first -> (*Second element has been read further*) try Queue.pop queue_snd with Queue.Empty -> let (x,y) = e.next() in Queue.push x queue_fst; advance := `second; y in (from first, from second) (*$R uncombine let pair_list = [1,2;3,4;5,6;7,8;9,0] in let a,b = uncombine (BatList.enum pair_list) in let a = BatArray.of_enum a in let b = BatArray.of_enum b in let c,d = uncombine (BatList.enum pair_list) in let d = BatArray.of_enum d in let c = BatArray.of_enum c in let aeq = assert_equal ~printer:(BatIO.to_string (BatArray.print BatInt.print)) in aeq a [|1;3;5;7;9|]; aeq b [|2;4;6;8;0|]; aeq a c; aeq b d *) let group_aux test eq e = let prev_group = ref (empty ()) in let f () = (* Make sure elements belonging to prev group are consumed from e *) force !prev_group; let grp = let last_test = ref None in let check_test t = let ok = match !last_test with | None -> true | Some t' -> eq t' t in if ok then last_test := Some t; ok in take_while (fun x -> check_test (test x)) e in if is_empty grp then raise No_more_elements; prev_group := grp; grp in let clone () = failwith "Grouped enumerations cannot be cloned safely" in from2 f clone let group test e = group_aux test (=) e let group_by eq e = group_aux (fun x -> x) eq e (*$T group empty () |> group (const ()) |> is_empty List.enum [1;2;3;4] |> group identity |> map List.of_enum \ |> List.of_enum = [[1];[2];[3];[4]] List.enum [1;2;3;4] |> group (const true) |> List.of_enum \ |> List.map List.of_enum = [[1;2;3;4]] List.enum [1;2;3;5;6;7;9;10;4;5] |> group (fun x -> x mod 2) |> List.of_enum \ |> List.map List.of_enum = [[1];[2];[3;5];[6];[7;9];[10;4];[5]] *) let clump clump_size add get e = (* convert a uchar enum into a ustring enum *) let next () = match peek e with | None -> raise No_more_elements | Some x -> add x; junk e; (* don't get [x] twice *) (try for _i = 2 to clump_size do add (e.next ()) done with No_more_elements -> ()); get () in from next (*$T clump let l = RefList.empty() in \ Char.range 'a' ~until:'k' |> \ clump 4 (RefList.push l) \ (fun()-> String.implode \ (RefList.to_list l |> tap (fun _ -> RefList.clear l) |> List.rev)) \ |> List.of_enum = ["abcd"; "efgh"; "ijk"] *) (* mutable state used for {!cartesian_product}. Use a module to have a private namespace. *) module ProductState = struct type ('a, 'b) current_state = | GetLeft | GetRight | GetRightOrStop | Stop | ProdLeft of 'a * 'b list | ProdRight of 'b * 'a list type ('a,'b) t = { e1 : 'a enumerable; e2 : 'b enumerable; mutable all1 : 'a list; mutable all2 : 'b list; mutable cur : ('a,'b) current_state; } end let cartesian_product e1 e2 = let open ProductState in (* sketch of the algo: state machine that alternates between taking a new element from [e1] and yield its product with [state.all2], and taking a new element from [e2] and make its product with [state.all1] [state.cur]: current state of automaton, i.e., what we have to do next. Can be `Stop, `GetLeft/`GetRight (to obtain next element from first/second generator), or `ProdLeft/`ProdRIght to compute the product of an element with a list of already met elements *) let rec next state () = match state.cur with | Stop -> raise No_more_elements | GetLeft -> let x1 = try Some (state.e1.next()) with No_more_elements -> None in begin match x1 with | None -> state.cur <- GetRightOrStop | Some x -> state.all1 <- x :: state.all1; state.cur <- ProdLeft (x, state.all2) end; next state () | GetRight | GetRightOrStop -> let x2 = try Some (state.e2.next()) with No_more_elements -> None in begin match x2, state.cur with | None, GetRightOrStop -> state.cur <- Stop; raise No_more_elements | None, GetRight -> state.cur <- GetLeft | Some y, _ -> state.all2 <- y::state.all2; state.cur <- ProdRight (y, state.all1) | None, _ -> assert false end; next state () | ProdLeft (_, []) -> state.cur <- GetRight; next state () | ProdLeft (x, y::l) -> state.cur <- ProdLeft (x, l); x, y | ProdRight (_, []) -> state.cur <- GetLeft; next state() | ProdRight (y, x::l) -> state.cur <- ProdRight (y, l); x, y and clone state () = let state' = {state with e1=state.e1.clone(); e2=state.e2.clone();} in _make state' and count state () = let n1 = state.e1.count () and n2 = state.e2.count () in (* 3 products to make: e1 with e2, and ei with all{2-i} for i in {1,2} *) let n = n1 * n2 + n1 * List.length state.all2 + n2 * List.length state.all1 in match state.cur with | ProdRight (_, l) -> n + List.length l | ProdLeft (_, l) -> n + List.length l | Stop -> 0 | GetLeft | GetRight | GetRightOrStop -> n (* build enum from the state *) and _make state = { next = next state; clone = clone state; count = count state; fast = state.e1.fast && state.e2.fast; } in let state = {e1; e2; cur=GetLeft; all1=[]; all2=[]} in _make state (*$T cartesian_product cartesian_product (List.enum [1;2;3]) (List.enum ["a";"b"]) \ |> List.of_enum |> List.sort Pervasives.compare = \ [1,"a"; 1,"b"; 2,"a"; 2,"b"; 3,"a"; 3,"b"] let e = cartesian_product (List.enum [1;2;3]) (List.enum [1]) in \ e |> List.of_enum |> List.sort Pervasives.compare = [1,1; 2,1; 3,1] let e = cartesian_product (List.enum [1]) (List.enum [1;2;3]) in \ e |> List.of_enum |> List.sort Pervasives.compare = [1,1; 1,2; 1,3] let e = cartesian_product (List.enum [1;2;3]) (List.enum [1;2;3]) in \ ignore (Enum.get e); Enum.count e = 8 let e = cartesian_product (List.enum [1;2]) (Enum.repeat 3) in\ e |> Enum.take 4 |> Enum.map fst |> List.of_enum \ |> List.sort Pervasives.compare = [1; 1; 2; 2] let e = cartesian_product (Enum.repeat 3) (List.enum [1;2]) in\ e |> Enum.take 4 |> Enum.map snd |> List.of_enum \ |> List.sort Pervasives.compare = [1; 1; 2; 2] let e = cartesian_product (Enum.repeat 3) (Enum.repeat "a") in\ e |> Enum.take 3 |> List.of_enum \ |> List.sort Pervasives.compare = [3, "a"; 3, "a"; 3, "a"] *) (*$Q cartesian_product Q.(pair (list small_int) (list small_int)) \ (fun (l1,l2) -> \ let l1 = List.take 5 l1 in \ let l2 = List.take 4 l2 in \ cartesian_product (List.enum l1) (List.enum l2) |> count = \ List.length l1 * List.length l2) Q.(pair (list small_int) (list small_int)) \ (fun (l1,l2) -> \ let l1 = List.take 5 l1 in \ let l2 = List.take 4 l2 in \ cartesian_product (List.enum l1) (List.enum l2) \ |> List.of_enum |> List.length = List.length l1 * List.length l2) *) let from_while f = from (fun () -> match f () with | None -> raise No_more_elements | Some x -> x ) let from_loop data next = let r = ref data in from(fun () -> let (a,b) = next !r in r := b; a) let unfold data next = from_loop data (fun data -> match next data with | None -> raise No_more_elements | Some x -> x ) let arg_min f enum = match get enum with None -> invalid_arg "Enum.arg_min: Empty enum" | Some v -> let item, eval = ref v, ref (f v) in iter (fun v -> let fv = f v in if fv < !eval then (item := v; eval := fv)) enum; !item let arg_max f enum = match get enum with None -> invalid_arg "Enum.arg_max: Empty enum" | Some v -> let item, eval = ref v, ref (f v) in iter (fun v -> let fv = f v in if fv > !eval then (item := v; eval := fv)) enum; !item (*$T arg_max List.enum ["cat"; "canary"; "dog"; "dodo"; "ant"; "cow"] \ |> arg_max String.length = "canary" *) (*$T arg_min -5 -- 5 |> arg_min (fun x -> x * x + 6 * x - 5) = -3 *) module Infix = struct let ( -- ) x y = range x ~until:y let ( --. ) (a, step) b = let n = int_of_float ((b -. a) /. step) + 1 in if n < 0 then empty () else init n (fun i -> float_of_int i *. step +. a) let ( --^ ) x y = range x ~until:(y-1) let ( --- ) x y = if x <= y then x -- y else seq x ((+) (-1)) ( (<=) y ) let ( --~ ) a b = map Char.chr (range (Char.code a) ~until:(Char.code b)) let ( // ) e f = filter f e let ( /@ ) e f = map f e let ( @/ ) = map let ( //@ ) e f = filter_map f e let ( @// ) = filter_map end include Infix (* ----------- Concurrency *) let append_from a b = let t = from (fun () -> a.next()) in let f () = let result = b.next () in t.next <- (fun () -> b.next ()); result in suffix_action_without_raise f t let merge test a b = if is_empty a then b else if is_empty b then a else let next_a = ref (a.next()) and next_b = ref (b.next()) in let aux () = let (n, na, nb) = if test !next_a !next_b then try (!next_a, a.next(), !next_b) with No_more_elements -> (*a is exhausted, b probably not*) push b !next_b; push b !next_a; raise No_more_elements else try (!next_b, !next_a, b.next()) with No_more_elements -> (*b is exhausted, a probably not*) push a !next_a; push a !next_b; raise No_more_elements in next_a := na; next_b := nb; n in append_from (append_from (from aux) a) b (*$T let a=List.enum [1;3;5] and b = List.enum[2;4] in \ let test = let r = ref false in (fun _ _ -> r:= not !r; !r) in \ merge test a b |> List.of_enum = [1;2;3;4;5] *) (*let mergen test a = ArrayLabels.fold_left ~init:[] ~f:(fun x -> let Array.of_list a let next = Array.map let rec aux = if Array.length !next = 1 then (*we're done*) if *) let interleave enums = let enums_len = Array.length enums in if not (enums_len > 0) then empty () else begin let available = Array.make enums_len true and next_idx = Array.init enums_len ((+) 1) in next_idx.((Array.length next_idx) - 1) <- 0 ; let rec next_elem idx = match get enums.(idx) with | Some x -> x , next_idx.(idx) | None -> begin available.(idx) <- false ; let rec loop k = let l = next_idx.(k) in if l = idx then raise No_more_elements else if available.(l) then (next_idx.(idx) <- l ; next_elem l) else loop l in loop idx end in from_loop 0 next_elem end (*$T interleave let e1 = List.enum [ 8 ; 2 ; 5 ; 2 ] and e2 = List.enum [ -5 ; -7 ; -6 ; 2 ; 1 ; -9 ; 2 ] in \ let e = interleave [| e1 ; e2 |] in \ List.of_enum e = [ 8 ; -5 ; 2 ; -7 ; 5 ; -6 ; 2 ; 2 ; 1 ; -9 ; 2 ] *) (*$R interleave let e1 = Enum.empty () and e2 = List.enum [ 8 ; 2 ; 5 ; 2 ] and e3 = List.enum [ -5 ; -7 ; -6 ; 2 ; 1 ; -9 ; 2 ] in let e = interleave [| e1; e2 ; e3 |] in assert_equal (List.of_enum e) [ 8 ; -5 ; 2 ; -7 ; 5 ; -6 ; 2 ; 2 ; 1 ; -9 ; 2 ] *) (*$R interleave let e1 = Enum.empty () and e2 = Enum.empty () and e3 = Enum.empty () in let e = interleave [| e1; e2 ; e3 |] in assert_equal (List.of_enum e) [ ] *) let slazy f = let constructor = lazy (f ()) in make ~next: (fun () -> (Lazy.force constructor).next ()) ~count: (fun () -> (Lazy.force constructor).count()) ~clone: (fun () -> (Lazy.force constructor).clone()) let delay = slazy let combination ?(repeat=false) n k = let binomial n p = let binom n p = if p < 0 || n < 0 || p > n then 0 else ( let a = ref 1 in for i = 1 to p do a := !a * (n + 1 - i) / i done; !a ) and comp = n - p in if (comp < p) then binom n comp else binom n p and add_repetitions = let rec conv range acc = function | [] -> acc | h::tl -> conv (range + 1) ((h - range) :: acc) tl in conv 0 [] in let order_to_comb n p repeat ord = let rec get_comb n p ord acc = if n <= 0 || p <= 0 || ord < 0 then acc else ( let b = binomial (n -1) (p - 1) in if ord < b then get_comb (n - 1) (p - 1) ord (n::acc) else get_comb (n - 1) p (ord - b) acc ) in let result = get_comb n p ord [] in if repeat then add_repetitions result else result and p = if repeat then n + k -1 else n in let length = binomial p k in let rec make_comb index = make ~next:(fun () -> if !index = length then raise No_more_elements else let next = order_to_comb p k repeat !index in incr index; next ) ~count:(fun () -> length - !index) ~clone:(fun () -> make_comb (ref !index)) in make_comb (ref 0) (*$T combination (combination 3 3 |> count) = 1 (combination ~repeat:true 3 3 |> count) = 10 (combination ~repeat:true 29 3 |> count) = 4495 (combination ~repeat:true 3 3 |> List.of_enum ) = \ [ [3; 3; 3]; [3; 3; 2]; [3; 3; 1]; [3; 2; 2]; [3; 2; 1]; [3; 1; 1]; \ [2; 2; 2]; [2; 2; 1]; [2; 1; 1]; \ [1; 1; 1]; ] *) let lsing f = init 1 (fun _ -> f ()) let lcons f e = append (lsing f) e let lapp f e = append (slazy f) e let ising = singleton let icons f e = append (ising f) e let iapp = append let hard_count t = if t.fast then let result = t.count () in close t; result else (*Counting would cache stuff, which we don't want here.*) let length = ref 0 in try while true do ignore (t.next()); incr length done; assert false with No_more_elements -> !length (* common hidden function for print and print_at_most *) let _print_common ~first ~last ~sep ~limit print_a out e = BatInnerIO.nwrite out first; match get e with | None -> BatInnerIO.nwrite out last | Some x -> print_a out x; let rec aux limit = match get e, limit with | None, _ -> BatInnerIO.nwrite out last | Some _, 0 -> BatInnerIO.nwrite out "..."; BatInnerIO.nwrite out last | Some x, _ -> BatInnerIO.nwrite out sep; print_a out x; aux (limit-1) in aux (limit-1) let print ?(first="") ?(last="") ?(sep=" ") print_a out e = _print_common ~first ~last ~sep ~limit:max_int print_a out e let print_at_most ?(first="") ?(last="") ?(sep=" ") ~limit print_a out e = if limit <= 0 then invalid_arg "Enum.print_at_most"; _print_common ~first ~last ~sep ~limit print_a out e (*$T print_at_most Printf.sprintf2 "yolo %a" (print_at_most ~limit:3 Int.print) \ (range 0 ~until:10) = "yolo 0 1 2..." *) let t_printer a_printer _paren out e = print ~first:"[" ~sep:"; " ~last:"]" (a_printer false) out e let compare cmp t u = let rec aux () = match (get t, get u) with | (None, None) -> 0 | (None, _) -> -1 | (_, None) -> 1 | (Some x, Some y) -> match cmp x y with | 0 -> aux () | n -> n in aux () let ord ord_val t u = let cmp_val = BatOrd.comp ord_val in BatOrd.ord0 (compare cmp_val t u) let equal eq t u = let rec aux () = match (get t, get u) with | (None, None) -> true | (Some x, Some y) -> eq x y && aux () | _ -> false in aux () (*$Q (Q.list Q.small_int) (fun l -> \ let e = List.enum l in equal Int.equal e (clone e)) *) let rec to_object t = object method next = t.next () method count= count t method clone = to_object (clone t) end let rec of_object o = make ~next:(fun () -> o#next) ~count:(fun () -> o#count) ~clone:(fun () -> of_object (o#clone)) let flatten = concat (*$T flatten (map singleton @@ List.enum [1;2;3]) |> List.of_enum = [1;2;3] *) let rec concat_map f t = let tn = ref (empty ()) in let rec next () = try (!tn).next () with No_more_elements -> tn := f (t.next()); next() in let clone () = append ((!tn).clone()) (concat_map f (t.clone())) in from2 next clone (*$T concat_map (1 -- 10 |> concat_map (fun x -> List.enum [x;-x]) |> sum) = 0 let e = (1 -- 10 |> concat_map (fun x -> List.enum [x;-x])) in \ let n = Enum.count e in \ n = (List.of_enum e |> List.length) let e = (1 -- 10 |> concat_map (fun x -> List.enum [x;-x])) in \ Enum.count e = 20 *) (*$Q concat_map Q.small_int (fun i -> \ let i = abs i in \ equal (=) (0 -- i) (concat_map singleton (0 -- i))) *) module Exceptionless = struct let find f e = try Some (find f e) with Not_found -> None end module Labels = struct let iter ~f x = iter f x let iter2 ~f x y = iter2 f x y let iteri ~f x = iteri f x let iter2i ~f x y = iter2i f x y let for_all ~f t = for_all f t let exists ~f t = exists f t let fold ~f ~init x = fold f init x let fold2 ~f ~init x y = fold2 f init x y let foldi ~f ~init x = foldi f init x let fold2i ~f ~init x y= fold2i f init x y let find ~f x = find f x let map ~f x = map f x let mapi ~f x = mapi f x let filter ~f x = filter f x let filter_map ~f x= filter_map f x let init x ~f = init x f let switch ~f = switch f let take_while ~f = take_while f let drop_while ~f = drop_while f let from ~f = from f let from_loop ~init ~f = from_loop init f let from_while ~f = from_while f let seq ~init ~f ~cnd = seq init f cnd let unfold ~init ~f = unfold init f let compare ?(cmp=Pervasives.compare) t u = compare cmp t u let uniq ?(cmp=(=)) x = uniq_by cmp x module LExceptionless = struct include Exceptionless let find ~f e = find f e end end module type Enumerable = sig type 'a enumerable val enum : 'a enumerable -> 'a t val of_enum : 'a t -> 'a enumerable end module WithMonad (Mon : BatInterfaces.Monad) = struct type 'a m = 'a Mon.m let sequence enum = let (>>=) = Mon.bind and return = Mon.return in (* We use a list as an accumulator for the result sequence computed under the monad. A previous version of this code used a Queue instead, which was problematic for backtracking monads. Due to the destructive nature of Enums, the current version will still be problematic but at least the result will be consistent. *) let of_acc acc = (* we don't use List functions to avoid creating a cyclic dependency *) let li = ref (List.rev acc) in from (fun () -> match !li with | [] -> raise No_more_elements | hd::tl -> li := tl; hd) in let rec loop acc = match get enum with | None -> return (of_acc acc) | Some elem -> elem >>= (fun x -> loop (x :: acc)) in loop [] let fold_monad f init enum = let (>>=) = Mon.bind and return = Mon.return in let rec fold m = match get enum with | None -> m | Some x -> m >>= fun acc -> fold (f acc x) in fold (return init) end module Monad = struct type 'a m = 'a t let return x = singleton x let bind m f = concat (map f m) end (*$T equal (=) (Monad.return 1) (singleton 1) equal (=) (Monad.bind (List.enum [1;2]) (fun x-> List.enum [x+1;x])) \ (List.enum [2;1;3;2]) *) (*$Q (Q.list Q.small_int) (fun l -> \ let id l = Monad.bind l Monad.return in \ List.enum l |> id |> List.of_enum = l) *) batteries-included-3.4.0/src/batEnum.mli000066400000000000000000001043461415601150500201600ustar00rootroot00000000000000(* * BatEnum - enumeration over abstract collection of elements. * Copyright (C) 2003 Nicolas Cannasse * 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Enumeration over abstract collection of elements. Enumerations are a representation of finite or infinite sequences of elements. In Batteries Included, enumerations are used pervasively, both as a uniform manner of reading and manipulating the contents of a data structure, or as a simple manner of reading or writing sequences of characters, numbers, strings, etc. from/to files, network connections or other inputs/outputs. Enumerations are typically computed as needed, which allows the definition and manipulation of huge (possibly infinite) sequences. Manipulating an enumeration is a uniform and often comfortable way of extracting subsequences (function {!filter} or operator [//] et al), converting sequences into other sequences (function {!map} or operators [/@] and [@/] et al), gathering information (function {!scanl} et al) or performing loops (functions {!iter} and {!map}). For instance, function {!BatRandom.enum_int} creates an infinite enumeration of random numbers. Combined with [//] and {!map}, we may turn this into an infinite enumeration of squares of random even numbers: [map (fun x -> x * x) ( (Random.enum_int 100) // even )] Similarly, to obtain an enumeration of 50 random integers, we may use {!take}, as follows: [take 50 (Random.enum_int 100)] As most data structures in Batteries can be enumerated and built from enumerations, these operations may be used also on lists, arrays, hashtables, etc. When designing a new data structure, it is usually a good idea to allow enumeration and construction from an enumeration. {b Note} Enumerations are not thread-safe. You should not attempt to access one enumeration from different threads. @author Nicolas Cannasse @author David Rajchenbach-Teller *) type 'a t (** A signature for data structures which may be converted to and from [enum]. If you create a new data structure, you should make it compatible with [Enumerable]. *) module type Enumerable = sig type 'a enumerable (** The data structure, e.g. ['a List.t] *) val enum : 'a enumerable -> 'a t (** Return an enumeration of the elements of the data structure *) val of_enum : 'a t -> 'a enumerable (** Build a data structure from an enumeration *) end include Enumerable with type 'a enumerable = 'a t include BatInterfaces.Mappable with type 'a mappable = 'a t (** {6 Final functions} These functions consume the enumeration until it ends or an exception is raised by the first argument function. *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f e] calls the function [f] with each elements of [e] in turn. *) val iter2 : ('a -> 'b -> unit) -> 'a t -> 'b t -> unit (** [iter2 f e1 e2] calls the function [f] with the next elements of [e1] and [e2] repeatedly until one of the two enumerations ends. *) val exists: ('a -> bool) -> 'a t -> bool (** [exists f e] returns [true] if there is some [x] in [e] such that [f x]*) val for_all: ('a -> bool) -> 'a t -> bool (** [for_all f e] returns [true] if for every [x] in [e], [f x] is true*) val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b (** A general loop on an enumeration. If [e] is empty, [fold f v e] returns [v]. Otherwise, [fold v e] returns [f (... (f (f v a0) a1) ...) aN] where [a0,a1..aN] are the elements of [e]. This function may be used, for instance, to compute the sum of all elements of an enumeration [e] as follows: [fold ( + ) 0 e]. Eager. *) val reduce : ('a -> 'a -> 'a) -> 'a t -> 'a (** A simplified version of [fold], which uses the first element of the enumeration as a default value. [reduce f e] throws [Not_found] if [e] is empty, returns its only element if e is a singleton, otherwise [f (... (f (f a0 a1) a2)...) aN] where [a0,a1..aN] are the elements of [e]. *) val sum : int t -> int (** [sum] returns the sum of the given int enum. If the argument is empty, returns 0. Eager *) val fsum : float t -> float (** @returns the sum of the enum's elements. Uses Kahan summing to get a more accurate answer than [reduce (+.)] would return, but runs slower. @since 2.0 *) val kahan_sum : float t -> float (** [kahan_sum l] returns a numerically-accurate sum of the floats of [l]. See {!BatArray.fsum} for more details. @since 2.2.0 *) val fold2 : ('a -> 'b -> 'c -> 'c) -> 'c -> 'a t -> 'b t -> 'c (** [fold2] is similar to [fold] but will fold over two enumerations at the same time until one of the two enumerations ends. *) val scanl : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b t (** A variant of [fold] producing an enumeration of its intermediate values. If [e] contains [x0], [x1], ..., [scanl f init e] is the enumeration containing [init], [f init x0], [f (f init x0) x1]... Lazy. *) val scan : ('a -> 'a -> 'a) -> 'a t -> 'a t (** [scan] is similar to [scanl] but without the [init] value: if [e] contains [x0], [x1], [x2] ..., [scan f e] is the enumeration containing [x0], [f x0 x1], [f (f x0 x1) x2]... For instance, [scan ( * ) (1 -- 10)] will produce an enumeration containing the successive values of the factorial function.*) (** Indexed functions : these functions are similar to previous ones except that they call the function with one additional argument which is an index starting at 0 and incremented after each call to the function. *) val iteri : (int -> 'a -> unit) -> 'a t -> unit val iter2i : ( int -> 'a -> 'b -> unit) -> 'a t -> 'b t -> unit val foldi : (int -> 'a -> 'b -> 'b) -> 'b -> 'a t -> 'b val fold2i : (int -> 'a -> 'b -> 'c -> 'c) -> 'c -> 'a t -> 'b t -> 'c (** {6 Useful functions} *) val find : ('a -> bool) -> 'a t -> 'a (** [find f e] returns the first element [x] of [e] such that [f x] returns [true], consuming the enumeration up to and including the found element. @raise Not_found if no such element exists in the enumeration, consuming the whole enumeration in the search. Since [find] (eagerly) consumes a prefix of the enumeration, it can be used several times on the same enumeration to find the next element. *) val find_map : ('a -> 'b option) -> 'a t -> 'b (** [find_map f e] finds the first element [x] of [e] such that [f x] returns [Some r], then returns r. It consumes the enumeration up to and including the found element. @raise Not_found if no such element exists in the enumeration, consuming the whole enumeration in the search. Since [find_map] (eagerly) consumes a prefix of the enumeration, it can be used several times on the same enumeration to find the next element. @since 2.0 *) val is_empty : 'a t -> bool (** [is_empty e] returns true if [e] does not contains any element. Forces at most one element. *) val peek : 'a t -> 'a option (** [peek e] returns [None] if [e] is empty or [Some x] where [x] is the next element of [e]. The element is not removed from the enumeration. *) val get : 'a t -> 'a option (** [get e] returns [None] if [e] is empty or [Some x] where [x] is the next element of [e], in which case the element is removed from the enumeration. *) val get_exn : 'a t -> 'a (** [get_exn e] returns the first element of [e]. @raise No_more_elements if [e] is empty. @since 2.0 *) val push : 'a t -> 'a -> unit (** [push e x] will add [x] at the beginning of [e]. *) val junk : 'a t -> unit (** [junk e] removes the first element from the enumeration, if any. *) val clone : 'a t -> 'a t (** [clone e] creates a new enumeration that is copy of [e]. If [e] is consumed by later operations, the clone will not get affected. *) val force : 'a t -> unit (** [force e] forces the application of all lazy functions and the enumeration of all elements, exhausting the enumeration. An efficient intermediate data structure of enumerated elements is constructed and [e] will now enumerate over that data structure. *) val take : int -> 'a t -> 'a t (** [take n e] returns the prefix of [e] of length [n], or [e] itself if [n] is greater than the length of [e] *) val drop : int -> 'a t -> unit (** [drop n e] removes the first [n] element from the enumeration, if any. *) val skip: int -> 'a t -> 'a t (** [skip n e] removes the first [n] element from the enumeration, if any, then returns [e]. This function has the same behavior as [drop] but is often easier to compose with, e.g., [skip 5 %> take 3] is a new function which skips 5 elements and then returns the next 3 elements.*) val take_while : ('a -> bool) -> 'a t -> 'a t (** [take_while f e] produces a new enumeration in which only remain the first few elements [x] of [e] such that [f x] *) val drop_while : ('a -> bool) -> 'a t -> 'a t (** [drop_while p e] produces a new enumeration in which only all the first elements such that [f e] have been junked.*) val span : ('a -> bool) -> 'a t -> 'a t * 'a t (** [span test e] produces two enumerations [(hd, tl)], such that [hd] is the same as [take_while test e] and [tl] is the same as [drop_while test e]. *) val break : ('a -> bool) -> 'a t -> 'a t * 'a t (** Negated span. [break test e] is equivalent to [span (fun x -> not (test x)) e] *) val group : ('a -> 'b) -> 'a t -> 'a t t (** [group test e] divides [e] into an enumeration of enumerations, where each sub-enumeration is the longest continuous enumeration of elements whose [test] results are the same. [Enum.group (x -> x mod 2) [1;2;4;1] = [[1];[2;4];[1]]] [Enum.group (fun x -> x mod 3) [1;2;4;1] = [[1];[2];[4;1]]] [Enum.group (fun s -> s.[0]) ["cat"; "canary"; "dog"; "dodo"; "ant"; "cow"] = [["cat"; "canary"];["dog";"dodo"];["ant"];["cow"]]] Warning: The result of this operation cannot be directly cloned safely; instead, reify to a non-lazy structure and read from that structure multiple times. *) val group_by : ('a -> 'a -> bool) -> 'a t -> 'a t t (** [group_by eq e] divides [e] into an enumeration of enumerations, where each sub-enumeration is the longest continuous enumeration of elements that are equal, as judged by [eq]. Warning: The result of this operation cannot be directly cloned safely; instead, reify to a non-lazy structure and read from that structure multiple times. *) val clump : int -> ('a -> unit) -> (unit -> 'b) -> 'a t -> 'b t (** [clump size add get e] runs [add] on [size] (or less at the end) elements of [e] and then runs [get] to produce value for the result enumeration. Useful to convert a char enum into string enum. *) val cartesian_product : 'a t -> 'b t -> ('a * 'b) t (** [cartesian_product e1 e2] computes the cartesian product of [e1] and [e2]. Pairs are enumerated in a non-specified order, but in fair enough an order so that it works on infinite enums (i.e. even then, any pair is eventually returned) @since 2.2.0 *) (** {6 Lazy constructors} These functions are lazy which means that they will create a new modified enumeration without actually enumerating any element until they are asked to do so by the programmer (using one of the functions above). When the resulting enumerations of these functions are consumed, the underlying enumerations they were created from are also consumed. *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f e] returns an enumeration over [(f a0, f a1, ...)] where [a0,a1...] are the elements of [e]. Lazy. *) val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t (** [mapi] is similar to [map] except that [f] is passed one extra argument which is the index of the element in the enumeration, starting from 0 : mapi f e returns an enumeration over [(f 0 a0, f 1 a1, ...)] where [a0,a1...] are the elements of [e]. *) val filter : ('a -> bool) -> 'a t -> 'a t (** [filter f e] returns an enumeration over all elements [x] of [e] such as [f x] returns [true]. Lazy. {b Note} filter is lazy in that it returns a lazy enumeration, but each element in the result is eagerly searched in the input enumeration. Therefore, the access to a given element in the result will diverge if it is preceded, in the input enumeration, by infinitely many false elements (elements on which the predicate [p] returns [false]). Other functions that may drop an unbound number of elements ([filter_map], [take_while], etc.) have the same behavior. *) val filter_map : ('a -> 'b option) -> 'a t -> 'b t (** [filter_map f e] returns an enumeration over all elements [x] such as [f y] returns [Some x] , where [y] is an element of [e]. [filter_map] works on infinite enumerations; see [filter]. *) val append : 'a t -> 'a t -> 'a t (** [append e1 e2] returns an enumeration that will enumerate over all elements of [e1] followed by all elements of [e2]. Lazy. {b Note} The behavior of appending [e] to itself or to something derived from [e] is not specified. In particular, cloning [append e e] may destroy any sharing between the first and the second argument. *) val prefix_action : (unit -> unit) -> 'a t -> 'a t (** [prefix_action f e] will behave as [e] but guarantees that [f ()] will be invoked exactly once before the current first element of [e] is read. If [prefix_action f e] is cloned, [f] is invoked only once, during the cloning. If [prefix_action f e] is counted, [f] is invoked only once, during the counting. May be used for signalling that reading starts or for performing delayed evaluations.*) val suffix_action : (unit -> unit) -> 'a t -> 'a t (** [suffix_action f e] will behave as [e] but guarantees that [f ()] will be invoked after the contents of [e] are exhausted. If [suffix_action f e] is cloned, [f] is invoked only once, when the original enumeration is exhausted. If [suffix_action f e] is counted, [f] is only invoked if the act of counting requires a call to [force]. May be used for signalling that reading stopped or for performing delayed evaluations.*) val concat : 'a t t -> 'a t (** [concat e] returns an enumeration over all elements of all enumerations of [e]. *) val flatten : 'a t t -> 'a t (** Synonym of {!concat}*) val concat_map : ('a -> 'b t) -> 'a t -> 'b t (** Synonym of {!Monad.bind}, with flipped arguments. [concat_map f e] is the same as [concat (map f e)]. @since 2.2.0 *) (** {6 Constructors} In this section the word {i shall} denotes a semantic requirement. The correct operation of the functions in this interface are conditional on the client meeting these requirements. *) exception No_more_elements (** This exception {i shall} be raised by the [next] function of [make] or [from] when no more elements can be enumerated, it {i shall not} be raised by any function which is an argument to any other function specified in the interface. *) exception Infinite_enum (** As a convenience for debugging, this exception {i may} be raised by the [count] function of [make] when attempting to count an infinite enum.*) val empty : unit -> 'a t (** The empty enumeration : contains no element *) val make : next:(unit -> 'a) -> count:(unit -> int) -> clone:(unit -> 'a t) -> 'a t (** This function creates a fully defined enumeration. {ul {li the [next] function {i shall} return the next element of the enumeration or raise [No_more_elements] if the underlying data structure does not have any more elements to enumerate.} {li the [count] function {i shall} return the actual number of remaining elements in the enumeration or {i may} raise [Infinite_enum] if it is known that the enumeration is infinite.} {li the [clone] function {i shall} create a clone of the enumeration such as operations on the original enumeration will not affect the clone. }} For some samples on how to correctly use [make], you can have a look at implementation of [BatList.enum]. *) val from : (unit -> 'a) -> 'a t (** [from next] creates an enumeration from the [next] function. [next] {i shall} return the next element of the enumeration or raise [No_more_elements] when no more elements can be enumerated. Since the enumeration definition is incomplete, a call to [count] will result in a call to [force] that will enumerate all elements in order to return a correct value. *) val from_while : (unit -> 'a option) -> 'a t (** [from_while next] creates an enumeration from the [next] function. [next] {i shall} return [Some x] where [x] is the next element of the enumeration or [None] when no more elements can be enumerated. Since the enumeration definition is incomplete, a call to [clone] or [count] will result in a call to [force] that will enumerate all elements in order to return a correct value. *) val from_loop: 'b -> ('b -> ('a * 'b)) -> 'a t (**[from_loop data next] creates a (possibly infinite) enumeration from the successive results of applying [next] to [data], then to the result, etc. The list ends whenever the function raises {!BatEnum.No_more_elements}.*) val seq : 'a -> ('a -> 'a) -> ('a -> bool) -> 'a t (** [seq init step cond] creates a sequence of data, which starts from [init], extends by [step], until the condition [cond] fails. E.g. [seq 1 ((+) 1) ((>) 100)] returns [1, 2, ... 99]. If [cond init] is false, the result is empty. *) val unfold: 'b -> ('b -> ('a * 'b) option) -> 'a t (**As [from_loop], except uses option type to signal the end of the enumeration. [unfold data next] creates a (possibly infinite) enumeration from the successive results of applying [next] to [data], then to the result, etc. The enumeration ends whenever the function returns [None] Example: [Enum.unfold n (fun x -> if x = 1 then None else Some (x, if x land 1 = 1 then 3 * x + 1 else x / 2))] returns the hailstone sequence starting at [n]. *) val init : int -> (int -> 'a) -> 'a t (** [init n f] creates a new enumeration over elements [f 0, f 1, ..., f (n-1)] *) val singleton : 'a -> 'a t (** Create an enumeration consisting of exactly one element.*) val repeat : ?times:int -> 'a -> 'a t (** [repeat ~times:n x] creates a enum sequence filled with [n] times of [x]. It return infinite enum when [~times] is absent. It returns empty enum when [times <= 0] *) val cycle : ?times:int -> 'a t -> 'a t (** [cycle] is similar to [repeat], except that the content to fill is a subenum rather than a single element. Note that [times] represents the times of repeating not the length of enum. When [~times] is absent the result is an infinite enum. *) val delay : (unit -> 'a t) -> 'a t (** [delay (fun () -> e)] produces an enumeration which behaves as [e]. The enumeration itself will only be computed when consumed. A typical use of this function is to explore lazily non-trivial data structures, as follows: [type 'a tree = Leaf | Node of 'a * 'a tree * 'a tree let enum_tree = let rec aux = function | Leaf -> BatEnum.empty () | Node (n, l, r) -> BatEnum.append (BatEnum.singleton n) (BatEnum.append (delay (fun () -> aux l)) (delay (fun () -> aux r))) ] *) val to_object: 'a t -> ( as 'b) (**[to_object e] returns a representation of [e] as an object.*) val of_object: ( as 'b) -> 'a t (**[of_object e] returns a representation of an object as an enumeration*) val enum : 'a t -> 'a t (** identity : added for consistency with the other data structures *) val of_enum : 'a t -> 'a t (** identity : added for consistency with the other data structures *) val combination : ?repeat:bool -> int -> int -> int list t (** [combination n k] returns an enumeration over combination of [k] elements between [n] distincts elements. If [repeat] is true, the combination may contain the same elements many times.*) (** {6 Counting} *) val count : 'a t -> int (** [count e] returns the number of remaining elements in [e] without consuming the enumeration. Depending of the underlying data structure that is implementing the enumeration functions, the count operation can be costly, and even sometimes can cause a call to [force]. *) val fast_count : 'a t -> bool (** For users worried about the speed of [count] you can call the [fast_count] function that will give an hint about [count] implementation. Basically, if the enumeration has been created with [make] or [init] or if [force] has been called on it, then [fast_count] will return true. *) val hard_count : 'a t -> int (** [hard_count] returns the number of remaining in elements in [e], consuming the whole enumeration somewhere along the way. This function is always at least as fast as the fastest of either [count] or a [fold] on the elements of [t]. This function is useful when you have opened an enumeration for the sole purpose of counting its elements (e.g. the number of lines in a file).*) (** {6 Utilities } *) val range : ?until:int -> int -> int t (** [range p until:q] creates an enumeration of integers [[p, p+1, ..., q]]. If [until] is omitted, the enumeration is not bounded. Behaviour is not-specified once [max_int] has been reached.*) val dup : 'a t -> 'a t * 'a t (** [dup stream] returns a pair of streams which are identical to [stream]. Note that stream is a destructive data structure, the point of [dup] is to return two streams can be used independently. *) val combine : 'a t -> 'b t -> ('a * 'b) t (** [combine] transform two streams into a stream of pairs of corresponding elements. If one stream is shorter, excess elements of the longer stream are ignored. Curried @since 3.0 *) val uncombine : ('a * 'b) t -> 'a t * 'b t (** [uncombine] is the opposite of [combine] *) val merge : ('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t (** [merge test a b] merge the elements from [a] and [b] into a single enumeration. At each step, [test] is applied to the first element [xa] of [a] and the first element [xb] of [b] to determine which should get first into resulting enumeration. If [test xa xb] returns [true], [xa] (the first element of [a]) is used, otherwise [xb] is used. If [a] or [b] runs out of elements, the process will append all elements of the other enumeration to the result. For example, if [a] and [b] are enumerations of integers sorted in increasing order, then [merge (<) a b] will also be sorted. *) val interleave : 'a t array -> 'a t (** [interleave enums] creates a new enumeration from an array of enumerations. The new enumeration first yields the first elements of the enumerations in the supplied order, then second elements, etc. Thus, a sequence [ [| [x11 ; x12 ; ...] ; [x21 ; x22, ...] , ... [xN1 ; xN2 ; ...] |] ] becomes [[ x11 ; x12 ; ... ; xN1 ; x21 ; x22 ; ... ; xN2 ; x31 ; ... ]]. *) val uniq : 'a t -> 'a t (** [uniq e] returns a duplicate of [e] with repeated values omitted (similar to unix's [uniq] command). It uses structural equality to compare consecutive elements. *) val uniqq : 'a t -> 'a t (** [uniqq e] behaves as [uniq e] except it uses physical equality to compare consecutive elements. @since 2.4.0 *) val uniq_by : ('a -> 'a -> bool) -> 'a t -> 'a t (** [uniq_by cmp e] behaves as [uniq e] except it allows to specify a comparison function. @since 2.4.0 *) val switch : ('a -> bool) -> 'a t -> 'a t * 'a t (** [switch test enum] splits [enum] into two enums, where the first enum have all the elements satisfying [test], the second enum is opposite. The order of elements in the source enum is preserved. *) val partition : ('a -> bool) -> 'a t -> 'a t * 'a t (** as [switch] @added v1.4.0 *) (*val switchn: int -> ('a -> int) -> 'a t -> 'a t array (** [switchn] is the array version of [switch]. [switch n f fl] split [fl] to an array of [n] enums, [f] is applied to each element of [fl] to decide the id of its destination enum. *)*) val arg_min : ('a -> 'b) -> 'a t -> 'a val arg_max : ('a -> 'b) -> 'a t -> 'a (** [arg_min f xs] returns the [x] in [xs] for which [f x] is minimum. Similarly for [arg_max], except it returns the maximum. If multiple values reach the maximum, one of them is returned. (currently the first, but this is not guaranteed) Example: [-5 -- 5 |> arg_min (fun x -> x * x + 6 * x - 5) = -3] Example: [List.enum ["cat"; "canary"; "dog"; "dodo"; "ant"; "cow"] |> arg_max String.length = "canary"] @added v1.4.0 @raise Invalid_argument if the input enum is empty *) (** {6 Trampolining} *) val while_do : ('a -> bool) -> ('a t -> 'a t) -> 'a t -> 'a t (** [while_do cont f e] is a loop on [e] using [f] as body and [cont] as condition for continuing. If [e] contains elements [x0], [x1], [x2]..., then if [cont x0] is [false], [x0] is returned as such and treatment stops. On the other hand, if [cont x0] is [true], [f x0] is returned and the loop proceeds with [x1]... Note that f is used as halting condition {i after} the corresponding element has been added to the result stream. *) (** {6 Infix operators} *) (** Infix versions of some functions This module groups together all infix operators so that you can open it without opening the whole batEnum module. *) module Infix : sig val ( -- ) : int -> int -> int t (** As [range], without the label. [5 -- 10] is the enumeration 5,6,7,8,9,10. [10 -- 5] is the empty enumeration*) val ( --^ ) : int -> int -> int t (** As [(--)] but without the right endpoint [5 --^ 10] is the enumeration 5,6,7,8,9. *) val ( --. ) : (float * float) -> float -> float t (** [(a, step) --. b)] creates a float enumeration from [a] to [b] with an increment of [step] between elements. [(5.0, 1.0) --. 10.0] is the enumeration 5.0,6.0,7.0,8.0,9.0,10.0. [(10.0, -1.0) --. 5.0] is the enumeration 10.0,9.0,8.0,7.0,6.0,5.0. [(10.0, 1.0) --. 1.0] is the empty enumeration. *) val ( --- ) : int -> int -> int t (** As [--], but accepts enumerations in reverse order. [5 --- 10] is the enumeration 5,6,7,8,9,10. [10 --- 5] is the enumeration 10,9,8,7,6,5.*) val ( --~ ) : char -> char -> char t (** As ( -- ), but for characters.*) val ( // ) : 'a t -> ('a -> bool) -> 'a t (** Filtering (pronounce this operator name "such that"). For instance, [(1 -- 37) // odd] is the enumeration of all odd numbers between 1 and 37.*) val ( /@ ) : 'a t -> ('a -> 'b) -> 'b t val ( @/ ) : ('a -> 'b) -> 'a t -> 'b t (** Mapping operators. These operators have the same meaning as function {!map} but are sometimes more readable than this function, when chaining several transformations in a row. *) val ( //@ ) : 'a t -> ('a -> 'b option) -> 'b t val ( @// ) : ('a -> 'b option) -> 'a t -> 'b t (** Map combined with filter. Same as {!filter_map}. *) end val ( -- ) : int -> int -> int t val ( --^ ) : int -> int -> int t val ( --. ) : (float * float) -> float -> float t val ( --- ) : int -> int -> int t val ( --~ ) : char -> char -> char t val ( // ) : 'a t -> ('a -> bool) -> 'a t val ( /@ ) : 'a t -> ('a -> 'b) -> 'b t val ( @/ ) : ('a -> 'b) -> 'a t -> 'b t val ( //@ ) : 'a t -> ('a -> 'b option) -> 'b t val ( @// ) : ('a -> 'b option) -> 'a t -> 'b t (** {6 Monad related modules} *) (** Monadic operations on Enumerations containing monadic elements This module will let you use sequence and fold_monad functions over enumerations. *) module WithMonad : functor (Mon : BatInterfaces.Monad) -> sig type 'a m = 'a Mon.m (** Type of the monadic elements. *) val sequence : 'a m t -> 'a t m (** [sequence e] evaluates each monadic elements (of type ['a m]) contained in the enumeration [e] to get a monadic enumeration of ['a] elements, of type ['a BatEnum.t m]. *) val fold_monad : ('a -> 'b -> 'a m) -> 'a -> 'b t -> 'a m (** [fold_monad f init e] does a folding of the enumeration [e] applying step by step the function [f] that gives back results in the [Mon] monad, with the [init] initial element. The result is a value in the [Mon] monad. *) end (** The BatEnum Monad This module provides everything needed for writing and executing computations in the BatEnum Monad. *) module Monad : sig type 'a m = 'a t (** The type of the BatEnum monad's elements, thus [BatEnum.t]. *) val return : 'a -> 'a m (** This function puts a single value in the BatEnum monad, that is to say it creates an enumeration containing a single element. *) val bind : 'a m -> ('a -> 'b m) -> 'b m (** [bind m f] takes the result of the monadic computation m, puts the f function in the monadic context passing it the result of m and then returning a monadic result. *) end (** {6 Boilerplate code}*) val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> 'b t -> unit (** Print and consume the contents of an enumeration.*) val print_at_most : ?first:string -> ?last:string -> ?sep:string -> limit:int -> ('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> 'b t -> unit (** [print_at_most pp limit out enum] consumes [enum] to print its elements into [out] (using [pp] to print individual elements). At most [limit] arguments are printed, if more elements are available an ellipsis "..." is added. @raise Invalid_argument if the limit is <= 0. @since 2.2.0 *) val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int (** [compare cmp a b] compares enumerations [a] and [b] by lexicographical order using comparison [cmp]. @return 0 if [a] and [b] are equal wrt [cmp] @return -1 if [a] is empty and [b] is not @return 1 if [b] is empty and [a] is not @return [cmp x y], where [x] is the first element of [a] and [y] is the first element of [b], if [cmp x y <> 0] @return [compare cmp a' b'], where [a'] and [b'] are respectively equal to [a] and [b] without their first element, if both [a] and [b] are non-empty and [cmp x y = 0], where [x] is the first element of [a] and [y] is the first element of [b] *) val ord : ('a -> 'a -> BatOrd.order) -> 'a t -> 'a t -> BatOrd.order (** Same as [compare] but returning a {!BatOrd.order} instead of an integer. *) val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** [equal eq a b] returns [true] when [a] and [b] contain the same sequence of elements. *) (** {6 Override modules}*) (** The following modules replace functions defined in {!BatEnum} with functions behaving slightly differently but having the same name. This is by design: the functions meant to override the corresponding functions of {!BatEnum}. *) (** Operations on {!BatEnum} without exceptions.*) module Exceptionless : sig val find : ('a -> bool) -> 'a t -> 'a option (** [find f e] returns [Some x] where [x] is the first element [x] of [e] such that [f x] returns [true], consuming the enumeration up to and including the found element, or [None] if no such element exists in the enumeration, consuming the whole enumeration in the search. Since [find] consumes a prefix of the enumeration, it can be used several times on the same enumeration to find the next element. *) end (** Operations on {!BatEnum} with labels. This module overrides a number of functions of {!BatEnum} by functions in which some arguments require labels. These labels are there to improve readability and safety and to let you change the order of arguments to functions. In every case, the behavior of the function is identical to that of the corresponding function of {!BatEnum}. *) module Labels : sig val iter: f:('a -> unit) -> 'a t -> unit val iter2: f:('a -> 'b -> unit) -> 'a t -> 'b t -> unit val exists: f:('a -> bool) -> 'a t -> bool val for_all: f:('a -> bool) -> 'a t -> bool val fold: f:('b -> 'a -> 'b) -> init:'b -> 'a t -> 'b val fold2: f:('a -> 'b -> 'c -> 'c) -> init:'c -> 'a t -> 'b t -> 'c val iteri: f:(int -> 'a -> unit) -> 'a t -> unit val iter2i: f:( int -> 'a -> 'b -> unit) -> 'a t -> 'b t -> unit val foldi: f:(int -> 'a -> 'b -> 'b) -> init:'b -> 'a t -> 'b val fold2i: f:(int -> 'a -> 'b -> 'c -> 'c) -> init:'c -> 'a t -> 'b t -> 'c val find: f:('a -> bool) -> 'a t -> 'a val take_while: f:('a -> bool) -> 'a t -> 'a t val drop_while: f:('a -> bool) -> 'a t -> 'a t val map: f:('a -> 'b) -> 'a t -> 'b t val mapi: f:(int -> 'a -> 'b) -> 'a t -> 'b t val filter: f:('a -> bool) -> 'a t -> 'a t val filter_map: f:('a -> 'b option) -> 'a t -> 'b t val from: f:(unit -> 'a) -> 'a t val from_while: f:(unit -> 'a option) -> 'a t val from_loop: init:'b -> f:('b -> ('a * 'b)) -> 'a t val seq: init:'a -> f:('a -> 'a) -> cnd:('a -> bool) -> 'a t val unfold: init:'b -> f:('b -> ('a * 'b) option) -> 'a t val init: int -> f:(int -> 'a) -> 'a t val switch: f:('a -> bool) -> 'a t -> 'a t * 'a t val compare: ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int val uniq: ?cmp:('a -> 'a -> bool) -> 'a t -> 'a t module LExceptionless : sig val find : f:('a -> bool) -> 'a t -> 'a option end end (**/**) (** {6 For system use only, not for the casual user} For compatibility with {!Stream} *) val iapp : 'a t -> 'a t -> 'a t val icons : 'a -> 'a t -> 'a t val ising : 'a -> 'a t val lapp : (unit -> 'a t) -> 'a t -> 'a t val lcons : (unit -> 'a) -> 'a t -> 'a t val lsing : (unit -> 'a) -> 'a t val slazy : (unit -> 'a t) -> 'a t (**/**) batteries-included-3.4.0/src/batFile.ml000066400000000000000000000166051415601150500177620ustar00rootroot00000000000000(* * File - File manipulation * Copyright (C) 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (* this code is purposedly before any module open directive *) let count_lines (fn: string): int = let count = ref 0 in let input = open_in fn in (try while true do let _line = input_line input in incr count done with End_of_file -> close_in input); !count (*$T count_lines (Sys.file_exists __FILE__) && (count_lines __FILE__ > 0) *) open BatIO open ListLabels open Unix let finally = BatInnerPervasives.finally (* Permissions *) type permission = int (**Internally, permissions are represented in Unix-style octal.*) let default_permission = 0o000 let user_read = 0o400 let user_write = 0o200 let user_exec = 0o100 let group_read = 0o040 let group_write = 0o020 let group_exec = 0o010 let other_read = 0o004 let other_write = 0o002 let other_exec = 0o001 let perm l = fold_left l ~init:default_permission ~f:(fun acc x -> acc lor x) let unix_perm i = if 0 <= i && i <= 511 then i else Printf.ksprintf invalid_arg "File.unix_perm: Unix permission %o" i (* Opening *) type open_in_flag = [ `create | `excl (**Fail if the file exists and [`create] is set *) | `text (**Open in ascii mode -- if this flag is not specified or if the operating system does not perform conversions, the file is opened in binary mode. *) | `nonblock (**Open in non-blocking mode *) | `mmap (**Open in memory-mapped mode (experimental)*) ] type open_out_flag = [ `append (**Start writing at the end of the file rather than the start *) | `create (**Create the file if it does not exist *) | `trunc (**Empty the file if it already exists (on by default) *) | `excl (**Fail if the file exists and [`create] is set *) | `text (**Open in ascii mode -- if this flag is not specified or if the operating system does not perform conversions, the file is opened in binary mode. *) | `nonblock (**Open in non-blocking mode *) ] (** Convert a [open_in_flag list] into a low-level [open_flag list] *) let in_chan_mode ?mode binary = let mode_to_open_flag l = let rec aux acc is_binary = function | [] -> if is_binary then Open_binary::acc else Open_text ::acc | `create::t -> aux (Open_creat::acc) is_binary t | `excl::t -> aux (Open_excl::acc) is_binary t | `text::t -> aux acc false t | `nonblock::t -> aux (Open_nonblock::acc) is_binary t | _::t -> aux acc is_binary t (*Allow for future extensions*) in aux [] binary l in match mode with | None -> [Open_rdonly; Open_binary] | Some l -> mode_to_open_flag l (** Convert a [open_out_flag list] into a low-level [open_flag list] *) let out_chan_mode ?mode binary = let mode_to_open_flag l = let rec aux acc is_binary = function | [] -> let acc' = if List.mem Open_append acc then acc else Open_trunc::acc in if is_binary then Open_binary::acc' else Open_text ::acc' | `append::t -> aux (Open_append::acc) is_binary t | `trunc::t -> aux (Open_trunc::acc) is_binary t | `create::t -> aux (Open_creat::acc) is_binary t | `excl::t -> aux (Open_excl::acc) is_binary t | `text::t -> aux acc false t | `nonblock::t -> aux (Open_nonblock::acc) is_binary t | _::t -> aux acc is_binary t (*Allow for future extensions*) in aux [] binary l in match mode with | None -> [Open_wronly; Open_binary; Open_creat; Open_trunc] | Some l -> Open_wronly :: (mode_to_open_flag l) let open_out ?mode ?(perm=0o666) name = (* Printf.eprintf "Opening out\n%!";*) output_channel ~cleanup:true (open_out_gen (out_chan_mode ?mode true) perm name) open BatBigarray let open_in ?mode ?(perm=default_permission) name = let unix_mode = in_chan_mode ?mode true in match mode with | Some l when List.mem `mmap l -> let desc = Unix.openfile name [O_RDONLY] 0 in let array= Array1.map_file desc char c_layout (*shared*)false (-1) in let pos = ref 0 and len = Array1.dim array in create_in ~read:(fun () -> if !pos >= len then raise No_more_input else Array1.get array (BatRef.post_incr pos)) ~input:(fun sout _p l -> if !pos >= len then raise No_more_input; let n = (if !pos + l > len then len - !pos else l) in for i = 0 to n - 1 do Bytes.set sout (!pos + i) (Array1.get array i) done; (* String.unsafe_blit s (post pos ( (+) n ) ) sout p n;*) pos := !pos + n; n ) ~close:(fun () -> Unix.close desc) | _ -> input_channel ~cleanup:true ~autoclose:false (open_in_gen unix_mode perm name) let with_do opener closer x f = let file = opener x in finally (fun () -> closer file) f file let with_file_in ?mode ?perm x = with_do (open_in ?mode ?perm) close_in x let with_file_out ?mode ?perm x = with_do (open_out ?mode ?perm) close_out x let lines_of file = BatIO.lines_of (open_in file) let write_lines file lines = let mode = [`trunc; `create] in with_file_out ~mode file (fun oc -> BatEnum.iter (BatIO.write_line oc) lines) (** {6 Temporary files} *) type open_temporary_out_flag = [ open_out_flag | `delete_on_exit (**Should the file be deleted when program ends?*) ] let open_temporary_out ?mode ?(prefix="ocaml") ?(suffix="tmp") ?temp_dir () : (_ output * string) = let chan_mode = out_chan_mode ?mode true in let (name, cout) = Filename.open_temp_file ?temp_dir ~mode:chan_mode prefix suffix in let out = output_channel ~cleanup:true cout in (match mode with | Some l when List.mem `delete_on_exit l -> Pervasives.at_exit (fun () -> try BatIO.close_out out; Sys.remove name with _ -> ()) | _ -> ()); (out, name) let with_temporary_out ?mode ?prefix ?suffix ?temp_dir f = let (file, name) = open_temporary_out ?mode ?prefix ?suffix ?temp_dir () in finally (fun () -> close_out file) (fun (file, name) -> f file name) (file, name) (** {6 File manipulation} *) open Unix let size_of s = (stat s).st_size let size_of_big s = (LargeFile.stat s).LargeFile.st_size let chmod = Unix.chmod let set_permissions = chmod batteries-included-3.4.0/src/batFile.mli000066400000000000000000000203211415601150500201210ustar00rootroot00000000000000(* * File - File manipulation * Copyright (C) 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** File manipulation. @author David Teller *) open BatInnerIO (** {6 Utilities} *) val lines_of : string -> string BatEnum.t (** [lines_of name] reads the contents of file [name] as an enumeration of lines. The file is automatically closed once the last line has been reached or the enumeration is garbage-collected. *) val count_lines: string -> int (** [count_lines filename] count the number of lines in given file. Lines are read by the stdlib's input_line function. @since 3.1.0 *) val write_lines: string -> string BatEnum.t -> unit (** [write_lines name lines] writes strings given by [lines] to file [name] with newline character appended to each line. *) val size_of: string -> int (** [size_of name] returns the size of file [name] in bytes.*) val size_of_big: string -> Int64.t (** [size_of_big name] returns the size of file [name] in bytes, as a 64-bit integer. This function is provided as the size of a file larger than 1 Gb cannot be represented with an [int] on a 32-bit machine.*) (** {6 File permissions} File permissions are used when creating a file to allow controlling which users may read, write or open that file. To use a permission, create a value of type {!permission} and pass it as argument to {!open_in}, {!open_out}, {!with_file_in} or {!with_file_out}. *) type permission (** The list of operations which are permitted on a file.*) val default_permission: permission (**Default permissions.*) val user_read: permission (**Give the current user permission to read the file. Ignored under Windows.*) val user_write: permission (**Give the current user permission to write the file*) val user_exec: permission (**Give the current user permission to execute the file. Ignored under Windows.*) val group_read: permission (**Give the permission to read the file to the group containing the user. Ignored under Windows.*) val group_write: permission (**Give the permission to write the file to the group containing the user. Ignored under Windows.*) val group_exec: permission (**Give the permission to execute the file to the group containing the user. Ignored under Windows.*) val other_read: permission (**Give the permission to read the file to the rest of the world. Ignored under Windows.*) val other_write: permission (**Give the permission to modify the file to the rest of the world. Ignored under Windows.*) val other_exec: permission (**Give the permission to execute the file to the rest of the world. Ignored under Windows.*) val perm : permission list -> permission (**Join permissions*) val unix_perm : int -> permission (**Create a permission from a Unix-style octal integer. See your favorite Unix documentation on [chmod] for more details. @raise Invalid_argument if given number outside the [[0, 0o777]] range *) val set_permissions: string -> permission -> unit (** Set the permissions on a file.*) val chmod: string -> permission -> unit (** As {!set_permissions}*) (** {6 Opening a file for reading} *) type open_in_flag = [ `create | `excl (**Fail if the file exists and [`create] is set *) | `text (**Open in ascii mode -- if this flag is not specified or if the operating system does not perform conversions, the file is opened in binary mode. *) | `nonblock (**Open in non-blocking mode *) | `mmap (**Open in memory-mapped mode (experimental)*) ] val open_in : ?mode:(open_in_flag list) -> ?perm:permission -> string -> input (** [open_in file_name] opens the file named [file_name] for reading. {b Note} You will need to close the file manually, with {!BatIO.close_in}. An alternative is to call [with_file_in] instead of [open_in]. Naming conventions for files are platform-dependent.*) val with_file_in : ?mode:(open_in_flag list) -> ?perm:permission -> string -> (input -> 'a) -> 'a (** [with_file_in file_name f] opens the file named [file_name] for reading, invokes [f] to process the contents of that file then, once [f] has returned or triggered an exception, closes the file before proceeding. *) (** {6 Opening a file for writing} *) type open_out_flag = [ `append (**Start writing at the end of the file rather than the start *) | `create (**Create the file if it does not exist *) | `trunc (**Empty the file if it already exists; on by default *) | `excl (**Fail if the file exists and [`create] is set *) | `text (**Open in ascii mode -- if this flag is not specified or if the operating system does not perform conversions, the file is opened in binary mode. *) | `nonblock (**Open in non-blocking mode *) ] (** Flags governing file output; they correspond to the relevant flags to the POSIX [open()] call. The default flags are [[`create; `trunc]]. *) val open_out : ?mode:(open_out_flag list) -> ?perm:permission -> string -> unit output (** [open_out file_name] opens the file named [file_name] for writing. {b Note} You will need to close the file manually, with {!BatIO.close_out}. An alternative is to call [with_file_out] instead of [open_out]. Naming conventions for files are platform-dependent.*) val with_file_out: ?mode:(open_out_flag list) -> ?perm:permission -> string -> (unit output -> 'a) -> 'a (** [with_file_out file_name f] opens the file named [file_name] for writing, invokes [f] to write onto that file then, once [f] has returned or triggered an exception, closes the file before proceeding. *) (** {6 Opening a temporary file for writing} *) type open_temporary_out_flag = [ open_out_flag | `delete_on_exit (**Should the file be deleted when program ends?*) ] val open_temporary_out: ?mode:(open_temporary_out_flag list) -> ?prefix:string -> ?suffix:string -> ?temp_dir:string -> unit -> (unit output * string) (** [open_temporary_out ()] opens a new temporary file for writing. @param prefix a string which should appear at the start of your temporary file name (by default ["ocaml"]) @param suffix a string which should appear at the end of your temporary file name (by default ["tmp"]) @param temp_dir indicates what temp dir to use @return The name of the file and the [output] for writing in it. {b Note} You will need to close the file manually. An alternative is to call [with_temporary_out] instead of [open_out]. Naming conventions for files are platform-dependent.*) val with_temporary_out: ?mode:(open_temporary_out_flag list) -> ?prefix:string -> ?suffix:string -> ?temp_dir:string -> (unit output -> string -> 'a) -> 'a (** [with_temporary_out f] opens a new temporary file for writing, invokes [f] with to write onto that file then, once [f] has returned or triggered an exception, closes the file before proceeding. @param prefix a string which should appear at the start of your temporary file name (by default ["ocaml"]) @param suffix a string which should appear at the end of your temporary file name (by default ["tmp"]) @param temp_dir indicates what temp dir to use @return The name of the file and the [output] for writing in it. Naming conventions for files are platform-dependent.*) batteries-included-3.4.0/src/batFilename.mliv000066400000000000000000000264671415601150500211710ustar00rootroot00000000000000(* * BatFilename - Extended Filename module * Copyright (C) 1996 Xavier Leroy * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Operations on file names. *) val current_dir_name : string (** The conventional name for the current directory (e.g. [.] in Unix). *) val parent_dir_name : string (** The conventional name for the parent of the current directory (e.g. [..] in Unix). *) val dir_sep : string (** The directory separator (e.g. [/] in Unix). @since 2.11.0 and OCaml 3.11.2 *) val concat : string -> string -> string (** [concat dir file] returns a file name that designates file [file] in directory [dir]. *) val is_relative : string -> bool (** Return [true] if the file name is relative to the current directory, [false] if it is absolute (i.e. in Unix, starts with [/]). *) val is_implicit : string -> bool (** Return [true] if the file name is relative and does not start with an explicit reference to the current directory ([./] or [../] in Unix), [false] if it starts with an explicit reference to the root directory or the current directory. *) val check_suffix : string -> string -> bool (** [check_suffix name suff] returns [true] if the filename [name] ends with the suffix [suff]. Under Windows ports (including Cygwin), comparison is case-insensitive, relying on [String.lowercase_ascii]. Note that this does not match exactly the interpretation of case-insensitive filename equivalence from Windows. *) val chop_suffix : string -> string -> string (** [chop_suffix name suff] removes the suffix [suff] from the filename [name]. The behavior is undefined if [name] does not end with the suffix [suff]. [chop_suffix_opt] is thus recommended instead. *) ##V>=4.8##val chop_suffix_opt: suffix:string -> string -> string option ##V>=4.8##(** [chop_suffix_opt ~suffix filename] removes the suffix from ##V>=4.8## the [filename] if possible, or returns [None] if the ##V>=4.8## filename does not end with the suffix. ##V>=4.8## ##V>=4.8## Under Windows ports (including Cygwin), comparison is ##V>=4.8## case-insensitive, relying on [String.lowercase_ascii]. Note that ##V>=4.8## this does not match exactly the interpretation of case-insensitive ##V>=4.8## filename equivalence from Windows. ##V>=4.8## ##V>=4.8## @since 2.11.0 and OCaml 4.08 ##V>=4.8##*) ##V>=4.4##val extension : string -> string ##V>=4.4##(** [extension name] is the shortest suffix [ext] of [name0] where: ##V>=4.4## ##V>=4.4## - [name0] is the longest suffix of [name] that does not ##V>=4.4## contain a directory separator; ##V>=4.4## - [ext] starts with a period; ##V>=4.4## - [ext] is preceded by at least one non-period character ##V>=4.4## in [name0]. ##V>=4.4## ##V>=4.4## If such a suffix does not exist, [extension name] is the empty ##V>=4.4## string. ##V>=4.4## ##V>=4.4## @since 2.11.0 and OCaml 4.04 ##V>=4.4##*) ##V>=4.4##val remove_extension : string -> string ##V>=4.4##(** Return the given file name without its extension, as defined ##V>=4.4## in {!Filename.extension}. If the extension is empty, the function ##V>=4.4## returns the given file name. ##V>=4.4## ##V>=4.4## The following invariant holds for any file name [s]: ##V>=4.4## ##V>=4.4## [remove_extension s ^ extension s = s] ##V>=4.4## ##V>=4.4## @since 2.11.0 and OCaml 4.04 ##V>=4.4##*) val chop_extension : string -> string (** Same as {!Filename.remove_extension}, but raise [Invalid_argument] if the given name has an empty extension. *) val basename : string -> string (** Split a file name into directory name / base file name. If [name] is a valid file name, then [concat (dirname name) (basename name)] returns a file name which is equivalent to [name]. Moreover, after setting the current directory to [dirname name] (with {!Sys.chdir}), references to [basename name] (which is a relative file name) designate the same file as [name] before the call to {!Sys.chdir}. This function conforms to the specification of POSIX.1-2008 for the [basename] utility. *) val dirname : string -> string (** See {!Filename.basename}. This function conforms to the specification of POSIX.1-2008 for the [dirname] utility. *) ##V>=4.10##val null : string ##V>=4.10##(** [null] is ["/dev/null"] on POSIX and ["NUL"] on Windows. It represents a ##V>=4.10## file on the OS that discards all writes and returns end of file on reads. ##V>=4.10## ##V>=4.10## @since 2.12.0 and OCaml 4.10 ##V>=4.10##*) val temp_file : ?temp_dir: string -> string -> string -> string (** [temp_file prefix suffix] returns the name of a fresh temporary file in the temporary directory. The base name of the temporary file is formed by concatenating [prefix], then a suitably chosen integer number, then [suffix]. The optional argument [temp_dir] indicates the temporary directory to use, defaulting to the current result of {!Filename.get_temp_dir_name}. The temporary file is created empty, with permissions [0o600] (readable and writable only by the file owner). The file is guaranteed to be different from any other file that existed when [temp_file] was called. Raise [Sys_error] if the file could not be created. @before 3.11.2 no ?temp_dir optional argument *) val open_temp_file : ?mode: open_flag list -> ##V>4.2## ?perms: int -> ?temp_dir: string -> string -> string -> string * out_channel (** Same as {!Filename.temp_file}, but returns both the name of a fresh temporary file, and an output channel opened (atomically) on this file. This function is more secure than [temp_file]: there is no risk that the temporary file will be modified (e.g. replaced by a symbolic link) before the program opens it. The optional argument [mode] is a list of additional flags to control the opening of the file. It can contain one or several of [Open_append], [Open_binary], and [Open_text]. The default is [[Open_text]] (open in text mode). ##V>4.2## The file is created with permissions [perms] (defaults to readable and ##V>4.2## writable only by the file owner, [0o600]). @raise Sys_error if the file could not be opened. *) ##V>=4.0##val get_temp_dir_name : unit -> string ##V>=4.0##(** The name of the temporary directory: ##V>=4.0## Under Unix, the value of the [TMPDIR] environment variable, or "/tmp" ##V>=4.0## if the variable is not set. ##V>=4.0## Under Windows, the value of the [TEMP] environment variable, or "." ##V>=4.0## if the variable is not set. ##V>=4.0## The temporary directory can be changed with {!Filename.set_temp_dir_name}. ##V>=4.0## @since 2.11.0 and OCaml 4.00.0 ##V>=4.0##*) ##V>=4.0##val set_temp_dir_name : string -> unit ##V>=4.0##(** Change the temporary directory returned by {!Filename.get_temp_dir_name} ##V>=4.0## and used by {!Filename.temp_file} and {!Filename.open_temp_file}. ##V>=4.0## @since 2.11.0 and OCaml 4.00.0 ##V>=4.0##*) val temp_dir_name : string ##V>=4.2## [@@ocaml.deprecated "Use Filename.get_temp_dir_name instead"] (** The name of the initial temporary directory: Under Unix, the value of the [TMPDIR] environment variable, or "/tmp" if the variable is not set. Under Windows, the value of the [TEMP] environment variable, or "." if the variable is not set. @deprecated You should use {!Filename.get_temp_dir_name} instead. @since 2.11.0 and OCaml 3.09.1 *) val quote : string -> string (** Return a quoted version of a file name, suitable for use as one argument in a command line, escaping all meta-characters. Warning: under Windows, the output is only suitable for use with programs that follow the standard Windows quoting conventions. *) ##V>=4.10##val quote_command : ##V>=4.10## string -> ?stdin:string -> ?stdout:string -> ?stderr:string ##V>=4.10## -> string list -> string ##V>=4.10##(** [quote_command cmd args] returns a quoted command line, suitable ##V>=4.10## for use as an argument to {!Sys.command}, {!Unix.system}, and the ##V>=4.10## {!Unix.open_process} functions. ##V>=4.10## ##V>=4.10## The string [cmd] is the command to call. The list [args] is ##V>=4.10## the list of arguments to pass to this command. It can be empty. ##V>=4.10## ##V>=4.10## The optional arguments [?stdin] and [?stdout] and [?stderr] are ##V>=4.10## file names used to redirect the standard input, the standard ##V>=4.10## output, or the standard error of the command. ##V>=4.10## If [~stdin:f] is given, a redirection [< f] is performed and the ##V>=4.10## standard input of the command reads from file [f]. ##V>=4.10## If [~stdout:f] is given, a redirection [> f] is performed and the ##V>=4.10## standard output of the command is written to file [f]. ##V>=4.10## If [~stderr:f] is given, a redirection [2> f] is performed and the ##V>=4.10## standard error of the command is written to file [f]. ##V>=4.10## If both [~stdout:f] and [~stderr:f] are given, with the exact ##V>=4.10## same file name [f], a [2>&1] redirection is performed so that the ##V>=4.10## standard output and the standard error of the command are interleaved ##V>=4.10## and redirected to the same file [f]. ##V>=4.10## ##V>=4.10## Under Unix and Cygwin, the command, the arguments, and the redirections ##V>=4.10## if any are quoted using {!Filename.quote}, then concatenated. ##V>=4.10## Under Win32, additional quoting is performed as required by the ##V>=4.10## [cmd.exe] shell that is called by {!Sys.command}. ##V>=4.10## ##V>=4.10## Raise [Failure] if the command cannot be escaped on the current platform. ##V>=4.10## ##V>=4.10## @since 2.12.0 and OCaml 4.10 ##V>=4.10##*) ##V<4.4## val extension : string -> string ##V<4.4##(* extension name is the shortest suffix ext of name0 where: ##V<4.4## ##V<4.4## - name0 is the longest suffix of name that does not contain a directory separator; ##V<4.4## - ext starts with a period; ##V<4.4## - ext is preceded by at least one non-period character in name0. ##V<4.4## If such a suffix does not exist, extension name is the empty string. ##V<4.4## ##V<4.4## @since 2.11.0 *) ##V<4.4## val remove_extension : string -> string ##V<4.4##(* Return the given file name without its extension, as defined in ##V<4.4## Filename.extension. If the extension is empty, the function returns ##V<4.4## the given file name. ##V<4.4## ##V<4.4## @since 2.11.0 *) val split_extension : string -> string * string (** [split_extension s] returns both the filename [s] without its extension and its extension in two distinct strings. For instance, [split_extension "foo.bar"] returns the pair ["foo",".bar"]. @since 2.11.0 *) batteries-included-3.4.0/src/batFilename.mlv000066400000000000000000000047041415601150500210060ustar00rootroot00000000000000(* * BatFilename - Extended Filename module * Copyright (C) 1996 Xavier Leroy * 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) include Filename ##V<4.4## let is_dir_sep name i = ##V<4.4## try ##V<4.4## for j = 0 to String.length dir_sep - 1 do ##V<4.4## if i + j >= String.length name || ##V<4.4## name.[i + j] != dir_sep.[j] then raise Exit ##V<4.4## done; ##V<4.4## true ##V<4.4## with Exit -> ##V<4.4## false ##V<4.4## ##V<4.4## let extension_len name = ##V<4.4## let rec check i0 i = ##V<4.4## if i < 0 || is_dir_sep name i then 0 ##V<4.4## else if name.[i] = '.' then check i0 (i - 1) ##V<4.4## else String.length name - i0 ##V<4.4## in ##V<4.4## let rec search_dot i = ##V<4.4## if i < 0 || is_dir_sep name i then 0 ##V<4.4## else if name.[i] = '.' then check i (i - 1) ##V<4.4## else search_dot (i - 1) ##V<4.4## in ##V<4.4## search_dot (String.length name - 1) ##V<4.4## ##V<4.4## let remove_extension name = ##V<4.4## let l = extension_len name in ##V<4.4## if l = 0 then name else String.sub name 0 (String.length name - l) ##V<4.4## ##V<4.4## let extension name = ##V<4.4## let l = extension_len name in ##V<4.4## if l = 0 then "" else String.sub name (String.length name - l) l let split_extension s = remove_extension s, extension s (*$= split_extension & ~printer:(IO.to_string (Tuple2.print String.print String.print)) ("/foo/bar", ".baz") (split_extension "/foo/bar.baz") ("/foo/bar", "") (split_extension "/foo/bar") ("/foo/bar", ".") (split_extension "/foo/bar.") ("/foo/.rc", "") (split_extension "/foo/.rc") ("", "") (split_extension "") *) batteries-included-3.4.0/src/batFingerTree.ml000066400000000000000000001375271415601150500211440ustar00rootroot00000000000000(* * Copyright (C) 2011 Batteries Included Development Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type 'a monoid = { zero : 'a; combine : 'a -> 'a -> 'a ; } module type S = sig type ('a, 'm) fg type ('wrapped_type, 'a, 'm) wrap val empty : ('a, 'm) fg val singleton : 'a -> ('a, 'm) fg val cons : (('a, 'm) fg -> 'a -> ('a, 'm) fg, 'a, 'm) wrap val snoc : (('a, 'm) fg -> 'a -> ('a, 'm) fg, 'a, 'm) wrap val front : (('a, 'm) fg -> (('a, 'm) fg * 'a) option, 'a, 'm) wrap val front_exn : (('a, 'm) fg -> (('a, 'm) fg * 'a), 'a, 'm) wrap val head : ('a, 'm) fg -> 'a option val head_exn : ('a, 'm) fg -> 'a val last : ('a, 'm) fg -> 'a option val last_exn : ('a, 'm) fg -> 'a val tail : (('a, 'm) fg -> ('a, 'm) fg option, 'a, 'm) wrap val tail_exn : (('a, 'm) fg -> ('a, 'm) fg, 'a, 'm) wrap val init : (('a, 'm) fg -> ('a, 'm) fg option, 'a, 'm) wrap val init_exn : (('a, 'm) fg -> ('a, 'm) fg, 'a, 'm) wrap val rear : (('a, 'm) fg -> (('a, 'm) fg * 'a) option, 'a, 'm) wrap val rear_exn : (('a, 'm) fg -> (('a, 'm) fg * 'a), 'a, 'm) wrap val size : ('a, 'm) fg -> int val is_empty : ('a, 'm) fg -> bool val fold_left : ('acc -> 'a -> 'acc) -> 'acc -> ('a, 'm) fg -> 'acc val fold_right : ('acc -> 'a -> 'acc) -> 'acc -> ('a, 'm) fg -> 'acc val iter : ('a -> unit) -> ('a, 'm) fg -> unit val iter_right : ('a -> unit) -> ('a, 'm) fg -> unit val compare : ('a -> 'a -> int) -> ('a, 'm) fg -> ('a, 'm) fg -> int val equal : ('a -> 'a -> bool) -> ('a, 'm) fg -> ('a, 'm) fg -> bool val enum : ('a, 'm) fg -> 'a BatEnum.t val backwards : ('a, 'm) fg -> 'a BatEnum.t val to_list : ('a, 'm) fg -> 'a list val to_list_backwards : ('a, 'm) fg -> 'a list val of_enum : ('a BatEnum.t -> ('a, 'm) fg, 'a, 'm) wrap val of_backwards : ('a BatEnum.t -> ('a, 'm) fg, 'a, 'm) wrap val of_list : ('a list -> ('a, 'm) fg, 'a, 'm) wrap val of_list_backwards : ('a list -> ('a, 'm) fg, 'a, 'm) wrap val map : (('a -> 'b) -> ('a, 'm) fg -> ('b, 'm) fg, 'b, 'm) wrap val map_right : (('a -> 'b) -> ('a, 'm) fg -> ('b, 'm) fg, 'b, 'm) wrap val append : (('a, 'm) fg -> ('a, 'm) fg -> ('a, 'm) fg, 'a, 'm) wrap val reverse : (('a, 'm) fg -> ('a, 'm) fg, 'a, 'm) wrap val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> ('b, _) fg -> unit end exception Empty module Generic = struct (* All the datatypes in here are the same as the same described in the * paper in the mli. * Since there are several variants mentioned: * - we define 'a digit not as being an 'a list as done initially in the * paper but (as suggested later) as a sum types that cover sequence of * length 1, 2, 3 or 4 * I didn't test with lists, but I suspect it would be slower and take * more memory. On the minus side, the code is rather annoying to write * with the current digits. * - there are measure caches not only on nodes, but also on digits. * It is slightly faster when benchmarking construction/deconstruction * even with dummy annotations. * In many places, it looks like functions are defined twice in slightly * different versions. This is for performance reasons, to avoid higher * order calls (made everything 30% slower on my tests). *) type ('a, 'm) node = | Node2 of 'm * 'a * 'a | Node3 of 'm * 'a * 'a * 'a type ('a, 'm) digit = | One of 'm * 'a | Two of 'm * 'a * 'a | Three of 'm * 'a * 'a * 'a | Four of 'm * 'a * 'a * 'a * 'a type ('a, 'm) fg = | Nil (* not called Empty as in the paper to avoid a name * clash with the exception Empty *) | Single of 'a | Deep of 'm * ('a, 'm) digit * (('a, 'm) node, 'm) fg * ('a, 'm) digit let empty = Nil let singleton a = Single a let is_empty = function | Nil -> true | Single _ | Deep _ -> false (*---------------------------------*) (* fold *) (*---------------------------------*) let fold_right_node f acc = function | Node2 (_, a, b) -> f (f acc b) a | Node3 (_, a, b, c) -> f (f (f acc c) b) a let fold_left_node f acc = function | Node2 (_, a, b) -> f (f acc a) b | Node3 (_, a, b, c) -> f (f (f acc a) b) c let fold_right_digit f acc = function | One (_, a) -> f acc a | Two (_, a, b) -> f (f acc b) a | Three (_, a, b, c) -> f (f (f acc c) b) a | Four (_, a, b, c, d) -> f (f (f (f acc d) c) b) a let fold_left_digit f acc = function | One (_, a) -> f acc a | Two (_, a, b) -> f (f acc a) b | Three (_, a, b, c) -> f (f (f acc a) b) c | Four (_, a, b, c, d) -> f (f (f (f acc a) b) c) d let rec fold_right : 'acc 'a 'm. ('acc -> 'a -> 'acc) -> 'acc -> ('a, 'm) fg -> 'acc = fun f acc -> function | Nil -> acc | Single x -> f acc x | Deep (_, pr, m, sf) -> let acc = fold_right_digit f acc sf in let acc = fold_right (fun acc elt -> fold_right_node f acc elt) acc m in let acc = fold_right_digit f acc pr in acc let rec fold_left : 'acc 'a 'm. ('acc -> 'a -> 'acc) -> 'acc -> ('a, 'm) fg -> 'acc = fun f acc -> function | Nil -> acc | Single x -> f acc x | Deep (_, pr, m, sf) -> let acc = fold_left_digit f acc pr in let acc = fold_left (fun acc elt -> fold_left_node f acc elt) acc m in let acc = fold_left_digit f acc sf in acc (*---------------------------------*) (* debug printing *) (*---------------------------------*) let pp_debug_digit pp_measure pp_a f = function | One (m, a) -> Format.fprintf f "@[@[<2>One (@,%a,@ %a@])@]" pp_measure m pp_a a | Two (m, a, b) -> Format.fprintf f "@[@[<2>Two (@,%a,@ %a,@ %a@])@]" pp_measure m pp_a a pp_a b | Three (m, a, b, c) -> Format.fprintf f "@[@[<2>Three (@,%a,@ %a,@ %a,@ %a@])@]" pp_measure m pp_a a pp_a b pp_a c | Four (m, a, b, c, d) -> Format.fprintf f "@[@[<2>Four (@,%a,@ %a,@ %a,@ %a,@ %a@])@]" pp_measure m pp_a a pp_a b pp_a c pp_a d let pp_debug_node pp_measure pp_a f = function | Node2 (m, a, b) -> Format.fprintf f "@[@[<2>Node2 (@,%a,@ %a,@ %a@])@]" pp_measure m pp_a a pp_a b | Node3 (m, a, b, c) -> Format.fprintf f "@[@[<2>Node3 (@,%a,@ %a,@ %a,@ %a@])@]" pp_measure m pp_a a pp_a b pp_a c type 'a printer = Format.formatter -> 'a -> unit let rec pp_debug_tree : 'a 'm. 'm printer -> 'a printer -> ('a, 'm) fg printer = fun pp_measure pp_a f -> function | Nil -> Format.fprintf f "Nil" | Single a -> Format.fprintf f "@[<2>Single@ %a@]" pp_a a | Deep (v, pr, m, sf) -> Format.fprintf f "@[@[Deep (@,%a,@ %a,@ %a,@ %a@]@\n)@]" pp_measure v (pp_debug_digit pp_measure pp_a) pr (pp_debug_tree pp_measure (pp_debug_node pp_measure pp_a)) m (pp_debug_digit pp_measure pp_a) sf let dummy_printer f _ = Format.pp_print_string f "_" let pp_debug ?(pp_measure = dummy_printer) pp_a f t = pp_debug_tree pp_measure pp_a f t let pp_list pp_a f = function | [] -> Format.fprintf f "[]" | h :: t -> Format.fprintf f "[%a" pp_a h; List.iter (fun a -> Format.fprintf f "; %a" pp_a a) t; Format.fprintf f "]" (*---------------------------------*) (* measurement functions *) (*---------------------------------*) type ('wrapped_type, 'a, 'm) wrap = monoid:'m monoid -> measure:('a -> 'm) -> 'wrapped_type let measure_node = function | Node2 (v, _, _) | Node3 (v, _, _, _) -> v let measure_digit = function | One (v, _) | Two (v, _, _) | Three (v, _, _, _) | Four (v, _, _, _, _) -> v let measure_t_node ~monoid = function | Nil -> monoid.zero | Single x -> measure_node x | Deep (v, _, _, _) -> v let measure_t ~monoid ~measure = function | Nil -> monoid.zero | Single x -> measure x | Deep (v, _, _, _) -> v let check_measures_digit ~monoid ~measure ~eq check = function | One (v, a) -> check a && eq (measure a) v | Two (v, a, b) -> check a && check b && eq (monoid.combine (measure a) (measure b)) v | Three (v, a, b, c) -> check a && check b && check c && eq (monoid.combine (monoid.combine (measure a) (measure b)) (measure c)) v | Four (v, a, b, c, d) -> check a && check b && check c && check d && eq (monoid.combine (monoid.combine (measure a) (measure b)) (monoid.combine (measure c) (measure d))) v let check_measures_node ~monoid ~measure ~eq check = function | Node2 (v, a, b) -> check a && check b && eq (monoid.combine (measure a) (measure b)) v | Node3 (v, a, b, c) -> check a && check b && check c && eq (monoid.combine (monoid.combine (measure a) (measure b)) (measure c)) v let rec check_measures : 'a 'm. monoid:'m monoid -> measure:('a -> 'm) -> eq:('m -> 'm -> bool) -> ('a -> bool) -> ('a, 'm) fg -> bool = fun ~monoid ~measure ~eq check -> function | Nil -> true | Single a -> check a | Deep (v, pr, m, sf) -> check_measures_digit ~monoid ~measure ~eq check pr && check_measures_digit ~monoid ~measure ~eq check sf && check_measures ~monoid ~measure:measure_node ~eq (fun a -> check_measures_node ~monoid ~measure ~eq check a ) m && eq (monoid.combine (measure_digit pr) (monoid.combine (measure_t_node ~monoid m) (measure_digit sf))) v let check_measures ~monoid ~measure ~eq t = check_measures ~monoid ~measure ~eq (fun _ -> true) t (*---------------------------------*) (* a bunch of smart constructors *) (*---------------------------------*) let node2 ~monoid ~measure a b = Node2 (monoid.combine (measure a) (measure b), a, b) let node2_node ~monoid a b = Node2 (monoid.combine (measure_node a) (measure_node b), a, b) let node3 ~monoid ~measure a b c = Node3 (monoid.combine (measure a) (monoid.combine (measure b) (measure c)), a, b, c) let node3_node ~monoid a b c = Node3 (monoid.combine (measure_node a) (monoid.combine (measure_node b) (measure_node c)), a, b, c) let deep ~monoid pr m sf = let v = measure_digit pr in let v = monoid.combine v (measure_t_node ~monoid m) in let v = monoid.combine v (measure_digit sf) in Deep (v, pr, m, sf) let one_node a = One (measure_node a, a) let one ~measure a = One (measure a, a) let two_node ~monoid a b = Two (monoid.combine (measure_node a) (measure_node b), a, b) let two ~monoid ~measure a b = Two (monoid.combine (measure a) (measure b), a, b) let three_node ~monoid a b c = Three (monoid.combine (monoid.combine (measure_node a) (measure_node b)) (measure_node c), a, b, c) let three ~monoid ~measure a b c = Three (monoid.combine (monoid.combine (measure a) (measure b)) (measure c), a, b, c) let four_node ~monoid a b c d = Four (monoid.combine (monoid.combine (measure_node a) (measure_node b)) (monoid.combine (measure_node c) (measure_node d)), a, b, c, d) let four ~monoid ~measure a b c d = Four (monoid.combine (monoid.combine (measure a) (measure b)) (monoid.combine (measure c) (measure d)), a, b, c, d) (*---------------------------------*) (* cons / snoc *) (*---------------------------------*) let cons_digit_node ~monoid d x = match d with | One (v, a) -> Two (monoid.combine (measure_node x) v, x, a) | Two (v, a, b) -> Three (monoid.combine (measure_node x) v, x, a, b) | Three (v, a, b, c) -> Four (monoid.combine (measure_node x) v, x, a, b, c) | Four _ -> assert false let cons_digit ~monoid ~measure d x = match d with | One (v, a) -> Two (monoid.combine (measure x) v, x, a) | Two (v, a, b) -> Three (monoid.combine (measure x) v, x, a, b) | Three (v, a, b, c) -> Four (monoid.combine (measure x) v, x, a, b, c) | Four _ -> assert false let snoc_digit_node ~monoid d x = match d with | One (v, a) -> Two (monoid.combine v (measure_node x), a, x) | Two (v, a, b) -> Three (monoid.combine v (measure_node x), a, b, x) | Three (v, a, b, c) -> Four (monoid.combine v (measure_node x), a, b, c, x) | Four _ -> assert false let snoc_digit ~monoid ~measure d x = match d with | One (v, a) -> Two (monoid.combine v (measure x), a, x) | Two (v, a, b) -> Three (monoid.combine v (measure x), a, b, x) | Three (v, a, b, c) -> Four (monoid.combine v (measure x), a, b, c, x) | Four _ -> assert false let rec cons_aux : 'a 'm. monoid:'m monoid -> (('a, 'm) node, 'm) fg -> ('a, 'm) node -> (('a, 'm) node, 'm) fg = fun ~monoid t a -> match t with | Nil -> Single a | Single b -> deep ~monoid (one_node a) Nil (one_node b) | Deep (_, Four (_, b, c, d, e), m, sf) -> deep ~monoid (two_node ~monoid a b) (cons_aux ~monoid m (node3_node ~monoid c d e)) sf | Deep (v, pr, m, sf) -> Deep (monoid.combine (measure_node a) v, cons_digit_node ~monoid pr a, m, sf) let cons ~monoid ~measure t a = match t with | Nil -> Single a | Single b -> deep ~monoid (one ~measure a) Nil (one ~measure b) | Deep (_, Four (_, b, c, d, e), m, sf) -> deep ~monoid (two ~monoid ~measure a b) (cons_aux ~monoid m (node3 ~monoid ~measure c d e)) sf | Deep (v, pr, m, sf) -> Deep (monoid.combine (measure a) v, cons_digit ~monoid ~measure pr a, m, sf) let rec snoc_aux : 'a 'm. monoid:'m monoid -> (('a, 'm) node, 'm) fg -> ('a, 'm) node -> (('a, 'm) node, 'm) fg = fun ~monoid t a -> match t with | Nil -> Single a | Single b -> deep ~monoid (one_node b) Nil (one_node a) | Deep (_, pr, m, Four (_, b, c, d, e)) -> deep ~monoid pr (snoc_aux ~monoid m (node3_node ~monoid b c d)) (two_node ~monoid e a) | Deep (v, pr, m, sf) -> Deep (monoid.combine v (measure_node a), pr, m, snoc_digit_node ~monoid sf a) let snoc ~monoid ~measure t a = match t with | Nil -> Single a | Single b -> deep ~monoid (one ~measure b) Nil (one ~measure a) | Deep (_, pr, m, Four (_, b, c, d, e)) -> deep ~monoid pr (snoc_aux ~monoid m (node3 ~monoid ~measure b c d)) (two ~measure ~monoid e a) | Deep (v, pr, m, sf) -> Deep (monoid.combine v (measure a), pr, m, snoc_digit ~monoid ~measure sf a) (*---------------------------------*) (* various conversions *) (*---------------------------------*) let to_tree_digit_node ~monoid d = match d with | One (_, a) -> Single a | Two (v, a, b) -> Deep (v, one_node a, Nil, one_node b) | Three (v, a, b, c) -> Deep (v, two_node ~monoid a b, Nil, one_node c) | Four (v, a, b, c, d) -> Deep (v, three_node ~monoid a b c, Nil, one_node d) let to_tree_digit ~monoid ~measure d = match d with | One (_, a) -> Single a | Two (v, a, b) -> Deep (v, one ~measure a, Nil, one ~measure b) | Three (v, a, b, c) -> Deep (v, two ~monoid ~measure a b, Nil, one ~measure c) | Four (v, a, b, c, d) -> Deep (v, three ~monoid ~measure a b c, Nil, one ~measure d) let to_tree_list ~monoid ~measure = function | [] -> Nil | [a] -> Single a | [a; b] -> deep ~monoid (one ~measure a) Nil (one ~measure b) | [a; b; c] -> deep ~monoid (two ~monoid ~measure a b) Nil (one ~measure c) | [a; b; c; d] -> deep ~monoid (three ~monoid ~measure a b c) Nil (one ~measure d) | _ -> assert false let to_digit_node = function | Node2 (v, a, b) -> Two (v, a, b) | Node3 (v, a, b, c) -> Three (v, a, b, c) let to_digit_list ~monoid ~measure = function | [a] -> one ~measure a | [a; b] -> two ~monoid ~measure a b | [a; b; c] -> three ~monoid ~measure a b c | [a; b; c; d] -> four ~monoid ~measure a b c d | _ -> assert false let to_digit_list_node ~monoid = function | [a] -> one_node a | [a; b] -> two_node ~monoid a b | [a; b; c] -> three_node ~monoid a b c | [a; b; c; d] -> four_node ~monoid a b c d | _ -> assert false (*---------------------------------*) (* front / rear / etc. *) (*---------------------------------*) let head_digit = function | One (_, a) | Two (_, a, _) | Three (_, a, _, _) | Four (_, a, _, _, _) -> a let last_digit = function | One (_, a) | Two (_, _, a) | Three (_, _, _, a) | Four (_, _, _, _, a) -> a let tail_digit_node ~monoid = function | One _ -> assert false | Two (_, _, a) -> one_node a | Three (_, _, a, b) -> two_node ~monoid a b | Four (_, _, a, b, c) -> three_node ~monoid a b c let tail_digit ~monoid ~measure = function | One _ -> assert false | Two (_, _, a) -> one ~measure a | Three (_, _, a, b) -> two ~monoid ~measure a b | Four (_, _, a, b, c) -> three ~monoid ~measure a b c let init_digit_node ~monoid = function | One _ -> assert false | Two (_, a, _) -> one_node a | Three (_, a, b, _) -> two_node ~monoid a b | Four (_, a, b, c, _) -> three_node ~monoid a b c let init_digit ~monoid ~measure = function | One _ -> assert false | Two (_, a, _) -> one ~measure a | Three (_, a, b, _) -> two ~monoid ~measure a b | Four (_, a, b, c, _) -> three ~monoid ~measure a b c type ('a, 'rest) view = | Vnil | Vcons of 'a * 'rest let rec view_left_aux : 'a 'm. monoid:'m monoid -> (('a, 'm) node, 'm) fg -> (('a, 'm) node, (('a, 'm) node, 'm) fg) view = fun ~monoid -> function | Nil -> Vnil | Single x -> Vcons (x, Nil) | Deep (_, One (_, a), m, sf) -> let vcons = match view_left_aux ~monoid m with | Vnil -> to_tree_digit_node ~monoid sf | Vcons (a, m') -> deep ~monoid (to_digit_node a) m' sf in Vcons (a, vcons) | Deep (_, pr, m, sf) -> let vcons = deep ~monoid (tail_digit_node ~monoid pr) m sf in Vcons (head_digit pr, vcons) let view_left ~monoid ~measure = function | Nil -> Vnil | Single x -> Vcons (x, Nil) | Deep (_, One (_, a), m, sf) -> let vcons = match view_left_aux ~monoid m with | Vnil -> to_tree_digit ~monoid ~measure sf | Vcons (a, m') -> deep ~monoid (to_digit_node a) m' sf in Vcons (a, vcons) | Deep (_, pr, m, sf) -> let vcons = deep ~monoid (tail_digit ~monoid ~measure pr) m sf in Vcons (head_digit pr, vcons) let rec view_right_aux : 'a 'm. monoid:'m monoid -> (('a, 'm) node, 'm) fg -> (('a, 'm) node, (('a, 'm) node, 'm) fg) view = fun ~monoid -> function | Nil -> Vnil | Single x -> Vcons (x, Nil) | Deep (_, pr, m, One (_, a)) -> let vcons = match view_right_aux ~monoid m with | Vnil -> to_tree_digit_node ~monoid pr | Vcons (a, m') -> deep ~monoid pr m' (to_digit_node a) in Vcons (a, vcons) | Deep (_, pr, m, sf) -> let vcons = deep ~monoid pr m (init_digit_node ~monoid sf) in Vcons (last_digit sf, vcons) let view_right ~monoid ~measure = function | Nil -> Vnil | Single x -> Vcons (x, Nil) | Deep (_, pr, m, One (_, a)) -> let vcons = match view_right_aux ~monoid m with | Vnil -> to_tree_digit ~monoid ~measure pr | Vcons (a, m') -> deep ~monoid pr m' (to_digit_node a) in Vcons (a, vcons) | Deep (_, pr, m, sf) -> let vcons = deep ~monoid pr m (init_digit ~monoid ~measure sf) in Vcons (last_digit sf, vcons) let head_exn = function | Nil -> raise Empty | Single a -> a | Deep (_, pr, _, _) -> head_digit pr let head = function | Nil -> None | Single a -> Some a | Deep (_, pr, _, _) -> Some (head_digit pr) let last_exn = function | Nil -> raise Empty | Single a -> a | Deep (_, _, _, sf) -> last_digit sf let last = function | Nil -> None | Single a -> Some a | Deep (_, _, _, sf) -> Some (last_digit sf) let tail ~monoid ~measure t = match view_left ~monoid ~measure t with | Vnil -> None | Vcons (_, tl) -> Some tl let tail_exn ~monoid ~measure t = match view_left ~monoid ~measure t with | Vnil -> raise Empty | Vcons (_, tl) -> tl let front ~monoid ~measure t = match view_left ~monoid ~measure t with | Vnil -> None | Vcons (hd, tl) -> Some (tl, hd) let front_exn ~monoid ~measure t = match view_left ~monoid ~measure t with | Vnil -> raise Empty | Vcons (hd, tl) -> (tl, hd) let init ~monoid ~measure t = match view_right ~monoid ~measure t with | Vnil -> None | Vcons (_, tl) -> Some tl let init_exn ~monoid ~measure t = match view_right ~monoid ~measure t with | Vnil -> raise Empty | Vcons (_, tl) -> tl let rear ~monoid ~measure t = match view_right ~monoid ~measure t with | Vnil -> None | Vcons (hd, tl) -> Some (tl, hd) let rear_exn ~monoid ~measure t = match view_right ~monoid ~measure t with | Vnil -> raise Empty | Vcons (hd, tl) -> (tl, hd) (*---------------------------------*) (* append *) (*---------------------------------*) let nodes = let add_digit_to digit l = match digit with | One (_, a) -> a :: l | Two (_, a, b) -> a :: b :: l | Three (_, a, b, c) -> a :: b :: c :: l | Four (_, a, b, c, d) -> a :: b :: c :: d :: l in let rec nodes_aux ~monoid ~measure ts sf2 = (* no idea if this should be tail rec *) match ts, sf2 with | [], One _ -> assert false | [], Two (_, a, b) | [a], One (_, b) -> [node2 ~monoid ~measure a b] | [], Three (_, a, b, c) | [a], Two (_, b, c) | [a; b], One (_, c) -> [node3 ~monoid ~measure a b c] | [], Four (_, a, b, c, d) | [a], Three (_, b, c, d) | [a; b], Two (_, c, d) | [a; b; c], One (_, d) -> [node2 ~monoid ~measure a b; node2 ~monoid ~measure c d] | a :: b :: c :: ts, _ -> node3 ~monoid ~measure a b c :: nodes_aux ~monoid ~measure ts sf2 | [a], Four (_, b, c, d, e) | [a; b], Three (_, c, d, e) -> [node3 ~monoid ~measure a b c; node2 ~monoid ~measure d e] | [a; b], Four (_, c, d, e, f) -> [node3 ~monoid ~measure a b c; node3 ~monoid ~measure d e f] in fun ~monoid ~measure sf1 ts sf2 -> let ts = add_digit_to sf1 ts in nodes_aux ~monoid ~measure ts sf2 let rec app3 : 'a 'm. monoid:'m monoid -> measure:('a -> 'm) -> ('a, 'm) fg -> 'a list -> ('a, 'm) fg -> ('a, 'm) fg = fun ~monoid ~measure t1 elts t2 -> match t1, t2 with | Nil, _ -> List.fold_right (fun elt acc -> cons ~monoid ~measure acc elt) elts t2 | _, Nil -> List.fold_left (fun acc elt -> snoc ~monoid ~measure acc elt) t1 elts | Single x1, _ -> cons ~monoid ~measure (List.fold_right (fun elt acc -> cons ~monoid ~measure acc elt) elts t2) x1 | _, Single x2 -> snoc ~monoid ~measure (List.fold_left (fun acc elt -> snoc ~monoid ~measure acc elt) t1 elts) x2 | Deep (_, pr1, m1, sf1), Deep (_, pr2, m2, sf2) -> deep ~monoid pr1 (app3 ~monoid ~measure:measure_node m1 (nodes ~monoid ~measure sf1 elts pr2) m2) sf2 let append ~monoid ~measure t1 t2 = app3 ~monoid ~measure t1 [] t2 (*---------------------------------*) (* reverse *) (*---------------------------------*) (* unfortunately, when reversing, we need to rebuild every annotation * because the monoid does not have to be commutative *) let reverse_digit_node ~monoid rev_a = function | One (_, a) -> one_node (rev_a a) | Two (_, a, b) -> two_node ~monoid (rev_a b) (rev_a a) | Three (_, a, b, c) -> three_node ~monoid (rev_a c) (rev_a b) (rev_a a) | Four (_, a, b, c, d) -> four_node ~monoid (rev_a d) (rev_a c) (rev_a b) (rev_a a) let reverse_digit ~monoid ~measure = function | One _ as d -> d | Two (_, a, b) -> two ~monoid ~measure b a | Three (_, a, b, c) -> three ~monoid ~measure c b a | Four (_, a, b, c, d) -> four ~monoid ~measure d c b a let reverse_node_node ~monoid rev_a = function | Node2 (_, a, b) -> node2_node ~monoid (rev_a b) (rev_a a) | Node3 (_, a, b, c) -> node3_node ~monoid (rev_a c) (rev_a b) (rev_a a) let reverse_node ~monoid ~measure = function | Node2 (_, a, b) -> node2 ~monoid ~measure b a | Node3 (_, a, b, c) -> node3 ~monoid ~measure c b a let rec reverse_aux : 'a 'm. monoid:'m monoid -> (('a, 'm) node -> ('a, 'm) node) -> (('a, 'm) node, 'm) fg -> (('a, 'm) node, 'm) fg = fun ~monoid reverse_a -> function | Nil -> Nil | Single a -> Single (reverse_a a) | Deep (_, pr, m, sf) -> let rev_pr = reverse_digit_node ~monoid reverse_a pr in let rev_sf = reverse_digit_node ~monoid reverse_a sf in let rev_m = reverse_aux ~monoid (reverse_node_node ~monoid (reverse_a)) m in deep ~monoid rev_sf rev_m rev_pr let reverse ~monoid ~measure = function | Nil | Single _ as t -> t | Deep (_, pr, m, sf) -> let rev_pr = reverse_digit ~monoid ~measure pr in let rev_sf = reverse_digit ~monoid ~measure sf in let rev_m = reverse_aux ~monoid (reverse_node ~monoid ~measure) m in deep ~monoid rev_sf rev_m rev_pr (*---------------------------------*) (* split *) (*---------------------------------*) type ('a, 'rest) split = Split of 'rest * 'a * 'rest let split_digit ~monoid ~measure p i = function | One (_, a) -> Split ([], a, []) | Two (_, a, b) -> let i' = monoid.combine i (measure a) in if p i' then Split ([], a, [b]) else Split ([a], b, []) | Three (_, a, b, c) -> let i' = monoid.combine i (measure a) in if p i' then Split ([], a, [b; c]) else let i'' = monoid.combine i' (measure b) in if p i'' then Split ([a], b, [c]) else Split ([a; b], c, []) | Four (_, a, b, c, d) -> let i' = monoid.combine i (measure a) in if p i' then Split ([], a, [b; c; d]) else let i'' = monoid.combine i' (measure b) in if p i'' then Split ([a], b, [c; d]) else let i''' = monoid.combine i'' (measure c) in if p i''' then Split ([a; b], c, [d]) else Split ([a; b; c], d, []) let deep_left ~monoid ~measure pr m sf = match pr with | [] -> ( match view_left ~monoid ~measure:measure_node m with | Vnil -> to_tree_digit ~monoid ~measure sf | Vcons (a, m') -> deep ~monoid (to_digit_node a) m' sf ) | _ -> deep ~monoid (to_digit_list ~monoid ~measure pr) m sf let deep_right ~monoid ~measure pr m sf = match sf with | [] -> ( match view_right ~monoid ~measure:measure_node m with | Vnil -> to_tree_digit ~monoid ~measure pr | Vcons (a, m') -> deep ~monoid pr m' (to_digit_node a) ) | _ -> deep ~monoid pr m (to_digit_list ~monoid ~measure sf) let rec split_tree : 'a 'm. monoid:'m monoid -> measure:('a -> 'm) -> ('m -> bool) -> 'm -> ('a, 'm) fg -> ('a, ('a, 'm) fg) split = fun ~monoid ~measure p i -> function | Nil -> raise Empty | Single x -> Split (Nil, x, Nil) | Deep (_, pr, m, sf) -> let vpr = monoid.combine i (measure_digit pr) in if p vpr then let Split (l, x, r) = split_digit ~monoid ~measure p i pr in Split (to_tree_list ~monoid ~measure l, x, deep_left ~monoid ~measure r m sf) else let vm = monoid.combine vpr (measure_t_node ~monoid m) in if p vm then let Split (ml, xs, mr) = split_tree ~monoid ~measure:measure_node p vpr m in let Split (l, x, r) = split_digit ~monoid ~measure p (monoid.combine vpr (measure_t_node ~monoid ml)) (to_digit_node xs) in Split (deep_right ~monoid ~measure pr ml l, x, deep_left ~monoid ~measure r mr sf) else let Split (l, x, r) = split_digit ~monoid ~measure p vm sf in Split (deep_right ~monoid ~measure pr m l, x, to_tree_list ~monoid ~measure r) let split ~monoid ~measure f t = match t with | Nil -> (Nil, Nil) | _ -> if f (measure_t ~monoid ~measure t) then let Split (l, x, r) = split_tree ~monoid ~measure f monoid.zero t in (l, cons ~monoid ~measure r x) else (t, Nil) (*---------------------------------*) (* lookup *) (*---------------------------------*) (* This is a simplification of splitTree that avoids rebuilding the tree * two trees around the elements being looked up * But you can't just find the element, so instead these functions find the * element _and_ the measure of the elements of the current node that are on * the left of the element. * * (this is needed because in splitTree, at some point, you measure the left * tree returned by a recursive call, but here we don't have the left tree!) *) let lookup_digit ~monoid ~measure p i = function | One (_, a) -> monoid.zero, a | Two (_, a, b) -> let m_a = measure a in let i' = monoid.combine i m_a in if p i' then monoid.zero, a else m_a, b | Three (_, a, b, c) -> let m_a = measure a in let i' = monoid.combine i m_a in if p i' then monoid.zero, a else let m_b = measure b in let i'' = monoid.combine i' m_b in if p i'' then m_a, b else monoid.combine m_a m_b, c | Four (_, a, b, c, d) -> let m_a = measure a in let i' = monoid.combine i m_a in if p i' then monoid.zero, a else let m_b = measure b in let i'' = monoid.combine i' m_b in if p i'' then m_a, b else let m_c = measure c in let i''' = monoid.combine i'' m_c in if p i''' then monoid.combine m_a m_b, c else monoid.combine (monoid.combine m_a m_b) m_c, d let lookup_node ~monoid ~measure p i = function | Node2 (_, a, b) -> let m_a = measure a in let i' = monoid.combine i m_a in if p i' then monoid.zero, a else m_a, b | Node3 (_, a, b, c) -> let m_a = measure a in let i' = monoid.combine i m_a in if p i' then monoid.zero, a else let m_b = measure b in let i'' = monoid.combine i' m_b in if p i'' then m_a, b else monoid.combine m_a m_b, c let rec lookup_tree : 'a 'm. monoid:'m monoid -> measure:('a -> 'm) -> ('m -> bool) -> 'm -> ('a, 'm) fg -> 'm * 'a = fun ~monoid ~measure p i -> function | Nil -> raise Empty | Single x -> monoid.zero, x | Deep (_, pr, m, sf) -> let m_pr = measure_digit pr in let vpr = monoid.combine i m_pr in if p vpr then lookup_digit ~monoid ~measure p i pr else let m_m = measure_t_node ~monoid m in let vm = monoid.combine vpr m_m in if p vm then let v_left, node = lookup_tree ~monoid ~measure:measure_node p vpr m in let v, x = lookup_node ~monoid ~measure p (monoid.combine vpr v_left) node in monoid.combine (monoid.combine m_pr v_left) v, x else let v, x = lookup_digit ~monoid ~measure p vm sf in monoid.combine (monoid.combine m_pr m_m) v, x let lookup ~monoid ~measure p t = snd (lookup_tree ~monoid ~measure p monoid.zero t) (*---------------------------------*) (* enumerations *) (*---------------------------------*) type ('a, 'm) iter = | End | Next of 'a * ('a, 'm) iter | Digit of ('a, 'm) digit * ('a, 'm) iter | Fg of (('a, 'm) node, 'm) iter * ('a, 'm) iter let rec to_iter : 'a. ('a, 'm) fg -> ('a, 'm) iter -> ('a, 'm) iter = fun t k -> match t with | Nil -> k | Single a -> Next (a, k) | Deep (_, pr, m, sf) -> Digit (pr, Fg (to_iter m End, Digit (sf, k))) let rec to_iter_backwards : 'a. ('a, 'm) fg -> ('a, 'm) iter -> ('a, 'm) iter = fun t k -> match t with | Nil -> k | Single a -> Next (a, k) | Deep (_, pr, m, sf) -> Digit (sf, Fg (to_iter_backwards m End, Digit (pr, k))) (*---------------------------------*) (* conversion *) (*---------------------------------*) let rec iter_next : 'a . ('a, 'm) iter -> ('a * ('a, 'm) iter) option = function | End -> None | Next (v, k) -> Some (v, k) | Digit (One (_, a), k) -> Some (a, k) | Digit (Two (_, a, b), k) -> Some (a, Next (b, k)) | Digit (Three (_, a, b, c), k) -> Some (a, Next (b, Next (c, k))) | Digit (Four (_, a, b, c, d), k) -> Some (a, Next (b, Next (c, Next (d, k)))) | Fg (node_iter, k) -> match iter_next node_iter with | None -> iter_next k | Some (Node2 (_, a, b), k_node) -> Some (a, Next (b, Fg (k_node, k))) | Some (Node3 (_, a, b, c), k_node) -> Some (a, Next (b, Next (c, Fg (k_node, k)))) let rec iter_next_backwards : 'a . ('a, 'm) iter -> ('a * ('a, 'm) iter) option = function | End -> None | Next (v, k) -> Some (v, k) | Digit (One (_, a), k) -> Some (a, k) | Digit (Two (_, a, b), k) -> Some (b, Next (a, k)) | Digit (Three (_, a, b, c), k) -> Some (c, Next (b, Next (a, k))) | Digit (Four (_, a, b, c, d), k) -> Some (d, Next (c, Next (b, Next (a, k)))) | Fg (node_iter, k) -> match iter_next_backwards node_iter with | None -> iter_next_backwards k | Some (Node2 (_, a, b), k_node) -> Some (b, Next (a, Fg (k_node, k))) | Some (Node3 (_, a, b, c), k_node) -> Some (c, Next (b, Next (a, Fg (k_node, k)))) let enum t = BatEnum.unfold (to_iter t End) iter_next let backwards t = BatEnum.unfold (to_iter_backwards t End) iter_next_backwards let of_enum ~monoid ~measure enum = BatEnum.fold (fun t elt -> snoc ~monoid ~measure t elt) empty enum let of_backwards ~monoid ~measure enum = BatEnum.fold (fun t elt -> cons ~monoid ~measure t elt) empty enum let to_list t = BatList.of_backwards (backwards t) let to_list_backwards t = BatList.of_backwards (enum t) let of_list ~monoid ~measure l = List.fold_left (fun t elt -> snoc ~monoid ~measure t elt) empty l let of_list_backwards ~monoid ~measure l = List.fold_left (fun t elt -> cons ~monoid ~measure t elt) empty l (*---------------------------------*) (* classic traversals *) (*---------------------------------*) let iter f t = fold_left (fun () elt -> f elt) () t let iter_right f t = fold_right (fun () elt -> f elt) () t let map ~monoid ~measure f t = (* suboptimal when the measure does not depend on 'a *) fold_left (fun acc elt -> snoc ~monoid ~measure acc (f elt)) empty t let map_right ~monoid ~measure f t = fold_right (fun acc elt -> cons ~monoid ~measure acc (f elt)) empty t (*---------------------------------*) (* misc *) (*---------------------------------*) let measure = measure_t (* no defined because many local variables are * already called measure, so forgetting to bind * them would cause weird type errors if this * definition was in the scope *) let size t = fold_left (fun acc _ -> acc + 1) 0 t let print ?first ?last ?sep f oc x = BatEnum.print ?first ?last ?sep f oc (enum x) let compare cmp t1 t2 = let rec loop cmp iter1 iter2 = match iter_next iter1, iter_next iter2 with | None, None -> 0 | Some _, None -> 1 | None, Some _ -> -1 | Some (e1, iter1), Some (e2, iter2) -> let c = cmp e1 e2 in if c <> 0 then c else loop cmp iter1 iter2 in loop cmp (to_iter t1 End) (to_iter t2 End) let equal eq t1 t2 = let rec loop eq iter1 iter2 = match iter_next iter1, iter_next iter2 with | None, None -> true | Some _, None -> false | None, Some _ -> false | Some (e1, iter1), Some (e2, iter2) -> eq e1 e2 && loop eq iter1 iter2 in loop eq (to_iter t1 End) (to_iter t2 End) (* this function does as of_list, but, by using concatenation, * it generates trees with some Node2 (which are never generated * by of_list) *) let of_list_for_test ~monoid ~measure l = let i = Random.int (List.length l + 1) in let l1, l2 = BatList.split_at i l in append ~monoid ~measure (of_list ~monoid ~measure l1) (of_list ~monoid ~measure l2) end type nat = int let nat_plus_monoid = { zero = 0; combine = (+); } let size_measurer = fun _ -> 1 type ('a, 'm) fg = ('a, nat) Generic.fg type 'a t = ('a, nat) fg let last_exn = Generic.last_exn (*$Q last_exn (Q.list Q.int) (fun l -> \ (try Some (last_exn (of_list_for_test l)) with Empty -> None) \ = (try Some (BatList.last l) with Invalid_argument _ -> None)) *) (* this T test is just in case the empty list was not generated by the * test above *) (*$T last_exn try ignore (last_exn empty); false with Empty -> true *) let head_exn = Generic.head_exn (*$Q head_exn (Q.list Q.int) (fun l -> \ (try Some (head_exn (of_list_for_test l)) with Empty -> None) \ = (try Some (BatList.hd l) with Failure _ -> None)) *) (*$T head_exn try ignore (head_exn empty); false with Empty -> true *) let last = Generic.last (*$Q last (Q.list Q.int) (fun l -> last (of_list_for_test l) \ = (try Some (BatList.last l) with Invalid_argument _ -> None)) *) (*$T last last empty = None *) let head = Generic.head (*$Q head (Q.list Q.int) (fun l -> head (of_list_for_test l) \ = (try Some (BatList.hd l) with Failure _ -> None)) *) (*$T head head empty = None *) let singleton = Generic.singleton (*$T singleton to_list (verify_measure (singleton 78)) = [78] *) let empty = Generic.empty (*$T empty to_list (verify_measure empty) = [] *) let is_empty = Generic.is_empty (*$Q is_empty (Q.list Q.int) (fun l -> is_empty (verify_measure (of_list_for_test l)) = (l = [])) *) let fold_left = Generic.fold_left (* here we test that the accumulator is not lost somewhere in the fold by * using the count the elements of the sequence and side effects to check * that it goes left to right *) (*$Q fold_left (Q.list Q.int) (fun l -> \ let make_bf () = \ let b = Buffer.create 10 in \ b, (fun acc elt -> Printf.bprintf b "%d" elt; acc + 1) \ in \ let b1, f1 = make_bf () in let b2, f2 = make_bf () in \ let count1 = fold_left f1 0 (of_list_for_test l) in \ let count2 = BatList.fold_left f2 0 l in \ count1 = count2 && Buffer.contents b1 = Buffer.contents b2) *) let fold_right = Generic.fold_right (*$Q fold_right (Q.list Q.int) (fun l -> \ let make_bf () = \ let b = Buffer.create 10 in \ b, (fun acc elt -> Printf.bprintf b "%d" elt; acc + 1) \ in \ let b1, f1 = make_bf () in let b2, f2 = make_bf () in \ let count1 = fold_right f1 0 (of_list_for_test l) in \ let count2 = BatList.fold_right (fun elt acc -> f2 acc elt) l 0 in \ count1 = count2 && Buffer.contents b1 = Buffer.contents b2) *) let enum = Generic.enum (*$Q enum (Q.list Q.int) (fun l -> \ BatList.of_enum (enum (verify_measure (of_list_for_test l))) = l) *) let backwards = Generic.backwards (*$Q backwards (Q.list Q.int) (fun l -> \ BatList.of_enum (backwards (verify_measure (of_list_for_test l))) = List.rev l) *) let to_list = Generic.to_list (*$Q to_list (Q.list Q.int) (fun l -> \ to_list (verify_measure (of_list l)) = l) (Q.list Q.int) (fun l -> \ to_list (verify_measure (of_list_backwards l)) = List.rev l) (Q.list Q.int) (fun l -> \ to_list (verify_measure (of_enum (BatList.enum l))) = l) (Q.list Q.int) (fun l -> \ to_list (verify_measure (of_backwards (BatList.enum l))) = List.rev l) *) let to_list_backwards = Generic.to_list_backwards (*$Q to_list_backwards (Q.list Q.int) (fun l -> to_list_backwards (verify_measure (of_list_for_test l)) = List.rev l) *) let iter = Generic.iter (*$Q iter (Q.list Q.int) (fun l -> \ let make_bf () = \ let b = Buffer.create 10 in \ b, (fun elt -> Printf.bprintf b "%d" elt) \ in let b1, f1 = make_bf () in let b2, f2 = make_bf () in \ iter f1 (of_list_for_test l); BatList.iter f2 l; \ Buffer.contents b1 = Buffer.contents b2) *) let iter_right = Generic.iter_right (*$Q iter_right (Q.list Q.int) (fun l -> \ let make_bf () = \ let b = Buffer.create 10 in \ b, (fun elt -> Printf.bprintf b "%d" elt) \ in let b1, f1 = make_bf () in let b2, f2 = make_bf () in \ iter_right f1 (of_list_for_test l); BatList.iter f2 (BatList.rev l); \ Buffer.contents b1 = Buffer.contents b2) *) type ('wrapped_type, 'a, 'm) wrap = 'wrapped_type let cons t x = Generic.cons ~monoid:nat_plus_monoid ~measure:size_measurer t x (*$Q cons (Q.pair (Q.list Q.int) Q.int) (fun (l,i) -> \ to_list (verify_measure (cons (of_list_for_test l) i)) = i :: l) *) let snoc t x = Generic.snoc ~monoid:nat_plus_monoid ~measure:size_measurer t x (*$Q snoc (Q.pair (Q.list Q.int) Q.int) (fun (l,i) -> \ to_list (verify_measure (snoc (of_list_for_test l) i)) = BatList.append l [i]) *) let front t = Generic.front ~monoid:nat_plus_monoid ~measure:size_measurer t (*$Q front (Q.list Q.int) (fun l -> (match front (of_list_for_test l) with \ None -> [] | Some (t, hd) -> hd :: to_list (verify_measure t)) = l) *) let tail t = Generic.tail ~monoid:nat_plus_monoid ~measure:size_measurer t (*$Q tail (Q.list Q.int) (fun l -> (match tail (of_list_for_test l) with \ None -> None | Some t -> Some (to_list (verify_measure t))) \ = (match l with [] -> None | _ :: t -> Some t)) *) let init t = Generic.init ~monoid:nat_plus_monoid ~measure:size_measurer t (*$Q init (Q.list Q.int) (fun l -> (match init (of_list_for_test l) with \ None -> None | Some init -> Some (to_list (verify_measure init))) \ = (match l with [] -> \ None | _ :: _ -> Some (fst (BatList.split_at (List.length l - 1) l)))) *) let rear t = Generic.rear ~monoid:nat_plus_monoid ~measure:size_measurer t (*$Q rear (Q.list Q.int) (fun l -> (match rear (of_list_for_test l) with \ None -> [] | Some (init, last) -> \ BatList.append (to_list (verify_measure init)) [last]) = l) *) let front_exn t = Generic.front_exn ~monoid:nat_plus_monoid ~measure:size_measurer t (*$Q front_exn (Q.list Q.int) (fun l -> (try let tl, hd = front_exn (of_list_for_test l) in \ hd :: to_list (verify_measure tl) with Empty -> []) = l) *) let tail_exn t = Generic.tail_exn ~monoid:nat_plus_monoid ~measure:size_measurer t (*$Q tail_exn (Q.list Q.int) (fun l -> \ (try Some (to_list (verify_measure (tail_exn (of_list_for_test l)))) with \ Empty -> None) = (match l with [] -> None | _ :: t -> Some t)) *) let init_exn t = Generic.init_exn ~monoid:nat_plus_monoid ~measure:size_measurer t (*$Q init_exn (Q.list Q.int) (fun l -> \ (try Some (to_list (verify_measure (init_exn (of_list_for_test l)))) with \ Empty -> None) = (match l with [] -> None | _ :: _ -> \ Some (fst (BatList.split_at (List.length l - 1) l)))) *) let rear_exn t = Generic.rear_exn ~monoid:nat_plus_monoid ~measure:size_measurer t (*$Q rear_exn (Q.list Q.int) (fun l -> (try let init, last = rear_exn (of_list_for_test l) in \ BatList.append (to_list (verify_measure init)) [last] with Empty -> []) = l) *) let append t1 t2 = Generic.append ~monoid:nat_plus_monoid ~measure:size_measurer t1 t2 (*$Q append (Q.pair (Q.list Q.int) (Q.list Q.int)) (fun (l1, l2) -> \ to_list (verify_measure (append (of_list_for_test l1) (of_list_for_test l2))) \ = BatList.append l1 l2) *) let measure t = Generic.measure ~monoid:nat_plus_monoid ~measure:size_measurer t let size = measure (* O(1) this time *) (*$Q size (Q.list Q.int) (fun l -> List.length l = size (of_list_for_test l)) *) let reverse t = Generic.reverse ~monoid:nat_plus_monoid ~measure:size_measurer t (*$Q reverse (Q.list Q.int) (fun l -> \ to_list (verify_measure (reverse (of_list_for_test l))) \ = BatList.rev l) *) let split f t = Generic.split ~monoid:nat_plus_monoid ~measure:size_measurer f t let split_at t i = if i < 0 || i >= size t then invalid_arg "FingerTree.split_at: Index out of bounds"; split (fun index -> i < index) t (*$T split_at let n = 50 in \ let l = BatList.init n (fun i -> i) in \ let t = of_list_for_test l in let i = ref (-1) in \ BatList.for_all (fun _ -> incr i; let t1, t2 = split_at t !i in \ let l1, l2 = BatList.split_at !i l in \ to_list (verify_measure t1) = l1 && to_list (verify_measure t2) = l2) l try ignore (split_at empty 0); false with Invalid_argument _ -> true *) let lookup f t = Generic.lookup ~monoid:nat_plus_monoid ~measure:size_measurer f t let get t i = if i < 0 || i >= size t then invalid_arg "FingerTree.get: Index out of bounds"; lookup (fun index -> i < index) t (*$T get let n = 50 in \ let l = BatList.init n (fun i -> i) in \ let t = of_list_for_test l in let i = ref (-1) in \ BatList.for_all (fun elt -> incr i; elt = get t !i) l try ignore (get (singleton 1) 1); false with Invalid_argument _ -> true try ignore (get (singleton 1) (-1)); false with Invalid_argument _ -> true *) let set t i v = if i < 0 || i >= size t then invalid_arg "FingerTree.set: Index out of bounds"; let left, right = split_at t i in append (snoc left v) (tail_exn right) (*$T set to_list (set (snoc (snoc (snoc empty 1) 2) 3) 1 4) = [1; 4; 3] to_list (set (snoc (snoc (snoc empty 1) 2) 3) 0 4) = [4; 2; 3] to_list (set (snoc (snoc (snoc empty 1) 2) 3) 2 4) = [1; 2; 4] try ignore (set (snoc (snoc (snoc empty 1) 2) 3) (-1) 4); false with Invalid_argument _ -> true try ignore (set (snoc (snoc (snoc empty 1) 2) 3) 3 4); false with Invalid_argument _ -> true *) let update t i f = set t i (f (get t i)) (*$T update to_list (verify_measure (update (snoc (snoc (snoc empty 1) 2) 3) 1 (fun x -> x + 1))) = [1; 3; 3] to_list (verify_measure (update (snoc (snoc (snoc empty 1) 2) 3) 0 (fun x -> x + 1))) = [2; 2; 3] to_list (verify_measure (update (snoc (snoc (snoc empty 1) 2) 3) 2 (fun x -> x + 1))) = [1; 2; 4] try ignore (update (snoc (snoc (snoc empty 1) 2) 3) (-1) (fun x -> x + 1)); false with Invalid_argument _ -> true try ignore (update (snoc (snoc (snoc empty 1) 2) 3) 3 (fun x -> x + 1)); false with Invalid_argument _ -> true *) let of_enum e = Generic.of_enum ~monoid:nat_plus_monoid ~measure:size_measurer e let of_list l = Generic.of_list ~monoid:nat_plus_monoid ~measure:size_measurer l let of_backwards e = Generic.of_backwards ~monoid:nat_plus_monoid ~measure:size_measurer e let of_list_backwards l = Generic.of_list_backwards ~monoid:nat_plus_monoid ~measure:size_measurer l let of_list_for_test l = Generic.of_list_for_test ~monoid:nat_plus_monoid ~measure:size_measurer l let map f t = Generic.map ~monoid:nat_plus_monoid ~measure:size_measurer f t (*$Q map (Q.list Q.int) (fun l -> \ let make_bf () = \ let b = Buffer.create 10 in \ b, (fun elt -> Printf.bprintf b "%d" elt; elt + 1) \ in \ let b1, f1 = make_bf () in let b2, f2 = make_bf () in \ let res1 = map f1 (of_list_for_test l) in let res2 = BatList.map f2 l in \ to_list (verify_measure res1) = res2 && Buffer.contents b1 = Buffer.contents b2) *) let map_right f t = Generic.map_right ~monoid:nat_plus_monoid ~measure:size_measurer f t (*$Q map_right (Q.list Q.int) (fun l -> \ let make_bf () = \ let b = Buffer.create 10 in \ b, (fun elt -> Printf.bprintf b "%d" elt; elt + 1) \ in \ let b1, f1 = make_bf () in let b2, f2 = make_bf () in \ let res1 = map_right f1 (of_list_for_test l) in \ let res2 = List.rev (BatList.map f2 (List.rev l)) in \ to_list (verify_measure res1) = res2 && Buffer.contents b1 = Buffer.contents b2) *) let print = Generic.print let compare = Generic.compare let equal = Generic.equal let check_measures t = Generic.check_measures ~monoid:nat_plus_monoid ~measure:size_measurer ~eq:BatInt.(=) t let verify_measure t = if not (check_measures t) then failwith "Invariants not verified"; t let invariants t = assert (check_measures t) batteries-included-3.4.0/src/batFingerTree.mli000066400000000000000000000301021415601150500212720ustar00rootroot00000000000000(* * Copyright (C) 2011 Batteries Included Development Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** This module implements a generic finger tree datastructure as described here: Finger Trees: A Simple General-purpose Data Structure http://www.soi.city.ac.uk/~ross/papers/FingerTree.pdf The finger tree itself is polymorphic over the measure and the measurement function (this is needed because sometimes the type of the measure depends on the type of the elements). This module also contains an instantiation of a finger tree that implements a functional sequence with the following characteristics: - amortized constant time addition and deletions at both ends - constant time size operation - logarithmic lookup, update or deletion of the element at a given index - logarithmic splitting and concatenation If you are trying to understand the signature at first, whenever you see a type [(something, _, _) wrap], just pretend it is simply the type [something] (this is what the documentation does). Complexities are given assuming that the monoid combination operation and the measurement functions are constant time and space. None of the functions on finger trees can cause stack overflow: they use at worst a logarithmic amount of stack space. *) (** The type of the element of a monoid. *) type 'a monoid = { zero : 'a; (** The neutral element of the monoid. *) combine : 'a -> 'a -> 'a ; (** [combine] should be associative, and have [zero] as neutral element. *) } exception Empty (** An exception that is thrown by various operations when trying to get a non existing element. *) module type S = sig type ('a, 'm) fg (** The type of finger trees containing elements of type ['a] measured by ['m]. *) type ('wrapped_type, 'a, 'm) wrap (** A type meant to avoid duplication of signatures. For the generic finger tree, this type will be [monoid:'m monoid -> measure:('a -> 'm) -> 'wrapped_type]. Once the finger tree has been specialized, the resulting module should be reexported in such a way that the type is now simply ['wrapped_type]. *) (** {6 Construction} *) val empty : ('a, 'm) fg (** [empty] is the sequence with no elements. *) val singleton : 'a -> ('a, 'm) fg (** [singleton elt] build the sequence containing [elt] as its sole element. O(1). *) val cons : (('a, 'm) fg -> 'a -> ('a, 'm) fg, 'a, 'm) wrap (** [cons t elt] adds [elt] to the left of [t]. O(1) amortized, O(log(n)) worst case. *) val snoc : (('a, 'm) fg -> 'a -> ('a, 'm) fg, 'a, 'm) wrap (** [snoc t elt] adds [elt] to the right of [t]. O(1) amortized, O(log(n)) worst case. *) (** {6 Deconstruction} *) val front : (('a, 'm) fg -> (('a, 'm) fg * 'a) option, 'a, 'm) wrap (** [front t] returns [None] when [t] is empty, or [Some (tl, hd)] when [hd] is the first element of the sequence and [tl] is the rest of the sequence. O(1) amortized, O(log(n)) worst case. *) val front_exn : (('a, 'm) fg -> (('a, 'm) fg * 'a), 'a, 'm) wrap (** [front_exn t] returns [(tl, hd)] when [hd] is the first element of the sequence and [tl] is the rest of the sequence. @raise Empty if [t] is empty. O(1) amortized, O(log(n)) worst case. *) val head : ('a, 'm) fg -> 'a option (** [head t] returns [None] if [t] is empty, or [Some hd] otherwise, where [hd] is the first element of the sequence. O(1). *) val head_exn : ('a, 'm) fg -> 'a (** [head_exn t] returns the first element of the sequence. @raise Empty if [t] is empty. O(1). *) val last : ('a, 'm) fg -> 'a option (** [last t] returns [None] if [t] is empty, or [Some hd] otherwise, where [hd] is the last element of the sequence. O(1). *) val last_exn : ('a, 'm) fg -> 'a (** [last_exn t] returns the last element of the sequence. @raise Empty if [t] is empty. O(1). *) val tail : (('a, 'm) fg -> ('a, 'm) fg option, 'a, 'm) wrap (** [tail t] returns [None] when [t] is empty, or [Some tl] where [tl] is the sequence [t] where the first element has been removed. O(1) amortized, O(log(n)) worst case. *) val tail_exn : (('a, 'm) fg -> ('a, 'm) fg, 'a, 'm) wrap (** [tail_exn t] returns the sequence [t] where the first element has been removed. @raise Empty if [t] is empty. O(1) amortized, O(log(n)) worst case. *) val init : (('a, 'm) fg -> ('a, 'm) fg option, 'a, 'm) wrap (** [init t] returns [None] if [t] is empty, or [Some init] where [init] is the sequence [t] where the last element has been removed. O(1) amortized, O(log(n)) worst case. *) val init_exn : (('a, 'm) fg -> ('a, 'm) fg, 'a, 'm) wrap (** [init_exn t] returns the sequence [t] where the last element has been removed. @raise Empty if [t] is empty. O(1) amortized, O(log(n)) worst case. *) val rear : (('a, 'm) fg -> (('a, 'm) fg * 'a) option, 'a, 'm) wrap (** [rear t] returns [None] when [t] is empty, or [Some (init, last)] where [last] is the last element of the sequence and [init] is the rest of the sequence. O(1) amortized, O(log(n)) worst case. *) val rear_exn : (('a, 'm) fg -> (('a, 'm) fg * 'a), 'a, 'm) wrap (** [rear_exn t] returns [(init, last)] when [last] is the last element of the sequence and [init] is the rest of the sequence. @raise Empty if [t] is empty. O(1) amortized, O(log(n)) worst case. *) (** {6 Inspection} *) val size : ('a, 'm) fg -> int (** [size t] returns the number of elements in the sequence. If you want to know that a sequence is empty, it is much better to use {!is_empty}. O(n). *) val is_empty : ('a, 'm) fg -> bool (** [is_empty t] returns [true] when the sequence has no elements. O(1). *) val fold_left : ('acc -> 'a -> 'acc) -> 'acc -> ('a, 'm) fg -> 'acc (** [fold_left] is equivalent to [List.fold_left]. O(n). *) val fold_right : ('acc -> 'a -> 'acc) -> 'acc -> ('a, 'm) fg -> 'acc (** [fold_right] is equivalent to [List.fold_right]. O(n). *) val iter : ('a -> unit) -> ('a, 'm) fg -> unit (** [iter] is equivalent to [List.iter]. O(n). *) val iter_right : ('a -> unit) -> ('a, 'm) fg -> unit (** [iter_right] is equivalent to [List.iter o List.rev]. O(n). *) val compare : ('a -> 'a -> int) -> ('a, 'm) fg -> ('a, 'm) fg -> int (** [compare cmp t1 t2] compares the two sequences lexicographically. O(n). *) val equal : ('a -> 'a -> bool) -> ('a, 'm) fg -> ('a, 'm) fg -> bool (** [equal eq t1 t2] returns [true] when the two sequences contain the the same elements. O(n). *) (** {6 Conversions} *) (** {7 Conversions to other structures} *) val enum : ('a, 'm) fg -> 'a BatEnum.t (** [enum t] builds an enumeration of the elements of [t] going from left to right. O(1). Forcing the whole enumeration takes O(n). *) val backwards : ('a, 'm) fg -> 'a BatEnum.t (** [backwards t] builds an enumeration of the elements of [t] going from right to left. Same complexity as {!enum}. *) val to_list : ('a, 'm) fg -> 'a list (** [to_list t] is equivalent to [BatList.of_enum (enum t)]. O(n). *) val to_list_backwards : ('a, 'm) fg -> 'a list (** [to_list_backwards t] is equivalent to [BatList.of_enum (backwards t)]. O(n). *) (** {7 Conversions from other structures} *) val of_enum : ('a BatEnum.t -> ('a, 'm) fg, 'a, 'm) wrap (** [of_enum e] build the sequence containing the elements of [e] in the same order. Its complexity is the complexity of forcing the enumeration. *) val of_backwards : ('a BatEnum.t -> ('a, 'm) fg, 'a, 'm) wrap (** [of_backwards e] is equivalent to [reverse (of_enum e)]. O(n). *) val of_list : ('a list -> ('a, 'm) fg, 'a, 'm) wrap (** [of_list l] is equivalent to [of_enum (BatList.enum l)]. O(n). *) val of_list_backwards : ('a list -> ('a, 'm) fg, 'a, 'm) wrap (** [of_list_backwards l] is equivalent to [of_enum_backwards (BatList.enum l)]. O(n). *) (** {6 Combining/reorganizing} *) val map : (('a -> 'b) -> ('a, 'm) fg -> ('b, 'm) fg, 'b, 'm) wrap (** [map] is equivalent to {!List.map}. O(n). *) val map_right : (('a -> 'b) -> ('a, 'm) fg -> ('b, 'm) fg, 'b, 'm) wrap (** [map_right] is equivalent to [List.rev o List.map o List.rev]. O(n). *) val append : (('a, 'm) fg -> ('a, 'm) fg -> ('a, 'm) fg, 'a, 'm) wrap (** [append] is equivalent to [List.append]. O(log(min(n,m))). *) val reverse : (('a, 'm) fg -> ('a, 'm) fg, 'a, 'm) wrap (** [reverse t] is equivalent to [of_list (List.rev (to_list t))]. O(n). *) (** {6 Boilerplate code} *) val print : ?first:string -> ?last:string -> ?sep:string -> ('a, 'b) BatIO.printer -> (('a, _) fg,'b) BatIO.printer end module Generic : sig include S with type ('wrapped_type, 'a, 'm) wrap = monoid:'m monoid -> measure:('a -> 'm) -> 'wrapped_type val lookup : (('m -> bool) -> ('a, 'm) fg -> 'a, 'a, 'm) wrap (** [lookup p t], when [p] is monotonic, returns the first element of the sequence for which the measure of its predecessors in the sequence (itself included) satisfies [p]. @raise Empty is there is no such element. O(log(n)). When [p] is not monotonic, take a look at the code or at the paper cited above and see if you understand something (lookup is a specialized version of splitTree that returns the element without building the left and right tree). *) val measure : (('a, 'm) fg -> 'm, 'a, 'm) wrap (** [measure m] gives the measure of the whole tree, whose meaning depends on the measure chosen. O(1). *) val split : (('m -> bool) -> ('a, 'm) fg -> ('a, 'm) fg * ('a, 'm) fg, 'a, 'm) wrap (** [split p t], when [p] is monotonic, returns [(t1, t2)] where [t1] is the longest prefix of [t] whose measure does not satisfies [p], and [t2] is the rest of [t]. @raise Empty is there is no such element O(log(n)). When [p] is not monotonic, take a look at the code or at the paper cited above and see if you understand something. *) end type 'a t include S with type ('wrapped_type, 'a, 'm) wrap = 'wrapped_type and type ('a, 'm) fg = 'a t val size : 'a t -> int (** [size t] returns the number of elements in the sequence. Unlike the generic [size] on finger trees, this one has complexity O(1). *) val split_at : 'a t -> int -> 'a t * 'a t (** [split_at] is equivalent to [List.split_at]. @raise Invalid_argument when the index is out of bounds. O(log(n)). *) val get : 'a t -> int -> 'a (** [get t i] returns the [i]-th element of [t]. @raise Invalid_argument when the index is out of bounds. O(log(n)). *) val set : 'a t -> int -> 'a -> 'a t (** [set t i v] returns [t] where the [i]-th element is now [v]. @raise Invalid_argument when the index is out of bounds. O(log(n)). *) val update : 'a t -> int -> ('a -> 'a) -> 'a t (** [update t i f] returns [t] where the [i]-th element is now [f (get i t)]. @raise Invalid_argument when the index is out of bounds. O(log(n)). *) (**/**) val of_list_for_test : 'a list -> 'a t val verify_measure : 'a t -> 'a t val invariants : _ t -> unit (**/**) batteries-included-3.4.0/src/batFloat.mliv000066400000000000000000000446171415601150500205130ustar00rootroot00000000000000(* * BatFloat - Extended floats * Copyright (C) 2007 Bluestorm * 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (**Operations on floating-point numbers. OCaml's floating-point numbers follow the IEEE 754 standard, using double precision (64 bits) numbers. Floating-point operations never raise an exception on overflow, underflow, division by zero, etc. Instead, special IEEE numbers are returned as appropriate, such as [infinity] for [1.0 /. 0.0], [neg_infinity] for [-1.0 /. 0.0], and [nan] (``not a number'') for [0.0 /. 0.0]. These special numbers then propagate through floating-point computations as expected: for instance, [1.0 /. infinity] is [0.0], and any operation with [nan] as argument returns [nan] as result. For more precision, see {{:http://en.wikipedia.org/wiki/IEEE_754}The Wikipedia entry on standard IEEE 754}. @author Gabriel Scherer @author David Teller @author Edgar Friendly @documents Float *) type t = float (**The type of floating-point numbers. Floating-point numbers are the default representation of real numbers by OCaml. *) (** {6 Usual operations} *) val zero : float (** Floating number zero. This is the same thing as [0.]*) val one : float (** Floating number one. This is the same thing as [1.]*) external neg : float -> float = "%negfloat" (** Returns the negation of the input, i.e. (fun x -> ~-. x) *) val succ : float -> float (** Add [1.] to a floating number. Note that, as per IEEE 754, if [x] is a large enough float number, [succ x] might be equal to [x], due to rounding.*) val pred : float -> float (** Subtract [1.] from a floating number. Note that, as per IEEE 754, if [x] is a large enough float number, [pred x] might be equal to [x], due to rounding.*) external abs : float -> float = "%absfloat" (** The absolute value of a floating point number.*) val add : float -> float -> float val sub : float -> float -> float val mul : float -> float -> float val div : float -> float -> float external modulo : float -> float -> float = "caml_fmod_float" "fmod" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external pow : float -> float -> float = "caml_power_float" "pow" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] val min_num : float val max_num : float val compare : float -> float -> int val equal : float -> float -> bool val ord : float -> float -> BatOrd.order external of_int : int -> float = "%floatofint" external to_int : float -> int = "%intoffloat" external of_float : float -> float = "%identity" external to_float : float -> float = "%identity" val of_string : string -> float val to_string : float -> string external ( + ) : t -> t -> t = "%addfloat" external ( - ) : t -> t -> t = "%subfloat" external ( * ) : t -> t -> t = "%mulfloat" external ( / ) : t -> t -> t = "%divfloat" external ( ** ) : t -> t -> t = "caml_power_float" "pow" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] val min : float -> float -> float val max : float -> float -> float (* Available only in `Compare` submodule val ( <> ) : t -> t -> bool val ( >= ) : t -> t -> bool val ( <= ) : t -> t -> bool val ( > ) : t -> t -> bool val ( < ) : t -> t -> bool val ( = ) : t -> t -> bool *) val ( -- ): t -> t -> t BatEnum.t val ( --- ): t -> t -> t BatEnum.t val operations : t BatNumber.numeric (** {6 Operations specific to floating-point numbers} *) external sqrt : float -> float = "caml_sqrt_float" "sqrt" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] (** Square root. *) external exp : float -> float = "caml_exp_float" "exp" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] (** Exponential. *) external log : float -> float = "caml_log_float" "log" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] (** Natural logarithm. *) external log10 : float -> float = "caml_log10_float" "log10" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] (** Base 10 logarithm. *) external cos : float -> float = "caml_cos_float" "cos" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] (** See {!atan2}. *) external sin : float -> float = "caml_sin_float" "sin" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] (** See {!atan2}. *) external tan : float -> float = "caml_tan_float" "tan" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] (** See {!atan2}. *) external acos : float -> float = "caml_acos_float" "acos" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] (** See {!atan2}. *) external asin : float -> float = "caml_asin_float" "asin" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] (** See {!atan2}. *) external atan : float -> float = "caml_atan_float" "atan" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] (** See {!atan2}. *) external atan2 : float -> float -> float = "caml_atan2_float" "atan2" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] (** The usual trigonometric functions. *) external cosh : float -> float = "caml_cosh_float" "cosh" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] (** See {!tanh}. *) external sinh : float -> float = "caml_sinh_float" "sinh" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] (** See {!tanh}. *) external tanh : float -> float = "caml_tanh_float" "tanh" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] (** The usual hyperbolic trigonometric functions. *) external ceil : float -> float = "caml_ceil_float" "ceil" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] (** See {!floor}. *) external floor : float -> float = "caml_floor_float" "floor" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] (** Round the given float to an integer value. [floor f] returns the greatest integer value less than or equal to [f]. [ceil f] returns the least integer value greater than or equal to [f]. *) val round : float -> float (** [round x] rounds [x] to the nearest integral floating-point (the nearest of [floor x] and [ceil x]). In case the fraction of x is exactly 0.5, we round away from 0. : [round 1.5] is [2.] but [round (-3.5)] is [-4.]. *) val round_to_int : float -> int (** [round_to_int x] is [int_of_float (round x)]. @since 2.0 *) val round_to_string : ?digits:int -> float -> string (** [round_to_string ~digits:d x] will return a string representation of [x] -- in base 10 -- rounded to [d] digits after the decimal point. By default, [digits] is [0], we round to the nearest integer. @raise Invalid_argument if the ~digits argument is negative. This is strictly a convenience function for simple end-user printing and you should not rely on its behavior. One possible implementation is to rely on C `sprintf` internally, which means: - no guarantee is given on the round-at-half behavior; it may not be consistent with [round] or [round_to_int] - [round_to_string ~digits:0 3.] may return "3" instead of "3." as [string_of_float] would - no guarantee is given on the behavior for abusively high number of digits precision; for example [round_to_string ~digits:max_int x] may return the empty string. @since 2.0 *) (** [root x n] calculates the nth root of x. @raise Invalid_argument if n is negative or if the result would be imaginary *) val root: float -> int -> float (** @return True if the sign bit of [x] is set. This usually indicates thet [x] is negative. @since 2.0*) val signbit: float -> bool (** [copysign x y] returns a copy of [x] with the same sign as [y]. @since 2.0*) val copysign: float -> float -> float val is_nan : float -> bool (** [is_nan f] returns [true] if [f] is [nan], [false] otherwise.*) val is_special : float -> bool (** [is_special f] returns [true] if [f] is [nan] or [+/- infinity], [false] otherwise. @since 2.0 *) val is_finite : float -> bool (** [is_finite f] returns [true] if [f] is not [nan] or [+/- infinity], [false] otherwise. @since 2.0 *) (** {6 Constants} *) (** Special float constants. It may not be safe to compare directly with these, as they have multiple internal representations. Instead use the [is_special], [is_nan], etc. tests *) val infinity : float (** Positive infinity. *) val neg_infinity : float (** Negative infinity. *) val nan : float (** A special floating-point value denoting the result of an undefined operation such as [0.0 /. 0.0]. Stands for ``not a number''. Any floating-point operation with [nan] as argument returns [nan] as result. As for floating-point comparisons, [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true] if one or both of their arguments is [nan]. *) (** Numeric constants *) (** The smallest positive float [x] such that [1.0 +. x <> 1.0]. *) val epsilon : float (** Euler? ... Euler? ... Euler? @since 2.0*) val e: float (** [Math.log2 e] @since 2.0 *) val log2e: float (** [log10 e] @since 2.0 *) val log10e: float (** [log 2] @since 2.0 *) val ln2: float (** [log 10] @since 2.0 *) val ln10: float (** The constant pi (3.14159...) *) val pi : float (** [pi /. 2.] @since 2.0 *) val pi2: float (** [pi /. 4.] @since 2.0 *) val pi4: float (** [1. /. pi] @since 2.0 *) val invpi: float (** [2. /. pi] @since 2.0 *) val invpi2: float (** [2. *. sqrt pi] @since 2.0 *) val sqrtpi2: float (** [sqrt 2.] @since 2.0 *) val sqrt2: float (** [1. /. sqrt 2.] @since 2.0 *) val invsqrt2: float (** {6 Operations on the internal representation of floating-point numbers}*) external frexp : float -> float * int = "caml_frexp_float" (** [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]. *) external ldexp : float -> int -> float = "caml_ldexp_float" (** [ldexp x n] returns [x *. 2 ** n]. *) external modf : float -> float * float = "caml_modf_float" (** [modf f] returns the pair of the fractional and integral part of [f]. *) (** Classes of floating point numbers*) type fpkind = Pervasives.fpclass = | FP_normal (** Normal number, none of the below *) | FP_subnormal (** Number very close to 0.0, has reduced precision *) | FP_zero (** Number is 0.0 or -0.0 *) | FP_infinite (** Number is positive or negative infinity *) | FP_nan (** Not a number: result of an undefined operation *) (** The five classes of floating-point numbers, as determined by the {!classify} function. *) external classify : float -> fpkind = "caml_classify_float" (** Return the class of the given floating-point number: normal, subnormal, zero, infinite, or not a number. *) val approx_equal : ?epsilon:float -> float -> float -> bool (** Test whether two floats are approximately equal (i.e. within epsilon of each other). [epsilon] defaults to 1e-5. *) (** {6 Submodules grouping all infix operators} *) module Infix : sig include BatNumber.Infix with type bat__infix_t = t val (=~) : ?epsilon:float -> float -> float -> bool (** Approximate comparison of two floats, as [approx_equal]. [epsilon] defaults to 1e-5. *) end module Compare : BatNumber.Compare with type bat__compare_t = t include BatNumber.RefOps with type bat__refops_t = t include BatNumber.Bounded with type bounded = t (** {6 Boilerplate code}*) (** {7 Printing}*) val print: (t, _) BatIO.printer (**Operations on floating-point numbers, with exceptions raised in case of error. The operations implemented in this module are the same as the operations implemented in module {!Float}, with the exception that no operation returns [nan], [infinity] or [neg_infinity]. In case of overflow, instead of returning [infinity] or [neg_infinity], operations raise exception {!Number.Overflow}. In case of [nan], operations raise exception {!Number.NaN}. OCaml's floating-point numbers follow the IEEE 754 standard, using double precision (64 bits) numbers. Floating-point operations never raise an exception on overflow, underflow, division by zero, etc. Instead, special IEEE numbers are returned as appropriate, such as [infinity] for [1.0 /. 0.0], [neg_infinity] for [-1.0 /. 0.0], and [nan] (``not a number'') for [0.0 /. 0.0]. These special numbers then propagate through floating-point computations as expected: for instance, [1.0 /. infinity] is [0.0], and any operation with [nan] as argument returns [nan] as result. For more precision, see {{:http://en.wikipedia.org/wiki/IEEE_754}The Wikipedia entry on standard IEEE 754}. @author David Teller @documents Safe_float *) module Safe_float : sig type t = float (**The type of floating-point numbers. Floating-point numbers are the default representation of real numbers by OCaml. *) (** {6 Usual operations} *) val zero : float (** Floating number zero. This is the same thing as [0.]*) val one : float (** Floating number one. This is the same thing as [1.]*) val neg : float -> float val succ : float -> float (** Add [1.] to a floating number. Note that, as per IEEE 754, if [x] is a large enough float number, [succ x] might be equal to [x], due to rounding.*) val pred : float -> float (** Subtract [1.] from a floating number. Note that, as per IEEE 754, if [x] is a large enough float number, [pred x] might be equal to [x], due to rounding.*) val abs : float -> float (** The absolute value of a floating point number.*) val add : float -> float -> float val sub : float -> float -> float val mul : float -> float -> float val div : float -> float -> float val modulo : float -> float -> float val pow : float -> float -> float val min_num : float val max_num : float val compare : float -> float -> int val of_int : int -> float val to_int : float -> int external of_float : float -> float = "%identity" external to_float : float -> float = "%identity" val of_string : string -> float val to_string : float -> string val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t val ( ** ) : t -> t -> t (* Available only in `Compare` submodule val ( <> ) : t -> t -> bool val ( >= ) : t -> t -> bool val ( <= ) : t -> t -> bool val ( > ) : t -> t -> bool val ( < ) : t -> t -> bool val ( = ) : t -> t -> bool *) val operations : t BatNumber.numeric include BatNumber.Bounded with type bounded = t (** {6 Operations specific to floating-point numbers} *) val exp : float -> float (** Exponential. *) val log : float -> float (** Natural logarithm. *) val log10 : float -> float (** Base 10 logarithm. *) val cos : float -> float (** See {!atan2}. *) val sin : float -> float (** See {!atan2}. *) val tan : float -> float (** See {!atan2}. *) val acos : float -> float (** See {!atan2}. *) val asin : float -> float (** See {!atan2}. *) val atan : float -> float (** See {!atan2}. *) val atan2 : float -> float -> float (** The usual trigonometric functions. *) val cosh : float -> float (** See {!tanh}. *) val sinh : float -> float (** See {!tanh}. *) val tanh : float -> float (** The usual hyperbolic trigonometric functions. *) val ceil : float -> float (** See {!floor}. *) val floor : float -> float (** Round the given float to an integer value. [floor f] returns the greatest integer value less than or equal to [f]. [ceil f] returns the least integer value greater than or equal to [f]. *) val infinity : float (** Positive infinity. *) val neg_infinity : float (** Negative infinity. *) val nan : float (** A special floating-point value denoting the result of an undefined operation such as [0.0 /. 0.0]. Stands for ``not a number''. Any floating-point operation with [nan] as argument returns [nan] as result. As for floating-point comparisons, [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true] if one or both of their arguments is [nan]. *) val is_nan : float -> bool (** [is_nan f] returns [true] if [f] is [nan], [false] otherwise.*) val epsilon : float (** The smallest positive float [x] such that [1.0 +. x <> 1.0]. *) val pi : float (** The constant pi (3.14159...) *) (** {6 Operations on the internal representation of floating-point numbers}*) val frexp : float -> float * int (** [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 ldexp : float -> int -> float (** [ldexp x n] returns [x *. 2 ** n]. *) val modf : float -> float * float (** [modf f] returns the pair of the fractional and integral part of [f]. *) (** Classes of floating point numbers*) type fpkind = Pervasives.fpclass = FP_normal (** Normal number, none of the below *) | FP_subnormal (** Number very close to 0.0, has reduced precision *) | FP_zero (** Number is 0.0 or -0.0 *) | FP_infinite (** Number is positive or negative infinity *) | FP_nan (** Not a number: result of an undefined operation *) (** The five classes of floating-point numbers, as determined by the {!classify} function. *) external classify : float -> fpkind = "caml_classify_float" (** Return the class of the given floating-point number: normal, subnormal, zero, infinite, or not a number. *) (** {6 Boilerplate code}*) (** {7 Printing}*) val print: 'a BatInnerIO.output -> t -> unit end batteries-included-3.4.0/src/batFloat.mlv000066400000000000000000000320061415601150500203270ustar00rootroot00000000000000(* * BatFloat - Extended floating-point numbers * Copyright (C) 2007 Bluestorm * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open BatNumber module BaseFloat = struct type t = float let zero, one = 0., 1. let neg = (~-.) let succ x = x +. 1. let pred x = x -. 1. let abs = abs_float let add, sub, mul, div = (+.), (-.), ( *.), (/.) let modulo = mod_float let pow = ( ** ) let compare = compare let of_int = float_of_int let to_int = int_of_float let of_string = float_of_string let to_string = string_of_float external of_float : float -> float = "%identity" external to_float : float -> float = "%identity" end let approx_equal ?(epsilon = 1e-5) f1 f2 = abs_float (f1 -. f2) < epsilon (*$T approx_equal approx_equal 0. 1e-15 approx_equal 0.3333333333 (1. /. 3.) not (approx_equal 1. 2.) not (approx_equal 1.5 1.45) *) external exp : float -> float = "caml_exp_float" "exp" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external log : float -> float = "caml_log_float" "log" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external log10 : float -> float = "caml_log10_float" "log10" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external cos : float -> float = "caml_cos_float" "cos" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external sin : float -> float = "caml_sin_float" "sin" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external tan : float -> float = "caml_tan_float" "tan" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external acos : float -> float = "caml_acos_float" "acos" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external asin : float -> float = "caml_asin_float" "asin" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external atan : float -> float = "caml_atan_float" "atan" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external atan2 : float -> float -> float = "caml_atan2_float" "atan2" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external cosh : float -> float = "caml_cosh_float" "cosh" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external sinh : float -> float = "caml_sinh_float" "sinh" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external tanh : float -> float = "caml_tanh_float" "tanh" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external ceil : float -> float = "caml_ceil_float" "ceil" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external floor : float -> float = "caml_floor_float" "floor" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external frexp : float -> float * int = "caml_frexp_float" external ldexp : float -> int -> float = "caml_ldexp_float" external modf : float -> float * float = "caml_modf_float" let root m n = if n < 0 then invalid_arg "Float.root: Negative root" else if m < 0. && n land 1 <> 1 then invalid_arg "Float.root: Imaginary result" else if m < 0. then -. exp (log (abs_float m) /. (float_of_int n)) else exp (log m /. (float_of_int n)) (* sign bit is top bit, shift all other 63 bits away and test if = one Negative numbers have this bit set, positive unset. *) let signbit x = Int64.shift_right_logical (Int64.bits_of_float x) 63 = Int64.one (*$T signbit signbit (-256.) not (signbit 1e50) *) let copysign x s = if signbit s then -. (abs_float x) else abs_float x (*$T copysign copysign 1. 1. = 1. copysign 1. (-1.) = (-1.) *) let round x = (* 'halve' is the biggest representable double that is smaller than 0.5; (halve +. 0.5) rounds to 1., which makes for incorrect rounding of 'halve', while (halve +. halve) is strictly smaller than 1. as expected. *) let halve = 0.499999999999999944 in (* we test x >= 0. rather than x > 0. because otherwise round_to_string 0. returns "-0." (ceil of -0.5 is 'negative zero') which is confusing. *) if x >= 0.0 then floor (x +. halve) else ceil (x -. halve) (* the tests below look ugly with those Pervasives.(...); this is a temporary fix made necessary by BatFloat overriding the (=) operator. Hugh. *) (*$T round Pervasives.(=) (List.map round [1.1; 2.4; 3.3; 3.5; 4.99]) [1.; 2.; 3.; 4.; 5.] Pervasives.(=) (List.map round [-1.1; -2.4; -3.3; -3.5; -4.99]) [-1.; -2.; -3.; -4.; -5.] round 0.499999999999999944 = 0. round (-0.499999999999999944) = 0. *) let round_to_int x = int_of_float (round x) (*$T round_to_int Pervasives.(=) (List.map round_to_int [1.1; 2.4; 3.3; 3.5; 4.99]) [1; 2; 3; 4; 5] *) module Infix = struct include BatNumber.MakeInfix(BaseFloat) let (=~) = approx_equal end include (BatNumber.MakeNumeric(BaseFloat) : BatNumber.Numeric with type t = float and module Infix := Infix) let min (x:float) y = if x < y then x else y let max (x:float) y = if x < y then y else x (* Fix definitions for performance *) external of_float : float -> float = "%identity" external to_float : float -> float = "%identity" external sqrt : float -> float = "caml_sqrt_float" "sqrt" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external neg : float -> float = "%negfloat" external abs : float -> float = "%absfloat" external modulo : float -> float -> float = "caml_fmod_float" "fmod" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external pow : float -> float -> float = "caml_power_float" "pow" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] external of_int : int -> float = "%floatofint" external to_int : float -> int = "%intoffloat" external of_float : float -> float = "%identity" external to_float : float -> float = "%identity" external ( + ) : t -> t -> t = "%addfloat" external ( - ) : t -> t -> t = "%subfloat" external ( * ) : t -> t -> t = "%mulfloat" external ( / ) : t -> t -> t = "%divfloat" external ( ** ) : t -> t -> t = "caml_power_float" "pow" ##V<4.3## "float" ##V>=4.3## [@@unboxed] [@@noalloc] type bounded = t let min_num, max_num = neg_infinity, infinity type fpkind = Pervasives.fpclass = | FP_normal | FP_subnormal | FP_zero | FP_infinite | FP_nan external classify : float -> fpkind = "caml_classify_float" let is_nan f = match classify f with | FP_nan -> true | _ -> false let is_special f = match classify f with | FP_nan | FP_infinite -> true | FP_normal | FP_subnormal | FP_zero -> false let is_finite f = match classify f with | FP_nan | FP_infinite -> false | FP_normal | FP_subnormal | FP_zero -> true let infinity = Pervasives.infinity let neg_infinity = Pervasives.neg_infinity let nan = Pervasives.nan let epsilon = Pervasives.epsilon_float let e = 2.7182818284590452354 let log2e = 1.4426950408889634074 let log10e = 0.43429448190325182765 let ln2 = 0.69314718055994530942 let ln10 = 2.30258509299404568402 let pi = 3.14159265358979323846 let pi2 = 1.57079632679489661923 let pi4 = 0.78539816339744830962 let invpi = 0.31830988618379067154 let invpi2 = 0.63661977236758134308 let sqrtpi2 = 1.12837916709551257390 let sqrt2 = 1.41421356237309504880 let invsqrt2 = 0.70710678118654752440 let print out t = BatInnerIO.nwrite out (to_string t) let round_to_string ?(digits=0) x = if Pervasives.(<) digits 0 then invalid_arg "Float.round_to_string"; match classify x with | FP_normal | FP_subnormal | FP_zero -> BatPrintf.sprintf "%.*f" digits x (* we don't call sprintf in the 'special' cases as it seems to behave weirdly in some cases (eg. on Windows, bug #191) *) | FP_infinite -> if x = neg_infinity then "-inf" else "inf" | FP_nan -> "nan" (*$T round_to_string List.mem (round_to_string 3.) ["3."; "3"] Pervasives.(=) (round_to_string ~digits:0 3.) (round_to_string 3.) Pervasives.(=) (round_to_string ~digits:1 3.) "3.0" Pervasives.(=) (round_to_string ~digits:1 0.) "0.0" Pervasives.(=) (round_to_string ~digits:1 epsilon_float) "0.0" Pervasives.(=) (round_to_string ~digits:3 1.23456) "1.235" Pervasives.(=) (round_to_string ~digits:3 (- 1.23456)) "-1.235" Pervasives.(=) (round_to_string ~digits:3 1.98765) "1.988" Pervasives.(=) (round_to_string ~digits:3 (- 1.98765)) "-1.988" Result.(catch (round_to_string ~digits:(-1)) 3. |> is_exn (Invalid_argument "Float.round_to_string")) List.mem (round_to_string 0.5) ["0"; "0."; "1"; "1."] List.mem (round_to_string (-0.5)) ["-1"; "-1."; "0"; "0."; "-0"; "-0."] List.mem (round_to_string ~digits:2 0.215) ["0.21"; "0.22"] List.mem (round_to_string ~digits:2 (-0.215)) ["-0.22"; "-0.21"] Pervasives.(=) (round_to_string ~digits:32 epsilon_float) "0.00000000000000022204460492503131" List.mem (round_to_string ~digits:42 infinity) ["inf"; "infinity"] List.mem (round_to_string ~digits:0 neg_infinity) ["-inf"; "-infinity"] List.for_all (fun digits -> Pervasives.(=) "nan" (String.sub (round_to_string ~digits nan) 0 3)) [0; 42] *) module Base_safe_float = struct include BaseFloat let if_safe x = match classify x with | FP_infinite -> raise Overflow | FP_nan -> raise NaN | _ -> () let check x = if_safe x; x let safe1 f x = check (f x) let safe2 f x y = check (f x y) let add = safe2 add let sub = safe2 sub let div = safe2 div let mul = safe2 mul let modulo = safe2 modulo let pred = safe1 pred let succ = safe1 succ let pow = safe2 pow end module Safe_float = struct include BatNumber.MakeNumeric(Base_safe_float) let safe1 = Base_safe_float.safe1 let safe2 = Base_safe_float.safe2 let if_safe = Base_safe_float.if_safe let exp = safe1 exp let log = safe1 log let log10 = safe1 log10 let cos = safe1 cos let sin = safe1 sin let tan = safe1 tan let acos = safe1 acos let asin = safe1 asin let atan = safe1 atan let atan2 = safe2 atan2 let cosh = safe1 cosh let sinh = safe1 sinh let tanh = safe1 tanh let ceil = safe1 ceil let floor = safe1 floor let modf x = let (_, z) as result = modf x in if_safe z; result let frexp x = let (f, _) as result = frexp x in if_safe f; result let ldexp = safe2 ldexp type bounded = t let min_num, max_num = neg_infinity, infinity type fpkind = Pervasives.fpclass = | FP_normal | FP_subnormal | FP_zero | FP_infinite | FP_nan external classify : float -> fpkind = "caml_classify_float" let is_nan = is_nan let infinity = Pervasives.infinity let neg_infinity = Pervasives.neg_infinity let nan = Pervasives.nan let epsilon = Pervasives.epsilon_float let pi = 4. *. atan 1. external of_float : float -> float = "%identity" external to_float : float -> float = "%identity" let print = print end (*$T succ is_nan (succ nan) succ infinity = infinity succ neg_infinity = neg_infinity succ (-3.) = -2. *) (*$T pred is_nan (pred nan) pred infinity = infinity pred neg_infinity = neg_infinity pred (-3.) = -4. *) (*$T root approx_equal (root 9. 2) 3. approx_equal (root 8. 3) 2. approx_equal (root 1. 20) 1. approx_equal (root (-8.) 3) (-2.) approx_equal (root 0. 6) 0. approx_equal (root (-0.) 6) 0. is_nan (root nan 4) root infinity 4 = infinity root neg_infinity 3 = neg_infinity try ignore (root (-8.) 4); false with Invalid_argument _ -> true try ignore (root neg_infinity 4); false with Invalid_argument _ -> true try ignore (root (9.) (-2)); false with Invalid_argument _ -> true *) (*$T is_nan not (is_nan infinity) not (is_nan neg_infinity) not (is_nan (-0.)) not (is_nan 12.) is_nan nan *) (*$T is_special is_special infinity is_special neg_infinity not (is_special (-0.)) not (is_special 12.) is_special nan *) (*$T is_finite List.for_all is_finite [1.0; 1e200; 1e-200; 0.0; -0.0; -1.0; -1e200; -1e-200] not (is_finite nan) not (is_finite infinity) not (is_finite neg_infinity) *) (*$T try ignore (Safe_float.add 0. infinity); false with BatNumber.Overflow -> true try ignore (Safe_float.add 0. neg_infinity); false with BatNumber.Overflow -> true try ignore (Safe_float.add 0. nan); false with BatNumber.NaN -> true ignore (Safe_float.add 0. (-0.)); true ignore (Safe_float.add 0. (12.)); true *) (*$T try ignore (Safe_float.modf nan); false with Number.NaN -> true try ignore (Safe_float.modf infinity); false with Number.Overflow -> true try ignore (Safe_float.modf neg_infinity); false with Number.Overflow -> true let (frac, int) = Safe_float.modf 3.234 in approx_equal frac 0.234 && approx_equal int 3. *) batteries-included-3.4.0/src/batFormat.mliv000066400000000000000000000756501415601150500206770ustar00rootroot00000000000000(* * BatFormat - Extended Format module * Copyright (C) 1996 Pierre Weis * 2009 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open BatIO (** Pretty printing. This module implements a pretty-printing facility to format text within ``pretty-printing boxes''. The pretty-printer breaks lines at specified break hints, and indents lines according to the box structure. For a gentle introduction to the basics of pretty-printing using [Format], read {{:http://caml.inria.fr/resources/doc/guides/format.html}http://caml.inria.fr/resources/doc/guides/format.html}. You may consider this module as providing an extension to the [printf] facility to provide automatic line breaking. The addition of pretty-printing annotations to your regular [printf] formats gives you fancy indentation and line breaks. Pretty-printing annotations are described below in the documentation of the function {!Format.fprintf}. You may also use the explicit box management and printing functions provided by this module. This style is more basic but more verbose than the [fprintf] concise formats. For instance, the sequence [open_box 0; print_string "x ="; print_space (); print_int 1; close_box (); print_newline ()] that prints [x = 1] within a pretty-printing box, can be abbreviated as [printf "@[%s@ %i@]@." "x =" 1], or even shorter [printf "@[x =@ %i@]@." 1]. Rule of thumb for casual users of this library: - use simple boxes (as obtained by [open_box 0]); - use simple break hints (as obtained by [print_cut ()] that outputs a simple break hint, or by [print_space ()] that outputs a space indicating a break hint); - once a box is opened, display its material with basic printing functions (e. g. [print_int] and [print_string]); - when the material for a box has been printed, call [close_box ()] to close the box; - at the end of your routine, flush the pretty-printer to display all the remaining material, e.g. evaluate [print_newline ()]. The behaviour of pretty-printing commands is unspecified if there is no opened pretty-printing box. Each box opened via one of the [open_] functions below must be closed using [close_box] for proper formatting. Otherwise, some of the material printed in the boxes may not be output, or may be formatted incorrectly. In case of interactive use, the system closes all opened boxes and flushes all pending text (as with the [print_newline] function) after each phrase. Each phrase is therefore executed in the initial state of the pretty-printer. Warning: the material output by the following functions is delayed in the pretty-printer queue in order to compute the proper line breaking. Hence, you should not mix calls to the printing functions of the basic I/O system with calls to the functions of this module: this could result in some strange output seemingly unrelated with the evaluation order of printing commands. @author Pierre Weis (Base module) @author David Teller *) (** {6 Boxes} *) val open_box : int -> unit (** [open_box d] opens a new pretty-printing box with offset [d]. This box is the general purpose pretty-printing box. Material in this box is displayed ``horizontal or vertical'': break hints inside the box may lead to a new line, if there is no more room on the line to print the remainder of the box, or if a new line may lead to a new indentation (demonstrating the indentation of the box). When a new line is printed in the box, [d] is added to the current indentation. *) val close_box : unit -> unit (** Closes the most recently opened pretty-printing box. *) (** {6 Formatting functions} *) val print_string : string -> unit (** [print_string str] prints [str] in the current box. *) val print_as : int -> string -> unit (** [print_as len str] prints [str] in the current box. The pretty-printer formats [str] as if it were of length [len]. *) val print_int : int -> unit (** Prints an integer in the current box. *) val print_float : float -> unit (** Prints a floating point number in the current box. *) val print_char : char -> unit (** Prints a character in the current box. *) val print_bool : bool -> unit (** Prints a boolean in the current box. *) (** {6 Break hints} *) val print_space : unit -> unit (** [print_space ()] is used to separate items (typically to print a space between two words). It indicates that the line may be split at this point. It either prints one space or splits the line. It is equivalent to [print_break 1 0]. *) val print_cut : unit -> unit (** [print_cut ()] is used to mark a good break position. It indicates that the line may be split at this point. It either prints nothing or splits the line. This allows line splitting at the current point, without printing spaces or adding indentation. It is equivalent to [print_break 0 0]. *) val print_break : int -> int -> unit (** Inserts a break hint in a pretty-printing box. [print_break nspaces offset] indicates that the line may be split (a newline character is printed) at this point, if the contents of the current box does not fit on the current line. If the line is split at that point, [offset] is added to the current indentation. If the line is not split, [nspaces] spaces are printed. *) val print_flush : unit -> unit (** Flushes the pretty printer: all opened boxes are closed, and all pending text is displayed. *) val print_newline : unit -> unit (** Equivalent to [print_flush] followed by a new line. *) val force_newline : unit -> unit (** Forces a newline in the current box. Not the normal way of pretty-printing, you should prefer break hints. *) val print_if_newline : unit -> unit (** Executes the next formatting command if the preceding line has just been split. Otherwise, ignore the next formatting command. *) (** {6 Margin} *) val set_margin : int -> unit (** [set_margin d] sets the value of the right margin to [d] (in characters): this value is used to detect line overflows that leads to split lines. Nothing happens if [d] is smaller than 2. If [d] is too large, the right margin is set to the maximum admissible value (which is greater than [10^10]). *) val get_margin : unit -> int (** Returns the position of the right margin. *) (** {6 Maximum indentation limit} *) val set_max_indent : int -> unit (** [set_max_indent d] sets the value of the maximum indentation limit to [d] (in characters): once this limit is reached, boxes are rejected to the left, if they do not fit on the current line. Nothing happens if [d] is smaller than 2. If [d] is too large, the limit is set to the maximum admissible value (which is greater than [10^10]). *) val get_max_indent : unit -> int (** Return the value of the maximum indentation limit (in characters). *) (** {6 Formatting depth: maximum number of boxes allowed before ellipsis} *) val set_max_boxes : int -> unit (** [set_max_boxes max] sets the maximum number of boxes simultaneously opened. Material inside boxes nested deeper is printed as an ellipsis (more precisely as the text returned by [get_ellipsis_text ()]). Nothing happens if [max] is smaller than 2. *) val get_max_boxes : unit -> int (** Returns the maximum number of boxes allowed before ellipsis. *) val over_max_boxes : unit -> bool (** Tests if the maximum number of boxes allowed have already been opened. *) (** {6 Advanced formatting} *) val open_hbox : unit -> unit (** [open_hbox ()] opens a new pretty-printing box. This box is ``horizontal'': the line is not split in this box (new lines may still occur inside boxes nested deeper). *) val open_vbox : int -> unit (** [open_vbox d] opens a new pretty-printing box with offset [d]. This box is ``vertical'': every break hint inside this box leads to a new line. When a new line is printed in the box, [d] is added to the current indentation. *) val open_hvbox : int -> unit (** [open_hvbox d] opens a new pretty-printing box with offset [d]. This box is ``horizontal-vertical'': it behaves as an ``horizontal'' box if it fits on a single line, otherwise it behaves as a ``vertical'' box. When a new line is printed in the box, [d] is added to the current indentation. *) val open_hovbox : int -> unit (** [open_hovbox d] opens a new pretty-printing box with offset [d]. This box is ``horizontal or vertical'': break hints inside this box may lead to a new line, if there is no more room on the line to print the remainder of the box. When a new line is printed in the box, [d] is added to the current indentation. *) (** {6 Tabulations} *) val open_tbox : unit -> unit (** Opens a tabulation box. *) val close_tbox : unit -> unit (** Closes the most recently opened tabulation box. *) val print_tbreak : int -> int -> unit (** Break hint in a tabulation box. [print_tbreak spaces offset] moves the insertion point to the next tabulation ([spaces] being added to this position). Nothing occurs if insertion point is already on a tabulation mark. If there is no next tabulation on the line, then a newline is printed and the insertion point moves to the first tabulation of the box. If a new line is printed, [offset] is added to the current indentation. *) val set_tab : unit -> unit (** Sets a tabulation mark at the current insertion point. *) val print_tab : unit -> unit (** [print_tab ()] is equivalent to [print_tbreak 0 0]. *) (** {6 Ellipsis} *) val set_ellipsis_text : string -> unit (** Set the text of the ellipsis printed when too many boxes are opened (a single dot, [.], by default). *) val get_ellipsis_text : unit -> string (** Return the text of the ellipsis. *) (** {6:tags Semantics Tags} *) type tag = string (** {i Semantics tags} (or simply {e tags}) are used to decorate printed entities for user's defined purposes, e.g. setting font and giving size indications for a display device, or marking delimitation of semantics entities (e.g. HTML or TeX elements or terminal escape sequences). By default, those tags do not influence line breaking calculation: the tag ``markers'' are not considered as part of the printing material that drives line breaking (in other words, the length of those strings is considered as zero for line breaking). Thus, tag handling is in some sense transparent to pretty-printing and does not interfere with usual pretty-printing. Hence, a single pretty printing routine can output both simple ``verbatim'' material or richer decorated output depending on the treatment of tags. By default, tags are not active, hence the output is not decorated with tag information. Once [set_tags] is set to [true], the pretty printer engine honours tags and decorates the output accordingly. When a tag has been opened (or closed), it is both and successively ``printed'' and ``marked''. Printing a tag means calling a formatter specific function with the name of the tag as argument: that ``tag printing'' function can then print any regular material to the formatter (so that this material is enqueued as usual in the formatter queue for further line-breaking computation). Marking a tag means to output an arbitrary string (the ``tag marker''), directly into the output device of the formatter. Hence, the formatter specific ``tag marking'' function must return the tag marker string associated to its tag argument. Being flushed directly into the output device of the formatter, tag marker strings are not considered as part of the printing material that drives line breaking (in other words, the length of the strings corresponding to tag markers is considered as zero for line breaking). In addition, advanced users may take advantage of the specificity of tag markers to be precisely output when the pretty printer has already decided where to break the lines, and precisely when the queue is flushed into the output device. In the spirit of HTML tags, the default tag marking functions output tags enclosed in "<" and ">": hence, the opening marker of tag [t] is [""] and the closing marker [""]. Default tag printing functions just do nothing. Tag marking and tag printing functions are user definable and can be set by calling [set_formatter_tag_functions]. *) val open_tag : tag -> unit (** [open_tag t] opens the tag named [t]; the [print_open_tag] function of the formatter is called with [t] as argument; the tag marker [mark_open_tag t] will be flushed into the output device of the formatter. *) val close_tag : unit -> unit (** [close_tag ()] closes the most recently opened tag [t]. In addition, the [print_close_tag] function of the formatter is called with [t] as argument. The marker [mark_close_tag t] will be flushed into the output device of the formatter. *) val set_tags : bool -> unit (** [set_tags b] turns on or off the treatment of tags (default is off). *) val set_print_tags : bool -> unit (** [set_print_tags b] turns on or off the printing of tags. *) val set_mark_tags : bool -> unit (** [set_mark_tags b] turns on or off the output of tag markers. *) val get_print_tags : unit -> bool val get_mark_tags : unit -> bool (** Return the current status of tags printing and tags marking. *) (** {6 Redirecting the standard formatter output} *) val set_formatter_output : 'a output -> unit (** Sets the output of the formatter to the given argument *) val set_formatter_output_functions : (string -> int -> int -> unit) -> (unit -> unit) -> unit (** [set_formatter_output_functions out flush] redirects the relevant pretty-printer output functions to the functions [out] and [flush]. The [out] function performs the pretty-printer string output. It is called with a string [s], a start position [p], and a number of characters [n]; it is supposed to output characters [p] to [p + n - 1] of [s]. The [flush] function is called whenever the pretty-printer is flushed (via conversion [%!], pretty-printing indications [@?] or [@.], or using low level function [print_flush] or [print_newline]). *) val get_formatter_output_functions : unit -> (string -> int -> int -> unit) * (unit -> unit) (** Return the current output functions of the pretty-printer. *) (** {6:meaning Changing the meaning of standard formatter pretty printing} *) (** The [Format] module is versatile enough to let you completely redefine the meaning of pretty printing: you may provide your own functions to define how to handle indentation, line breaking, and even printing of all the characters that have to be printed! *) val set_all_formatter_output_functions : out:(string -> int -> int -> unit) -> flush:(unit -> unit) -> newline:(unit -> unit) -> spaces:(int -> unit) -> unit (** [set_all_formatter_output_functions out flush outnewline outspace] redirects the pretty-printer output to the functions [out] and [flush] as described in [set_formatter_output_functions]. In addition, the pretty-printer function that outputs a newline is set to the function [outnewline] and the function that outputs indentation spaces is set to the function [outspace]. This way, you can change the meaning of indentation (which can be something else than just printing space characters) and the meaning of new lines opening (which can be connected to any other action needed by the application at hand). The two functions [outspace] and [outnewline] are normally connected to [out] and [flush]: respective default values for [outspace] and [outnewline] are [out (String.make n ' ') 0 n] and [out "\n" 0 1]. *) val get_all_formatter_output_functions : unit -> (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) * (int -> unit) (** Return the current output functions of the pretty-printer, including line breaking and indentation functions. Useful to record the current setting and restore it afterwards. *) (** {6:tags Changing the meaning of printing semantics tags} *) type formatter_tag_functions = { mark_open_tag : tag -> string; mark_close_tag : tag -> string; print_open_tag : tag -> unit; print_close_tag : tag -> unit; } (** The tag handling functions specific to a formatter: [mark] versions are the ``tag marking'' functions that associate a string marker to a tag in order for the pretty-printing engine to flush those markers as 0 length tokens in the output device of the formatter. [print] versions are the ``tag printing'' functions that can perform regular printing when a tag is closed or opened. *) val set_formatter_tag_functions : formatter_tag_functions -> unit (** [set_formatter_tag_functions tag_funs] changes the meaning of opening and closing tags to use the functions in [tag_funs]. When opening a tag name [t], the string [t] is passed to the opening tag marking function (the [mark_open_tag] field of the record [tag_funs]), that must return the opening tag marker for that name. When the next call to [close_tag ()] happens, the tag name [t] is sent back to the closing tag marking function (the [mark_close_tag] field of record [tag_funs]), that must return a closing tag marker for that name. The [print_] field of the record contains the functions that are called at tag opening and tag closing time, to output regular material in the pretty-printer queue. *) val get_formatter_tag_functions : unit -> formatter_tag_functions (** Return the current tag functions of the pretty-printer. *) (** {6 Multiple formatted output} *) type formatter=Format.formatter (** Abstract data corresponding to a pretty-printer (also called a formatter) and all its machinery. Defining new pretty-printers permits unrelated output of material in parallel on several output channels. All the parameters of a pretty-printer are local to this pretty-printer: margin, maximum indentation limit, maximum number of boxes simultaneously opened, ellipsis, and so on, are specific to each pretty-printer and may be fixed independently. Given a [Pervasives.out_channel] output channel [oc], a new formatter writing to that channel is simply obtained by calling [formatter_of_out_channel oc]. Alternatively, the [make_formatter] function allocates a new formatter with explicit output and flushing functions (convenient to output material to strings for instance). *) val std_formatter : formatter (** The standard formatter used by the formatting functions above. It is defined as [formatter_of_out_channel stdout]. *) val err_formatter : formatter (** A formatter to use with formatting functions below for output to standard error. It is defined as [formatter_of_out_channel stderr]. *) val formatter_of_output : _ output -> formatter (** [formatter_of_output out] returns a new formatter that writes to the corresponding output [out]. *) val formatter_of_buffer : Buffer.t -> formatter (** [formatter_of_buffer b] returns a new formatter writing to buffer [b]. As usual, the formatter has to be flushed at the end of pretty printing, using [pp_print_flush] or [pp_print_newline], to display all the pending material. *) val stdbuf : Buffer.t (** The string buffer in which [str_formatter] writes. *) val str_formatter : formatter (** A formatter to use with formatting functions below for output to the [stdbuf] string buffer. [str_formatter] is defined as [formatter_of_buffer stdbuf]. *) val flush_str_formatter : unit -> string (** Returns the material printed with [str_formatter], flushes the formatter and resets the corresponding buffer. *) val make_formatter : (string -> int -> int -> unit) -> (unit -> unit) -> formatter (** [make_formatter out flush] returns a new formatter that writes according to the output function [out], and the flushing function [flush]. For instance, a formatter to the [Pervasives.out_channel] [oc] is returned by [make_formatter (Pervasives.output oc) (fun () -> Pervasives.flush oc)]. *) (** {6 Basic functions to use with formatters} *) val pp_open_hbox : formatter -> unit -> unit val pp_open_vbox : formatter -> int -> unit val pp_open_hvbox : formatter -> int -> unit val pp_open_hovbox : formatter -> int -> unit val pp_open_box : formatter -> int -> unit val pp_close_box : formatter -> unit -> unit val pp_open_tag : formatter -> string -> unit val pp_close_tag : formatter -> unit -> unit val pp_print_string : formatter -> string -> unit val pp_print_as : formatter -> int -> string -> unit val pp_print_int : formatter -> int -> unit val pp_print_float : formatter -> float -> unit val pp_print_char : formatter -> char -> unit val pp_print_bool : formatter -> bool -> unit val pp_print_break : formatter -> int -> int -> unit val pp_print_cut : formatter -> unit -> unit val pp_print_space : formatter -> unit -> unit val pp_force_newline : formatter -> unit -> unit val pp_print_flush : formatter -> unit -> unit val pp_print_newline : formatter -> unit -> unit val pp_print_if_newline : formatter -> unit -> unit val pp_open_tbox : formatter -> unit -> unit val pp_close_tbox : formatter -> unit -> unit val pp_print_tbreak : formatter -> int -> int -> unit val pp_set_tab : formatter -> unit -> unit val pp_print_tab : formatter -> unit -> unit val pp_set_tags : formatter -> bool -> unit val pp_set_print_tags : formatter -> bool -> unit val pp_set_mark_tags : formatter -> bool -> unit val pp_get_print_tags : formatter -> unit -> bool val pp_get_mark_tags : formatter -> unit -> bool val pp_set_margin : formatter -> int -> unit val pp_get_margin : formatter -> unit -> int val pp_set_max_indent : formatter -> int -> unit val pp_get_max_indent : formatter -> unit -> int val pp_set_max_boxes : formatter -> int -> unit val pp_get_max_boxes : formatter -> unit -> int val pp_over_max_boxes : formatter -> unit -> bool val pp_set_ellipsis_text : formatter -> string -> unit val pp_get_ellipsis_text : formatter -> unit -> string val pp_set_formatter_out_channel : formatter -> Pervasives.out_channel -> unit val pp_set_formatter_output_functions : formatter -> (string -> int -> int -> unit) -> (unit -> unit) -> unit val pp_get_formatter_output_functions : formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit) val pp_set_all_formatter_output_functions : formatter -> out:(string -> int -> int -> unit) -> flush:(unit -> unit) -> newline:(unit -> unit) -> spaces:(int -> unit) -> unit val pp_get_all_formatter_output_functions : formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) * (int -> unit) val pp_set_formatter_tag_functions : formatter -> formatter_tag_functions -> unit val pp_get_formatter_tag_functions : formatter -> unit -> formatter_tag_functions (** These functions are the basic ones: usual functions operating on the standard formatter are defined via partial evaluation of these primitives. For instance, [print_string] is equal to [pp_print_string std_formatter]. *) val pp_print_list: ?pp_sep:(formatter -> unit -> unit) -> (formatter -> 'a -> unit) -> (formatter -> 'a list -> unit) (** [pp_print_list ?pp_sep pp_v ppf l] prints the list [l]. [pp_v] is used on the elements of [l] and each element is separated by a call to [pp_sep] (defaults to {!pp_print_cut}). Does nothing on empty lists. @since 4.02.0 *) val pp_print_text : formatter -> string -> unit (** [pp_print_text ppf s] prints [s] with spaces and newlines respectively printed with {!pp_print_space} and {!pp_force_newline}. @since 4.02.0 *) (** {6 [printf] like functions for pretty-printing.} *) val fprintf : formatter -> ('a, formatter, unit) format -> 'a (** [fprintf ff fmt arg1 ... argN] formats the arguments [arg1] to [argN] according to the format string [fmt], and outputs the resulting string on the formatter [ff]. The format [fmt] is a character string which contains three types of objects: plain characters and conversion specifications as specified in the [Printf] module, and pretty-printing indications specific to the [Format] module. The pretty-printing indication characters are introduced by a [@] character, and their meanings are: - [@\[]: open a pretty-printing box. The type and offset of the box may be optionally specified with the following syntax: the [<] character, followed by an optional box type indication, then an optional integer offset, and the closing [>] character. Box type is one of [h], [v], [hv], [b], or [hov], which stand respectively for an horizontal box, a vertical box, an ``horizontal-vertical'' box, or an ``horizontal or vertical'' box ([b] standing for an ``horizontal or vertical'' box demonstrating indentation and [hov] standing for a regular``horizontal or vertical'' box). For instance, [@\[] opens an ``horizontal or vertical'' box with indentation 2 as obtained with [open_hovbox 2]. For more details about boxes, see the various box opening functions [open_*box]. - [@\]]: close the most recently opened pretty-printing box. - [@,]: output a good break as with [print_cut ()]. - [@ ]: output a space, as with [print_space ()]. - [@\n]: force a newline, as with [force_newline ()]. - [@;]: output a good break as with [print_break]. The [nspaces] and [offset] parameters of the break may be optionally specified with the following syntax: the [<] character, followed by an integer [nspaces] value, then an integer [offset], and a closing [>] character. If no parameters are provided, the good break defaults to a space. - [@?]: flush the pretty printer as with [print_flush ()]. This is equivalent to the conversion [%!]. - [@.]: flush the pretty printer and output a new line, as with [print_newline ()]. - [@]: print the following item as if it were of length [n]. Hence, [printf "@<0>%s" arg] is equivalent to [print_as 0 arg]. If [@] is not followed by a conversion specification, then the following character of the format is printed as if it were of length [n]. - [@\{]: open a tag. The name of the tag may be optionally specified with the following syntax: the [<] character, followed by an optional string specification, and the closing [>] character. The string specification is any character string that does not contain the closing character ['>']. If omitted, the tag name defaults to the empty string. For more details about tags, see the functions [open_tag] and [close_tag]. - [@\}]: close the most recently opened tag. - [@@]: print a plain [@] character. Example: [printf "@[%s@ %d@]@." "x =" 1] is equivalent to [open_box (); print_string "x ="; print_space (); print_int 1; close_box (); print_newline ()]. It prints [x = 1] within a pretty-printing box. *) val printf : ('a, formatter, unit) format -> 'a (** Same as [fprintf] above, but output on [std_formatter]. *) val eprintf : ('a, formatter, unit) format -> 'a (** Same as [fprintf] above, but output on [err_formatter]. *) val sprintf : ('a, unit, string) format -> 'a (** Same as [printf] above, but instead of printing on a formatter, returns a string containing the result of formatting the arguments. Note that the pretty-printer queue is flushed at the end of {e each call} to [sprintf]. In case of multiple and related calls to [sprintf] to output material on a single string, you should consider using [fprintf] with the predefined formatter [str_formatter] and call [flush_str_formatter ()] to get the final result. Alternatively, you can use [Format.fprintf] with a formatter writing to a buffer of your own: flushing the formatter and the buffer at the end of pretty-printing returns the desired string. *) ##V>=4.01##val asprintf : ('a, formatter, unit, string) format4 -> 'a ##V>=4.01##(** Same as [printf] above, but instead of printing on a formatter, returns a ##V>=4.01## string containing the result of formatting the arguments. The type of ##V>=4.01## asprintf is general enough to interact nicely with [%a] conversions. ##V>=4.01## @since 4.01.0 ##V>=4.01##*) val ifprintf : formatter -> ('a, formatter, unit) format -> 'a (** Same as [fprintf] above, but does not print anything. Useful to ignore some material when conditionally printing. @since 3.10.0 *) (** Formatted output functions with continuations. *) val kfprintf : (formatter -> 'a) -> formatter -> ('b, formatter, unit, 'a) format4 -> 'b (** Same as [fprintf] above, but instead of returning immediately, passes the formatter to its first argument at the end of printing. *) val ikfprintf : (formatter -> 'a) -> formatter -> ('b, formatter, unit, 'a) format4 -> 'b (** Same as [kfprintf] above, but does not print anything. Useful to ignore some material when conditionally printing. @since 3.12.0 *) val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b (** Same as [sprintf] above, but instead of returning the string, passes it to the first argument. *) (** {6 Deprecated} *) val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a (** A deprecated and error prone function. Do not use it. If you need to print to some buffer [b], you must first define a formatter writing to [b], using [let to_b = formatter_of_buffer b]; then use regular calls to [Format.fprintf] on formatter [to_b]. *) val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b (** A deprecated synonym for [ksprintf]. *) (** {6 Basic functions to use with formatters} *) val pp_set_formatter_output : formatter -> _ output -> unit (** {6 Deprecated}*) val set_formatter_out_channel : _ output -> unit (** Redirect the pretty-printer output to the given channel. (All the output functions of the standard formatter are set to the default output functions printing to the given channel.) *) val formatter_of_out_channel : _ output -> formatter (** [formatter_of_out_channel oc] returns a new formatter that writes to the corresponding channel [oc]. *) val pp_set_formatter_out_channel : formatter -> _ output -> unit batteries-included-3.4.0/src/batFormat.mlv000066400000000000000000000100301415601150500205030ustar00rootroot00000000000000(* * BatFormat - Extended Format module * Copyright (C) 1996 Pierre Weis * 2009 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open BatIO include Format (* internal functions *) let output_of out = fun s i o -> ignore (really_output_substring out s i o) let flush_of out = BatInnerIO.get_flush out let newline_of out = fun () -> BatInnerIO.write out '\n' let spaces_of out = (* Default function to output spaces. Copied from base format.ml*) let blank_line = Bytes.make 80 ' ' in let rec display_blanks n = if n > 0 then if n <= 80 then ignore (really_output out blank_line 0 n) else begin ignore (really_output out blank_line 0 80); display_blanks (n - 80) end in display_blanks (**{6 New functions}*) let formatter_of_output out = let output = output_of out and flush = flush_of out in let f = make_formatter output flush in BatInnerIO.on_close_out out (fun _ -> pp_print_flush f ()); (*Note: we can't just use [flush] as [f] contains a cache.*) pp_set_all_formatter_output_functions f ~out:output ~flush ~newline:(newline_of out) ~spaces:(spaces_of out); f let set_formatter_output out = BatInnerIO.on_close_out out (fun _ -> pp_print_flush Format.std_formatter ()); set_all_formatter_output_functions ~out:(output_of out) ~flush:(flush_of out) ~newline:(newline_of out) ~spaces:(spaces_of out) let pp_set_formatter_output f out = BatInnerIO.on_close_out out (fun _ -> pp_print_flush f ()); pp_set_all_formatter_output_functions f ~out:(output_of out) ~flush:(flush_of out) ~newline:(newline_of out) ~spaces:(spaces_of out) (**{6 Old values, new semantics}*) let formatter_of_out_channel = formatter_of_output let set_formatter_out_channel = set_formatter_output let pp_set_formatter_out_channel = pp_set_formatter_output let std_formatter = formatter_of_output BatIO.stdout let err_formatter = formatter_of_output BatIO.stderr (* Backward compatibility *) ##V<4.02##(* To format a list *) ##V<4.02##let rec pp_print_list ?(pp_sep = pp_print_cut) pp_v ppf = function ##V<4.02## | [] -> () ##V<4.02## | [v] -> pp_v ppf v ##V<4.02## | v :: vs -> ##V<4.02## pp_v ppf v; ##V<4.02## pp_sep ppf (); ##V<4.02## pp_print_list ~pp_sep pp_v ppf vs ##V<4.02## ##V<4.02##(* To format free-flowing text *) ##V<4.02##let pp_print_text ppf s = ##V<4.02## let len = String.length s in ##V<4.02## let left = ref 0 in ##V<4.02## let right = ref 0 in ##V<4.02## let flush () = ##V<4.02## pp_print_string ppf (String.sub s !left (!right - !left)); ##V<4.02## incr right; left := !right; ##V<4.02## in ##V<4.02## while (!right <> len) do ##V<4.02## match s.[!right] with ##V<4.02## | '\n' -> ##V<4.02## flush (); ##V<4.02## pp_force_newline ppf () ##V<4.02## | ' ' -> ##V<4.02## flush (); pp_print_space ppf () ##V<4.02## (* there is no specific support for '\t' ##V<4.02## as it is unclear what a right semantics would be *) ##V<4.02## | _ -> incr right ##V<4.02## done; ##V<4.02## if !left <> len then flush () (**{6 Initialization}*) let () = set_formatter_output BatIO.stdout; pp_set_formatter_output Format.std_formatter stdout; pp_set_formatter_output Format.err_formatter stderr batteries-included-3.4.0/src/batGc.ml000066400000000000000000000042061415601150500174260ustar00rootroot00000000000000(* * BatGC - Extended GC operations * Copyright (C) 1996 Damien Doligez * 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open BatPrintf include Gc let print_stat c = (* copied from original module *) let st = stat () in fprintf c "minor_collections: %d\n" st.minor_collections; fprintf c "major_collections: %d\n" st.major_collections; fprintf c "compactions: %d\n" st.compactions; fprintf c "\n"; let l1 = String.length (sprintf "%.0f" st.minor_words) in fprintf c "minor_words: %*.0f\n" l1 st.minor_words; fprintf c "promoted_words: %*.0f\n" l1 st.promoted_words; fprintf c "major_words: %*.0f\n" l1 st.major_words; fprintf c "\n"; let l2 = String.length (sprintf "%d" st.top_heap_words) in fprintf c "top_heap_words: %*d\n" l2 st.top_heap_words; fprintf c "heap_words: %*d\n" l2 st.heap_words; fprintf c "live_words: %*d\n" l2 st.live_words; fprintf c "free_words: %*d\n" l2 st.free_words; fprintf c "largest_free: %*d\n" l2 st.largest_free; fprintf c "fragments: %*d\n" l2 st.fragments; fprintf c "\n"; fprintf c "live_blocks: %d\n" st.live_blocks; fprintf c "free_blocks: %d\n" st.free_blocks; fprintf c "heap_chunks: %d\n" st.heap_chunks (*$T print_stat (IO.output_string () |> tap print_stat |> IO.close_out |> String.nsplit ~by:"\n" |> List.length) = 19 *) batteries-included-3.4.0/src/batGc.mliv000066400000000000000000000572711415601150500177770ustar00rootroot00000000000000(* * BatGC - Extended GC operations * Copyright (C) 1996 Damien Doligez * 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Memory management control and statistics; finalised values. This module extends Stdlib's {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html}Gc} module, go there for documentation on the rest of the functions and types. @author Damien Doligez (Base module) @author David Teller *) type stat = Gc.stat = { minor_words : float; (** Number of words allocated in the minor heap since the program was started. This number is accurate in byte-code programs, but only an approximation in programs compiled to native code. *) promoted_words : float; (** Number of words allocated in the minor heap that survived a minor collection and were moved to the major heap since the program was started. *) major_words : float; (** Number of words allocated in the major heap, including the promoted words, since the program was started. *) minor_collections : int; (** Number of minor collections since the program was started. *) major_collections : int; (** Number of major collection cycles completed since the program was started. *) heap_words : int; (** Total size of the major heap, in words. *) heap_chunks : int; (** Number of contiguous pieces of memory that make up the major heap. *) live_words : int; (** Number of words of live data in the major heap, including the header words. *) live_blocks : int; (** Number of live blocks in the major heap. *) free_words : int; (** Number of words in the free list. *) free_blocks : int; (** Number of blocks in the free list. *) largest_free : int; (** Size (in words) of the largest block in the free list. *) fragments : int; (** Number of wasted words due to fragmentation. These are 1-words free blocks placed between two live blocks. They are not available for allocation. *) compactions : int; (** Number of heap compactions since the program was started. *) top_heap_words : int; (** Maximum size reached by the major heap, in words. *) stack_size: int; (** Current size of the stack, in words. @since 3.12.0 *) ##V>=4.12## forced_major_collections: int; ##V>=4.12## (** Number of forced full major collections completed since the program ##V>=4.12## was started. @since 4.12.0 *) } (** The memory management counters are returned in a [stat] record. The total amount of memory allocated by the program since it was started is (in words) [minor_words + major_words - promoted_words]. Multiply by the word size (4 on a 32-bit machine, 8 on a 64-bit machine) to get the number of bytes. *) type control = Gc.control = { mutable minor_heap_size : int; (** The size (in words) of the minor heap. Changing this parameter will trigger a minor collection. Default: 32k. *) mutable major_heap_increment : int; (** The minimum number of words to add to the major heap when increasing it. Default: 124k. *) mutable space_overhead : int; (** The major GC speed is computed from this parameter. This is the memory that will be "wasted" because the GC does not immediately collect unreachable blocks. It is expressed as a percentage of the memory used for live data. The GC will work more (use more CPU time and collect blocks more eagerly) if [space_overhead] is smaller. Default: 80. *) mutable verbose : int; (** This value controls the GC messages on standard error output. It is a sum of some of the following flags, to print messages on the corresponding events: - [0x001] Start of major GC cycle. - [0x002] Minor collection and major GC slice. - [0x004] Growing and shrinking of the heap. - [0x008] Resizing of stacks and memory manager tables. - [0x010] Heap compaction. - [0x020] Change of GC parameters. - [0x040] Computation of major GC slice size. - [0x080] Calling of finalisation functions. - [0x100] Bytecode executable search at start-up. - [0x200] Computation of compaction triggering condition. Default: 0. *) mutable max_overhead : int; (** Heap compaction is triggered when the estimated amount of "wasted" memory is more than [max_overhead] percent of the amount of live data. If [max_overhead] is set to 0, heap compaction is triggered at the end of each major GC cycle (this setting is intended for testing purposes only). If [max_overhead >= 1000000], compaction is never triggered. Default: 500. *) mutable stack_limit : int; (** The maximum size of the stack (in words). This is only relevant to the byte-code runtime, as the native code runtime uses the operating system's stack. Default: 256k. *) mutable allocation_policy : int; (** The policy used for allocating in the heap. Possible values are 0 and 1. 0 is the next-fit policy, which is quite fast but can result in fragmentation. 1 is the first-fit policy, which can be slower in some cases but can be better for programs with fragmentation problems. Default: 0. @since 3.11.0 *) ##V>=4.3## window_size : int; ##V>=4.3## (** The size of the window used by the major GC for smoothing ##V>=4.3## out variations in its workload. This is an integer between ##V>=4.3## 1 and 50. ##V>=4.3## Default: 1. @since 2.5.0 and OCaml 4.03.0 *) ##V>=4.3## ##V>=4.8## custom_major_ratio : int; ##V>=4.8## (** Target ratio of floating garbage to major heap size for ##V>=4.8## out-of-heap memory held by custom values located in the major ##V>=4.8## heap. The GC speed is adjusted to try to use this much memory ##V>=4.8## for dead values that are not yet collected. Expressed as a ##V>=4.8## percentage of major heap size. The default value keeps the ##V>=4.8## out-of-heap floating garbage about the same size as the ##V>=4.8## in-heap overhead. ##V>=4.8## Note: this only applies to values allocated with ##V>=4.8## [caml_alloc_custom_mem] (e.g. bigarrays). ##V>=4.8## Default: 44. ##V>=4.8## @since 2.10.0 and OCaml 4.08.0 *) ##V>=4.8## custom_minor_ratio : int; ##V>=4.8## (** Bound on floating garbage for out-of-heap memory held by ##V>=4.8## custom values in the minor heap. A minor GC is triggered when ##V>=4.8## this much memory is held by custom values located in the minor ##V>=4.8## heap. Expressed as a percentage of minor heap size. ##V>=4.8## Note: this only applies to values allocated with ##V>=4.8## [caml_alloc_custom_mem] (e.g. bigarrays). ##V>=4.8## Default: 100. ##V>=4.8## @since 2.10.0 and OCaml 4.08.0 *) ##V>=4.8## custom_minor_max_size : int; ##V>=4.8## (** Maximum amount of out-of-heap memory for each custom value ##V>=4.8## allocated in the minor heap. When a custom value is allocated ##V>=4.8## on the minor heap and holds more than this many bytes, only ##V>=4.8## this value is counted against [custom_minor_ratio] and the ##V>=4.8## rest is directly counted against [custom_major_ratio]. ##V>=4.8## Note: this only applies to values allocated with ##V>=4.8## [caml_alloc_custom_mem] (e.g. bigarrays). ##V>=4.8## Default: 8192 bytes. ##V>=4.8## @since 2.10.0 and OCaml 4.08.0 *) ##V>=4.8## } (** The GC parameters are given as a [control] record. Note that these parameters can also be initialised by setting the OCAMLRUNPARAM environment variable. See the documentation of ocamlrun. *) external stat : unit -> stat = "caml_gc_stat" (** Return the current values of the memory management counters in a [stat] record. This function examines every heap block to get the statistics. *) external quick_stat : unit -> stat = "caml_gc_quick_stat" (** Same as [stat] except that [live_words], [live_blocks], [free_words], [free_blocks], [largest_free], and [fragments] are set to 0. This function is much faster than [stat] because it does not need to go through the heap. *) external counters : unit -> float * float * float = "caml_gc_counters" (** Return [(minor_words, promoted_words, major_words)]. This function is as fast at [quick_stat]. *) ##V>=4.4##external minor_words : unit -> (float [@unboxed]) ##V>=4.4## = "caml_gc_minor_words" "caml_gc_minor_words_unboxed" ##V=4.4## [@@noalloc] ##V>=4.4##(** Number of words allocated in the minor heap since the program was ##V>=4.4## started. This number is accurate in byte-code programs, but only an ##V>=4.4## approximation in programs compiled to native code. ##V>=4.4## ##V>=4.4## In native code this function does not allocate. ##V>=4.4## ##V>=4.4## @since 2.5.3 and OCaml 4.04 *) external get : unit -> control = "caml_gc_get" (** Return the current values of the GC parameters in a [control] record. *) external set : control -> unit = "caml_gc_set" (** [set r] changes the GC parameters according to the [control] record [r]. The normal usage is: [Gc.set { (Gc.get()) with Gc.verbose = 0x00d }] *) external minor : unit -> unit = "caml_gc_minor" (** Trigger a minor collection. *) external major_slice : int -> int = "caml_gc_major_slice" (** Do a minor collection and a slice of major collection. The argument is the size of the slice, 0 to use the automatically-computed slice size. In all cases, the result is the computed slice size. *) external major : unit -> unit = "caml_gc_major" (** Do a minor collection and finish the current major collection cycle. *) external full_major : unit -> unit = "caml_gc_full_major" (** Do a minor collection, finish the current major collection cycle, and perform a complete new cycle. This will collect all currently unreachable blocks. *) external compact : unit -> unit = "caml_gc_compaction" (** Perform a full major collection and compact the heap. Note that heap compaction is a lengthy operation. *) val print_stat : _ BatInnerIO.output -> unit (** Print the current values of the memory management counters (in human-readable form) into the channel argument. *) val allocated_bytes : unit -> float (** Return the total number of bytes allocated since the program was started. It is returned as a [float] to avoid overflow problems with [int] on 32-bit machines. *) ##V>=4.3####V int = "caml_get_minor_free" ##V=4.3## [@@noalloc] ##V=4.4## [@@noalloc] ##V>=4.3####V=4.3####V=4.3####V int = "caml_get_major_bucket" [@@noalloc] ##V>=4.3####V=4.3####V=4.3####V=4.3####V=4.3####V=4.3####V int = "caml_get_major_credit" [@@noalloc] ##V>=4.3####V=4.3####V=4.3####V=4.3####V=4.3####V int = "caml_gc_huge_fallback_count" ##V>=4.3####V=4.3####V=4.3####V unit) -> 'a -> unit (** [finalise f v] registers [f] as a finalisation function for [v]. [v] must be heap-allocated. [f] will be called with [v] as argument at some point between the first time [v] becomes unreachable and the time [v] is collected by the GC. Several functions can be registered for the same value, or even several instances of the same function. Each instance will be called once (or never, if the program terminates before [v] becomes unreachable). The GC will call the finalisation functions in the order of deallocation. When several values become unreachable at the same time (i.e. during the same GC cycle), the finalisation functions will be called in the reverse order of the corresponding calls to [finalise]. If [finalise] is called in the same order as the values are allocated, that means each value is finalised before the values it depends upon. Of course, this becomes false if additional dependencies are introduced by assignments. Anything reachable from the closure of finalisation functions is considered reachable, so the following code will not work as expected: - [ let v = ... in Gc.finalise (fun x -> ...) v ] Instead you should write: - [ let f = fun x -> ... ;; let v = ... in Gc.finalise f v ] The [f] function can use all features of OCaml, including assignments that make the value reachable again. It can also loop forever (in this case, the other finalisation functions will not be called during the execution of f, unless it calls [finalise_release]). It can call [finalise] on [v] or other values to register other functions or even itself. It can raise an exception; in this case the exception will interrupt whatever the program was doing when the function was called. [finalise] will raise [Invalid_argument] if [v] is not heap-allocated. Some examples of values that are not heap-allocated are integers, constant constructors, booleans, the empty array, the empty list, the unit value. The exact list of what is heap-allocated or not is implementation-dependent. Some constant values can be heap-allocated but never deallocated during the lifetime of the program, for example a list of integer constants; this is also implementation-dependent. You should also be aware that compiler optimisations may duplicate some immutable values, for example floating-point numbers when stored into arrays, so they can be finalised and collected while another copy is still in use by the program. The results of calling {!String.make}, {!String.create}, {!Array.make}, and {!Pervasives.ref} are guaranteed to be heap-allocated and non-constant except when the length argument is [0]. *) ##V>=4.4##val finalise_last : (unit -> unit) -> 'a -> unit ##V>=4.4##(** same as {!finalise} except the value is not given as argument. So ##V>=4.4## you can't use the given value for the computation of the ##V>=4.4## finalisation function. The benefit is that the function is called ##V>=4.4## after the value is unreachable for the last time instead of the ##V>=4.4## first time. So contrary to {!finalise} the value will never be ##V>=4.4## reachable again or used again. In particular every weak pointers ##V>=4.4## and ephemerons that contained this value as key or data is unset ##V>=4.4## before running the finalisation function. Moreover the ##V>=4.4## finalisation function attached with `GC.finalise` are always ##V>=4.4## called before the finalisation function attached with `GC.finalise_last`. ##V>=4.4## ##V>=4.4## @since 2.11.0 and OCaml 4.04 ##V>=4.4##*) val finalise_release : unit -> unit (** A finalisation function may call [finalise_release] to tell the GC that it can launch the next finalisation function without waiting for the current one to return. *) type alarm = Gc.alarm (** An alarm is a piece of data that calls a user function at the end of each major GC cycle. The following functions are provided to create and delete alarms. *) val create_alarm : (unit -> unit) -> alarm (** [create_alarm f] will arrange for [f] to be called at the end of each major GC cycle, starting with the current cycle or the next one. A value of type [alarm] is returned that you can use to call [delete_alarm]. *) val delete_alarm : alarm -> unit (** [delete_alarm a] will stop the calls to the function associated to [a]. Calling [delete_alarm a] again has no effect. *) ##V>=4.11##external eventlog_pause : unit -> unit = "caml_eventlog_pause" ##V>=4.11##(** [eventlog_pause ()] will pause the collection of traces in the ##V>=4.11## runtime. ##V>=4.11## Traces are collected if the program is linked to the instrumented runtime ##V>=4.11## and started with the environment variable OCAML_EVENTLOG_ENABLED. ##V>=4.11## Events are flushed to disk after pausing, and no new events will be ##V>=4.11## recorded until [eventlog_resume] is called. *) ##V>=4.11## ##V>=4.11##external eventlog_resume : unit -> unit = "caml_eventlog_resume" ##V>=4.11##(** [eventlog_resume ()] will resume the collection of traces in the ##V>=4.11## runtime. ##V>=4.11## Traces are collected if the program is linked to the instrumented runtime ##V>=4.11## and started with the environment variable OCAML_EVENTLOG_ENABLED. ##V>=4.11## This call can be used after calling [eventlog_pause], or if the program ##V>=4.11## was started with OCAML_EVENTLOG_ENABLED=p. (which pauses the collection of ##V>=4.11## traces before the first event.) *) ##V>=4.11## ##V>=4.11## ##V>=4.11##(** [Memprof] is a sampling engine for allocated memory words. Every ##V>=4.11## allocated word has a probability of being sampled equal to a ##V>=4.11## configurable sampling rate. Once a block is sampled, it becomes ##V>=4.11## tracked. A tracked block triggers a user-defined callback as soon ##V>=4.11## as it is allocated, promoted or deallocated. ##V>=4.11## ##V>=4.11## Since blocks are composed of several words, a block can potentially ##V>=4.11## be sampled several times. If a block is sampled several times, then ##V>=4.11## each of the callback is called once for each event of this block: ##V>=4.11## the multiplicity is given in the [n_samples] field of the ##V>=4.11## [allocation] structure. ##V>=4.11## ##V>=4.11## This engine makes it possible to implement a low-overhead memory ##V>=4.11## profiler as an OCaml library. ##V>=4.11## ##V>=4.11## Note: this API is EXPERIMENTAL. It may change without prior ##V>=4.11## notice. *) ##V>=4.11##module Memprof : ##V>=4.11## sig ##V>=4.12## type allocation_source = Gc.Memprof.allocation_source = Normal | Marshal | Custom ##V>=4.11## type allocation = Gc.Memprof.allocation = private ##V>=4.11## { n_samples : int; ##V>=4.11## (** The number of samples in this block (>= 1). *) ##V>=4.11## ##V>=4.11## size : int; ##V>=4.11## (** The size of the block, in words, excluding the header. *) ##V>=4.11## ##V>=4.11####V<4.12## unmarshalled : bool; ##V>=4.11####V<4.12## (** Whether the block comes from unmarshalling. *) ##V>=4.12## source : allocation_source; ##V>=4.12## (** The type of the allocation. *) ##V>=4.11## ##V>=4.11## callstack : Printexc.raw_backtrace ##V>=4.11## (** The callstack for the allocation. *) ##V>=4.11## } ##V>=4.11## (** The type of metadata associated with allocations. This is the ##V>=4.11## type of records passed to the callback triggered by the ##V>=4.11## sampling of an allocation. *) ##V>=4.11## ##V>=4.11## type ('minor, 'major) tracker = ##V>=4.11## ('minor, 'major) Gc.Memprof.tracker = { ##V>=4.11## alloc_minor: allocation -> 'minor option; ##V>=4.11## alloc_major: allocation -> 'major option; ##V>=4.11## promote: 'minor -> 'major option; ##V>=4.11## dealloc_minor: 'minor -> unit; ##V>=4.11## dealloc_major: 'major -> unit; ##V>=4.11## } ##V>=4.11## (** ##V>=4.11## A [('minor, 'major) tracker] describes how memprof should track ##V>=4.11## sampled blocks over their lifetime, keeping a user-defined piece ##V>=4.11## of metadata for each of them: ['minor] is the type of metadata ##V>=4.11## to keep for minor blocks, and ['major] the type of metadata ##V>=4.11## for major blocks. ##V>=4.11## ##V>=4.11## If an allocation-tracking or promotion-tracking function returns [None], ##V>=4.11## memprof stops tracking the corresponding value. ##V>=4.11## *) ##V>=4.11## ##V>=4.11## val null_tracker: ('minor, 'major) tracker ##V>=4.11## (** Default callbacks simply return [None] or [()] *) ##V>=4.11## ##V>=4.11## val start : ##V>=4.11## sampling_rate:float -> ##V>=4.11## ?callstack_size:int -> ##V>=4.11## ('minor, 'major) tracker -> ##V>=4.11## unit ##V>=4.11## (** Start the sampling with the given parameters. Fails if ##V>=4.11## sampling is already active. ##V>=4.11## ##V>=4.11## The parameter [sampling_rate] is the sampling rate in samples ##V>=4.11## per word (including headers). Usually, with cheap callbacks, a ##V>=4.11## rate of 1e-4 has no visible effect on performance, and 1e-3 ##V>=4.11## causes the program to run a few percent slower ##V>=4.11## ##V>=4.11## The parameter [callstack_size] is the length of the callstack ##V>=4.11## recorded at every sample. Its default is [max_int]. ##V>=4.11## ##V>=4.11## The parameter [tracker] determines how to track sampled blocks ##V>=4.11## over their lifetime in the minor and major heap. ##V>=4.11## ##V>=4.11## Sampling is temporarily disabled when calling a callback ##V>=4.11## for the current thread. So they do not need to be reentrant if ##V>=4.11## the program is single-threaded. However, if threads are used, ##V>=4.11## it is possible that a context switch occurs during a callback, ##V>=4.11## in this case the callback functions must be reentrant. ##V>=4.11## ##V>=4.11## Note that the callback can be postponed slightly after the ##V>=4.11## actual event. The callstack passed to the callback is always ##V>=4.11## accurate, but the program state may have evolved. ##V>=4.11## ##V>=4.11## Calling [Thread.exit] in a callback is currently unsafe and can ##V>=4.11## result in undefined behavior. *) ##V>=4.11## ##V>=4.11## val stop : unit -> unit ##V>=4.11## (** Stop the sampling. Fails if sampling is not active. ##V>=4.11## ##V>=4.11## This function does not allocate memory, but tries to run the ##V>=4.11## postponed callbacks for already allocated memory blocks (of ##V>=4.11## course, these callbacks may allocate). ##V>=4.11## ##V>=4.11## All the already tracked blocks are discarded. ##V>=4.11## ##V>=4.11## Calling [stop] when a callback is running can lead to ##V>=4.11## callbacks not being called even though some events happened. *) ##V>=4.11##end batteries-included-3.4.0/src/batGenlex.ml000066400000000000000000000437031415601150500203240ustar00rootroot00000000000000open BatInnerPervasives open BatParserCo open BatCharParser include Genlex let string_of_token = function | Kwd s -> Printf.sprintf "Kwd %S" s | Ident s -> Printf.sprintf "Ident %S" s | Int i -> Printf.sprintf "Int %d" i | Float f -> Printf.sprintf "Float %f" f | String s -> Printf.sprintf "String %S" s | Char c -> Printf.sprintf "Char %C" c type lexer_error = | IllegalCharacter of char | NotReallyAChar | NotReallyAnEscape | EndOfStream exception LexerError of lexer_error * int exception EarlyEndOfStream type enum = { mutable position : int; content : char BatEnum.t } let junk e = e.position <- e.position + 1; BatEnum.junk e.content let peek e = BatEnum.peek e.content type t = (string, token) Hashtbl.t let of_list x = let kwd_table = Hashtbl.create (List.length x) in List.iter (fun s -> Hashtbl.add kwd_table s (Kwd s)) x; kwd_table let to_enum_filter kwd_table = let initial_buffer = Bytes.create 32 in let buffer = ref initial_buffer in let bufpos = ref 0 in let reset_buffer () = buffer := initial_buffer; bufpos := 0 in let store c = if !bufpos >= Bytes.length !buffer then begin let newbuffer = Bytes.create (2 * !bufpos) in Bytes.blit !buffer 0 newbuffer 0 !bufpos; buffer := newbuffer end; Bytes.set !buffer !bufpos c; incr bufpos in let get_string () = let s = Bytes.sub_string !buffer 0 !bufpos in buffer := initial_buffer; s in let ident_or_keyword id = try Hashtbl.find kwd_table id with Not_found -> Ident id and keyword_or_error c pos = let s = BatString.of_char c in try Hashtbl.find kwd_table s with Not_found -> raise (LexerError (IllegalCharacter c, pos)) in let rec next_token (enum : enum) = match peek enum with Some (' ' | '\010' | '\013' | '\009' | '\026' | '\012') -> junk enum; next_token enum | Some ('A'..'Z' | 'a'..'z' | '_' | '\192'..'\255' as c) -> junk enum; let s = enum in reset_buffer (); store c; ident s | Some ('!' | '%' | '&' | '$' | '#' | '+' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '\\' | '~' | '^' | '|' | '*' as c) -> junk enum; let s = enum in reset_buffer (); store c; ident2 s | Some ('0'..'9' as c) -> junk enum; let s = enum in reset_buffer (); store c; number s | Some '\'' -> junk enum; let c = try char enum with EarlyEndOfStream -> raise (LexerError (NotReallyAChar, enum.position)) in begin match peek enum with Some '\'' -> junk enum; Some (Char c) | None -> raise EarlyEndOfStream | _ -> raise (LexerError (NotReallyAChar, enum.position)) end | Some '"' -> junk enum; let s = enum in reset_buffer (); Some (String (string s)) | Some '-' -> junk enum; neg_number enum | Some '(' -> junk enum; maybe_comment enum | Some c -> junk enum; Some (keyword_or_error c enum.position) | _ -> None and ident (enum : enum) = match peek enum with Some ('A'..'Z' | 'a'..'z' | '\192'..'\255' | '0'..'9' | '_' | '\'' as c) -> junk enum; let s = enum in store c; ident s | _ -> Some (ident_or_keyword (get_string ())) and ident2 (enum : enum) = match peek enum with Some ('!' | '%' | '&' | '$' | '#' | '+' | '-' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '\\' | '~' | '^' | '|' | '*' as c) -> junk enum; let s = enum in store c; ident2 s | _ -> Some (ident_or_keyword (get_string ())) and neg_number (enum : enum) = match peek enum with Some ('0'..'9' as c) -> junk enum; let s = enum in reset_buffer (); store '-'; store c; number s | _ -> let s = enum in reset_buffer (); store '-'; ident2 s and number (enum : enum) = match peek enum with Some ('0'..'9' as c) -> junk enum; let s = enum in store c; number s | Some '.' -> junk enum; let s = enum in store '.'; decimal_part s | Some ('e' | 'E') -> junk enum; let s = enum in store 'E'; exponent_part s | _ -> Some (Int (int_of_string (get_string ()))) and decimal_part (enum : enum) = match peek enum with Some ('0'..'9' as c) -> junk enum; let s = enum in store c; decimal_part s | Some ('e' | 'E') -> junk enum; let s = enum in store 'E'; exponent_part s | _ -> Some (Float (float_of_string (get_string ()))) and exponent_part (enum : enum) = match peek enum with Some ('+' | '-' as c) -> junk enum; let s = enum in store c; end_exponent_part s | _ -> end_exponent_part enum and end_exponent_part (enum : enum) = match peek enum with Some ('0'..'9' as c) -> junk enum; let s = enum in store c; end_exponent_part s | _ -> Some (Float (float_of_string (get_string ()))) and string (enum : enum) = match peek enum with Some '"' -> junk enum; get_string () | Some '\\' -> junk enum; let c = try escape enum with EarlyEndOfStream -> raise (LexerError (NotReallyAnEscape, enum.position)) in let s = enum in store c; string s | Some c -> junk enum; let s = enum in store c; string s | _ -> raise EarlyEndOfStream and char (enum : enum) = match peek enum with Some '\\' -> junk enum; begin try escape enum with | EarlyEndOfStream -> raise (LexerError(NotReallyAChar, enum.position)) end | Some c -> junk enum; c | _ -> raise EarlyEndOfStream and escape (enum : enum) = match peek enum with Some 'n' -> junk enum; '\n' | Some 'r' -> junk enum; '\r' | Some 't' -> junk enum; '\t' | Some ('0'..'9' as c1) -> junk enum; begin match peek enum with Some ('0'..'9' as c2) -> junk enum; begin match peek enum with Some ('0'..'9' as c3) -> junk enum; Char.chr ((Char.code c1 - 48) * 100 + (Char.code c2 - 48) * 10 + (Char.code c3 - 48)) | Some _ -> raise (LexerError(NotReallyAnEscape, enum.position)) | None -> raise EarlyEndOfStream end | Some _ -> raise (LexerError(NotReallyAnEscape, enum.position)) | _ -> raise EarlyEndOfStream end | Some c -> junk enum; c | _ -> raise EarlyEndOfStream and maybe_comment (enum : enum) = match peek enum with Some '*' -> junk enum; let s = enum in comment s; next_token s | _ -> Some (keyword_or_error '(' enum.position) and comment (enum : enum) = match peek enum with Some '(' -> junk enum; maybe_nested_comment enum | Some '*' -> junk enum; maybe_end_comment enum | Some _ -> junk enum; comment enum | _ -> raise EarlyEndOfStream and maybe_nested_comment (enum : enum) = match peek enum with Some '*' -> junk enum; let s = enum in comment s; comment s | Some _ -> junk enum; comment enum | _ -> raise EarlyEndOfStream and maybe_end_comment (enum : enum) = match peek enum with Some ')' -> junk enum; () | Some '*' -> junk enum; maybe_end_comment enum | Some _ -> junk enum; comment enum | _ -> raise EarlyEndOfStream in fun input -> BatEnum.from_while (fun _count -> next_token {position = 0; content = input}) let to_stream_filter (kwd_table:t) (x:char Stream.t) : token Stream.t = (BatStream.of_enum (to_enum_filter kwd_table (BatStream.enum x))) let to_lazy_list_filter kwd_table x = (BatLazyList.of_enum (to_enum_filter kwd_table (BatLazyList.enum x))) let ocaml_escape = label "OCaml-style escaped character" ( any >>= function | 'n' -> return '\n' | 'r' -> return '\r' | 't' -> return '\t' | '\\'-> return '\\' | 'b' -> return '\b' | '"' -> return '"' | 'x' -> times 2 hex >>= fun t -> return (Char.chr (BatInt.of_string (BatString.implode ('0'::'x'::t)))) | '0' .. '9' as x -> times 2 digit >>= fun t -> return (Char.chr (BatInt.of_string (BatString.implode (x::t)))) | _ -> fail ) module Languages = struct module type Definition = sig val comment_delimiters : (string * string) option val line_comment_start : string option val nested_comments : bool val ident_start : (char, char, position) BatParserCo.t val ident_letter : (char, char, position) BatParserCo.t val op_start : (char, char, position) BatParserCo.t val op_letter : (char, char, position) BatParserCo.t val reserved_names : string list val case_sensitive : bool end module Library = struct (**A good approximation of language definition for OCaml's lexer*) module OCaml = struct let comment_delimiters = Some ("(*", "*)") let line_comment_start = None let nested_comments = true let ident_start = either [uppercase; lowercase; one_of ['_'; '`']] let ident_letter = either [uppercase; lowercase; digit; one_of ['\''; '_']] let op_start = satisfy (BatChar.is_symbol) let op_letter = op_start let reserved_names = ["fun"; "let"; "module"; "begin"; "end"; "sig"; "function"; "{"; "}"; ";"; "|"; ","; ":"; "."; ](*@TODO: Complete*) let case_sensitive = true end (**A good approximation of language definition for C++'s lexer*) module C = struct let comment_delimiters = Some ("/*", "*/") let line_comment_start = Some "//" let nested_comments = true let ident_start = either [uppercase; lowercase; char '_'] let ident_letter = either [ident_start; digit] let op_start = one_of [';';':';'!';'$';'%';'&';'*';'+';'.';'/';'<';'=';'>';'?';'^';'|';'-';'~'] let op_letter = op_start let reserved_names = ["continue"; "volatile"; "register"; "unsigned"; "typedef"; "default"; "sizeof"; "switch"; "return"; "extern"; "struct"; "static"; "signed"; "while"; "break"; "union"; "const"; "else"; "case"; "enum"; "auto"; "goto"; "for"; "if"; "do" ] let case_sensitive = true end end (** Create a lexer based on conventions*) module Make (M:Definition) = struct open M (** {6 Case management} *) let char = if case_sensitive then char else case_char let string = if case_sensitive then string else case_string let adapt_case = if case_sensitive then identity else String.lowercase let string_compare = if case_sensitive then String.compare else BatString.icompare (** {6 Whitespace management} *) let line_comment = match line_comment_start with | None -> fail | Some s -> (*label "Line comment"*)label "" ( string s >>= fun _ -> ignore_zero_plus (not_char '\n') >>= fun _ -> newline >>= fun _ -> return ()) (*Note: we use [string] rather than [CharParser.string], as the line comment may be introduced by a word rather than a symbol (e.g. Basic's [REM]), hence may depend on case sensitivity.*) let multiline_comment = match comment_delimiters with | None -> fail | Some (l, r) -> (*label "Multi-line comment"*) label "" ( let l0 = String.get l 0 and r0 = String.get r 0 and string_r = string r in let in_comment () = if nested_comments then let not_lr = label ("Neither \""^l^"\" nor ^ \"" ^r^"\"") (none_of [r0; l0]) in let rec aux () = label "aux" ( either [ string r >>= (fun _ -> return ()); string l >>= (fun _ -> aux () >>= fun _ -> aux ()) ; (ignore_one_plus not_lr) >>= fun _ -> aux () ] ) in aux () else string l >>> label "Contents of comments" ( let rec aux () = maybe string_r >>= function | Some _ -> return () | None -> any >>> aux () in aux () ) in in_comment ()) let comment = ( line_comment <|> multiline_comment ) >>> return () let whitespaces = ignore_zero_plus (either [ satisfy BatChar.is_whitespace >>= (fun _ -> return ()); comment ]) let to_symbol p = p >>= fun r -> whitespaces >>= fun _ -> return (BatString.of_list r) let lexeme p = p >>= fun r -> whitespaces >>= fun _ -> return r (** {6 Actual content} *) let identifier_content = either [ident_start >:: zero_plus ident_letter ; op_start >:: zero_plus op_letter] let is_reserved s = List.mem s reserved_names let ident_or_kwd = label "identifier or reserved" (label "" ( to_symbol identifier_content >>= fun s -> (* Printf.eprintf "Got something %S\n" s;*) return (adapt_case s))) let ident = label "identifier or operator" (label "" (ident_or_kwd >>= fun s -> if is_reserved s then fail else ((*Printf.eprintf "Got ident %S\n" s;*)return s))) (* let kwd = label "keyword" (ident_or_kwd >>= fun s -> if is_reserved s then (Printf.eprintf "Got reserved %S\n" s; return s) else fail)*) let kwd = label "keyword" (ident_or_kwd) let identifier s = label ("specific identifier \""^s^"\"") (label "" (ident >>= fun s' -> if string_compare s s' = 0 then return () else fail)) let keyword s = label ("specific keyword \""^s^"\"") (label "" (kwd >>= fun s' -> if string_compare s s' = 0 then return () else fail)) (* let as_identifier p = p >>= fun s -> if List.mem s reserved_names then fail else return s let as_operator p = p >>= fun s -> if List.mem s reserved_op_names then fail else return s*) (* let any_reserved = label "reserved name" ( to_symbol (ident_start >:: zero_plus ident_letter) >>= fun s -> if List.mem s reserved_names then return s else fail) let any_reserved_op = label "reserved operator" ( to_symbol (op_start >:: zero_plus op_letter) >>= fun s -> if List.mem s reserved_op_names then return s else fail)*) let char_literal = label "Character literal" (BatCharParser.char '\'' >>= fun _ -> any >>= function | '\\' -> ocaml_escape | c -> return c ) >>= fun c -> BatCharParser.char '\'' >>= fun _ -> return c let string_literal = label "String Literal" (lexeme (BatCharParser.char '"' >>> let rec content chars = any >>= function | '"' -> return chars | '\\' -> ocaml_escape >>= fun e -> content (e::chars) | e -> (*Printf.eprintf "Just received char %c\n" e;*) content (e::chars) in content [] >>= fun c -> (*Printf.eprintf "Sending full string %S\n" (String.of_list (List.rev c));*) return (BatString.of_list (List.rev c)))) let integer = label "OCaml-style integer" ( lexeme(maybe (BatCharParser.char '-') >>= fun sign -> one_plus digit >>= fun digits -> let number = BatInt.of_string (BatString.of_list digits) in match sign with | Some _ -> return (~- number) | None -> return number )) let float = label "OCaml-style floating-point number" ( lexeme (maybe (BatCharParser.char '-') >>= fun sign -> post_map BatString.of_list (zero_plus digit) >>= fun int_part -> maybe ( BatCharParser.char '.' >>= fun _ -> post_map BatString.of_list (zero_plus digit) ) >>= fun decimal_part -> maybe ( BatCharParser.char 'E' >>= fun _ -> maybe (BatCharParser.char '+' <|> BatCharParser.char '-') >>= fun sign -> let sign = BatOption.default '+' sign in one_plus digit >>= fun expo -> return ("E" ^ (BatString.of_char sign) ^ (BatString.of_list expo))) >>= fun expo -> let number = match (decimal_part, expo) with | Some d, Some e -> Some (int_part ^ "." ^ d ^ e) | Some d, None -> Some (int_part ^ "." ^ d) | None, Some e -> Some (int_part ^ e ) | None, None -> None in match number with | None -> fail | Some n -> let absolute = BatFloat.of_string n in return ( match sign with | None -> absolute | Some _ -> ~-. absolute) )) let number = ( float >>= fun f -> return (`Float f)) <|>( integer >>= fun i -> return (`Integer i) ) (** Getting it all together. *) let check_reserved = if case_sensitive then fun x -> if is_reserved x then (Kwd x) else (Ident x) else fun x -> let x = String.lowercase x in if is_reserved x then (Kwd x) else (Ident x) let as_parser = whitespaces >>= fun _ -> either [ ident_or_kwd >>= (fun x -> return (check_reserved x)); float >>= (fun x -> return (Float x) ); integer >>= (fun x -> return (Int x) ); string_literal >>= (fun x -> return (String x) ); char_literal >>= (fun x -> return (Char x) ) ] let feed = source_map as_parser let start = whitespaces end end batteries-included-3.4.0/src/batGenlex.mli000066400000000000000000000162741415601150500205000ustar00rootroot00000000000000(* * Genlex - Generic lexer * Copyright (C) 2002 Jacques Garrigue * 2008 David Teller (Contributor) * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** A generic lexical analyzer. This module implements a simple ``standard'' lexical analyzer, presented as a function from character streams to token streams. It implements roughly the lexical conventions of OCaml, but is parameterized by the set of keywords of your language. Example: a lexer suitable for a desk calculator is obtained by {[ let lexer = make_lexer ["+";"-";"*";"/";"let";"="; "("; ")"] ]} The associated parser would be a function from [token stream] to, for instance, [int], and would have rules such as: {[ let parse_expr = parser [< 'Int n >] -> n | [< 'Kwd "("; n = parse_expr; 'Kwd ")" >] -> n | [< n1 = parse_expr; n2 = parse_remainder n1 >] -> n2 and parse_remainder n1 = parser [< 'Kwd "+"; n2 = parse_expr >] -> n1+n2 | ... ]} @author Jacques Garrigue @author David Teller *) (** The type of tokens. The lexical classes are: [Int] and [Float] for integer and floating-point numbers; [String] for string literals, enclosed in double quotes; [Char] for character literals, enclosed in single quotes; [Ident] for identifiers (either sequences of letters, digits, underscores and quotes, or sequences of ``operator characters'' such as [+], [*], etc); and [Kwd] for keywords (either identifiers or single ``special characters'' such as [(], [}], etc). *) type token = Genlex.token = Kwd of string | Ident of string | Int of int | Float of float | String of string | Char of char val make_lexer : string list -> char Stream.t -> token Stream.t (** Construct the lexer function. The first argument is the list of keywords. An identifier [s] is returned as [Kwd s] if [s] belongs to this list, and as [Ident s] otherwise. A special character [s] is returned as [Kwd s] if [s] belongs to this list, and cause a lexical error (exception [Parse_error]) otherwise. Blanks and newlines are skipped. Comments delimited by [(*] and [*)] are skipped as well, and can be nested. *) (* {6 Batteries extensions to genlex } *) type lexer_error = | IllegalCharacter of char | NotReallyAChar | NotReallyAnEscape | EndOfStream exception LexerError of lexer_error * int type t (** A lexer*) val of_list : string list -> t (** Create a lexer from a list of keywords*) val to_stream_filter : t -> char Stream.t -> token Stream.t (** Apply the lexer to a stream.*) val to_enum_filter : t -> char BatEnum.t -> token BatEnum.t (** Apply the lexer to an enum.*) val to_lazy_list_filter: t -> char BatLazyList.t -> token BatLazyList.t (** Apply the lexer to a lazy list.*) val string_of_token : token -> string (**{6 Extending to other languages}*) open BatCharParser module Languages : sig module type Definition = sig val comment_delimiters : (string * string) option val line_comment_start : string option val nested_comments : bool val ident_start : (char, char, position) BatParserCo.t val ident_letter : (char, char, position) BatParserCo.t val op_start : (char, char, position) BatParserCo.t val op_letter : (char, char, position) BatParserCo.t val reserved_names : string list val case_sensitive : bool (**[true] if the language is case-sensitive, [false] otherwise. If the language is not case-sensitive, every identifier is returned as lower-case.*) end module Library : sig module OCaml : Definition module C : Definition end module Make(M:Definition) : sig (**Create a lexer from a language definition*) (** {6 High-level API} *) (** Drop comments, present reserved operators and reserved names as [Kwd], operators and identifiers as [Ident], integer numbers as [Int], floating-point numbers as [Float] and characters as [Char]. If the language is not [case_sensitive], identifiers and keywords are returned in lower-case. *) val feed : (char, position) BatParserCo.Source.t -> (token, position) BatParserCo.Source.t (** {6 Medium-level API} *) val start : (char, unit, position) BatParserCo.t (**Remove any leading whitespaces*) val ident : (char, string, position) BatParserCo.t (**Accepts any non-reserved identifier/operator. If the language is not [case_sensitive], the identifier is returned in lower-case.*) val kwd : (char, string, position) BatParserCo.t (**Accepts any identifier. If the language is not [case_sensitive], the identifier is returned in lower-case.*) val identifier : string -> (char, unit, position) BatParserCo.t val keyword : string -> (char, unit, position) BatParserCo.t val char_literal : (char, char, position) BatParserCo.t (**Accepts a character literal, i.e. one character (or an escape) between two quotes.*) val string_literal :(char, string, position) BatParserCo.t (**Accepts a string, i.e. one sequence of characters or escapes between two double quotes, on one line.*) val integer: (char, int , position) BatParserCo.t (**Parse an integer.*) val float: (char, float , position) BatParserCo.t (**Parse a floating-point number.*) val number: (char, [`Float of float | `Integer of int] , position) BatParserCo.t (**Parse either an integer or a floating-point number.*) (** {6 Low-level API} *) val char : char -> (char, char , position) BatParserCo.t (** As {!CharParser.char}, but case-insensitive if specified by {!case_sensitive}. *) val string : string -> (char, string, position) BatParserCo.t (** As {!CharParser.string}, but case-insensitive if specified by {!case_sensitive}. *) val line_comment : (char, unit , position) BatParserCo.t val multiline_comment : (char, unit , position) BatParserCo.t val comment : (char, unit , position) BatParserCo.t val whitespaces : (char, unit , position) BatParserCo.t (* val lexeme : (char, 'a , position) BatParserCo.t -> (char, 'a , position) BatParserCo.t*) (**Apply this filter to your own parsers if you want them to ignore following comments.*) end end batteries-included-3.4.0/src/batGlobal.ml000066400000000000000000000023411415601150500202730ustar00rootroot00000000000000(* * Global - Mutable global variable * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) exception Global_not_initialized of string type 'a t = ('a option ref * string) let empty name = (ref None, name) let name = snd let set (r, _) v = r := Some v let get_exn (r, name) = match !r with | None -> raise (Global_not_initialized name) | Some v -> v let undef (r, _) = r := None let isdef (r, _) = !r <> None let get (r,_) = !r batteries-included-3.4.0/src/batGlobal.mli000066400000000000000000000045061415601150500204510ustar00rootroot00000000000000(* * Global - Mutable global variable * Copyright (C) 2003 Nicolas Cannasse * Copyright (C) 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Mutable global variable. Often in OCaml you want to have a global variable, which is mutable and uninitialized when declared. You can use a ['a option ref] but this is not very convenient. The Global module provides functions to easily create and manipulate such variables. @author Nicolas Cannasse @author David Teller (boilerplate code) *) type 'a t (** Abstract type of a global *) exception Global_not_initialized of string (** Raised when a global variable is accessed without first having been assigned a value. The parameter contains the name of the global. *) val empty : string -> 'a t (** Returns an new named empty global. The name of the global can be any string. It identifies the global and makes debugging easier. Using the same string twice will not return the same global twice, but will create two globals with the same name. *) val name : 'a t -> string (** Retrieve the name of a global. *) val set : 'a t -> 'a -> unit (** Set the global value contents. *) val get_exn : 'a t -> 'a (** Get the global value contents - raise Global_not_initialized if not defined. *) val get : 'a t -> 'a option (** Return [None] if the global is undefined, else [Some v] where [v] is the current global value contents. *) val undef : 'a t -> unit (** Reset the global value contents to undefined. *) val isdef : 'a t -> bool (** Return [true] if the global value has been set. *) batteries-included-3.4.0/src/batHashcons.ml000066400000000000000000000116111415601150500206410ustar00rootroot00000000000000(* * Hashcons -- a hashconsing library * Copyright (C) 2011 Batteries Included Development Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (* Most of this code is lifted from J.-C. Fillâtre and S. Conchon's implementation: http://www.lri.fr/~filliatr/ftp/ocaml/ds/hashcons.ml *) module Int = BatInt module Sys = BatSys module Hashtbl = BatHashtbl module Array = BatArray type 'a hobj = { obj : 'a ; tag : int ; hcode : int ; } type 'a t = 'a hobj let compare ho1 ho2 = Int.compare ho1.tag ho2.tag let gentag = let tags = ref 0 in fun () -> incr tags ; !tags module type Table = sig type key type t val create : int -> t val clear : t -> unit val hashcons : t -> key -> key hobj val iter : (key hobj -> unit) -> t -> unit val fold : (key hobj -> 'a -> 'a) -> t -> 'a -> 'a val count : t -> int end module MakeTable (HT : Hashtbl.HashedType) : Table with type key = HT.t = struct type key = HT.t type data = HT.t hobj type t = { mutable table : data Weak.t array ; mutable totsize : int ; (* sum of the bucket sizes *) mutable limit : int ; (* max ratio totsize/table length *) } let emptybucket = Weak.create 0 let create sz = let sz = Pervasives.min (Pervasives.max sz 7) (Sys.max_array_length - 1) in { table = Array.make sz emptybucket ; totsize = 0 ; limit = 3 } let clear t = Array.modify (fun _ -> emptybucket) t.table ; t.totsize <- 0 ; t.limit <- 3 let fold f t init = let rec fold_bucket i b accu = if i >= Weak.length b then accu else match Weak.get b i with | Some v -> fold_bucket (i + 1) b (f v accu) | None -> fold_bucket (i + 1) b accu in Array.fold_right (fold_bucket 0) t.table init let iter f t = let rec iter_bucket i b = if i >= Weak.length b then () else match Weak.get b i with | Some v -> f v ; iter_bucket (i + 1) b | None -> iter_bucket (i + 1) b in Array.iter (iter_bucket 0) t.table let count t = let rec count_bucket i b accu = if i >= Weak.length b then accu else count_bucket (i + 1) b (accu + (if Weak.check b i then 1 else 0)) in Array.fold_right (count_bucket 0) t.table 0 let next_sz n = Pervasives.min (3 * n / 2 + 3) (Sys.max_array_length - 1) let rec resize t = let oldlen = Array.length t.table in let newlen = next_sz oldlen in if newlen > oldlen then begin let newt = create newlen in newt.limit <- t.limit + 100 ; (* prevent resizing of newt *) iter (add newt) t ; t.table <- newt.table ; t.limit <- t.limit + 2 ; end and add t d = let index = d.hcode mod (Array.length t.table) in let bucket = t.table.(index) in let sz = Weak.length bucket in let rec loop i = if i >= sz then begin let newsz = Pervasives.min (sz + 3) (Sys.max_array_length - 1) in if newsz <= sz then failwith "Hashcons.Make: hash bucket cannot grow more" ; let newbucket = Weak.create newsz in Weak.blit bucket 0 newbucket 0 sz ; Weak.set newbucket i (Some d) ; t.table.(index) <- newbucket ; t.totsize <- t.totsize + (newsz - sz) ; if t.totsize > t.limit * Array.length t.table then resize t ; end else begin if Weak.check bucket i then loop (i + 1) else Weak.set bucket i (Some d) end in loop 0 let hashcons t d = let hcode = (HT.hash d) land Pervasives.max_int in let index = hcode mod (Array.length t.table) in let bucket = t.table.(index) in let sz = Weak.length bucket in let rec loop i = if i >= sz then begin let hdata = { hcode = hcode ; tag = gentag () ; obj = d } in add t hdata ; hdata end else begin match Weak.get_copy bucket i with | Some v when HT.equal v.obj d -> begin match Weak.get bucket i with | Some v -> v | None -> loop (i + 1) end | _ -> loop (i + 1) end in loop 0 end module H = struct let hc0_ h = h let hc0 x = x.hcode let hc1_ x h = x + 19 * h let hc1 x = hc1_ x.hcode end batteries-included-3.4.0/src/batHashcons.mli000066400000000000000000000062721415601150500210210ustar00rootroot00000000000000(* * Hashcons -- a hashconsing library * Copyright (C) 2011 Batteries Included Development Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Hash consing of data structures *) (** The type [t hobj] represents hashed objects of type [t]. A hashed object contains a unique tag and a hash code. *) type 'a hobj = private { obj : 'a ; tag : int ; (** Unique id for this object *) hcode : int ; (** Hash code for this object *) } type 'a t = 'a hobj (** A synonym for convenience *) val compare : 'a hobj -> 'a hobj -> int (** Comparison on the tags *) (** Hashcons tables *) module type Table = sig type key (** type of objects in the table *) type t (** type of the table *) val create : int -> t (** [create n] creates a table with at least [n] cells. *) val clear : t -> unit (** [clear tab] removes all entries from the table [tab]. *) val hashcons : t -> key -> key hobj (** [hashcons tab k] returns either [k], adding it to the table [tab] as a side effect, or if [k] is already in the table then it returns the hashed object corresponding to that entry. @raise Failure if number of objects with the same hash reaches system limit of array size *) val iter : (key hobj -> unit) -> t -> unit (** [iter f tab] applies [f] to every live hashed object in the table [tab]. *) val fold : (key hobj -> 'a -> 'a) -> t -> 'a -> 'a (** [fold f tab x0] folds [f] across every live hashed object in the table [tab], starting with value [x0] *) val count : t -> int (** [count tab] returns a count of how many live objects are in [tab]. This can decrease whenever the GC runs, even during execution, so consider the returned value as an upper-bound. *) end module MakeTable (HT : BatHashtbl.HashedType) : Table with type key = HT.t (** Hashing utilities *) module H : sig val hc0_ : int -> int (** [hc0_ h] corresponds to the hashcode of a first constructor applied to an object of hashcode [h] *) val hc0 : 'a hobj -> int (** [hc0 ho] is the hashcode of a first constructor applied to the hashed object [ho] *) val hc1_ : int -> int -> int (** [hc1_ h k] corresponds to the hashcode of the [k]th constructor applied to an object of hashcode [h]. *) val hc1 : 'a hobj -> int -> int (** [hc1 ho k] corresponds to the hashcode of the [k]th constructor applied to the hashed object [ho]. *) end batteries-included-3.4.0/src/batHashtbl.mli000066400000000000000000000626411415601150500206420ustar00rootroot00000000000000(* * BatHashtbl - extra functions over hashtables. * Copyright (C) 2003 Nicolas Cannasse * 2009 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Extra functions over hashtables. *) (** Operations over hashtables. This module replaces Stdlib's {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Hashtbl.html}Hashtbl} module. All functions and types are provided here. @author Xavier Leroy (base module) @author Damien Doligez (base module) @author Nicolas Cannasse @author David Teller *) type ('a, 'b) t = ('a, 'b) Hashtbl.t (** A Hashtable with keys of type 'a and values 'b *) (**{6 Base operations}*) val create : int -> ('a, 'b) t (** [Hashtbl.create n] creates a new, empty hash table, with initial size [n]. For best results, [n] should be on the order of the expected number of elements that will be in the table. The table grows as needed, so [n] is just an initial guess. *) val length : ('a, 'b) t -> int (** [Hashtbl.length tbl] returns the number of bindings in [tbl]. Multiple bindings are counted multiply, so [Hashtbl.length] gives the number of times [Hashtbl.iter] calls its first argument. *) val is_empty : ('a, 'b) t -> bool (** [Hashtbl.is_empty tbl] returns [true] if there are no bindings in [tbl], false otherwise.*) val add : ('a, 'b) t -> 'a -> 'b -> unit (** [Hashtbl.add tbl x y] adds a binding of [x] to [y] in table [tbl]. Previous bindings for [x] are not removed, but simply hidden. That is, after performing {!Hashtbl.remove}[ tbl x], the previous binding for [x], if any, is restored. (Same behavior as with association lists.) *) val remove : ('a, 'b) t -> 'a -> unit (** [Hashtbl.remove tbl x] removes the current binding of [x] in [tbl], restoring the previous binding if it exists. It does nothing if [x] is not bound in [tbl]. *) val remove_all : ('a,'b) t -> 'a -> unit (** Remove all bindings for the given key *) val replace : ('a, 'b) t -> 'a -> 'b -> unit (** [Hashtbl.replace tbl x y] replaces the current binding of [x] in [tbl] by a binding of [x] to [y]. If [x] is unbound in [tbl], a binding of [x] to [y] is added to [tbl]. This is functionally equivalent to {!Hashtbl.remove}[ tbl x] followed by {!Hashtbl.add}[ tbl x y]. *) val modify : 'a -> ('b -> 'b) -> ('a, 'b) t -> unit (** [Hashtbl.modify k f tbl] replaces the first binding for [k] in [tbl] with [f] applied to that value. @raise Not_found if [k] is unbound in [tbl]. @since 2.1 *) val modify_def : 'b -> 'a -> ('b -> 'b) -> ('a, 'b) t -> unit (** [Hashtbl.modify_def v k f tbl] does the same as [Hashtbl.modify k f tbl] but [f v] is inserted in [tbl] if [k] was unbound. @since 2.1 *) val modify_opt : 'a -> ('b option -> 'b option) -> ('a, 'b) t -> unit (** [Hashtbl.modify_opt k f tbl] allows to remove, modify or add a binding for [k] in [tbl]. [f] will be called with [None] if [k] was unbound. first previous binding of [k] in [tbl] will be deleted if [f] returns [None]. Otherwise, the previous binding is replaced by the value produced by [f]. @since 2.1 *) val copy : ('a, 'b) t -> ('a, 'b) t (** Return a copy of the given hashtable. *) val clear : ('a, 'b) t -> unit (** Empty a hash table. *) (**{6 Enumerations}*) val keys : ('a,'b) t -> 'a BatEnum.t (** Return an enumeration of all the keys of a hashtable. If the key is in the Hashtable multiple times, all occurrences will be returned. *) val values : ('a,'b) t -> 'b BatEnum.t (** Return an enumeration of all the values of a hashtable. *) val enum : ('a, 'b) t -> ('a * 'b) BatEnum.t (** Return an enumeration of (key,value) pairs of a hashtable. *) val of_enum : ('a * 'b) BatEnum.t -> ('a, 'b) t (** Create a hashtable from a (key,value) enumeration. *) (**{6 Lists}*) val of_list : ('a * 'b) list -> ('a, 'b) t (** Create a hashtable from a list of (key,value) pairs. @since 2.6.0 *) val to_list : ('a, 'b) t -> ('a * 'b) list (** Return the list of (key,value) pairs. @since 2.6.0 *) val bindings : ('a, 'b) t -> ('a * 'b) list (** Alias for [to_list]. @since 2.6.0 *) (**{6 Searching}*) val find : ('a, 'b) t -> 'a -> 'b (** [Hashtbl.find tbl x] returns the current binding of [x] in [tbl], or raises [Not_found] if no such binding exists. *) val find_all : ('a, 'b) t -> 'a -> 'b list (** [Hashtbl.find_all tbl x] returns the list of all data associated with [x] in [tbl]. The current binding is returned first, then the previous bindings, in reverse order of introduction in the table. *) val find_default : ('a,'b) t -> 'a -> 'b -> 'b (** [Hashtbl.find_default tbl key default] finds a binding for [key], or return [default] if [key] is unbound in [tbl]. *) val find_option : ('a,'b) Hashtbl.t -> 'a -> 'b option (** Find a binding for the key, or return [None] if no value is found *) val mem : ('a, 'b) t -> 'a -> bool (** [Hashtbl.mem tbl x] checks if [x] is bound in [tbl]. *) (*val exists : ('a,'b) t -> 'a -> bool (** [exists h k] returns true is at least one item with key [k] is found in the hashtable. *)*) (**{6 Traversing} A number of higher-order functions are provided to allow purely functional traversal or transformation of hashtables. These functions are similar to their counterparts in module {!BatEnum}. Whenever you wish to traverse or transfor a hashtable, you have the choice between using the more general functions of {!BatEnum}, with {!keys}, {!values}, {!enum} and {!of_enum}, or the more optimized functions of this section. If you are new to OCaml or unsure about data structure, using the functions of {!BatEnum} is a safe bet. Should you wish to improve performance at the cost of generality, you will always be able to rewrite your code to make use of the functions of this section. *) val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit (** [Hashtbl.iter f tbl] applies [f] to all bindings in table [tbl]. [f] receives the key as first argument, and the associated value as second argument. Each binding is presented exactly once to [f]. The order in which the bindings are passed to [f] is unspecified. However, if the table contains several bindings for the same key, they are passed to [f] in reverse order of introduction, that is, the most recent binding is passed first. *) val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c (** [Hashtbl.fold f tbl init] computes [(f kN dN ... (f k1 d1 (f k0 d0 init))...)], where [k0,k1..kN] are the keys of all bindings in [tbl], and [d0,d1..dN] are the associated values. Each binding is presented exactly once to [f]. The order in which the bindings are passed to [f] is unspecified. However, if the table contains several bindings for the same key, they are passed to [f] in reverse order of introduction, that is, the most recent binding is passed first. *) val map : ('a -> 'b -> 'c) -> ('a,'b) t -> ('a,'c) t (** [map f x] creates a new hashtable with the same keys as [x], but with the function [f] applied to all the values *) val map_inplace : ('a -> 'b -> 'b) -> ('a,'b) t -> unit (** [map_inplace f x] replace all values currently bound in [x] by [f] applied to each value. @since 2.1 *) val filter: ('a -> bool) -> ('key, 'a) t -> ('key, 'a) t (** [filter f m] returns a new hashtable where only the values [a] of [m] such that [f a = true] remain.*) val filter_inplace : ('a -> bool) -> ('key,'a) t -> unit (** [filter_inplace f m] removes from [m] all bindings that does not satisfy the predicate f. @since 2.1 *) val filteri: ('key -> 'a -> bool) -> ('key, 'a) t -> ('key, 'a) t (** [filteri f m] returns a hashtbl where only the key, values pairs [key], [a] of [m] such that [f key a = true] remain. *) val filteri_inplace : ('key -> 'a -> bool) -> ('key, 'a) t -> unit (** [filteri_inplace f m] performs as filter_inplace but [f] receive the value in additiuon to the key. @since 2.1 *) val filter_map: ('key -> 'a -> 'b option) -> ('key, 'a) t -> ('key, 'b) t (** [filter_map f m] combines the features of [filteri] and [map]. It calls [f key0 a0], [f key1 a1], [f keyn an] where [a0,a1..an] are the elements of [m] and [key0..keyn] the corresponding keys. It returns a hashtbl with associations [keyi],[bi] where [f keyi ai = Some bi]. When [f] returns [None], the corresponding element of [m] is discarded. *) val filter_map_inplace: ('key -> 'a -> 'a option) -> ('key, 'a) t -> unit (** [filter_map_inplace f m] performs like filter_map but modify [m] inplace instead of creating a new Hashtbl. *) val merge: ('a -> 'b option -> 'c option -> 'd option) -> ('a, 'b) t -> ('a, 'c) t -> ('a, 'd) t (** [merge f a b] returns a new Hashtbl which is build from the bindings of [a] and [b] according to the function [f], that is given all defined keys one by one, along with the value from [a] (if defined) and the value from [b] (if defined), and has to return the (optional) resulting value. It is assumed that each key is bound at most once in [a] and [b]. See [merge_all] for a more general alternative if this is not the case. @since 2.10.0 *) val merge_all: ('a -> 'b list -> 'c list -> 'd list) -> ('a, 'b) t -> ('a, 'c) t -> ('a, 'd) t (** [merge_all f a b] is similar to [merge], but passes to [f] all bindings for a key (most recent first, as returned by [find_all]). [f] must then return all the new bindings of the merged hashtable (or an empty list if that key should not be bound in the resulting hashtable). Those new bindings will be inserted in reverse, so that the head of the list will become the most recent binding in the merged hashtable. @since 2.10.0 *) (** {6 The polymorphic hash primitive}*) val hash : 'a -> int (** [Hashtbl.hash x] associates a positive integer to any value of any type. It is guaranteed that if [x = y] or [Pervasives.compare x y = 0], then [hash x = hash y]. Moreover, [hash] always terminates, even on cyclic structures. *) (** {6 Boilerplate code}*) (** {7 Printing}*) val print : ?first:string -> ?last:string -> ?sep:string -> ?kvsep:string -> ('a BatInnerIO.output -> 'b -> unit) -> ('a BatInnerIO.output -> 'c -> unit) -> 'a BatInnerIO.output -> ('b, 'c) t -> unit (** {6 Override modules}*) (** The following modules replace functions defined in {!Hashtbl} with functions behaving slightly differently but having the same name. This is by design: the functions meant to override the corresponding functions of {!Hashtbl}. *) (** Operations on {!Hashtbl} without exceptions. @documents Hashtbl.Exceptionless *) module Exceptionless : sig val find : ('a, 'b) t -> 'a -> 'b option val modify : 'a -> ('b -> 'b) -> ('a, 'b) t -> (unit, exn) BatPervasives.result end (** Infix operators over a {!BatHashtbl} *) module Infix : sig val (-->) : ('a, 'b) t -> 'a -> 'b (** [tbl-->x] returns the current binding of [x] in [tbl], or raises [Not_found] if no such binding exists. Equivalent to [Hashtbl.find tbl x]*) val (<--) : ('a, 'b) t -> 'a * 'b -> unit (** [tbl<--(x, y)] adds a binding of [x] to [y] in table [tbl]. Previous bindings for [x] are not removed, but simply hidden. That is, after performing {!Hashtbl.remove}[ tbl x], the previous binding for [x], if any, is restored. (Same behavior as with association lists.) Equivalent to [Hashtbl.add tbl x y]*) end (** Operations on {!Hashtbl} with labels. This module overrides a number of functions of {!Hashtbl} by functions in which some arguments require labels. These labels are there to improve readability and safety and to let you change the order of arguments to functions. In every case, the behavior of the function is identical to that of the corresponding function of {!Hashtbl}. @documents Hashtbl.Labels *) module Labels : sig val add : ('a, 'b) t -> key:'a -> data:'b -> unit val replace : ('a, 'b) t -> key:'a -> data:'b -> unit val iter : f:(key:'a -> data:'b -> unit) -> ('a, 'b) t -> unit val map : f:(key:'a -> data:'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t val map_inplace : f:(key:'a -> data:'b -> 'b) -> ('a,'b) t -> unit val filter : f:('a -> bool) -> ('key, 'a) t -> ('key, 'a) t val filter_inplace : f:('a -> bool) -> ('key, 'a) t -> unit val filteri : f:(key:'key -> data:'a -> bool) -> ('key, 'a) t -> ('key, 'a) t val filteri_inplace : f:(key:'key -> data:'a -> bool) -> ('key, 'a) t -> unit val filter_map : f:(key:'key -> data:'a -> 'b option) -> ('key, 'a) t -> ('key, 'b) t val filter_map_inplace : f:(key:'key -> data:'a -> 'a option) -> ('key, 'a) t -> unit val fold : f:(key:'a -> data:'b -> 'c -> 'c) -> ('a, 'b) t -> init:'c -> 'c val modify : key:'a -> f:('b -> 'b) -> ('a, 'b) t -> unit val modify_def : default:'b -> key:'a -> f:('b -> 'b) -> ('a, 'b) t -> unit val modify_opt : key:'a -> f:('b option -> 'b option) -> ('a, 'b) t -> unit val merge: f:('a -> 'b option -> 'c option -> 'd option) -> left:('a, 'b) t -> right:('a, 'c) t -> ('a, 'd) t val merge_all: f:('a -> 'b list -> 'c list -> 'd list) -> left:('a, 'b) t -> right:('a, 'c) t -> ('a, 'd) t end (** {6 Functorial interface} *) module type HashedType = sig type t (** The type of the hashtable keys. *) val equal : t -> t -> bool (** The equality predicate used to compare keys. *) val hash : t -> int (** A hashing function on keys. It must be such that if two keys are equal according to [equal], then they have identical hash values as computed by [hash]. Examples: suitable ([equal], [hash]) pairs for arbitrary key types include ([(=)], {!Hashtbl.hash}) for comparing objects by structure, ([(fun x y -> compare x y = 0)], {!Hashtbl.hash}) for comparing objects by structure and handling {!Pervasives.nan} correctly, and ([(==)], {!Hashtbl.hash}) for comparing objects by addresses (e.g. for cyclic keys). *) end (** The output signature of the functor {!Hashtbl.Make}. *) module type S = sig type key type 'a t val create : int -> 'a t val length : 'a t -> int val is_empty : 'a t -> bool val clear : 'a t -> unit val copy : 'a t -> 'a t val add : 'a t -> key -> 'a -> unit val remove : 'a t -> key -> unit val remove_all : 'a t -> key -> unit val find : 'a t -> key -> 'a val find_all : 'a t -> key -> 'a list val find_default : 'a t -> key -> 'a -> 'a val find_option : 'a t -> key -> 'a option val replace : 'a t -> key -> 'a -> unit val mem : 'a t -> key -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val map : (key -> 'b -> 'c) -> 'b t -> 'c t val map_inplace : (key -> 'a -> 'a) -> 'a t -> unit val filter : ('a -> bool) -> 'a t -> 'a t val filter_inplace : ('a -> bool) -> 'a t -> unit val filteri : (key -> 'a -> bool) -> 'a t -> 'a t val filteri_inplace : (key -> 'a -> bool) -> 'a t -> unit val filter_map : (key -> 'a -> 'b option) -> 'a t -> 'b t val filter_map_inplace : (key -> 'a -> 'a option) -> 'a t -> unit val modify : key -> ('a -> 'a) -> 'a t -> unit val modify_def : 'a -> key -> ('a -> 'a) -> 'a t -> unit val modify_opt : key -> ('a option -> 'a option) -> 'a t -> unit val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t val merge_all : (key -> 'a list -> 'b list -> 'c list) -> 'a t -> 'b t -> 'c t val keys : 'a t -> key BatEnum.t val values : 'a t -> 'a BatEnum.t val enum : 'a t -> (key * 'a) BatEnum.t val to_list : 'a t -> (key * 'a) list val of_enum : (key * 'a) BatEnum.t -> 'a t val of_list : (key * 'a) list -> 'a t val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> key -> unit) -> ('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> 'b t -> unit (** {6 Override modules}*) (** The following modules replace functions defined in {!Hashtbl} with functions behaving slightly differently but having the same name. This is by design: the functions meant to override the corresponding functions of {!Hashtbl}. *) (** Operations on {!Hashtbl} without exceptions. @documents Hashtbl.S.Exceptionless*) module Exceptionless : sig val find : 'a t -> key -> 'a option val modify : key -> ('a -> 'a) -> 'a t -> (unit, exn) BatPervasives.result end (** Infix operators over a {!BatHashtbl} *) module Infix : sig val (-->) : 'a t -> key -> 'a (** [tbl-->x] returns the current binding of [x] in [tbl], or raises [Not_found] if no such binding exists. Equivalent to [Hashtbl.find tbl x]*) val (<--) : 'a t -> key * 'a -> unit (** [tbl<--(x, y)] adds a binding of [x] to [y] in table [tbl]. Previous bindings for [x] are not removed, but simply hidden. That is, after performing {!Hashtbl.remove}[ tbl x], the previous binding for [x], if any, is restored. (Same behavior as with association lists.) Equivalent to [Hashtbl.add tbl x y]*) end (** Operations on {!Hashtbl} with labels. This module overrides a number of functions of {!Hashtbl} by functions in which some arguments require labels. These labels are there to improve readability and safety and to let you change the order of arguments to functions. In every case, the behavior of the function is identical to that of the corresponding function of {!Hashtbl}. @documents Hashtbl.S.Labels *) module Labels : sig val add : 'a t -> key:key -> data:'a -> unit val replace : 'a t -> key:key -> data:'a -> unit val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit val map : f:(key:key -> data:'a -> 'b) -> 'a t -> 'b t val map_inplace : f:(key:key -> data:'a -> 'a) -> 'a t -> unit val filter : f:('a -> bool) -> 'a t -> 'a t val filter_inplace : f:('a -> bool) -> 'a t -> unit val filteri : f:(key:key -> data:'a -> bool) -> 'a t -> 'a t val filteri_inplace : f:(key:key -> data:'a -> bool) -> 'a t -> unit val filter_map : f:(key:key -> data:'a -> 'b option) -> 'a t -> 'b t val filter_map_inplace : f:(key:key -> data:'a -> 'a option) -> 'a t -> unit val fold : f:(key:key -> data:'a -> 'b -> 'b) -> 'a t -> init:'b -> 'b val modify : key:key -> f:('a -> 'a) -> 'a t -> unit val modify_def : default:'a -> key:key -> f:('a -> 'a) -> 'a t -> unit val modify_opt : key:key -> f:('a option -> 'a option) -> 'a t -> unit val merge : f:(key -> 'a option -> 'b option -> 'c option) -> left:'a t -> right:'b t -> 'c t val merge_all : f:(key -> 'a list -> 'b list -> 'c list) -> left:'a t -> right:'b t -> 'c t end end (** The output signature of the functor {!Hashtbl.Make}. *) module Make (H : HashedType) : S with type key = H.t (** Functor building an implementation of the hashtable structure. The functor [Hashtbl.Make] returns a structure containing a type [key] of keys and a type ['a t] of hash tables associating data of type ['a] to keys of type [key]. The operations perform similarly to those of the generic interface, but use the hashing and equality functions specified in the functor argument [H] instead of generic equality and hashing. *) (** Capabilities for hashtables. @documents Hashtbl.Cap *) module Cap : sig type ('a, 'b, 'c) t constraint 'c = [< `Read | `Write ] (** The type of a hashtable. *) (**{6 Constructors}*) val create : int -> ('a, 'b, _) t external of_table : ('a, 'b) Hashtbl.t -> ('a, 'b, _ ) t = "%identity" (** Adopt a regular hashtable as a capability hashtble, allowing to decrease capabilities if necessary. This operation involves no copying. In other words, in [let cap = of_table a in ...], any modification in [a] will also have effect on [cap] and reciprocally.*) external to_table : ('a, 'b, [`Read | `Write]) t -> ('a, 'b) Hashtbl.t = "%identity" (** Return a capability hashtable as a regular hashtable. This operation requires both read and write permissions on the capability table and involves no copying. In other words, in [let a = of_table cap in ...], any modification in [a] will also have effect on [cap] and reciprocally.*) external read_only : ('a, 'b, [>`Read]) t -> ('a, 'b, [`Read]) t = "%identity" (** Drop to read-only permissions. This operation involves no copying.*) external write_only : ('a, 'b, [>`Write]) t -> ('a, 'b, [`Write]) t = "%identity" (** Drop to write-only permissions. This operation involves no copying.*) (**{6 Base operations}*) val length : ('a, 'b, _) t -> int val is_empty : ('a, 'b, _) t -> bool val add : ('a, 'b, [>`Write]) t -> 'a -> 'b -> unit val remove : ('a, 'b, [>`Write]) t -> 'a -> unit val remove_all : ('a,'b, [>`Write]) t -> 'a -> unit val replace : ('a, 'b, [>`Write]) t -> 'a -> 'b -> unit val copy : ('a, 'b, [>`Read]) t -> ('a, 'b, _) t val clear : ('a, 'b, [>`Write]) t -> unit (**{6 Searching}*) val find : ('a, 'b, [>`Read]) t -> 'a -> 'b val find_all : ('a, 'b, [>`Read]) t -> 'a -> 'b list val find_default : ('a, 'b, [>`Read]) t -> 'a -> 'b -> 'b val find_option : ('a, 'b, [>`Read]) t -> 'a -> 'b option val mem : ('a, 'b, [>`Read]) t -> 'a -> bool (*val exists : ('a,'b) t -> 'a -> bool (** [exists h k] returns true is at least one item with key [k] is found in the hashtable. *)*) (**{6 Traversing}*) val iter : ('a -> 'b -> unit) -> ('a, 'b, [>`Read]) t -> unit val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b, [>`Read]) t -> 'c -> 'c val map : ('a -> 'b -> 'c) -> ('a, 'b, [>`Read]) t -> ('a, 'c, _) t val map_inplace : ('a -> 'b -> 'b) -> ('a, 'b, [>`Write]) t -> unit val filter : ('a -> bool) -> ('key, 'a, [>`Read]) t -> ('key, 'a, _) t val filter_inplace : ('a -> bool) -> ('key, 'a, [>`Write]) t -> unit val filteri : ('key -> 'a -> bool) -> ('key, 'a, [>`Read]) t -> ('key, 'a, _) t val filteri_inplace : ('key -> 'a -> bool) -> ('key, 'a, [>`Write]) t -> unit val filter_map : ('key -> 'a -> 'b option) -> ('key, 'a, [>`Read]) t -> ('key, 'b, _) t val filter_map_inplace : ('key -> 'a -> 'a option) -> ('key, 'a, [>`Write]) t -> unit val merge : ('key -> 'a option -> 'b option -> 'c option) -> ('key, 'a, [>`Read]) t -> ('key, 'b, [>`Read]) t -> ('key, 'c, _) t val merge_all : ('key -> 'a list -> 'b list -> 'c list) -> ('key, 'a, [>`Read]) t -> ('key, 'b, [>`Read]) t -> ('key, 'c, _) t (**{6 Conversions}*) val keys : ('a,'b, [>`Read]) t -> 'a BatEnum.t val values : ('a, 'b, [>`Read]) t -> 'b BatEnum.t val enum : ('a, 'b, [>`Read]) t -> ('a * 'b) BatEnum.t val of_enum : ('a * 'b) BatEnum.t -> ('a, 'b, _) t val to_list : ('a, 'b, [>`Read]) t -> ('a * 'b) list val of_list : ('a * 'b) list -> ('a, 'b, _) t (** {6 Boilerplate code}*) (** {7 Printing}*) val print : ?first:string -> ?last:string -> ?sep:string -> ?kvsep:string -> ('a BatInnerIO.output -> 'b -> unit) -> ('a BatInnerIO.output -> 'c -> unit) -> 'a BatInnerIO.output -> ('b, 'c, [>`Read]) t -> unit (** {6 Override modules}*) (** Operations on {!BatHashtbl.Cap} without exceptions.*) module Exceptionless : sig val find : ('a, 'b, [>`Read]) t -> 'a -> 'b option val modify : 'a -> ('b -> 'b) -> ('a, 'b, [>`Read]) t -> (unit, exn) BatPervasives.result end (** Operations on {!BatHashtbl.Cap} with labels.*) module Labels : sig val add : ('a, 'b, [>`Write]) t -> key:'a -> data:'b -> unit val replace : ('a, 'b, [>`Write]) t -> key:'a -> data:'b -> unit val iter : f:(key:'a -> data:'b -> unit) -> ('a, 'b, [>`Read]) t -> unit val map : f:(key:'a -> data:'b -> 'c) -> ('a, 'b, [>`Read]) t -> ('a, 'c, _) t val map_inplace : f:(key:'a -> data:'b -> 'b) -> ('a, 'b, [>`Write]) t -> unit val filter : f:('a -> bool) -> ('key, 'a, [>`Read]) t -> ('key, 'a, _) t val filter_inplace : f:('a -> bool) -> ('key, 'a, [>`Write]) t -> unit val filteri : f:(key:'key -> data:'a -> bool) -> ('key, 'a, [>`Read]) t -> ('key, 'a, _) t val filteri_inplace : f:(key:'key -> data:'a -> bool) -> ('key, 'a, [>`Write]) t -> unit val filter_map : f:(key:'key -> data:'a -> 'b option) -> ('key, 'a, [>`Read]) t -> ('key, 'b, _) t val filter_map_inplace : f:(key:'key -> data:'a -> 'a option) -> ('key, 'a, [>`Write]) t -> unit val fold : f:(key:'a -> data:'b -> 'c -> 'c) -> ('a, 'b, [>`Read]) t -> init:'c -> 'c val merge : f:('key -> 'a option -> 'b option -> 'c option) -> left:('key, 'a, [>`Read]) t -> right:('key, 'b, [>`Read]) t -> ('key, 'c, _) t val merge_all : f:('key -> 'a list -> 'b list -> 'c list) -> left:('key, 'a, [>`Read]) t -> right:('key, 'b, [>`Read]) t -> ('key, 'c, _) t end end (* Cap module *) batteries-included-3.4.0/src/batHashtbl.mlv000066400000000000000000000752361415601150500206630ustar00rootroot00000000000000(* * BatHashtbl, extra functions over hashtables. * Copyright (C) 1996 Xavier Leroy * 2003 Nicolas Cannasse * 2005 Damien Doligez * 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** {6 Import the contents of {!Hashtbl}} Note: We can't directly [include Hashtbl] as this would cause a collision on [Make]*) type ('a, 'b) t = ('a, 'b) Hashtbl.t let create s = Hashtbl.create s let clear = Hashtbl.clear let add = Hashtbl.add let copy = Hashtbl.copy let find = Hashtbl.find let find_all = Hashtbl.find_all let mem = Hashtbl.mem let remove = Hashtbl.remove let replace = Hashtbl.replace let iter = Hashtbl.iter let fold = Hashtbl.fold let hash = Hashtbl.hash type ('a, 'b) h_bucketlist = | Empty | Cons of 'a * 'b * ('a, 'b) h_bucketlist type ('a, 'b) h_t = { mutable size: int; mutable data: ('a, 'b) h_bucketlist array; ##V>=4## mutable seed: int; ##V>=4## initial_size: int; } external h_conv : ('a, 'b) t -> ('a, 'b) h_t = "%identity" external h_make : ('a, 'b) h_t -> ('a, 'b) t = "%identity" ##V>=4## let key_index h key = ##V>=4## if Obj.size (Obj.repr h) >= 3 ##V>=4## then Hashtbl.seeded_hash (h_conv h).seed key ##V>=4## land (Array.length (h_conv h).data - 1) ##V>=4## else (Hashtbl.hash key land max_int) mod (Array.length (h_conv h).data) ##V<4## let key_index h key = (Hashtbl.hash key land max_int) ##V<4## mod (Array.length (h_conv h).data) (* NOT EXPOSED let resize hashfun tbl = let odata = tbl.data in let osize = Array.length odata in let nsize = min (2 * osize + 1) Sys.max_array_length in if nsize <> osize then ( let ndata = Array.create nsize Empty in let rec insert_bucket = function Empty -> () | Cons(key, data, rest) -> insert_bucket rest; (* preserve original order of elements *) let nidx = (hashfun key) mod nsize in ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in for i = 0 to osize - 1 do insert_bucket odata.(i) done; tbl.data <- ndata; ) *) let enum h = let rec make ipos ibuck idata icount = let pos = ref ipos in let buck = ref ibuck in let hdata = ref idata in let hcount = ref icount in let force() = (* this is a hack in order to keep an O(1) enum constructor **) if !hcount = -1 then ( hcount := (h_conv h).size; hdata := Array.copy (h_conv h).data; ); in let rec next() = force(); match !buck with | Empty -> if !hcount = 0 then raise BatEnum.No_more_elements; incr pos; buck := Array.unsafe_get !hdata !pos; next() | Cons (k,i,next_buck) -> buck := next_buck; decr hcount; (k,i) in let count() = if !hcount = -1 then (h_conv h).size else !hcount in let clone() = force(); make !pos !buck !hdata !hcount in BatEnum.make ~next ~count ~clone in make (-1) Empty (Obj.magic()) (-1) let to_list ht = fold (fun k v acc -> (k, v) :: acc ) ht [] (*$T to_list let ht = create 1 in \ add ht 1 '2'; \ to_list ht = [(1, '2')] *) let of_list l = let res = create 11 in List.iter (fun (k, v) -> add res k v ) l; res (*$T of_list let l = [(1,2);(2,3);(3,4)] in \ List.sort compare (to_list (of_list l)) = l *) let bindings ht = to_list ht (*$T bindings let ht = create 1 in \ add ht 1 '2'; \ bindings ht = [(1, '2')] *) let keys h = BatEnum.map (fun (k,_) -> k) (enum h) let values h = BatEnum.map (fun (_,v) -> v) (enum h) let map f h = let rec loop = function | Empty -> Empty | Cons (k,v,next) -> Cons (k,f k v,loop next) in let hc = h_conv h in h_make { hc with data = Array.map loop hc.data; } (*$T map (* non regression test for bug #354 *) \ let h = create 20 and k = (0,5) in add h k 3 ; \ let h2 = map (fun _ v -> v) h in mem h2 k *) let map_inplace f h = let rec loop = function | Empty -> Empty | Cons (k, v, next) -> Cons (k, f k v, loop next) in BatArray.modify loop (h_conv h).data (* Helper functions to test hashtables which values are integers: *) (*$inject let (|>) x f = f x let printer = IO.to_string (List.print Int.print) let to_sorted_list h = values h |> List.of_enum |> List.sort Int.compare *) (*$= map_inplace & ~printer (let h = Enum.combine (1 -- 5) (1 -- 5) |> of_enum in \ map_inplace (fun _ x -> x+1) h ; \ to_sorted_list h) [2;3;4;5;6] *) let remove_all h key = let hc = h_conv h in let rec loop = function | Empty -> Empty | Cons(k,v,next) -> if k = key then ( hc.size <- pred hc.size; loop next ) else Cons(k,v,loop next) in let pos = key_index h key in Array.unsafe_set hc.data pos (loop (Array.unsafe_get hc.data pos)) let find_default h key defval = let rec loop = function | Empty -> defval | Cons (k,v,next) -> if k = key then v else loop next in let pos = key_index h key in loop (Array.unsafe_get (h_conv h).data pos) let find_option h key = let rec loop = function | Empty -> None | Cons (k,v,next) -> if k = key then Some v else loop next in let pos = key_index h key in loop (Array.unsafe_get (h_conv h).data pos) let of_enum e = let h = create (if BatEnum.fast_count e then BatEnum.count e else 0) in BatEnum.iter (fun (k,v) -> add h k v) e; h let length h = (h_conv h).size let is_empty h = length h = 0 exception Hashtbl_key_not_found let modify_opt key f h = let hc = h_conv h in let rec loop = function (* Inserting an element might require a resize of the hash table. We rely on Hashtbl.add function to grow the hashtbl if needed instead of duplicating logic from the OCaml standard library. *) | Empty -> raise Hashtbl_key_not_found | Cons(k,v,next) -> if k = key then match f (Some v) with | Some v -> Cons(key,v,next) | None -> hc.size <- pred hc.size; next else Cons(k,v,loop next) in try let pos = key_index h key in Array.unsafe_set hc.data pos (loop (Array.unsafe_get hc.data pos)) with | Hashtbl_key_not_found -> begin match f None with | None -> () | Some v -> (* Add the element to make sure the hashtbl is grown correctly if needed. *) add h key v end (*$T modify_opt let h = create 3 in \ modify_opt "foo" (function None -> Some 0 | _ -> assert false) h; \ length h = 1 && find_option h "foo" = Some 0 let h = create 3 in \ add h "foo" 1; \ modify_opt "foo" (function Some 1 -> None | _ -> assert false) h; \ length h = 0 && find_option h "foo" = None *) let modify key f h = let hc = h_conv h in let rec loop = function | Empty -> raise Not_found | Cons(k,v,next) -> if k = key then ( Cons(key,f v,next) ) else Cons(k,v,loop next) in let pos = key_index h key in Array.unsafe_set hc.data pos (loop (Array.unsafe_get hc.data pos)) (*$T modify let h = create 3 in \ add h "foo" 1; add h "bar" 2; \ modify "foo" succ h; \ values h |> List.of_enum = [ 2; 2 ] let h = create 3 in \ try modify "baz" succ h; false \ with Not_found -> true *) let modify_def v0 key f h = let f' = function | None -> Some (f v0) | Some v -> Some (f v) in modify_opt key f' h (*$T modify_def let h = create 3 in \ modify_def 0 "foo" succ h; \ length h = 1 && find_option h "foo" = Some 1 *) let print ?(first="{\n") ?(last="\n}") ?(sep=",\n") ?(kvsep=": ") print_k print_v out t = BatEnum.print ~first ~last ~sep (fun out (k,v) -> BatPrintf.fprintf out "%a%s%a" print_k k kvsep print_v v) out (enum t) let filteri (f:'key -> 'a -> bool) (t:('key, 'a) t) = let result = create 16 in iter (fun k a -> if f k a then add result k a) t; result let filteri_inplace f h = let hc = h_conv h in let rec loop = function | Empty -> Empty | Cons (k, v, next) -> if f k v then Cons (k, v, loop next) else ( hc.size <- pred hc.size ; loop next ) in BatArray.modify loop hc.data (*$= filteri_inplace & ~printer (let h = Enum.combine (1 -- 5) (1 -- 5) |> of_enum in \ filteri_inplace (fun _ x -> x>3) h ; \ to_sorted_list h) [4; 5] *) let filter f t = filteri (fun _k a -> f a) t let filter_inplace f h = filteri_inplace (fun _k a -> f a) h (*$= filter_inplace & ~printer:(IO.to_string (List.print Int.print)) (let h = Enum.combine (1 -- 5) (1 -- 5) |> of_enum in \ filter_inplace (fun x -> x>3) h ; \ to_sorted_list h) [4; 5] *) let filter_map f t = let result = create 16 in iter (fun k a -> match f k a with | None -> () | Some v -> add result k v) t; result let filter_map_inplace f h = let hc = h_conv h in let rec loop = function | Empty -> Empty | Cons (k, v, next) -> (match f k v with | None -> hc.size <- pred hc.size ; loop next | Some v' -> Cons (k, v', loop next)) in BatArray.modify loop hc.data (*$= filter_map_inplace & ~printer (let h = Enum.combine (1 -- 5) (1 -- 5) |> of_enum in \ filter_map_inplace (fun _ x -> if x>3 then Some (x+1) else None) h ; \ to_sorted_list h) [5; 6] *) let merge f h1 h2 = let res = create (max (length h1) (length h2)) in let may_add_res k v1 v2 = BatOption.may (add res k) (f k v1 v2) in iter (fun k v1 -> may_add_res k (Some v1) (find_option h2 k) ) h1 ; iter (fun k v2 -> if not (mem h1 k) then may_add_res k None (Some v2) ) h2 ; res (*$inject let union = merge (fun _ l r -> if l = None then r else l) let inter = merge (fun _ l r -> if l = None then l else r) let equal h1 h2 = to_sorted_list h1 = to_sorted_list h2 let empty = create 0 let h_1_5 = Enum.combine (1 -- 5) (1 -- 5) |> of_enum let h_1_3 = Enum.combine (1 -- 3) (1 -- 3) |> of_enum let h_3_5 = Enum.combine (3 -- 5) (3 -- 5) |> of_enum let of_uniq_list l = List.unique l |> List.map (fun i -> i, i) |> of_list *) (*$= merge & ~printer [] \ (merge (fun k _ _ -> Some k) empty empty |> to_sorted_list) [1; 2; 3; 4; 5] \ (merge (fun _ l _ -> l) h_1_5 empty |> to_sorted_list) [] \ (merge (fun _ _ r -> r) h_1_5 empty |> to_sorted_list) [] \ (merge (fun _ l _ -> l) empty h_1_5 |> to_sorted_list) [1; 2; 3; 4; 5] \ (merge (fun _ _ r -> r) empty h_1_5 |> to_sorted_list) [1; 2; 3] \ (let h = Enum.combine (3 -- 6) (13 -- 15) |> of_enum in \ merge (fun _ l _ -> l) h_1_3 h |> to_sorted_list) [13; 14; 15] \ (let h = Enum.combine (3 -- 5) (13 -- 15) |> of_enum in \ merge (fun _ _ r -> r) h_1_3 h |> to_sorted_list) [] \ (merge (fun _ _ _ -> None) h_1_3 h_3_5 |> to_sorted_list) *) (*$= union & ~printer [1; 2; 3; 4; 5] \ (union h_1_3 h_3_5 |> to_sorted_list) *) (*$= inter & ~printer [3] \ (inter h_1_3 h_3_5 |> to_sorted_list) *) (*$Q equal (Q.list Q.small_int) (fun l -> \ let h = of_uniq_list l in \ equal (inter h h) h) (Q.list Q.small_int) (fun l -> \ let h = of_uniq_list l in \ equal (union h h) h) (Q.list Q.small_int) (fun l -> \ let h = of_uniq_list l in \ equal (union h empty) h) (Q.list Q.small_int) (fun l -> \ let h = of_uniq_list l in \ equal (inter h empty) empty) (Q.pair (Q.list Q.small_int) (Q.list Q.small_int)) (fun (l1, l2) -> \ let h1 = of_uniq_list l1 and h2 = of_uniq_list l2 in \ equal (inter h1 h2) (inter h2 h1)) (Q.pair (Q.list Q.small_int) (Q.list Q.small_int)) (fun (l1, l2) -> \ let h1 = of_uniq_list l1 and h2 = of_uniq_list l2 in \ equal (union h1 h2) (union h2 h1)) *) let merge_all f h1 h2 = let res = create (max (length h1) (length h2)) in let may_add_res k v1 v2 = List.iter (add res k) (List.rev (f k v1 v2)) in iter (fun k _ -> let l1 = find_all h1 k and l2 = find_all h2 k in may_add_res k l1 l2 ) h1 ; iter (fun k _ -> match find_all h1 k with | [] -> let l2 = find_all h2 k in may_add_res k [] l2 | _ -> () (* done above *) ) h2 ; res (*$= merge_all & ~printer [] \ (let h1 = create 0 and h2 = create 0 in \ merge_all (fun k _ _ -> [k]) h1 h2 |> to_sorted_list) [1; 2; 3; 4; 5] \ (let h = create 0 in \ merge_all (fun _ l _ -> l) h_1_5 h |> to_sorted_list) [] \ (let h = create 0 in \ merge_all (fun _ _ r -> r) h_1_5 h |> to_sorted_list) [] \ (let h = create 0 in \ merge_all (fun _ l _ -> l) h h_1_5 |> to_sorted_list) [1; 2; 3; 4; 5] \ (let h = create 0 in \ merge_all (fun _ _ r -> r) h h_1_5 |> to_sorted_list) [1; 2; 3] \ (let h = Enum.combine (3 -- 6) (13 -- 15) |> of_enum in \ merge_all (fun _ l _ -> l) h_1_3 h |> to_sorted_list) [13; 14; 15] \ (let h = Enum.combine (3 -- 5) (13 -- 15) |> of_enum in \ merge_all (fun _ _ r -> r) h_1_3 h |> to_sorted_list) [] \ (merge_all (fun _ _ _ -> []) h_1_3 h_3_5 |> to_sorted_list) [2; 1] \ (let h1 = of_list [1, 1] in \ let h2 = copy h1 in \ Hashtbl.add h2 1 2 ;\ let h = merge_all (fun _ _ r -> r) h1 h2 in \ find_all h 1) *) module Exceptionless = struct let find = find_option let modify k f = BatPervasives.wrap (modify k f) end module Infix = struct let (-->) h k = find h k let (<--) h (k,v) = add h k v end module Labels = struct let label f = fun key data -> f ~key ~data let add e ~key ~data = add e key data let replace e ~key ~data = replace e key data let iter ~f e = iter (label f) e let map ~f e = map (label f) e let map_inplace ~f e = map_inplace (label f) e let filter ~f e = filter f e let filter_inplace ~f e = filter_inplace f e let filteri ~f e = filteri (label f) e let filteri_inplace ~f e = filteri_inplace (label f) e let filter_map ~f e = filter_map (label f) e let filter_map_inplace ~f e = filter_map_inplace (label f) e let fold ~f e ~init = fold (label f) e init let modify ~key ~f = modify key f let modify_def ~default ~key ~f = modify_def default key f let modify_opt ~key ~f = modify_opt key f let merge ~f ~left ~right = merge f left right let merge_all ~f ~left ~right = merge_all f left right end module type HashedType = Hashtbl.HashedType module type S = sig type key type 'a t val create : int -> 'a t val length : 'a t -> int val is_empty : 'a t -> bool val clear : 'a t -> unit val copy : 'a t -> 'a t val add : 'a t -> key -> 'a -> unit val remove : 'a t -> key -> unit val remove_all : 'a t -> key -> unit val find : 'a t -> key -> 'a val find_all : 'a t -> key -> 'a list val find_default : 'a t -> key -> 'a -> 'a val find_option : 'a t -> key -> 'a option val replace : 'a t -> key -> 'a -> unit val mem : 'a t -> key -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val map : (key -> 'b -> 'c) -> 'b t -> 'c t val map_inplace : (key -> 'a -> 'a) -> 'a t -> unit val filter : ('a -> bool) -> 'a t -> 'a t val filter_inplace : ('a -> bool) -> 'a t -> unit val filteri : (key -> 'a -> bool) -> 'a t -> 'a t val filteri_inplace : (key -> 'a -> bool) -> 'a t -> unit val filter_map : (key -> 'a -> 'b option) -> 'a t -> 'b t val filter_map_inplace : (key -> 'a -> 'a option) -> 'a t -> unit val modify : key -> ('a -> 'a) -> 'a t -> unit val modify_def : 'a -> key -> ('a -> 'a) -> 'a t -> unit val modify_opt : key -> ('a option -> 'a option) -> 'a t -> unit val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t val merge_all : (key -> 'a list -> 'b list -> 'c list) -> 'a t -> 'b t -> 'c t val keys : 'a t -> key BatEnum.t val values : 'a t -> 'a BatEnum.t val enum : 'a t -> (key * 'a) BatEnum.t val to_list: 'a t -> (key * 'a) list val of_enum : (key * 'a) BatEnum.t -> 'a t val of_list : (key * 'a) list -> 'a t val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> key -> unit) -> ('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> 'b t -> unit (** Operations on {!Hashtbl} without exceptions.*) module Exceptionless : sig val find : 'a t -> key -> 'a option val modify : key -> ('a -> 'a) -> 'a t -> (unit, exn) BatPervasives.result end (** Infix operators over a {!BatHashtbl} *) module Infix : sig val (-->) : 'a t -> key -> 'a (** [tbl-->x] returns the current binding of [x] in [tbl], or raises [Not_found] if no such binding exists. Equivalent to [Hashtbl.find tbl x]*) val (<--) : 'a t -> key * 'a -> unit (** [tbl<--(x, y)] adds a binding of [x] to [y] in table [tbl]. Previous bindings for [x] are not removed, but simply hidden. That is, after performing {!Hashtbl.remove}[ tbl x], the previous binding for [x], if any, is restored. (Same behavior as with association lists.) Equivalent to [Hashtbl.add tbl x y]*) end (** Operations on {!Hashtbl} with labels. This module overrides a number of functions of {!Hashtbl} by functions in which some arguments require labels. These labels are there to improve readability and safety and to let you change the order of arguments to functions. In every case, the behavior of the function is identical to that of the corresponding function of {!Hashtbl}. *) module Labels : sig val add : 'a t -> key:key -> data:'a -> unit val replace : 'a t -> key:key -> data:'a -> unit val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit val map : f:(key:key -> data:'a -> 'b) -> 'a t -> 'b t val map_inplace : f:(key:key -> data:'a -> 'a) -> 'a t -> unit val filter : f:('a -> bool) -> 'a t -> 'a t val filter_inplace : f:('a -> bool) -> 'a t -> unit val filteri : f:(key:key -> data:'a -> bool) -> 'a t -> 'a t val filteri_inplace : f:(key:key -> data:'a -> bool) -> 'a t -> unit val filter_map : f:(key:key -> data:'a -> 'b option) -> 'a t -> 'b t val filter_map_inplace : f:(key:key -> data:'a -> 'a option) -> 'a t -> unit val fold : f:(key:key -> data:'a -> 'b -> 'b) -> 'a t -> init:'b -> 'b val modify : key:key -> f:('a -> 'a) -> 'a t -> unit val modify_def : default:'a -> key:key -> f:('a -> 'a) -> 'a t -> unit val modify_opt : key:key -> f:('a option -> 'a option) -> 'a t -> unit val merge : f:(key -> 'a option -> 'b option -> 'c option) -> left:'a t -> right:'b t -> 'c t val merge_all : f:(key -> 'a list -> 'b list -> 'c list) -> left:'a t -> right:'b t -> 'c t end end module Make(H: HashedType): (S with type key = H.t) = struct include Hashtbl.Make(H) external to_hash : 'a t -> (key, 'a) Hashtbl.t = "%identity" external of_hash : (key, 'a) Hashtbl.t -> 'a t = "%identity" (* Warning: these two externals are unsafe, as they forget about the user-provided HashtedType implementation. They are used to avoid code duplication for functions that do *not* use the hashing function, but only traverse the bucket structure. *) (* type key = H.t type 'a hashtbl = (key, 'a) t type 'a t = 'a hashtbl let create = create let clear = clear let copy = copy let safehash key = (H.hash key) land max_int let add h key info = let h = h_conv h in let i = (safehash key) mod (Array.length h.data) in let bucket = Cons(key, info, h.data.(i)) in h.data.(i) <- bucket; h.size <- succ h.size; if h.size > Array.length h.data lsl 1 then resize safehash h let remove h key = let h = h_conv h in let rec remove_bucket = function Empty -> Empty | Cons(k, i, next) -> if H.equal k key then begin h.size <- pred h.size; next end else Cons(k, i, remove_bucket next) in let i = (safehash key) mod (Array.length h.data) in h.data.(i) <- remove_bucket h.data.(i) let rec find_rec key = function Empty -> raise Not_found | Cons(k, d, rest) -> if H.equal key k then d else find_rec key rest let find h key = let h = h_conv h in match h.data.((safehash key) mod (Array.length h.data)) with Empty -> raise Not_found | Cons(k1, d1, rest1) -> if H.equal key k1 then d1 else match rest1 with Empty -> raise Not_found | Cons(k2, d2, rest2) -> if H.equal key k2 then d2 else match rest2 with Empty -> raise Not_found | Cons(k3, d3, rest3) -> if H.equal key k3 then d3 else find_rec key rest3 let find_all h key = let rec find_in_bucket = function Empty -> [] | Cons(k, d, rest) -> if H.equal k key then d :: find_in_bucket rest else find_in_bucket rest in find_in_bucket h.data.((safehash key) mod (Array.length h.data)) let replace h key info = let rec replace_bucket = function Empty -> raise Not_found | Cons(k, i, next) -> if H.equal k key then Cons(k, info, next) else Cons(k, i, replace_bucket next) in let i = (safehash key) mod (Array.length h.data) in let l = h.data.(i) in try h.data.(i) <- replace_bucket l with Not_found -> h.data.(i) <- Cons(key, info, l); h.size <- succ h.size; if h.size > Array.length h.data lsl 1 then resize safehash h let mem h key = let rec mem_in_bucket = function | Empty -> false | Cons(k, d, rest) -> H.equal k key || mem_in_bucket rest in mem_in_bucket h.data.((safehash key) mod (Array.length h.data))*) let key_index h key = (H.hash key) land (Array.length (h_conv (to_hash h)).data - 1) let iter = iter let fold = fold let length = length (* the functions here do not hash values, they only traverse the buckets *) let enum h = enum (to_hash h) let to_list h = to_list (to_hash h) let values h = values (to_hash h) let keys h = keys (to_hash h) let map (f:key -> 'a -> 'b) h = of_hash (map f (to_hash h)) (* We can use polymorphic filteri since we do not use the key at all for inline ops *) let map_inplace (f:key -> 'a -> 'b) h = map_inplace f (to_hash h) let filteri_inplace f h = filteri_inplace f (to_hash h) let filter_inplace f h = filter_inplace f (to_hash h) ##V<4.3## let filter_map_inplace f h = filter_map_inplace f (to_hash h) (* these functions do need to hash values, so we cannot use {to,of}_hash *) let of_enum e = let tbl = create 11 in BatEnum.iter (fun (k, v) -> add tbl k v) e; tbl let of_list li = let tbl = create 11 in List.iter (fun (k, v) -> add tbl k v) li; tbl let find_option h key = let hc = h_conv (to_hash h) in let rec loop = function | Empty -> None | Cons (k,v,next) -> if H.equal k key then Some v else loop next in let pos = key_index h key in loop (Array.unsafe_get hc.data pos) let find_default h key defval = let hc = h_conv (to_hash h) in let rec loop = function | Empty -> defval | Cons (k,v,next) -> if H.equal k key then v else loop next in let pos = key_index h key in loop (Array.unsafe_get hc.data pos) let remove_all h key = let hc = h_conv (to_hash h) in let rec loop = function | Empty -> Empty | Cons(k,v,next) -> if H.equal k key then begin hc.size <- pred hc.size; loop next end else Cons(k,v,loop next) in let pos = key_index h key in Array.unsafe_set hc.data pos (loop (Array.unsafe_get hc.data pos)) let is_empty h = length h = 0 let print ?first ?last ?sep print_k print_v out t = print ?first ?last ?sep print_k print_v out (to_hash t) let filteri f t = let result = create 16 in iter (fun k a -> if f k a then add result k a) t; result let filter f t = filteri (fun _k a -> f a) t let filter_map f t = let result = create 16 in iter (fun k a -> match f k a with | None -> () | Some v -> add result k v) t; result let modify_opt key f h = let hc = h_conv (to_hash h) in let rec loop = function (* Inserting an element might require a resize of the hash table. We rely on Hashtbl.add function to grow the hashtbl if needed instead of duplicating logic from the OCaml standard library. *) | Empty -> raise Hashtbl_key_not_found | Cons(k,v,next) -> if H.equal k key then match f (Some v) with | Some v -> Cons(key,v,next) | None -> hc.size <- pred hc.size; next else Cons(k,v,loop next) in try let pos = key_index h key in Array.unsafe_set hc.data pos (loop (Array.unsafe_get hc.data pos)) with | Hashtbl_key_not_found -> begin match f None with | None -> () | Some v -> (* Add the element to make sure the hashtbl is grown correctly if needed. *) add h key v end let modify key f h = let hc = h_conv (to_hash h) in let rec loop = function | Empty -> raise Not_found | Cons(k,v,next) -> if H.equal k key then ( Cons(key,f v,next) ) else Cons(k,v,loop next) in let pos = key_index h key in Array.unsafe_set hc.data pos (loop (Array.unsafe_get hc.data pos)) let modify_def v0 key f h = let f' = function | None -> Some (f v0) | Some v -> Some (f v) in modify_opt key f' h let merge f a b = let res = create (max (length a) (length b)) in let may_add_res k v1 v2 = BatOption.may (add res k) (f k v1 v2) in iter (fun k v1 -> may_add_res k (Some v1) (find_option b k) ) a ; iter (fun k v2 -> if not (mem a k) then may_add_res k None (Some v2) ) b ; res let merge_all f a b = let res = create (max (length a) (length b)) in let may_add_res k v1 v2 = List.iter (add res k) (List.rev (f k v1 v2)) in iter (fun k _ -> let l1 = find_all a k and l2 = find_all b k in may_add_res k l1 l2 ) a ; iter (fun k _ -> match find_all a k with | [] -> let l2 = find_all b k in may_add_res k [] l2 | _ -> () (* done above *) ) b ; res module Labels = struct let label f = fun key data -> f ~key ~data let add e ~key ~data = add e key data let replace e ~key ~data = replace e key data let iter ~f e = iter (label f) e let map ~f e = map (label f) e let map_inplace ~f e = map_inplace (label f) e let filter ~f e = filter f e let filter_inplace ~f e = filter_inplace f e let filteri ~f e = filteri (label f) e let filteri_inplace ~f e = filteri_inplace (label f) e let filter_map ~f e = filter_map (label f) e let filter_map_inplace ~f e = filter_map_inplace (label f) e let fold ~f e ~init = fold (label f) e init let modify ~key ~f = modify key f let modify_def ~default ~key ~f = modify_def default key f let modify_opt ~key ~f = modify_opt key f let merge ~f ~left ~right = merge f left right let merge_all ~f ~left ~right = merge_all f left right end module Exceptionless = struct let find = find_option let modify k f = BatPervasives.wrap (modify k f) end module Infix = struct let (-->) h k = find h k let (<--) h (k,v) = add h k v end end module Cap = struct type ('a, 'b, 'c) t = ('a, 'b) Hashtbl.t constraint 'c = [< `Read | `Write ] let create = create external of_table : ('a, 'b) Hashtbl.t -> ('a, 'b, _ ) t = "%identity" external to_table : ('a, 'b, [`Read | `Write]) t -> ('a, 'b) Hashtbl.t = "%identity" external read_only : ('a, 'b, [>`Read]) t -> ('a, 'b, [`Read]) t = "%identity" external write_only : ('a, 'b, [>`Write]) t -> ('a, 'b, [`Write]) t = "%identity" let length = length let is_empty = is_empty let add = add let remove = remove let remove_all = remove_all let replace = replace let copy = copy let clear = clear let find = find let find_all = find_all let find_default= find_default let find_option = find_option let mem = mem let iter = iter let fold = fold let map = map let map_inplace = map_inplace let filter = filter let filter_inplace = filter_inplace let filteri = filteri let filteri_inplace = filteri_inplace let filter_map = filter_map let filter_map_inplace = filter_map_inplace let modify = modify let modify_def = modify_def let modify_opt = modify_opt let keys = keys let values = values let enum = enum let to_list = to_list let of_enum = of_enum let of_list = of_list let print = print let filter = filter let filteri = filteri let filter_map = filter_map let merge = merge let merge_all = merge_all module Labels = struct let label f = fun key data -> f ~key ~data let add e ~key ~data = add e key data let replace e ~key ~data = replace e key data let iter ~f e = iter (label f) e let map ~f e = map (label f) e let map_inplace ~f e = map_inplace (label f) e let filter ~f e = filter f e let filter_inplace ~f e = filter_inplace f e let filteri ~f e = filteri (label f) e let filteri_inplace ~f e = filteri_inplace (label f) e let filter_map ~f e = filter_map (label f) e let filter_map_inplace ~f e = filter_map_inplace (label f) e let fold ~f e ~init = fold (label f) e init let modify ~key ~f = modify key f let modify_def ~default ~key ~f = modify_def default key f let modify_opt ~key ~f = modify_opt key f let merge ~f ~left ~right = merge f left right let merge_all ~f ~left ~right = merge_all f left right end module Exceptionless = struct let find = find_option let modify k f = BatPervasives.wrap (modify k f) end end batteries-included-3.4.0/src/batHeap.ml000066400000000000000000000230721415601150500177540ustar00rootroot00000000000000(* * Heap -- binomial heaps * Copyright (C) 2011 Batteries Included Development Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) let min x y = if Pervasives.compare x y <= 0 then x else y (** binomial trees *) type 'a bt = { rank : int ; root : 'a ; kids : 'a bt list ; } type 'a t = { size : int ; data : 'a bt list ; mind : 'a option ; (** cached minimal element *) } let empty = { size = 0 ; data = [] ; mind = None } let size bh = bh.size let link bt1 bt2 = assert (bt1.rank = bt2.rank) ; let rank = bt1.rank + 1 in let leq = Pervasives.compare bt1.root bt2.root <= 0 in let root = if leq then bt1.root else bt2.root in let kids = if leq then bt2 :: bt1.kids else bt1 :: bt2.kids in { rank = rank ; root = root ; kids = kids } let rec add_tree t = function | [] -> [t] | (ut :: uts) as ts -> assert (t.rank <= ut.rank) ; if t.rank < ut.rank then t :: ts else add_tree (link t ut) uts let insert bh x = let size = bh.size + 1 in let data = add_tree { rank = 0 ; root = x ; kids = [] } bh.data in let mind = match bh.mind with | None -> Some x | Some mind -> Some (min x mind) in { size = size ; data = data ; mind = mind } (*$T size ; empty size (insert empty 3) = 1 size empty = 0 *) let add x bh = insert bh x (*$T find_min (add 3 (add 2 (add 1 empty))) = 1 *) let rec merge_data ts1 ts2 = match ts1, ts2 with | _, [] -> ts1 | [], _ -> ts2 | t1 :: tss1, t2 :: tss2 -> if t1.rank < t2.rank then t1 :: merge_data tss1 ts2 else if t1.rank > t2.rank then t2 :: merge_data ts1 tss2 else add_tree (link t1 t2) (merge_data tss1 tss2) let merge bh1 bh2 = let size = bh1.size + bh2.size in let data = merge_data bh1.data bh2.data in let mind = match bh1.mind, bh2.mind with | Some m1, Some m2 -> Some (min m1 m2) | m, None | None, m -> m in { size = size ; data = data ; mind = mind } (*$T merge (of_list [3;2]) (of_list [4;1]) |> to_list = [1;2;3;4] *) let find_min bh = match bh.mind with | None -> invalid_arg "find_min" | Some d -> d (*$T find_min ; insert ; empty find_min (insert (insert empty 3) 5) = 3 find_min (insert (insert empty 5) 3) = 3 *) let rec find_min_tree ts ~kfail ~ksuccess = match ts with | [] -> kfail () | [t] -> ksuccess t | t :: ts -> find_min_tree ts ~kfail ~ksuccess:(fun u -> if Pervasives.compare t.root u.root <= 0 then ksuccess t else ksuccess u) let rec del_min_tree bts ~kfail ~ksuccess = match bts with | [] -> kfail () | [t] -> ksuccess t [] | t :: ts -> del_min_tree ts ~kfail ~ksuccess:(fun u uts -> if Pervasives.compare t.root u.root <= 0 then ksuccess t ts else ksuccess u (t :: uts)) let del_min bh = let kfail () = invalid_arg "del_min" in del_min_tree bh.data ~kfail ~ksuccess:(fun bt data -> let size = bh.size - 1 in let data = merge_data (List.rev bt.kids) data in let mind = if size = 0 then None else Some (find_min_tree data ~kfail ~ksuccess:(fun t -> t)).root in { size; data; mind }) let of_list l = List.fold_left insert empty l let to_list bh = let rec aux acc bh = if size bh = 0 then acc else let m = find_min bh in let bh = del_min bh in aux (m :: acc) bh in List.rev (aux [] bh) (*$T to_list ; empty to_list (insert (insert empty 4) 6) = [4; 6] to_list (insert (insert empty 6) 4) = [4; 6] to_list empty = [] *) (*$Q to_list ; insert ; empty (Q.list Q.int) ~count:10 (fun l -> to_list (List.fold_left insert empty l) = List.sort Pervasives.compare l) *) let elems = to_list let print ?(first="[") ?(last="]") ?(sep="; ") elepr out bh = let rec spin bh = if size bh = 0 then () else if size bh = 1 then elepr out (find_min bh) else begin elepr out (find_min bh) ; BatInnerIO.nwrite out sep ; spin (del_min bh) end in BatInnerIO.nwrite out first ; spin bh ; BatInnerIO.nwrite out last let rec enum bh = let cur = ref bh in let next () = let bh = !cur in if size bh = 0 then raise BatEnum.No_more_elements ; cur := (del_min bh) ; find_min bh in let count () = size !cur in let clone () = enum !cur in BatEnum.make ~next ~count ~clone let of_enum e = BatEnum.fold insert empty e (*$Q (Q.list Q.small_int) (fun l -> \ of_list l |> enum |> List.of_enum = List.sort Int.compare l) *) module type H = sig type elem type t val empty : t val size : t -> int val insert : t -> elem -> t val add : elem -> t -> t val merge : t -> t -> t val find_min : t -> elem val del_min : t -> t val of_list : elem list -> t val to_list : t -> elem list val elems : t -> elem list val of_enum : elem BatEnum.t -> t val enum : t -> elem BatEnum.t val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> elem -> unit) -> 'a BatInnerIO.output -> t -> unit end module Make (Ord : BatInterfaces.OrderedType) = struct type elem = Ord.t let ord_min x y = if Ord.compare x y <= 0 then x else y type bt = { rank : int ; root : Ord.t ; kids : bt list ; } type t = { size : int ; data : bt list ; mind : Ord.t option ; } let empty = { size = 0 ; data = [] ; mind = None } let size bh = bh.size let link bt1 bt2 = assert (bt1.rank = bt2.rank) ; let rank = bt1.rank + 1 in let leq = Ord.compare bt1.root bt2.root <= 0 in let root = if leq then bt1.root else bt2.root in let kids = if leq then bt2 :: bt1.kids else bt1 :: bt2.kids in { rank = rank ; root = root ; kids = kids } let rec add_tree t = function | [] -> [t] | (ut :: uts) as ts -> assert (t.rank <= ut.rank) ; if t.rank < ut.rank then t :: ts else add_tree (link t ut) uts let insert bh x = let data = add_tree { rank = 0 ; root = x ; kids = [] } bh.data in let mind = match bh.mind with | None -> Some x | Some mind -> Some (ord_min x mind) in { size = bh.size + 1 ; data = data ; mind = mind } let add x bh = insert bh x let rec merge_data ts1 ts2 = match ts1, ts2 with | _, [] -> ts1 | [], _ -> ts2 | t1 :: tss1, t2 :: tss2 -> if t1.rank < t2.rank then t1 :: merge_data tss1 ts2 else if t1.rank > t2.rank then t2 :: merge_data ts1 tss2 else add_tree (link t1 t2) (merge_data tss1 tss2) let merge bh1 bh2 = let size = bh1.size + bh2.size in let data = merge_data bh1.data bh2.data in let mind = match bh1.mind, bh2.mind with | Some m1, Some m2 -> Some (ord_min m1 m2) | m, None | None, m -> m in { size = size ; data = data ; mind = mind } let find_min bh = match bh.mind with | None -> invalid_arg "find_min" | Some d -> d let rec find_min_tree ts ~kfail ~ksuccess = match ts with | [] -> kfail () | [t] -> ksuccess t | t :: ts -> find_min_tree ts ~kfail ~ksuccess:(fun u -> if Ord.compare t.root u.root <= 0 then ksuccess t else ksuccess u) let rec del_min_tree bts ~kfail ~ksuccess = match bts with | [] -> kfail () | [t] -> ksuccess t [] | t :: ts -> del_min_tree ts ~kfail ~ksuccess:(fun u uts -> if Ord.compare t.root u.root <= 0 then ksuccess t ts else ksuccess u (t :: uts)) let del_min bh = let kfail () = invalid_arg "del_min" in del_min_tree bh.data ~kfail ~ksuccess:(fun bt data -> let size = bh.size - 1 in let data = merge_data (List.rev bt.kids) data in let mind = if size = 0 then None else Some (find_min_tree data ~kfail ~ksuccess:(fun t -> t)).root in { size; data; mind }) let to_list bh = let rec aux acc bh = if size bh = 0 then acc else let m = find_min bh in let bh = del_min bh in aux (m :: acc) bh in List.rev (aux [] bh) let elems = to_list let of_list l = List.fold_left insert empty l let rec enum bh = let cur = ref bh in let next () = let bh = !cur in if size bh = 0 then raise BatEnum.No_more_elements ; cur := (del_min bh) ; find_min bh in let count () = size !cur in let clone () = enum !cur in BatEnum.make ~next ~count ~clone let of_enum e = BatEnum.fold insert empty e let print ?(first="[") ?(last="]") ?(sep="; ") elepr out bh = let rec spin bh = if size bh = 0 then () else if size bh = 1 then elepr out (find_min bh) else begin elepr out (find_min bh) ; BatInnerIO.nwrite out sep ; spin (del_min bh) end in BatInnerIO.nwrite out first ; spin bh ; BatInnerIO.nwrite out last end batteries-included-3.4.0/src/batHeap.mli000066400000000000000000000074221415601150500201260ustar00rootroot00000000000000(* * Heap -- binomial heaps * Copyright (C) 2011 Batteries Included Development Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Functional heaps over ordered types Ascribes to: [BatEnum.Enumerable with type 'a enumerable = 'a t] *) type +'a t (** Heap of elements that are compared with [Pervasives.compare]. *) val size : 'a t -> int (** Number of elements in the heap. O(1) *) (** {6 Construction} *) val empty : 'a t (** The empty heap. *) val insert : 'a t -> 'a -> 'a t (** Insert an element into the heap. Duplicates are kept. O(log m) *) val add : 'a -> 'a t -> 'a t (** [add x h] is the same as [insert h x]. This function is intended to be used with [fold_right]. *) (** {6 Operations} *) val merge : 'a t -> 'a t -> 'a t (** Merge two heaps. O(log m) *) val find_min : 'a t -> 'a (** Find the minimal element of the heap. O(1) @raise Invalid_argument ["find_min"] if the heap is empty *) val del_min : 'a t -> 'a t (** Delete the minimal element of the heap. O(log n) @raise Invalid_argument ["del_min"] if the heap is empty *) (** {6 Transformation} *) val of_list : 'a list -> 'a t (** Build a heap from a given list. O(n log n) *) val to_list : 'a t -> 'a list (** Enumerate the elements of the heap. O(n log n) *) val elems : 'a t -> 'a list (** @deprecated Same as [to_list]. *) val of_enum : 'a BatEnum.t -> 'a t (** Build a heap from an enumeration. Consumes the enumeration. O(n log n) *) val enum : 'a t -> 'a BatEnum.t (** Enumerate the elements of the heap in heap order. O(log n) per {!BatEnum.get}. *) (** {6 Printing} *) val print : ?first:string -> ?last:string -> ?sep:string -> ('a, 'b) BatIO.printer -> ('a t, 'b) BatIO.printer (** Print the contents of the heap in heap order. O(n log n) *) (** {6 Functorized version} *) (** The result of {!Make} *) module type H = sig type elem (** Type of elements of the heap *) type t (** Type of the heap *) val empty : t (** See {!BatHeap.empty}. *) val size : t -> int (** See {!BatHeap.size}. *) val insert : t -> elem -> t (** See {!BatHeap.add}. *) val add : elem -> t -> t (** See {!BatHeap.insert}. *) val merge : t -> t -> t (** See {!BatHeap.merge}. *) val find_min : t -> elem (** See {!BatHeap.find_min}. *) val del_min : t -> t (** See {!BatHeap.del_min}. *) val of_list : elem list -> t (** See {!BatHeap.of_list}. *) val to_list : t -> elem list (** See {!BatHeap.to_list}. *) val elems : t -> elem list (** @deprecated Same as [to_list]. *) val of_enum : elem BatEnum.t -> t (** See {!BatHeap.of_enum}. *) val enum : t -> elem BatEnum.t (** See {!BatHeap.enum}. *) val print : ?first:string -> ?last:string -> ?sep:string -> (elem, 'a) BatIO.printer -> (t, 'a) BatIO.printer (** See {!BatHeap.print}. *) end module Make (Ord : BatInterfaces.OrderedType) : H with type elem = Ord.t (** Functorized heaps over arbitrary orderings. All the functions have the same complexity as the non-functorized versions. *) batteries-included-3.4.0/src/batIMap.ml000066400000000000000000000332221415601150500177230ustar00rootroot00000000000000(* Copyright 2003 Yamagata Yoriyuki. distributed with LGPL *) (* Modified by Edgar Friendly *) module Core = struct type 'a t = (int * int * 'a) BatAvlTree.tree include BatAvlTree let singleton n v = singleton_tree (n, n, v) let make eq l (n1, n2, v) r = let n1, l = if is_empty l || n1 = min_int then n1, empty else let (k1, k2, v0), l' = split_rightmost l in if k2 + 1 = n1 && eq v v0 then k1, l' else n1, l in let n2, r = if is_empty r || n2 = max_int then n2, empty else let (k1, k2, v0), r' = split_leftmost r in if n2 + 1 = k1 && eq v v0 then k2, r' else n2, r in make_tree l (n1, n2, v) r let rec add ?(eq = (==)) n v m = if is_empty m then make_tree empty (n, n, v) empty else let (n1, n2, v0) as x = root m in let l = left_branch m in let r = right_branch m in if n1 <> min_int && n = n1 - 1 && eq v v0 then make eq l (n, n2, v) r else if n < n1 then make_tree (add n v l) x r else if n1 <= n && n <= n2 then if eq v v0 then m else let l = if n1 = n then l else make_tree l (n1, n - 1, v0) empty in let r = if n2 = n then r else make_tree empty (n + 1, n2, v0) r in make eq l (n, n, v) r else if n2 <> max_int && n = n2 + 1 && eq v v0 then make eq l (n1, n, v) r else make_tree l x (add n v r) let rec from n s = if is_empty s then empty else let (n1, n2, v) as x = root s in let s0 = left_branch s in let s1 = right_branch s in if n < n1 then make_tree (from n s0) x s1 else if n > n2 then from n s1 else make_tree empty (n, n2, v) s1 let after n s = if n = max_int then empty else from (n + 1) s let rec until n s = if is_empty s then empty else let (n1, n2, v) as x = root s in let s0 = left_branch s in let s1 = right_branch s in if n > n2 then make_tree s0 x (until n s1) else if n < n1 then until n s0 else make_tree s0 (n1, n, v) empty let before n s = if n = min_int then empty else until (n - 1) s let add_range ?(eq=(==)) n1 n2 v s = if n1 > n2 then invalid_arg "IMap.add_range" else make eq (before n1 s) (n1, n2, v) (after n2 s) let rec find (n:int) m = if is_empty m then raise Not_found else let (n1, n2, v) = root m in if n < n1 then find n (left_branch m) else if n1 <= n && n <= n2 then v else find n (right_branch m) let modify_opt ?(eq=(==)) (n:int) f m = let rec aux m = if is_empty m then match f None with | Some v -> singleton n v | None -> raise Exit else let (n1, n2, v) = root m in if n < n1 then make_tree (aux (left_branch m)) (n1, n2, v) (right_branch m) else if n > n2 then make_tree (left_branch m) (n1, n2, v) (aux (right_branch m)) else match f (Some v) with | None -> concat (left_branch m) (right_branch m) | Some v' -> if eq v' v then raise Exit (* fast exit *) else if n = n1 && n = n2 then (* no need to rebalance *) create (left_branch m) (n, n, v') (right_branch m) else let l = if n = n1 then left_branch m else add_range ~eq n1 (n-1) v (left_branch m) and r = if n = n2 then right_branch m else add_range ~eq (n+1) n2 v (right_branch m) in make_tree l (n, n, v') r in try aux m with Exit -> m let modify ?(eq=(==)) (n:int) f m = let f' = function | Some v -> Some (f v) | None -> raise Not_found in modify_opt ~eq n f' m let modify_def v0 ?(eq=(==)) (n:int) f m = let f' = function | Some v -> Some (f v) | None -> Some (f v0) in modify_opt ~eq n f' m let rec remove n m = if is_empty m then empty else let (n1, n2, v) as x = root m in let l = left_branch m in let r = right_branch m in if n < n1 then make_tree (remove n l) x r else if n1 = n then if n2 = n then concat l r else make_tree l (n + 1, n2, v) r else if n1 < n && n < n2 then make_tree (make_tree l (n1, n - 1, v) empty) (n + 1, n2, v) r else if n = n2 then make_tree l (n1, n - 1, v) r else make_tree l x (remove n r) let remove_range n1 n2 m = if n1 > n2 then invalid_arg "IMap.remove_range" else concat (before n1 m) (after n2 m) let rec mem (n:int) m = if is_empty m then false else let (n1, n2, _) = root m in if n < n1 then mem n (left_branch m) else if n1 <= n && n <= n2 then true else mem n (right_branch m) let iter_range proc m = BatAvlTree.iter (fun (n1, n2, v) -> proc n1 n2 v) m let fold_range f m a = BatAvlTree.fold (fun (n1, n2, v) a -> f n1 n2 v a) m a let fold f m a = let rec loop n1 n2 v a = let a = f n1 v a in if n1 = n2 then a else loop (n1 + 1) n2 v a in fold_range loop m a let iter proc m = fold (fun n v () -> proc n v) m () let rec map ?(eq=(=)) f m = if is_empty m then empty else let n1, n2, v = root m in let l = map ~eq f (left_branch m) in let r = map ~eq f (right_branch m) in let v = f v in make eq l (n1, n2, v) r let mapi ?eq f m = fold (fun n v a -> add ?eq n (f n v) a) m empty let rec map_range ?(eq=(=)) f m = if is_empty m then empty else let n1, n2, v = root m in let l = map_range ~eq f (left_branch m) in let r = map_range ~eq f (right_branch m) in let v = f n1 n2 v in make eq l (n1, n2, v) r let rec set_to_map s v = if is_empty s then empty else let (n1, n2) = root s in let l = left_branch s in let r = right_branch s in make_tree (set_to_map l v) (n1, n2, v) (set_to_map r v) let domain m = if is_empty m then empty else let (k1, k2, _), m' = split_leftmost m in let f n1 n2 _ (k1, k2, s) = if n1 = k2 + 1 then (k1, n2, s) else (n1, n2, make_tree s (k1, k2) empty) in let k1, k2, s = fold_range f m' (k1, k2, empty) in make_tree s (k1, k2) empty let map_to_set p m = let rec loop m = if is_empty m then None else let (k1, k2, v), m' = split_leftmost m in if p v then Some (k1, k2, m') else loop m' in match loop m with Some (k1, k2, m') -> let f n1 n2 v (k1, k2, s) = if p v then if n1 = k2 + 1 then (k1, n2, s) else (n1, n2, make_tree s (k1, k2) empty) else (k1, k2, s) in let (k1, k2, s) = fold_range f m' (k1, k2, empty) in make_tree s (k1, k2) empty | None -> empty module Enum = BatEnum (* Fold across two maps *) let fold2_range f m1 m2 acc = let e1 = enum m1 and e2 = enum m2 in let rec aux acc = function None,None -> acc | Some (lo,hi,rx), None -> aux (f lo hi (Some rx) None acc) (Enum.get e1, None) | None, Some (lo,hi,rx) -> aux (f lo hi None (Some rx) acc) (None, Enum.get e2) | Some (lo1,hi1,rx1), Some (lo2,hi2,rx2) when lo1 < lo2 -> let hi, v1 = if hi1 > lo2 then lo2-1, Some (lo2,hi1,rx1) else if hi1 = lo2 then hi1, Some (lo2,lo2,rx1) else hi1, Enum.get e1 and v2 = Some (lo2,hi2,rx2) in aux (f lo1 hi (Some rx1) None acc) (v1, v2) | Some (lo1,hi1,rx1), Some (lo2,hi2,rx2) when lo2 < lo1 -> let hi, v2 = if hi2 > lo1 then lo1-1, Some (lo1,hi2,rx2) else if hi2 = lo1 then hi2, Some (lo1,lo1,rx2) else hi2, Enum.get e2 and v1 = Some (lo1,hi1,rx1) in aux (f lo2 hi None (Some rx2) acc) (v1,v2) | Some (lo1,hi1,rx1), Some (_lo2,hi2,rx2) (* lo1 = lo2 *) -> let hi, v1, v2 = if hi1 = hi2 then hi1, Enum.get e1, Enum.get e2 else if hi1 < hi2 then hi1, Enum.get e1, Some (hi1+1,hi2,rx2) else (* hi2 < hi1 *) hi2, Some (hi2+1,hi1,rx1), Enum.get e2 in (* printf "#@%a\n" print_rng (lo1, hi); *) aux (f lo1 hi (Some rx1) (Some rx2) acc) (v1, v2) in aux acc (Enum.get e1, Enum.get e2) let union ~eq f m1 m2 = let insert lo hi v1 v2 m = match v1, v2 with | Some v1, Some v2 -> add_range ~eq lo hi (f v1 v2) m | Some x, None | None, Some x -> add_range ~eq lo hi x m | None, None -> assert false in fold2_range insert m1 m2 empty let merge ~eq f m1 m2 = let insert lo hi v1 v2 m = match f lo hi v1 v2 with None -> m | Some v -> add_range ~eq lo hi v m in fold2_range insert m1 m2 empty let forall2_range f m1 m2 = let e1 = enum m1 and e2 = enum m2 in let rec aux = function None,None -> true | Some (lo,hi,rx), None -> (f lo hi (Some rx) None) && aux (Enum.get e1, None) | None, Some (lo,hi,rx) -> (f lo hi None (Some rx)) && aux (None, Enum.get e2) | Some (lo1,hi1,rx1), Some (lo2,hi2,rx2) when lo1 < lo2 -> let hi, v1 = if hi1 > lo2 then lo2-1, Some (lo2,hi1,rx1) else hi1, Enum.get e1 and v2 = Some (lo2,hi2,rx2) in (f lo1 hi (Some rx1) None) && aux (v1, v2) | Some (lo1,hi1,rx1), Some (lo2,hi2,rx2) when lo2 < lo1 -> let hi, v2 = if hi2 > lo1 then lo1-1, Some (lo1,hi2,rx2) else hi2, Enum.get e2 and v1 = Some (lo1,hi1,rx1) in (f lo2 hi None (Some rx2)) && aux (v1,v2) | Some (lo1,hi1,rx1), Some (_,hi2,rx2) (* lo1 = lo2 *) -> let hi, v1, v2 = if hi1 = hi2 then hi1, Enum.get e1, Enum.get e2 else if hi1 < hi2 then hi1, Enum.get e1, Some (hi1+1,hi2,rx2) else (* hi2 < hi1 *) hi2, Some (hi2+1,hi1,rx1), Enum.get e2 in (f lo1 hi (Some rx1) (Some rx2)) && aux (v1, v2) in aux (Enum.get e1, Enum.get e2) end type 'a t = {m: 'a Core.t; eq: 'a -> 'a -> bool} type key = int let empty ~eq = {m = Core.empty; eq} (*$T empty is_empty (empty ~eq:(=)) *) let singleton ~eq x y = {m = Core.singleton x y; eq} (*$T singleton not (is_empty (singleton ~eq:(=) 1 'x')) find 1 (singleton ~eq:(=) 1 'x') = 'x' try ignore(find 0 (singleton ~eq:(=) 1 'x')); false with Not_found -> true *) let is_empty {m; _} = Core.is_empty m let add x y {m;eq} = {m=Core.add ~eq x y m; eq} (*$= add as a & ~cmp:(List.eq (Tuple3.eq Int.equal Int.equal Int.equal)) ~printer:(List.print (Tuple3.print Int.print Int.print Int.print) |> IO.to_string) [(0,2,0)] (empty ~eq:(=) |> a 0 0 |> a 2 0 |> a 1 0 |> enum |> List.of_enum) *) (*$= add as a & ~cmp:(List.eq (Tuple3.eq Int.equal Int.equal String.equal)) ~printer:(List.print (Tuple3.print Int.print Int.print String.print) |> IO.to_string) [(0,2,"foo")] \ (empty ~eq:(=) |> a 0 "foo" |> a 2 "foo" |> a 1 "foo" |> enum |> List.of_enum) *) let add_range lo hi y {m;eq} = {m=Core.add_range ~eq lo hi y m; eq} let find x {m; _} = Core.find x m let modify x f {m;eq} = {m=Core.modify ~eq x f m; eq} (*$T modify (* modify a single entry *) \ empty ~eq:(=) |> add 1 1 |> modify 1 succ |> find 1 = 2 (* modify a range boundary *) \ empty ~eq:(=) |> add_range 1 5 1 |> modify 1 succ |> find 1 = 2 empty ~eq:(=) |> add_range 1 5 1 |> modify 1 succ |> find 2 = 1 empty ~eq:(=) |> add_range 1 5 1 |> modify 1 succ |> find 5 = 1 (* modify a range boundary (the other one) *) \ empty ~eq:(=) |> add_range 1 5 1 |> modify 5 succ |> find 1 = 1 empty ~eq:(=) |> add_range 1 5 1 |> modify 5 succ |> find 4 = 1 empty ~eq:(=) |> add_range 1 5 1 |> modify 5 succ |> find 5 = 2 (* modify a range in the middle *) \ empty ~eq:(=) |> add_range 1 5 1 |> modify 2 succ |> find 1 = 1 empty ~eq:(=) |> add_range 1 5 1 |> modify 2 succ |> find 2 = 2 empty ~eq:(=) |> add_range 1 5 1 |> modify 2 succ |> find 3 = 1 empty ~eq:(=) |> add_range 1 5 1 |> modify 2 succ |> find 5 = 1 *) let modify_def v0 x f {m;eq} = {m=Core.modify_def ~eq v0 x f m; eq} (*$T modify_def (* adding an entry *) \ empty ~eq:(=) |> modify_def 0 1 succ |> find 1 = 1 *) let modify_opt x f {m;eq} = {m=Core.modify_opt ~eq x f m; eq} (*$T modify_opt (* adding an entry *) \ empty ~eq:(=) |> modify_opt 1 (function None -> Some 1 | _ -> assert false) |> find 1 = 1 (* deleting an entry *) \ empty ~eq:(=) |> add 1 1 |> modify_opt 1 (function Some 1 -> None | _ -> assert false) |> mem 1 |> not *) let remove x {m;eq} = {m=Core.remove x m; eq} let remove_range lo hi {m;eq} = {m=Core.remove_range lo hi m; eq} let from x {m;eq} = {m=Core.from x m; eq} let after x {m;eq} = {m=Core.after x m; eq} let until x {m;eq} = {m=Core.until x m; eq} let before x {m;eq} = {m=Core.before x m; eq} let mem x {m; _} = Core.mem x m let iter f {m; _} = Core.iter f m let iter_range f {m; _} = Core.iter_range f m let map ?(eq=(=)) f {m; _} = {m=Core.map ~eq f m; eq} let mapi ?(eq=(=)) f {m; _} = {m=Core.mapi ~eq f m; eq} let map_range ?(eq=(=)) f {m; _} = {m = Core.map_range ~eq f m; eq} let fold f {m; _} x0 = Core.fold f m x0 let fold_range f {m; _} x0 = Core.fold_range f m x0 let set_to_map ?(eq=(=)) s x = {m = Core.set_to_map s x; eq} let domain {m; _} = Core.domain m let map_to_set f {m; _} = Core.map_to_set f m let enum {m; _} = Core.enum m let fold2_range f {m=m1; _} {m=m2; _} x0 = Core.fold2_range f m1 m2 x0 let union f {m=m1;eq} {m=m2; _} = {m=Core.union ~eq f m1 m2; eq} let merge ?(eq=(=)) f {m=m1; _} {m=m2; _} = {m=Core.merge ~eq f m1 m2; eq} let forall2_range f {m=m1; _} {m=m2; _} = Core.forall2_range f m1 m2 let get_dec_eq {eq; _} = eq (*$T get_dec_eq get_dec_eq (empty ~eq:Int.equal) == Int.equal *) let of_enum ~eq e = BatEnum.fold (fun t (n1, n2, v) -> add_range n1 n2 v t) (empty ~eq) e module Infix = struct let (-->) {m; _} k = Core.find k m let (<--) m (k,v) = add k v m end batteries-included-3.4.0/src/batIMap.mli000066400000000000000000000136331415601150500201000ustar00rootroot00000000000000(* $Id: iMap.mli,v 1.1 2003/12/19 17:24:34 yori Exp $ *) (* Copyright 2003 Yamagata Yoriyuki. distributed with LGPL *) (* Modified by Edgar Friendly *) (** DIET Maps from integers, packed using ranges *) (* Note: Lost covariance with use of record for keeping eq *) type 'a t (*= (int * int * 'a) BatAvlTree.tree*) type key = int val empty : eq:('a -> 'a -> bool) -> 'a t (** The empty map. Needs one parameter: a comparison function for the values, to enable merging of ranges with identical values. *) val singleton : eq:('a -> 'a -> bool) -> int -> 'a -> 'a t val is_empty : 'a t -> bool (** Test whether a map is empty (i.e. has no bindings) *) val add : int -> 'a -> 'a t -> 'a t (** [add x y t] adds a binding from [x] to [y] in [t], returning a new map. *) val add_range : int -> int -> 'a -> 'a t -> 'a t (** [add_range lo hi y t] adds bindings to [y] for all values in the range [lo,hi], returning a new map *) val find : int -> 'a t -> 'a (** [find x t] returns the [y] that is bound to [x] in [t]. @raise Not_found if [x] is unbound *) val modify : int -> ('a -> 'a) -> 'a t -> 'a t (** [modify x f t] replaces the [y] that is bound to [x] in [t] by [f y]. @raise Not_found if [x] is unbound @since 2.1 *) val modify_def : 'a -> int -> ('a -> 'a) -> 'a t -> 'a t (** [modify_def dft x f t] does the same as [modify x f t] but binds [x] to [f dft] if [x] was not bound. @since 2.1 *) val modify_opt : int -> ('a option -> 'a option) -> 'a t -> 'a t (** [modify_opt x f t] allows to modify the binding for [x] in [t] or absence thereof. @since 2.1 *) val remove : int -> 'a t -> 'a t (** Remove any bindings from the given value. *) val remove_range : int -> int -> 'a t -> 'a t (** Remove any bindings within the given range *) val from : int -> 'a t -> 'a t (** Return the sub-map of bindings in the range [x,max_int] *) val after : int -> 'a t -> 'a t (** Return the sub-map of bindings in the range [x+1,max_int] *) val until : int -> 'a t -> 'a t (** Return the sub-map of bindings in the range [min_int, x] *) val before : int -> 'a t -> 'a t (** Return the sub-map of bindings in the range [min_int, x-1] *) val mem : int -> 'a t -> bool (** Test whether there is a binding from the given int *) val iter : (int -> 'a -> unit) -> 'a t -> unit (** [iter f t] calls [f] on every binding *) val iter_range : (int -> int -> 'a -> unit) -> 'a t -> unit (** [iter_range f t] calls [f] on every contiguous range. For maps, contiguous ranges must map to the same [y] *) val map : ?eq:('b -> 'b -> bool) -> ('a -> 'b) -> 'a t -> 'b t (** Create a new map by modifying each [y] by the given function. This will not create new ranges; the mapping function is only applied to each contiguous range once. It is not applied to the ranges in order. [~eq] defaults to (=). *) val mapi : ?eq:('b -> 'b -> bool) -> (int -> 'a -> 'b) -> 'a t -> 'b t (** Create a new map by computing new values based on key and value of the existing bindings. This can create new ranges, as adjacent bindings can be assigned different values. [~eq] defaults to (=). *) val map_range : ?eq:('b -> 'b -> bool) -> (int -> int -> 'a -> 'b) -> 'a t -> 'b t (** Create a new map by modifying each [y] using the given function. This will not create new ranges, but will have access to the [lo,hi] of the current range. [~eq] defaults to (=). *) val fold : (int -> 'b -> 'a -> 'a) -> 'b t -> 'a -> 'a (** [fold f t x0] folds all the bindings of [t] into [x0] using [f] to merge. *) val fold_range : (int -> int -> 'b -> 'a -> 'a) -> 'b t -> 'a -> 'a (** [fold_range f t x0] folds all the contiguous ranges of [t] into [x0] using [f] to merge. The order of foldings is unspecified.*) val set_to_map : ?eq:('a -> 'a -> bool) -> BatISet.t -> 'a -> 'a t (** [set_to_map s x] returns a map where every element of [s] is bound to [x]. *) val domain : 'a t -> BatISet.t (** [domain t] returns the set of ints that are bound in [t] *) val map_to_set : ('a -> bool) -> 'a t -> BatISet.t (** [map_to_set p t] returns the set of keys of [t] where [p] evaluates as true *) val enum : 'a t -> (int * int * 'a) BatEnum.t (** [enum t] returns an enumeration of the bindings in [t] *) val of_enum : eq:('a -> 'a -> bool) -> (int * int * 'a) BatEnum.t -> 'a t (** [of_enum e] returns the set of given ranges *) val fold2_range : (int -> int -> 'a option -> 'b option -> 'c -> 'c) -> 'a t -> 'b t -> 'c -> 'c (** [fold2_range f t u x0] folds across each range that's defined in either [t] or [u] or both, giving that range and the possible values to [f] to merge with [x0]. Example: let union_first = fold2_range (fun _lo _hi a b = match a,b with Some x,_ -> x | _,Some y -> y) *) val union : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t (** Merge two maps, giving a value *) val merge : ?eq:('c -> 'c -> bool) -> (int -> int -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t val forall2_range : (int -> int -> 'a option -> 'b option -> bool) -> 'a t -> 'b t -> bool (** Get the equality function used in an IMap.t *) val get_dec_eq : 'a t -> ('a -> 'a -> bool) (** Infix operators over a {!BatIMap} *) module Infix : sig val (-->) : 'a t -> int -> 'a (** [map-->key] returns the current binding of [key] in [map], or @raise Not_found if no such binding exists. Equivalent to [find key map]. *) val (<--) : 'a t -> int * 'a -> 'a t (** [map<--(key, value)] returns a map containing the same bindings as [map], plus a binding of [key] to [value]. If [key] was already bound in [map], its previous binding disappears. Equivalent to [add key value map] {b Important warning}: {!BatIMap.add} takes an optional argument, [eq] that is missing in this operator [<--]. As a consequence, using [<--] implies the use of {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Pervasives.html#VAL(==)}Pervasives.(==)} as comparison function. *) end batteries-included-3.4.0/src/batIO.ml000066400000000000000000000525611415601150500174130ustar00rootroot00000000000000(* * BatIO - Abstract input/output * Copyright (C) 2003 Nicolas Cannasse * 2008 David Teller (contributor) * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) include BatInnerIO external noop : unit -> unit = "%ignore" external default_close : unit -> unit = "%ignore" type ('a, 'b) printer = 'b output -> 'a -> unit type 'a f_printer = Format.formatter -> 'a -> unit let pos_in i = let p = ref 0 in (wrap_in ~read:(fun () -> let c = read i in incr p; c ) ~input:(fun s sp l -> let n = input i s sp l in p := !p + n; n ) ~close:noop ~underlying:[i] , (fun () -> !p)) let pos_out o = let p = ref 0 in (wrap_out ~write:(fun c -> write o c; incr p ) ~output:(fun s sp l -> let n = output o s sp l in p := !p + n; n ) ~close:noop ~flush:(fun () -> flush o) ~underlying:[o] , fun () -> !p) let progress_in inp f = wrap_in ~read: (fun () -> let c = read inp in f(); c) ~input:(fun s i l -> let r = input inp s i l in f(); r) ~close:ignore ~underlying:[inp] let progress_out out f = wrap_out ~write:(fun c -> write out c; f()) ~output:(fun s i l -> let r = output out s i l in f(); r) ~close:ignore ~flush:(fun () -> flush out) ~underlying:[out] (** {6 Support for enumerations} *) (*Function inlined here to avoid circular dependencies between [BatIO] and [ExtString].*) let string_enum s = let l = String.length s in let rec make i = BatEnum.make ~next:(fun () -> if !i = l then raise BatEnum.No_more_elements else let p = !i in incr i; String.unsafe_get s p ) ~count:(fun () -> l - !i) ~clone:(fun () -> make (ref !i)) in make (ref 0) let input_enum e = let pos = ref 0 in create_in ~read:(fun () -> match BatEnum.get e with | None -> raise No_more_input | Some c -> incr pos; c ) ~input:(fun s p l -> let rec loop p l = if l = 0 then 0 else match BatEnum.get e with | None -> l | Some c -> Bytes.unsafe_set s p c; loop (p + 1) (l - 1) in let k = loop p l in if k = l then raise No_more_input; l - k ) ~close:default_close let output_enum() = let b = Buffer.create default_buffer_size in create_out ~write:(fun x -> Buffer.add_char b x ) ~output:(fun s p l -> BatBytesCompat.buffer_add_subbytes b s p l; l ) ~close:(fun () -> let s = Buffer.contents b in string_enum s ) ~flush:default_close (** [apply_enum f x] applies [f] to [x] and converts exceptions [No_more_input] and [Input_closed] to [BatEnum.No_more_elements]*) let apply_enum do_close f x = try f x with | No_more_input -> raise BatEnum.No_more_elements | Input_closed -> do_close := false; raise BatEnum.No_more_elements (** [close_at_end input e] returns an enumeration which behaves as [e] and has the secondary effect of closing [input] once everything has been read.*) let close_at_end do_close (input:input) e = BatEnum.suffix_action (fun () -> if !do_close then close_in input) e let make_enum f input = let do_close = ref true in close_at_end do_close input (BatEnum.from (fun () -> apply_enum do_close f input)) let combine (a,b) = wrap_out ~write:(fun c -> write a c; write b c) ~output:(fun s i j -> let _ = output a s i j in output b s i j) ~flush:(fun () -> flush a; flush b) ~close:(fun () -> (close_out a, close_out b)) ~underlying:[cast_output a; cast_output b] let write_enum f out enum = BatEnum.iter (f out) enum (*; flush out*) (** {6 Big Endians} *) module BigEndian = struct let read_ui16 i = let ch2 = read_byte i in let ch1 = read_byte i in ch1 lor (ch2 lsl 8) let read_i16 i = let ch2 = read_byte i in let ch1 = read_byte i in let n = ch1 lor (ch2 lsl 8) in if ch2 land 128 <> 0 then n - 65536 else n let fix = lnot 0x7FFFFFFF (* -:) *) let read_i32 ch = let ch4 = read_byte ch in let ch3 = read_byte ch in let ch2 = read_byte ch in let ch1 = read_byte ch in if ch4 land 128 <> 0 then begin (* negative number *) if ch4 land 64 = 0 then raise (Overflow "read_i32"); (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor ((ch4 land 127) lsl 24)) lor fix (* FIX HERE *) end else begin (*positive number*) if ch4 land 64 <> 0 then raise (Overflow "read_i32"); ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor (ch4 lsl 24) end let read_real_i32 ch = let big = Int32.shift_left (Int32.of_int (read_byte ch)) 24 in let ch3 = read_byte ch in let ch2 = read_byte ch in let ch1 = read_byte ch in let base = Int32.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in Int32.logor base big let read_i64 ch = let big = Int64.of_int32 (read_real_i32 ch) in let ch4 = read_byte ch in let ch3 = read_byte ch in let ch2 = read_byte ch in let ch1 = read_byte ch in let base = Int64.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in let small = Int64.logor base (Int64.shift_left (Int64.of_int ch4) 24) in Int64.logor (Int64.shift_left big 32) small let read_double ch = Int64.float_of_bits (read_i64 ch) let read_float ch = Int32.float_of_bits (read_real_i32 ch) let write_ui16 ch n = if n < 0 || n > 0xFFFF then raise (Overflow "write_ui16"); write_byte ch (n lsr 8); write_byte ch n let write_i16 ch n = if n < -0x8000 || n > 0x7FFF then raise (Overflow "write_i16"); if n < 0 then write_ui16 ch (65536 + n) else write_ui16 ch n let write_i32 ch n = write_byte ch (n asr 24); write_byte ch (n lsr 16); write_byte ch (n lsr 8); write_byte ch n let write_real_i32 ch n = let base = Int32.to_int n in let big = Int32.to_int (Int32.shift_right_logical n 24) in write_byte ch big; write_byte ch (base lsr 16); write_byte ch (base lsr 8); write_byte ch base let write_i64 ch n = write_real_i32 ch (Int64.to_int32 (Int64.shift_right_logical n 32)); write_real_i32 ch (Int64.to_int32 n) let write_double ch f = write_i64 ch (Int64.bits_of_float f) let write_float ch f = write_real_i32 ch (Int32.bits_of_float f) let ui16s_of input = make_enum read_ui16 input let i16s_of input = make_enum read_i16 input let i32s_of input = make_enum read_i32 input let real_i32s_of input = make_enum read_real_i32 input let i64s_of input = make_enum read_i64 input let doubles_of input = make_enum read_double input let floats_of input = make_enum read_float input end (** {6 Bits API} *) type 'a bc = { ch : 'a; mutable nbits : int; mutable bits : int; } type in_bits = input bc type out_bits = unit output bc exception Bits_error let input_bits ch = { ch = ch; nbits = 0; bits = 0; } let output_bits ch = { ch = cast_output ch; nbits = 0; bits = 0; } let rec read_bits b n = if b.nbits >= n then begin let c = b.nbits - n in let k = (b.bits asr c) land ((1 lsl n) - 1) in b.nbits <- c; k end else begin let k = read_byte b.ch in if b.nbits >= 24 then begin if n >= 31 then raise Bits_error; let c = 8 + b.nbits - n in let d = b.bits land ((1 lsl b.nbits) - 1) in let d = (d lsl (8 - c)) lor (k lsr c) in b.bits <- k; b.nbits <- c; d end else begin b.bits <- (b.bits lsl 8) lor k; b.nbits <- b.nbits + 8; read_bits b n; end end let drop_bits b = b.nbits <- 0 let rec write_bits b ~nbits x = let n = nbits in if n + b.nbits >= 32 then begin if n > 31 then raise Bits_error; let n2 = 32 - b.nbits - 1 in let n3 = n - n2 in write_bits b ~nbits:n2 (x asr n3); write_bits b ~nbits:n3 (x land ((1 lsl n3) - 1)); end else begin if n < 0 then raise Bits_error; if (x < 0 || x > (1 lsl n - 1)) && n <> 31 then raise Bits_error; b.bits <- (b.bits lsl n) lor x; b.nbits <- b.nbits + n; while b.nbits >= 8 do b.nbits <- b.nbits - 8; write_byte b.ch (b.bits asr b.nbits) done end let flush_bits b = if b.nbits > 0 then write_bits b ~nbits:(8 - b.nbits) 0 (** {6 Generic BatIO} *) class in_channel ch = object method input s pos len = input ch s pos len method close_in() = close_in ch end class out_channel ch = object method output s pos len = output ch s pos len method flush() = flush ch method close_out() = ignore(close_out ch) end class in_chars ch = object method get() = try read ch with No_more_input -> raise End_of_file method close_in() = close_in ch end class out_chars ch = object method put t = write ch t method flush() = flush ch method close_out() = ignore(close_out ch) end let from_in_channel ch = let cbuf = Bytes.create 1 in let read() = try if ch#input cbuf 0 1 = 0 then raise Sys_blocked_io; Bytes.unsafe_get cbuf 0 with End_of_file -> raise No_more_input in let input s p l = ch#input s p l in create_in ~read ~input ~close:ch#close_in let from_out_channel ch = let cbuf = Bytes.create 1 in let write c = Bytes.unsafe_set cbuf 0 c; if ch#output cbuf 0 1 = 0 then raise Sys_blocked_io; in let output s p l = ch#output s p l in create_out ~write ~output ~flush:ch#flush ~close:ch#close_out let from_in_chars ch = let input s p l = let i = ref 0 in try while !i < l do Bytes.unsafe_set s (p + !i) (ch#get()); incr i done; l with End_of_file when !i > 0 -> !i in create_in ~read:ch#get ~input ~close:ch#close_in let from_out_chars ch = let output s p l = for i = p to p + l - 1 do ch#put (Bytes.unsafe_get s i) done; l in create_out ~write:ch#put ~output ~flush:ch#flush ~close:ch#close_out (** {6 Enumerations} *) let bytes_of input = make_enum read_byte input let signed_bytes_of input = make_enum read_signed_byte input let ui16s_of input = make_enum read_ui16 input let i16s_of input = make_enum read_i16 input let i32s_of input = make_enum read_i32 input let real_i32s_of input = make_enum read_real_i32 input let i64s_of input = make_enum read_i64 input let doubles_of input = make_enum read_double input let floats_of input = make_enum read_float input let strings_of input = make_enum read_string input let lines_of input = make_enum read_line input let chunks_of n input = make_enum (fun ic -> nread ic n) input (** The number of chars to read at once *) let buffer_size = 1024 (*Arbitrary size.*) (* make a bunch of char enums by reading buffer_size at a time and concat them all into into one big char enum *) let chars_of input = let do_close = ref true in close_at_end do_close input (BatEnum.concat (BatEnum.from (fun () -> apply_enum do_close (fun source -> string_enum (nread source buffer_size)) input))) let bits_of input = let do_close = ref true in close_at_end do_close input.ch (BatEnum.from (fun () -> apply_enum do_close read_bits input 1)) (** Buffered lines_of, for performance. Ideas taken from ocaml stdlib *) let lines_of2 ic = let buf = Bytes.create buffer_size in let read_pos = ref 0 in (* next byte to read *) let end_pos = ref 0 in (* place to write new data *) let find_eol () = let rec find_loop pos = if pos >= !end_pos then !read_pos - pos else if Bytes.get buf pos = '\n' then 1 + pos - !read_pos (* TODO: HANDLE CRLF *) else find_loop (pos+1) in find_loop !read_pos in let join_strings total_len accu = let rec loop buf pos = function | [] -> () | h::t -> let len = Bytes.length h in Bytes.blit h 0 buf (pos-len) len; loop buf (pos-len) t in let buf = Bytes.create total_len in loop buf total_len accu; Bytes.unsafe_to_string buf in let input_buf s o l = Bytes.blit buf !read_pos s o l; read_pos := !read_pos + l; if !end_pos = !read_pos then try if !end_pos >= buffer_size then begin read_pos := 0; end_pos := input ic buf 0 buffer_size; end else begin let len_read = input ic buf 0 (buffer_size - !end_pos) in end_pos := !end_pos + len_read; end with No_more_input -> end_pos := !read_pos; in let get_line () = let rec get_pieces accu len = let n = find_eol () in if n = 0 then match accu with (* EOF *) | [] -> close_in ic; raise BatEnum.No_more_elements | _ -> join_strings len accu else if n > 0 then (* newline found *) let res = Bytes.create (n-1) in input_buf res 0 (n-1); input_buf (Bytes.of_string " ") 0 1; (* throw away EOL *) match accu with | [] -> Bytes.unsafe_to_string res | _ -> let len = len + n-1 in join_strings len (res :: accu) else (* n < 0 ; no newline found *) let piece = Bytes.create (-n) in input_buf piece 0 (-n); get_pieces (piece::accu) (len-n) in get_pieces [] 0 in (* prime the buffer *) end_pos := input ic buf 0 buffer_size; BatEnum.from get_line let write_bitss ~nbits output enum = write_enum (write_bits ~nbits) output enum (** {6 Utilities} *) let is_newline = function '\010' | '\013' -> true | _ -> false let tab_out ?(tab=' ') n out = let spaces = String.make n tab in wrap_out ~write: (fun c -> write out c; if is_newline c then nwrite out spaces; ) ~output:(fun s p l -> (*Replace each newline within the segment with newline^spaces*) let length = Bytes.length s in let buffer = Buffer.create length in for i = p to min (length - 1) l do let c = Bytes.unsafe_get s i in Buffer.add_char buffer c; if is_newline c then Buffer.add_string buffer spaces done; let s' = BatBytesCompat.buffer_to_bytes buffer in really_output out s' 0 (Bytes.length s')) ~flush:noop ~close:noop ~underlying:[out] (* let lmargin n (p:_ output -> 'a -> unit) out x = p (tab_out n (cast_output out)) x *) let comb (a,b) = create_out ~write:(fun c -> write a c; write b c) ~output:(fun s i j -> let _ = output a s i j in output b s i j) ~flush:(fun () -> flush a; flush b) ~close:(fun () -> ignore (close_out a); close_out b) (*let repeat n out = wrap_out ~underlying:[out] ~write:(fun c -> for i = 1 to n do write out c) ~output:(fun s p l -> for i = 1 to n do output out s p l) ~close:(fun () -> flush out)*) (*let copy input output = write_chunks output (chunks_of default_buffer_size input)*) (*let copy input output = write_chars output (chars_of input)*) let copy ?(buffer=4096) inp out = let n = buffer in let buf = Bytes.create n in try while true do let len = input inp buf 0 n in if len = 0 then raise No_more_input else ignore (really_output out buf 0 len) done with No_more_input -> () (*let fast_chunks_of n inp = let buffer = String.create n in make_enum (fun inp -> input inp buffer 0 n) input*) (* (** {6 Test} *) let in_channel_of_input i = let (cin, cout) = Unix.pipe () in let latest_pos_in = ref 0 in let rec aux () = let new_pos_in = pos_in cin in if new_pos_in > !latest_pos_in then (*Something has been read, we can write a little bit more*) let size = new_pos_in - !latest_pos_in in let buf = String.create size in input i buf (* UnixLabels.select ~read:? ~write:*) (* let (fin, fout) = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM in let cin = open_in fin and cout = open_out fout in let rec aux () = let c = read i in Pervasives.output_char cout c; aux ()*) *) (** {6 Thread-safety} *) let lock_factory = ref (fun () -> BatConcurrent.nolock) let synchronize_in ?(lock = !lock_factory ()) inp = wrap_in ~read:(BatConcurrent.sync lock (fun () -> read inp)) ~input:(BatConcurrent.sync lock (fun s p l -> input inp s p l)) ~close:noop ~underlying:[inp] let synchronize_out ?(lock = !lock_factory ()) out = wrap_out ~write: (BatConcurrent.sync lock (fun c -> write out c)) ~output:(fun s p -> BatConcurrent.sync lock (fun l -> output out s p l)) ~flush: (BatConcurrent.sync lock (fun () -> flush out)) ~close: noop ~underlying:[out] (** {6 Things that require temporary files} *) (** [to_input_channel inp] converts [inp] to an [in_channel]. In the simplest case, [inp] maps to a file descriptor, which makes it possible to just reopen the same file descriptor as an [in_channel]. There is no flushing with which to screw up and this shouldn't interfere with [pos_in] et al. because [inp] maps {e directly} to a file descriptor, not through higher-level abstract streams. Otherwise, read everything, write it to a temporary file and read it back as an [in_channel]. Yes, this is prohibitively expensive. *) let to_input_channel inp = try let descr = try BatUnix.descr_of_input inp with Invalid_argument _ -> raise Exit in (*Simple case*) Unix.in_channel_of_descr descr with Exit -> (*Bad, bad case*) (* FIXME: this 'pipe' is never deleted *) let (name, cout) = Filename.open_temp_file ~mode:[Open_binary] "ocaml" "pipe" in let out = output_channel cout in copy inp out; close_out out; Pervasives.open_in_bin name (*(** Copy everything to a temporary file *) let out_channel_of_output out = let (name, cout) = Filename.open_temp_file "ocaml" "tmp" in create_out cout*) let to_string print_x x = BatPrintf.sprintf2 "%a" print_x x let to_f_printer printer = fun fmt t -> Format.pp_print_string fmt (to_string printer t) module Incubator = struct module Array = struct let pp ?(flush = false) ?(first = "[|") ?(last = "|]") ?(sep = "; ") ?(indent = String.length first) pp f a = let open Format in pp_open_box f indent; pp_print_cut f (); pp_print_string f first; pp_print_cut f (); for i = 0 to Array.length a - 2 do pp_open_box f indent; pp f a.(i); pp_print_string f sep; pp_close_box f (); pp_print_cut f (); done; if Array.length a > 0 then ( (* Print the last element without a trailing separator *) pp_open_box f indent; pp f a.(Array.length a - 1); pp_close_box f (); ); pp_print_cut f (); pp_print_string f last; pp_close_box f (); if flush then pp_print_flush f () end module Enum = struct let pp ?(flush = false) ?(first = "") ?(last = "") ?(sep = " ") ?(indent = String.length first) pp f e = let open Format in pp_open_box f indent; pp_print_cut f (); pp_print_string f first; pp_print_cut f (); match BatEnum.get e with | None -> pp_print_string f last; pp_close_box f (); if flush then pp_print_flush f () | Some x -> pp_open_box f indent; pp f x; let rec aux () = match BatEnum.get e with | None -> pp_close_box f (); pp_print_cut f (); pp_print_string f last; pp_close_box f (); if flush then pp_print_flush f () | Some x -> pp_print_string f sep; pp_close_box f (); pp_print_cut f (); pp_open_box f indent; pp f x; aux () in aux () end module List = struct let pp ?(flush = false) ?(first = "[") ?(last = "]") ?(sep = "; ") ?(indent = String.length first) pp f l = let open Format in pp_open_box f indent; pp_print_cut f (); pp_print_string f first; pp_print_cut f (); match l with | [] -> pp_print_string f last; pp_close_box f (); if flush then pp_print_flush f () | hd :: tl -> pp_open_box f indent; pp f hd; let rec aux rem = match rem with | [] -> pp_close_box f (); pp_print_cut f (); pp_print_string f last; pp_close_box f (); if flush then pp_print_flush f () | hd :: tl -> pp_print_string f sep; pp_close_box f (); pp_print_cut f (); pp_open_box f indent; pp f hd; aux tl in aux tl end end batteries-included-3.4.0/src/batIO.mli000066400000000000000000001041501415601150500175540ustar00rootroot00000000000000(* * BatIO - Abstract input/output * Copyright (C) 2003 Nicolas Cannasse * 2008 David Teller (contributor) * 2008 Philippe Strauss (contributor) * 2008 Edgar Friendly (contributor) * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** High-order abstract I/O. This module deals with {!type: input}s and {!type: output}s. Inputs are manners of getting information from the outside world and into your program (for instance, reading from the network, from a file, etc.) Outputs are manners of getting information out from your program and into the outside world (for instance, sending something onto the network, onto a file, etc.) In other words, if you are looking for a way to modify files, read from the network, etc., you're in the right place. To perform I/O, you first need to {e open} your {!type: input} or your {!type: output}. Chances are that there is an {e opening} operation for this task. Note that most opening operations are defined in their respective module. Operations for opening files are defined in module {!File}, operations for opening communications with the network or with other processes are defined in module {!Unix}. Opening operations related to compression and decompression are defined in module {!Compress}, etc. Once you have opened an {!type: input}, you may read the data it contains by using functions such as {!read} (to read one character), {!nread} or {!val: input} (to read one string) or one of the [read_*] functions. If you need not one information but a complete enumeration, for instance for processing many information before writing them, you may also convert the input into an enumeration, by using one of the [*s_of] functions. Once you have opened an {!type: output}, you may write data to this output by using functions scuh as {!write} (to write one char), {!nwrite} or {!val: output} (to write one string) or one of the [write_*] functions. If you have not just one piece of data but a complete enumeration, you may write this whole enumeration to the output by using one of the [write_*s] functions. Note that most operations on output are said to be {e buffered}. This means that small writing operations may be automatically delayed and grouped into large writing operations, as these are generally faster and induce less wear on the hardware. Occasionally, you may wish to force all waiting operations to take place {e now}. For this purpose, you may call function {!flush}. Once you have finished using your {!type: input} or your {!type: output}, chances are that you will want to close it. This is not a strict necessity, as OCaml will eventually close it for you when it detects that you have no more need of that {!type: input}/{!type: output}, but this is generally a good policy, as this will let other programs access the resources which are currently allocated to that {!type:input}/{!type:output} -- typically, under Windows, if you are reading the contents of a file from a program, no other program may read the contents of that file simultaneously and you may also not rename or move the file to another directory. To close an {!type: input}, use function {!close_in} and to close an {!type: output}, use function {!close_out}. {b Note} Some {!type:input}s are built on top of other {!type:input}s to provide transparent translations (e.g. on-the-fly decompression of a file or network information) and that some {!type:output}s are built on top of other {!type:output}s for the same purpose (e.g. on-the-fly compression of a file or network information). In this case, closing the "outer" {!type:input}/{!type:output} (e.g. the decompressor/compressor) will {e not} close the "inner" {!type:input}/{!type:output} (e.g. access to the file or to the network). You will need to close the "inner" {!type:input}/{!type:output}, which will automatically flush the outer {!type:input}/{!type:output} and close it. @author Nicolas Cannasse @author David Teller @author Philippe Strauss @author Edgar Friendly @documents BatInnerIO *) type input = BatInnerIO.input (** The abstract input type. *) type 'a output = 'a BatInnerIO.output (** The abstract output type, ['a] is the accumulator data, it is returned when the [close_out] function is called. *) type ('a, 'b) printer = 'b output -> 'a -> unit (** The type of a printing function to print a ['a] to an output that produces ['b] as result. *) type 'a f_printer = Format.formatter -> 'a -> unit exception No_more_input (** This exception is raised when reading on an input with the [read] or [nread] functions while there is no available token to read. *) exception Input_closed (** This exception is raised when reading on a closed input. *) exception Output_closed (** This exception is raised when reading on a closed output. *) (** {6 Standard inputs/outputs} *) val stdin : input (** Standard input, as per Unix/Windows conventions (by default, keyboard). Example: [if read_line stdin |> Int.of_string > 10 then failwith "too big a number read"; ] *) val stdout: unit output (** Standard output, as per Unix/Windows conventions (by default, console). Use this output to display regular messages. Example: [ write_string stdout "Enter your name:"; let name = read_line stdin in write_line stdout ("Your name is " ^ name); ] *) val stderr: unit output (** Standard error output, as per Unix/Windows conventions. Use this output to display warnings and error messages. Example: [ write_line stderr "Error on Internet - please delete google.com"; ] *) val stdnull: unit output (** An output which discards everything written to it. Use this output to ignore messages. Example: [ let out_ch = if debug then stderr else stdnull in write_line out_ch "Program running."; ] *) (** {6 Standard API} *) val read : input -> char (** Read a single char from an input or raise [No_more_input] if no input is available. Example: [let rec skip_line ch = if read ch = '\n' then skip_line ch else ();] *) val nread : input -> int -> string (** [nread i n] reads a string of size up to [n] from an input. The function will raise [No_more_input] if no input is available. It will raise [Invalid_argument] if [n] < 0. Example: [let read_md5 ch = nread ch 32] *) val really_nread : input -> int -> string (** [really_nread i n] reads a string of exactly [n] characters from the input. @raise No_more_input if at least [n] characters are not available. @raise Invalid_argument if [n] < 0. Example: [let read_md5 ch = really_nread ch 32] *) val input : input -> Bytes.t -> int -> int -> int (** [input i s p len] reads up to [len] characters from the given input, storing them in byte sequence [s], starting at character number [p]. It returns the actual number of characters read (which may be 0) or raise [No_more_input] if no character can be read. It will raise [Invalid_argument] if [p] and [len] do not designate a valid subsequence of [s]. Example: [let map_ch f ?(block_size=100) = let b = String.create block_size in try while true do let l = input ch b 0 block_size in f b 0 l; done with No_more_input -> ()] *) val really_input : input -> Bytes.t -> int -> int -> int (** [really_input ic s p len] reads exactly [len] characters from the input [ic], storing them in the string [s], starting at position [p]. For consistency with {!BatIO.input} it returns [len]. @raise No_more_input if at [len] characters are not available. @raise Invalid_argument if [p] and [len] do not designate a valid substring of [s]. Example: [let _ = really_input stdin b 0 3] *) val close_in : input -> unit (** Close the input. It can no longer be read from. Example: [close_in network_in;] *) val write : (char, _) printer (** Write a single char to an output. Example: [write stdout 'x';] *) val nwrite : (string, _) printer (** Write a string to an output. Example: [nwrite stdout "Enter your name: ";] *) val output : 'a output -> Bytes.t -> int -> int -> int (** [output o s p len] writes up to [len] characters from byte sequence [s], starting at offset [p]. It returns the number of characters written. It will raise [Invalid_argument] if [p] and [len] do not designate a valid subsequence of [s]. Example: [let written = output stdout (Bytes.to_string "Foo Bar Baz") 2 4] This writes "o Ba" to stdout, and returns 4. *) val output_substring : 'a output -> string -> int -> int -> int (** like [output] above, but outputs from a substring instead of a subsequence of bytes @since 2.8.0 *) val really_output : 'a output -> Bytes.t -> int -> int -> int (** [really_output o s p len] writes exactly [len] characters from byte sequence [s] onto the the output, starting with the character at offset [p]. For consistency with {!BatIO.output} it returns [len]. @raise Invalid_argument if [p] and [len] do not designate a valid subsequence of [s]. This function is useful for networking situations where the output buffer might fill resulting in not the entire substring being readied for transmission. Uses [output] internally, and will raise [Sys_blocked_io] in the case that any call returns 0. *) val really_output_substring : 'a output -> string -> int -> int -> int (** like [really_output] above, but outputs from a substring instead of a subsequence of bytes @since 2.8.0 *) val flush : 'a output -> unit (** Flush an output. If previous write operations have caused errors, this may trigger an exception. Example: [flush stdout;] *) val flush_all : unit -> unit (** Flush all outputs, ignore errors. Example: [flush_all ();] *) val close_out : 'a output -> 'a (** Close the output and return its accumulator data. The output is flushed before being closed and can no longer be written. Attempting to flush or write after the output has been closed will have no effect. Example: [ let strout = output_string () in write strout 'x'; if 2+3>5 then write strout "y"; print_string (close_out strout) ] *) (**/**) val close_all : unit -> unit (** Close all outputs. Ignore errors. Automatically called at the end of your program. You probably should never use it manually, as it also closes [stdout], [stderr], [stdnull]. Example: [close_all ();] *) (**/**) (** {6 Creation of BatIO Inputs/Outputs} To open a file for reading/writing, see {!File.open_in} and {!File.open_out}*) val input_string : string -> input (** Create an input that will read from a string. Example: [ let inch = input_string "1234554321" in let str1 = nread inch 3 in (* "123" *) let str2 = nread inch 5 in (* "45543" *) let str3 = nread inch 2 in (* "21" *) try string_of_char(read inch) with BatIO.No_more_input -> "End of string"; ] *) val output_string : unit -> string output (** Create an output that will write into a string in an efficient way. When closed, the output returns all the data written into it. *) val input_enum : char BatEnum.t -> input (** Create an input that will read from an [enum]. *) val output_enum : unit -> char BatEnum.t output (** Create an output that will write into an [enum]. The final enum is returned when the output is closed. *) val combine : ('a output * 'b output) -> ('a * 'b) output (** [combine (a,b)] creates a new [output] [c] such that writing to [c] will actually write to both [a] and [b] *) val tab_out : ?tab:char -> int -> 'a output -> unit output (** Create an output shifted to the right by a number of spaces (or other character as specified by [tab]). [tab_out n out] produces a new output for writing into [out], in which every new line starts with [n] spaces. @raise Invalid_argument if [n] < 0. Closing [tab_out n out] does not close [out]. Rather, closing [out] closes [tab_out n out]. *) (*val repeat: int -> 'a output -> unit output (** [repeat n out] create an output in which every character or string is repeated [n] times to [out].*)*) (** {6 Utilities} *) val read_all : input -> string (** read all the contents of the input until [No_more_input] is raised. *) val pipe : unit -> input * unit output (** Create a pipe between an input and an output. Data written from the output can be read from the input. *) val copy : ?buffer:int -> input -> _ output -> unit (** Read everything from an input and copy it to an output. @param buffer The size of the buffer to use for copying, in bytes. By default, this is 4,096b. *) val pos_in : input -> input * (unit -> int) (** Create an input that provide a count function of the number of bytes read from it. *) val progress_in : input -> (unit -> unit) -> input (** [progress_in inp f] create an input that calls [f ()] whenever some content is successfully read from it.*) val pos_out : 'a output -> unit output * (unit -> int) (** Create an output that provide a count function of the number of bytes written through it. *) val progress_out : 'a output -> (unit -> unit) -> unit output (** [progress_out out f] create an output that calls [f ()] whenever some content is successfully written to it.*) external cast_output : 'a output -> unit output = "%identity" (** You can safely transform any output to an unit output in a safe way by using this function. *) (** {6 Binary files API} Here is some API useful for working with binary files, in particular binary files generated by C applications. By default, encoding of multibyte integers is low-endian. The {!BigEndian} module provide multibyte operations with other encoding. *) exception Overflow of string (** Exception raised when a read or write operation cannot be completed. *) val read_byte : input -> int (** Read an unsigned 8-bit integer. *) val read_signed_byte : input -> int (** Read an signed 8-bit integer. *) val read_ui16 : input -> int (** Read an unsigned 16-bit word. *) val read_i16 : input -> int (** Read a signed 16-bit word. *) val read_i32 : input -> int (** Read a signed 32-bit integer. @raise Overflow if the read integer cannot be represented as an OCaml 31-bit integer. *) val read_real_i32 : input -> int32 (** Read a signed 32-bit integer as an OCaml int32. *) val read_i64 : input -> int64 (** Read a signed 64-bit integer as an OCaml int64. *) val read_float : input -> float (** Read an IEEE single precision floating point value. *) val read_double : input -> float (** Read an IEEE double precision floating point value. *) val read_string : input -> string (** Read a null-terminated string. *) val read_line : input -> string (** Read a LF or CRLF terminated string. If the source runs out of input before a LF is found, returns a string of the remaining input. Will raise [No_more_input] only if no characters are available. *) val write_byte : (int, _) printer (** Write an unsigned 8-bit byte. *) val write_ui16 : (int, _) printer (** Write an unsigned 16-bit word. *) val write_i16 : (int, _) printer (** Write a signed 16-bit word. *) val write_i32 : (int, _) printer (** Write a signed 32-bit integer. *) val write_real_i32 : (int32, _) printer (** Write an OCaml int32. *) val write_i64 : (int64, _) printer (** Write an OCaml int64. *) val write_double : (float, _) printer (** Write an IEEE double precision floating point value. *) val write_float : (float, _) printer (** Write an IEEE single precision floating point value. *) val write_string : (string, _) printer (** Write a string and append an null character. *) val write_line : (string, _) printer (** Write a line and append a line end. This adds the correct line end for your operating system. That is, if you are writing to a file and your system imposes that files should end lines with character LF (or ['\n']), as Unix, then a LF is inserted at the end of the line. If your system favors CRLF (or ['\r\n']), then this is what will be inserted.*) (** Same operations as module {!BatIO}, but with big-endian encoding *) module BigEndian : sig (** This module redefines the operations of module {!BatIO} which behave differently on big-endian [input]s/[output]s. Generally, to use this module you will wish to either open both {!BatIO} and {!BigEndian}, so as to import a big-endian version of {!BatIO}, as per [open System.BatIO, BigEndian in ...], or to redefine locally {!BatIO} to use big-endian encodings [module BatIO = System.BatIO include BigEndian] *) val read_ui16 : input -> int (** Read an unsigned 16-bit word. *) val read_i16 : input -> int (** Read a signed 16-bit word. *) val read_i32 : input -> int (** Read a signed 32-bit integer. @raise Overflow if the read integer cannot be represented as an OCaml 31-bit integer. *) val read_real_i32 : input -> int32 (** Read a signed 32-bit integer as an OCaml int32. *) val read_i64 : input -> int64 (** Read a signed 64-bit integer as an OCaml int64. *) val read_double : input -> float (** Read an IEEE double precision floating point value. *) val read_float: input -> float (** Read an IEEE single precision floating point value. *) val write_ui16 : (int, _) printer (** Write an unsigned 16-bit word. *) val write_i16 : (int, _) printer (** Write a signed 16-bit word. *) val write_i32 : (int, _) printer (** Write a signed 32-bit integer. *) val write_real_i32 : (int32, _) printer (** Write an OCaml int32. *) val write_i64 : (int64, _) printer (** Write an OCaml int64. *) val write_double : (float, _) printer (** Write an IEEE double precision floating point value. *) val write_float : (float, _) printer (** Write an IEEE single precision floating point value. *) val ui16s_of : input -> int BatEnum.t (** Read an enumeration of unsigned 16-bit words. *) val i16s_of : input -> int BatEnum.t (** Read an enumartion of signed 16-bit words. *) val i32s_of : input -> int BatEnum.t (** Read an enumeration of signed 32-bit integers. @raise Overflow if the read integer cannot be represented as an OCaml 31-bit integer. *) val real_i32s_of : input -> int32 BatEnum.t (** Read an enumeration of signed 32-bit integers as OCaml [int32]s. *) val i64s_of : input -> int64 BatEnum.t (** Read an enumeration of signed 64-bit integers as OCaml [int64]s. *) val doubles_of : input -> float BatEnum.t (** Read an enumeration of IEEE double precision floating point values. *) val floats_of : input -> float BatEnum.t (** Read an enumeration of IEEE single precision floating point values. *) end (** {6 Bits API} This enable you to read and write from an BatIO bit-by-bit or several bits at the same time. *) type in_bits type out_bits exception Bits_error val input_bits : input -> in_bits (** Read bits from an input *) val output_bits : 'a output -> out_bits (** Write bits to an output *) val read_bits : in_bits -> int -> int (** Read up to 31 bits, raise Bits_error if n < 0 or n > 31 *) val write_bits : out_bits -> nbits:int -> int -> unit (** Write up to 31 bits represented as a value, raise Bits_error if nbits < 0 or nbits > 31 or the value representation excess nbits. *) val flush_bits : out_bits -> unit (** Flush remaining unwritten bits, adding up to 7 bits which values 0. *) val drop_bits : in_bits -> unit (** Drop up to 7 buffered bits and restart to next input character. *) (** {6 Creating new types of inputs/outputs} *) val create_in : read:(unit -> char) -> input:(Bytes.t -> int -> int -> int) -> close:(unit -> unit) -> input (** Fully create an input by giving all the needed functions. {b Note} Do {e not} use this function for creating an input which reads from one or more underlying inputs. Rather, use {!wrap_in}. *) val wrap_in : read:(unit -> char) -> input:(Bytes.t -> int -> int -> int) -> close:(unit -> unit) -> underlying:(input list) -> input (** Fully create an input reading from other inputs by giving all the needed functions. This function is a more general version of {!create_in} which also handles dependency management between inputs. {b Note} When you create an input which reads from another input, function [close] should {e not} close the inputs of [underlying]. Doing so is a common error, which could result in inadvertently closing {!stdin} or a network socket, etc. *) val inherit_in: ?read:(unit -> char) -> ?input:(Bytes.t -> int -> int -> int) -> ?close:(unit -> unit) -> input -> input (** Simplified and optimized version of {!wrap_in} which may be used whenever only one input appears as dependency. [inherit_in inp] will return an input identical to [inp]. [inherit_in ~read inp] will return an input identical to [inp] except for method [read], etc. You do not need to close [inp] in [close]. *) val create_out : write:(char -> unit) -> output:(Bytes.t -> int -> int -> int) -> flush:(unit -> unit) -> close:(unit -> 'a) -> 'a output (** Fully create an output by giving all the needed functions. @param write Write one character to the output (see {!write}). @param output Write a (sub)string to the output (see {!output}). @param flush Flush any buffers of this output (see {!flush}). @param close Close this output. The output will be automatically flushed. {b Note} Do {e not} use this function for creating an output which writes to one or more underlying outputs. Rather, use {!wrap_out}. *) val wrap_out : write:(char -> unit) -> output:(Bytes.t -> int -> int -> int) -> flush:(unit -> unit) -> close:(unit -> 'a) -> underlying:('b output list) -> 'a output (** Fully create an output that writes to one or more underlying outputs. This function is a more general version of {!create_out}, which also handles dependency management between outputs. To illustrate the need for dependency management, let us consider the following values: - an output [out] - a function [f : _ output -> _ output], using {!create_out} to create a new output for writing some data to an underyling output (for instance, a function comparale to {!tab_out} or a function performing transparent compression or transparent traduction between encodings) With these values, let us consider the following scenario - a new output [f out] is created - some data is written to [f out] but not flushed - output [out] is closed, perhaps manually or as a consequence of garbage-collection, or because the program has ended - data written to [f out] is flushed. In this case, data reaches [out] only after [out] has been closed. Despite appearances, it is quite easy to reach such situation, especially in short programs. If, instead, [f] uses [wrap_out], then when output [out] is closed, [f out] is first automatically flushed and closed, which avoids the issue. @param write Write one character to the output (see {!write}). @param output Write a (sub)string to the output (see {!output}). @param flush Flush any buffers of this output (see {!flush}). @param close Close this output. The output will be automatically flushed. @param underlying The list of outputs to which the new output will write. {b Note} Function [close] should {e not} close [underlying] yourself. This is a common mistake which may cause sockets or standard output to be closed while they are still being used by another part of the program. *) val inherit_out: ?write:(char -> unit) -> ?output:(Bytes.t -> int -> int -> int) -> ?flush:(unit -> unit) -> ?close:(unit -> unit) -> 'a output -> unit output (** Simplified and optimized version of {!wrap_out} whenever only one output appears as dependency. [inherit_out out] will return an output identical to [out]. [inherit_out ~write out] will return an output identical to [out] except for its [write] method, etc. You do not need to close [out] in [close]. *) (** {6 For compatibility purposes} *) val input_channel : ?autoclose:bool -> ?cleanup:bool -> in_channel -> input (** Create an input that will read from a channel. @param autoclose If true or unspecified, the {!type: input} will be automatically closed when the underlying [in_channel] has reached its end. @param cleanup If true, the channel will be automatically closed when the {!type: input} is closed. Otherwise, you will need to close the channel manually. Default is [true]. *) val output_channel : ?cleanup:bool -> out_channel -> unit output (** Create an output that will write into a channel. @param cleanup If true, the channel will be automatically closed when the {!type: output} is closed. Otherwise, you will need to close the channel manually. *) val to_input_channel : input -> in_channel (** Create a channel that will read from an input. {b Note} This function is extremely costly and is provided essentially for debugging purposes or for reusing legacy libraries which can't be adapted. As a general rule, if you can avoid using this function, don't use it.*) (** {6 Generic BatIO Object Wrappers} These OO Wrappers have been written to provide easy support of BatIO by external libraries. If you want your library to support BatIO without actually requiring Batteries to compile, you can implement the classes [in_channel], [out_channel], [poly_in_channel] and/or [poly_out_channel] which are the common BatIO specifications established for ExtLib, OCamlNet and Camomile. (see http://www.ocaml-programming.de/tmp/BatIO-Classes.html for more details). {b Note} In this version of Batteries Included, the object wrappers are {e not} closed automatically by garbage-collection. *) class in_channel : input -> object method input : Bytes.t -> int -> int -> int method close_in : unit -> unit end class out_channel : 'a output -> object method output : Bytes.t -> int -> int -> int method flush : unit -> unit method close_out : unit -> unit end class in_chars : input -> object method get : unit -> char method close_in : unit -> unit end class out_chars : 'a output -> object method put : char -> unit method flush : unit -> unit method close_out : unit -> unit end val from_in_channel : #in_channel -> input val from_out_channel : #out_channel -> unit output val from_in_chars : #in_chars -> input val from_out_chars : #out_chars -> unit output (** {6 Enumeration API}*) val bytes_of : input -> int BatEnum.t (** Read an enumeration of unsigned 8-bit integers. *) val signed_bytes_of : input -> int BatEnum.t (** Read an enumeration of signed 8-bit integers. *) val ui16s_of : input -> int BatEnum.t (** Read an enumeration of unsigned 16-bit words. *) val i16s_of : input -> int BatEnum.t (** Read an enumartion of signed 16-bit words. *) val i32s_of : input -> int BatEnum.t (** Read an enumeration of signed 32-bit integers. @raise Overflow if the read integer cannot be represented as an OCaml 31-bit integer. *) val real_i32s_of : input -> int32 BatEnum.t (** Read an enumeration of signed 32-bit integers as OCaml [int32]s. *) val i64s_of : input -> int64 BatEnum.t (** Read an enumeration of signed 64-bit integers as OCaml [int64]s. *) val doubles_of : input -> float BatEnum.t (** Read an enumeration of IEEE double precision floating point values. *) val floats_of : input -> float BatEnum.t (** Read an enumeration of IEEE single precision floating point values. *) val strings_of : input -> string BatEnum.t (** Read an enumeration of null-terminated strings. *) val lines_of : input -> string BatEnum.t (** Read an enumeration of LF or CRLF terminated strings. *) val lines_of2 : input -> string BatEnum.t (** Buffered version of {!lines_of}, for performance. *) val chunks_of : int -> input -> string BatEnum.t (** Read an input as an enumeration of strings of given length. If the input isn't a multiple of that length, the final string will be smaller than the rest. *) val chars_of : input -> char BatEnum.t (** Read an enumeration of Latin-1 characters. {b Note} Usually faster than calling [read] several times.*) val bits_of : in_bits -> int BatEnum.t (** Read an enumeration of bits *) val write_bitss : nbits:int -> out_bits -> int BatEnum.t -> unit (** Write an enumeration of bits*) val default_buffer_size : int (**The default size for internal buffers.*) (** {6 Thread-safety} *) val synchronize_in : ?lock:BatConcurrent.lock -> input -> input (**[synchronize_in inp] produces a new {!type: input} which reads from [input] in a thread-safe way. In other words, a lock prevents two distinct threads from reading from that input simultaneously, something which would potentially wreak havoc otherwise @param lock An optional lock. If none is provided, the lock will be specific to this [input]. Specifying a custom lock may be useful to associate one common lock for several inputs and/or outputs, for instance in the case of pipes. *) val synchronize_out: ?lock:BatConcurrent.lock -> _ output -> unit output (**[synchronize_out out] produces a new {!type: output} which writes to [output] in a thread-safe way. In other words, a lock prevents two distinct threads from writing to that output simultaneously, something which would potentially wreak havoc otherwise @param lock An optional lock. If none is provided, the lock will be specific to this [output]. Specifying a custom lock may be useful to associate one common lock for several inputs and/or outputs, for instance in the case of pipes. *) (** {6 Thread-safety internals} Unless you are attempting to adapt Batteries Included to a new model of concurrency, you probably won't need this. *) val lock: BatConcurrent.lock ref (** A lock used to synchronize internal operations. By default, this is {!BatConcurrent.nolock}. However, if you're using a version of Batteries compiled in threaded mode, this uses {!BatMutex}. If you're attempting to use Batteries with another concurrency model, set the lock appropriately. *) val lock_factory: (unit -> BatConcurrent.lock) ref (** A factory used to create locks. This is used transparently by {!synchronize_in} and {!synchronize_out}. By default, this always returns {!BatConcurrent.nolock}. However, if you're using a version of Batteries compiled in threaded mode, this uses {!BatMutex}. *) val to_string : ('a, string) printer -> 'a -> string val to_f_printer: ('a, _) printer -> 'a f_printer (**/**) val comb : ('a output * 'a output) -> 'a output (** Old name of [combine]*) val make_enum : (input -> 'a) -> input -> 'a BatEnum.t (** {6 Debugging facilities} *) val get_output_id : _ output -> int val get_input_id : input -> int module Incubator : sig (** {6 Format-based pretty-printing} *) module Array : sig val pp : ?flush:bool -> ?first:string -> ?last:string -> ?sep:string -> ?indent:int -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a array -> unit (** Print the contents of an array, with [first] preceding the first item (default: ["\[|"]), [last] following the last item (default: ["|\]"]) and [sep] separating items (default: ["; "]). A printing function must be provided to print the items in the array. The [flush] parameter (default: [false]) should be set to [true] for the outer-most printing call. Setting inner calls to [true] - for example, for nested values - prevent indentation from working properly. Example: [pp ~flush:true Format.pp_print_int Format.std_formatter \[|1; 2; 3|\]] *) end module Enum : sig val pp : ?flush:bool -> ?first:string -> ?last:string -> ?sep:string -> ?indent:int -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a BatEnum.t -> unit (** Print the contents of an enum, with [first] preceding the first item (default: [""]), [last] following the last item (default: [""]) and [sep] separating items (default: [" "]). A printing function must be provided to print the items in the enum. The [flush] parameter (default: [false]) should be set to [true] for the outer-most printing call. Setting inner calls to [true] - for example, for nested values - prevent indentation from working properly. Example: [pp ~flush:true Format.pp_print_int Format.std_formatter (1 -- 3)] *) end module List : sig val pp : ?flush:bool -> ?first:string -> ?last:string -> ?sep:string -> ?indent:int -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit (** Print the contents of a list, with [first] preceding the first item (default: ["\["]), [last] following the last item (default: ["\]"]) and [sep] separating items (default: ["; "]). A printing function must be provided to print the items in the list. The [flush] parameter (default: [false]) should be set to [true] for the outer-most printing call. Setting inner calls to [true] - for example, for nested values - prevent indentation from working properly. Example: [pp ~flush:true Format.pp_print_int Format.std_formatter \[1; 2; 3\]] *) end end batteries-included-3.4.0/src/batISet.ml000066400000000000000000000304751415601150500177500ustar00rootroot00000000000000(* Copyright 2003 Yamagata Yoriyuki. distributed with LGPL *) (* Modified by Edgar Friendly *) include BatAvlTree type t = (int * int) tree type elt = int let rec mem (n:int) s = if is_empty s then false else let v1, v2 = root s in if n < v1 then mem n (left_branch s) else if v1 <= n && n <= v2 then true else mem n (right_branch s) (*$T mem let t = empty |> add_range 1 10 |> add_range 10 20 in \ mem 1 t && mem 5 t && mem 20 t && not (mem 21 t) && not (mem 0 t) let t = Enum.append (1--9) (20 --- 15) |> Enum.map (fun i -> i,i) |> of_enum in \ mem 1 t && mem 5 t && mem 15 t && not (mem 10 t) && not (mem 14 t) *) let rec add n s = if is_empty s then make_tree empty (n, n) empty else let (v1, v2) as v = root s in let s0 = left_branch s in let s1 = right_branch s in if v1 <> min_int && n < v1 - 1 then make_tree (add n s0) v s1 else if v2 <> max_int && n > v2 + 1 then make_tree s0 v (add n s1) else if n + 1 = v1 then if not (is_empty s0) then let (u1, u2), s0' = split_rightmost s0 in if u2 <> max_int && u2 + 1 = n then make_tree s0' (u1, v2) s1 else make_tree s0 (n, v2) s1 else make_tree s0 (n, v2) s1 else if v2 + 1 = n then if not (is_empty s1) then let (u1, u2), s1' = split_leftmost s1 in if n <> max_int && n + 1 = u1 then make_tree s0 (v1, u2) s1' else make_tree s0 (v1, n) s1 else make_tree s0 (v1, n) s1 else s (*$Q add (Q.list Q.small_int) (fun l -> let t = List.fold_left (fun s x -> add x s) empty l in List.for_all (fun i -> mem i t) l) *) let rec from n s = if is_empty s then empty else let (v1, v2) as v = root s in let s0 = left_branch s in let s1 = right_branch s in if n < v1 then make_tree (from n s0) v s1 else if n > v2 then from n s1 else make_tree empty (n, v2) s1 let after n s = if n = max_int then empty else from (n + 1) s let rec until n s = if is_empty s then empty else let (v1, v2) as v = root s in let s0 = left_branch s in let s1 = right_branch s in if n > v2 then make_tree s0 v (until n s1) else if n < v1 then until n s0 else make_tree s0 (v1, n) empty let before n s = if n = min_int then empty else until (n - 1) s (*$= from & ~cmp:equal ~printer:(IO.to_string print) (from 3 (of_list [1,5])) (of_list [3,5]) empty (from 3 (of_list [1,2])) *) (*$= until & ~cmp:equal ~printer:(IO.to_string print) (until 3 (of_list [1,5])) (of_list [1,3]) empty (until 3 (of_list [4,5])) *) let add_range n1 n2 s = if n1 > n2 then Printf.ksprintf invalid_arg "ISet.add_range - %d > %d" n1 n2 else let n1, l = if n1 = min_int then n1, empty else let l = until (n1 - 1) s in if is_empty l then n1, empty else let (v1, v2), l' = split_rightmost l in if v2 + 1 = n1 then v1, l' else n1, l in let n2, r = if n2 = max_int then n2, empty else let r = from (n2 + 1) s in if is_empty r then n2, empty else let (v1, v2), r' = split_leftmost r in if n2 + 1 = v1 then v2, r' else n2, r in make_tree l (n1, n2) r let singleton n = singleton_tree (n, n) (*$T singleton singleton 3 |> mem 3 singleton 3 |> mem 4 |> not *) let rec remove n s = if is_empty s then empty else let (v1, v2) as v = root s in let s1 = left_branch s in let s2 = right_branch s in if n < v1 then make_tree (remove n s1) v s2 else if n = v1 then if v1 = v2 then concat s1 s2 else make_tree s1 (v1 + 1, v2) s2 else if n > v1 && n < v2 then let s = make_tree s1 (v1, n - 1) empty in make_tree s (n + 1, v2) s2 else if n = v2 then make_tree s1 (v1, v2 - 1) s2 else make_tree s1 v (remove n s2) (*$= remove & ~cmp:equal ~printer:(IO.to_string print) empty (remove 3 (singleton 3)) (of_list [1,5] |> remove 5) (of_list [1,4]) (of_list [1,5] |> remove 1) (of_list [2,5]) (of_list [1,5] |> remove 3) (of_list [1,2;4,5]) (of_list [4,6;1,3;8,10] |> remove 1) (of_list [2,3;4,6;8,10]) (of_list [4,6;1,3;8,10] |> remove 10) (of_list [1,3;4,6;8,9]) *) let remove_range n1 n2 s = if n1 > n2 then invalid_arg "ISet.remove_range" else concat (before n1 s) (after n2 s) (*$= remove_range & ~cmp:equal ~printer:(IO.to_string print) empty (remove_range 10 15 (of_list [10,15])) (of_list [0,20] |> remove_range 3 5) (of_list [0,2;6,20]) (of_list [0,20] |> remove_range 3 5 |> remove_range 8 10 |> remove_range 5 8) (of_list [0,2;11,20]) *) let rec union s1 s2 = if is_empty s1 then s2 else if is_empty s2 then s1 else let s1, s2 = if height s1 > height s2 then s1, s2 else s2, s1 in let n1, n2 = root s1 in let l1 = left_branch s1 in let r1 = right_branch s1 in let l2 = before n1 s2 in let r2 = after n2 s2 in let n1, l = if n1 = min_int then n1, empty else let l = union l1 l2 in if is_empty l then n1, l else let (v1, v2), l' = split_rightmost l in (* merge left *) if v2 + 1 = n1 then v1, l' else n1, l in let n2, r = if n1 = max_int then n2, empty else let r = union r1 r2 in if is_empty r then n2, r else let (v1, v2), r' = split_leftmost r in (* merge right *) if n2 + 1 = v1 then v2, r' else n2, r in make_tree l (n1, n2) r (*$= union & ~cmp:equal ~printer:(IO.to_string print) (union (of_list [3,5]) (of_list [1,3])) (of_list [1,5]) (union (of_list [3,5]) (of_list [1,2])) (of_list [1,5]) (union (of_list [3,5]) (of_list [1,5])) (of_list [1,5]) (union (of_list [1,5]) (of_list [3,5])) (of_list [1,5]) (union (of_list [1,2]) (of_list [4,5])) (of_list [1,2;4,5]) *) let rec inter s1 s2 = if is_empty s1 then empty else if is_empty s2 then empty else let s1, s2 = if height s1 > height s2 then s1, s2 else s2, s1 in let n1, n2 = root s1 in let l1 = left_branch s1 in let r1 = right_branch s1 in let l2 = before n1 s2 in let r2 = after n2 s2 in let m = until n2 (from n1 s2) in concat (concat (inter l1 l2) m) (inter r1 r2) (*$= inter & ~cmp:equal ~printer:(IO.to_string print) (inter (of_list [1,5]) (of_list [2,3])) (of_list [2,3]) (inter (of_list [1,4]) (of_list [2,6])) (of_list [2,4]) *) let rec compl_aux n1 n2 s = if is_empty s then add_range n1 n2 empty else let v1, v2 = root s in let l = left_branch s in let r = right_branch s in let l = if v1 = min_int then empty else compl_aux n1 (v1 - 1) l in let r = if v2 = max_int then empty else compl_aux (v2 + 1) n2 r in concat l r let compl s = compl_aux min_int max_int s let diff s1 s2 = inter s1 (compl s2) (*$= diff & ~cmp:equal ~printer:(IO.to_string print) (diff (of_list [1,5]) (of_list [2,3])) (of_list [1,1;4,5]) (diff (of_list [1,3;6,8]) (of_list [3,6])) (of_list [1,2;7,8]) *) let rec compare_aux x1 x2 = match x1, x2 with [], [] -> 0 | `Set s :: rest, x -> if is_empty s then compare_aux rest x2 else let l = left_branch s in let v = root s in let r = right_branch s in compare_aux (`Set l :: `Range v :: `Set r :: rest) x | _x, `Set s :: rest -> if is_empty s then compare_aux x1 rest else let l = left_branch s in let v = root s in let r = right_branch s in compare_aux x1 (`Set l :: `Range v :: `Set r :: rest) | `Range ((v1, v2)) :: rest1, `Range ((v3, v4)) :: rest2 -> let sgn = BatInt.compare v1 v3 in if sgn <> 0 then sgn else let sgn = BatInt.compare v2 v4 in if sgn <> 0 then sgn else compare_aux rest1 rest2 | [], _ -> ~-1 | _, [] -> 1 let compare s1 s2 = compare_aux [`Set s1] [`Set s2] let equal s1 s2 = compare s1 s2 = 0 (*$T equal not (equal (of_list [3,3;5,5]) (of_list [3,3;1,1])) *) let ord = BatOrd.ord compare let rec subset s1 s2 = if is_empty s1 then true else if is_empty s2 then false else let v1, v2 = root s2 in let l2 = left_branch s2 in let r2 = right_branch s2 in let l1 = before v1 s1 in let r1 = after v2 s1 in (subset l1 l2) && (subset r1 r2) (*$T subset subset (of_list [1,3]) (of_list [1,5]) subset (of_list [1,3]) (of_list [1,3]) subset (of_list []) (of_list [1,5]) not (subset (of_list [0,3]) (of_list [1,5])) not (subset (of_list [0,6]) (of_list [1,5])) *) let fold_range f s x0 = BatAvlTree.fold (fun (n1, n2) x -> f n1 n2 x) s x0 let fold f s x0 = let rec g n1 n2 a = if n1 = n2 then f n1 a else g (n1 + 1) n2 (f n1 a) in fold_range g s x0 (*$= fold & ~cmp:Int.equal ~printer:string_of_int (fold (+) (of_list [1,3]) 0) 6 *) let iter proc s = fold (fun n () -> proc n) s () (*$T iter let a = ref 0 in iter (fun _ -> incr a) (of_list [1,3;5,8]); !a = 7 *) let iter_range proc = BatAvlTree.iter (fun (n1, n2) -> proc n1 n2) (*$T iter_range let a = ref 0 in iter_range (fun _ _ -> incr a) (of_list [1,3;5,8]); !a = 2 *) let for_all p s = let rec test_range n1 n2 = if n1 = n2 then p n1 else p n1 && test_range (n1 + 1) n2 in let rec test_set s = if is_empty s then true else let n1, n2 = root s in test_range n1 n2 && test_set (left_branch s) && test_set (right_branch s) in test_set s (*$T for_all for_all (fun x -> x < 10) (of_list [1,3;2,7]) not (for_all (fun x -> x = 5) (of_list [4,5])) *) let exists p s = let rec test_range n1 n2 = if n1 = n2 then p n1 else p n1 || test_range (n1 + 1) n2 in let rec test_set s = if is_empty s then false else let n1, n2 = root s in test_range n1 n2 || test_set (left_branch s) || test_set (right_branch s) in test_set s (*$T exists exists (fun x -> x = 5) (of_list [1,10]) not (exists (fun x -> x = 5) (of_list [1,3;7,10])) *) let filter_range p n1 n2 a = let rec loop n1 n2 a = function None -> if n1 = n2 then make_tree a (n1, n1) empty else loop (n1 + 1) n2 a (if p n1 then Some n1 else None) | Some v1 as x -> if n1 = n2 then make_tree a (v1, n1) empty else if p n1 then loop (n1 + 1) n2 a x else loop (n1 + 1) n2 (make_tree a (v1, n1 - 1) empty) None in loop n1 n2 a None let filter p s = fold_range (filter_range p) empty s (*$T filter true || equal (filter (fun x -> x <> 5) (of_list [1,10])) (of_list [1,4;6,10]) *) let partition_range p n1 n2 (a, b) = let rec loop n1 n2 acc = let acc = let a, b, (v, n) = acc in if p n1 = v then acc else if v then (make_tree a (n, n1) empty, b, (not v, n1)) else (a, make_tree b (n, n1) empty, (not v, n1)) in if n1 = n2 then let a, b, (v, n) = acc in if v then (make_tree a (n, n1) empty, b) else (a, make_tree b (n, n1) empty) else loop (n1 + 1) n2 acc in loop n1 n2 (a, b, (p n1, n1)) let partition p s = fold_range (partition_range p) s (empty, empty) let cardinal s = fold_range (fun n1 n2 c -> c + n2 - n1 + 1) s 0 (*$T cardinal cardinal (of_list [1,3;5,9]) = 8 *) let rev_ranges s = fold_range (fun n1 n2 a -> (n1, n2) :: a) s [] let rec burst_range n1 n2 a = if n1 = n2 then n1 :: a else burst_range n1 (n2 - 1) (n2 :: a) let elements s = let f a (n1, n2) = burst_range n1 n2 a in List.fold_left f [] (rev_ranges s) (*$Q ranges;of_list (Q.list (Q.pair Q.int Q.int)) (fun l -> \ let norml = List.map (fun (x,y) -> if x < y then (x,y) else (y,x)) l in \ let set = of_list norml in \ equal set (ranges set |> of_list) \ ) *) let ranges s = List.rev (rev_ranges s) let min_elt s = let (n, _), _ = split_leftmost s in n let max_elt s = let (_, n), _ = split_rightmost s in n (*$= min_elt & ~printer:string_of_int 3 (of_list [4,7;8,22;23,23;3,3] |> min_elt) 1 (of_list [4,7;8,12;23,23;1,3] |> min_elt) *) (*$T min_elt Result.(catch min_elt empty |> is_exn Not_found) *) (*$= max_elt & ~printer:string_of_int 23 (of_list [4,7;8,22;23,23;3,3] |> max_elt) 21 (of_list [4,7;8,12;15,21;1,3] |> max_elt) *) (*$T max_elt Result.(catch max_elt empty |> is_exn Not_found) *) let choose s = fst (root s) let of_list l = List.fold_left (fun s (lo,hi) -> add_range lo hi s) empty l let of_enum e = BatEnum.fold (fun s (lo,hi) -> add_range lo hi s) empty e let print oc t = let print_range oc (lo,hi) = if lo=hi then BatInt.print oc lo else BatTuple.Tuple2.printn BatInt.print oc (lo,hi) in BatEnum.print print_range oc (enum t) (*$= print & ~printer:(fun x -> x) "(1,3) (5,6)" (IO.to_string print (of_list [1,3;5,6])) *) batteries-included-3.4.0/src/batISet.mli000066400000000000000000000115241415601150500201130ustar00rootroot00000000000000(* $Id: iSet.mli,v 1.1 2003/12/19 17:24:34 yori Exp $ *) (* Copyright 2003 Yamagata Yoriyuki. distributed with LGPL *) (** DIET : Discrete Interval Encoding Trees Sets of integers represented as ranges This data structure is efficient for large sets of integers where many adjacent integers are all part of the set. This will have higher overhead for sets with lots of point elements, but will be much more efficient for sets containing mostly ranges. *) type t = (int * int) BatAvlTree.tree (** the underlying representation is a balanced tree of ranges *) type elt = int (** This kind of set only holds ints *) val empty : t (** The empty set *) val is_empty : t -> bool (** Test whether a set is empty, returns [true] if the set is empty. *) val mem : int -> t -> bool (** test whether a given int is a member of the set *) val add : int -> t -> t (** Add the given int to the set, returning a new set *) val add_range : int -> int -> t -> t (** [add_range lo hi t] adds the range of integers [lo, hi] (including both endpoints) to the given set, returning a new set @raise Invalid_argument if [lo] > [hi] *) val singleton : int -> t (** Return the singleton set containing only the given element *) val remove : int -> t -> t (** Remove an element from the given set, returning a new set *) val remove_range : int -> int -> t -> t (** [remove_range lo hi t] removes a range of elements from the given set, returning a new set @raise Invalid_argument if [lo] > [hi] *) val union : t -> t -> t (** Compute the union of two sets. This is the set whose elements are those elements in either input set. *) val inter : t -> t -> t (** Compute the intersection of two sets. This is the set whose elements are those in *both* of the input sets. *) val diff : t -> t -> t (** Compute the difference between two sets. This is the set of elements that are in the first but not in the second. Unlike [union] and [inter], order matters here.*) val compl : t -> t (** Create the complement of the given set - i.e. the set of all values not in the input set. *) val compare : t -> t -> int (** Compare two sets. It is not safe to use the polymorphic (<) and related functions to compare these sets, as the tree representation used can balance in multiple ways. *) val equal : t -> t -> bool (** Test whether two sets are equal. It is not safe to use the polymorphic (=) on these sets, as the same set can have multiple representations depending on how it was built. *) val ord : t -> t -> BatOrd.order (** Same as [compare] but returns [BatOrd.Lt | BatOrd.Eq | BatOrd.Gt] instead of an int. *) val subset : t -> t -> bool (** [subset t u] returns [true] if [t] is a subset of [u] *) val from : int -> t -> t (** [from x t] returns the portion of [t] in the range [x, max_int] *) val after : int -> t -> t (** [after x t] returns the portion of [t] in the range [x+1, max_int] *) val until : int -> t -> t (** [until x t] returns the portion of [t] in the range [min_int, x] *) val before : int -> t -> t (** [before x t] returns the portion of [t] in the range [min_int, x-1] *) val iter : (int -> unit) -> t -> unit (** [iter f t] calls [f] once for each element of [t] *) val iter_range : (int -> int -> unit) -> t -> unit (** [iter_range f t] calls [f] once for each contiguous range of [t]. The contiguous ranges of a set are sequences of adjacent integers all part of the set. *) val fold : (int -> 'a -> 'a) -> t -> 'a -> 'a (** [fold f t x0] returns the final result of merging each element of [t] into [x0] using merge function [f] *) val fold_range : (int -> int -> 'a -> 'a) -> t -> 'a -> 'a (** As fold, but operates on contiguous ranges *) val for_all : (int -> bool) -> t -> bool (** Tests whether a predicate applies to all elements of the set *) val exists : (int -> bool) -> t -> bool (** Test whether some element of a set satisfies a predicate *) val filter : (int -> bool) -> t -> t (** Builds the subset of those elements that satisfy the predicate *) val partition : (int -> bool) -> t -> t * t (** partitions the input set into two sets with elements that satisfy the predicate and those that don't *) val cardinal : t -> int (** Returns the number of elements in the set *) val elements : t -> int list (** Returns a list of all elements in the set *) val ranges : t -> (int * int) list (** Returns a list of all contiguous ranges in the set *) val min_elt : t -> int (** Returns the minimum element in the set *) val max_elt : t -> int (** Returns the maximum element in the set *) val choose : t -> int (** Returns some element in the set *) val enum : t -> (int * int) BatEnum.t (** Enumerates all contiguous ranges in the set *) val of_enum : (int*int) BatEnum.t -> t val of_list : (int*int) list -> t (** Build a ISet.t out of a list or enum of ranges *) val print : _ BatIO.output -> t -> unit batteries-included-3.4.0/src/batInnerIO.ml000066400000000000000000000405311415601150500204010ustar00rootroot00000000000000(* * BatInnerIO - Abstract input/output (inner module) * Copyright (C) 2003 Nicolas Cannasse * 2008 Philippe Strauss * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type 'a weak_set = ('a, unit) BatInnerWeaktbl.t let weak_create size = BatInnerWeaktbl.create size let weak_add set element = BatInnerWeaktbl.add set element () let weak_iter f s = BatInnerWeaktbl.iter (fun x _ -> f x) s type input = { mutable in_read : unit -> char; mutable in_input : Bytes.t -> int -> int -> int; mutable in_close : unit -> unit; in_id: int;(**A unique identifier.*) in_upstream: input weak_set } type 'a output = { mutable out_write : char -> unit; mutable out_output: Bytes.t -> int -> int -> int; mutable out_close : unit -> 'a; mutable out_flush : unit -> unit; out_id: int;(**A unique identifier.*) out_upstream:unit output weak_set (** The set of outputs which have been created to write to this output.*) } module Input = struct type t = input let compare x y = x.in_id - y.in_id let hash x = x.in_id let equal x y = x.in_id = y.in_id end module Output = struct type t = unit output let compare x y = x.out_id - y.out_id let hash x = x.out_id let equal x y = x.out_id = y.out_id end (**All the currently opened outputs -- used to permit [flush_all] and [close_all].*) (*module Inputs = Weaktbl.Make(Input)*) module Outputs= Weak.Make(Output) (** {6 Primitive operations}*) external noop : unit -> unit = "%ignore" external cast_output : 'a output -> unit output = "%identity" let lock = ref BatConcurrent.nolock let outputs = Outputs.create 32 let outputs_add out = BatConcurrent.sync !lock (Outputs.add outputs) out let outputs_remove out = BatConcurrent.sync !lock (Outputs.remove outputs) out exception No_more_input exception Input_closed exception Output_closed let post_incr r = let result = !r in incr r; result let post r op = let result = !r in r := op !r; result let uid = ref 0 let uid () = post_incr uid let on_close_out out f = BatConcurrent.sync !lock (fun () -> let do_close = out.out_close in out.out_close <- (fun () -> f out; do_close ())) () let on_close_in inp f = BatConcurrent.sync !lock (fun () -> let do_close = inp.in_close in inp.in_close <- (fun () -> f inp; do_close ())) () let close_in i = let f _ = raise Input_closed in i.in_close(); i.in_read <- f; i.in_input <- f; i.in_close <- noop (*Double closing is not a problem*) let wrap_in ~read ~input ~close ~underlying = let result = { in_read = read; in_input = input; in_close = close; in_id = uid (); in_upstream = weak_create 2 } in BatConcurrent.sync !lock (List.iter (fun x -> weak_add x.in_upstream result)) underlying; Gc.finalise close_in result; result let inherit_in ?read ?input ?close inp = let read = match read with None -> inp.in_read | Some f -> f and input = match input with None -> inp.in_input| Some f -> f and close = match close with None -> ignore | Some f -> f in wrap_in ~read ~input ~close ~underlying:[inp] let create_in ~read ~input ~close = wrap_in ~read ~input ~close ~underlying:[] (*For recursively closing outputs, we need either polymorphic recursion or a hack. Well, a hack it is.*) (*Close a [unit output] -- note that this works for any kind of output, thanks to [cast_output], but this can't return a proper result.*) let rec close_unit (o:unit output) : unit = let forbidden _ = raise Output_closed in o.out_flush (); weak_iter close_unit o.out_upstream; let r = o.out_close() in o.out_write <- forbidden; o.out_output <- forbidden; o.out_close <- (fun _ -> r) (*Closing again is not a problem*); o.out_flush <- noop (*Flushing again is not a problem*); () (*Close a ['a output] -- first close it as a [unit output] then recover the result.*) let close_out o = (* Printf.eprintf "close_out\n%!";*) close_unit (cast_output o); o.out_close () let ignore_close_out out = ignore (close_out out) let wrap_out ~write ~output ~flush ~close ~underlying = let rec out = { out_write = write; out_output = output; out_close = (fun () -> outputs_remove (cast_output out); close ()); out_flush = flush; out_id = uid (); out_upstream = weak_create 2 } in let o = cast_output out in BatConcurrent.sync !lock (List.iter (fun x -> weak_add x.out_upstream o)) underlying; outputs_add (cast_output out); Gc.finalise ignore_close_out out; out let inherit_out ?write ?output ?flush ?close out = let write = match write with None -> out.out_write | Some f -> f and output= match output with None -> out.out_output| Some f -> f and flush = match flush with None -> out.out_flush | Some f -> f and close = match close with None -> ignore | Some f -> f in wrap_out ~write ~output ~flush ~close ~underlying:[out] let create_out ~write ~output ~flush ~close = wrap_out ~write ~output ~flush ~close ~underlying:[] let read i = i.in_read() let nread i n = if n < 0 then invalid_arg "BatIO.nread"; if n = 0 then "" else let s = Bytes.create n in let l = ref n in let p = ref 0 in try while !l > 0 do let r = i.in_input s !p !l in if r = 0 then raise No_more_input; p := !p + r; l := !l - r; done; Bytes.unsafe_to_string s with No_more_input as e -> if !p = 0 then raise e; Bytes.sub_string s 0 !p let really_output o s p l' = let sl = Bytes.length s in if p + l' > sl || p < 0 || l' < 0 then invalid_arg "BatIO.really_output"; let l = ref l' in let p = ref p in while !l > 0 do let w = o.out_output s !p !l in if w = 0 then raise Sys_blocked_io; p := !p + w; l := !l - w; done; l' let really_output_substring o s p l' = really_output o (Bytes.of_string s) p l' let input i s p l = let sl = Bytes.length s in if p + l > sl || p < 0 || l < 0 then invalid_arg "BatIO.input"; if l = 0 then 0 else i.in_input s p l let really_input i s p l' = let sl = Bytes.length s in if p + l' > sl || p < 0 || l' < 0 then invalid_arg "BatIO.really_input"; let l = ref l' in let p = ref p in while !l > 0 do let r = i.in_input s !p !l in if r = 0 then raise Sys_blocked_io; p := !p + r; l := !l - r; done; l' let really_nread i n = if n < 0 then invalid_arg "BatIO.really_nread"; if n = 0 then "" else let s = Bytes.create n in ignore(really_input i s 0 n); Bytes.unsafe_to_string s let write o x = o.out_write x let nwrite_bytes o s = let p = ref 0 in let l = ref (Bytes.length s) in while !l > 0 do let w = o.out_output s !p !l in (* FIXME: unknown how many characters were already written *) if w = 0 then raise Sys_blocked_io; p := !p + w; l := !l - w; done let nwrite o s = nwrite_bytes o (Bytes.unsafe_of_string s) let output o s p l = let sl = Bytes.length s in if p + l > sl || p < 0 || l < 0 then invalid_arg "BatIO.output"; o.out_output s p l let output_substring o s p l = output o (Bytes.unsafe_of_string s) p l let flush o = o.out_flush() let flush_all () = BatConcurrent.sync !lock ( Outputs.iter (fun o -> try flush o with _ -> ())) outputs let close_all () = let outs = BatConcurrent.sync !lock (Outputs.fold (fun o os -> o :: os) outputs) [] in List.iter (fun o -> try close_out o with _ -> ()) outs let read_all i = let maxlen = 1024 in let str = ref [] in let pos = ref 0 in let rec loop() = let s = nread i maxlen in str := (s,!pos) :: !str; pos := !pos + String.length s; loop() in try loop() with No_more_input | Input_closed -> let buf = Bytes.create !pos in List.iter (fun (s,p) -> Bytes.blit_string s 0 buf p (String.length s) ) !str; Bytes.unsafe_to_string buf let input_string s = let pos = ref 0 in let len = String.length s in create_in ~read:(fun () -> if !pos >= len then raise No_more_input else String.unsafe_get s (post_incr pos)) ~input:(fun sout p l -> if !pos >= len then raise No_more_input; let n = (if !pos + l > len then len - !pos else l) in Bytes.blit_string s (post pos ( (+) n ) ) sout p n; n ) ~close:noop (** {6 Standard BatIO} *) let default_buffer_size = 16 (*Arbitrary number. If you replace it, just don't put something too small, i.e. anything smaller than 10 is probably a bad idea.*) let output_string() = let b = Buffer.create default_buffer_size in create_out ~write: (fun c -> Buffer.add_char b c ) ~output: (fun s p l -> BatBytesCompat.buffer_add_subbytes b s p l; l ) ~close: (fun () -> Buffer.contents b) ~flush: noop (** A placeholder used to allow recursive use of [self] in an [input_channel]*) let placeholder_in = { in_read = (fun () -> ' '); in_input = (fun _ _ _ -> 0); in_close = noop; in_id = (-1); in_upstream= weak_create 0 } let input_channel ?(autoclose=true) ?(cleanup=true) ch = let me = ref placeholder_in (*placeholder*) in let result = create_in ~read:(fun () -> try input_char ch with End_of_file -> if autoclose then close_in !me; raise No_more_input) ~input:(fun s p l -> let n = Pervasives.input ch s p l in if n = 0 then begin if autoclose then close_in !me else (); raise No_more_input end else n) ~close:(if cleanup then fun () -> Pervasives.close_in ch else ignore) in me := result; result let output_channel ?(cleanup=false) ch = create_out ~write: (fun c -> output_char ch c) ~output:(fun s p l -> Pervasives.output ch s p l; l) ~close: (if cleanup then fun () -> begin (* Printf.eprintf "Cleaning up\n%!";*) Pervasives.close_out ch end else fun () -> begin (* Printf.eprintf "Not cleaning up\n%!";*) Pervasives.flush ch end) ~flush: (fun () -> Pervasives.flush ch) let pipe() = let input = ref "" in let inpos = ref 0 in let output = Buffer.create default_buffer_size in let flush() = input := Buffer.contents output; inpos := 0; Buffer.reset output; if String.length !input = 0 then raise No_more_input in let read() = if !inpos = String.length !input then flush(); String.unsafe_get !input (post_incr inpos) in let input s p l = if !inpos = String.length !input then flush(); let r = if !inpos + l <= String.length !input then l else String.length !input - !inpos in Bytes.blit_string !input !inpos s p r; inpos := !inpos + r; r in let write c = Buffer.add_char output c in let output s p l = BatBytesCompat.buffer_add_subbytes output s p l; l in let input = create_in ~read ~input ~close:noop and output = create_out ~write ~output ~close:noop ~flush:noop in input , output (*let to_input_channel inp = let (fin, fout) = Unix.pipe () in let outp = out_channel fout in (*connect [inp] to [outp]*) in_channel_of_descr fin*) (** {6 Binary APIs} *) exception Overflow of string let read_byte i = int_of_char (i.in_read()) let read_signed_byte i = let c = int_of_char (i.in_read()) in if c land 128 <> 0 then c - 256 else c let read_string i = let b = Buffer.create 8 in let rec loop() = let c = i.in_read() in if c <> '\000' then begin Buffer.add_char b c; loop(); end; in loop(); Buffer.contents b let read_line i = let b = Buffer.create 80 in let cr = ref false in let rec loop() = match i.in_read() with | '\n' -> () | '\r' when !cr -> Buffer.add_char b '\r'; loop() | '\r' -> cr := true; loop() | c when !cr -> cr := false; Buffer.add_char b '\r'; Buffer.add_char b c; loop(); | c -> Buffer.add_char b c; loop() in try loop(); Buffer.contents b with No_more_input -> if !cr then Buffer.add_char b '\r'; if Buffer.length b > 0 then Buffer.contents b else raise No_more_input (*$= read_line & ~cmp:BatString.equal ~printer:String.quote "abc" (read_line (BatIO.input_string "abc\ndef\n")) "abc" (read_line (BatIO.input_string "abc\r\ndef\n")) "abc\r" (read_line (BatIO.input_string "abc\r\r\ndef\n")) "abc" (read_line (BatIO.input_string "abc")) "abc\r" (read_line (BatIO.input_string "abc\r")) "kldsjf\r\r\rasdfa" (read_line (BatIO.input_string "kldsjf\r\r\rasdfa\nsfdsagf\n")) *) let read_ui16 i = let ch1 = read_byte i in let ch2 = read_byte i in ch1 lor (ch2 lsl 8) let read_i16 i = let ch1 = read_byte i in let ch2 = read_byte i in let n = ch1 lor (ch2 lsl 8) in if ch2 land 128 <> 0 then n - 65536 else n let fix = lnot 0x7FFFFFFF (* -:) *) let read_i32 ch = let ch1 = read_byte ch in let ch2 = read_byte ch in let ch3 = read_byte ch in let ch4 = read_byte ch in if ch4 land 128 <> 0 then begin if ch4 land 64 = 0 then raise (Overflow "read_i32"); (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor ((ch4 land 127) lsl 24)) lor fix (* FIX HERE *) end else begin if ch4 land 64 <> 0 then raise (Overflow "read_i32"); ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor (ch4 lsl 24) end let read_real_i32 ch = let ch1 = read_byte ch in let ch2 = read_byte ch in let ch3 = read_byte ch in let base = Int32.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in let big = Int32.shift_left (Int32.of_int (read_byte ch)) 24 in Int32.logor base big let read_i64 ch = let ch1 = read_byte ch in let ch2 = read_byte ch in let ch3 = read_byte ch in let ch4 = read_byte ch in let base = Int64.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in let small = Int64.logor base (Int64.shift_left (Int64.of_int ch4) 24) in let big = Int64.of_int32 (read_real_i32 ch) in Int64.logor (Int64.shift_left big 32) small let read_double ch = Int64.float_of_bits (read_i64 ch) let read_float ch = Int32.float_of_bits (read_real_i32 ch) let write_byte o n = (* doesn't test bounds of n in order to keep semantics of Pervasives.output_byte *) write o (Char.unsafe_chr (n land 0xFF)) let write_string o s = nwrite o s; write o '\000' let write_bytes o b = nwrite o b let write_line o s = nwrite o s; write o '\n' let write_ui16 ch n = if n < 0 || n > 0xFFFF then raise (Overflow "write_ui16"); write_byte ch n; write_byte ch (n lsr 8) let write_i16 ch n = if n < -0x8000 || n > 0x7FFF then raise (Overflow "write_i16"); if n < 0 then write_ui16 ch (65536 + n) else write_ui16 ch n let write_i32 ch n = write_byte ch n; write_byte ch (n lsr 8); write_byte ch (n lsr 16); write_byte ch (n asr 24) let write_real_i32 ch n = let base = Int32.to_int n in let big = Int32.to_int (Int32.shift_right_logical n 24) in write_byte ch base; write_byte ch (base lsr 8); write_byte ch (base lsr 16); write_byte ch big let write_i64 ch n = write_real_i32 ch (Int64.to_int32 n); write_real_i32 ch (Int64.to_int32 (Int64.shift_right_logical n 32)) let write_double ch f = write_i64 ch (Int64.bits_of_float f) let write_float ch f = write_real_i32 ch (Int32.bits_of_float f) let stdin = input_channel Pervasives.stdin let stdout = output_channel Pervasives.stdout let stderr = output_channel Pervasives.stderr let stdnull= create_out ~write:ignore ~output:(fun _ _ l -> l) ~flush:ignore ~close:ignore let get_output out = out.out_output let get_flush out = out.out_flush let get_output_id out = out.out_id let get_input_id inp = inp.in_id batteries-included-3.4.0/src/batInnerIO.mli000066400000000000000000000355631415601150500205630ustar00rootroot00000000000000(* * BatInnerIO - Abstract input/output (inner module) * Copyright (C) 2003 Nicolas Cannasse * 2008 David Teller * 2008 Philippe Strauss * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Core of the BatIO module. This module contains the core definitions of {!BatIO}, so as to avoid circular dependencies between modules which only need simple functions of {!BatIO} and that module itself. Don't use this module, use {!BatIO}. @author Nicolas Cannasse @author David Teller @author Philippe Strauss @author Edgar Friendly *) type input type 'a output exception No_more_input (** This exception is raised when reading on an input with the [read] or [nread] functions while there is no available token to read. *) exception Input_closed (** This exception is raised when reading on a closed input. *) exception Output_closed (** This exception is raised when reading on a closed output. *) val read : input -> char (** Read a single char from an input or raise [No_more_input] if no input available. *) val read_all : input -> string (** read all the contents of the input until [No_more_input] is raised. *) val pipe : unit -> input * unit output (** Create a pipe between an input and an output. Data written from the output can be read from the input. *) val nread : input -> int -> string (** [nread i n] reads a string of size up to [n] from an input. The function will raise [No_more_input] if no input is available. It will raise [Invalid_argument] if [n] < 0. *) val really_nread : input -> int -> string (** [really_nread i n] reads a string of exactly [n] characters from the input. @raise No_more_input if at least [n] characters are not available. @raise Invalid_argument if [n] < 0. *) val input : input -> Bytes.t -> int -> int -> int (** [input i s p len] reads up to [len] bytes from the given input, storing them in byte sequence [s], starting at position [p]. It returns the actual number of bytes read or raise [No_more_input] if no character can be read. It will raise [Invalid_argument] if [p] and [len] do not designate a valid subsequence of [s]. *) val really_input : input -> Bytes.t -> int -> int -> int (** [really_input i s p len] reads exactly [len] characters from the given input, storing them in the byte sequence [s], starting at position [p]. For consistency with {!BatIO.input} it returns [len]. @raise No_more_input if at least [len] characters are not available. @raise Invalid_argument if [p] and [len] do not designate a valid subsequence of [s]. *) val close_in : input -> unit (** Close the input. It can no longer be read from. *) (*val auto_close_in : input -> input (** Create a new channel which will close automatically once there is nothing left to read.*)*) val write : 'a output -> char -> unit (** Write a single char to an output. *) val nwrite : 'a output -> string -> unit (** Write a string to an output. *) val nwrite_bytes : 'a output -> Bytes.t -> unit (** Write a byte sequence to an output. @since 2.8.0 *) val output : 'a output -> Bytes.t -> int -> int -> int (** [output o s p len] writes up to [len] characters from byte sequence [len], starting at offset [p]. It returns the number of characters written. It will raise [Invalid_argument] if [p] and [len] do not designate a valid subsequence of [s]. *) val output_substring : 'a output -> string -> int -> int -> int (** like [output] above, but outputs from a substring instead of a subsequence of bytes @since 2.8.0 *) val really_output : 'a output -> Bytes.t -> int -> int -> int (** [really_output o s p len] writes exactly [len] characters from byte sequence [s] onto the the output, starting with the character at offset [p]. For consistency with {!BatIO.output} it returns [len]. @raise Invalid_argument if [p] and [len] do not designate a valid subsequence of [s]. *) val really_output_substring : 'a output -> string -> int -> int -> int (** like [really_output] above, but outputs from a substring instead of a subsequence of bytes @since 2.8.0 *) val flush : 'a output -> unit (** Flush an output. *) val flush_all : unit -> unit (** Flush all outputs. *) val close_out : 'a output -> 'a (** Close the output and return its accumulator data. It can no longer be written. *) val close_all : unit -> unit (** Close all outputs. Ignore errors.*) val input_string : string -> input (** Create an input that will read from a string. *) val output_string : unit -> string output (** Create an output that will write into a string in an efficient way. When closed, the output returns all the data written into it. *) val on_close_out : 'a output -> ('a output -> unit) -> unit (** Register a function to be triggered just before an output is closed. *) val create_in : read:(unit -> char) -> input:(Bytes.t -> int -> int -> int) -> close:(unit -> unit) -> input (** Fully create an input by giving all the needed functions. {b Note} Do {e not} use this function for creating an input which reads from one or more underlying inputs. Rather, use {!wrap_in}. *) val inherit_in: ?read:(unit -> char) -> ?input:(Bytes.t -> int -> int -> int) -> ?close:(unit -> unit) -> input -> input (** Simplified and optimized version of {!wrap_in} whenever only one input appears as dependency. *) val wrap_in : read:(unit -> char) -> input:(Bytes.t -> int -> int -> int) -> close:(unit -> unit) -> underlying:(input list) -> input (** Fully create an input reading from other inputs by giving all the needed functions. This function is a more general version of {!create_in} which also handles dependency management between inputs. *) val create_out : write:(char -> unit) -> output:(Bytes.t -> int -> int -> int) -> flush:(unit -> unit) -> close:(unit -> 'a) -> 'a output (** Fully create an output by giving all the needed functions. @param write Write one character to the output (see {!write}). @param output Write a (sub)string to the output (see {!output}). @param flush Flush any buffers of this output (see {!flush}). @param close Close this output. The output will be automatically flushed. {b Note} Do {e not} use this function for creating an output which writes to one or more underlying outputs. Rather, use {!wrap_out}. *) val inherit_out: ?write:(char -> unit) -> ?output:(Bytes.t -> int -> int -> int) -> ?flush:(unit -> unit) -> ?close:(unit -> unit) -> _ output -> unit output (** Simplified and optimized version of {!wrap_out} whenever only one output appears as dependency. *) val wrap_out : write:(char -> unit) -> output:(Bytes.t -> int -> int -> int) -> flush:(unit -> unit) -> close:(unit -> 'a) -> underlying:('b output list) -> 'a output (** Fully create an output that writes to one or more underlying outputs. This function is a more general version of {!create_out}, which also handles dependency management between outputs. To illustrate the need for dependency management, let us consider the following values: - an output [out] - a function [f : _ output -> _ output], using {!create_out} to create a new output for writing some data to an underyling output (for instance, a function comparale to {!tab_out} or a function performing transparent compression or transparent traduction between encodings) With these values, let us consider the following scenario - a new output [f out] is created - some data is written to [f out] but not flushed - output [out] is closed, perhaps manually or as a consequence of garbage-collection, or because the program has ended - data written to [f out] is flushed. In this case, data reaches [out] only after [out] has been closed, which violates the protocol. Despite appearances, it is quite easy to reach such situation, especially in short programs. The solution is to use [wrap_out] rather than [create_out] in [f]. Specifying that [f out] writes on [out] will then let the run-time flush and close [f out] when [out] is closed for any reason, which in turn avoids the issue. @param write Write one character to the output (see {!write}). @param output Write a (sub)string to the output (see {!output}). @param flush Flush any buffers of this output (see {!flush}). @param close Close this output. The output will be automatically flushed. @param underlying The list of outputs to which the new output will write. {b Note} Function [close] should {e not} close [underlying] yourself. This is a common mistake which may cause sockets or standard output to be closed while they are still being used by another part of the program. *) val default_buffer_size : int (**The default size of buffers.*) (** {6 Binary files API} Here is some API useful for working with binary files, in particular binary files generated by C applications. By default, encoding of multibyte integers is low-endian. The BigEndian module provide multibyte operations with other encoding. *) exception Overflow of string (** Exception raised when a read or write operation cannot be completed. *) val read_byte : input -> int (** Read an unsigned 8-bit integer. *) val read_signed_byte : input -> int (** Read an signed 8-bit integer. *) val read_ui16 : input -> int (** Read an unsigned 16-bit word. *) val read_i16 : input -> int (** Read a signed 16-bit word. *) val read_i32 : input -> int (** Read a signed 32-bit integer. @raise Overflow if the read integer cannot be represented as an OCaml 31-bit integer. *) val read_real_i32 : input -> int32 (** Read a signed 32-bit integer as an OCaml int32. *) val read_i64 : input -> int64 (** Read a signed 64-bit integer as an OCaml int64. *) val read_float : input -> float (** Read an IEEE single precision floating point value. *) val read_double : input -> float (** Read an IEEE double precision floating point value. *) val read_string : input -> string (** Read a null-terminated string. *) val read_line : input -> string (** Read a LF or CRLF terminated string. *) val write_byte : 'a output -> int -> unit (** Write an unsigned 8-bit byte. *) val write_ui16 : 'a output -> int -> unit (** Write an unsigned 16-bit word. *) val write_i16 : 'a output -> int -> unit (** Write a signed 16-bit word. *) val write_i32 : 'a output -> int -> unit (** Write a signed 32-bit integer. *) val write_real_i32 : 'a output -> int32 -> unit (** Write an OCaml int32. *) val write_i64 : 'a output -> int64 -> unit (** Write an OCaml int64. *) val write_double : 'a output -> float -> unit (** Write an IEEE double precision floating point value. *) val write_float : 'a output -> float -> unit (** Write an IEEE single precision floating point value. *) val write_string : 'a output -> string -> unit (** Write a string and append an null character. *) val write_line : 'a output -> string -> unit (** Write a line and append a LF (it might be converted to CRLF on some systems depending on the underlying BatIO). *) external cast_output : 'a output -> unit output = "%identity" (** You can safely transform any output to an unit output in a safe way by using this function. *) (** {6 For compatibility purposes} *) val input_channel : ?autoclose:bool -> ?cleanup:bool -> in_channel -> input (** Create an input that will read from a channel. @param autoclose If true or unspecified, the {!type: input} will be automatically closed when the underlying [in_channel] has reached its end. @param cleanup If true, the channel will be automatically closed when the {!type: input} is closed. Otherwise, you will need to close the channel manually. *) val output_channel : ?cleanup:bool -> out_channel -> unit output (** Create an output that will write into a channel. @param cleanup If true, the channel will be automatically closed when the {!type: output} is closed. Otherwise, you will need to close the channel manually. *) (* val to_input_channel : input -> in_channel (** Create a channel that will read from an input. {b Note} This function is very costly and is provided essentially for debugging purposes or for reusing legacy libraries which can't be adapted. As a general rule, if you can avoid using this function, don't use it.*) val to_output_channel: _ output -> out_channel (** Create a channel that will write to an output {b Note} This function is very costly and is provided essentially for debugging purposes or for reusing legacy libraries which can't be adapted. As a general rule, if you can avoid using this function, don't use it.*) *) (** {6 Standard inputs/outputs} *) val stdin : input (** Standard input, as per Unix/Windows conventions (by default, keyboard).*) val stdout: unit output (** Standard output, as per Unix/Windows conventions (by default, console). Use this output to display regular messages.*) val stderr: unit output (** Standard error output, as per Unix/Windows conventions. Use this output to display warnings and error messages. *) val stdnull: unit output (** An output which discards everything written to it. Use this output to ignore messages.*) (** {6 Comparison} The following modules may be useful to create hashtables of inputs or outputs. *) module Input : sig type t = input val compare : input -> input -> int (**A total order on inputs*) val hash : input -> int (**A hash function for inputs*) val equal : input -> input -> bool end module Output : sig type t = unit output val compare : _ output -> _ output -> int (**A total order on outputs*) val hash : _ output -> int (**A hash function for outputs*) val equal : _ output -> _ output -> bool end (**/**) (**{6 Internals}*) external noop : unit -> unit = "%ignore" (** {7 Optimized access to fields} *) val get_output : _ output -> (Bytes.t -> int -> int -> int) val get_flush : _ output -> (unit -> unit) val lock : BatConcurrent.lock ref (** A reference to a set of locking operations. *) (** {7 Facilities for debugging} *) val get_output_id : _ output -> int val get_input_id : input -> int (**/**) batteries-included-3.4.0/src/batInnerPervasives.mlv000066400000000000000000000045341415601150500224120ustar00rootroot00000000000000(* * Copyright (C) 2012 Batteries Included Development Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (* Inner functions for Pervasives, that can be accessed from other modules without pulling in all of batteries as deps. *) let finally handler f x = let r = ( try f x with e -> handler(); raise e ) in handler(); r let with_dispose ~dispose f x = finally (fun () -> dispose x) f x (* unique int generation *) let unique_value = ref 0 let lock = ref BatConcurrent.nolock let unique () = BatConcurrent.sync !lock BatRef.post_incr unique_value (*$Q unique Q.unit (fun () -> unique () <> unique ()) *) type ('a, 'b) result = ##V>=4.8## ('a, 'b) Stdlib.result = | Ok of 'a | Error of 'b (* Ideas taken from Nicholas Pouillard's my_std.ml in ocamlbuild/ *) let ignore_ok = function Ok _ -> () | Error ex -> raise ex let ok = function Ok v -> v | Error ex -> raise ex let wrap f x = try Ok (f x) with ex -> Error ex let forever f x = ignore (while true do ignore (f x) done) let ignore_exceptions f x = try ignore (f x) with _ -> () (** {6 Operators}*) ##V<4## let ( |> ) x f = f x ##V>=4## external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply" ##V<4## let ( @@ ) f x = f x ##V>=4## external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" let ( %> ) f g x = g (f x) let ( % ) f g x = f (g x) let flip f x y = f y x let curry f x y = f (x,y) let uncurry f (x,y) = f x y let const x _ = x let neg p x = not (p x) let neg2 p x y = not (p x y) external identity : 'a -> 'a = "%identity" let tap f x = f x; x let ( |? ) = BatOption.Infix.( |? ) batteries-included-3.4.0/src/batInnerShuffle.ml000066400000000000000000000020661415601150500214670ustar00rootroot00000000000000let array_shuffle ?state a = let random_int state n = match state with | None -> Random.int n | Some s -> Random.State.int s n in for n = Array.length a - 1 downto 1 do let k = random_int state (n + 1) in if k <> n then begin let buf = Array.unsafe_get a n in Array.unsafe_set a n (Array.unsafe_get a k); Array.unsafe_set a k buf end done (*$Q Q.(array_of_size Gen.(2--15) small_int) (fun a -> \ let a' = Array.copy a in \ array_shuffle a'; \ (Array.to_list a' |> List.sort Pervasives.compare) = \ (Array.to_list a |> List.sort Pervasives.compare)) *) (*$R let rec fact = function 0 -> 1 | n -> n * fact (n - 1) in let length = 5 in let test = Array.init length (fun i -> i) in (* all elements must be distinct *) let permut_number = fact length in let histogram = Hashtbl.create permut_number in for i = 1 to 50_000 do let a = Array.copy test in array_shuffle a; Hashtbl.replace histogram a (); done; assert_bool "all permutations occur" (Hashtbl.length histogram = permut_number) *) batteries-included-3.4.0/src/batInnerWeaktbl.mliv000066400000000000000000000137041415601150500220240ustar00rootroot00000000000000(***********************************************************************) (* *) (* Weaktbl *) (* *) (* (C) 2007 by Zheng Li (li@pps.jussieu.fr) *) (* *) (* This program is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Lesser General Public *) (* License version 2.1 as published by the Free Software Foundation, *) (* with the special exception on linking described in file LICENSE. *) (* *) (* This program is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Library General Public License for more details. *) (* *) (***********************************************************************) (** Weak hash table library for OCaml, with an interface compatible with the standard Hashtbl module. *) (** {6 Generic interface} *) type ('a, 'b) t (** The type of hash tables from type ['a] to type ['b]. *) val create : int -> ('a, 'b) t (** [Weaktbl.create n] creates a new, empty hash table, with initial size [n]. For best results, [n] should be on the order of the expected number of elements that will be in the table. The table grows as needed, so [n] is just an initial guess. *) val clear : ('a, 'b) t -> unit (** Empty a hash table. *) val add : ('a, 'b) t -> 'a -> 'b -> unit (** [Weaktbl.add tbl x y] adds a binding of [x] to [y] in table [tbl]. Previous bindings for [x] are not removed, but simply hidden. That is, after performing {!Weaktbl.remove}[ tbl x], the previous binding for [x], if any, is restored. (Same behavior as with association lists.) *) val copy : ('a, 'b) t -> ('a, 'b) t (** Return a copy of the given hashtable. *) val find : ('a, 'b) t -> 'a -> 'b (** [Weaktbl.find tbl x] returns the current binding of [x] in [tbl], or raises [Not_found] if no such binding exists. *) val find_all : ('a, 'b) t -> 'a -> 'b list (** [Weaktbl.find_all tbl x] returns the list of all data associated with [x] in [tbl]. The current binding is returned first, then the previous bindings, in reverse order of introduction in the table. *) val mem : ('a, 'b) t -> 'a -> bool (** [Weaktbl.mem tbl x] checks if [x] is bound in [tbl]. *) val remove : ('a, 'b) t -> 'a -> unit (** [Weaktbl.remove tbl x] removes the current binding of [x] in [tbl], restoring the previous binding if it exists. It does nothing if [x] is not bound in [tbl]. *) val replace : ('a, 'b) t -> 'a -> 'b -> unit (** [Weaktbl.replace tbl x y] replaces the current binding of [x] in [tbl] by a binding of [x] to [y]. If [x] is unbound in [tbl], a binding of [x] to [y] is added to [tbl]. This is functionally equivalent to {!Weaktbl.remove}[ tbl x] followed by {!Weaktbl.add}[ tbl x y]. *) val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit (** [Weaktbl.iter f tbl] applies [f] to all bindings in table [tbl]. [f] receives the key as first argument, and the associated value as second argument. Each binding is presented exactly once to [f]. The order in which the bindings are passed to [f] is unspecified. However, if the table contains several bindings for the same key, they are passed to [f] in reverse order of introduction, that is, the most recent binding is passed first. *) val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c (** [Weaktbl.fold f tbl init] computes [(f kN dN ... (f k1 d1 init)...)], where [k1 ... kN] are the keys of all bindings in [tbl], and [d1 ... dN] are the associated values. Each binding is presented exactly once to [f]. The order in which the bindings are passed to [f] is unspecified. However, if the table contains several bindings for the same key, they are passed to [f] in reverse order of introduction, that is, the most recent binding is passed first. *) val length : ('a, 'b) t -> int (** [Weaktbl.length tbl] returns the number of bindings in [tbl]. Multiple bindings are counted multiply, so [Weaktbl.length] gives the number of times [Weaktbl.iter] calls its first argument. *) (** {6 Functorial interface} *) module type HashedType = sig type t val equal : t -> t -> bool val hash : t -> int end module type S = sig type key type 'a t val create : int -> 'a t val clear : 'a t -> unit val reset : 'a t -> unit val copy : 'a t -> 'a t val add : 'a t -> key -> 'a -> unit val remove : 'a t -> key -> unit val find : 'a t -> key -> 'a val find_opt : 'a t -> key -> 'a option val find_all : 'a t -> key -> 'a list val replace : 'a t -> key -> 'a -> unit val mem : 'a t -> key -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val filter_map_inplace: (key -> 'a -> 'a option) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val length : 'a t -> int ##V>=4## val stats: 'a t -> Hashtbl.statistics end (** This is a subset of Hashtbl.S, kept as a separate interface to avoid compatibility issues when Hashtbl.S evolves. *) module Make (H : HashedType) : S with type key = H.t (** Functor building an implementation of the hashtable structure. The functor [Weaktbl.Make] returns a structure containing a type [key] of keys and a type ['a t] of hash tables associating data of type ['a] to keys of type [key]. The operations perform similarly to those of the generic interface, but use the hashing and equality functions specified in the functor argument [H] instead of generic equality and hashing. *) batteries-included-3.4.0/src/batInnerWeaktbl.mlv000066400000000000000000000161471415601150500216570ustar00rootroot00000000000000(***********************************************************************) (* *) (* Weaktbl *) (* *) (* (C) 2007 by Zheng Li (li@pps.jussieu.fr) *) (* *) (* This program is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Lesser General Public *) (* License version 2.1 as published by the Free Software Foundation, *) (* with the special exception on linking described in file LICENSE. *) (* *) (* This program is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Library General Public License for more details. *) (* *) (***********************************************************************) (* weak stack, for ordering purpose *) module Stack = struct type 'a t = {mutable data:'a Weak.t; mutable length:int; mutable cursor:int} let create n = let len = min n (Sys.max_array_length - 1) in {data = Weak.create len; length = len; cursor = 0} let iter f s = for i = s.cursor -1 downto 0 do match Weak.get s.data i with Some x -> f x | _ -> () done let length s = (* resize by the way, since it's invoked by push *) let flag = ref false and pt = ref 0 in for i = 0 to s.cursor -1 do match Weak.get s.data i with | Some _ as d -> if !flag then Weak.set s.data !pt d; incr pt | None -> flag := true done; s.cursor <- !pt; s.cursor let copy s = let s' = create s.length in Weak.blit s.data 0 s'.data 0 s.cursor; s'.cursor <- s.cursor; s' let rec push x s = if s.cursor < s.length then (Weak.set s.data s.cursor (Some x); s.cursor <- s.cursor + 1) else let len = length s in if len >= s.length / 3 && len < s.length * 2 / 3 then push x s else let len' = min (len * 3 / 2 + 2) (Sys.max_array_length -1) in if len' = len then failwith "Weaktbl.Stack.push: stack cannot grow" else let data' = Weak.create len' in Weak.blit s.data 0 data' 0 s.cursor; s.data <- data'; s.length <- len'; push x s let rec pop s = if s.cursor <= 0 then raise Not_found; s.cursor <- s.cursor -1; match Weak.get s.data s.cursor with Some x -> x | None -> pop s let rec top s = if s.cursor <= 0 then raise Not_found; match Weak.get s.data (s.cursor -1) with | Some x -> x | None -> s.cursor <- s.cursor -1; top s let is_empty s = (* stop as earlier as we can *) try iter (fun _ -> raise Not_found) s; true with Not_found -> false end module type HashedType = sig type t val equal : t -> t -> bool val hash : t -> int end module type S = sig type key type 'a t val create : int -> 'a t val clear : 'a t -> unit val reset : 'a t -> unit val copy : 'a t -> 'a t val add : 'a t -> key -> 'a -> unit val remove : 'a t -> key -> unit val find : 'a t -> key -> 'a val find_opt : 'a t -> key -> 'a option val find_all : 'a t -> key -> 'a list val replace : 'a t -> key -> 'a -> unit val mem : 'a t -> key -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val filter_map_inplace: (key -> 'a -> 'a option) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val length : 'a t -> int ##V>=4## val stats: 'a t -> Hashtbl.statistics end open Obj (* Recover polymorphism from standard monomorphic (Weak)Hashtbl *) module Make (H: HashedType) : S with type key = H.t = struct type box = H.t Weak.t let enbox k = let w = Weak.create 1 in Weak.set w 0 (Some k); w let unbox bk = Weak.get bk 0 type bind = box * t let bind_new k v = enbox k, repr v type cls = bind Stack.t let cls_new bd = let cls = Stack.create 1 in Stack.push bd cls; cls let dummy k = cls_new (bind_new k ()) let rec top_bind cls = let (bk,v) as bind = Stack.top cls in match unbox bk with | Some k -> k, (obj v) | _ -> assert (bind == Stack.pop cls); top_bind cls let top_key cls = fst (top_bind cls) and top_value cls = snd (top_bind cls) let all_bind cls = let l = ref [] in let f (bk,v) = match unbox bk with | Some k -> l := (k, obj v) :: !l | _ -> () in Stack.iter f cls; List.rev !l let all_key cls = List.map fst (all_bind cls) and all_value cls = List.map snd (all_bind cls) module HX = struct type t = cls let hash x = try H.hash (top_key x) with Not_found -> 0 let equal x y = try H.equal (top_key x) (top_key y) with Not_found -> false end module W = Weak.Make(HX) type key = H.t and 'a t = W.t let create = W.create and clear = W.clear let find_all tbl key = try all_value (W.find tbl (dummy key)) with Not_found-> [] let find tbl key = top_value (W.find tbl (dummy key)) let find_opt tbl key = try Some (find tbl key) with Not_found -> None let add tbl key data = let bd = bind_new key data in let cls = try let c = W.find tbl (dummy key) in Stack.push bd c; c with Not_found -> let c = cls_new bd in W.add tbl c; c in let final _ = ignore bd; ignore cls in try Gc.finalise final key with Invalid_argument _ -> Gc.finalise final bd; Gc.finalise final cls let remove tbl key = try ignore (Stack.pop (W.find tbl (dummy key))) with Not_found -> () let replace tbl key data = remove tbl key; add tbl key data let mem tbl key = try ignore (find tbl key); true with Not_found -> false let iter f tbl = let f' (bk,v) = match unbox bk with Some k -> f k (obj v) | None -> () in W.iter (Stack.iter f') tbl let fold f tbl accu = let r = ref accu in let f' k v = r := f k v !r in iter f' tbl; !r let length tbl = W.fold (fun cls -> (+) (Stack.length cls)) tbl 0 let copy tbl = let tbl'= W.create (W.count tbl * 3 / 2 + 2) in W.iter (fun cls -> W.add tbl' (Stack.copy cls)) tbl; tbl' let stats _ = assert false let reset _ = assert false let filter_map_inplace f tbl = let delta = ref [] in iter (fun k v -> match f k v with | Some v' when v' == v -> () | other -> delta := (k, other) :: !delta) tbl; let handle_delta = function | (k, None) -> remove tbl k | (k, Some v) -> remove tbl k; add tbl k v in List.iter handle_delta !delta end module StdHash = Make (struct type t = Obj.t let equal x y = (compare x y) = 0 let hash = Hashtbl.hash end) open StdHash type ('a,'b) t = 'b StdHash.t let create = create and clear = clear and copy = copy and length = length let add tbl k = add tbl (repr k) let remove tbl k = remove tbl (repr k) let find tbl k = find tbl (repr k) let find_all tbl k = find_all tbl (repr k) let replace tbl k = replace tbl (repr k) let mem tbl k = mem tbl (repr k) let iter f = iter (fun k d -> f (obj k) d) let fold f = fold (fun k d a -> f (obj k) d a) batteries-included-3.4.0/src/batInt.ml000066400000000000000000000251261415601150500176330ustar00rootroot00000000000000(* * BatInt - Extended integers * Copyright (C) 2007 Bluestorm * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open BatNumber let enum () = let current_value = ref min_int in let already_through = ref false in let f () = if !current_value = max_int then if !already_through then raise BatEnum.No_more_elements else ( already_through := true; max_int ) else BatRef.post_incr current_value in BatEnum.from f module BaseInt = struct type t = int let zero, one = 0, 1 external neg : int -> int = "%negint" external add : int -> int -> int = "%addint" external sub : int -> int -> int = "%subint" external mul : int -> int -> int = "%mulint" external div : int -> int -> int = "%divint" external ( + ) : int -> int -> int = "%addint" external ( - ) : int -> int -> int = "%subint" external ( * ) : int -> int -> int = "%mulint" external ( / ) : int -> int -> int = "%divint" external pred: int -> int = "%predint" external succ: int -> int = "%succint" let abs = abs external modulo : int -> int -> int = "%modint" let pow a b = if b < 0 then invalid_arg "Int.pow" else let div_two n = n / 2 and mod_two n = n mod 2 in generic_pow ~zero ~one ~div_two ~mod_two ~mul a b (*$Q pow Q.int (fun a -> pow a 0 = 1) Q.int (fun a -> pow a 1 = a) Q.int (fun a -> pow a 2 = a * a) Q.pos_int (fun b -> b = 0 || pow 0 b = 0) Q.pos_int (fun b -> pow 1 b = 1) (Q.pair Q.int Q.neg_int) (fun (a,b) -> \ b = 0 || Result.(catch2 pow a b |> is_exn (Invalid_argument "Int.pow"))) *) (*$= pow (pow (-2) 3) (-8) (pow 0 0) 1 *) let min_num, max_num = min_int, max_int (* this function is performance sensitive : it is heavily used by associative data structures using ordered keys (Set, Map). The current version, due to Mauricio "mfp" Fernandez, only uses a type annotation to benefit from the excellent compilation of statically-known integer comparisons. It outperforms the previous version calling directly the external primitive "caml_int_compare". *) let compare (x : int) y = if x > y then 1 else if y > x then -1 else 0 external of_int : int -> int = "%identity" external to_int : int -> int = "%identity" let to_string = string_of_int let enum = enum let minus_one = ( - 1) external to_float : int -> float = "%floatofint" external of_float : float -> int = "%intoffloat" external of_string : string -> int = "caml_int_of_string" external rem : int -> int -> int = "%modint" let ( <> ) (a:int) b = a <> b let ( <= ) (a:int) b = a <= b let ( >= ) (a:int) b = a >= b let ( < ) (a:int) b = a < b let ( > ) (a:int) b = a > b let ( = ) (a:int) b = a = b let ( ** ) a b = pow a b (*$T ( ** ) 0 ** 0 = 1 0 ** 1 = 0 (-1) ** 3 = (-1) (-1) ** 4 = 1 15 ** 3 = 3375 7 ** 4 = 2401 *) let print out t = BatInnerIO.nwrite out (string_of_int t) let print_hex out t = BatPrintf.fprintf out "%X" t let ( -- ) x y = BatEnum.seq x (add one) ((>=) y) let ( --- ) x y = if x <= y then x -- y else BatEnum.seq x pred ((<=) y) end (* We want BaseInt versions of these function instead of MakeNumeric ones *) module Compare = struct type bat__compare_t = int let ( <> ), ( >= ), ( <= ), ( > ), ( < ), ( = ) = BaseInt.(( <> ), ( >= ), ( <= ), ( > ), ( < ), ( = )) end include (BatNumber.MakeNumeric(BaseInt) : BatNumber.Numeric with type t := int and module Compare := Compare) include BaseInt let min a b = if a < b then a else b let max a b = if a > b then a else b (*$T min min 3 4 = 3 min 4 4 = 4 min (-3) 5 = -3 min min_int max_int = min_int *) (*$T max max 3 4 = 4 max 4 4 = 4 max (-3) 5 = 5 max min_int max_int = max_int max max_int max_int = max_int max min_int min_int = min_int *) let mid a b = a land b + ((a lxor b) asr 1) (*$Q mid (Q.pair Q.int Q.int) (fun (a,b) -> \ let m = mid a b in \ (a <= b && a <= m && m <= b && abs ((m-a) - (b-m)) <= 1) || \ (b < a && b <= m && m <= a && abs ((m-b) - (a-m)) <= 1)) (Q.int) (fun a -> mid a a = a) *) let popcount = if Sys.word_size = 32 then let k1 = 0x55555555 in let k2 = 0x33333333 in let k3 = 0x0f0f0f0f in (fun x -> let x = x - (x lsr 1) land k1 in let x = ((x lsr 2) land k2) + (x land k2) in let x = (x + (x lsr 4)) land k3 in let x = x + x lsr 8 in (x + x lsr 16) land 0x3f ) else (* word_size = 64 *) (* uses int_of_string to hide these constants from the 32-bit compiler *) let k1 = int_of_string "0x5555_5555_5555_5555" in let k2 = int_of_string "0x3333_3333_3333_3333" in let k4 = int_of_string "0x0f0f_0f0f_0f0f_0f0f" in (fun x -> let x = x - (x lsr 1) land k1 in let x = (x land k2) + ((x lsr 2) land k2) in let x = (x + x lsr 4) land k4 in let x = x + x asr 8 in let x = x + x asr 16 in let x = x + x asr 32 in x land 0x7f ) let popcount_sparse x = let rec loop n x = if x = 0 then n else loop (n+1) (x land (x-1)) in loop 0 x (*$Q popcount (Q.int) (fun x -> popcount x = popcount_sparse x) *) let copysign n o = match n with | 0 -> 0 | n when n > 0 -> o | _ -> - o (*$T copysign copysign 2 1 = 1 copysign 3 1 = 1 copysign 3 5 = 5 copysign max_int min_int = min_int copysign (-22) 12 = -12 copysign 0 42 = 0 *) module BaseSafeInt = struct include BaseInt (** Open this module and [SafeInt] to replace traditional integer operators with their safe counterparts *) let add a b = let c = Pervasives.( + ) a b in if a < 0 && b < 0 && c >= 0 || a > 0 && b > 0 && c <= 0 then raise Overflow else c let sub a b = let c = Pervasives.( - ) a b in if a < 0 && b > 0 && c >= 0 || a > 0 && b < 0 && c <= 0 then raise Overflow else c let neg x = if x <> min_int then ~- x else raise Overflow let succ x = if x <> max_int then succ x else raise Overflow let pred x = if x <> min_int then pred x else raise Overflow let abs x = if x <> min_int then abs x else raise Overflow (* Performance hack: if both operands of the multiplication operator can be represented using the specified amount of bits (not counting the sign bit), then it is safe to assume that overflow does not happen. *) let mul_shift_bits = match Sys.word_size with | 64 -> 31 (* 64 = sign bit + 31*2 + tag bit *) | 32 -> 15 (* 32 = sign bit + 15*2 + tag bit *) | _ -> 0 (* Uses a formula taken from Hacker's Delight, chapter "Overflow Detection", plus a fast-path check (see comment above) *) let mul (a: int) (b: int) : int = let open Pervasives in let c = a * b in if (a lor b) asr mul_shift_bits = 0 || not ((a = min_int && b < 0) || (b <> 0 && c / b <> a)) then c else raise BatNumber.Overflow let pow a b = if b < 0 then invalid_arg "Int.Safe_int.pow" else let div_two n = n / 2 and mod_two n = n mod 2 in BatNumber.generic_pow ~zero ~one ~div_two ~mod_two ~mul a b end module Safe_int = struct module Compare = struct type bat__compare_t = t let ( <> ), ( >= ), ( <= ), ( > ), ( < ), ( = ) = ( <> ), ( >= ), ( <= ), ( > ), ( < ), ( = ) end include (BatNumber.MakeNumeric(BaseSafeInt) : BatNumber.Numeric with type t := int and module Compare := Compare) include BaseSafeInt (* for performance, replace functor-values with direct values *) end (*$T & Result.(catch (Safe_int.add max_int) max_int |> is_exn Number.Overflow) Result.(catch (Safe_int.add min_int) min_int |> is_exn Number.Overflow) Safe_int.add 0 0 = 0 Safe_int.add max_int min_int = (-1) Result.(catch (Safe_int.sub min_int) max_int |> is_exn Number.Overflow) Result.(catch (Safe_int.sub max_int) min_int |> is_exn Number.Overflow) Safe_int.sub 0 0 = 0 Safe_int.neg max_int = -max_int Result.(catch Safe_int.neg min_int |> is_exn Number.Overflow) Result.(catch (List.reduce Safe_int.mul) \ [1 lsl 18 * 21; 3*3*3*3*3*3*3*3; 5*5*5*5*7*7*11*13*17*19] \ |> is_exn Number.Overflow) Safe_int.mul 0 min_int = 0 Safe_int.mul min_int 0 = 0 Safe_int.mul 1 min_int = min_int Safe_int.mul min_int 1 = min_int Safe_int.mul (-1) max_int = -max_int Safe_int.mul max_int (-1) = -max_int Result.(catch (Safe_int.mul min_int) (-1) |> is_exn Number.Overflow) Result.(catch (Safe_int.mul (-1)) min_int |> is_exn Number.Overflow) Result.(catch (Safe_int.Infix.(+) max_int) 1 |> is_exn Number.Overflow) Safe_int.succ 1 = 2 Safe_int.succ (-1) = 0 Safe_int.succ (-2) = (-1) Safe_int.succ 0 = 1 Result.(catch Safe_int.succ max_int |> is_exn Number.Overflow) Safe_int.pred 1 = 0 Safe_int.pred 0 = (-1) Safe_int.pred (-1) = (-2) Result.(catch Safe_int.pred min_int |> is_exn Number.Overflow) Safe_int.abs 0 = 0 Safe_int.abs (-5) = 5 Safe_int.abs 5 = 5 Safe_int.abs max_int = max_int Result.(catch Safe_int.abs min_int |> is_exn Number.Overflow) *) (*$Q & (Q.pair Q.pos_int Q.pos_int) (fun (a,b) -> let (a,b) = max a b, min a b in \ let b = max_int - a + b in try Safe_int.add a b |>ignore; false \ with BatNumber.Overflow -> true) (Q.pair Q.pos_int Q.pos_int) (fun (a,b) -> let (a,b) = max a b, min a b in \ let b = max_int - a + b in try Safe_int.sub (-a) b|>ignore; false \ with BatNumber.Overflow -> true) (Q.pair Q.int Q.int) (fun (a,b) -> \ let slow_mul a b = \ if b = 0 then 0 \ else if (abs a) > max_int / (abs b) then raise BatNumber.Overflow else a*b \ in Pervasives.(=) \ (Result.catch (Safe_int.mul a) b) (Result.catch (slow_mul a) b)) *) (* module Int = struct include BaseInt module Numeric = struct include Numeric(BaseInt) end end module SafeInt = struct include BaseSafeInt module Numeric = struct include Numeric(BaseSafeInt) end end *) batteries-included-3.4.0/src/batInt.mli000066400000000000000000000302231415601150500177760ustar00rootroot00000000000000(* * BatInt - Extended operations on integers * Copyright (C) 2008 Gabriel Scherer * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Operations on integers. This module provides operations on the type [int] of integers. Values of this type may be either 31 bits on 32-bit processors or 63 bits on 64-bit processors. All arithmetic operations over [int] are taken modulo 2{^number of bits}. This module implements {!Number.Numeric}, {!Number.Bounded}, {!Number.Discrete}. @author Gabriel Scherer @author David Teller @documents Int *) type t = int (** An alias for the type of integers. *) val zero : int (** The integer [0]. *) val one : int (** The integer [1]. *) val minus_one : int (** The integer [-1]. *) external neg : int -> int = "%negint" (** Unary negation. *) external add : int -> int -> int = "%addint" (** Addition. *) external ( + ) : int -> int -> int = "%addint" (** Addition. *) external sub : int -> int -> int = "%subint" (** Subtraction. *) external ( - ) : int -> int -> int = "%subint" (** Subtraction. *) external mul : int -> int -> int = "%mulint" (** Multiplication. *) external ( * ) : int -> int -> int = "%mulint" (** Multiplication. *) external div : int -> int -> int = "%divint" (** Integer division. This division rounds the real quotient of its arguments towards zero, as specified for {!Pervasives.(/)}. @raise Division_by_zero if the second argument is zero. *) external ( / ) : int -> int -> int = "%divint" (** Integer division. This division rounds the real quotient of its arguments towards zero, as specified for {!Pervasives.(/)}. @raise Division_by_zero if the second argument is zero. *) external rem : int -> int -> int = "%modint" (** Integer remainder. If [y] is not zero, the result of [Int.rem x y] satisfies the following property: [x = Int.add (Int.mul (Int.div x y) y) (Int.rem x y)]. @raise Division_by_zero if the second argument is zero. *) external modulo : int -> int -> int = "%modint" (** [modulo a b] computes the remainder of the integer division of [a] by [b]. This is defined only if [b <> 0]. The result of [modulo a b] is a number [m] between [0] and [abs ( b - 1 )] if [a >= 0] or between [~- ( abs ( b - 1 ) ) ] if [a < 0] and such that [a * k + (abs b) = m], for some [k]. *) val pow : int -> int -> int (** [pow a b] computes a{^b}. @raise Invalid_argument when [b] is negative. *) val ( ** ) : int -> int -> int (** [a ** b] computes a{^b}*) val ( <> ) : int -> int -> bool val ( > ) : int -> int -> bool val ( < ) : int -> int -> bool val ( >= ) : int -> int -> bool val ( <= ) : int -> int -> bool val ( = ) : int -> int -> bool val min_num : int (** The smallest representable integer, -2{^30} or -2{^62}. *) val max_num : int (** The greatest representable integer, which is either 2{^30}-1 or 2{^62}-1. *) external succ: int -> int = "%succint" (** Successor. [Int.succ x] is [Int.add x Int.one]. *) external pred: int -> int = "%predint" (** Predecessor. [Int.pred x] is [Int.sub x Int.one]. *) val abs : int -> int (** Return the absolute value of its argument, except when the argument is [min_num]. In that case, [abs min_num = min_num]. *) external of_float : float -> int = "%intoffloat" (** Convert the given floating-point number to integer integer, discarding the fractional part (truncate towards 0). The result of the conversion is undefined if, after truncation, the number is outside the range \[{!Int.min_int}, {!Int.max_int}\]. *) external to_float : int -> float = "%floatofint" (** Convert the given integer to a floating-point number. *) val of_string : string -> int (** Convert the given string to an integer The string is read in decimal (by default) or in hexadecimal, octal or binary if the string begins with [0x], [0o] or [0b] respectively. @raise Failure if the given string is not a valid representation of an integer, or if the integer represented exceeds the range of integers representable in type [int]. *) val to_string : int -> string (** Return the string representation of its argument, in signed decimal. *) (** The minimum of two integers. Faster than the polymorphic [min] from the standard library. *) val min : int -> int -> int (** The maximum of two integers. Faster than the polymorphic [min] from the standard library. *) val max : int -> int -> int val mid : int -> int -> int (** Midpoint function; [mid a b] returns [floor((a+b)/2)], but done correctly to compensate for numeric overflows. The result is an integer that lies between [a] and [b] and is as equidistant from both as possible. *) (** Returns the number of 1 bits set in the binary representation of the number. Maybe has problems with negative numbers *) val popcount : int -> int val copysign : int -> int -> int (** [copysign n o] multiplies [o] by the "sign" of [n], i.e. it returns either: - [0] if [n=0] - [o] if [n>0] - [-o] if [n<0] @since 2.3.0 *) (**/**) val popcount_sparse : int -> int (**/**) val operations : int BatNumber.numeric val ( -- ) : t -> t -> t BatEnum.t (** Enumerate an interval. [5 -- 10] is the enumeration 5,6,7,8,9,10. [10 -- 5] is the empty enumeration*) val ( --- ) : t -> t -> t BatEnum.t (** Enumerate an interval. [5 --- 10] is the enumeration 5,6,7,8,9,10. [10 --- 5] is the enumeration 10,9,8,7,6,5.*) external of_int : int -> int = "%identity" external to_int : int -> int = "%identity" (** {6 Submodules regrouping all infix operations} *) module Infix : BatNumber.Infix with type bat__infix_t = t module Compare : BatNumber.Compare with type bat__compare_t = t (** {6 Boilerplate code}*) (** {7 Printing}*) val print: 'a BatInnerIO.output -> int -> unit (** prints as decimal string *) val print_hex: 'a BatInnerIO.output -> int -> unit (** prints as hex string *) (* val bprint: 'a BatInnerIO.output -> t -> unit (** prints as binary string *) *) (** {7 Compare} *) val compare: t -> t -> int (** The comparison function for integers, with the same specification as {!Pervasives.compare}. Along with the type [t], this function [compare] allows the module [Int] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) val equal : t -> t -> bool (** Equality function for integers, useful for {!HashedType}. *) val ord : t -> t -> BatOrd.order (** Safe operations on integers. This module provides operations on the type [int] of integers. Values of this type may be either 31 bits on 32-bit processors or 63 bits on 64-bit processors. Operations which overflow raise exception {!Number.Overflow}. This module implements {!Number.Numeric}, {!Number.Bounded}, {!Number.Discrete}. {b Important note} Untested. *) module Safe_int : sig type t = int (** An alias for the type of integers. *) val zero : t (** The integer [0]. *) val one : t (** The integer [1]. *) val minus_one : t (** The integer [-1]. *) val neg : t -> t (** Unary negation. *) val add : t -> t -> t (** Addition. *) val ( + ) : t -> t -> t (** Addition. *) val sub : t -> t -> t (** Subtraction. *) val ( - ) : t -> t -> t (** Subtraction. *) val mul : t -> t -> t (** Multiplication. *) val ( * ) : t -> t -> t (** Multiplication. *) external div : t -> t -> t = "%divint" (** Integer division. This division rounds the real quotient of its arguments towards zero, as specified for {!Pervasives.(/)}. @raise Division_by_zero if the second argument is zero. *) external ( / ) : t -> t -> t = "%divint" (** Integer division. This division rounds the real quotient of its arguments towards zero, as specified for {!Pervasives.(/)}. @raise Division_by_zero if the second argument is zero. *) external rem : t -> t -> t = "%modint" (** Integer remainder. If [y] is not zero, the result of [Int.rem x y] satisfies the following property: [x = Int.add (Int.mul (Int.div x y) y) (Int.rem x y)]. @raise Division_by_zero if the second argument is zero. *) external modulo : t -> t -> t = "%modint" (** [modulo a b] computes the remainder of the integer division of [a] by [b]. This is defined only if [b <> 0]. The result of [modulo a b] is a number [m] between [0] and [abs ( b - 1 )] if [a >= 0] or between [~- ( abs ( b - 1 ) ) ] if [a < 0] and such that [a * k + (abs b) = m], for some [k]. *) val pow : t -> t -> t (** [pow a b] computes a{^b}. @raise Invalid_argument when [b] is negative. *) val ( ** ) : t -> t -> t (** [a ** b] computes a{^b}*) val ( <> ) : t -> t -> bool (** Comparison: [a <> b] is true if and only if [a] and [b] have different values. *) val ( > ) : t -> t -> bool (** Comparison: [a > b] is true if and only if [a] is strictly greater than [b].*) val ( < ) : t -> t -> bool (** Comparison: [a < b] is true if and only if [a] is strictly smaller than [b].*) val ( >= ) : t -> t -> bool (** Comparison: [a >= b] is true if and only if [a] is greater or equal to [b].*) val ( <= ) : t -> t -> bool (** Comparison: [a <= b] is true if and only if [a] is smaller or equalto [b].*) val ( = ) : t -> t -> bool (** Comparison: [a = b] if and only if [a] and [b] have the same value.*) val max_num : t (** The greatest representable integer, which is either 2{^30}-1 or 2{^62}-1. *) val min_num : t (** The smallest representable integer, -2{^30} or 2{^62}. *) val succ: t -> t (** Successor. [succ x] is [add x one]. *) val pred: t -> t (** Predecessor. [pred x] is [sub x one]. *) val abs : t -> t (** Return the absolute value of its argument. *) external of_float : float -> t = "%intoffloat" (** Convert the given floating-point number to integer, discarding the fractional part (truncate towards 0). The result of the conversion is undefined if, after truncation, the number is outside the range \[{!Int.min_int}, {!Int.max_int}\]. *) external to_float : t -> float = "%floatofint" (** Convert the given integer to a floating-point number. *) val of_string : string -> t (** Convert the given string to an integer The string is read in decimal (by default) or in hexadecimal, octal or binary if the string begins with [0x], [0o] or [0b] respectively. @raise Failure if the given string is not a valid representation of an integer, or if the integer represented exceeds the range of integers representable in type [int]. *) val to_string : t -> string (** Return the string representation of its argument, in signed decimal. *) val operations : t BatNumber.numeric external of_int : int -> t = "%identity" external to_int : t -> int = "%identity" (** {6 Submodules regrouping all infix operations on safe integers} *) module Infix : BatNumber.Infix with type bat__infix_t = t module Compare : BatNumber.Compare with type bat__compare_t = t (** {6 Boilerplate code}*) val print: 'a BatInnerIO.output -> t -> unit val compare : t -> t -> int (** The comparison function for integers, with the same specification as {!Pervasives.compare}. Along with the type [t], this function [compare] allows the module [Int] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) val equal : t -> t -> bool (** Equality function for integers, useful for {!HashedType}. *) val ord : t -> t -> BatOrd.order end batteries-included-3.4.0/src/batInt32.mliv000066400000000000000000000271161415601150500203400ustar00rootroot00000000000000(* * BatInt32 - Extended 32-bit integers * Copyright (C) 1996 Xavier Leroy * 2007 Bluestorm * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** 32-bit integers. This module provides operations on the type [int32] of signed 32-bit integers. Unlike the built-in [int] type, the type [int32] is guaranteed to be exactly 32-bit wide on all platforms. All arithmetic operations over [int32] are taken modulo 2{^32}. Any integer literal followed by [l] is taken to be an [int32]. For instance, [1l] is {!Int32.one}. Performance notice: values of type [int32] occupy more memory space than values of type [int], and arithmetic operations on [int32] are generally slower than those on [int]. Use [int32] only when the application requires exact 32-bit arithmetic. This module extends Stdlib's {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Int32.html}Int32} module, go there for documentation on the rest of the functions and types. @author Xavier Leroy (base module) @author Gabriel Scherer @author David Teller *) type t = int32 val zero : int32 (** The 32-bit integer 0. *) val one : int32 (** The 32-bit integer 1. *) val minus_one : int32 (** The 32-bit integer -1. *) external neg : int32 -> int32 = "%int32_neg" (** Unary negation. *) external add : int32 -> int32 -> int32 = "%int32_add" (** Addition. *) external sub : int32 -> int32 -> int32 = "%int32_sub" (** Subtraction. *) external mul : int32 -> int32 -> int32 = "%int32_mul" (** Multiplication. *) external div : int32 -> int32 -> int32 = "%int32_div" (** Integer division. This division rounds the real quotient of its arguments towards zero, as specified for {!Pervasives.(/)}. @raise Division_by_zero if the second argument is zero. *) ##V>=4.08##val unsigned_div : int32 -> int32 -> int32 ##V>=4.08##(** Same as {!div}, except that arguments and result are interpreted as {e ##V>=4.08## unsigned} 32-bit integers. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) external rem : int32 -> int32 -> int32 = "%int32_mod" (** Integer remainder. If [y] is not zero, the result of [Int32.rem x y] satisfies the following property: [x = Int32.add (Int32.mul (Int32.div x y) y) (Int32.rem x y)]. @raise Division_by_zero if the second argument is zero. *) ##V>=4.08##val unsigned_rem : int32 -> int32 -> int32 ##V>=4.08##(** Same as {!rem}, except that arguments and result are interpreted as {e ##V>=4.08## unsigned} 32-bit integers. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) val modulo : int32 -> int32 -> int32 val pow : int32 -> int32 -> int32 (** @raise Invalid_argument if the exponent is negative. *) val min_num : int32 val max_num : int32 val succ : int32 -> int32 (** Successor. [Int32.succ x] is [Int32.add x Int32.one]. *) val pred : int32 -> int32 (** Predecessor. [Int32.pred x] is [Int32.sub x Int32.one]. *) val abs : int32 -> int32 (** Return the absolute value of its argument. *) val max_int : int32 (** The greatest representable 32-bit integer, 2{^31} - 1. *) val min_int : int32 (** The smallest representable 32-bit integer, -2{^31}. *) external logand : int32 -> int32 -> int32 = "%int32_and" (** Bitwise logical and. *) external logor : int32 -> int32 -> int32 = "%int32_or" (** Bitwise logical or. *) external logxor : int32 -> int32 -> int32 = "%int32_xor" (** Bitwise logical exclusive or. *) val lognot : int32 -> int32 (** Bitwise logical negation *) external shift_left : int32 -> int -> int32 = "%int32_lsl" (** [Int32.shift_left x y] shifts [x] to the left by [y] bits. The result is unspecified if [y < 0] or [y >= 32]. *) external shift_right : int32 -> int -> int32 = "%int32_asr" (** [Int32.shift_right x y] shifts [x] to the right by [y] bits. This is an arithmetic shift: the sign bit of [x] is replicated and inserted in the vacated bits. The result is unspecified if [y < 0] or [y >= 32]. *) external shift_right_logical : int32 -> int -> int32 = "%int32_lsr" (** [Int32.shift_right_logical x y] shifts [x] to the right by [y] bits. This is a logical shift: zeroes are inserted in the vacated bits regardless of the sign of [x]. The result is unspecified if [y < 0] or [y >= 32]. *) val ( -- ) : t -> t -> t BatEnum.t (** Enumerate an interval. [5l -- 10l] is the enumeration 5l,6l,7l,8l,9l,10l. [10l -- 5l] is the empty enumeration*) val ( --- ) : t -> t -> t BatEnum.t (** Enumerate an interval. [5l -- 10l] is the enumeration 5l,6l,7l,8l,9l,10l. [10l -- 5l] is the enumeration 10l,9l,8l,7l,6l,5l.*) external of_int : int -> int32 = "%int32_of_int" (** Convert the given integer (type [int]) to a 32-bit integer (type [int32]). *) external to_int : int32 -> int = "%int32_to_int" (** Convert the given 32-bit integer (type [int32]) to an integer (type [int]). On 32-bit platforms, the 32-bit integer is taken modulo 2{^31}, i.e. the high-order bit is lost during the conversion. On 64-bit platforms, the conversion is exact. *) ##V>=4.08##val unsigned_to_int : int32 -> int option ##V>=4.08##(** Same as {!to_int}, but interprets the argument as an {e unsigned} integer. ##V>=4.08## Returns [None] if the unsigned value of the argument cannot fit into an ##V>=4.08## [int]. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) external of_float : float -> int32 = "caml_int32_of_float" ##V>=4.3## "caml_int32_of_float_unboxed" [@@unboxed] [@@noalloc] (** Convert the given floating-point number to a 32-bit integer, discarding the fractional part (truncate towards 0). The result of the conversion is undefined if, after truncation, the number is outside the range \[{!Int32.min_int}, {!Int32.max_int}\]. *) external to_float : int32 -> float = "caml_int32_to_float" ##V>=4.3## "caml_int32_to_float_unboxed" [@@unboxed] [@@noalloc] (** Convert the given 32-bit integer to a floating-point number. *) external of_int64 : int64 -> int32 = "%int64_to_int32" (** Convert the given 64-bit integer (type [int64]) to a 32-bit integer (type [int32]). The 64-bit integer is taken modulo 2{^32}, i.e. the top 32 bits are lost during the conversion. *) external to_int64 : int32 -> int64 = "%int64_of_int32" (** Convert the given 32-bit integer (type [int32]) to a 64-bit integer (type [int64]). *) external of_nativeint : nativeint -> int32 = "%nativeint_to_int32" (** Convert the given native integer (type [nativeint]) to a 32-bit integer (type [int32]). On 64-bits platform the top 32 bits are lost. *) external to_nativeint : int32 -> nativeint = "%nativeint_of_int32" (** Convert the given 32-bit integer (type [int32]) to a native integer. *) external of_string : string -> int32 = "caml_int32_of_string" (** Convert the given string to a 32-bit integer. The string is read in decimal (by default) or in hexadecimal, octal or binary if the string begins with [0x], [0o] or [0b] respectively. @raise Failure if the given string is not a valid representation of an integer, or if the integer represented exceeds the range of integers representable in type [int32]. *) val of_string_opt: string -> int32 option (** Same as [of_string], but return [None] instead of raising. @since 2.7.0 *) val to_string : int32 -> string (** Return the string representation of its argument, in signed decimal. *) external bits_of_float : float -> int32 = "caml_int32_bits_of_float" ##V>=4.3## "caml_int32_bits_of_float_unboxed" [@@unboxed] [@@noalloc] (** Return the internal representation of the given float according to the IEEE 754 floating-point ``single format'' bit layout. Bit 31 of the result represents the sign of the float; bits 30 to 23 represent the (biased) exponent; bits 22 to 0 represent the mantissa. *) external float_of_bits : int32 -> float = "caml_int32_float_of_bits" ##V>=4.3## "caml_int32_float_of_bits_unboxed" [@@unboxed] [@@noalloc] (** Return the floating-point number whose internal representation, according to the IEEE 754 floating-point ``single format'' bit layout, is the given [int32]. *) val of_byte : char -> int32 val to_byte : int32 -> char val pack : Bytes.t -> int -> int32 -> unit (** [pack s off i] writes the little endian bit representation of [i] into byte sequence [s] at offset [off] *) val pack_big : Bytes.t -> int -> int32 -> unit (** [pack_big s off i] writes the big endian bit representation of [i] into byte sequence [s] at offset [off] *) val unpack : Bytes.t -> int -> int32 (** [unpack s off] reads 4 bytes from byte sequence [str] starting at offset [off] as a little-endian int32 *) val unpack_big : Bytes.t -> int -> int32 (** [unpack s off] reads 4 bytes from byte sequence [str] starting at offset [off] as a big-endian int32 *) val compare : t -> t -> int (** The comparison function for 32-bit integers, with the same specification as {!Pervasives.compare}. Along with the type [t], this function [compare] allows the module [Int32] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) val min: t -> t -> t (** Return the smaller of the two. @since 3.4.0 *) val max: t -> t -> t (** Return the greater of the two. @since 3.4.0 *) ##V>=4.08##val unsigned_compare: t -> t -> int ##V>=4.08##(** Same as {!compare}, except that arguments are interpreted as {e unsigned} ##V>=4.08## 32-bit integers. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) val equal : t -> t -> bool (** Equality function for 32-bit integers, useful for {!HashedType}. *) val ord : t -> t -> BatOrd.order (**/**) (** {6 Deprecated functions} *) external format : string -> int32 -> string = "caml_int32_format" (** [Int32.format fmt n] return the string representation of the 32-bit integer [n] in the format specified by [fmt]. [fmt] is a [Printf]-style format consisting of exactly one [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification. This function is deprecated; use {!Printf.sprintf} with a [%lx] format instead. *) (**/**) val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t val ( ** ) : t -> t -> t (* Available only in `Compare` submodule, as they override the polymorphic compare val ( <> ) : t -> t -> bool val ( >= ) : t -> t -> bool val ( <= ) : t -> t -> bool val ( > ) : t -> t -> bool val ( < ) : t -> t -> bool val ( = ) : t -> t -> bool *) val operations : t BatNumber.numeric (** {6 Submodules grouping all infix operators} *) module Infix : BatNumber.Infix with type bat__infix_t = t module Compare : BatNumber.Compare with type bat__compare_t = t include BatNumber.Bounded with type bounded = t (** {6 Boilerplate code}*) (** {7 Printing}*) val print: 'a BatInnerIO.output -> t -> unit (** prints as decimal string *) val print_hex: 'a BatInnerIO.output -> t -> unit (** prints as hex string *) batteries-included-3.4.0/src/batInt32.mlv000066400000000000000000000174511415601150500201700ustar00rootroot00000000000000(* * BatInt32 - Extended 32-bit integers * Copyright (C) 2007 Bluestorm * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open BatNumber let (|>) x f = f x let to_byte n = Int32.logand 0xffl n |> Int32.to_int |> Char.chr let of_byte b = Char.code b |> Int32.of_int (*$Q to_byte; of_byte Q.char (fun c -> Pervasives.(=) (to_byte (of_byte c)) c) *) (*$T to_byte to_byte 256l = to_byte 0l *) (* really need to just blit an int32 word into a string and vice versa *) let pack str pos item = if Bytes.length str < pos + 4 then invalid_arg "Int32.pack: pos too close to end of string"; if pos < 0 then invalid_arg "Int32.pack: pos negative"; Bytes.set str pos (to_byte item); let item = Int32.shift_right item 8 in Bytes.set str (pos + 1) (to_byte item); let item = Int32.shift_right item 8 in Bytes.set str (pos + 2) (to_byte item); let item = Int32.shift_right item 8 in Bytes.set str (pos + 3) (to_byte item) (* optimize out last logand? *) (*$T pack let str = Bytes.of_string " " in pack str 0 0l; (Bytes.to_string str = "\000\000\000\000") let str = Bytes.of_string " " in pack str 0 0l; (Bytes.to_string str = "\000\000\000\000 ") let str = Bytes.of_string " " in pack str 1 0l; (Bytes.to_string str = " \000\000\000\000") let str = Bytes.of_string " " in try pack str 0 0l; false with Invalid_argument _ -> true let str = Bytes.of_string " " in try pack str 1 0l; false with Invalid_argument _ -> true *) let pack_big str pos item = if Bytes.length str < pos + 4 then invalid_arg "Int32.pack_big: pos too close to end of string"; if pos < 0 then invalid_arg "Int32.pack_big: pos negative"; Bytes.set str (pos + 3) (to_byte item); let item = Int32.shift_right item 8 in Bytes.set str (pos + 2) (to_byte item); let item = Int32.shift_right item 8 in Bytes.set str (pos + 1) (to_byte item); let item = Int32.shift_right item 8 in Bytes.set str pos (to_byte item) (* optimize out last logand? *) (*$T pack_big let str = Bytes.of_string " " in pack_big str 0 0l; (Bytes.to_string str = "\000\000\000\000") let str = Bytes.of_string " " in pack_big str 0 0l; (Bytes.to_string str = "\000\000\000\000 ") let str = Bytes.of_string " " in pack_big str 1 0l; (Bytes.to_string str = " \000\000\000\000") let str = Bytes.of_string " " in try pack_big str 0 0l; false with Invalid_argument _ -> true let str = Bytes.of_string " " in try pack_big str 1 0l; false with Invalid_argument _ -> true *) let unpack str pos = if Bytes.length str < pos + 4 then invalid_arg "Int32.unpack: pos + 4 not within string"; if pos < 0 then invalid_arg "Int32.unpack: pos negative"; let shift n = Int32.shift_left n 8 and add b n = Int32.add (of_byte b) n in of_byte (Bytes.unsafe_get str (pos+3)) |> shift |> add (Bytes.unsafe_get str (pos+2)) |> shift |> add (Bytes.unsafe_get str (pos+1)) |> shift |> add (Bytes.unsafe_get str pos) (* TODO: improve performance of bit twiddling? will these curried functions get inlined? *) (*$T unpack unpack (Bytes.of_string "\000\000\000\000") 0 = 0l unpack (Bytes.of_string "\000\000\000\000 ") 0 = 0l unpack (Bytes.of_string " \000\000\000\000") 1 = 0l unpack (Bytes.of_string "\255\000\000\000") 0 = 255l *) (*$Q pack; unpack Q.int (let str = Bytes.of_string " " in fun x -> let x = Int32.of_int x in pack str 0 x; unpack str 0 = x) *) let unpack_big str pos = if Bytes.length str < pos + 4 then invalid_arg "Int32.unpack_big: pos + 4 not within string"; if pos < 0 then invalid_arg "Int32.unpack_big: pos negative"; let shift n = Int32.shift_left n 8 and add b n = Int32.add (of_byte b) n in of_byte (Bytes.unsafe_get str pos) |> shift |> add (Bytes.unsafe_get str (pos+1)) |> shift |> add (Bytes.unsafe_get str (pos+2)) |> shift |> add (Bytes.unsafe_get str (pos+3)) (*$T unpack_big unpack_big (Bytes.of_string "\000\000\000\000") 0 = 0l unpack_big (Bytes.of_string "\000\000\000\000 ") 0 = 0l unpack_big (Bytes.of_string " \000\000\000\000 ") 1 = 0l unpack_big (Bytes.of_string "\000\000\000\255") 0 = 255l *) (*$Q pack_big; unpack_big Q.int (let str = Bytes.of_string " " in fun x -> let x = Int32.of_int x in pack_big str 0 x; unpack_big str 0 = x) *) module BaseInt32 = struct include Int32 let modulo = rem let pow = generic_pow ~zero ~one ~div_two:(fun n -> shift_right n 1) ~mod_two:(logand one) ~mul:mul (*$T pow pow one one = one pow one zero = one pow zero one = zero pow zero zero = one pow one one = one pow (neg one) one = neg one try ignore (pow one (of_int ~-1)) ; false \ with Invalid_argument _ -> true | _ -> false *) end include BatNumber.MakeNumeric(BaseInt32) let min_int = Int32.min_int let max_int = Int32.max_int let minus_one = Int32.minus_one let lognot = Int32.lognot external neg : int32 -> int32 = "%int32_neg" external add : int32 -> int32 -> int32 = "%int32_add" external sub : int32 -> int32 -> int32 = "%int32_sub" external mul : int32 -> int32 -> int32 = "%int32_mul" external div : int32 -> int32 -> int32 = "%int32_div" external rem : int32 -> int32 -> int32 = "%int32_mod" external logand : int32 -> int32 -> int32 = "%int32_and" external logor : int32 -> int32 -> int32 = "%int32_or" external logxor : int32 -> int32 -> int32 = "%int32_xor" external shift_left : int32 -> int -> int32 = "%int32_lsl" external shift_right : int32 -> int -> int32 = "%int32_asr" external shift_right_logical : int32 -> int -> int32 = "%int32_lsr" external of_int : int -> int32 = "%int32_of_int" external to_int : int32 -> int = "%int32_to_int" external of_float : float -> int32 = "caml_int32_of_float" ##V>=4.3## "caml_int32_of_float_unboxed" [@@unboxed] [@@noalloc] external to_float : int32 -> float = "caml_int32_to_float" ##V>=4.3## "caml_int32_to_float_unboxed" [@@unboxed] [@@noalloc] external of_string : string -> int32 = "caml_int32_of_string" ##V>=4.5##let of_string_opt = Int32.of_string_opt ##V<4.5##let of_string_opt n = try Some (Int32.of_string n) with _ -> None external of_int64 : int64 -> int32 = "%int64_to_int32" external to_int64 : int32 -> int64 = "%int64_of_int32" external of_nativeint : nativeint -> int32 = "%nativeint_to_int32" external to_nativeint : int32 -> nativeint = "%nativeint_of_int32" external bits_of_float : float -> int32 = "caml_int32_bits_of_float" ##V>=4.3## "caml_int32_bits_of_float_unboxed" [@@unboxed] [@@noalloc] external float_of_bits : int32 -> float = "caml_int32_float_of_bits" ##V>=4.3## "caml_int32_float_of_bits_unboxed" [@@unboxed] [@@noalloc] external format : string -> int32 -> string = "caml_int32_format" ##V>=4.08##let unsigned_div = Int32.unsigned_div ##V>=4.08##let unsigned_rem = Int32.unsigned_rem ##V>=4.08##let unsigned_to_int = Int32.unsigned_to_int ##V>=4.08##let unsigned_compare = Int32.unsigned_compare type bounded = t let min_num, max_num = min_int, max_int let print out t = BatInnerIO.nwrite out (to_string t) let print_hex out t = BatPrintf.fprintf out "%lx" t let min (x: t) (y: t): t = if x <= y then x else y let max (x: t) (y: t): t = if x >= y then x else y batteries-included-3.4.0/src/batInt64.mliv000066400000000000000000000256451415601150500203520ustar00rootroot00000000000000(* * BatInt64 - Extended 64-bit integers * Copyright (C) 2005 Damien Doligez * 2007 Bluestorm * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** 64-bit integers. This module provides operations on the type [int64] of signed 64-bit integers. Unlike the built-in [int] type, the type [int64] is guaranteed to be exactly 64-bit wide on all platforms. All arithmetic operations over [int64] are taken modulo 2{^64}. Performance notice: values of type [int64] occupy more memory space than values of type [int], and arithmetic operations on [int64] are generally slower than those on [int]. Use [int64] only when the application requires exact 64-bit arithmetic. Any integer literal followed by [L] is taken to be an [int64]. For instance, [1L] is {!Int64.one}. This module extends Stdlib's {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Int64.html}Int64} module, go there for documentation on the rest of the functions and types. @author Xavier Leroy (base module) @author Gabriel Scherer @author David Teller *) type t = int64 val zero : int64 (** The 64-bit integer 0. *) val one : int64 (** The 64-bit integer 1. *) val minus_one : int64 (** The 64-bit integer -1. *) external neg : int64 -> int64 = "%int64_neg" (** Unary negation. *) external add : int64 -> int64 -> int64 = "%int64_add" (** Addition. *) external sub : int64 -> int64 -> int64 = "%int64_sub" (** Subtraction. *) external mul : int64 -> int64 -> int64 = "%int64_mul" (** Multiplication. *) external div : int64 -> int64 -> int64 = "%int64_div" (** Integer division. This division rounds the real quotient of its arguments towards zero, as specified for {!Pervasives.(/)}. @raise Division_by_zero if the second argument is zero. *) ##V>=4.08##val unsigned_div : int64 -> int64 -> int64 ##V>=4.08##(** Same as {!div}, except that arguments and result are interpreted as {e ##V>=4.08## unsigned} 64-bit integers. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) external rem : int64 -> int64 -> int64 = "%int64_mod" (** Integer remainder. If [y] is not zero, the result of [Int64.rem x y] satisfies the following property: [x = Int64.add (Int64.mul (Int64.div x y) y) (Int64.rem x y)]. @raise Division_by_zero if the second argument is zero. *) ##V>=4.08##val unsigned_rem : int64 -> int64 -> int64 ##V>=4.08##(** Same as {!rem}, except that arguments and result are interpreted as {e ##V>=4.08## unsigned} 64-bit integers. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) val succ : int64 -> int64 (** Successor. [Int64.succ x] is [Int64.add x Int64.one]. *) val pred : int64 -> int64 (** Predecessor. [Int64.pred x] is [Int64.sub x Int64.one]. *) val abs : int64 -> int64 (** Return the absolute value of its argument. *) val max_int : int64 (** The greatest representable 64-bit integer, 2{^63} - 1. *) val min_int : int64 (** The smallest representable 64-bit integer, -2{^63}. *) external logand : int64 -> int64 -> int64 = "%int64_and" (** Bitwise logical and. *) external logor : int64 -> int64 -> int64 = "%int64_or" (** Bitwise logical or. *) external logxor : int64 -> int64 -> int64 = "%int64_xor" (** Bitwise logical exclusive or. *) val lognot : int64 -> int64 (** Bitwise logical negation *) external shift_left : int64 -> int -> int64 = "%int64_lsl" (** [Int64.shift_left x y] shifts [x] to the left by [y] bits. The result is unspecified if [y < 0] or [y >= 64]. *) external shift_right : int64 -> int -> int64 = "%int64_asr" (** [Int64.shift_right x y] shifts [x] to the right by [y] bits. This is an arithmetic shift: the sign bit of [x] is replicated and inserted in the vacated bits. The result is unspecified if [y < 0] or [y >= 64]. *) external shift_right_logical : int64 -> int -> int64 = "%int64_lsr" (** [Int64.shift_right_logical x y] shifts [x] to the right by [y] bits. This is a logical shift: zeroes are inserted in the vacated bits regardless of the sign of [x]. The result is unspecified if [y < 0] or [y >= 64]. *) val ( -- ) : t -> t -> t BatEnum.t (** Enumerate an interval. [5L -- 10L] is the enumeration 5L,6L,7L,8L,9L,10L. [10L -- 5L] is the empty enumeration*) val ( --- ) : t -> t -> t BatEnum.t (** Enumerate an interval. [5L -- 10L] is the enumeration 5L,6L,7L,8L,9L,10L. [10L -- 5L] is the enumeration 10L,9L,8L,7L,6L,5L.*) external of_int : int -> int64 = "%int64_of_int" (** Convert the given integer (type [int]) to a 64-bit integer (type [int64]). *) external to_int : int64 -> int = "%int64_to_int" (** Convert the given 64-bit integer (type [int64]) to an integer (type [int]). On 64-bit platforms, the 64-bit integer is taken modulo 2{^63}, i.e. the high-order bit is lost during the conversion. On 32-bit platforms, the 64-bit integer is taken modulo 2{^31}, i.e. the top 33 bits are lost during the conversion. *) ##V>=4.08##val unsigned_to_int : int64 -> int option ##V>=4.08##(** Same as {!to_int}, but interprets the argument as an {e unsigned} integer. ##V>=4.08## Returns [None] if the unsigned value of the argument cannot fit into an ##V>=4.08## [int]. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) external of_float : float -> int64 = "caml_int64_of_float" ##V>=4.3## "caml_int64_of_float_unboxed" [@@unboxed] [@@noalloc] (** Convert the given floating-point number to a 64-bit integer, discarding the fractional part (truncate towards 0). The result of the conversion is undefined if, after truncation, the number is outside the range \[{!Int64.min_int}, {!Int64.max_int}\]. *) external to_float : int64 -> float = "caml_int64_to_float" ##V>=4.3## "caml_int64_to_float_unboxed" [@@unboxed] [@@noalloc] (** Convert the given 64-bit integer to a floating-point number. *) external of_int32 : int32 -> int64 = "%int64_of_int32" (** Convert the given 32-bit integer (type [int32]) to a 64-bit integer (type [int64]). *) external to_int32 : int64 -> int32 = "%int64_to_int32" (** Convert the given 64-bit integer (type [int64]) to a 32-bit integer (type [int32]). The 64-bit integer is taken modulo 2{^32}, i.e. the top 32 bits are lost during the conversion. *) external of_nativeint : nativeint -> int64 = "%int64_of_nativeint" (** Convert the given native integer (type [nativeint]) to a 64-bit integer (type [int64]). *) external to_nativeint : int64 -> nativeint = "%int64_to_nativeint" (** Convert the given 64-bit integer (type [int64]) to a native integer. On 32-bit platforms, the 64-bit integer is taken modulo 2{^32}. On 64-bit platforms, the conversion is exact. *) external of_string : string -> int64 = "caml_int64_of_string" (** Convert the given string to a 64-bit integer. The string is read in decimal (by default) or in hexadecimal, octal or binary if the string begins with [0x], [0o] or [0b] respectively. @raise Failure if the given string is not a valid representation of an integer, or if the integer represented exceeds the range of integers representable in type [int64]. *) val of_string_opt: string -> int64 option (** Same as [of_string], but return [None] instead of raising. @since 2.7.0 *) val to_string : int64 -> string (** Return the string representation of its argument, in decimal. *) external bits_of_float : float -> int64 = "caml_int64_bits_of_float" ##V>=4.3## "caml_int64_bits_of_float_unboxed" [@@unboxed] [@@noalloc] (** Return the internal representation of the given float according to the IEEE 754 floating-point ``double format'' bit layout. Bit 63 of the result represents the sign of the float; bits 62 to 52 represent the (biased) exponent; bits 51 to 0 represent the mantissa. *) external float_of_bits : int64 -> float = "caml_int64_float_of_bits" ##V>=4.3## "caml_int64_float_of_bits_unboxed" [@@unboxed] [@@noalloc] (** Return the floating-point number whose internal representation, according to the IEEE 754 floating-point ``double format'' bit layout, is the given [int64]. *) val compare : t -> t -> int (** The comparison function for 64-bit integers, with the same specification as {!Pervasives.compare}. Along with the type [t], this function [compare] allows the module [Int64] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) val min: t -> t -> t (** Return the smaller of the two. @since 3.4.0 *) val max: t -> t -> t (** Return the greater of the two. @since 3.4.0 *) ##V>=4.08##val unsigned_compare: t -> t -> int ##V>=4.08##(** Same as {!compare}, except that arguments are interpreted as {e unsigned} ##V>=4.08## 64-bit integers. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) val equal : t -> t -> bool (** Equality function for 64-bit integers, useful for {!HashedType}. *) val ord : t -> t -> BatOrd.order (** {6 Submodules grouping all infix operators} *) module Infix : BatNumber.Infix with type bat__infix_t = t module Compare: BatNumber.Compare with type bat__compare_t = t (**/**) (** {6 Deprecated functions} *) external format : string -> int64 -> string = "caml_int64_format" (** [Int64.format fmt n] return the string representation of the 64-bit integer [n] in the format specified by [fmt]. [fmt] is a {!Printf}-style format consisting of exactly one [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification. This function is deprecated; use {!Printf.sprintf} with a [%Lx] format instead. *) (**/**) val modulo : int64 -> int64 -> int64 val pow : int64 -> int64 -> int64 (** @raise Invalid_argument if the exponent is negative. *) val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t val ( ** ) : t -> t -> t (* Available only in `Compare` submodule val ( <> ) : t -> t -> bool val ( >= ) : t -> t -> bool val ( <= ) : t -> t -> bool val ( > ) : t -> t -> bool val ( < ) : t -> t -> bool val ( = ) : t -> t -> bool *) val operations : t BatNumber.numeric (** {6 Boilerplate code}*) (** {7 Printing}*) val print: 'a BatInnerIO.output -> t -> unit (** prints as decimal string *) val print_hex: 'a BatInnerIO.output -> t -> unit (** prints as hex string *) batteries-included-3.4.0/src/batInt64.mlv000066400000000000000000000067001415601150500201700ustar00rootroot00000000000000(* * BatInt64 - Extended 64-bit integers * Copyright (C) 2007 Bluestorm * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module BaseInt64 = struct include Int64 let modulo = rem let pow = BatNumber.generic_pow ~zero ~one ~div_two:(fun n -> shift_right n 1) ~mod_two:(logand one) ~mul end include BatNumber.MakeNumeric(BaseInt64) let min_int = Int64.min_int let max_int = Int64.max_int let minus_one = Int64.minus_one let lognot = Int64.lognot external neg : int64 -> int64 = "%int64_neg" external add : int64 -> int64 -> int64 = "%int64_add" external sub : int64 -> int64 -> int64 = "%int64_sub" external mul : int64 -> int64 -> int64 = "%int64_mul" external div : int64 -> int64 -> int64 = "%int64_div" external rem : int64 -> int64 -> int64 = "%int64_mod" external logand : int64 -> int64 -> int64 = "%int64_and" external logor : int64 -> int64 -> int64 = "%int64_or" external logxor : int64 -> int64 -> int64 = "%int64_xor" external shift_left : int64 -> int -> int64 = "%int64_lsl" external shift_right : int64 -> int -> int64 = "%int64_asr" external shift_right_logical : int64 -> int -> int64 = "%int64_lsr" external of_int : int -> int64 = "%int64_of_int" external to_int : int64 -> int = "%int64_to_int" external of_float : float -> int64 = "caml_int64_of_float" ##V>=4.3## "caml_int64_of_float_unboxed" [@@unboxed] [@@noalloc] external to_float : int64 -> float = "caml_int64_to_float" ##V>=4.3## "caml_int64_to_float_unboxed" [@@unboxed] [@@noalloc] external of_int32 : int32 -> int64 = "%int64_of_int32" external to_int32 : int64 -> int32 = "%int64_to_int32" external of_nativeint : nativeint -> int64 = "%int64_of_nativeint" external to_nativeint : int64 -> nativeint = "%int64_to_nativeint" external of_string : string -> int64 = "caml_int64_of_string" ##V>=4.5##let of_string_opt = Int64.of_string_opt ##V<4.5##let of_string_opt n = try Some (Int64.of_string n) with _ -> None external bits_of_float : float -> int64 = "caml_int64_bits_of_float" ##V>=4.3## "caml_int64_bits_of_float_unboxed" [@@unboxed] [@@noalloc] external float_of_bits : int64 -> float = "caml_int64_float_of_bits" ##V>=4.3## "caml_int64_float_of_bits_unboxed" [@@unboxed] [@@noalloc] external format : string -> int64 -> string = "caml_int64_format" ##V>=4.08##let unsigned_compare = Int64.unsigned_compare ##V>=4.08##let unsigned_to_int = Int64.unsigned_to_int ##V>=4.08##let unsigned_rem = Int64.unsigned_rem ##V>=4.08##let unsigned_div = Int64.unsigned_div let print out t = BatInnerIO.nwrite out (to_string t) let print_hex out t = BatPrintf.fprintf out "%Lx" t let min (x: t) (y: t): t = if x <= y then x else y let max (x: t) (y: t): t = if x >= y then x else y batteries-included-3.4.0/src/batInterfaces.ml000066400000000000000000000023031415601150500211540ustar00rootroot00000000000000(* * Interfaces - Common interfaces for data structures * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module type Mappable = sig type 'a mappable val map : ('a -> 'b) -> ('a mappable -> 'b mappable) end module type OrderedType = sig type t val compare : t -> t -> int end module type Monad = sig type 'a m val bind : 'a m -> ('a -> 'b m) -> 'b m val return: 'a -> 'a m end batteries-included-3.4.0/src/batInterfaces.mli000066400000000000000000000061221415601150500213300ustar00rootroot00000000000000(* * Interfaces - Common interfaces for data structures * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Common signatures for data structures. *) (** A signature for data structures which have a [map : ('a -> 'b) -> ('a t -> 'b t)] operation. If you create a new data structure, you should make it compatible with [Mappable]. *) module type Mappable = sig type 'a mappable (** The data structure, e.g. ['a List.t] *) val map : ('a -> 'b) -> ('a mappable -> 'b mappable) (** [map f e] applies [f] to every element of [e] and returns the corresponding data structure *) end module type OrderedType = sig type t val compare : t -> t -> int (** A total ordering function This is a two-argument function [f] such that [f e1 e2] is zero if the values [e1] and [e2] are equal, [f e1 e2] is strictly negative if [e1] is smaller than [e2], and [f e1 e2] is strictly positive if [e1] is greater than [e2]. Example: a suitable ordering function is the generic structural comparison function {!Pervasives.compare}. *) end (** Monads are a design pattern which may be used to enforce strong functional or non-functional constraints on the manipulation of resources, while remaining in the world of functional programming. For instance, monads may serve to implement approximations of a types-and-effects type system, to enforce functional use of arrays or other mutable data structures, or to enforce the fact that only files opened for writing may be actually used for writing. For more information on monads, see {{:http://enfranchisedmind.com/blog/2007/08/06/a-monad-tutorial-for-ocaml/} A Monad Tutorial for Ocaml}. This definition is compatible with the standard syntax extension for monads. For more information, see {{:http://www.cas.mcmaster.ca/~carette/pa_monad/} the documentation of pa_monad}. @author David Teller *) (** Signature for monads *) module type Monad = sig (** The type of a monad producing values of type ['a].*) type 'a m (** Monadic binding. [bind m f] executes first [m] then [f], using the result of [m]. *) val bind : 'a m -> ('a -> 'b m) -> 'b m (**Return a value, that is, put a value in the monad.*) val return: 'a -> 'a m end batteries-included-3.4.0/src/batLazyList.ml000066400000000000000000000507441415601150500206600ustar00rootroot00000000000000(* * LazyListLabels - lazily-computed lists * Copyright (C) 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** {6 Exceptions} *) exception No_more_elements exception Empty_list exception Invalid_index of int exception Different_list_size of string (** {6 Types} *) type 'a node_t = | Nil | Cons of 'a * 'a t and 'a t = ('a node_t) Lazy.t type 'a enumerable = 'a t type 'a mappable = 'a t (** {6 Access} *) let nil = Lazy.lazy_from_val Nil let next l = Lazy.force l let cons h t = Lazy.lazy_from_val (Cons(h, t)) let ( ^:^ ) = cons let get l = match next l with | Nil -> None | Cons (x, rest) -> Some (x, rest) let peek l = match next l with | Nil -> None | Cons (x, _) -> Some x (** {6 Constructors} *) let from_while f = let rec aux () = lazy ( match f () with | None -> Nil | Some x -> Cons (x, aux ()) ) in aux () let from f = let f' () = try Some (f ()) with No_more_elements -> None in from_while f' let seq data next cond = let rec aux data = if cond data then Cons (data, lazy (aux (next data))) else Nil in lazy (aux data) let unfold (data:'b) (next: 'b -> ('a * 'b) option) = let rec aux data = match next data with | Some(a,b) -> Cons(a, lazy (aux b)) | None -> Nil in lazy (aux data) let from_loop (data:'b) (next:'b -> ('a * 'b)) : 'a t= let f' data = try Some (next data) with No_more_elements -> None in unfold data f' let init n f = let rec aux i = if i < n then lazy (Cons (f i, aux ( i + 1 ) ) ) else nil in if n < 0 then invalid_arg "LazyList.init" else aux 0 let make n x = let rec aux i = if i < n then lazy (Cons (x, aux ( i + 1 ) ) ) else nil in if n < 0 then invalid_arg "LazyList.make" else aux 0 (** {6 Iterators} *) let iter f l = let rec aux l = match next l with | Cons (x, t) -> (ignore (f x); aux t) | Nil -> () in aux l let iteri f l = let rec aux i l = match next l with | Cons (x, t) -> (f i x; aux (i + 1) t) | Nil -> () in aux 0 l let map f l = let rec aux rest = match next rest with | Cons (x, (t : 'a t)) -> Cons (f x, lazy (aux t)) | Nil -> Nil in lazy (aux l) let mapi f l = let rec aux rest i = match next rest with | Cons (x, (t : 'a t)) -> Cons (f i x, lazy (aux t ( i + 1 ) )) | Nil -> Nil in lazy (aux l 0) let fold_left f init l = let rec aux acc rest = match next rest with | Cons (x, t) -> aux (f acc x) t | Nil -> acc in aux init l let fold_right f init l = let rec aux rest = match next rest with | Cons (x, t) -> f x (aux t) | Nil -> init in aux l let eager_fold_right f l init = fold_right f init l let lazy_fold_right f l init = let rec aux rest = lazy begin match next rest with | Cons (x, t) -> f x (aux t) | Nil -> Lazy.force init end in aux l (** {6 Finding}*) let may_find p l = let rec aux l = match next l with | Nil -> None | Cons (x, t) -> if p x then Some x else aux t in aux l let may_rfind p l = let rec aux l acc = match next l with | Nil -> acc | Cons (x, t) -> aux t (if p x then Some x else acc) in aux l None let may_findi p l = let rec aux l i = match next l with | Nil -> None | Cons (x, _) when p i x -> Some (i, x) | Cons (_, t) -> aux t (i+1) in aux l 0 let may_rfindi p l = let rec aux l acc i = match next l with | Nil -> acc | Cons (x, t) -> aux t (if p i x then Some (i, x) else acc) (i+1) in aux l None 0 let find_exn p e l = BatOption.get_exn (may_find p l) e let rfind_exn p e l = BatOption.get_exn (may_rfind p l) e let find p l = find_exn p Not_found l let rfind p l = rfind_exn p Not_found l let findi p l = BatOption.get_exn (may_findi p l) Not_found let rfindi p l = BatOption.get_exn (may_rfindi p l) Not_found let index_of e l = match may_findi (fun _ x -> e = x) l with | None -> None | Some (i, _) -> Some i let rindex_of e l = match may_rfindi (fun _ x -> e = x) l with | None -> None | Some (i, _) -> Some i let index_ofq e l = match may_findi (fun _ x -> e == x) l with | None -> None | Some (i, _) -> Some i let rindex_ofq e l = match may_rfindi (fun _ x -> e == x) l with | None -> None | Some (i, _) -> Some i (** {6 Common functions}*) let length l = fold_left (fun n _ -> n + 1) 0 l let is_empty l = match next l with | Nil -> true | Cons _ -> false let would_at_fail n = let rec aux l i = match next l with | Nil -> true | Cons (_, _) when i = 0 -> false | Cons (_, t) -> aux t (i - 1) in aux n let hd list = match next list with | Cons (x, _) -> x | Nil -> raise Empty_list let first = hd let last l = let rec aux acc l = match next l with | Nil -> acc | Cons(x, t) -> aux (Some x) t in match aux None l with | None -> raise Empty_list | Some x -> x let tl list = match next list with | Cons (_, t) -> t | Nil -> raise Empty_list let at list n = let rec aux list i = match ((next list), i) with | (Cons (x, _), 0) -> x | (Cons (_, t), _) -> aux t (i - 1) | (Nil, _) -> raise (Invalid_index n) in if n < 0 then raise (Invalid_index n) else aux list n let nth = at let rev list = fold_left (fun acc x -> Lazy.lazy_from_val (Cons (x, acc))) nil list (**Revert a list, convert it to a lazy list. Used as an optimisation.*) let rev_of_list (list:'a list) = List.fold_left (fun acc x -> Lazy.lazy_from_val (Cons (x, acc))) nil list let eager_append (l1 : 'a t) (l2 : 'a t) = let rec aux list = match next list with | Cons (x, t) -> cons x (aux t) | Nil -> l2 in aux l1 let rev_append (l1 : 'a t) (l2 : 'a t) = let rec aux list acc = match next list with | Cons (x, t) -> aux t (Lazy.lazy_from_val (Cons (x, acc))) | Nil -> acc in aux l1 l2 (**Revert a list, convert it to a lazy list and append it. Used as an optimisation.*) let rev_append_of_list (l1 : 'a list) (l2 : 'a t) : 'a t = let rec aux list acc = match list with | [] -> acc | h::t -> aux t (cons h acc) in aux l1 l2 let append (l1 : 'a t) (l2 : 'a t) = let rec aux list = match next list with | Cons (x, (t : 'a t)) -> Cons (x, lazy (aux t)) | _ -> Lazy.force l2 in lazy (aux l1) (*$T append to_list (append (of_list [1;2]) (of_list [3;4])) = [1;2;3;4] ignore (append (lazy (failwith "lazy cell")) nil); true hd (append (cons () nil) (lazy (failwith "lazy cell"))); true *) let ( ^@^ ) = append let flatten (lol : ('a t) list) = ListLabels.fold_left ~init: nil ~f: append lol let concat lol = lazy_fold_right (fun li rest -> Lazy.force (append li rest)) lol nil (*$T concat to_list (concat (of_list (List.map of_list [[1;2]; [3]; [4;5]; []; [6]; []; []]))) = [1;2;3;4;5;6] ignore (concat (lazy (Cons ((let () = failwith "foo" in nil), nil)))); true *) (** {6 Combinatorics} *) let combinations l = let rec gen l = match l with | [] -> cons [] nil | x::l' -> lazy (let tl = gen l' in let node = append tl (map (fun l -> x::l) tl) in Lazy.force node) in gen l (*$T combinations List.sort Pervasives.compare (to_list (combinations [1;2;3])) = \ [[]; [1]; [1;2]; [1;2;3]; [1;3]; [2]; [2;3]; [3]] to_list (combinations []) = [[]] List.sort Pervasives.compare (to_list (combinations [1])) = [[]; [1]] *) let permutations l = (* do a choice in [l]. [right] contain elements not to choose from. *) let rec choose_first among right = match among with | [] -> cons [] nil | [x] -> perms_starting_with x right | x::among' -> (* choose [x], or don't (in which case put it in [right]) *) append (perms_starting_with x (among' @ right)) (choose_first among' (x::right)) (* all permutations of [l], prefixed with [x] *) and perms_starting_with x l = map (fun l -> x :: l) (choose_first l []) in choose_first l [] (*$T permutations List.sort Pervasives.compare (to_list (permutations [1;2;3])) = \ [[1;2;3]; [1;3;2]; [2;1;3]; [2;3;1]; [3;1;2]; [3;2;1]] to_list (permutations []) = [[]] to_list (permutations [1]) = [[1]] *) (** {6 Conversions} *) (** Eager conversion to list. *) let to_list l = fold_right (fun x acc -> x :: acc) [] l (** Lazy conversion to stream. *) let to_stream l = let rec aux rest = match next rest with | Cons (x, t) -> Stream.icons x (Stream.slazy (fun _ -> aux t)) | Nil -> Stream.sempty in aux l (** Eager conversion to array. *) let to_array l = Array.of_list (to_list l) let enum l = let rec aux l = let reference = ref l in BatEnum.make ~next:(fun () -> match next !reference with | Cons(x,t) -> reference := t; x | Nil -> raise BatEnum.No_more_elements ) ~count:(fun () -> length !reference) ~clone:(fun () -> aux !reference) in aux l (** Lazy conversion from lists Albeit slower than eager conversion, this is the default mechanism for converting from regular lists to lazy lists. This for two reasons : * if you're using lazy lists, total speed probably isn't as much an issue as start-up speed * this will let you convert regular infinite lists to lazy lists. *) let of_list l = let rec aux = function | [] -> nil | h :: t -> lazy (Cons (h, aux t)) in aux l (** Lazy conversion from stream. *) let of_stream s = let rec aux s = let (__strm : _ Stream.t) = s in match Stream.peek __strm with | Some h -> (Stream.junk __strm; lazy (Cons (h, aux s))) | None -> nil in aux s (** Eager conversion from lists *) let eager_of_list l = ListLabels.fold_right ~init: nil ~f: (fun x acc -> Lazy.lazy_from_val (Cons (x, acc))) l (** Eager conversion from array *) let of_array l = ArrayLabels.fold_right ~init: nil ~f: (fun x acc -> Lazy.lazy_from_val (Cons (x, acc))) l (** Lazy conversion from enum *) let of_enum e = let rec aux () = lazy (match BatEnum.get e with | Some x -> Cons (x, aux () ) | None -> Nil ) in aux () (** {6 Predicates} *) let filter f l = let rec next_true l = match next l with (*Compute the next accepted predicate without thunkification*) | Cons (x, l) when not (f x) -> next_true l | l -> l in let rec aux l = lazy(match next_true l with | Cons (x, l) -> Cons (x, aux l) | Nil -> Nil) in aux l let filter_map f l = let rec next_true l = match next l with (*Compute the next accepted predicate without thunkification*) | Cons (x, l) -> begin match f x with | Some v -> Some (v, l) | None -> next_true l end | Nil -> None in let rec aux l = lazy(match next_true l with | Some (x, l) -> Cons (x, aux l) | None -> Nil) in aux l (*let filter f l = let rec aux rest = match next rest with | Cons (x, t) when f x -> Cons (x, lazy (aux t)) | Cons (_, t) -> aux t | Nil -> Nil in lazy (aux l)*) let exists f l = let rec aux rest = match next rest with | Cons (x, _) when f x -> true | Cons (_, t) -> aux t | Nil -> false in aux l (*$T exists exists (fun x -> x = 3) (append (of_list [0;1;2]) (map (fun () -> 3) eternity)) not (exists (fun x -> x < 0) (init 100 (fun i -> i))) *) let for_all f l = let rec aux rest = match next rest with | Cons (x, t) when f x -> aux t | Cons _ -> false | Nil -> true in aux l (*$T for_all not (for_all (fun x -> x <> 3) (append (of_list [0;1;2]) (map (fun () -> 3) eternity))) for_all (fun x -> x >= 0) (init 100 (fun i -> i)) *) let range a b = let rec increasing lo hi = if lo > hi then nil else lazy (Cons (lo, increasing (lo + 1) hi)) in (* and decreasing lo hi = if lo > hi then nil else lazy (Cons hi (decreasing lo (hi - 1)))*) if b >= a then increasing a b else (*decreasing b a*) nil let drop n l = let rec aux l i = if i = 0 then l else match next l with | Nil -> raise (Invalid_index n) | Cons(_, t) -> aux t (i - 1) in aux l n let split_at n li = let last_n = ref n in let last_li = ref li in let rec take n li = last_n := n; last_li := li; if n = 0 then lazy Nil else lazy (match (Lazy.force li) with | Nil -> Nil | Cons (x, xs) -> Cons (x, take (n - 1) xs)) in take n li, lazy (Lazy.force (drop !last_n !last_li)) let split_nth = split_at let mem e = exists (( = ) e) let memq e = exists (( == ) e ) let assoc e l = snd (find (fun (a,_) -> a = e) l) let assq e l = snd (find (fun (a,_) -> a == e) l) let mem_assoc e l = BatOption.is_some (may_find (fun (a, _) -> a = e) l) let mem_assq e l = BatOption.is_some (may_find (fun (a, _) -> a == e) l) (* let rec aux rest = match next rest with | Cons (h, t) -> (match f h with | None -> lazy (aux t) | Some x -> cons x (lazy (aux t))) | Nil -> Nil in lazy (aux l)*) let unique ?(cmp = compare) l = let set = ref (BatMap.PMap.create cmp) in let should_keep x = if BatMap.PMap.mem x !set then false else ( set := BatMap.PMap.add x true !set; true ) in (* use a stateful filter to remove duplicate elements *) filter should_keep l let unique_eq ?(eq = (=)) l = let rec next_true l = match next l with (*Compute the next accepted predicate without thunkification*) | Cons (x, l) when exists (eq x) l -> next_true l | l -> l in let rec aux l = lazy(match next_true l with | Cons (x, l) -> Cons (x, aux l) | Nil -> Nil) in aux l let remove_if p l = let rec aux acc l = match next l with | Nil -> rev_of_list acc | Cons(h,t) when p h -> rev_append_of_list acc t | Cons(h,t) -> aux (h::acc) t in aux [] l let remove_all_such p l = filter_map (fun y -> if p y then None else Some y) l let remove x l = remove_if ( ( = ) x ) l let remove_all x l = remove_all_such ( ( = ) x ) l (** An infinite list of nothing *) let rec eternity = lazy (Cons ((), eternity)) let take n l = fst (split_at n l) let drop_while p = let rec aux l = match next l with | Nil -> nil | Cons(h,t) when p h -> aux t | Cons(_,_) -> l in aux (* TODO: make lazy *) let take_while p = let rec aux acc l = match next l with | Cons(h,t) when p h -> aux (h::acc) t | Cons _ | Nil -> rev_of_list acc in aux [] let sort ?(cmp=Pervasives.compare) l = of_list (List.sort cmp (to_list l)) let stable_sort cmp l = of_list (List.stable_sort cmp (to_list l)) let map2 f l1 l2 = let rec aux l1 l2 = match (next l1, next l2) with | (Cons (h1, t1), Cons(h2, t2)) -> lazy (Cons (f h1 h2, aux t1 t2)) | (Nil, Nil) -> nil | (Cons _, Nil) | (Nil, Cons _) -> raise (Different_list_size "LazyList.map2") in aux l1 l2 let iter2 f l1 l2 = let rec aux l1 l2 = match (next l1, next l2) with | (Cons (h1, t1), Cons(h2, t2)) -> f h1 h2; aux t1 t2 | (Nil, Nil) -> () | (Cons _, Nil) | (Nil, Cons _) -> raise (Different_list_size "LazyList.iter2") in aux l1 l2 let fold_left2 f acc l1 l2 = let rec aux acc l1 l2 = match (next l1, next l2) with | (Cons (h1, t1), Cons(h2, t2)) -> aux (f acc h1 h2) t1 t2 | (Nil, Nil) -> acc | (Cons _, Nil) | (Nil, Cons _) -> raise (Different_list_size "LazyList.fold_left2") in aux acc l1 l2 let fold_right2 f l1 l2 acc = let rec aux l1 l2 = match (next l1, next l2) with | (Cons (h1, t1), Cons(h2, t2)) -> f h1 h2 (aux t1 t2) | (Nil, Nil) -> acc | (Cons _, Nil) | (Nil, Cons _) -> raise (Different_list_size "LazyList.fold_right2") in aux l1 l2 let for_all2 p l1 l2 = let rec aux l1 l2 = match (next l1, next l2) with | (Cons (h1, t1), Cons(h2, t2)) -> p h1 h2 && (aux t1 t2) | (Nil, Nil) -> true | (Cons _, Nil) | (Nil, Cons _) -> raise (Different_list_size "LazyList.for_all2") in aux l1 l2 let equal eq l1 l2 = let rec aux l1 l2 = match (next l1, next l2) with | (Cons (h1, t1), Cons (h2, t2)) -> eq h1 h2 && (aux t1 t2) | (Nil, Nil) -> true | (Cons _, Nil) | (Nil, Cons _) -> false in aux l1 l2 (*$T equal equal (equal (=)) (init 3 (range 0)) (init 3 (range 0)) not (equal (equal (=)) (of_list [(of_list [0; 1; 2])]) (of_list [(of_list [0; 42; 2])])) not (equal (=) (range 0 2) (range 0 3)) not (equal (=) (range 0 3) (range 0 2)) *) let exists2 p l1 l2 = let rec aux l1 l2 = match (next l1, next l2) with | (Cons (h1, t1), Cons(h2, t2)) -> p h1 h2 || (aux t1 t2) | (Nil, Nil) -> false | (Cons _, Nil) | (Nil, Cons _) -> raise (Different_list_size "LazyList.exists2") in aux l1 l2 let combine l1 l2 = let rec aux l1 l2 = match (next l1, next l2) with | (Cons(h1, t1), Cons(h2, t2)) -> lazy (Cons ((h1, h2), ( aux t1 t2 ))) | (Nil, Nil ) -> nil | (Cons _, Nil) | (Nil, Cons _) -> raise (Different_list_size "LazyList.combine") in aux l1 l2 let uncombine l = let (l1, l2) = BatEnum.uncombine (enum l) in (of_enum l1, of_enum l2) (*let uncombine l = let rec aux l = match next l with | Cons ((h1, h2), t) -> lazy (let (t1, t2) = aux t in Cons (h1, t1), Cons(h2, t2)) | Nil -> lazy (Nil, Nil) in aux l*) (*let uncombine l = unfold l (fun l -> match peek l with | None -> None | Cons (h1, h2), t*) let print ?(first="[^") ?(last="^]") ?(sep="; ") print_a out t = BatEnum.print ~first ~last ~sep print_a out (enum t) module Infix = struct let ( ^:^ ), ( ^@^ ) = ( ^:^ ), ( ^@^ ) end module Exceptionless = struct (** Exceptionless counterparts for error-raising operations*) let find = may_find let rfind = may_rfind let findi = may_findi let rfindi = may_rfindi let at list n = let rec aux list i = match (next list, i) with | (Cons (x, _), 0) -> `Ok x | (Cons (_, t), _) -> aux t (i - 1) | (Nil, _) -> `Invalid_index n in if n < 0 then `Invalid_index n else aux list n let assoc a (l:'a t) = try Some (assoc a l) with Not_found -> None let assq a l = try Some (assq a l) with Not_found -> None let split_at n l = try `Ok (split_at n l) with Not_found -> `Invalid_index n end module Labels = struct let iter ~f x = iter f x let iter2 ~f x = iter2 f x let iteri ~f x = iteri f x let map ~f x = map f x let map2 ~f x = map2 f x let mapi ~f x = mapi f x let filter ~f = filter f let exists ~f = exists f let exists2 ~f = exists2 f let for_all ~f = for_all f let for_all2 ~f = for_all2 f let filter_map ~f = filter_map f let find ~f = find f let findi ~f = findi f let rfind ~f = rfind f let rfindi ~f = rfindi f let find_exn ~f = find_exn f let rfind_exn ~f = rfind_exn f let remove_if ~f = remove_if f let remove_all_such ~f= remove_all_such f let take_while ~f= take_while f let drop_while ~f= drop_while f let fold_left ~f ~init = fold_left f init let fold_right ~f ~init = fold_right f init let fold_left2 ~f ~init = fold_left2 f init let fold_right2 ~f l1 l2 ~init = fold_right2 f l1 l2 init module Exceptionless = struct let find ~f = Exceptionless.find f let rfind ~f = Exceptionless.rfind f let findi ~f = Exceptionless.findi f let rfindi ~f = Exceptionless.rfindi f let assq = Exceptionless.assq let assoc = Exceptionless.assoc let at = Exceptionless.at let split_at = Exceptionless.split_at end end batteries-included-3.4.0/src/batLazyList.mli000066400000000000000000000650541415601150500210310ustar00rootroot00000000000000(* * LazyList - Lazily-computed lists of possibly infinite size * Copyright (C) 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Lazy lists of elements. Lazy lists are similar to lists, with the exception that their contents are only computed whenever requested. This makes them particularly useful in contexts where streams of data are to be handled. {b Note} For this documentation, we will assume the existence of a lazy list syntax extension such that [[^ ^]] is the empty lazy list and [[^ a;b;c ^]] is the lazy list containing elements [a], [b], [c]. {b Note} Enumerations (as featured in module {!BatEnum}) and lazy lists (as featured in this module) are quite similar in purpose. Lazy lists are slightly higher level, insofar as no cloning is required to get them to work, which makes them slightly more useful in contexts where backtracking is common. Enumerations, on the other hand, are closer to traditional stream processing, and require more low-level marking whenever backtracking is required, but may be faster and more memory-efficient when used properly. Either choice is recommended over OCaml's built-in {!Stream}. @author David Teller *) (** {6 Exceptions} *) exception Empty_list (** [Empty_list] is raised when an operation applied on an empty list is invalid. For instance, [hd nil] will raise [Empty_list]. *) exception Invalid_index of int (** [Invalid_index] is raised when an indexed access on a list is out of list bounds. *) exception Different_list_size of string (** [Different_list_size] is raised when applying functions such as [iter2] on two lists having different size. *) exception No_more_elements (** See {!from} and {!from_loop} for more information on this exception.*) (**{6 Type} {b Note} The types are kept concrete so as to allow pattern-matching. However, it is generally easier to manipulate {!nil} and {!cons}.*) type 'a t = ('a node_t) Lazy.t (**The type of a lazy list.*) and 'a node_t = | Nil | Cons of 'a * 'a t (**The type of an item in the list.*) include BatEnum.Enumerable with type 'a enumerable = 'a t include BatInterfaces.Mappable with type 'a mappable = 'a t (** {6 Access } *) val nil : 'a t (**The empty list.*) val cons : 'a -> 'a t -> 'a t (**Build a list from a head and a tail.*) val ( ^:^ ) : 'a -> 'a t -> 'a t (**As [cons]: [x^:^l] is the lazy list with head [x] and tail [l]*) val peek : 'a t -> 'a option (**[peek l] returns the first element of [l], if it exists.*) val get : 'a t -> ('a * 'a t) option (**[get l] returns the head and tail of [l], if [l] is not empty.*) (** {6 List creation} *) val from: (unit -> 'a) -> 'a t (**[from next] creates a (possibly infinite) lazy list from the successive results of [next]. @raise LazyList.No_more_elements to denote the end of the list.*) val from_while: (unit -> 'a option) -> 'a t (**[from next] creates a (possibly infinite) lazy list from the successive results of [next]. The list ends whenever [next] returns [None]. *) val seq: 'a -> ('a -> 'a) -> ('a -> bool) -> 'a t (**[seq data next cond] creates a lazy list from the successive results of applying [next] to [data], then to the result, etc. The list continues until the condition [cond] fails. For example, [seq 1 ((+) 1) ((>) 100)] returns [[^1, 2, ... 99^]]. If [cond init] is false, the result is empty. To create an infinite lazy list, pass [(fun _ -> true)] as [cond]. *) val unfold: 'b -> ('b -> ('a * 'b) option) -> 'a t (**[unfold data next] creates a (possibly infinite) lazy list from the successive results of applying [next] to [data], then to the result, etc. The list ends whenever [next] returns [None]. The function [next] should return a pair [option] whose first element will be the current value of the sequence; the second element will be passed (lazily) to [next] in order to compute the following element. One example of a use of [unfold] is to make each element of the resulting sequence to depend on the previous two elements, as in this Fibonacci sequence definition: {[ let data = (1, 1) let next (x, y) = Some (x, (y, x + y)) let fib = unfold data next ]} The first element [x] of the pair within [Some] will be the current value of the sequence; the next value of the sequence, and the one after that, are recorded as [y] and [x + y] respectively. *) val from_loop: 'b -> ('b -> ('a * 'b)) -> 'a t (**[from_loop data next] creates a (possibly infinite) lazy list from the successive results of applying [next] to [data], then to the result, etc. The list ends whenever the function raises {!LazyList.No_more_elements}. (For further information see [unfold]; ignore references to [option] and [Some].) *) val init : int -> (int -> 'a) -> 'a t (** Similar to [Array.init], [init n f] returns the lazy list containing the results of (f 0),(f 1).... (f (n-1)). @raise Invalid_argument ["LazyList.init"] if n < 0.*) val make : int -> 'a -> 'a t (** Similar to [String.make], [make n x] returns a list containing [n] elements [x]. *) val range : int -> int -> int t (**Compute lazily a range of integers a .. b as a lazy list. The range is empty if b <= a.*) (** {6 Higher-order functions} *) val iter : ('a -> 'b) -> 'a t -> unit (** Eager iteration [iter f [^ a0; a1; ...; an ^]] applies function [f] in turn to [a0; a1; ...; an]. It is equivalent to [begin f a0; f a1; ...; f an; () end]. In particular, it causes all the elements of the list to be evaluated.*) val iteri : (int -> 'a -> unit) -> 'a t -> unit (**Eager iteration, with indices [iteri f [^ a0; a1; ...; an ^]] applies function [f] in turn to [a0; a1;...; an], along with the corresponding [0,1..n] index. It is equivalent to [begin f 0 a0; f 1 a1; ...; f n an; () end]. In particular, it causes all the elements of the list to be evaluated.*) val map : ('a -> 'b) -> 'a t -> 'b t (**Lazy map [map f [^ a0; a1; ... ^]] builds the list [[^ f a0; f a1; ... ^]] with the results returned by [f]. Not tail-recursive. Evaluations of [f] take place only when the contents of the list are forced.*) val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t (**Lazy map, with indices [mapi f [^ a0; a1; ... ^]] builds the list [[^ f 0 a0; f 1 a1; ... ^]] with the results returned by [f]. Not tail-recursive. Evaluations of [f] take place only when the contents of the list are forced. *) val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (**Eager fold_left [LazyList.fold_left f a [^ b0; b1; ...; bn ^]] is [f (... (f (f a b0) b1) ...) bn]. This causes evaluation of all the elements of the list.*) val fold_right : ('a -> 'b -> 'b) -> 'b -> 'a t -> 'b (**Eager fold_right [fold_right f b [^ a0; a1; ...; an ^]] is [f a0 (f a1 (... (f an b) ...))]. This causes evaluation of all the elements of the list. Not tail-recursive. Note that the argument order of this function is the same as [fold_left] above, but inconsistent with other [fold_right] functions in Batteries. We hope to fix this inconsistency in the next compatibility-breaking release, so you should rather use the more consistent [eager_fold_right]. @since 2.2.0 *) val eager_fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** Eager fold_right As [fold_right] above, but with the usual argument order for a fold_right. Just as [fold_left] on a structure ['a t] turns an element-level function of type [('b -> 'a -> 'b)], with the accumulator argument ['b] on the left, into a structure-level function ['b -> 'a t -> 'b], [fold_right] turns a function [('a -> 'b -> 'b)] (accumulator on the right) into a ['a t -> 'b -> 'b]. *) val lazy_fold_right : ('a -> 'b Lazy.t -> 'b) -> 'a t -> 'b Lazy.t -> 'b Lazy.t (**Lazy fold_right [lazy_fold_right f (Cons (a0, Cons (a1, Cons (a2, nil)))) b] is [lazy (f a0 (lazy (f a1 (lazy (f a2 b)))))]. Forcing the result of [lazy_fold_right] forces the first element of the list; the rest is forced only if/when the function [f] forces its accumulator argument. @since 2.1 *) (** {6 Finding}*) val mem : 'a -> 'a t -> bool (** [mem x l] determines if [x] is part of [l]. Evaluates all the elements of [l] which appear before [x].*) val memq : 'a -> 'a t -> bool (** As [mem], but with physical equality*) val find : ('a -> bool) -> 'a t -> 'a (** [find p l] returns the first element of [l] such as [p x] returns [true]. @raise Not_found if such an element has not been found.*) val rfind : ('a -> bool) -> 'a t -> 'a (** [rfind p l] returns the last element [x] of [l] such as [p x] returns [true]. @raise Not_found if such element as not been found. *) val find_exn : ('a -> bool) -> exn -> 'a t -> 'a (** [find_exn p e l] returns the first element of [l] such as [p x] returns [true] or raises [e] if such an element has not been found. *) val rfind_exn : ('a -> bool) -> exn -> 'a t -> 'a (** [rfind_exn p e l] returns the last element of [l] such as [p x] returns [true] or raises [e] if such an element has not been found. *) val findi : (int -> 'a -> bool) -> 'a t -> (int * 'a) (** [findi p e l] returns the first element [ai] of [l] along with its index [i] such that [p i ai] is true. @raise Not_found if no such element has been found. *) val rfindi : (int -> 'a -> bool) -> 'a t -> (int * 'a) (** [rfindi p e l] returns the last element [ai] of [l] along with its index [i] such that [p i ai] is true. @raise Not_found if no such element has been found. *) val index_of : 'a -> 'a t -> int option (** [index_of e l] returns the index of the first occurrence of [e] in [l], or [None] if there is no occurrence of [e] in [l] *) val index_ofq : 'a -> 'a t -> int option (** [index_ofq e l] behaves as [index_of e l] except it uses physical equality*) val rindex_of : 'a -> 'a t -> int option (** [index_of e l] returns the index of the last occurrence of [e] in [l], or [None] if there is no occurrence of [e] in [l] *) val rindex_ofq : 'a -> 'a t -> int option (** [rindex_ofq e l] behaves as [rindex_of e l] except it uses physical equality*) (** {6 Common functions} *) val next : 'a t -> 'a node_t (** Compute and return the first node from the list as a [Cons]. This differs from [hd], which returns the first element (the first component of the first node). *) val length : 'a t -> int (**Return the length (number of elements) of the given list. Causes the evaluation of all the elements of the list.*) val is_empty : 'a t -> bool (** Returns [true] if the list is empty, false otherwise.*) val would_at_fail: 'a t -> int -> bool (**[would_at_fail l n] returns [true] if [l] contains strictly less than [n] elements, [false] otherwise*) val hd : 'a t -> 'a (**Return the first element of the given list. @raise Empty_list if the list is empty. Note: this function does not comply with the usual exceptionless error-management recommendations, as doing so would essentially render it useless.*) val tl : 'a t -> 'a t (**Return the given list without its first element. @raise Empty_list if the list is empty. Note: this function does not comply with the usual exceptionless error-management recommendations, as doing so would essentially render it useless.*) val first : 'a t -> 'a (** As [hd]*) val last : 'a t -> 'a (** Returns the last element of the list. @raise Empty_list if the list is empty. This function takes linear time and causes the evaluation of all elements of the list*) val at : 'a t -> int -> 'a (** [at l n] returns the element at index [n] (starting from [0]) in the list [l]. @raise Invalid_index is the index is outside of [l] bounds. *) val nth : 'a t -> int -> 'a (** Obsolete. As [at]*) (** {6 Association lists} These lists behave essentially as {!HashMap}, although they are typically faster for short number of associations, and much slower for for large number of associations. *) val assoc : 'a -> ('a * 'b) t -> 'b (** [assoc a l] returns the value associated with key [a] in the list of pairs [l]. That is, [assoc a [^ ...; (a,b); ...^] = b] if [(a,b)] is the leftmost binding of [a] in list [l]. @raise Not_found if there is no value associated with [a] in the list [l]. *) val assq : 'a -> ('a * 'b) t -> 'b (** As {!assoc} but with physical equality *) val mem_assoc : 'a -> ('a * 'b) t -> bool (** As {!assoc} but simply returns [true] if a binding exists, [false] otherwise. *) val mem_assq : 'a -> ('a * 'b) t -> bool (** As {!mem_assoc} but with physical equality.*) val rev : 'a t -> 'a t (** Eager list reversal.*) (** {6 Transformations} *) val eager_append : 'a t -> 'a t -> 'a t (**Evaluate a list and append another list after this one. Cost is linear in the length of the first list, not tail-recursive.*) val rev_append : 'a t -> 'a t -> 'a t (**Eager reverse-and-append Cost is linear in the length of the first list, tail-recursive.*) val append : 'a t -> 'a t -> 'a t (**Lazy append Cost is constant. All evaluation is delayed until the contents of the list are actually read. Reading itself is delayed by a constant.*) val ( ^@^ ) : 'a t -> 'a t -> 'a t (**As lazy append*) val concat : ('a t) t -> 'a t (**Lazy concatenation of a lazy list of lazy lists*) val flatten : ('a t) list -> 'a t (** Lazy concatenation of a list of lazy lists*) val split_at : int -> 'a t -> 'a t * 'a t (** [split_at n l] returns two lists [l1] and [l2], [l1] containing the first [n] elements of [l] and [l2] the others. @raise Invalid_index if [n] is outside of [l] size bounds. *) val split_nth : int -> 'a t -> 'a t * 'a t (** Obsolete. As [split_at]. *) (**{6 Dropping elements}*) val unique : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t (** [unique cmp l] returns the list [l] without any duplicate element. Default comparator ( = ) is used if no comparison function specified. *) val unique_eq : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t (** as [unique] except only uses an equality function. Use for short lists when comparing is expensive compared to equality testing @since 1.3.0 *) val remove : 'a -> 'a t -> 'a t (** [remove l x] returns the list [l] without the first element [x] found or returns [l] if no element is equal to [x]. Elements are compared using ( = ). *) val remove_if : ('a -> bool) -> 'a t -> 'a t (** [remove_if cmp l] is similar to [remove], but with [cmp] used instead of ( = ). *) val remove_all : 'a -> 'a t -> 'a t (** [remove_all l x] is similar to [remove] but removes all elements that are equal to [x] and not only the first one. *) val remove_all_such : ('a -> bool) -> 'a t -> 'a t (** [remove_all_such f l] is similar to [remove] but removes all elements that satisfy the predicate [f] and not only the first one. *) val take : int -> 'a t -> 'a t (** [take n l] returns up to the [n] first elements from list [l], if available. *) val drop : int -> 'a t -> 'a t (** [drop n l] returns [l] without the first [n] elements, or the empty list if [l] have less than [n] elements. *) val take_while : ('a -> bool) -> 'a t -> 'a t (** [take_while f xs] returns the first elements of list [xs] which satisfy the predicate [f]. *) val drop_while : ('a -> bool) -> 'a t -> 'a t (** [drop_while f xs] returns the list [xs] with the first elements satisfying the predicate [f] dropped. *) (** {6 Combinatorics} *) val combinations : 'a list -> ('a list) t (** [combinations l] yields a list of all combinations of elements of [l]. Each combination selects a "subset" of the elements of [l] (duplicates are considered as distinct elements). *) val permutations : 'a list -> ('a list) t (** [permutations l] yields a lazy list of all permutations of the list [l]. Every permutation has the same elements as [l], but in a different order. There are [factorial (length l)] permutations. *) (** {6 Conversions} *) val to_list : 'a t -> 'a list (**Eager conversion to string.*) val to_stream : 'a t -> 'a Stream.t (**Lazy conversion to stream.*) val to_array : 'a t -> 'a array (** Eager conversion to array.*) val enum : 'a t -> 'a BatEnum.t (**Lazy conversion to enumeration*) val of_list : 'a list -> 'a t (**Lazy conversion from lists Albeit slower than eager conversion, this is the default mechanism for converting from regular lists to lazy lists. This for two reasons : * if you're using lazy lists, total speed probably isn't as much an issue as start-up speed * this will let you convert regular infinite lists to lazy lists.*) val of_stream : 'a Stream.t -> 'a t (**Lazy conversion from stream.*) val of_enum : 'a BatEnum.t -> 'a t (**Lazy conversion from enum.*) val eager_of_list : 'a list -> 'a t (**Eager conversion from lists. This function is much faster than {!of_list} but will freeze on cyclic lists. *) val of_array : 'a array -> 'a t (**Eager conversion from array*) (** {6 Predicates} *) val filter : ('a -> bool) -> 'a t -> 'a t (**Lazy filtering. [filter p l] returns all the elements of the list [l] that satisfy the predicate [p]. The order of the elements in the input list is preserved.*) val exists : ('a -> bool) -> 'a t -> bool (**Eager existential. [exists p [^ a0; a1; ... ^]] checks if at least one element of the list satisfies the predicate [p]. That is, it returns [ (p a0) || (p a1) || ... ].*) val for_all : ('a -> bool) -> 'a t -> bool (**Eager universal. [for_all p [^ a0; a1; ... ^]] checks if all elements of the list satisfy the predicate [p]. That is, it returns [(p a0) && (p a1) && ... ].*) val filter_map : ('a -> 'b option) -> 'a t -> 'b t (**Lazily eliminate some elements and transform others. [filter_map f [^ a0; a1; ... ^]] applies lazily [f] to each [a0], [a1]... If [f ai] evaluates to [None], the element is not included in the result. Otherwise, if [f ai] evaluates to [Some x], element [x] is included in the result. This is equivalent to [match f a0 with | Some x0 -> x0 ^:^ (match f a1 with | Some x1 -> x1 ^:^ ... | None -> [^ ^]) | None -> [^ ^] ].*) (**{6 Misc.}*) val eternity : unit t (** An infinite list of nothing*) (**{6 Sorting}*) val sort : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t (** Sort the list using optional comparator (by default [compare]). *) val stable_sort : ('a -> 'a -> int) -> 'a t -> 'a t (**{6 Operations on two lists}*) val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t (** [map2 f [^ a0; a1; ...^] [^ b0; b1; ... ^]] is [[^ f a0 b0; f a1 b1; ... ^]]. @raise Different_list_size if the two lists have different lengths. Not tail-recursive, lazy. In particular, the exception is raised only after the shortest list has been entirely consumed. *) val iter2 : ('a -> 'b -> unit) -> 'a t -> 'b t -> unit (** [iter2 f [^ a0; ...; an ^] [^ b0; ...; bn ^]] calls in turn [f a0 b0; ...; f an bn]. Tail-recursive, eager. @raise Different_list_size if the two lists have different lengths. *) val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a (** [fold_left2 f a [^ b0; b1; ...; bn ^] [^ c0; c1; ...; cn ^]] is [f (... (f (f a b0 c0) b1 c1) ...) bn cn]. Eager. @raise Different_list_size if the two lists have different lengths. *) val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a t -> 'b t -> 'c -> 'c (** [fold_right2 f [^ a0; a1; ...; an ^] [^ b0; b1; ...; bn ^] c] is [f a0 b0 (f a1 b1 (... (f an bn c) ...))]. Eager. @raise Different_list_size if the two lists have different lengths. Tail-recursive. *) val for_all2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool (** Same as {!for_all}, but for a two-argument predicate. @raise Different_list_size if the two lists have different lengths. *) val equal : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool (** [equal eq s1 s2] compares elements of [s1] and [s2] pairwise using [eq] and returns true if all elements pass the test and the lists have the same length; otherwise it returns false. Examples: {[ equal (=) (range 0 4) (range 0 4) (* true *) (* Make lazy lists of lazy lists: *) let s1 = init 5 (range 0) let s2 = init 5 (range 0) equal (equal (=)) s1 s2 (* true *) ]} (Calling [=] directly on a pair of lazy lists may succeed but is not guaranteed to behave consistently.) Note that on lists of equal length, [equal] and [for_all2] can perform the same function; their intended uses differ, however, as signaled by behavior on lists of different lengths. *) val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool (** Same as {!exists}, but for a two-argument predicate. @raise Different_list_size if the two lists have different lengths. *) val combine : 'a t -> 'b t -> ('a * 'b) t (** Transform a pair of lists into a list of pairs: [combine [^ a0; a1; ... ^] [^ b0; b1; ... ^]] is [[^ (a0, b0); (a1, b1); ... ^]]. @raise Different_list_size if the two lists have different lengths. Tail-recursive, lazy. *) val uncombine : ('a * 'b) t -> 'a t * 'b t (** Divide a list of pairs into a pair of lists. *) (** {6 Infix submodule regrouping all infix operators} *) module Infix : sig val ( ^:^ ) : 'a -> 'a t -> 'a t val ( ^@^ ) : 'a t -> 'a t -> 'a t end (** {6 Boilerplate code}*) (** {7 Printing}*) val print : ?first:string -> ?last:string -> ?sep:string ->('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> 'b t -> unit (** {6 Override modules}*) (** The following modules replace functions defined in {!LazyList} with functions behaving slightly differently but having the same name. This is by design: the functions meant to override the corresponding functions of {!LazyList}. *) (** Exceptionless counterparts for error-raising operations*) module Exceptionless : sig val find : ('a -> bool) -> 'a t -> 'a option (** [find p l] returns [Some x] where [x] is the first element of [l] such that [p x] returns [true] or [None] if such element as not been found. *) val rfind : ('a -> bool) -> 'a t -> 'a option (** [rfind p l] returns [Some x] where [x] is the last element of [l] such that [p x] returns [true] or [None] if such element as not been found. *) val findi : (int -> 'a -> bool) -> 'a t -> (int * 'a) option (** [findi p e l] returns [Some (i, ai)] where [ai] and [i] are respectively the first element of [l] and its index, such that [p i ai] is true, or [None] if no such element has been found. *) val rfindi : (int -> 'a -> bool) -> 'a t -> (int * 'a) option (** [rfindi p e l] returns [Some (i, ai)] where [ai] and [i] are respectively the last element of [l] and its index, such that [p i ai] is true, or [None] if no such element has been found. *) val split_at : int -> 'a t -> [`Ok of ('a t * 'a t) | `Invalid_index of int] (** Whenever [n] is inside of [l] size bounds, [split_at n l] returns [`Ok (l1,l2)], where [l1] contains the first [n] elements of [l] and [l2] contains the others. Otherwise, returns [`Invalid_index n] *) val at : 'a t -> int -> [`Ok of 'a | `Invalid_index of int] (** If [n] is inside the bounds of [l], [at l n] returns [`Ok x], where [x] is the n-th element of the list [l]. Otherwise, returns [`Invalid_index n].*) val assoc : 'a -> ('a * 'b) t -> 'b option (** [assoc a l] returns [Some b] where [b] is the value associated with key [a] in the list of pairs [l]. That is, [assoc a [ ...; (a,b); ...] = Some b] if [(a,b)] is the leftmost binding of [a] in list [l]. Return [None] if there is no value associated with [a] in the list [l]. *) val assq : 'a -> ('a * 'b) t -> 'b option (** As {!assoc} but with physical equality *) end (** Operations on {!LazyList} with labels. This module overrides a number of functions of {!List} by functions in which some arguments require labels. These labels are there to improve readability and safety and to let you change the order of arguments to functions. In every case, the behavior of the function is identical to that of the corresponding function of {!LazyList}. *) module Labels : sig val iter : f:('a -> 'b) -> 'a t -> unit val iteri : f:(int -> 'a -> unit) -> 'a t -> unit val map : f:('a -> 'b) -> 'a t -> 'b t val mapi : f:(int -> 'a -> 'b) -> 'a t -> 'b t val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b t -> 'a val fold_right : f:('a -> 'b -> 'b) -> init:'b -> 'a t -> 'b val find : f:('a -> bool) -> 'a t -> 'a val rfind : f:('a -> bool) -> 'a t -> 'a val find_exn : f:('a -> bool) -> exn -> 'a t -> 'a val rfind_exn : f:('a -> bool) -> exn -> 'a t -> 'a val findi : f:(int -> 'a -> bool) -> 'a t -> (int * 'a) val rfindi : f:(int -> 'a -> bool) -> 'a t -> (int * 'a) val remove_if : f:('a -> bool) -> 'a t -> 'a t val remove_all_such : f:('a -> bool) -> 'a t -> 'a t val take_while : f:('a -> bool) -> 'a t -> 'a t val drop_while : f:('a -> bool) -> 'a t -> 'a t val filter : f:('a -> bool) -> 'a t -> 'a t val exists : f:('a -> bool) -> 'a t -> bool val for_all : f:('a -> bool) -> 'a t -> bool val filter_map : f:('a -> 'b option) -> 'a t -> 'b t val map2 : f:('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t val iter2 : f:('a -> 'b -> unit) -> 'a t -> 'b t -> unit val fold_right2 : f:('a -> 'b -> 'c -> 'c) -> 'a t -> 'b t -> init:'c -> 'c val for_all2 : f:('a -> 'b -> bool) -> 'a t -> 'b t -> bool val exists2 : f:('a -> 'b -> bool) -> 'a t -> 'b t -> bool module Exceptionless : sig val find: f:('a -> bool) -> 'a t -> 'a option val rfind: f:('a -> bool) -> 'a t -> 'a option val findi: f:(int -> 'a -> bool) -> 'a t -> (int * 'a) option val rfindi:f:(int -> 'a -> bool) -> 'a t -> (int * 'a) option val split_at: int -> 'a t -> [`Ok of ('a t * 'a t) | `Invalid_index of int] val at : 'a t -> int -> [`Ok of 'a | `Invalid_index of int] val assoc : 'a -> ('a * 'b) t -> 'b option val assq : 'a -> ('a * 'b) t -> 'b option end end batteries-included-3.4.0/src/batLexing.mliv000066400000000000000000000225251415601150500206660ustar00rootroot00000000000000(* * BatLexing - Additional functions for string manipulations. * Copyright (C) 1996 Xavier Leroy, INRIA Rocquencourt * Copyright (C) 2009 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Simple lexing using ocaml conventions This module extends Stdlib's {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Lexing.html}Lexing} module, go there for documentation on the rest of the functions and types. *) (** The run-time library for lexers generated by [ocamllex]. *) (** {6 Positions} *) type position = Lexing.position = { pos_fname : string; pos_lnum : int; pos_bol : int; pos_cnum : int; } (** A value of type [position] describes a point in a source file. [pos_fname] is the file name; [pos_lnum] is the line number; [pos_bol] is the offset of the beginning of the line (number of characters between the beginning of the file and the beginning of the line); [pos_cnum] is the offset of the position (number of characters between the beginning of the file and the position). See the documentation of type [lexbuf] for information about how the lexing engine will manage positions. *) val dummy_pos : position (** A value of type [position], guaranteed to be different from any valid position. *) (** {6 Lexer buffers} *) type lexbuf = Lexing.lexbuf = { refill_buff : lexbuf -> unit; mutable lex_buffer : Bytes.t; mutable lex_buffer_len : int; mutable lex_abs_pos : int; mutable lex_start_pos : int; mutable lex_curr_pos : int; mutable lex_last_pos : int; mutable lex_last_action : int; mutable lex_eof_reached : bool; mutable lex_mem : int array; mutable lex_start_p : position; mutable lex_curr_p : position; } (** The type of lexer buffers. A lexer buffer is the argument passed to the scanning functions defined by the generated scanners. The lexer buffer holds the current state of the scanner, plus a function to refill the buffer from the input. At each token, the lexing engine will copy [lex_curr_p] to [lex_start_p], then change the [pos_cnum] field of [lex_curr_p] by updating it with the number of characters read since the start of the [lexbuf]. The other fields are left unchanged by the lexing engine. In order to keep them accurate, they must be initialised before the first use of the lexbuf, and updated by the relevant lexer actions (i.e. at each end of line -- see also [new_line]). Note: Batteries does not currently support the ~with_positions:false mode available since OCaml 4.08 to disable position tracking. If you need this, please get in touch with the Batteries maintainers. *) ##V<4.08##val from_input : BatIO.input -> lexbuf ##V<4.08##(** Create a lexer buffer on the given input ##V<4.08## [Lexing.from_input inp] returns a lexer buffer which reads ##V<4.08## from the input [inp], at the current reading position. *) ##V<4.08##val from_string : string -> lexbuf ##V<4.08##(** Create a lexer buffer which reads from ##V<4.08## the given string. Reading starts from the first character in ##V<4.08## the string. An end-of-input condition is generated when the ##V<4.08## end of the string is reached. *) ##V<4.08##val from_function : (Bytes.t -> int -> int) -> lexbuf ##V<4.08##(** Create a lexer buffer with the given function as its reading method. ##V<4.08## When the scanner needs more characters, it will call the given ##V<4.08## function, giving it a byte sequence [s] and a byte ##V<4.08## count [n]. The function should put [n] bytes or less in [s], ##V<4.08## starting at byte number 0, and return the number of byte ##V<4.08## provided. A return value of 0 means end of input. *) ##V>=4.08##val from_channel : ?with_positions:bool -> in_channel -> lexbuf ##V>=4.08##(** Create a lexer buffer on the given input channel. ##V>=4.08## [Lexing.from_channel inchan] returns a lexer buffer which reads ##V>=4.08## from the input channel [inchan], at the current reading position. *) ##V>=4.08##val from_string : ?with_positions:bool -> string -> lexbuf ##V>=4.08##(** Create a lexer buffer which reads from ##V>=4.08## the given string. Reading starts from the first character in ##V>=4.08## the string. An end-of-input condition is generated when the ##V>=4.08## end of the string is reached. *) ##V>=4.08##val from_function : ?with_positions:bool -> (bytes -> int -> int) -> lexbuf ##V>=4.08##(** Create a lexer buffer with the given function as its reading method. ##V>=4.08## When the scanner needs more characters, it will call the given ##V>=4.08## function, giving it a byte sequence [s] and a byte ##V>=4.08## count [n]. The function should put [n] bytes or fewer in [s], ##V>=4.08## starting at index 0, and return the number of bytes ##V>=4.08## provided. A return value of 0 means end of input. *) ##V>=4.11##val set_position : lexbuf -> position -> unit ##V>=4.11##(** Set the initial tracked input position for [lexbuf] to a custom value. ##V>=4.11## Ignores [pos_fname]. See {!set_filename} for changing this field. ##V>=4.11## @since 4.11 *) ##V>=4.11## ##V>=4.11##val set_filename: lexbuf -> string -> unit ##V>=4.11##(** Set filename in the initial tracked position to [file] in ##V>=4.11## [lexbuf]. ##V>=4.11## @since 4.11 *) ##V>=4.08##val with_positions : lexbuf -> bool ##V>=4.08##(** Tell whether the lexer buffer keeps track of position fields ##V>=4.08## [lex_curr_p] / [lex_start_p], as determined by the corresponding ##V>=4.08## optional argument for functions that create lexer buffers ##V>=4.08## (whose default value is [true]). ##V>=4.08## ##V>=4.08## When [with_positions] is [false], lexer actions should not ##V>=4.08## modify position fields. Doing it nevertheless could ##V>=4.08## re-enable the [with_position] mode and degrade performances. ##V>=4.08##*) (** {6 Functions for lexer semantic actions} *) (** The following functions can be called from the semantic actions of lexer definitions (the ML code enclosed in braces that computes the value returned by lexing functions). They give access to the character string matched by the regular expression associated with the semantic action. These functions must be applied to the argument [lexbuf], which, in the code generated by [ocamllex], is bound to the lexer buffer passed to the parsing function. *) val lexeme : lexbuf -> string (** [Lexing.lexeme lexbuf] returns the string matched by the regular expression. *) val lexeme_char : lexbuf -> int -> char (** [Lexing.lexeme_char lexbuf i] returns character number [i] in the matched string. *) val lexeme_start : lexbuf -> int (** [Lexing.lexeme_start lexbuf] returns the offset in the input stream of the first character of the matched string. The first character of the stream has offset 0. *) val lexeme_end : lexbuf -> int (** [Lexing.lexeme_end lexbuf] returns the offset in the input stream of the character following the last character of the matched string. The first character of the stream has offset 0. *) val lexeme_start_p : lexbuf -> position (** Like [lexeme_start], but return a complete [position] instead of an offset. *) val lexeme_end_p : lexbuf -> position (** Like [lexeme_end], but return a complete [position] instead of an offset. *) val new_line : lexbuf -> unit (** Update the [lex_curr_p] field of the lexbuf to reflect the start of a new line. You can call this function in the semantic action of the rule that matches the end-of-line character. @since 3.11.0 *) (** {6 Miscellaneous functions} *) val flush_input : lexbuf -> unit (** Discard the contents of the buffer and reset the current position to 0. The next use of the lexbuf will trigger a refill. *) (**/**) (** {6 } *) (** The following definitions are used by the generated scanners only. They are not intended to be used by user programs. *) val sub_lexeme : lexbuf -> int -> int -> string val sub_lexeme_opt : lexbuf -> int -> int -> string option val sub_lexeme_char : lexbuf -> int -> char val sub_lexeme_char_opt : lexbuf -> int -> char option type lex_tables = Lexing.lex_tables = { lex_base : string; lex_backtrk : string; lex_default : string; lex_trans : string; lex_check : string; lex_base_code : string; lex_backtrk_code : string; lex_default_code : string; lex_trans_code : string; lex_check_code : string; lex_code: string;} val engine : lex_tables -> int -> lexbuf -> int val new_engine : lex_tables -> int -> lexbuf -> int (** {6 Deprecated}*) val from_channel : BatIO.input -> lexbuf (** @deprecated As {!from_input}*) (**/**) batteries-included-3.4.0/src/batLexing.mlv000066400000000000000000000023131415601150500205060ustar00rootroot00000000000000(* * BatString - Additional functions for string manipulations. * Copyright (C) 1996 Xavier Leroy, INRIA Rocquencourt * Copyright (C) 2009 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open BatIO include Lexing let from_string = Lexing.from_string let from_function = Lexing.from_function let from_input inp = from_function (fun s n -> try input inp s 0 n with No_more_input -> 0) let from_channel = from_input batteries-included-3.4.0/src/batList.mliv000066400000000000000000001262061415601150500203540ustar00rootroot00000000000000(* * BatList - additional and modified functions for lists. * Copyright (C) 2003 Brian Hurt * Copyright (C) 2003 Nicolas Cannasse * Copyright (C) 2008 Red Hat Inc. * Copyright (C) 2009 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Additional and modified functions for lists. The OCaml standard library provides a module for list functions. This BatList module can be used to extend the List module or as a standalone module. It provides new functions and modify the behavior of some other ones (in particular all functions are now {b tail-recursive}). The following functions have the same behavior as the [List] module ones but are tail-recursive: [map], [append], [concat], [flatten], [fold_right], [remove_assoc], [remove_assq], [split]. That means they will not cause a [Stack_overflow] when used on very long list. The implementation might be a little more slow in bytecode, but compiling in native code will not affect performances. This module extends Stdlib's {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/List.html}List} module, go there for documentation on the rest of the functions and types. *) (** List operations. @documents List @author Xavier Leroy (base module) @author Brian Hurt @author Nicolas Cannasse @author Richard W.M. Jones @author David Teller *) ##V<4.08##type 'a t = 'a list ##V>=4.08##type 'a t = 'a list = [] | (::) of 'a * 'a list (**The type of lists*) include BatEnum.Enumerable with type 'a enumerable = 'a t include BatInterfaces.Mappable with type 'a mappable = 'a t (**{6 Base operations}*) val is_empty : 'a list -> bool (** [is_empty e] returns true if [e] does not contains any element. *) val cons : 'a -> 'a list -> 'a list (** [cons h t] returns the list starting with [h] and continuing as [t]. *) val hd : 'a list -> 'a (** Returns the first element of the list, or @raise Failure if the list is empty. *) val first : 'a list -> 'a (** Alias to hd *) val tl : 'a list -> 'a list (** Return the given list without its first element. @raise Failure if the list is empty. *) val last : 'a list -> 'a (** Returns the last element of the list, or @raise Invalid_argument if the list is empty. This function takes linear time. *) val length : 'a list -> int (** Return the length (number of elements) of the given list. *) val compare_lengths : 'a list -> 'b list -> int (** Compare the lengths of two lists. [compare_lengths l1 l2] is equivalent to [compare (length l1) (length l2)], except that the computation stops after itering on the shortest list. @since 2.7.0 *) val compare_length_with : 'a list -> int -> int (** Compare the length of a list to an integer. [compare_length_with l n] is equivalent to [compare (length l) n], except that the computation stops after at most [n] iterations on the list. @since 2.7.0 *) val at : 'a list -> int -> 'a (** [at l n] returns the n-th element of the list [l] or @raise Invalid_argument if the index is outside of [l] bounds. O(l) *) val at_opt : 'a list -> int -> 'a option (** [at_opt] returns the n-th element of the list [l] or None if the index is beyond the length of [l]. @since 2.7.0 @raise Invalid_argument if the index is negative *) val rev : 'a list -> 'a list (** List reversal. *) val shuffle : ?state:Random.State.t -> 'a list -> 'a list (** [shuffle ~state:rs l] randomly shuffles the elements of [l]. The optional random state [rs] allows to control the random numbers being used during shuffling (for reproducibility). Shuffling is implemented using the Fisher-Yates algorithm on an array and works in O(n), where n is the number of elements of [l]. @since 2.6.0 *) val append : 'a list -> 'a list -> 'a list (** [append l1 l2] is a concatenation of [l1] and [l2]. Same function as the infix operator [@]. Tail-recursive. This function takes O([length l1]) time. *) val rev_append : 'a list -> 'a list -> 'a list (** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2]. *) val concat : 'a list list -> 'a list (** Concatenate a list of lists. The elements of the argument are all concatenated together (in the same order) to give the result. Tail-recursive. *) val flatten : 'a list list -> 'a list (** Same as [concat]. *) val singleton : 'a -> 'a list (** Create a list consisting of exactly one element. @since 2.1 *) (**{6 Constructors}*) val make : int -> 'a -> 'a list (** Similar to [String.make], [make n x] returns a list containing [n] elements [x]. *) val range : int -> [< `To | `Downto ] -> int -> int list (** [range 1 `To 3] = [[1; 2; 3]]. [range 3 `Downto 1] = [[3; 2; 1]]. @raise Invalid_argument in ([range i `To j]) if (i > j). @raise Invalid_argument in ([range i `Downto j]) if (i < j). @since 2.2.0 *) val frange : float -> [< `To | `Downto ] -> float -> int -> float list (** [frange start `To stop n] generates (without accumulating floating point errors) [n] floats in the range [[start..stop]]. [n] must be >= 2. At each step, floats in an increasing (resp. decreasing) range increase (resp. decrease) by approximately (stop - start) / (n - 1). @raise Invalid_argument in ([frange i _ j n]) if (n < 2). @raise Invalid_argument in ([frange i `To j _]) if (i >= j). @raise Invalid_argument in ([frange i `Downto j _]) if (i <= j). Examples: [frange 1.0 `To 3.0 3] = [[1.0; 2.0; 3.0]]. [frange 3.0 `Downto 1.0 3] = [[3.0; 2.0; 1.0]]. @since 2.6.0 *) val init : int -> (int -> 'a) -> 'a list (** Similar to [Array.init], [init n f] returns the list containing the results of (f 0),(f 1).... (f (n-1)). @raise Invalid_argument if n < 0.*) val unfold: 'b -> ('b -> ('a * 'b) option) -> 'a list (** [unfold init f] creates a list by repeatedly applying [f] to the second element of its own result, starting from the initial value [init]. The first element of each result is accumulated in a list. The list is terminated and returned as soon as [f] returns [None]. Example: [List.unfold 0 (fun x -> if x = 3 then None else Some (string_of_int x, x+1))] will return [["0";"1";"2"]] @since 2.1 *) val unfold_exn : (unit -> 'a) -> 'a list * exn (** Creates a list containing the results of sequential calls to [f()]. [f()] is called repeatedly until it throws an exception. Both the results list, as well as the exception thrown are returned in a [(results_list, exn)] pair. Warning: if calls to [f()] never throw an exception, unfold_exn is an infinite loop. @since 3.2.0 *) val unfold_exc : (unit -> 'a) -> 'a list * exn (** Alias for [unfold_exn]. @deprecated use {!unfold_exn} @since 2.3.0 *) ##V>=4.12##(**{6 Comparison}*) ##V>=4.12## ##V>=4.12##val equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool ##V>=4.12##(** [equal eq [a1; ...; an] [b1; ..; bm]] holds when ##V>=4.12## the two input lists have the same length, and for each ##V>=4.12## pair of elements [ai], [bi] at the same position we have ##V>=4.12## [eq ai bi]. ##V>=4.12## ##V>=4.12## Note: the [eq] function may be called even if the ##V>=4.12## lists have different length. If you know your equality ##V>=4.12## function is costly, you may want to check {!compare_lengths} ##V>=4.12## first. ##V>=4.12## ##V>=4.12## @since 3.3.0 and 4.12.0 ##V>=4.12##*) (**{6 Iterators}*) val iter : ('a -> unit) -> 'a list -> unit (** [List.iter f [a0; a1; ...; an]] applies function [f] in turn to [a0; a1; ...; an]. It is equivalent to [begin f a0; f a1; ...; f an; () end]. *) val iteri : (int -> 'a -> unit) -> 'a list -> unit (** [iteri f l] will call [(f 0 a0); (f 1 a1) ... (f n an)] where [a0..an] are the elements of the list [l]. *) val map : ('a -> 'b) -> 'a list -> 'b list (** [map f [a0; a1; ...; an]] applies function [f] to [a0, a1, ..., an], and builds the list [[f a0; f a1; ...; f an]] with the results returned by [f]. Tail-recursive. *) (* why that formulation emphasizing "applies function f to ..." ? Because map is specifically designed to respect a left-to-right order of evaluation *) val rev_map : ('a -> 'b) -> 'a list -> 'b list (** [List.rev_map f l] gives the same result as {!List.rev}[ (]{!List.map}[ f l)]. *) val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list (** [mapi f l] will build the list containing [(f 0 a0); (f 1 a1) ... (f n an)] where [a0..an] are the elements of the list [l]. *) val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a (** [List.fold_left f a [b0; b1; ...; bn]] is [f (... (f (f a b0) b1) ...) bn]. *) val fold : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a (** Alias for [fold_left]. *) val fold_lefti : ('a -> int -> 'b -> 'a) -> 'a -> 'b list -> 'a (** As [fold_left], but with the index of the element, from [0] to [length li - 1], as additional argument. @since 2.3.0 *) val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b (** [List.fold_right f [a0; a1; ...; an] b] is [f a0 (f a1 (... (f an b) ...))]. Tail-recursive. *) val fold_righti : (int -> 'b -> 'a -> 'a) -> 'b list -> 'a -> 'a (** As [fold_right], but with the index of the element, from [0] to [length li - 1], as additional argument. @since 2.3.0 *) val reduce : ('a -> 'a -> 'a) -> 'a list -> 'a (** [List.reduce f h::t] is [fold_left f h t]. @raise Invalid_argument on empty list. *) val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list (** Combines [fold_left] and [map]. Tail-recursive. More precisely : {[ fold_left_map f acc [] = (acc, []) fold_left_map f acc (x :: xs) = let (acc', y) = f acc x in let (res, ys) = fold_left_map acc' xs in (res, y :: ys) ]} @since 2.6.0 *) val max : ?cmp:('a -> 'a -> int) -> 'a list -> 'a (** [max l] returns the largest value in [l] as judged by [Pervasives.compare] (by default). You can provide another comparison function via the optional [cmp] parameter. @raise Invalid_argument on an empty list. *) val min : ?cmp:('a -> 'a -> int) -> 'a list -> 'a (** [min l] returns the smallest value in [l] as judged by [Pervasives.compare] (by default). You can provide another comparison function via the optional [cmp] parameter. @raise Invalid_argument on an empty list. *) val sum : int list -> int (** [sum l] returns the sum of the integers of [l]. Returns [0] on the empty list. Note: prior to 2.11.0, used to raise Invalid_argument on the empty list. *) val fsum : float list -> float (** [fsum l] returns the sum of the floats of [l]. Returns [0.] on the empty list. Note: prior to 2.11.0, used to raise Invalid_argument on the empty list. *) val favg : float list -> float (** [favg l] returns the average of the floats of [l] @raise Invalid_argument on the empty list. @since 2.6.0 *) val kahan_sum : float list -> float (** [kahan_sum l] returns a numerically-accurate sum of the floats of [l]. See {!BatArray.fsum} for more details. @since 2.2.0 *) val min_max : ?cmp:('a -> 'a -> int) -> 'a list -> 'a * 'a (** [min_max l] returns the pair (smallest, largest) from [l] as judged by [Pervasives.compare] (by default). You can provide another comparison function via the optional [cmp] parameter. @raise Invalid_argument on an empty list. @since 2.1 *) ##V>=4.07##val to_seq : 'a list -> 'a Seq.t ##V>=4.07##(** Iterate on the list ##V>=4.07## @since 2.10.0 and OCaml 4.07 *) ##V>=4.07##val of_seq : 'a Seq.t -> 'a list ##V>=4.07##(** Create a list from the iterator ##V>=4.07## @since 2.10.0 and OCaml 4.07 *) (** {6 Iterators on two lists} *) val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit (** [List.iter2 f [a0; a1; ...; an] [b0; b1; ...; bn]] calls in turn [f a0 b0; f a1 b1; ...; f an bn]. @raise Invalid_argument if two lists have different lengths. *) val iter2i : (int -> 'a -> 'b -> unit) -> 'a list -> 'b list -> unit (** [List.iter2i f [a0; a1; ...; an] [b0; b1; ...; bn]] calls in turn [f 0 a0 b0; f 1 a1 b1; ...; f n an bn]. @raise Invalid_argument if two lists have different lengths. *) val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.map2 f [a0; a1; ...; an] [b0; b1; ...; bn]] is [[f a0 b0; f a1 b1; ...; f an bn]]. @raise Invalid_argument if two lists have different lengths. Tail-recursive. *) val map2i : (int -> 'a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.map2i f [a0; a1; ...; an] [b0; b1; ...; bn]] is [[f 0 a0 b0; f 1 a1 b1; ...; f n an bn]]. @raise Invalid_argument if two lists have different lengths. Tail-recursive. *) val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.rev_map2 f l1 l2] gives the same result as {!List.rev}[ (]{!List.map2}[ f l1 l2)], but is tail-recursive and more efficient. *) val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a (** [List.fold_left2 f a [b0; b1; ...; bn] [c0; c1; ...; cn]] is [f (... (f (f a b0 c0) b1 c1) ...) bn cn]. @raise Invalid_argument if two lists have different lengths. *) val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c (** [List.fold_right2 f [a0; a1; ...; an] [b0; b1; ...; bn] c] is [f a0 b0 (f a1 b1 (... (f an bn c) ...))]. @raise Invalid_argument if two lists have different lengths. Tail-recursive. *) (**{6 List scanning}*) val mem : 'a -> 'a list -> bool (** [mem a l] is true if and only if [a] is equal to an element of [l]. *) val mem_cmp : ('a -> 'a -> int) -> 'a -> 'a list -> bool (** Same as {!List.mem}, but the comparator function is explicitly provided. @since 2.2.0 *) val memq : 'a -> 'a list -> bool (** Same as {!List.mem}, but uses physical equality instead of structural equality to compare list elements. *) (**{7 Unary predicate, One list}*) val for_all : ('a -> bool) -> 'a list -> bool (** [for_all p [a0; a1; ...; an]] checks if all elements of the list satisfy the predicate [p]. That is, it returns [(p a0) && (p a1) && ... && (p an)]. *) val exists : ('a -> bool) -> 'a list -> bool (** [exists p [a0; a1; ...; an]] checks if at least one element of the list satisfies the predicate [p]. That is, it returns [(p a0) || (p a1) || ... || (p an)]. *) (**{7 Binary predicate, Two lists}*) val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool (** Same as {!List.for_all}, but for a two-argument predicate. @raise Invalid_argument if two lists have different lengths. *) val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool (** Same as {!List.exists}, but for a two-argument predicate. @raise Invalid_argument if two lists have different lengths. *) val subset : ('a -> 'b -> int) -> 'a list -> 'b list -> bool (** [subset cmp l l'] check if all elements of the list [l] is contained in the list [l'] by applying [cmp] as comparator. @since 2.2.0 *) (**{6 List searching}*) val find : ('a -> bool) -> 'a list -> 'a (** [find p l] returns the first element of the list [l] that satisfies the predicate [p]. @raise Not_found if there is no value that satisfies [p] in the list [l]. *) val find_opt: ('a -> bool) -> 'a list -> 'a option (** [find_opt p l] returns the first element of the list [l] that satisfies the predicate [p], or [None] if there is no value that satisfies [p] in the list [l]. @since 2.7.0 *) ##V>=4.10##val find_map_opt: ('a -> 'b option) -> 'a list -> 'b option ##V>=4.10##(** [find_map_opt f l] applies [f] to the elements of [l] in order, ##V>=4.10## and returns the first result of the form [Some v], or [None] ##V>=4.10## if none exist. ##V>=4.10## ##V>=4.10## @since 2.12.0 and OCaml 4.10 ##V>=4.10##*) val find_exn : ('a -> bool) -> exn -> 'a list -> 'a (** [find_exn p e l] returns the first element of [l] such as [p x] returns [true] or raises [e] if such an element has not been found. *) val findi : (int -> 'a -> bool) -> 'a list -> (int * 'a) (** [findi p l] returns the first element [ai] of [l] along with its index [i] such that [p i ai] is true, or @raise Not_found if no such element has been found. *) val find_map : ('a -> 'b option) -> 'a list -> 'b (** [find_map pred list] finds the first element of [list] for which [pred element] returns [Some r]. It returns [r] immediately once found or @raise Not_found if no element matches the predicate. See also {!filter_map}. *) ##V>=4.10##val concat_map : ('a -> 'b list) -> 'a list -> 'b list ##V>=4.10##(** [List.concat_map f l] gives the same result as ##V>=4.10## {!List.concat}[ (]{!List.map}[ f l)]. Tail-recursive. ##V>=4.10## ##V>=4.10## @since 2.12.0 and OCaml 4.10 ##V>=4.10##*) val rfind : ('a -> bool) -> 'a list -> 'a (** [rfind p l] returns the last element [x] of [l] such as [p x] returns [true] or @raise Not_found if such element as not been found. *) val filter : ('a -> bool) -> 'a list -> 'a list (** [filter p l] returns all the elements of the list [l] that satisfy the predicate [p]. The order of the elements in the input list is preserved. *) val count_matching : ('a -> bool) -> 'a list -> int (** [count_matching p l] returns the number of elements in [l] that satisfy [p]. Semantically equivalent but faster than [length (filter p l)]. *) val filteri : (int -> 'a -> bool) -> 'a list -> 'a list (** [filteri p [a0; a1; ...; an]] returns all the elements [ai] of index [i] that satisfy the predicate [p i ai]. The order of the elements in the input list is preserved. @since 2.2.0 *) val filter_map : ('a -> 'b option) -> 'a list -> 'b list (** [filter_map f l] calls [(f a0) (f a1).... (f an)] where [a0,a1..an] are the elements of [l]. It returns the list of elements [bi] such as [f ai = Some bi] (when [f] returns [None], the corresponding element of [l] is discarded). *) val filteri_map : (int -> 'a -> 'b option) -> 'a list -> 'b list (** [filteri_map f l] calls [(f 0 a0) (f 1 a1).... (f n an)] where [a0,a1..an] are the elements of [l]. It returns the list of elements [bi] such as [f ai = Some bi] (when [f] returns [None], the corresponding element of [l] is discarded). @since 2.2.0 *) val find_all : ('a -> bool) -> 'a list -> 'a list (** [find_all] is another name for {!List.filter}. *) val partition : ('a -> bool) -> 'a list -> 'a list * 'a list (** [partition p l] returns a pair of lists [(l1, l2)], where [l1] is the list of all the elements of [l] that satisfy the predicate [p], and [l2] is the list of all the elements of [l] that do not satisfy [p]. The order of the elements in the input list is preserved. *) val partition_map : ('a -> ('b, 'c) BatEither.t) -> 'a list -> 'b list * 'c list (** [partition_map f l] returns a pair of lists [(l1, l2)] such that, for each element [x] of the input list [l]: - if [f x] is [Left y1], then [y1] is in [l1], and - if [f x] is [Right y2], then [y2] is in [l2]. The output elements are included in [l1] and [l2] in the same relative order as the corresponding input elements in [l]. In particular, [partition_map (fun x -> if f x then Left x else Right x) l] is equivalent to [partition f l]. @since 3.3.0 *) val index_of : 'a -> 'a list -> int option (** [index_of e l] returns the index of the first occurrence of [e] in [l], or [None] if there is no occurrence of [e] in [l] *) val index_ofq : 'a -> 'a list -> int option (** [index_ofq e l] behaves as [index_of e l] except it uses physical equality*) val rindex_of : 'a -> 'a list -> int option (** [rindex_of e l] returns the index of the last occurrence of [e] in [l], or [None] if there is no occurrence of [e] in [l] *) val rindex_ofq : 'a -> 'a list -> int option (** [rindex_ofq e l] behaves as [rindex_of e l] except it uses physical equality*) val unique : ?eq:('a -> 'a -> bool) -> 'a list -> 'a list (** [unique cmp l] returns the list [l] without any duplicate element. The default comparator ( = ) is used if no comparison function specified. Implementation Note: The current implementation removes any elements where the tail of the list contains an equal element, thus it keeps the *last* copy of each equal element. This function takes O(n^2) time. @see 'sort_unique' to save time in cases when reordering the list is acceptable @since 2.0 *) val unique_cmp : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list (** As [unique], except comparator parameter returns an int. Default comparator is [Pervasives.compare]. This function takes O(n log n) time. Implementation Note: The current implementation removes subsequent elements that compare as equal to earlier elements in the list, thus it keeps the *first* copy of each equal element. @since 1.3.0 *) val unique_hash : ?hash:('a -> int) -> ?eq:('a -> 'a -> bool) -> 'a list -> 'a list (** As [unique], except uses a hash table to cut down the expected runtime to linear, assuming a good hash function. [?hash] defaults to [Hashtbl.hash] and [?eq] defaults to [(=)]. Implementation Note: The current implementation removes subsequent elements that hash and compare as equal to earlier elements in the list, thus it keeps the *first* copy of each equal element. @since 2.0.0 *) (**{6 Association lists}*) val assoc : 'a -> ('a * 'b) list -> 'b (** [assoc a l] returns the value associated with key [a] in the list of pairs [l]. That is, [assoc a [ ...; (a,b); ...] = b] if [(a,b)] is the leftmost binding of [a] in list [l]. @raise Not_found if there is no value associated with [a] in the list [l]. *) val assoc_opt: 'a -> ('a * 'b) list -> 'b option (** [assoc_opt a l] returns the value associated with key [a] in the list of pairs [l]. That is, [assoc_opt a [ ...; (a,b); ...] = b] if [(a,b)] is the leftmost binding of [a] in list [l]. Returns [None] if there is no value associated with [a] in the list [l]. @since 2.7.0 *) val assoc_inv : 'b -> ('a * 'b) list -> 'a (** [assoc_inv b l] returns the key associated with value [b] in the list of pairs [l]. That is, [assoc b [ ...; (a,b); ...] = a] if [(a,b)] is the leftmost binding of [a] in list [l]. @raise Not_found if there is no key associated with [b] in the list [l]. *) val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list (** [remove_assoc a l] returns the list of pairs [l] without the first pair with key [a], if any. Tail-recursive. *) val mem_assoc : 'a -> ('a * 'b) list -> bool (** Same as {!List.assoc}, but simply return true if a binding exists, and false if no bindings exist for the given key. *) val assq : 'a -> ('a * 'b) list -> 'b (** Same as {!List.assoc}, but uses physical equality instead of structural equality to compare keys. *) val assq_opt : 'a -> ('a * 'b) list -> 'b option (** Same as {!List.assoc_opt}, but uses physical equality instead of structural equality to compare keys. @since 2.7.0 *) val assq_inv : 'b -> ('a * 'b) list -> 'a (** Same as {!List.assoc_inv}, but uses physical equality instead of structural equality to compare keys. *) val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list (** Same as {!List.remove_assoc}, but uses physical equality instead of structural equality to compare keys. Tail-recursive. *) val mem_assq : 'a -> ('a * 'b) list -> bool (** Same as {!List.mem_assoc}, but uses physical equality instead of structural equality to compare keys. *) val modify : 'a -> ('b -> 'b) -> ('a * 'b) list -> ('a * 'b) list (** [modify a f l] returns the same list as [l] but with value [b] associated to key [a] replaced with [f b]. @raise Not_found if no value is associated with [a] in [l] @since 2.1 *) val modify_def : 'b -> 'a -> ('b -> 'b) -> ('a * 'b) list -> ('a * 'b) list (** [modify_def dfl a f l] performs as [modify a f l] except that it add an association from [a] to [f dfl] instead of raising [Not_found]. @since 2.1 *) val modify_opt : 'a -> ('b option -> 'b option) -> ('a * 'b) list -> ('a * 'b) list (** [modify_opt a f l] allows to modify the binding for [a] in [l] or absence thereof. @since 2.1 *) (** {6 List transformations}*) val modify_at : int -> ('a -> 'a) -> 'a list -> 'a list (** [modify_at n f l] returns the same list as [l] but with nth-value [a] replaced with [f a]. @raise Invalid_argument if the index is outside of [l] bounds @since 2.3.0 *) val modify_opt_at : int -> ('a -> 'a option) -> 'a list -> 'a list (** [modify_opt_at n f l] returns the same list as [l] but with nth-value [a] removed if [f a] is [None], and replaced by [v] if it is [Some v]. @raise Invalid_argument if the index is outside of [l] bounds @since 2.3.0 *) val split_at : int -> 'a list -> 'a list * 'a list (** [split_at n l] returns two lists [l1] and [l2], [l1] containing the first [n] elements of [l] and [l2] the others. @raise Invalid_argument if [n] is outside of [l] size bounds. *) val split_nth : int -> 'a list -> 'a list * 'a list (** Obsolete. As [split_at]. *) val remove : 'a list -> 'a -> 'a list (** [remove l x] returns the list [l] without the first element [x] found or returns [l] if no element is equal to [x]. Elements are compared using ( = ). *) val remove_if : ('a -> bool) -> 'a list -> 'a list (** [remove_if cmp l] is similar to [remove], but with [cmp] used instead of ( = ). *) val remove_at : int -> 'a list -> 'a list (** [remove_at i l] returns the list [l] without the element at index [i]. @raise Invalid_argument if [i] is outside of [l] size bounds. @since 2.3.0 *) val remove_all : 'a list -> 'a -> 'a list (** [remove_all l x] is similar to [remove] but removes all elements that are equal to [x] and not only the first one. *) val take : int -> 'a list -> 'a list (** [take n l] returns up to the [n] first elements from list [l], if available. *) val ntake : int -> 'a list -> 'a list list (** [ntake n l] cuts [l] into lists of size at most [n]. [n] must be > 0. @raise Invalid_argument if [n] <= 0. Each list in the result has size n, except the last one which may have fewer elements in case [l] was too short. Example: [ntake 2 [1; 2; 3; 4; 5] = [[1; 2]; [3; 4]; [5]]] @since 2.2.0 *) val drop : int -> 'a list -> 'a list (** [drop n l] returns [l] without the first [n] elements, or the empty list if [l] have less than [n] elements. *) val takedrop : int -> 'a list -> 'a list * 'a list (** [takedrop n l] is equivalent to [(take n l, drop n l)] but is done in one pass. @since 2.2.0 *) val take_while : ('a -> bool) -> 'a list -> 'a list (** [take_while p xs] returns the (possibly empty) longest prefix of elements of [xs] that satisfy the predicate [p].*) val drop_while : ('a -> bool) -> 'a list -> 'a list (** [drop_while p xs] returns the suffix remaining after [take_while p xs]. *) val span : ('a -> bool) -> 'a list -> 'a list * 'a list (** [span], applied to a predicate [p] and a list [xs], returns a tuple where first element is longest prefix (possibly empty) of xs of elements that satisfy p and second element is the remainder of the list. This is equivalent to [(take_while p xs, drop_while p xs)], but is done in one pass. @since 2.1 *) val fold_while : ('acc -> 'a -> bool) -> ('acc -> 'a -> 'acc) -> 'acc -> 'a list -> 'acc * 'a list (** [fold_while p f init l], accumulates elements [x] of list [l] using function [f], as long as predicate [p acc x] holds. At the end, the accumulated value along with the remaining part of the list are returned. @since 2.10.0 *) val nsplit : ('a -> bool) -> 'a list -> 'a list list (** [nsplit], applied to a predicate [p] and a list [xs], returns a list of lists. [xs] is split when [p x] is true and [x] is excluded from the result. If elements that satisfy [p] are consecutive, or at the beginning or end of the input list, the output list will contain empty lists marking their position. For example, [split (fun n -> n<0) [-1;2;-2;-3;4;-5]] is [[[];[2];[];[4];[]]]. This is consistent with the behavior of [String.nsplit], where [String.nsplit ";" "1;2;;3;" = ["1";"2";"";"3";""]]. Note that for any [xss : 'a list list] and [sep : 'a], we always have that [flatten (interleave [sep] (nsplit ((=) sep) xss))] is [xss]. @since 2.1 *) val group_consecutive : ('a -> 'a -> bool) -> 'a list -> 'a list list (** The [group_consecutive] function takes a list and returns a list of lists such that the concatenation of the result is equal to the argument. Moreover, each sublist in the result contains only equal elements. For example, [group_consecutive (=) [3;3;4;3;3] = [[3;3];[4];[3;3]]]. {b Note:} In the next major version, this function is intended to replace the current [group], which also sorts its input before grouping, and which will therefore be renamed into something more pertinent, such as [classify], [regroup], or [group_sort]. @since 2.1 *) val interleave : ?first:'a -> ?last:'a -> 'a -> 'a list -> 'a list (** [interleave ~first ~last sep [a0;a1;a2;...;an]] returns [first; a0; sep; a1; sep; a2; sep; ...; sep; an; last]. *) (** {6 BatEnum functions} Abstraction layer.*) val enum : 'a list -> 'a BatEnum.t (** Returns an enumeration of the elements of a list. This enumeration may be used to visit elements of the list in forward order (i.e. from the first element to the last one). *) val of_enum : 'a BatEnum.t -> 'a list (** Build a list from an enumeration. In the result, elements appear in the same order as they did in the source enumeration. *) val backwards : 'a list -> 'a BatEnum.t (** Returns an enumeration of the elements of a list. This enumeration may be used to visit elements of the list in backwards order (i.e. from the last element to the first one). *) val of_backwards : 'a BatEnum.t -> 'a list (** Build a list from an enumeration. The first element of the enumeration becomes the last element of the list, the second element of the enumeration becomes the second-to-last element of the list... *) (** {6 List of pairs}*) val split : ('a * 'b) list -> 'a list * 'b list (** Transform a list of pairs into a pair of lists: [split [(a0,b0); (a1,b1); ...; (an,bn)]] is [([a0; a1; ...; an], [b0; b1; ...; bn])]. Tail-recursive. *) val combine : 'a list -> 'b list -> ('a * 'b) list (** Transform a pair of lists into a list of pairs: [combine [a0; a1; ...; an] [b0; b1; ...; bn]] is [[(a0,b0); (a1,b1); ...; (an,bn)]]. @raise Invalid_argument if two lists have different lengths. Tail-recursive. *) (** {6 Sorting}*) val sort : ('a -> 'a -> int) -> 'a list -> 'a list (** 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, {!Pervasives.compare} is a suitable comparison function. The resulting list is sorted in increasing order. [List.sort] is guaranteed to run in constant heap space (in addition to the size of the result list) and logarithmic stack space. The current implementation uses Merge Sort. It runs in constant heap space and logarithmic stack space. *) val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list (** Same as {!List.sort}, but the sorting algorithm is guaranteed to be stable (i.e. elements that compare equal are kept in their original order) . The current implementation uses Merge Sort. It runs in constant heap space and logarithmic stack space. *) val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list (** Same as {!List.sort} or {!List.stable_sort}, whichever is faster on typical input. *) val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list (** Merge two lists: Assuming that [l1] and [l2] are sorted according to the comparison function [cmp], [merge cmp 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]. Not tail-recursive (sum of the lengths of the arguments). *) val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list (** [sort_uniq cmp l] returns the list [l] sorted and without any duplicate element. [cmp] is a usual comparison function providing total order. This function takes O(n log n) time. @since 2.3.0 *) val sort_unique : ('a -> 'a -> int) -> 'a list -> 'a list (** synonym for [sort_uniq] *) (** {6 Utilities}*) val group : ('a -> 'a -> int) -> 'a list -> 'a list list (** [group cmp l] returns list of groups and each group consists of elements judged equal by comparison function [cmp]. Groups in the resulting list appear in order given by [cmp]. All groups are always nonempty. [group] returns [[]] only if [l] is empty. For example [group cmp [f;c;b;e;d;a]] can give [[[a;b];[c];[d;e;f]]] if following conditions are met: [cmp a b = 0], [cmp b c = -1], [cmp c d = -1], [cmp d e = 0], ... See the note on [group_consecutive]. *) val cartesian_product : 'a list -> 'b list -> ('a * 'b) list (** Different from [List.combine], this returns every pair of elements formed out of the two lists. [cartesian_product [a0; a1; ...; an] [b0; b1; ...; bn] = [(a0,b0);(a0,b1); ...; (a0,bn); (a1,b0); ..; (a1, bn); ...; (an,bn)]]. The lists can be of unequal size. *) val n_cartesian_product : 'a list list -> 'a list list (** Given n lists, return the n-way cartesian product of these lists. Given [[a;b];[c];[d;e;f]], returns [[a;c;d];[a;c;e];[a;c;f];[b;c;d];[b;c;e];[b;c;f]], all ways of choosing one element from each input list. *) val transpose : 'a list list -> 'a list list (** Transposes a list of lists, turning rows of the input into columns of the output and vice versa. @since 2.0.0 *) (** {6 Boilerplate code}*) (** {7 Printing}*) val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> 'b list -> unit (**Print the contents of a list*) open BatOrd val eq : 'a eq -> 'a list eq val ord : 'a ord -> 'a list ord val compare : 'a comp -> 'a list comp (** Comparison and equality for lists based on element comparison and equality *) module Eq (T : Eq) : Eq with type t = T.t list module Ord (T : Ord) : Ord with type t = T.t list module Comp (T : Comp) : Comp with type t = T.t list (** {6 Obsolete functions} *) val nth : 'a list -> int -> 'a (** Obsolete. As [at]. *) val nth_opt: 'a list -> int -> 'a option (** Return the [n]-th element of the given list. The first element (head of the list) is at position 0. Return [None] if the list is too short. Raise [Invalid_argument "List.nth"] if [n] is negative. @since 2.7.0 *) val takewhile : ('a -> bool) -> 'a list -> 'a list (** obsolete, as {!take_while} *) val dropwhile : ('a -> bool) -> 'a list -> 'a list (** obsolete, as {!drop_while} *) (** {6 Override modules}*) (** The following modules replace functions defined in {!List} with functions behaving slightly differently but having the same name. This is by design: the functions are meant to override the corresponding functions of {!List}. *) (** Exceptionless counterparts for error-raising operations*) module Exceptionless : sig val find : ('a -> bool) -> 'a list -> 'a option (** [find p l] returns [Some x] where [x] is the first element of [l] such as [p x] returns [true] or [None] if such an element has not been found.*) val rfind : ('a -> bool) -> 'a list -> 'a option (** [rfind p l] returns [Some x] where [x] is the last element of [l] such that [p x] returns [true] or [None] if such element as not been found. *) val findi : (int -> 'a -> bool) -> 'a list -> (int * 'a) option (** [findi p l] returns [Some (i, ai)] where [ai] and [i] are respectively the first element of [l] and its index, such that [p i ai] is true, or [None] if no such element has been found. *) val split_at : int -> 'a list -> [`Ok of ('a list * 'a list) | `Invalid_argument of string] (** Whenever [n] is inside of [l] size bounds, [split_at n l] returns [Ok(l1,l2)], where [l1] contains the first [n] elements of [l] and [l2] contains the others. Otherwise, returns [`Invalid_argument n]. *) val at : 'a list -> int -> [`Ok of 'a | `Invalid_argument of string] (** If [n] is inside the bounds of [l], [at l n] returns [Ok x], where [x] is the n-th element of the list [l]. Otherwise, returns [Error (`Invalid_argument(n))].*) val assoc : 'a -> ('a * 'b) list -> 'b option (** [assoc a l] returns [Some b] where [b] is the value associated with key [b] in the list of pairs [l]. That is, [assoc a [ ...; (a,b); ...] = Some b] if [(a,b)] is the leftmost binding of [a] in list [l]. Return [None] if there is no value associated with [a] in the list [l]. *) val assoc_inv : 'b -> ('a * 'b) list -> 'a option (** [assoc_inv b l] returns [Some a] where [a] is the key associated with value [b] in the list of pairs [l]. That is, [assoc b [ ...; (a,b); ...] = Some a] if [(a,b)] is the leftmost binding of [a] in list [l]. Return [None] if there is no key associated with [b] in the list [l]. *) val assq : 'a -> ('a * 'b) list -> 'b option (** As {!assoc} but with physical equality. *) val find_map : ('a -> 'b option) -> 'a list -> 'b option (** [find_map f xs] returns [Some y] such that [x] is the first element of the list where [f x] returns [Some y]. It returns [None] if no such element exists. *) val hd : ('a list -> 'a option) (** [hd l] returns [Some x] such that [x] is the first element of the given list [l]. Returns [None] if list [l] is empty. *) val tl : ('a list -> 'a list option) (** [tl l] returns [Some x] such that [x] is the given list [l] without its first element. Returns [None] if list [l] is empty. *) val last : 'a list -> 'a option (** [last l] returns either [Some x] where [x] is the last element of the list, or [None] if the list is empty. This function takes linear time. *) val reduce : ('a -> 'a -> 'a) -> 'a list -> 'a option (** [reduce f h::t] is [Some (fold_left f h t)] and [reduce f []] is None. *) val min_max : ?cmp:('a -> 'a -> int) -> 'a list -> ('a * 'a) option (** [min_max l] returns either Some(s, l) where s and l are respectively the smallest and biggest element of [l] as judged by [Pervasives.compare] (by default) or None if [l] is empty. You can provide another comparison function via the optional [cmp] parameter. *) val max : ?cmp:('a -> 'a -> int) -> 'a list -> 'a option (** [max l] returns either [Some x] where [x] is the largest value of the list as judged by [Pervasives.compare] (by default) or [None] is the list is empty. You can provide another comparison function via the optional [cmp] parameter. *) val min : ?cmp:('a -> 'a -> int) -> 'a list -> 'a option (** [min l] returns either [Some x] where [x] is the smallest value of the list as judged by [Pervasives.compare] or [None] is the list is empty. You can provide another comparison function via the optional [cmp] parameter. *) end (** {6 Infix submodule regrouping all infix operators} *) module Infix : sig val ( @ ) : 'a list -> 'a list -> 'a list end (** Operations on {!List} with labels. This module overrides a number of functions of {!List} by functions in which some arguments require labels. These labels are there to improve readability and safety and to let you change the order of arguments to functions. In every case, the behavior of the function is identical to that of the corresponding function of {!List}. *) module Labels : sig val init : int -> f:(int -> 'a) -> 'a list val iter : f:('a -> unit) -> 'a list -> unit val iteri : f:(int -> 'a -> unit) -> 'a list -> unit val map : f:('a -> 'b) -> 'a list -> 'b list val mapi : f:(int -> 'a -> 'b) -> 'a list -> 'b list val rev_map : f:('a -> 'b) -> 'a list -> 'b list val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b list -> 'a val fold : f:('a -> 'b -> 'a) -> init:'a -> 'b list -> 'a val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b val iter2 : f:('a -> 'b -> unit) -> 'a list -> 'b list -> unit val map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val rev_map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val fold_left2 : f:('a -> 'b -> 'c -> 'a) -> init:'a -> 'b list -> 'c list -> 'a val fold_right2 : f:('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> init:'c -> 'c val for_all : f:('a -> bool) -> 'a list -> bool val exists : f:('a -> bool) -> 'a list -> bool val for_all2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool val exists2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool val subset : cmp:('a -> 'b -> int) -> 'a list -> 'b list -> bool val find : f:('a -> bool) -> 'a list -> 'a val find_exn : f:('a -> bool) -> exn -> 'a list -> 'a ##V>=4.10##val find_map_opt: f:('a -> 'b option) -> 'a list -> 'b option val findi : f:(int -> 'a -> bool) -> 'a list -> (int * 'a) val rfind : f:('a -> bool) -> 'a list -> 'a val filter : f:('a -> bool) -> 'a list -> 'a list val filter_map : f:('a -> 'b option) -> 'a list -> 'b list val count_matching : f:('a -> bool) -> 'a list -> int ##V>=4.10##val concat_map : f:('a -> 'b list) -> 'a list -> 'b list val find_all : f:('a -> bool) -> 'a list -> 'a list val partition : f:('a -> bool) -> 'a list -> 'a list * 'a list val partition_map : f:('a -> ('b, 'c) BatEither.t) -> 'a list -> 'b list * 'c list val remove_if : f:('a -> bool) -> 'a list -> 'a list val take_while : f:('a -> bool) -> 'a list -> 'a list val drop_while : f:('a -> bool) -> 'a list -> 'a list val stable_sort : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list val fast_sort : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list val merge : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list module LExceptionless : sig val find : f:('a -> bool) -> 'a list -> 'a option val rfind : f:('a -> bool) -> 'a list -> 'a option val findi : f:(int -> 'a -> bool) -> 'a list -> (int * 'a) option val split_at : int -> 'a list -> [`Ok of ('a list * 'a list) |`Invalid_argument of string] val at : 'a list -> int -> [`Ok of 'a | `Invalid_argument of string] val assoc : 'a -> ('a * 'b) list -> 'b option val assoc_inv : 'b -> ('a * 'b) list -> 'a option val assq : 'a -> ('a * 'b) list -> 'b option end end val ( @ ) : 'a list -> 'a list -> 'a list (** Tail recursive [List.append]. *) batteries-included-3.4.0/src/batList.mlv000066400000000000000000001277051415601150500202100ustar00rootroot00000000000000(* * BatList - additional and modified functions for lists. * Copyright (C) 2003 Brian Hurt * Copyright (C) 2003 Nicolas Cannasse * Copyright (C) 2008 Red Hat Inc. * Copyright (C) 2008 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (* ::VH:: GLUE with StdLib *) let merge = List.merge let fast_sort = List.fast_sort let stable_sort = List.stable_sort let sort = List.sort let assq = List.assq ##V>=4.5##let assq_opt = List.assq_opt ##V<4.5##let assq_opt k li = try Some (assq k li) with Not_found -> None let assoc = List.assoc ##V>=4.5##let assoc_opt = List.assoc_opt ##V<4.5##let assoc_opt k li = try Some (assoc k li) with Not_found -> None let find = List.find ##V>=4.5##let find_opt = List.find_opt ##V<4.5##let find_opt p li = try Some (find p li) with Not_found -> None let exists = List.exists let for_all = List.for_all let fold_left = List.fold_left let fold = List.fold_left let rev_map = List.rev_map let iter = List.iter let rev_append = List.rev_append let rev = List.rev let length = List.length ##V>=4.5##let compare_length_with = List.compare_length_with ##V>=4.5##let compare_lengths = List.compare_lengths let tl = List.tl let hd = List.hd let mem = List.mem let memq = List.memq let mem_assq = List.mem_assq let mem_assoc = List.mem_assoc let rev_map2 = List.rev_map2 ##V>=4.07##let to_seq = List.to_seq ##V>=4.07##let of_seq = List.of_seq ##V>=4.10##let concat_map = List.concat_map ##V>=4.10##let find_map_opt = List.find_map ##V>=4.12##let equal = List.equal (* ::VH:: END GLUE *) let rec compare_lengths la lb = match la, lb with | [], [] -> 0 | [], _::_ -> -1 | _::_, [] -> 1 | _::la, _::lb -> compare_lengths la lb (*$T compare_lengths compare_lengths [] [] = 0 compare_lengths [] [1] = -1 compare_lengths [1] [] = 1 compare_lengths [1; 2] [3; 4] = 0 compare_lengths [1; 2; 3] [3; 4] = 1 compare_lengths [1; 2] [2; 3; 4] = -1 *) (*$Q compare_lengths (Q.pair (Q.list Q.small_int) (Q.list Q.small_int)) \ (fun (la, lb) -> \ BatOrd.ord0 (compare_lengths la lb) \ = BatOrd.ord0 (Pervasives.compare (length la) (length lb))) *) let rec compare_length_with li n = match li, n with | [], n -> Pervasives.compare 0 n | _::tl, n -> compare_length_with tl (n-1) (*$T compare_length_with compare_length_with [] 0 = 0 compare_length_with [] 1 = -1 compare_length_with [1] 0 = 1 compare_length_with [1; 2] 2 = 0 compare_length_with [1; 2; 3] 2 = 1 compare_length_with [1; 2] 3 = -1 *) (*$Q compare_length_with (Q.pair (Q.list Q.small_int) Q.small_int) \ (fun (li, n) -> \ BatOrd.ord0 (compare_length_with li n) \ = BatOrd.ord0 (Pervasives.compare (length li) n)) *) (* Thanks to Jacques Garrigue for suggesting the following structure *) type 'a mut_list = { hd: 'a; mutable tl: 'a list } ##V<4.08##type 'a t = 'a list ##V>=4.08##type 'a t = 'a list = [] | (::) of 'a * 'a list type 'a enumerable = 'a t type 'a mappable = 'a t external inj : 'a mut_list -> 'a list = "%identity" module Acc = struct let dummy () = { hd = Obj.magic (); tl = [] } let create x = { hd = x; tl = [] } let accum acc x = let cell = create x in acc.tl <- inj cell; cell end let cons h t = h::t let is_empty = function | [] -> true | _ -> false (*$T is_empty is_empty [] not (is_empty [1]) *) let at_negative_index_msg = "List: Negative index not allowed" let at_after_end_msg = "List: Index past end of list" let nth l index = if index < 0 then invalid_arg at_negative_index_msg; let rec loop n = function | [] -> invalid_arg at_after_end_msg; | h :: t -> if n = 0 then h else loop (n - 1) t in loop index l let at = nth (*$T at try ignore (at [] 0); false with Invalid_argument _ -> true try ignore (at [1;2;3] (-1)); false with Invalid_argument _ -> true at [1;2;3] 2 = 3 *) let at_opt l index = if index < 0 then invalid_arg at_negative_index_msg; try Some (at l index) with Invalid_argument _ -> None (*$T at_opt at_opt [] 0 = None try ignore (at_opt [1;2;3] (-1)); false with Invalid_argument _ -> true at_opt [1;2;3] 2 = Some 3 *) let mem_cmp cmp x l = exists (fun y -> cmp x y = 0) l (*$T mem_cmp mem_cmp Pervasives.compare 0 [] = false mem_cmp Pervasives.compare 0 [1; 2] = false mem_cmp Pervasives.compare 1 [1; 2] = true mem_cmp Pervasives.compare 2 [1; 2] = true *) let append l1 l2 = match l1 with | [] -> l2 | h :: t -> let rec loop dst = function | [] -> dst.tl <- l2 | h :: t -> loop (Acc.accum dst h) t in let r = Acc.create h in loop r t; inj r (*$T append append [] [] = [] append [] [1] = [1] append [1] [] = [1] append [1] [2] = [1; 2] append [1; 2] [3] = [1; 2; 3] append [1] [2; 3] = [1; 2; 3] *) let flatten l = let rec inner dst = function | [] -> dst | h :: t -> inner (Acc.accum dst h) t in let rec outer dst = function | [] -> () | h :: t -> outer (inner dst h) t in let r = Acc.dummy () in outer r l; r.tl let concat = flatten (*$T flatten flatten [[1;2];[3];[];[4;5;6]] = [1;2;3;4;5;6] flatten [[]] = [] *) let singleton x = [x] (*$Q singleton Q.int (fun x -> let s = singleton x in hd s = x && length s = 1) *) let map f = function | [] -> [] | h :: t -> let rec loop dst = function | [] -> () | h :: t -> loop (Acc.accum dst (f h)) t in let r = Acc.create (f h) in loop r t; inj r (*$Q map (Q.pair (Q.fun1 Q.Observable.int Q.int) (Q.list Q.small_int)) \ (fun (Q.Fun (_,f),l) -> map f l = List.map f l) *) let rec drop n = function | _ :: l when n > 0 -> drop (n-1) l | l -> l (*$= drop & ~printer:(IO.to_string (List.print Int.print)) (drop 0 [1;2;3]) [1;2;3] (drop 3 [1;2;3]) [] (drop 4 [1;2;3]) [] (drop 1 [1;2;3]) [2;3] *) let take n l = let rec loop n dst = function | h :: t when n > 0 -> loop (n - 1) (Acc.accum dst h) t | _ -> () in let dummy = Acc.dummy () in loop n dummy l; dummy.tl (*$= take & ~printer:(IO.to_string (List.print Int.print)) (take 0 [1;2;3]) [] (take 3 [1;2;3]) [1;2;3] (take 4 [1;2;3]) [1;2;3] (take 1 [1;2;3]) [1] *) let takedrop n l = let rec loop n dst = function | h :: t when n > 0 -> loop (n - 1) (Acc.accum dst h) t | rest -> rest in let dummy = Acc.dummy () in let rest = loop n dummy l in (dummy.tl, rest) (*$T takedrop takedrop 0 [1; 2; 3] = ([], [1; 2; 3]) takedrop 3 [1; 2; 3] = ([1; 2; 3], []) takedrop 4 [1; 2; 3] = ([1; 2; 3], []) takedrop 1 [1; 2; 3] = ([1], [2; 3]) *) let ntake n l = if n < 1 then invalid_arg "List.ntake"; let took, left = takedrop n l in let acc = Acc.create took in let rec loop dst = function | [] -> inj acc | li -> let taken, rest = takedrop n li in loop (Acc.accum dst taken) rest in loop acc left (*$T ntake ntake 2 [] = [[]] ntake 2 [1] = [[1]] ntake 2 [1; 2] = [[1; 2]] ntake 2 [1; 2; 3] = [[1; 2]; [3]] ntake 2 [1; 2; 3; 4] = [[1; 2]; [3; 4]] *) let take_while p li = let rec loop dst = function | [] -> () | x :: xs -> if p x then loop (Acc.accum dst x) xs in let dummy = Acc.dummy () in loop dummy li; dummy.tl (*$= take_while & ~printer:(IO.to_string (List.print Int.print)) (take_while ((=) 3) [3;3;4;3;3]) [3;3] (take_while ((=) 3) [3]) [3] (take_while ((=) 3) [4]) [] (take_while ((=) 3) []) [] (take_while ((=) 2) [2; 2]) [2; 2] *) let rec drop_while f = function | [] -> [] | x :: xs when f x -> drop_while f xs | xs -> xs (*$= drop_while & ~printer:(IO.to_string (List.print Int.print)) (drop_while ((=) 3) [3;3;4;3;3]) [4;3;3] (drop_while ((=) 3) [3]) [] *) let span p li = let rec loop dst = function | [] -> [] | x :: xs as l -> if p x then loop (Acc.accum dst x) xs else l in let dummy = Acc.dummy () in let xs = loop dummy li in (dummy.tl , xs) (*$= span (span ((=) 3) [3;3;4;3;3]) ([3;3],[4;3;3]) (span ((=) 3) [3]) ([3],[]) (span ((=) 3) [4]) ([],[4]) (span ((=) 3) []) ([],[]) (span ((=) 2) [2; 2]) ([2; 2],[]) *) let fold_while p f init li = let rec loop acc = function | [] -> (acc, []) | (x :: xs) as l -> if p acc x then loop (f acc x) xs else (acc, l) in loop init li (*$= fold_while (fold_while (fun _acc x -> x = 3) (fun acc x -> acc + x) 0 [3;3;4;3;3]) (6,[4;3;3]) (fold_while (fun acc _x -> acc < 6) (fun acc x -> acc + x) 0 [3;3;4;3;3]) (6,[4;3;3]) (fold_while (fun _acc x -> x = 3) (fun acc x -> acc + x) 0 [3]) (3,[]) (fold_while (fun _acc x -> x = 3) (fun acc x -> acc + x) 0 [4]) (0,[4]) (fold_while (fun _acc x -> x = 3) (fun acc x -> acc + x) 0 []) (0,[]) (fold_while (fun _acc x -> x = 2) (fun acc x -> acc + x) 0 [2; 2]) (4,[]) *) let nsplit p = function | [] -> [] (* note that returning [] on empty inputs is an arbitrary choice that is made for consistence with the behavior of BatString.nsplit. Not having this hardcoded case would have `nsplit p []` return `[[]]`, which is also a semantically valid return value (in fact the two are equivalent, but `[[]]` would be a more natural choice as it allows to enforce the simply invariant that `nsplit` return values are always non-empty). If that was to redo from scratch, `[[]]` would be a better return value for both `BatList.nsplit` and `BatString.nsplit`. *) | li -> let not_p x = not (p x) in let rec loop dst l = let ok, rest = span not_p l in let r = Acc.accum dst ok in match rest with | [] -> () | _x :: xs -> loop r xs in let dummy = Acc.dummy () in loop dummy li; dummy.tl (*$T nsplit nsplit ((=) 0) [] = [] nsplit ((=) 0) [0] = [[]; []] nsplit ((=) 0) [1; 0] = [[1]; []] nsplit ((=) 0) [0; 1] = [[]; [1]] nsplit ((=) 0) [1; 2; 0; 0; 3; 4; 0; 5] = [[1; 2]; []; [3; 4]; [5]] *) (*$Q nsplit & ~count:10 (Q.list (Q.list Q.pos_int)) (fun xss -> \ let join sep xss = flatten (interleave [sep] xss) in \ (* normalize: the return type of nsplit \ is quotiented by the equivalence []~[[]] *) \ let normalize = function [] -> [[]] | li -> li in \ let neg = -1 in \ normalize xss = normalize (nsplit ((=) neg) (join neg xss)) \ ) (Q.pair Q.small_int (Q.list Q.small_int)) (fun (sep,xs) -> \ let join sep xss = flatten (interleave [sep] xss) in \ xs = join sep (nsplit ((=) sep) xs) \ ) *) (* nsplit ((=) sep) la @ nsplit ((=) sep) lb = nsplit ((=) sep) (la @ [sep] @ lb) *) let group_consecutive p l = let rec loop dst = function | [] -> () | x :: rest -> let xs, rest = span (p x) rest in loop (Acc.accum dst (x :: xs)) rest in let dummy = Acc.dummy () in loop dummy l; dummy.tl (*$= group_consecutive & ~printer:(IO.to_string (List.print (List.print Int.print))) (group_consecutive (=) [3; 3; 4; 3; 3]) [[3; 3]; [4]; [3; 3]] (group_consecutive (=) [3]) [[3]] (group_consecutive (=) []) [] (group_consecutive (=) [2; 2]) [[2; 2]] *) ##V>=4.5##let nth_opt = List.nth_opt ##V<4.5##let nth_opt li n = try Some (nth li n) with _ -> None let takewhile = take_while let dropwhile = drop_while let interleave ?first ?last (sep:'a) (l:'a list) = let may_prepend maybe_x lst = match maybe_x with | None -> lst | Some x -> x :: lst in let rec loop acc = function | [] -> acc | x :: xs -> match acc with | [] -> loop [x] xs | _ -> loop (x :: sep :: acc) xs in let res = loop [] l in may_prepend first (rev (may_prepend last res)) (*$= interleave & ~printer:(IO.to_string (List.print Int.print)) (interleave 0 [1;2;3]) [1;0;2;0;3] (interleave 0 [1]) [1] (interleave 0 []) [] (interleave ~first:(-1) 0 [1;2;3]) [-1;1;0;2;0;3] (interleave ~first:(-1) 0 [1]) [-1;1] (interleave ~first:(-1) 0 []) [-1] (interleave ~last:(-2) 0 [1;2;3]) [1;0;2;0;3;-2] (interleave ~last:(-2) 0 [1]) [1;-2] (interleave ~last:(-2) 0 []) [-2] (interleave ~first:(-1) ~last:(-2) 0 [1;2;3]) [-1;1;0;2;0;3;-2] (interleave ~first:(-1) ~last:(-2) 0 [1]) [-1;1;-2] (interleave ~first:(-1) ~last:(-2) 0 []) [-1;-2] *) let unique ?(eq = ( = )) l = let rec loop dst = function | [] -> () | h :: t -> match exists (eq h) t with | true -> loop dst t | false -> loop (Acc.accum dst h) t in let dummy = Acc.dummy () in loop dummy l; dummy.tl (* FIXME BAD TESTS: RESULT IS SPECIFIC TO IMPLEMENTATION *) (*$= unique & ~printer:(IO.to_string (List.print Int.print)) [1;2;3;4;5;6] (unique [1;1;2;2;3;3;4;5;6;4;5;6]) [1] (unique [1;1;1;1;1;1;1;1;1;1]) [1;2] (unique ~eq:(fun x y -> x land 1 = y land 1) [2;2;2;4;6;8;3;1;2]) *) let unique_cmp ?(cmp = Pervasives.compare) l = let set = ref (BatSet.PSet.create cmp) in let should_keep x = if BatSet.PSet.mem x !set then false else ( set := BatSet.PSet.add x !set; true ) in (* use a stateful filter to remove duplicate elements *) List.filter should_keep l (*$= unique_cmp & ~printer:(IO.to_string (List.print Int.print)) [1;2;3;4;5;6] (unique_cmp [1;1;2;2;3;3;4;5;6;4;5;6]) [1] (unique_cmp [1;1;1;1;1;1;1;1;1;1]) [2;3] (unique_cmp ~cmp:(fun x y -> Int.compare (x land 1) (y land 1)) [2;2;2;4;6;8;3;1;2]) *) let unique_hash (type et) ?(hash = Hashtbl.hash) ?(eq = (=)) (l : et list) = let module HT = Hashtbl.Make(struct type t = et let equal = eq let hash = hash end) in let ht = HT.create (List.length l) in let rec loop dst = function | h::t when not (HT.mem ht h) -> HT.add ht h (); (* put h in hash table *) loop (Acc.accum dst h) (* and to output list *) t | _::t -> (* if already in hashtable then don't add to output list *) loop dst t | [] -> () in let dummy = Acc.dummy () in loop dummy l; dummy.tl (*$= unique_hash & ~printer:(IO.to_string (List.print Int.print)) [1;2;3;4;5;6] (unique_hash [1;1;2;2;3;3;4;5;6;4;5;6]) [1] (unique_hash [1;1;1;1;1;1;1;1;1;1]) [2;3] (unique_hash ~hash:(fun x -> Hashtbl.hash (x land 1)) ~eq:(fun x y -> x land 1 = y land 1) [2;2;2;4;6;8;3;1;2]) *) let filter_map f l = let rec loop dst = function | [] -> () | h :: t -> match f h with | None -> loop dst t | Some x -> loop (Acc.accum dst x) t in let dummy = Acc.dummy () in loop dummy l; dummy.tl let filteri_map f l = let rec loop i dst = function | [] -> () | h :: t -> match f i h with | None -> loop (succ i) dst t | Some x -> loop (succ i) (Acc.accum dst x) t in let dummy = Acc.dummy () in loop 0 dummy l; dummy.tl (*$T filteri_map (let r = ref (-1) in filteri_map (fun i _ -> incr r; if i = !r then Some i else None) [5; 4; 8] = [0; 1; 2]) filteri_map (fun _ x -> if x > 4 then Some (x, string_of_int x) else None) [5; 4; 8] = [(5, "5"); (8, "8")] filteri_map (fun _ _ -> Some ()) [] = [] filteri_map (fun _ _ -> None) [1; 2] = [] *) let rec find_map f = function | [] -> raise Not_found | x :: xs -> match f x with | Some y -> y | None -> find_map f xs let fold_right_max = 1000 let fold_right f l init = let rec tail_loop acc = function | [] -> acc | h :: t -> tail_loop (f h acc) t in let rec loop n = function | [] -> init | h :: t -> if n < fold_right_max then f h (loop (n+1) t) else f h (tail_loop init (rev t)) in loop 0 l let map2 f l1 l2 = let rec loop dst src1 src2 = match src1, src2 with | [], [] -> () | h1 :: t1, h2 :: t2 -> loop (Acc.accum dst (f h1 h2)) t1 t2 | _ -> invalid_arg "List.map2: list lengths differ" in let dummy = Acc.dummy () in loop dummy l1 l2; dummy.tl let map2i f l1 l2 = let rec loop i dst src1 src2 = match src1, src2 with | [], [] -> () | h1 :: t1, h2 :: t2 -> loop (succ i) (Acc.accum dst (f i h1 h2)) t1 t2 | _ -> invalid_arg "List.map2i: list lengths differ" in let dummy = Acc.dummy () in loop 0 dummy l1 l2; dummy.tl (*$T map2i map2i (fun i x y -> i, x, y) [] [] = [] map2i (fun i x y -> i, x, y) ['a'] ["b"] = [0, 'a', "b"] map2i (fun i x y -> i, x, y) ['a'; 'b'; 'c'] ["d"; "e"; "f"] = \ [(0, 'a', "d"); (1, 'b', "e"); (2, 'c', "f")] try ignore (map2i (fun i x y -> i, x, y) [] [0]); false \ with Invalid_argument _ -> true try ignore (map2i (fun i x y -> i, x, y) [1; 2; 3] ["4"]); false \ with Invalid_argument _ -> true *) let rec iter2 f l1 l2 = match l1, l2 with | [], [] -> () | h1 :: t1, h2 :: t2 -> f h1 h2; iter2 f t1 t2 | _ -> invalid_arg "List.iter2: list lengths differ" let iter2i f l1 l2 = let rec loop i l1 l2 = match l1, l2 with | [], [] -> () | h1 :: t1, h2 :: t2 -> f i h1 h2; loop (succ i) t1 t2 | _ -> invalid_arg "List.iter2i: list lengths differ" in loop 0 l1 l2 (*$T iter2i try iter2i (fun _ _ _ -> ()) [1] [1;2;3]; false \ with Invalid_argument _ -> true try iter2i (fun _ _ _ -> ()) [1] []; false \ with Invalid_argument _ -> true *) (*$T iter2i iter2i (fun _ _ _ -> assert false) [] []; true let r = ref 0 in iter2i (fun i x y -> r := !r + i * x + y) [1] [2]; !r = 2 let r = ref 0 in iter2i (fun i x y -> r := !r + i * x + y) [1; 2] [3; 4]; !r = 9 *) let rec fold_left2 f accum l1 l2 = match l1, l2 with | [], [] -> accum | h1 :: t1, h2 :: t2 -> fold_left2 f (f accum h1 h2) t1 t2 | _ -> invalid_arg "List.fold_left2: list lengths differ" let fold_right2 f l1 l2 init = let rec tail_loop acc l1 l2 = match l1, l2 with | [] , [] -> acc | h1 :: t1 , h2 :: t2 -> tail_loop (f h1 h2 acc) t1 t2 | _ -> invalid_arg "List.fold_right2: list lengths differ" in let rec loop n l1 l2 = match l1, l2 with | [], [] -> init | h1 :: t1, h2 :: t2 -> if n < fold_right_max then f h1 h2 (loop (n+1) t1 t2) else f h1 h2 (tail_loop init (rev t1) (rev t2)) | _ -> invalid_arg "List.fold_right2: list lengths differ" in loop 0 l1 l2 let for_all2 p l1 l2 = let rec loop l1 l2 = match l1, l2 with | [], [] -> true | h1 :: t1, h2 :: t2 -> if p h1 h2 then loop t1 t2 else false | _ -> invalid_arg "List.for_all2: list lengths differ" in loop l1 l2 let exists2 p l1 l2 = let rec loop l1 l2 = match l1, l2 with | [], [] -> false | h1 :: t1, h2 :: t2 -> if p h1 h2 then true else loop t1 t2 | _ -> invalid_arg "List.exists2: list lengths differ" in loop l1 l2 let remove_assoc x lst = let rec loop dst = function | [] -> () | (a, _ as pair) :: t -> if a = x then dst.tl <- t else loop (Acc.accum dst pair) t in let dummy = Acc.dummy () in loop dummy lst; dummy.tl let remove_assq x lst = let rec loop dst = function | [] -> () | (a, _ as pair) :: t -> if a == x then dst.tl <- t else loop (Acc.accum dst pair) t in let dummy = Acc.dummy () in loop dummy lst; dummy.tl let remove_at i lst = let rec loop dst i = function | [] -> invalid_arg "List.remove_at" | x :: xs -> if i = 0 then dst.tl <- xs else loop (Acc.accum dst x) (i - 1) xs in if i < 0 then invalid_arg "List.remove_at" else let dummy = Acc.dummy () in loop dummy i lst; dummy.tl (*$T remove_at try ignore (remove_at 0 []) ; false with Invalid_argument _ -> true try ignore (remove_at 1 [0]); false with Invalid_argument _ -> true remove_at 0 [0] = [] remove_at 0 [0; 1; 2] = [1; 2] remove_at 1 [0; 1; 2] = [0; 2] remove_at 2 [0; 1; 2] = [0; 1] *) let rfind p l = find p (rev l) let find_all p l = let rec findnext dst = function | [] -> () | h :: t -> if p h then findnext (Acc.accum dst h) t else findnext dst t in let dummy = Acc.dummy () in findnext dummy l; dummy.tl let findi p l = let rec loop n = function | [] -> raise Not_found | h :: t -> if p n h then (n,h) else loop (n+1) t in loop 0 l let index_of e l = let rec loop n = function | [] -> None | h::_ when h = e -> Some n | _::t -> loop ( n + 1 ) t in loop 0 l let index_ofq e l = let rec loop n = function | [] -> None | h::_ when h == e -> Some n | _::t -> loop ( n + 1 ) t in loop 0 l let rindex_of e l = let rec loop n acc = function | [] -> acc | h::t when h = e -> loop ( n + 1) ( Some n ) t | _::t -> loop ( n + 1 ) acc t in loop 0 None l let rindex_ofq e l = let rec loop n acc = function | [] -> acc | h::t when h == e -> loop ( n + 1) ( Some n ) t | _::t -> loop ( n + 1 ) acc t in loop 0 None l let filter = find_all let count_matching p l = fold_left (fun count x -> if p x then count + 1 else count ) 0 l (*$T count_matching count_matching (fun _ -> true) [] = 0 count_matching (fun _ -> true) [1] = 1 count_matching (fun _ -> true) [1;2] = 2 count_matching (fun x -> x mod 2 = 1) [1;2;3;4;5;6] = 3 *) ##V>=4.11##let filteri = List.filteri ##V<4.11##let filteri f = ##V<4.11## let rec aux i = function ##V<4.11## | [] -> [] ##V<4.11## | x::xs when f i x -> x :: aux (succ i) xs ##V<4.11## | _x::xs -> aux (succ i) xs ##V<4.11## in ##V<4.11## aux 0 (*$T filteri (let r = ref (-1) in filteri (fun i _ -> incr r; i = !r) [5; 4; 8] = [5; 4; 8]) filteri (fun _ x -> x > 4) [5; 4; 8] = [5; 8] filteri (fun _ _ -> true) [] = [] *) let partition p lst = let rec loop yesdst nodst = function | [] -> () | h :: t -> if p h then loop (Acc.accum yesdst h) nodst t else loop yesdst (Acc.accum nodst h) t in let yesdummy = Acc.dummy () and nodummy = Acc.dummy () in loop yesdummy nodummy lst; (yesdummy.tl, nodummy.tl) let partition_map p lst = let rec loop left right = function | [] -> () | x :: xs -> match p x with | BatEither.Left v -> loop (Acc.accum left v) right xs | BatEither.Right v -> loop left (Acc.accum right v) xs in let left_acc = Acc.dummy () and right_acc = Acc.dummy () in loop left_acc right_acc lst; (left_acc.tl, right_acc.tl) (*$T partition_map let odd_or_even x = \ if x mod 2 = 1 then BatEither.Left x else BatEither.Right x in \ partition_map odd_or_even [1;2;3;4;5;6] = ([1;3;5], [2;4;6]) *) let split lst = let rec loop adst bdst = function | [] -> () | (a, b) :: t -> loop (Acc.accum adst a) (Acc.accum bdst b) t in let adummy = Acc.dummy () and bdummy = Acc.dummy () in loop adummy bdummy lst; adummy.tl, bdummy.tl let combine l1 l2 = match l1, l2 with | [], [] -> [] | x :: xs, y :: ys -> let acc = Acc.create (x, y) in let rec loop dst l1 l2 = match l1, l2 with | [], [] -> inj acc | h1 :: t1, h2 :: t2 -> loop (Acc.accum dst (h1, h2)) t1 t2 | _, _ -> invalid_arg "List.combine: list lengths differ" in loop acc xs ys | _, _ -> invalid_arg "List.combine: list lengths differ" (*$T combine combine [] [] = [] combine [1] [2] = [(1, 2)] combine [1; 3] [2; 4] = [(1, 2); (3, 4)] *) let init size f = if size = 0 then [] else if size < 0 then invalid_arg "BatList.init" else let rec loop dst n = if n < size then loop (Acc.accum dst (f n)) (n+1) in let r = Acc.create (f 0) in loop r 1; inj r let unfold_exn f = let rec loop dst = loop (Acc.accum dst (f ())) in let acc = Acc.dummy () in try loop acc with exn -> (acc.tl, exn) (*$T unfold_exn let exc () = raise End_of_file in \ unfold_exn exc = ([], End_of_file) let state = ref 0 in \ let just_zero () = \ if !state = 1 then raise End_of_file \ else let _ = incr state in 0 \ in \ unfold_exn just_zero = ([0], End_of_file) *) let unfold_exc = unfold_exn let make i x = if i < 0 then invalid_arg "List.make"; let rec loop x acc = function | 0 -> acc | i -> loop x (x::acc) (i-1) in loop x [] i let range i dir j = let op = match dir with | `To -> if i > j then invalid_arg (Printf.sprintf "List.range %d `To %d" i j) else pred | `Downto -> if i < j then invalid_arg (Printf.sprintf "List.range %d `Downto %d" i j) else succ in let rec loop acc k = if i = k then k :: acc else loop (k :: acc) (op k) in loop [] j (*$T range range 1 `To 3 = [1; 2; 3] range 1 `To 1 = [1] range 3 `Downto 1 = [3; 2; 1] range 3 `Downto 3 = [3] try ignore(range 1 `To 0); true with Invalid_argument _ -> true try ignore(range 1 `Downto 2); true with Invalid_argument _ -> true *) let frange start direction stop n = if n < 2 then invalid_arg (Printf.sprintf "List.frange: %d < 2" n); let nb_steps = float_of_int (n - 1) in match direction with | `To -> begin if start >= stop then invalid_arg (Printf.sprintf "List.frange %f `To %f" start stop); let span = stop -. start in let rec loop acc i = let x = ((span *. float_of_int (i - 1)) /. nb_steps) +. start in let acc' = x :: acc in if i = 1 then acc' else loop acc' (i - 1) in loop [] n end | `Downto -> begin if start <= stop then invalid_arg (Printf.sprintf "List.frange %f `Downto %f" start stop); let span = start -. stop in let rec loop acc i = let x = ((span *. float_of_int (i - 1)) /. nb_steps) +. stop in let acc' = x :: acc in if i = n then acc' else loop acc' (i + 1) in loop [] 1 end (*$T frange try ignore(frange 1. `To 2. 1); true with Invalid_argument _ -> true try ignore(frange 2. `Downto 1. 1); true with Invalid_argument _ -> true try ignore(frange 3. `To 1. 3); true with Invalid_argument _ -> true try ignore(frange 1. `Downto 3. 3); true with Invalid_argument _ -> true frange 1. `To 3. 3 = [1.; 2.; 3.] frange 1. `To 2. 2 = [1.; 2.] frange 3. `Downto 1. 3 = [3.; 2.; 1.] frange 2. `Downto 1. 2 = [2.; 1.] length (frange 0.123 `To 3.491 1000) = 1000 *) let mapi f = function | [] -> [] | h :: t -> let rec loop dst n = function | [] -> () | h :: t -> loop (Acc.accum dst (f n h)) (n + 1) t in let r = Acc.create (f 0 h) in loop r 1 t; inj r let iteri f l = let rec loop n = function | [] -> () | h :: t -> f n h; loop (n+1) t in loop 0 l let fold_lefti f init l = let rec loop i acc = function | [] -> acc | x :: xs -> loop (i + 1) (f acc i x) xs in loop 0 init l (*$T fold_lefti fold_lefti (fun acc i x -> (i, x) :: acc) [] [] = [] fold_lefti (fun acc i x -> (i, x) :: acc) [] [0.] = [(0, 0.)] fold_lefti (fun acc i x -> (i, x) :: acc) [] [0.; 1.] = [(1, 1.); (0, 0.)] *) let fold_righti f l init = let xis = (* reverse the list and index its elements *) fold_lefti (fun acc i x -> (i, x) :: acc) [] l in fold_left (fun acc (i, x) -> f i x acc) init xis (*$T fold_righti fold_righti (fun i x acc -> (i, x) :: acc) [] [] = [] fold_righti (fun i x acc -> (i, x) :: acc) [0.] [] = [(0, 0.)] fold_righti (fun i x acc -> (i, x) :: acc) [0.; 1.] [] = [(0, 0.); (1, 1.)] *) ##V>=4.11##let fold_left_map = List.fold_left_map ##V<4.11##let fold_left_map f acc = function ##V<4.11## | [] -> acc, [] ##V<4.11## | h :: t -> ##V<4.11## let rec loop acc dst = function ##V<4.11## | [] -> acc ##V<4.11## | h :: t -> ##V<4.11## let acc', t' = f acc h in ##V<4.11## loop acc' (Acc.accum dst t') t ##V<4.11## in ##V<4.11## let acc', h' = f acc h in ##V<4.11## let r = Acc.create h' in ##V<4.11## let res = loop acc' r t in ##V<4.11## res, inj r (*$T fold_left_map fold_left_map (fun acc x -> assert false) 0 [] = (0, []) fold_left_map (fun acc x -> acc ^ x, int_of_string x) "0" ["1"; "2"; "3"] = ("0123", [1; 2; 3]) *) let first = hd let rec last = function | [] -> invalid_arg "Empty List" | h :: [] -> h | _ :: t -> last t let split_nth index = function | [] -> if index = 0 then [],[] else invalid_arg at_after_end_msg | (h :: t as l) -> if index = 0 then [],l else if index < 0 then invalid_arg at_negative_index_msg else let rec loop n dst l = if n = 0 then l else match l with | [] -> invalid_arg at_after_end_msg | h :: t -> loop (n - 1) (Acc.accum dst h) t in let r = Acc.create h in inj r, loop (index-1) r t let split_at = split_nth let find_exn f e l = try find f l with Not_found -> raise e let remove l x = let rec loop dst = function | [] -> () | h :: t -> if x = h then dst.tl <- t else loop (Acc.accum dst h) t in let dummy = Acc.dummy () in loop dummy l; dummy.tl let remove_if f lst = let rec loop dst = function | [] -> () | x :: l -> if f x then dst.tl <- l else loop (Acc.accum dst x) l in let dummy = Acc.dummy () in loop dummy lst; dummy.tl let remove_all l x = let rec loop dst = function | [] -> () | h :: t -> if x = h then loop dst t else loop (Acc.accum dst h) t in let dummy = Acc.dummy () in loop dummy l; dummy.tl let transpose = function | [] -> [] | [x] -> List.map (fun x -> [x]) x | x::xs -> let heads = List.map Acc.create x in ignore ( fold_left (fun acc x -> map2 (fun x xs -> Acc.accum xs x) x acc) heads xs); Obj.magic heads (* equivalent to List.map inj heads, but without creating a new list *) (*$T transpose transpose [ [1; 2; 3;]; [4; 5; 6;]; [7; 8; 9;] ] = [[1;4;7];[2;5;8];[3;6;9]] transpose [] = [] transpose [ [1] ] = [ [1] ] *) let enum l = let rec make lr count = BatEnum.make ~next:(fun () -> match !lr with | [] -> raise BatEnum.No_more_elements | h :: t -> decr count; lr := t; h ) ~count:(fun () -> if !count < 0 then count := length !lr; !count ) ~clone:(fun () -> make (ref !lr) (ref !count) ) in make (ref l) (ref (-1)) let of_enum e = let h = Acc.dummy () in let _ = BatEnum.fold Acc.accum h e in h.tl let backwards l = enum (rev l) (*TODO: should we make it more efficient?*) (*let backwards l = (*This version only needs one pass but is actually less lazy*) let rec aux acc = function | [] -> acc | h::t -> aux BatEnum.append (BatEnum.singleton h) acc in aux l*) let of_backwards e = let rec aux acc = match BatEnum.get e with | Some h -> aux (h::acc) | None -> acc in aux [] let assoc_inv e l = let rec aux = function | [] -> raise Not_found | (a,b)::_ when b = e -> a | _::t -> aux t in aux l let assq_inv e l = let rec aux = function | [] -> raise Not_found | (a,b)::_ when b == e -> a | _::t -> aux t in aux l let modify_opt a f l = let rec aux p = function | [] -> (match f None with | None -> raise Exit | Some v -> rev ((a,v)::p)) | (a',b)::t when a' = a -> (match f (Some b) with | None -> rev_append p t | Some b' -> rev_append ((a,b')::p) t) | p'::t -> aux (p'::p) t in try aux [] l with Exit -> l (*$= modify_opt & ~printer:(IO.to_string (List.print (fun fmt (a,b) -> Printf.fprintf fmt "%d,%d" a b))) (* to modify a value *) \ (modify_opt 5 (function Some 1 -> Some 2 | _ -> assert false) [ 1,0 ; 5,1 ; 8,2 ]) \ [ 1,0 ; 5,2 ; 8,2 ] (* to add a value *) \ (modify_opt 5 (function None -> Some 2 | _ -> assert false) [ 1,0 ; 8,2 ]) \ [ 1,0 ; 8,2 ; 5,2 ] (* to remove a value *) \ (modify_opt 5 (function Some 1 -> None | _ -> assert false) [ 1,0 ; 5,1 ; 8,2 ]) \ [ 1,0 ; 8,2 ] *) let modify a f l = let f' = function | None -> raise Not_found | Some b -> Some (f b) in modify_opt a f' l (*$= modify & ~printer:(IO.to_string (List.print (fun fmt (a,b) -> Printf.fprintf fmt "%d,%d" a b))) (modify 5 succ [ 1,0 ; 5,1 ; 8,2 ]) [ 1,0 ; 5,2 ; 8,2 ] *) (*$T modify try ignore (modify 5 succ [ 1,0 ; 8,2 ]); false with Not_found -> true *) let modify_def dfl a f l = let f' = function | None -> Some (f dfl) | Some b -> Some (f b) in modify_opt a f' l (*$= modify_def & ~printer:(IO.to_string (List.print (fun fmt (a,b) -> Printf.fprintf fmt "%d,%d" a b))) (modify_def 0 5 succ [ 1,0 ; 5,1 ; 8,2 ]) [ 1,0 ; 5,2 ; 8,2 ] (modify_def 0 5 succ [ 1,0 ; 8,2 ]) [ 1,0 ; 8,2 ; 5,1 ] *) let modify_opt_at n f l = if n < 0 then invalid_arg at_negative_index_msg; let rec loop acc n = function | [] -> invalid_arg at_after_end_msg | h :: t -> if n <> 0 then loop (h :: acc) (n - 1) t else match f h with | None -> rev_append acc t | Some v -> rev_append acc (v :: t) in loop [] n l (*$T modify_opt_at modify_opt_at 2 (fun n -> Some (n*n)) [1;2;3;4;5] = [1;2;9;4;5] modify_opt_at 2 (fun _ -> None) [1;2;3;4;5] = [1;2;4;5] try ignore (modify_opt_at 0 (fun _ -> None) []); false \ with Invalid_argument _ -> true try ignore (modify_opt_at 2 (fun _ -> None) []); false \ with Invalid_argument _ -> true try ignore (modify_opt_at (-1) (fun _ -> None) [1;2;3]); false \ with Invalid_argument _ -> true try ignore (modify_opt_at 5 (fun _ -> None) [1;2;3]); false \ with Invalid_argument _ -> true try ignore (modify_opt_at 3 (fun _ -> None) [1;2;3]); false \ with Invalid_argument _ -> true *) let modify_at n f l = modify_opt_at n (fun x -> Some (f x)) l (*$T modify_at modify_at 2 ((+) 1) [1;2;3;4] = [1;2;4;4] try ignore (modify_at 0 ((+) 1) []); false \ with Invalid_argument _ -> true try ignore (modify_at 2 ((+) 1) []); false \ with Invalid_argument _ -> true try ignore (modify_at (-1) ((+) 1) [1;2;3]); false \ with Invalid_argument _ -> true try ignore (modify_at 5 ((+) 1) [1;2;3]); false \ with Invalid_argument _ -> true try ignore (modify_at 3 ((+) 1) [1;2;3]); false \ with Invalid_argument _ -> true *) let sort_unique cmp lst = let sorted = List.sort cmp lst in let fold first rest = List.fold_left (fun (acc, last) elem -> if (cmp last elem) = 0 then (acc, elem) else (elem::acc, elem) ) ([first], first) rest in match sorted with | [] -> [] | hd::tl -> begin let rev_result, _ = fold hd tl in List.rev rev_result end ##V<4.2##let sort_uniq = sort_unique ##V>=4.2##let sort_uniq = List.sort_uniq let group cmp lst = let sorted = List.sort cmp lst in let fold first rest = List.fold_left (fun (acc, agr, last) elem -> if (cmp last elem) = 0 then (acc, elem::agr, elem) else (agr::acc, [elem], elem) ) ([], [first], first) rest in match sorted with | [] -> [] | hd::tl -> begin let groups, lastgr, _ = fold hd tl in List.rev_map List.rev (lastgr::groups) end (*$T group group Pervasives.compare [] = [] group Pervasives.compare [1] = [[1]] group Pervasives.compare [2; 2] = [[2; 2]] group Pervasives.compare [5; 4; 4; 2; 1; 6] = [[1]; [2]; [4; 4]; [5]; [6]] *) let cartesian_product l1 l2 = List.concat (List.map (fun i -> List.map (fun j -> (i,j)) l2) l1) (*$T cartesian_product as cp cp [1;2;3] ['x';'y'] = [1,'x';1,'y';2,'x';2,'y';3,'x';3,'y'] *) let rec n_cartesian_product = function | [] -> [[]] | h :: t -> let rest = n_cartesian_product t in List.concat (List.map (fun i -> List.map (fun r -> i :: r) rest) h) (*$T n_cartesian_product as ncp ncp [] = [[]] ncp [[]] = [] ncp [[1]; [2]; [3]] = [[1;2;3]] ncp [[1;2;3]] = [[1]; [2]; [3]] ncp [[1;2;3]; []] = [] ncp [[1;2;3]; [4;5]] = [[1;4]; [1;5]; [2;4]; [2;5]; [3;4]; [3;5]] *) let print ?(first="[") ?(last="]") ?(sep="; ") print_a out = function | [] -> BatInnerIO.nwrite out first; BatInnerIO.nwrite out last | [h] -> BatInnerIO.nwrite out first; print_a out h; BatInnerIO.nwrite out last | h::t -> BatInnerIO.nwrite out first; print_a out h; iter (fun x -> BatInnerIO.nwrite out sep; print_a out x) t; BatInnerIO.nwrite out last let t_printer a_printer _paren out x = print (a_printer false) out x let reduce f = function | [] -> invalid_arg "List.reduce: Empty List" | h :: t -> fold_left f h t let min ?cmp:(cmp = Pervasives.compare) l = let min = BatOrd.min_comp cmp in reduce min l let max ?cmp:(cmp = Pervasives.compare) l = let max = BatOrd.max_comp cmp in reduce max l let sum l = fold_left (+) 0 l (*$= sum & ~printer:string_of_int 2 (sum [1;1]) 0 (sum []) *) let fsum l = match l with | [] -> 0. | x::xs -> let acc = ref x in let rem = ref xs in let go = ref true in while !go do match !rem with | [] -> go := false; | x::xs -> acc := !acc +. x; rem := xs done; !acc (*$= fsum & ~printer:string_of_float 0. (fsum []) 6. (fsum [1.;2.;3.]) *) let favg l = match l with | [] -> invalid_arg "List.favg: Empty List" | x::xs -> let acc = ref x in let len = ref 1 in let rem = ref xs in let go = ref true in while !go do match !rem with | [] -> go := false; | x::xs -> acc := !acc +. x; incr len; rem := xs done; !acc /. float_of_int !len (*$T favg try let _ = favg [] in false with Invalid_argument _ -> true favg [1.;2.;3.] = 2. *) let kahan_sum li = (* This algorithm is written in a particularly untasteful imperative style to benefit from the nice unboxing of float references that is harder to obtain with recursive functions today. See the definition of kahan sum on arrays, on which this one is directly modeled. *) let li = ref li in let continue = ref (!li <> []) in let sum = ref 0. in let err = ref 0. in while !continue do match !li with | [] -> continue := false | x::xs -> li := xs; let x = x -. !err in let new_sum = !sum +. x in err := (new_sum -. !sum) -. x; sum := new_sum +. 0.; done; !sum +. 0. (*$T kahan_sum kahan_sum [ ] = 0. kahan_sum [ 1.; 2. ] = 3. let n, x = 1_000, 1.1 in \ Float.approx_equal (float n *. x) \ (kahan_sum (List.make n x)) *) let min_max ?cmp:(cmp = Pervasives.compare) = function | [] -> invalid_arg "List.min_max: Empty List" | x :: xs -> fold_left (fun (curr_min, curr_max) y -> let new_min = if cmp curr_min y = 1 then y else curr_min in let new_max = if cmp curr_max y = -1 then y else curr_max in (new_min, new_max) ) (x, x) xs (*$T min_max min_max [1] = (1, 1) min_max [1; 1] = (1, 1) min_max [1; -2; 3; 4; 5; 60; 7; 8] = (-2, 60) *) let unfold b f = let acc = Acc.dummy () in let rec loop dst v = match f v with | None -> acc.tl | Some (a, v) -> loop (Acc.accum dst a) v in loop acc b (*$T unfold unfold 1 (fun x -> None) = [] unfold 0 (fun x -> if x > 3 then None else Some (x, succ x)) = [0;1;2;3] *) let subset cmp l l' = for_all (fun x -> mem_cmp cmp x l') l (*$T subset subset Pervasives.compare [1;2;3;4] [1;2;3] = false subset Pervasives.compare [1;2;3] [1;2;3] = true subset Pervasives.compare [3;2;1] [1;2;3] = true subset Pervasives.compare [1;2] [1;2;3] = true *) let shuffle ?state l = let arr = Array.of_list l in BatInnerShuffle.array_shuffle ?state arr; Array.to_list arr (*$T shuffle let s = Random.State.make [|11|] in \ shuffle ~state:s [1;2;3;4;5;6;7;8;9] = [7; 2; 9; 5; 3; 6; 4; 1; 8] shuffle [] = [] *) module Exceptionless = struct let rfind p l = try Some (rfind p l) with Not_found -> None let find p l = try Some (find p l) with Not_found -> None let findi p l = try Some (findi p l) with Not_found -> None let split_at n l = try `Ok (split_at n l) with Invalid_argument s -> `Invalid_argument s let at n l = try `Ok (at n l) with Invalid_argument s -> `Invalid_argument s let assoc e l = try Some (assoc e l) with Not_found -> None let assq e l = try Some (assq e l) with Not_found -> None let assoc_inv e l = try Some (assoc_inv e l) with Not_found -> None let find_map f l = try Some(find_map f l) with Not_found -> None let hd l = try Some (hd l) with Failure _ -> None let tl l = try Some (tl l) with Failure _ -> None let rec last = function | [] -> None | [x] -> Some x | _ :: l -> last l let reduce f = function | [] -> None | h :: t -> Some (fold_left f h t) let min_max ?cmp:(cmp = Pervasives.compare) l = try Some (min_max ~cmp l) with Invalid_argument _ -> None let min ?cmp:(cmp = Pervasives.compare) l = try Some (min ~cmp l) with Invalid_argument _ -> None let max ?cmp:(cmp = Pervasives.compare) l = try Some (max ~cmp l) with Invalid_argument _ -> None end module Labels = struct let init i ~f = init i f let make n x = make n x let iteri ~f l = iteri f l let map ~f l = map f l let mapi ~f l = mapi f l let rfind ~f l = rfind f l let find ~f l = find f l let findi ~f = findi f let find_exn ~f = find_exn f ##V>=4.10##let find_map_opt ~f = find_map_opt f let filter_map ~f = filter_map f let remove_if ~f = remove_if f let take_while ~f = take_while f let drop_while ~f = drop_while f let map2 ~f = map2 f let iter2 ~f = iter2 f let exists2 ~f = exists2 f let fold_left ~f ~init = fold_left f init let fold = fold_left let fold_right ~f l ~init = fold_right f l init let fold_left2 ~f ~init = fold_left2 f init let fold_right2 ~f l1 l2 ~init = fold_right2 f l1 l2 init let filter ~f = filter f let count_matching ~f = count_matching f ##V>=4.10##let concat_map ~f = List.concat_map f let find_all ~f = find_all f let partition ~f = partition f let partition_map ~f = partition_map f let rev_map ~f = rev_map f let rev_map2 ~f = rev_map2 f let iter ~f = iter f let for_all ~f = for_all f let for_all2 ~f = for_all2 f let exists ~f = exists f let subset ~cmp = subset cmp let stable_sort ?(cmp=compare) = stable_sort cmp let fast_sort ?(cmp=compare) = fast_sort cmp let sort ?(cmp=compare) = sort cmp let merge ?(cmp=compare) = merge cmp module LExceptionless = struct include Exceptionless let rfind ~f l = rfind f l let find ~f l = find f l let findi ~f l = findi f l end end let ( @ ) = List.append module Infix = struct let ( @ ) = ( @ ) end open BatOrd let rec eq eq_elt l1 l2 = match l1 with | [] -> (match l2 with [] -> true | _ -> false) | hd1::tl1 -> (match l2 with | [] -> false | hd2::tl2 -> bin_eq eq_elt hd1 hd2 (eq eq_elt) tl1 tl2) let rec ord ord_elt l1 l2 = match l1 with | [] -> (match l2 with [] -> Eq | _::_ -> Lt) | hd1::tl1 -> (match l2 with | [] -> Gt | hd2::tl2 -> bin_ord ord_elt hd1 hd2 (ord ord_elt) tl1 tl2) let rec compare comp_elt l1 l2 = match l1 with | [] -> (match l2 with [] -> 0 | _::_ -> -1) | hd1::tl1 -> (match l2 with | [] -> 1 | hd2::tl2 -> bin_comp comp_elt hd1 hd2 (compare comp_elt) tl1 tl2) module Eq (T : Eq) = struct type t = T.t list let eq = eq T.eq end module Ord (T : Ord) = struct type t = T.t list let ord = ord T.ord end module Comp (T : Comp) = struct type t = T.t list let compare = compare T.compare end batteries-included-3.4.0/src/batLog.ml000066400000000000000000000133101415601150500176120ustar00rootroot00000000000000(* * BatLog - Simple Logging module * Copyright (C) 2011 The Batteries Included Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open BatInnerIO (** Flags enable features in logging *) type flag = [ | `Date (** Print the current date as 2011/0628 *) | `Time (** Print the current time as 01:23:45 *) | `Filepos (** Print the file and position of this log command (UNIMPLEMENTED) *) | `Custom of unit -> string (** Print a generated string *) ] let output = ref stderr let prefix = ref "" let flags = ref [`Date; `Time] let print_flag ?fp t oc = function | `Date -> let {Unix.tm_year=y; tm_mon=m; tm_mday=d; _} = Lazy.force t in BatPrintf.fprintf oc "%4d/%02d/%02d" (y + 1900) (m + 1) d | `Time -> let {Unix.tm_hour=h; tm_min=m; tm_sec=s; _} = Lazy.force t in BatPrintf.fprintf oc "%2d:%02d:%02d" h m s | `Filepos -> BatOption.may (nwrite oc) fp | `Custom gen -> nwrite oc (gen ()) let write_flags ?fp oc fs = if fs <> [] then (* is it better to call time in print_flag? *) let t = lazy (Unix.localtime (Unix.time ())) in BatList.print ~first:"" ~sep:" " ~last:":" (print_flag ?fp t) oc fs (* BatPrintf.fprintf !output "%a%s%s\n" (write_flags ?fp) !flags !prefix s *) let log ?fp s = let oc = !output in (* makes sure all output goes to a single channel when multi-threaded *) write_flags ?fp oc !flags; nwrite oc !prefix; nwrite oc s; write oc '\n' (* BatPrintf.fprintf !output ("%a%s" ^^ fmt ^^"\n") (write_flags ?fp) !flags !prefix *) let logf ?fp fmt = let oc = !output in write_flags ?fp oc !flags; nwrite oc !prefix; BatPrintf.fprintf oc fmt (* BatPrintf.kfprintf (fun _ -> exit 1) !output "%a%s%s\n" (write_flags ?fp) !flags !prefix s *) let fatal ?fp s = let oc = !output in write_flags ?fp oc !flags; nwrite oc !prefix; nwrite oc s; write oc '\n'; exit 1 let fatalf ?fp fmt = BatPrintf.kfprintf (fun _ -> exit 1) !output ("%a%s" ^^ fmt ^^ "%!") (write_flags ?fp) !flags !prefix module type Config = sig type t val out: t output val prefix: string val flags: flag list end module Make (S:Config) = struct let log ?fp s = write_flags ?fp S.out S.flags; nwrite S.out S.prefix; nwrite S.out s; write S.out '\n' let logf ?fp fmt = write_flags ?fp S.out S.flags; nwrite S.out S.prefix; BatPrintf.fprintf S.out (fmt ^^ "\n") let fatal ?fp s = write_flags ?fp S.out S.flags; nwrite S.out S.prefix; nwrite S.out s; write S.out '\n'; exit 1 let fatalf ?fp fmt = BatPrintf.kfprintf (fun _ -> exit 1) S.out ("%a%s" ^^ fmt ^^ "\n%!") (write_flags ?fp) S.flags S.prefix end let make_logger out prefix flags = object method log ?fp s = write_flags ?fp out flags; nwrite out prefix; nwrite out s; write out '\n' method logf ?fp fmt = write_flags ?fp out flags; nwrite out prefix; BatPrintf.fprintf out (fmt ^^ "\n") method fatal ?fp s = write_flags ?fp out flags; nwrite out prefix; nwrite out s; write out '\n'; exit 1 method fatalf ?fp fmt = BatPrintf.kfprintf (fun _ -> exit 1) out ("%a%s" ^^ fmt ^^ "%!") (write_flags ?fp) flags prefix end (*$= make_logger & ~printer:identity "abcLog1\nabc34\n" \ (let oc = IO.output_string () in \ let l = make_logger oc "abc" [] in \ l#log "Log1"; l#logf "%d" 34; \ IO.close_out oc) *) module type Level_sig = sig type t val to_string : t -> string val default_level : t val compare : t -> t -> int end module Make_lev(L : Level_sig)(S: Config) = struct (* These are threadsafe to get/set, so no setter/getter needed; publicly accessible *) let level = ref L.default_level let output = ref S.out (** Main logging function *) let log ?fp l m = if L.compare l !level >= 0 then let oc = !output in write_flags ?fp oc S.flags; nwrite oc S.prefix; nwrite oc (L.to_string l); nwrite oc ": "; nwrite oc m; write oc '\n' let logf ?fp l fmt = (* printf-style logging *) if L.compare l !level >= 0 then let oc = !output in write_flags ?fp oc S.flags; nwrite oc S.prefix; nwrite oc (L.to_string l); nwrite oc ": "; BatPrintf.fprintf oc (fmt ^^ "\n") else Printf.ifprintf !output fmt end type easy_lev = [ `trace | `debug | `info | `warn | `error | `fatal | `always ] module Basic = struct type t = easy_lev let to_string : (t -> string) = function | `trace -> "TRACE" | `debug -> "DEBUG" | `info -> "INFO" | `warn -> "WARN" | `error -> "ERROR" | `fatal -> "FATAL" | `always -> "ALWAYS" let to_int : (t -> int) = function | `trace -> 0 | `debug -> 1 | `info -> 2 | `warn -> 3 | `error -> 4 | `fatal -> 5 | `always -> 6 let default_level = `always let compare a b = BatInt.compare (to_int a) (to_int b) end module Default_config = struct type t = unit let out = stderr let prefix = "" let flags = [`Date; `Time] end module Easy = Make_lev(Basic)(Default_config) batteries-included-3.4.0/src/batLog.mli000066400000000000000000000142101415601150500177630ustar00rootroot00000000000000(* * BatLog - Simple Logging module * Copyright (C) 2011 The Batteries Included Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Simple logging @author Edgar Friendly *) open BatIO (** This ref holds the output channel for simple logging. Defaults to [stderr] @since 2.0; had getter and setter in 1.x *) val output : unit output ref (** This ref holds the text printed before each log message. Defaults to the empty string. @since 2.0; had getter and setter in 1.x *) val prefix : string ref type flag = [ | `Date (** Print the current date as 2011-06-28 *) | `Time (** Print the current time as 01:23:45 *) | `Filepos (** Print the file and linenum of this log command (UNIMPLEMENTED - needs syntax extension) *) | `Custom of unit -> string (** Print the results of running the given closure *) ] (** This ref holds the output flags. These flags control how the log messages are output. The default is [`Date; `Time] and log messages are printed as: 2011/0628 01:23:45: prefixmessage @since 2.0; had getter and setter in 1.x *) val flags : flag list ref (** [log s] logs the message s, returning unit. @since 2.0; was [print] in 1.x *) val log : ?fp:string -> string -> unit (** As [Printf.printf], only the message is printed to the logging output and prefixed with status information per the current flags and the currently set prefix. @since 2.0; was [printf] in 1.x *) val logf: ?fp:string -> ('a, unit output, unit) Pervasives.format -> 'a (** [fatal s] logs the message [s] and then calls [exit 1]. This exits the program with return code 1. *) val fatal : ?fp:string -> string -> 'a (** [fatalf] allows a format string (as [Printf.printf])and the arguments to that format string to build the logging message. Exits the program with return code 1. *) val fatalf: ?fp:string -> ('a, unit output, unit) Pervasives.format -> 'a module type Config = sig type t val out: t output val prefix: string val flags: flag list end (** Build a logger module with custom, fixed output, prefix and flags *) module Make (S:Config) : sig (** [print s] logs the message s, returning unit. *) val log : ?fp:string -> string -> unit (** As [Printf.printf], only the message is printed to the logging output and prefixed with status information per the current flags and the currently set prefix. *) val logf: ?fp:string -> ('a, S.t output, unit) Pervasives.format -> 'a (** [fatal s] logs the message [s] and then calls [exit 1]. This exits the program with return code 1. *) val fatal : ?fp:string -> string -> 'a (** [fatalf] allows a format string (as [Printf.printf])and the arguments to that format string to build the logging message. Exits the program with return code 1. *) val fatalf: ?fp:string -> ('a, S.t output, unit) Pervasives.format -> 'a end (** Returns an object with methods [fatal], [fatalf], [log], and [logf] that logs to the given output channel, with given prefix and flags. These methods work like the corresponding functions in the BatLog module. @since 2.0 *) val make_logger : 'a output -> string -> [< `Custom of unit -> string | `Date | `Filepos | `Time ] list -> < fatal : ?fp:string -> string -> 'b; fatalf : ?fp:string -> ('c, 'a output, unit, unit, unit, 'd) format6 -> 'c; log : ?fp:string -> string -> unit; logf : ?fp:string -> ('e, 'a output, unit) format -> 'e > (** The different verbosity levels supported in the [Easy] logger *) type easy_lev = [ `trace | `debug | `info | `warn | `error | `fatal | `always ] (** A simple-to-use logger with verbosity levels that outputs by default to stderr (changeable at runtime) with the date and time at the beginning of each log message. @since 2.0 *) module Easy : sig (** Set this ref to the lowest level of log you want logged. For example, [Easy.level := `always] disables all logging except that at the [`always] level. Setting [Easy.level := `info] will enable logging for [`info], [`warn], [`error], [`fatal] and [`always] levels. *) val level : easy_lev ref (** Set this ref to the output you want logging messages to go to. Defaults to [stderr]. *) val output : unit output ref (** [log lev msg] logs the message [msg] if the current logging level is [lev] or lower. *) val log : ?fp:string -> easy_lev -> string -> unit (** As [log], but instead of a string message, a printf format is allowed with whatever arguments are appropriate. *) val logf : ?fp:string -> easy_lev -> ('a, unit output, unit) format -> 'a end (** The details of a level scheme for verbosity-level loggers *) module type Level_sig = sig (** A type for level values, usually a polymorphic variant *) type t (** Convert each level to a string *) val to_string : t -> string (** The default level for loggers created with this; log messages with level less than this won't be printed by default. *) val default_level : t (** a comparison function between levels, to know whether logging at a particular level should be printed *) val compare : t -> t -> int end (** Make your own level-based logger, like [Easy] *) module Make_lev(L:Level_sig)(S:Config) : sig val level : L.t ref val output : S.t output ref val log : ?fp:string -> L.t -> string -> unit val logf : ?fp:string -> L.t -> ('a, S.t output, unit) format -> 'a end batteries-included-3.4.0/src/batLogger.ml000066400000000000000000000163001415601150500203120ustar00rootroot00000000000000(* -*- Mode: Caml; indent-tabs-mode: nil -*- *) (******************************************************************************) (* Copyright (c) 2009, Metaweb Technologies, Inc. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) open BatPrintf type log = { name : string; mutable level : int; } type level = NONE | FATAL | ERROR | WARN | NOTICE | INFO | DEBUG type event = string * (string * string) list type formatter = log -> level -> event -> float -> unit (******************************************************************************) (** log utilities *) let int_of_level = function | NONE -> 0 | FATAL -> 1 | ERROR -> 2 | WARN -> 3 | NOTICE -> 4 | INFO -> 5 | DEBUG -> 6 let level_of_int = function | 0 -> NONE | 1 -> FATAL | 2 -> ERROR | 3 -> WARN | 4 -> NOTICE | 5 -> INFO | 6 -> DEBUG | i -> failwith ("invalid level: " ^ string_of_int i) let name_of_level = function | NONE -> "NONE" | FATAL -> "FATAL" | ERROR -> "ERROR" | WARN -> "WARN" | NOTICE -> "NOTICE" | INFO -> "INFO" | DEBUG -> "DEBUG" let level_of_name = function | "NONE" -> NONE | "FATAL" -> FATAL | "ERROR" -> ERROR | "WARN" -> WARN | "NOTICE" -> NOTICE | "INFO" -> INFO | "DEBUG" -> DEBUG | n -> failwith ("invalid level: " ^ n) let format_timestamp out ts = let tm = Unix.gmtime ts in let us, _ = modf ts in fprintf out "%04d-%02d-%02dT%02d:%02d:%02d.%06dZ" (1900 + tm.Unix.tm_year) (1 + tm.Unix.tm_mon) (tm.Unix.tm_mday) (tm.Unix.tm_hour) (tm.Unix.tm_min) (tm.Unix.tm_sec) (int_of_float (1_000_000. *. us)) (******************************************************************************) (** log modules *) let logs = Hashtbl.create 16 let default_level = ref (int_of_level INFO) let make_log name = try Hashtbl.find logs name with Not_found -> let lm = { name = name; level = !default_level } in Hashtbl.replace logs name lm; lm let log_enable lm lev = lm.level <- int_of_level lev let log_enabled lm lev = let lev_no = int_of_level lev in lev_no <= lm.level let log_name lm = lm.name let log_level lm = level_of_int lm.level (******************************************************************************) (** log formatters *) let depth = ref 0 let formatters : (string * formatter) list ref = ref [] let register_formatter name f = formatters := (name, f) :: !formatters let unregister_formatter name = formatters := List.remove_assoc name !formatters let rec format_kvl oc = function | [] -> () | (k, v)::rest -> fprintf oc "\t%s:%s" k v; format_kvl oc rest let make_std_formatter oc lm lev (event_name, event_args) timestamp = fprintf oc "D:%a\tE:%s.%s\tL:%s%a\n%!" (*D:*) format_timestamp timestamp (*E:*) lm.name event_name (*L:*) (name_of_level lev) format_kvl event_args let stderr_formatter = make_std_formatter BatIO.stderr let null_formatter _lm _lev _event _timestamp = () let format_indent oc depth = for _i = 0 to depth do fprintf oc "| " done let make_dbg_formatter oc lm lev (event_name, event_args) _timestamp = let indent = try int_of_string (List.assoc "I" event_args) with _ -> 0 in let args = List.remove_assoc "I" event_args in fprintf oc "### %a%s.%s %a [%s]\n%!" format_indent indent (log_name lm) event_name format_kvl args (name_of_level lev) let dbg_formatter lm lev ep ts = make_dbg_formatter BatIO.stderr lm lev ep ts (******************************************************************************) (** log events *) let log lm lev event_fun = if log_enabled lm lev then let time = Unix.gettimeofday () in let event_name, event_args = event_fun () in let event = event_name, ("I", string_of_int !depth) :: event_args in List.iter (fun (_name, fmt) -> fmt lm lev event time) !formatters let with_log lm lev event_fun ?result body = if log_enabled lm lev then begin try log lm lev event_fun; incr depth; let rv = body () in decr depth; log lm lev (fun () -> let event_name, event_args = event_fun () in let result_str = match result with | Some f -> f rv | None -> "-" in event_name, ("RESULT", result_str) ::event_args); rv with exn -> decr depth; log lm lev (fun () -> let event_name, event_args = event_fun () in event_name, ("EXN", Printexc.to_string exn) :: event_args); raise exn end else body () (******************************************************************************) (** logger initialization *) let init name_level_list formatter = List.iter (fun (name, level) -> let lm = make_log name in log_enable lm level) name_level_list; register_formatter "default" formatter let init_from_string name_level_string formatter = let init_key_value ss = try let name_ss, level_ss = BatSubstring.splitl (fun c -> c <> ':') ss in let name = BatSubstring.to_string name_ss in let level = level_of_name (BatSubstring.to_string level_ss) in let lm = make_log name in log_enable lm level with Not_found -> try let level = level_of_name (BatSubstring.to_string ss) in default_level := int_of_level level; Hashtbl.iter (fun _name lm -> log_enable lm level) logs with Failure _ -> failwith ("invalid log initialization: " ^ BatSubstring.to_string ss) in List.iter init_key_value (BatSubstring.split_on_comma (BatSubstring.of_string name_level_string) ); register_formatter "default" formatter (******************************************************************************) (* let test = let lm = make_log "test" in let direct () = log lm NOTICE (fun () -> "hello", []); log lm DEBUG (fun () -> "debug msg1", []); log lm ERROR (fun () -> "error msg1", []); log lm ERROR (fun () -> "ok", ["ARG1", string_of_int 234]); in let rec run () = direct (); Unix.sleep 3; run () in run () *) (******************************************************************************) batteries-included-3.4.0/src/batLogger.mli000066400000000000000000000230311415601150500204620ustar00rootroot00000000000000(* -*- Mode: Caml; indent-tabs-mode: nil -*- *) (******************************************************************************) (* Copyright (c) 2009, Metaweb Technologies, Inc. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) (** {1 Logging Library} This module defines functions which implement a flexible error logging system for applications. @author Warren Harris, Metaweb Technologies *) (******************************************************************************) (** {6 log modules} *) type log type level = NONE | FATAL | ERROR | WARN | NOTICE | INFO | DEBUG val make_log : string -> log (** [make_log name] returns a new logger. *) val log_name : log -> string (** [log_name logger] returns the name of the logger. *) val log_enable : log -> level -> unit (** [log_enable logger level] enables a log level for a logger. *) val log_level : log -> level (** [log_level logger] returns the currently enabled level for a logger. *) val log_enabled : log -> level -> bool (** [log_enabled logger level] returns true if the specified level is currently enabled for the logger. *) (******************************************************************************) (** {6 log events} *) type event = string * (string * string) list (** A log [event] consists of an event name and a list of key-value parameters (an association list). Events are constructed by [log] when a log level is enabled and passed to log formatters to render them to any logging output stream. *) val log : log -> level -> (unit -> event) -> unit (** [log logger level event_fun] raises a log event if if the specified level is currently enabled for the logger. The function [event_fun ()] is called to return the event record, and is a function in order to delay construction or formatting of any event parameters in the case where the specified log level is not enabled. For example: {[log io_log INFO (fun () -> "connect", ["ADDR", addr])]} would only log the ["connect"] event (with the ["ADDR"] string parameter) when the [INFO] log level was enabled for the [io_log] logger. *) val with_log : log -> level -> (unit -> event) -> ?result:('a -> string) -> (unit -> 'a) -> 'a (** [with_log logger level event_fun ?result body] logs an event before and after calling [body ()]. The function [event_fun ()] is called to return the event record to be logged. After the body is evaluated, the [result] function is used to convert the body's result value into a string, which is added to the event record as a ["RESULT"] parameter (if no [result] function is supplied then a ["-"] is used). In the case where the body raises an exception, an ["EXN"] parameter is instead added to the event containing the name of the exception. In addition, an indentation level is maintained throughout the duration of the body such that any other log statements occurring inside the body will see an incremented indentation level. This is added to the event key-value arguments as an additional ["I"] parameter. *) (******************************************************************************) (** {6 log formatters} *) type formatter = log -> level -> event -> float -> unit (** the type of a log formatter is a function that takes the logger, the level of the log statement (which will be the currently enabled level or one of its successors), the event record, and a unix timestamp indicating the time the event was created. *) val register_formatter : string -> formatter -> unit (** [register_formatter name formatter] registers a named log formatter. The name is only used for subsequent calls to identify the formatter via [unregister_formatter]. *) val unregister_formatter : string -> unit (** [unregister_formatter name] unregisters a named log formatter. *) val make_std_formatter : 'a BatIO.output -> formatter (** [make_std_formatter oc] constructs a formatter from an output channel. This formatter will format log events as tab-separated [:] pairs. The resulting formatter must be registered via [register_formatter] to be used when events are raised. This formatter also always outputs special parameters that describe the event timestamp (an ISO-8610 timestamp prefixed by ["D"]), the event name (the log module name followed by a dot, followed by the event name, prefixed by ["E"]), the log level (prefixed by ["L"]), the indentation level ( prefixed by ["I"]), followed by any other event parameters. For example, the log statement: {[log io_log INFO (fun () -> "connect", ["ADDR", addr])]} would produce formatted output like the following when the [io_log] [INFO] level was enabled: {[D:2009-01-26T00:47:45.033329Z E:io.connect L:INFO I:1 ADDR:localhost:8080]} *) val stderr_formatter : formatter (** [stderr_formatter] is a standard formatter that outputs log events to stderr using the same format as [make_std_formatter]. The resulting formatter must be registered via [register_formatter] or supplied to [init] or [init_from_string] to be used when events are raised. *) val null_formatter : formatter (** [null_formatter] is a formatter that does not output any events, but simply discards them. *) val make_dbg_formatter : 'a BatIO.output -> formatter (** [make_dbg_formatter oc] constructs a debug formatter from an output channel. The debug formatter outputs simplified format that is easier to read for debugging purposes and displays indentation level. E.g.: {[ with_log io_log DEBUG (fun () -> "listener" ["ADDR", addr]) accept_connections (* calls other log statements *) ]} would produce formatted output like the following when the [io_log] [DEBUG] level was enabled: {[ ### io.listener ADDR:localhost:8080 [DEBUG] ### | io.connected CLIENT_ADDR:192.168.0.23:28303 [DEBUG] ### | io.disconnected CLIENT_ADDR:192.168.0.23:28303 [DEBUG] ... ### io.listener ADDR:localhost:8080 RESULT:- [DEBUG] ]} *) val dbg_formatter : formatter (** [dbg_formatter] is a debug formatter that outputs log events to stderr using the same format as [make_dbg_formatter]. The resulting formatter must be registered via [register_formatter] or supplied to [init] or [init_from_string] to be used when events are raised. *) (******************************************************************************) (** {6 logger initialization} *) val init : (string * level) list -> formatter -> unit (** [init name_level_list formatter] initializes the logging system enabling the specified levels for each named logger. The formatter is the initial formatter for any log events that are output and is registered with the name "default" (other formatters may be registered by [register_formatter]). *) val init_from_string : string -> formatter -> unit (** [init_from_string name_level_string formatter] initializes the logging system enabling the specified levels for each named logger. The string must be a comma separated list of [:] pairs, e.g. ["FOO:ERROR,BAR:WARN"]. If a un-prefixed level name is specified, then that becomes the default log level for all newly created logs, and all currently created logs are enabled to that level. If the logger does not yet exist, it is created. The formatter is the initial formatter for any log events that are output and is registered with the name "default" (other formatters may be registered by [register_formatter]). *) (******************************************************************************) (** {6 log utilities} *) val level_of_name : string -> level (** [level_of_name str] returns the [level] associated with [str]. *) val name_of_level : level -> string (** [name_of_level level] returns the name of the specified [level]. *) val format_timestamp : 'a BatIO.output -> float -> unit (** [format_timestamp oc timestamp] prints an ISO-8601 formatted timestamp (extended to specify higher-resolution seconds) to the output channel, [oc]. *) (******************************************************************************) batteries-included-3.4.0/src/batMap.mliv000066400000000000000000001554271415601150500201650ustar00rootroot00000000000000(* * BatMap - Additional map operations * Copyright (C) 1996 Xavier Leroy * 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Association tables over ordered types. This module implements applicative association tables, also known as finite maps or dictionaries, given a total ordering function over the keys. All operations over maps are purely applicative (no side-effects). The implementation uses balanced binary trees, and therefore searching and insertion take time logarithmic in the size of the map. {b Note} OCaml, Batteries Included, provides two implementations of maps: polymorphic maps and functorized maps. Functorized maps (see {!S} and {!Make}) are slightly more complex to use but offer stronger type-safety. Polymorphic maps make it easier to shoot yourself in the foot. In case of doubt, you should use functorized maps. {4 Functorized maps} The important part is the {!Make} module which builds association maps from a user-provided datatype and comparison function. In the {!Make} module (or its output signature {!S}) are documentated all functions available on maps. Here is a typical example of use: {[ module MyKeyType = struct type t = my_type let compare = my_compare_function end module MyMap = Map.Make(MyKeyType) let some_map = MyMap.add something MyMap.empty ... ]} To define maps with integer/string keys: {[ module IntMap = Map.Make(Int) module StringMap = Map.Make(String) ]} @author Xavier Leroy (Base library) @author Nicolas Cannasse @author Markus Mottl @author David Rajchenbach-Teller @author Gabriel Scherer *) module type S = sig type key (** The type of the map keys. *) type + ##V>=4.12## ! 'a t (** The type of maps from type [key] to type ['a]. *) val empty: 'a t (** The empty map. *) val is_empty: 'a t -> bool (** Test whether a map is empty or not. *) val cardinal: 'a t -> int (** Return the number of bindings of a map. *) val add: key -> 'a -> 'a t -> 'a t (** [add x y m] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already bound in [m], its previous binding disappears. If [x] was already bound to some [z] that is physically equal to [y], then the returned map is physically equal to [m]. @before 3.3.0 physical equality was not ensured. *) val update_stdlib : key -> ('a option -> 'a option) -> 'a t -> 'a t (** [update_stdlib k f m] returns a map containing the same bindings as [m], except [k] has a new binding as determined by [f]: First, calculate [y] as [f (find_opt k m)]. If [y = Some v] then [k] will be bound to [v] in the resulting map. Else [k] will not be bound in the resulting map. If [v] is physically equal to the value of the previous binding of [k] in [m], then the returned map will be physically equal to [m]. This function does the same thing as [update] in the stdlib, but has a different name for backwards compatibility reasons. @since 3.3.0 *) (* TODO: maybe deprecate this function to re-gain compatibility with stdlib? *) val update: key -> key -> 'a -> 'a t -> 'a t (** [update k1 k2 v2 m] replace the previous binding of [k1] in [m] by [k2] associated to [v2]. This is equivalent to [add k2 v2 (remove k1) m], but more efficient in the case where [k1] and [k2] have the same key ordering. If [k1] and [k2] have the same key ordering and [v2] is physically equal to the value [k1] is bound to in [m] then the returned map will be physically equal to [m] @raise Not_found if [k1] is not bound in [m]. @since 2.4.0 @before 3.3.0 physical equality was not ensured. *) val find: key -> 'a t -> 'a (** [find x m] returns the current binding of [x] in [m], or raises [Not_found] if no such binding exists. *) val find_opt: key -> 'a t -> 'a option (** [find_opt x m] returns Some b where b is the current binding * of [x] in [m], or None if no such binding exists. *) val find_default: 'a -> key -> 'a t -> 'a (** [find_default d x m] returns the current binding of [x] in [m], or the default value [d] if no such binding exists. *) val find_first: (key -> bool) -> 'a t -> key * 'a (** [find_first f m] returns the first binding [(k, v)] for which [f k] is true or raises [Not_found] if there is no such binding. [f] must be monotonically increasing, i.e. if [k1 < k2 && f k1] is true then [f k2] must also be true. @since 3.3.0 *) val find_first_opt: (key -> bool) -> 'a t -> (key * 'a) option (** [find_first_opt f m] returns [Some (k, v)] for the first binding [(k, v)] for which [f k] is true or returns [None] if there is no such binding. [f] must be monotonically increasing, i.e. if [k1 < k2 && f k1] is true then [f k2] must also be true. @since 3.3.0 *) val find_last: (key -> bool) -> 'a t -> key * 'a (** [find_last f m] returns the last binding [(k, v)] for which [f k] is true or raises [Not_found] if there is no such binding. [f] must be monotonically decreasing, i.e. if [k1 < k2 && f k2] is true then [f k1] must also be true. @since 3.3.0*) val find_last_opt: (key -> bool) -> 'a t -> (key * 'a) option (** [find_last_opt f m] returns [Some (k, v)] for the last binding [(k, v)] for which [f k] is true or returns [None] if there is no such binding. [f] must be monotonically decreasing, i.e. if [k1 < k2 && f k2] is true then [f k1] must also be true. @since 3.3.0 *) val remove: key -> 'a t -> 'a t (** [remove x m] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map. The returned map is physically equal to the passed one if [x] was already unbound. @before 3.3.0 physical equality was not ensured *) val remove_exn: key -> 'a t -> 'a t (** [remove_exn x m] behaves like [remove x m] except that it raises an exception if [x] is unbound in [m]. @raise Not_found if [x] is unbound in [m] @since 3.2.0 *) val modify: key -> ('a -> 'a) -> 'a t -> 'a t (** [modify k f m] replaces the previous binding for [k] with [f] applied to that value. If [k] is unbound in [m] or [Not_found] is raised during the search, [Not_found] is raised. @since 1.2.0 @raise Not_found if [k] is unbound in [m] (or [f] raises [Not_found]) *) val modify_def: 'a -> key -> ('a -> 'a) -> 'a t -> 'a t (** [modify_def v0 k f m] replaces the previous binding for [k] with [f] applied to that value. If [k] is unbound in [m] or [Not_found] is raised during the search, [f v0] is inserted (as if the value found were [v0]). @since 1.3.0 *) val modify_opt: key -> ('a option -> 'a option) -> 'a t -> 'a t (** [modify_opt k f m] allows to modify the binding for [k] in [m] or absence thereof. @since 2.1 *) val extract : key -> 'a t -> 'a * 'a t (** [extract k m] removes the current binding of [k] from [m], returning the value [k] was bound to and the updated [m]. @raise Not_found if [k] is unbound in [m] @since 1.4.0 *) val pop : 'a t -> (key * 'a) * 'a t (** [pop m] returns a binding from [m] and [m] without that binding. @raise Not_found if [m] is empty @since 1.4.0 *) val mem: key -> 'a t -> bool (** [mem x m] returns [true] if [m] contains a binding for [x], and [false] otherwise. *) val iter: (key -> 'a -> unit) -> 'a t -> unit (** [iter f m] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated value as second argument. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. Only current bindings are presented to [f]: bindings hidden by more recent bindings are not passed to [f]. *) val map: ('a -> 'b) -> 'a t -> 'b t (** [map f m] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been replaced by the result of the application of [f] to [a]. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. *) val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t (** Same as {!Map.S.map}, but the function receives as arguments both the key and the associated value for each binding of the map. *) val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** [fold f m a] computes [(f kN dN ... (f k1 d1 (f k0 d0 a))...)], where [k0,k1..kN] are the keys of all bindings in [m] (in increasing order), and [d1 ... dN] are the associated data. *) val filterv: ('a -> bool) -> 'a t -> 'a t (** [filterv f m] returns a map where only the values [a] of [m] such that [f a = true] remain. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. *) val filter: (key -> 'a -> bool) -> 'a t -> 'a t (** [filter f m] returns a map where only the [(key, value)] pairs of [m] such that [f key value = true] remain. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. If [f] returns [true] for all bindings of [m] the returned map is physically equal to [m]. @before 3.3.0 physical equality was not ensured. *) val filter_map: (key -> 'a -> 'b option) -> 'a t -> 'b t (** [filter_map f m] combines the features of [filter] and [map]. It calls calls [f key0 a0], [f key1 a1], [f keyn an] where [a0,a1..an] are the elements of [m] and [key0..keyn] the respective corresponding keys. It returns the map of pairs [(keyi, bi)] such as [f keyi ai = Some bi] (when [f] returns [None], the corresponding element of [m] is discarded). *) val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int (** Total ordering between maps. The first argument is a total ordering used to compare data associated with equal keys in the two maps. *) val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, that is, contain equal keys and associate them with equal data. [cmp] is the equality predicate used to compare the data associated with the keys. *) val keys : _ t -> key BatEnum.t (** Return an enumeration of all the keys of a map. The returned enumeration is sorted in increasing key order. *) val values: 'a t -> 'a BatEnum.t (** Return an enumeration of all the values of a map. The returned enumeration is sorted in increasing key order. *) val min_binding : 'a t -> (key * 'a) (** Return the [(key, value)] pair with the smallest key. @raise Not_found if the map is empty. *) val min_binding_opt : 'a t -> (key * 'a) option (** Return [Some (key, value)] for the [key, value] pair with the smallest key, or [None] if the map is empty. @since 3.3.0 *) val pop_min_binding : 'a t -> (key * 'a) * 'a t (** Return the [(key, value)] pair with the smallest key along with the rest of the map. *) val max_binding : 'a t -> (key * 'a) (** Return the [(key, value)] pair with the largest key. Raises Not_found if the map is empty. *) val max_binding_opt : 'a t -> (key * 'a) option (** Return [Some (key, value)] for the [key, value] pair with the largest key, or [None] if the map is empty. @since 3.3.0 *) val pop_max_binding : 'a t -> (key * 'a) * 'a t (** Return the ([key, value]) pair with the largest key along with the rest of the map. *) (* The following documentations comments are from stdlib's map.mli: - split - singleton - partition *) val choose : 'a t -> (key * 'a) (** Return one binding of the given map. Which binding is chosen is unspecified, but equal bindings will be chosen for equal maps. @raise Not_found if the map is empty *) val choose_opt : 'a t -> (key * 'a) option (** Return [Some (k, v)] for one binding [(k, v)] of the given map, if the map is not empty. Else, return None. Which binding is chosen is unspecified, but equal bindings will be chosen for equal maps. @since 3.3.0 *) val any : 'a t -> (key * 'a) (** Return one binding of the given map. The difference with choose is that there is no guarantee that equals elements will be picked for equal sets. This merely returns the quickest binding to get (O(1)). @raise Not_found if the map is empty. *) val split : key -> 'a t -> ('a t * 'a option * 'a t) (** [split x m] returns a triple [(l, data, r)], where [l] is the map with all the bindings of [m] whose key is strictly less than [x]; [r] is the map with all the bindings of [m] whose key is strictly greater than [x]; [data] is [None] if [m] contains no binding for [x], or [Some v] if [m] binds [v] to [x]. *) val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t (** [partition p m] returns a pair of maps [(m1, m2)], where [m1] contains all the bindings of [s] that satisfy the predicate [p], and [m2] is the map with all the bindings of [s] that do not satisfy [p]. @since 1.4.0 *) val singleton: key -> 'a -> 'a t (** [singleton x y] returns the one-element map that contains a binding [y] for [x]. *) val bindings : 'a t -> (key * 'a) list (** Return the list of all bindings of the given map. The returned list is sorted in increasing key order. Added for compatibility with stdlib 3.12 *) val enum : 'a t -> (key * 'a) BatEnum.t (** Return an enumeration of [(key, value)] pairs of a map. The returned enumeration is sorted in increasing order with respect to the ordering [Ord.compare], where [Ord] is the argument given to {!Map.Make}. *) val backwards : 'a t -> (key * 'a) BatEnum.t (** Return an enumeration of [(key, value)] pairs of a map. The returned enumeration is sorted in decreasing order with respect to the ordering [Ord.compare], where [Ord] is the argument given to {!Map.Make}. *) val of_enum: (key * 'a) BatEnum.t -> 'a t (** Create a map from a (key, value) enumeration. *) val for_all: (key -> 'a -> bool) -> 'a t -> bool (** [for_all p m] checks if all the bindings of the map satisfy the predicate [p]. *) val exists: (key -> 'a -> bool) -> 'a t -> bool (** [exists p m] checks if at least one binding of the map satisfy the predicate [p]. *) val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] and of [m2]. The presence of each such binding, and the corresponding value, is determined with the function [f]. *) val union: (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t (** [union f m1 m2] computes a map whose keys are a subset of the keys of [m1] and of [m2]. When the same binding is defined in both arguments, the function f is used to combine them. This function is similar to [merge], except [f] is only called if a key is present in both [m1] and [m2]. If a key is present in either [m1] or [m2] but not in both, it (and the corresponding value) will be present in the resulting map. @since 3.3.0 *) val to_seq : 'a t -> (key * 'a) BatSeq.t (** Iterate on the whole map, in ascending order of keys. @since 3.3.0 *) val to_rev_seq : 'a t -> (key * 'a) BatSeq.t (** Iterate on the whole map, in descending order of keys. @since 3.3.0 *) val to_seq_from : key -> 'a t -> (key * 'a) BatSeq.t (** [to_seq_from k m] iterates on a subset of the bindings in [m], namely those bindings greater or equal to [k], in ascending order. @since 3.3.0 *) val add_seq : (key * 'a) BatSeq.t -> 'a t -> 'a t (** add the given bindings to the map, in order. @since 3.3.0 *) val of_seq : (key * 'a) BatSeq.t -> 'a t (** build a map from the given bindings @since 3.3.0 *) (** {6 Boilerplate code}*) (** {7 Printing}*) val print : ?first:string -> ?last:string -> ?sep:string -> ?kvsep:string -> ('a BatInnerIO.output -> key -> unit) -> ('a BatInnerIO.output -> 'c -> unit) -> 'a BatInnerIO.output -> 'c t -> unit (** Output signature of the functor {!Map.Make}. *) (** {6 Override modules}*) (** The following modules replace functions defined in {!Map} with functions behaving slightly differently but having the same name. This is by design: the functions meant to override the corresponding functions of {!Map}. *) (** Operations on {!Map} without exceptions. *) module Exceptionless : sig val find: key -> 'a t -> 'a option val choose: 'a t -> (key * 'a) option val any: 'a t -> (key * 'a) option end (** Infix operators over a {!BatMap} *) module Infix : sig val (-->) : 'a t -> key -> 'a (** [map-->key] returns the current binding of [key] in [map], or raises [Not_found]. Equivalent to [find key map]. *) val (<--) : 'a t -> key * 'a -> 'a t (** [map <-- (key, value)] returns a map containing the same bindings as [map], plus a binding of [key] to [value]. If [key] was already bound in [map], its previous binding disappears. Equivalent to [add key value map]. *) end (** Operations on {!Map} with labels. This module overrides a number of functions of {!Map} by functions in which some arguments require labels. These labels are there to improve readability and safety and to let you change the order of arguments to functions. In every case, the behavior of the function is identical to that of the corresponding function of {!Map}. *) module Labels : sig val add : key:key -> data:'a -> 'a t -> 'a t val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit val map : f:('a -> 'b) -> 'a t -> 'b t val mapi : f:(key:key -> data:'a -> 'b) -> 'a t -> 'b t val filterv: f:('a -> bool) -> 'a t -> 'a t val filter:f:(key -> 'a -> bool) -> 'a t -> 'a t val fold : f:(key:key -> data:'a -> 'b -> 'b) -> 'a t -> init:'b -> 'b val compare: cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: cmp:('a -> 'a -> bool) -> 'a t -> 'a t -> bool end end module Make (Ord : BatInterfaces.OrderedType) : S with type key = Ord.t (** Functor building an implementation of the map structure given a totally ordered type. *) (** {6 Common instantiations} **) module Int : S with type key = int module Int32 : S with type key = int32 module Int64 : S with type key = int64 module Nativeint : S with type key = nativeint module Float : S with type key = float module Char : S with type key = char module String : S with type key = string (** {4 Polymorphic maps} The functions below present the manipulation of polymorphic maps, as were provided by the Extlib PMap module. They are similar in functionality to the functorized {!Make} module, but only uses the [Pervasives.compare] function to compare elements. If you need to compare using a custom comparison function, it is recommended to use the functorized maps provided by {!Make}. *) type ('a, 'b) t val empty : ('a, 'b) t (** The empty map, using [compare] as key comparison function. *) val is_empty : ('a, 'b) t -> bool (** Returns [true] if the map is empty. *) val singleton : 'a -> 'b -> ('a, 'b) t (** Creates a new map with a single binding. *) val cardinal: ('a, 'b) t -> int (** Return the number of bindings of a map. *) val add : 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t (** [add x y m] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already bound in [m], its previous binding disappears. If [x] was already bound to some [z] that is physically equal to [y], then the returned map is physically equal to [m]. @before 3.3.0 physical equality was not ensured. *) val update: 'a -> 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t (** [update k1 k2 v2 m] replace the previous binding of [k1] in [m] by [k2] associated to [v2]. This is equivalent to [add k2 v2 (remove k1) m], but more efficient in the case where [k1] and [k2] have the same key ordering. If [k1] and [k2] have the same key ordering and [v2] is physically equal to the value [k1] is bound to in [m] then the returned map will be physically equal to [m] @raise Not_found if [k1] is not bound in [m]. @since 2.4.0 @before 3.3.0 physical equality was not ensured. *) val update_stdlib : 'a -> ('b option -> 'b option) -> ('a, 'b) t -> ('a, 'b) t (** [update_stdlib k f m] returns a map containing the same bindings as [m], except [k] has a new binding as determined by [f]: First, calculate [y] as [f (find_opt k m)]. If [y = Some v] then [k] will be bound to [v] in the resulting map. Else [k] will not be bound in the resulting map. If [v] is physically equal to the value of the previous binding of [k] in [m], then the returned map will be physically equal to [m]. This function does the same thing as [update] in the stdlib, but has a different name for backwards compatibility reasons. @since 3.3.0 *) val find : 'a -> ('a, 'b) t -> 'b (** [find x m] returns the current binding of [x] in [m], or raises [Not_found] if no such binding exists. *) val find_opt : 'a -> ('a, 'b) t -> 'b option (** [find_opt x m] returns Some b where b is the current binding * of [x] in [m], or None if no such binding exists. *) val find_default : 'b -> 'a -> ('a, 'b) t -> 'b (** [find_default d x m] returns the current binding of [x] in [m], or the default value [d] if no such binding exists. *) val find_first: ('a -> bool) -> ('a, 'b) t -> 'a * 'b (** [find_first f m] returns the first binding [(k, v)] for which [f k] is true or raises [Not_found] if there is no such binding. [f] must be monotonically increasing, i.e. if [k1 < k2 && f k1] is true then [f k2] must also be true. @since 3.3.0 *) val find_first_opt: ('a -> bool) -> ('a, 'b) t -> ('a * 'b) option (** [find_first_opt f m] returns [Some (k, v)] for the first binding [(k, v)] for which [f k] is true or returns [None] if there is no such binding. [f] must be monotonically increasing, i.e. if [k1 < k2 && f k1] is true then [f k2] must also be true. @since 3.3.0 *) val find_last: ('a -> bool) -> ('a, 'b) t -> 'a * 'b (** [find_last f m] returns the last binding [(k, v)] for which [f k] is true or raises [Not_found] if there is no such binding. [f] must be monotonically decreasing, i.e. if [k1 < k2 && f k2] is true then [f k1] must also be true. @since 3.3.0 *) val find_last_opt: ('a -> bool) -> ('a, 'b) t -> ('a * 'b) option (** [find_last_opt f m] returns [Some (k, v)] for the last binding [(k, v)] for which [f k] is true or returns [None] if there is no such binding. [f] must be monotonically decreasing, i.e. if [k1 < k2 && f k2] is true then [f k1] must also be true. @since 3.3.0 *) val remove : 'a -> ('a, 'b) t -> ('a, 'b) t (** [remove x m] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map. The returned map is physically equal to the passed one if [x] was already unbound. @before 3.3.0 physical equality was not ensured *) val remove_exn: 'a -> ('a, 'b) t -> ('a, 'b) t (** [remove_exn x m] behaves like [remove x m] except that it raises an exception if [x] is unbound in [m]. @raise Not_found if [x] is unbound in [m] @since 3.2.0 *) val mem : 'a -> ('a, 'b) t -> bool (** [mem x m] returns [true] if [m] contains a binding for [x], and [false] otherwise. *) val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit (** [iter f m] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated value as second argument. The order in which the bindings are passed to [f] is unspecified. Only current bindings are presented to [f]: bindings hidden by more recent bindings are not passed to [f]. *) val map : ('b -> 'c) -> ('a, 'b) t -> ('a, 'c) t (** [map f m] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been replaced by the result of the application of [f] to [a]. The order in which the associated values are passed to [f] is unspecified. *) val mapi : ('a -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t (** Same as [map], but the function receives as arguments both the key and the associated value for each binding of the map. *) val fold : ('b -> 'c -> 'c) -> ('a , 'b) t -> 'c -> 'c (** [fold f m a] computes [(f kN dN ... (f k1 d1 (f k0 d0 a))...)], where [k0,k1..kN] are the keys of all bindings in [m], and [d0,d1..dN] are the associated data. The order in which the bindings are presented to [f] is unspecified. *) val foldi : ('a -> 'b -> 'c -> 'c) -> ('a , 'b) t -> 'c -> 'c (** Same as [fold], but the function receives as arguments both the key and the associated value for each binding of the map. *) val at_rank_exn: int -> ('key, 'a) t -> ('key * 'a) (** [at_rank_exn i m] returns the [(key,value)] pair whose key is at rank [i] in [m], that is the [i]-th element in increasing order of the keys (the [0]-th element being the smallest key in [m] with its associated value). @raise Not_found if [m = empty]. @raise Invalid_argument error_message if [i < 0 || i >= cardinal m] @since 2.4 *) val filterv: ('a -> bool) -> ('key, 'a) t -> ('key, 'a) t (**[filterv f m] returns a map where only the values [a] of [m] such that [f a = true] remain. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. *) val filter: ('key -> 'a -> bool) -> ('key, 'a) t -> ('key, 'a) t (** [filter f m] returns a map where only the [(key, value)] pairs of [m] such that [f key value = true] remain. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. If [f] returns [true] for all bindings of [m] the returned map is physically equal to [m]. @before 3.3.0 physical equality was not ensured. *) val filter_map: ('key -> 'a -> 'b option) -> ('key, 'a) t -> ('key, 'b) t (** [filter_map f m] combines the features of [filter] and [map]. It calls calls [f key0 a0], [f key1 a1], [f keyn an] where [a0..an] are the elements of [m] and [key0..keyn] the respective corresponding keys. It returns the map of [(keyi, bi)] pairs such as [f keyi ai = Some bi] (when [f] returns [None], the corresponding element of [m] is discarded). *) val choose : ('key, 'a) t -> ('key * 'a) (** Return one binding of the given map. Which binding is chosen is unspecified, but equal bindings will be chosen for equal maps. @raise Not_found if the map is empty *) val choose_opt : ('key, 'a) t -> ('key * 'a) option (** Return [Some (k, v)] for one binding [(k, v)] of the given map, if the map is not empty. Else, return None. Which binding is chosen is unspecified, but equal bindings will be chosen for equal maps. @since 3.3.0 *) val any : ('key, 'a) t -> ('key * 'a) (** Return one binding of the given map. The difference with choose is that there is no guarantee that equals elements will be picked for equal sets. This merely returns the quickest binding to get (O(1)). @raise Not_found if the map is empty. *) (* The following documentation comment is from stdlib's map.mli: *) val split : 'key -> ('key, 'a) t -> (('key, 'a) t * 'a option * ('key, 'a) t) (** [split x m] returns a triple [(l, data, r)], where [l] is the map with all the bindings of [m] whose key is strictly less than [x]; [r] is the map with all the bindings of [m] whose key is strictly greater than [x]; [data] is [None] if [m] contains no binding for [x], or [Some v] if [m] binds [v] to [x]. *) val min_binding : ('key, 'a) t -> ('key * 'a) (** Returns the binding with the smallest key. Raises Not_found if the map is empty. *) val min_binding_opt : ('key, 'a) t -> ('key * 'a) option (** Return [Some (key, value)] for the [key, value] pair with the smallest key, or [None] if the map is empty. @since 3.3.0 *) val pop_min_binding : ('key, 'a) t -> ('key * 'a) * ('key, 'a) t (** Returns the binding with the smallest key along with the rest of the map. *) val max_binding : ('key, 'a) t -> ('key * 'a) (** Return the [(key, value)] pair with the largest key. Raises Not_found if the map is empty. *) val max_binding_opt : ('key, 'a) t -> ('key * 'a) option (** Return [Some (key, value)] for the [key, value] pair with the largest key, or [None] if the map is empty. @since 3.3.0 *) val pop_max_binding : ('key, 'a) t -> ('key * 'a) * ('key, 'a) t (** Returns the binding with the largest key along with the rest of the map. *) val enum : ('a, 'b) t -> ('a * 'b) BatEnum.t (** Creates an enumeration for this map, enumerating [(key, value)] pairs with the keys in increasing order. *) val backwards : ('a,'b) t -> ('a * 'b) BatEnum.t (** Creates an enumeration for this map, enumerating [(key, value)] pairs with the keys in decreasing order. *) val keys : ('a,'b) t -> 'a BatEnum.t (** Return an enumeration of all the keys of a map. *) val values: ('a,'b) t -> 'b BatEnum.t (** Return an enumeration of all the values of a map. *) val of_enum : ('a * 'b) BatEnum.t -> ('a, 'b) t (** Creates a map from an enumeration. *) val for_all : ('a -> 'b -> bool) -> ('a, 'b) t -> bool (** Tests whether all [(key, value)] pairs satisfy a predicate function. *) val exists : ('a -> 'b -> bool) -> ('a, 'b) t -> bool (** Tests whether some [(key, value)] pair satisfies a predicate function. *) (* documentation comment from INRIA's stdlib *) val partition : ('a -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t * ('a, 'b) t (** [partition p m] returns a pair of maps [(m1, m2)], where [m1] contains all the bindings of [s] that satisfy the predicate [p], and [m2] is the map with all the bindings of [s] that do not satisfy [p]. *) val add_carry : 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t * 'b option (** [add_carry k v m] adds the binding [(k, v)] to [m], returning the new map and optionally the previous value bound to [k]. *) val modify : 'a -> ('b -> 'b) -> ('a, 'b) t -> ('a, 'b) t (** [modify k f m] replaces the previous binding for [k] with [f] applied to that value. If [k] is unbound in [m] or [Not_found] is raised during the search, [Not_found] is raised. @since 1.2.0 @raise Not_found if [k] is unbound in [m] (or [f] raises [Not_found]) *) val modify_def: 'b -> 'a -> ('b -> 'b) -> ('a,'b) t -> ('a,'b) t (** [modify_def v0 k f m] replaces the previous binding for [k] with [f] applied to that value. If [k] is unbound in [m] or [Not_found] is raised during the search, [f v0] is inserted (as if the value found were [v0]). @since 1.3.0 *) val modify_opt: 'a -> ('b option -> 'b option) -> ('a,'b) t -> ('a,'b) t (** [modify_opt k f m] allow to modify the binding for [k] in [m] or absence thereof. @since 2.1 *) val extract : 'a -> ('a, 'b) t -> 'b * ('a, 'b) t (** [extract k m] removes the current binding of [k] from [m], returning the value [k] was bound to and the updated [m]. *) val pop : ('a, 'b) t -> ('a * 'b) * ('a, 'b) t (** [pop m] returns a binding from [m] and [m] without that binding. *) val union : ('a, 'b) t -> ('a, 'b) t -> ('a, 'b) t (** [union m1 m2] merges two maps, using the comparison function of [m1]. In case of conflicted bindings, [m2]'s bindings override [m1]'s. Equivalent to [foldi add m2 m1]. The resulting map uses the comparison function of [m1]. *) val union_stdlib: ('key -> 'a -> 'a -> 'a option) -> ('key, 'a) t -> ('key, 'a) t -> ('key, 'a) t (** [union_stdlib f m1 m2] computes a map whose keys are a subset of the keys of [m1] and of [m2]. When the same binding is defined in both arguments, the function f is used to combine them. This function is similar to [merge], except [f] is only called if a key is present in both [m1] and [m2]. If a key is present in either [m1] or [m2] but not in both, it (and the corresponding value) will be present in the resulting map. This is the union method from the stdlib map, renamed for backwards compatibility. @since 3.3.0 *) val to_seq : ('key, 'a) t -> ('key * 'a) BatSeq.t (** Iterate on the whole map, in ascending order of keys. @since 3.3.0 *) val to_rev_seq : ('key, 'a) t -> ('key * 'a) BatSeq.t (** Iterate on the whole map, in descending order of keys. @since 3.3.0 *) val to_seq_from : 'key -> ('key, 'a) t -> ('key * 'a) BatSeq.t (** [to_seq_from k m] iterates on a subset of the bindings in [m], namely those bindings greater or equal to [k], in ascending order. @since 3.3.0 *) val add_seq : ('key * 'a) BatSeq.t -> ('key, 'a) t -> ('key, 'a) t (** add the given bindings to the map, in order. @since 3.3.0 *) val of_seq : ('key * 'a) BatSeq.t -> ('key, 'a) t (** build a map from the given bindings @since 3.3.0 *) val diff : ('a, 'b) t -> ('a, 'b) t -> ('a, 'b) t (** [diff m1 m2] removes all bindings of keys found in [m2] from [m1], using the comparison function of [m1]. Equivalent to [foldi (fun k _v m -> remove k m) m2 m1]. The resulting map uses the comparison function of [m1]. *) val intersect : ('b -> 'c -> 'd) -> ('a, 'b) t -> ('a, 'c) t -> ('a, 'd) t (** [intersect merge_f m1 m2] returns a map with bindings only for keys bound in both [m1] and [m2], and with [k] bound to [merge_f v1 v2], where [v1] and [v2] are [k]'s bindings in [m1] and [m2]. The resulting map uses the comparison function of [m1]. *) val merge: ('key -> 'a option -> 'b option -> 'c option) -> ('key, 'a) t -> ('key, 'b) t -> ('key, 'c) t (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] and of [m2]. The presence of each such binding, and the corresponding value, is determined with the function [f]. The resulting map uses the comparison function of [m1]. *) val compare: ('b -> 'b -> int) -> ('a,'b) t -> ('a, 'b) t -> int val equal : ('b -> 'b -> bool) -> ('a,'b) t -> ('a, 'b) t -> bool (** Construct a comparison or equality function for maps based on a value comparison or equality function. Uses the key comparison function to compare keys *) (** Exceptionless versions of functions *) module Exceptionless : sig val find: 'a -> ('a,'b) t -> 'b option val choose: ('a, 'b) t -> ('a * 'b) option val any: ('a, 'b) t -> ('a * 'b) option end (** Infix operators over a {!BatPMap} *) module Infix : sig val (-->) : ('a, 'b) t -> 'a -> 'b (** [map --> key] returns the current binding of [key] in [map], or raises [Not_found]. Equivalent to [find key map]. *) val (<--) : ('a, 'b) t -> 'a * 'b -> ('a, 'b) t (** [map <-- (key, value)] returns a map containing the same bindings as [map], plus a binding of [key] to [value]. If [key] was already bound in [map], its previous binding disappears. Equivalent to [add key value map]. *) end (** Map find and insert from Infix *) val (-->) : ('a, 'b) t -> 'a -> 'b val (<--) : ('a, 'b) t -> 'a * 'b -> ('a, 'b) t val bindings : ('key, 'a) t -> ('key * 'a) list (** Return the list of all bindings of the given map. The returned list is sorted in increasing key order. Added for compatibility with stdlib 3.12 *) (** {6 Boilerplate code}*) (** {7 Printing}*) val print : ?first:string -> ?last:string -> ?sep:string -> ?kvsep:string -> ('a BatInnerIO.output -> 'b -> unit) -> ('a BatInnerIO.output -> 'c -> unit) -> 'a BatInnerIO.output -> ('b, 'c) t -> unit (**/**) module type OrderedType = BatInterfaces.OrderedType (** Input signature of the functor {!Map.Make}. *) (**/**) module PMap : sig (** {4 Polymorphic maps} The functions below present the manipulation of polymorphic maps, as were provided by the Extlib PMap module. They are similar in functionality to the functorized {!Make} module, but the compiler cannot ensure that maps using different key ordering have different types: the responsibility of not mixing non-sensical comparison functions together is to the programmer. If in doubt, you should rather use the {!Make} functor for additional safety. *) type ('a, 'b) t val empty : ('a, 'b) t (** The empty map, using [compare] as key comparison function. *) val is_empty : ('a, 'b) t -> bool (** Returns [true] if the map is empty. *) val create : ('a -> 'a -> int) -> ('a, 'b) t (** Creates a new empty map, using the provided function for key comparison. *) val get_cmp : ('a, 'b) t -> ('a -> 'a -> int) (** Returns the comparison function of the given map. *) val singleton : ?cmp:('a -> 'a -> int) -> 'a -> 'b -> ('a, 'b) t (** Creates a new map with a single binding. *) val cardinal: ('a, 'b) t -> int (** Return the number of bindings of a map. *) val add : 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t (** [add x y m] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already bound in [m], its previous binding disappears. If [x] was already bound to some [z] that is physically equal to [y], then the returned map is physically equal to [m]. @before 3.3.0 physical equality was not ensured. *) val update : 'a -> 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t (** [update k1 k2 v2 m] replace the previous binding of [k1] in [m] by [k2] associated to [v2]. This is equivalent to [add k2 v2 (remove k1) m], but more efficient in the case where [k1] and [k2] have the same key ordering. If [k1] and [k2] have the same key ordering and [v2] is physically equal to the value [k1] is bound to in [m] then the returned map will be physically equal to [m] @raise Not_found if [k1] is not bound in [m]. @since 2.4.0 @before 3.3.0 physical equality was not ensured. *) val update_stdlib : 'a -> ('b option -> 'b option) -> ('a, 'b) t -> ('a, 'b) t (** [update_stdlib k f m] returns a map containing the same bindings as [m], except [k] has a new binding as determined by [f]: First, calculate [y] as [f (find_opt k m)]. If [y = Some v] then [k] will be bound to [v] in the resulting map. Else [k] will not be bound in the resulting map. If [v] is physically equal to the value of the previous binding of [k] in [m], then the returned map will be physically equal to [m]. This function does the same thing as [update] in the stdlib, but has a different name for backwards compatibility reasons. @since 3.3.0 *) val find : 'a -> ('a, 'b) t -> 'b (** [find x m] returns the current binding of [x] in [m], or raises [Not_found] if no such binding exists. *) val find_default : 'b -> 'a -> ('a, 'b) t -> 'b (** [find_default d x m] returns the current binding of [x] in [m], or the default value [d] if no such binding exists. *) val find_first: ('a -> bool) -> ('a, 'b) t -> 'a * 'b (** [find_first f m] returns the first binding [(k, v)] for which [f k] is true or raises [Not_found] if there is no such binding. [f] must be monotonically increasing, i.e. if [k1 < k2 && f k1] is true then [f k2] must also be true. @since 3.3.0 *) val find_first_opt: ('a -> bool) -> ('a, 'b) t -> ('a * 'b) option (** [find_first_opt f m] returns [Some (k, v)] for the first binding [(k, v)] for which [f k] is true or returns [None] if there is no such binding. [f] must be monotonically increasing, i.e. if [k1 < k2 && f k1] is true then [f k2] must also be true. @since 3.3.0 *) val find_last: ('a -> bool) -> ('a, 'b) t -> 'a * 'b (** [find_last f m] returns the last binding [(k, v)] for which [f k] is true or raises [Not_found] if there is no such binding. [f] must be monotonically decreasing, i.e. if [k1 < k2 && f k2] is true then [f k1] must also be true. @since 3.3.0 *) val find_last_opt: ('a -> bool) -> ('a, 'b) t -> ('a * 'b) option (** [find_last_opt f m] returns [Some (k, v)] for the last binding [(k, v)] for which [f k] is true or returns [None] if there is no such binding. [f] must be monotonically decreasing, i.e. if [k1 < k2 && f k2] is true then [f k1] must also be true. @since 3.3.0 *) val remove : 'a -> ('a, 'b) t -> ('a, 'b) t (** [remove x m] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map. The returned map is physically equal to the passed one if [x] was already unbound. @before 3.3.0 physical equality was not ensured *) val remove_exn : 'a -> ('a, 'b) t -> ('a, 'b) t (** [remove_exn x m] behaves like [remove x m] except that it raises an exception if [x] is unbound in [m]. @raise Not_found if [x] is unbound in [m] @since 3.2.0 *) val mem : 'a -> ('a, 'b) t -> bool (** [mem x m] returns [true] if [m] contains a binding for [x], and [false] otherwise. *) val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit (** [iter f m] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated value as second argument. The order in which the bindings are passed to [f] is unspecified. Only current bindings are presented to [f]: bindings hidden by more recent bindings are not passed to [f]. *) val map : ('b -> 'c) -> ('a, 'b) t -> ('a, 'c) t (** [map f m] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been replaced by the result of the application of [f] to [a]. The order in which the associated values are passed to [f] is unspecified. *) val mapi : ('a -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t (** Same as [map], but the function receives as arguments both the key and the associated value for each binding of the map. *) val fold : ('b -> 'c -> 'c) -> ('a , 'b) t -> 'c -> 'c (** [fold f m a] computes [(f kN dN ... (f k1 d1 (f k0 d0 a))...)], where [k0,k1..kN] are the keys of all bindings in [m], and [d0,d1..dN] are the associated data. The order in which the bindings are presented to [f] is unspecified. *) val foldi : ('a -> 'b -> 'c -> 'c) -> ('a , 'b) t -> 'c -> 'c (** Same as [fold], but the function receives as arguments both the key and the associated value for each binding of the map. *) val at_rank_exn: int -> ('a, 'b) t -> ('a * 'b) (** [at_rank_exn i m] returns the [(key,value)] pair whose key is at rank [i] in [m], that is the [i]-th element in increasing order of the keys (the [0]-th element being the smallest key in [m] with its associated value). @raise Not_found if [m = empty]. @raise Invalid_argument error_message if [i < 0 || i >= cardinal m] @since 2.4 *) val filterv: ('a -> bool) -> ('key, 'a) t -> ('key, 'a) t (**[filterv f m] returns a map where only the values [a] of [m] such that [f a = true] remain. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. *) val filter: ('key -> 'a -> bool) -> ('key, 'a) t -> ('key, 'a) t (** [filter f m] returns a map where only the [(key, value)] pairs of [m] such that [f key value = true] remain. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. If [f] returns [true] for all bindings of [m] the returned map is physically equal to [m]. @before 3.3.0 physical equality was not ensured. *) val filter_map: ('key -> 'a -> 'b option) -> ('key, 'a) t -> ('key, 'b) t (** [filter_map f m] combines the features of [filter] and [map]. It calls calls [f key0 a0], [f key1 a1], [f keyn an] where [a0..an] are the elements of [m] and [key0..keyn] the respective corresponding keys. It returns the map of ([keyi], [bi]) pairs such as [f keyi ai = Some bi] (when [f] returns [None], the corresponding element of [m] is discarded). *) val choose : ('key, 'a) t -> ('key * 'a) (** Return one binding of the given map. Which binding is chosen is unspecified, but equal bindings will be chosen for equal maps. @raise Not_found if the map is empty. *) val choose_opt : ('key, 'a) t -> ('key * 'a) option (** Return [Some (k, v)] for one binding [(k, v)] of the given map, if the map is not empty. Else, return None. Which binding is chosen is unspecified, but equal bindings will be chosen for equal maps. @since 3.3.0 *) val any : ('key, 'a) t -> ('key * 'a) (** Return one binding of the given map. The difference with choose is that there is no guarantee that equals elements will be picked for equal sets. This merely returns the quickest binding to get (O(1)). @raise Not_found if the map is empty. *) (* The following documentation comment is from stdlib's map.mli: *) val split : 'key -> ('key, 'a) t -> (('key, 'a) t * 'a option * ('key, 'a) t) (** [split x m] returns a triple [(l, data, r)], where [l] is the map with all the bindings of [m] whose key is strictly less than [x]; [r] is the map with all the bindings of [m] whose key is strictly greater than [x]; [data] is [None] if [m] contains no binding for [x], or [Some v] if [m] binds [v] to [x]. *) val min_binding : ('key, 'a) t -> ('key * 'a) (** Returns the binding with the smallest key. *) val min_binding_opt : ('key, 'a) t -> ('key * 'a) option (** Return [Some (key, value)] for the [key, value] pair with the smallest key, or [None] if the map is empty. @since 3.3.0 *) val pop_min_binding : ('key, 'a) t -> ('key * 'a) * ('key, 'a) t (** Return the binding with the smallest key along with the rest of the map. *) val max_binding : ('key, 'a) t -> ('key * 'a) (** Returns the binding with the largest key. *) val max_binding_opt : ('key, 'a) t -> ('key * 'a) option (** Return [Some (key, value)] for the [key, value] pair with the largest key, or [None] if the map is empty. @since 3.3.0 *) val pop_max_binding : ('key, 'a) t -> ('key * 'a) * ('key, 'a) t (** Return the binding with the largest key along with the rest of the map. *) val enum : ('a, 'b) t -> ('a * 'b) BatEnum.t (** Creates an enumeration for this map, enumerating [(key, value)] pairs with the keys in increasing order. *) val backwards : ('a,'b) t -> ('a * 'b) BatEnum.t (** Creates an enumeration for this map, enumerating [(key, value)] pairs with the keys in decreasing order. *) val keys : ('a,'b) t -> 'a BatEnum.t (** Return an enumeration of all the keys of a map. *) val values: ('a,'b) t -> 'b BatEnum.t (** Return an enumeration of all the values of a map. *) val of_enum : ?cmp:('a -> 'a -> int) -> ('a * 'b) BatEnum.t -> ('a, 'b) t (** creates a map from an enumeration, using the specified function for key comparison or [compare] by default. *) val for_all : ('a -> 'b -> bool) -> ('a, 'b) t -> bool (** Tests whether all [(key, value)] pairs satisfy a predicate function. *) val exists : ('a -> 'b -> bool) -> ('a, 'b) t -> bool (** Tests whether some [(key, value)] pair satisfies a predicate function. *) (* documentation comment from INRIA's stdlib *) val partition : ('a -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t * ('a, 'b) t (** [partition p m] returns a pair of maps [(m1, m2)], where [m1] contains all the bindings of [s] that satisfy the predicate [p], and [m2] is the map with all the bindings of [s] that do not satisfy [p]. *) val add_carry : 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t * 'b option (** [add_carry k v m] adds the binding [(k, v)] to [m], returning the new map and optionally the previous value bound to [k]. *) val modify : 'a -> ('b -> 'b) -> ('a, 'b) t -> ('a, 'b) t (** [modify k f m] replaces the previous binding for [k] with [f] applied to that value. If [k] is unbound in [m] or [Not_found] is raised during the search, [Not_found] is raised. @since 1.2.0 @raise Not_found if [k] is unbound in [m] (or [f] raises [Not_found]) *) val modify_def: 'b -> 'a -> ('b -> 'b) -> ('a,'b) t -> ('a,'b) t (** [modify_def v0 k f m] replaces the previous binding for [k] with [f] applied to that value. If [k] is unbound in [m] or [Not_found] is raised during the search, [f v0] is inserted (as if the value found were [v0]). @since 1.3.0 *) val modify_opt: 'a -> ('b option -> 'b option) -> ('a,'b) t -> ('a,'b) t (** [modify_opt k f m] allow to modify the binding for [k] in [m] or absence thereof. @since 2.1 *) val extract : 'a -> ('a, 'b) t -> 'b * ('a, 'b) t (** [extract k m] removes the current binding of [k] from [m], returning the value [k] was bound to and the updated [m]. *) val pop : ('a, 'b) t -> ('a * 'b) * ('a, 'b) t (** [pop m] returns a binding from [m] and [m] without that binding. *) val union : ('a, 'b) t -> ('a, 'b) t -> ('a, 'b) t (** [union m1 m2] merges two maps, using the comparison function of [m1]. In case of conflicted bindings, [m2]'s bindings override [m1]'s. Equivalent to [foldi add m2 m1]. The resulting map uses the comparison function of [m1]. *) val diff : ('a, 'b) t -> ('a, 'b) t -> ('a, 'b) t (** [diff m1 m2] removes all bindings of keys found in [m2] from [m1], using the comparison function of [m1]. Equivalent to [foldi (fun k _v m -> remove k m) m2 m1]. The resulting map uses the comparison function of [m1]. *) val intersect : ('b -> 'c -> 'd) -> ('a, 'b) t -> ('a, 'c) t -> ('a, 'd) t (** [intersect merge_f m1 m2] returns a map with bindings only for keys bound in both [m1] and [m2], and with [k] bound to [merge_f v1 v2], where [v1] and [v2] are [k]'s bindings in [m1] and [m2]. The resulting map uses the comparison function of [m1]. *) val merge: ('key -> 'a option -> 'b option -> 'c option) -> ('key, 'a) t -> ('key, 'b) t -> ('key, 'c) t (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] and of [m2]. The presence of each such binding, and the corresponding value, is determined with the function [f]. The resulting map uses the comparison function of [m1]. *) val merge_unsafe: ('key -> 'a option -> 'b option -> 'c option) -> ('key, 'a) t -> ('key, 'b) t -> ('key, 'c) t (** Same as merge, but assumes the comparison function of both maps are equal. If it's not the case, the result is a map using the comparison function of its first parameter, but which ['b option] elements are passed to the function is unspecified. *) val union_stdlib: ('key -> 'a -> 'a -> 'a option) -> ('key, 'a) t -> ('key, 'a) t -> ('key, 'a) t (** [union f m1 m2] computes a map whose keys are a subset of the keys of [m1] and of [m2]. When the same binding is defined in both arguments, the function f is used to combine them. This function is similar to [merge], except [f] is only called if a key is present in both [m1] and [m2]. If a key is present in either [m1] or [m2] but not in both, it (and the corresponding value) will be present in the resulting map. This is the union method from the stdlib map, renamed for backwards compatibility. @since 3.3.0 *) val to_seq : ('key, 'a) t -> ('key * 'a) BatSeq.t (** Iterate on the whole map, in ascending order of keys. @since 3.3.0 *) val to_rev_seq : ('key, 'a) t -> ('key * 'a) BatSeq.t (** Iterate on the whole map, in descending order of keys. @since 3.3.0 *) val to_seq_from : 'key -> ('key, 'a) t -> ('key * 'a) BatSeq.t (** [to_seq_from k m] iterates on a subset of the bindings in [m], namely those bindings greater or equal to [k], in ascending order. @since 3.3.0 *) val add_seq : ('key * 'a) BatSeq.t -> ('key, 'a) t -> ('key, 'a) t (** add the given bindings to the map, in order. @since 3.3.0 *) val of_seq : ?cmp:('key -> 'key -> int) -> ('key * 'a) BatSeq.t -> ('key, 'a) t (** build a map from the given bindings @since 3.3.0 *) val compare: ('b -> 'b -> int) -> ('a,'b) t -> ('a, 'b) t -> int val equal : ('b -> 'b -> bool) -> ('a,'b) t -> ('a, 'b) t -> bool (** Construct a comparison or equality function for maps based on a value comparison or equality function. Uses the key comparison function to compare keys. *) (** Exceptionless versions of functions *) module Exceptionless : sig val find: 'a -> ('a,'b) t -> 'b option val choose: ('a, 'b) t -> ('a * 'b) option val any: ('a, 'b) t -> ('a * 'b) option end (** Infix operators over a {!PMap} *) module Infix : sig val (-->) : ('a, 'b) t -> 'a -> 'b (** [map-->key] returns the current binding of [key] in [map], or raises [Not_found]. Equivalent to [find key map]. *) val (<--) : ('a, 'b) t -> 'a * 'b -> ('a, 'b) t (** [map <-- (key, value)] returns a map containing the same bindings as [map], plus a binding of [key] to [value]. If [key] was already bound in [map], its previous binding disappears. Equivalent to [add key value map]. *) end (** Map find and insert from Infix *) val (-->) : ('a, 'b) t -> 'a -> 'b val (<--) : ('a, 'b) t -> 'a * 'b -> ('a, 'b) t val bindings : ('key, 'a) t -> ('key * 'a) list (** Return the list of all bindings of the given map. The returned list is sorted in increasing key order. Added for compatibility with stdlib 3.12 *) (** {6 Boilerplate code}*) (** {7 Printing}*) val print : ?first:string -> ?last:string -> ?sep:string -> ?kvsep:string -> ('a BatInnerIO.output -> 'b -> unit) -> ('a BatInnerIO.output -> 'c -> unit) -> 'a BatInnerIO.output -> ('b, 'c) t -> unit (** get the comparison function used for a polymorphic map *) val get_cmp : ('a, 'b) t -> ('a -> 'a -> int) end (* PMap module *) batteries-included-3.4.0/src/batMap.mlv000066400000000000000000001615411415601150500200060ustar00rootroot00000000000000(* * BatMap - Additional map operations * Copyright (C) 1996 Xavier Leroy * 1996-2003 Nicolas Cannasse, Markus Mottl * 2009-2011 David Rajchenbach-Teller, Edgar Friendly, Gabriel Scherer * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (* A concrete implementation for the direct balanced maps structure, without carrying the ordering information with the data. This implementation directly expose the map structure, and should be the basis of both functorized Map and polymorphic PMap operations (both providing their own way to access the ordering information, and to possibly pass it along with the result). I tried to keep the interface minimal with respect to ordering information : function that do not need the ordering (they do not need to find the position of a specific key in the map) do not have a 'cmp' parameter. Most of those implementations are derived from Extlib's PMap module. Please keep in mind that our Map module currently relies on the fact that the (('k, 'v) Concrete.map) implementation is physically equal to stdlib's ('a Map.S.t). Changing Concrete.map is not a good idea. *) module Concrete = struct type ('k, 'v) map = | Empty | Node of ('k, 'v) map * 'k * 'v * ('k, 'v) map * int let height = function | Node (_, _, _, _, h) -> h | Empty -> 0 let empty = Empty let is_empty m = m = Empty (* The create and bal functions are from stdlib's map.ml (3.12) differences from the old (extlib) implementation : 1. create use direct integer comparison instead of calling polymorphic 'max' 2. the two calls of 'height' for hl and hr in the beginning of 'bal' (hot path) are inlined The difference in performances is important for bal-heavy worflows, such as "adding a lot of elements". On a test system, we go from 1800 op/s to 2500 op/s. *) let create l x d r = let hl = height l and hr = height r in Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let bal l x d r = let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in if hl > hr + 2 then begin match l with Empty -> invalid_arg "Map.bal" | Node(ll, lv, ld, lr, _) -> if height ll >= height lr then create ll lv ld (create lr x d r) else begin match lr with Empty -> invalid_arg "Map.bal" | Node(lrl, lrv, lrd, lrr, _)-> create (create ll lv ld lrl) lrv lrd (create lrr x d r) end end else if hr > hl + 2 then begin match r with Empty -> invalid_arg "Map.bal" | Node(rl, rv, rd, rr, _) -> if height rr >= height rl then create (create l x d rl) rv rd rr else begin match rl with Empty -> invalid_arg "Map.bal" | Node(rll, rlv, rld, rlr, _) -> create (create l x d rll) rlv rld (create rlr rv rd rr) end end else Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let rec min_binding = function | Node (Empty, k, v, _, _) -> k, v | Node (l, _, _, _, _) -> min_binding l | Empty -> raise Not_found let rec min_binding_opt = function | Node (Empty, k, v, _, _) -> Some (k, v) | Node (l, _, _, _, _) -> min_binding_opt l | Empty -> None let get_root = function | Empty -> raise Not_found | Node (_, k, v, _, _) -> k, v let pop_min_binding s = let mini = ref (get_root s) in let rec loop = function | Empty -> assert(false) (* get_root already raises Not_found on empty map *) | Node(Empty, k, v, r, _) -> mini := (k, v); r | Node(l, k, v, r, _) -> bal (loop l) k v r in let others = loop s in (!mini, others) let rec max_binding = function | Node (_, k, v, Empty, _) -> k, v | Node (_, _, _, r, _) -> max_binding r | Empty -> raise Not_found let rec max_binding_opt = function | Node (_, k, v, Empty, _) -> Some (k, v) | Node (_, _, _, r, _) -> max_binding_opt r | Empty -> None let pop_max_binding s = let maxi = ref (get_root s) in let rec loop = function | Empty -> assert(false) (* get_root already raises Not_found on empty map *) | Node (l, k, v, Empty, _) -> maxi := (k, v); l | Node (l, k, v, r, _) -> bal l k v (loop r) in let others = loop s in (!maxi, others) let rec remove_min_binding = function | Node (Empty, _, _, r, _) -> r | Node (l, k, v, r, _) -> bal (remove_min_binding l) k v r | Empty -> raise Not_found let merge t1 t2 = match t1, t2 with | Empty, _ -> t2 | _, Empty -> t1 | _ -> let k, v = min_binding t2 in bal t1 k v (remove_min_binding t2) let add x d cmp map = let rec loop = function | Node (l, k, v, r, h) as node -> let c = cmp x k in if c = 0 then if d == v then node else Node (l, x, d, r, h) else if c < 0 then let nl = loop l in if nl == l then node else bal nl k v r else let nr = loop r in if nr == r then node else bal l k v nr | Empty -> Node (Empty, x, d, Empty, 1) in loop map let find x cmp map = let rec loop = function | Node (l, k, v, r, _) -> let c = cmp x k in if c < 0 then loop l else if c > 0 then loop r else v | Empty -> raise Not_found in loop map let rec find_first_helper_found k0 v0 f = function | Empty -> (k0, v0) | Node (l, k, v, r, _) -> if f k then find_first_helper_found k v f l else find_first_helper_found k0 v0 f r let rec find_first f m = match m with | Empty -> raise Not_found | Node (l, k, v, r, _) -> if f k then find_first_helper_found k v f l else find_first f r let rec find_first_opt f m = match m with | Empty -> None | Node (l, k, v, r, _) -> if f k then Some (find_first_helper_found k v f l) else find_first_opt f r let rec find_last_helper_found k0 v0 f = function | Empty -> (k0, v0) | Node (l, k, v, r, _) -> if f k then find_last_helper_found k v f r else find_last_helper_found k0 v0 f l let rec find_last f m = match m with | Empty -> raise Not_found | Node (l, k, v, r, _) -> if f k then find_last_helper_found k v f r else find_last f l let rec find_last_opt f m = match m with | Empty -> None | Node (l, k, v, r, _) -> if f k then Some (find_last_helper_found k v f r) else find_last_opt f l (*$T find_first (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first (fun x -> x >= 0)) = ((1, 11)) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first (fun x -> x >= 1)) = ((1, 11)) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first (fun x -> x >= 2)) = ((2, 12)) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first (fun x -> x >= 3)) = ((3, 13)) try ignore(empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first (fun x -> x >= 4)); false with Not_found -> true try ignore(empty |> find_first (fun x -> x >= 3)); false with Not_found -> true *) (*$T find_first_opt (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first_opt (fun x -> x >= 0)) = (Some (1, 11)) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first_opt (fun x -> x >= 1)) = (Some (1, 11)) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first_opt (fun x -> x >= 2)) = (Some (2, 12)) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first_opt (fun x -> x >= 3)) = (Some (3, 13)) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first_opt (fun x -> x >= 4)) = (None) (empty |> find_first_opt (fun x -> x >= 3)) = (None) *) (*$T find_last (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last (fun x -> x <= 1)) = (1, 11) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last (fun x -> x <= 2)) = (2, 12) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last (fun x -> x <= 3)) = (3, 13) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last (fun x -> x <= 4)) = (3, 13) try ignore(empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last (fun x -> x <= 0)); false with Not_found -> true try ignore(empty |> find_last (fun x -> x <= 3)); false with Not_found -> true *) (*$T find_last_opt (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last_opt (fun x -> x <= 0)) = None (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last_opt (fun x -> x <= 1)) = Some (1, 11) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last_opt (fun x -> x <= 2)) = Some (2, 12) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last_opt (fun x -> x <= 3)) = Some (3, 13) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last_opt (fun x -> x <= 4)) = Some (3, 13) (empty |> find_last_opt (fun x -> x <= 3)) = None *) let find_option x cmp map = try Some (find x cmp map) with Not_found -> None let find_default def x cmp map = try find x cmp map with Not_found -> def let remove x cmp map = let rec loop = function | Node (l, k, v, r, _) as node -> let c = cmp x k in if c = 0 then merge l r else if c < 0 then let nl = loop l in if nl == l then node else bal nl k v r else let nr = loop r in if nr == r then node else bal l k v nr | Empty -> Empty in loop map (* A variant of [remove] that throws [Not_found] on failure *) let remove_exn x cmp map = let rec loop = function | Empty -> raise Not_found | Node (l, k, v, r, _) -> let c = cmp x k in if c = 0 then merge l r else if c < 0 then bal (loop l) k v r else bal l k v (loop r) in loop map let update k1 k2 v2 cmp map = if cmp k1 k2 <> 0 then add k2 v2 cmp (remove_exn k1 cmp map) else let rec loop = function | Empty -> raise Not_found | Node(l, k, v, r, h) as node -> let c = cmp k1 k in if c = 0 then if v == v2 && k == k2 then node else Node(l, k2, v2, r, h) else if c < 0 then let nl = loop l in if nl == l then node else Node(nl, k, v, r, h) else let nr = loop r in if nr == r then node else Node(l, k, v, nr, h) in loop map let rec update_stdlib x f cmp = function | Empty -> begin match f None with | None -> Empty | Some data -> Node(Empty, x, data, Empty, 1) end | Node (l, v, d, r, h) as m -> let c = cmp x v in if c = 0 then begin match f (Some d) with | None -> merge l r | Some data -> if d == data then m else Node(l, x, data, r, h) end else if c < 0 then let ll = update_stdlib x f cmp l in if l == ll then m else bal ll v d r else let rr = update_stdlib x f cmp r in if r == rr then m else bal l v d rr let mem x cmp map = let rec loop = function | Node (l, k, _v, r, _) -> let c = cmp x k in c = 0 || loop (if c < 0 then l else r) | Empty -> false in loop map let iter f map = let rec loop = function | Empty -> () | Node (l, k, v, r, _) -> loop l; f k v; loop r in loop map let map f map = let rec loop = function | Empty -> Empty | Node (l, k, v, r, h) -> (* ensure evaluation in increasing order *) let l' = loop l in let v' = f v in let r' = loop r in Node (l', k, v', r', h) in loop map let mapi f map = let rec loop = function | Empty -> Empty | Node (l, k, v, r, h) -> (* ensure evaluation in increasing order *) let l' = loop l in let v' = f k v in let r' = loop r in Node (l', k, v', r', h) in loop map let fold f map acc = let rec loop acc = function | Empty -> acc | Node (l, _k, v, r, _) -> loop (f v (loop acc l)) r in loop acc map let foldi f map acc = let rec loop acc = function | Empty -> acc | Node (l, k, v, r, _) -> loop (f k v (loop acc l)) r in loop acc map exception Found let at_rank_exn i m = if i < 0 then invalid_arg "Map.at_rank_exn: i < 0"; let res = ref (get_root m) in (* raises Not_found if empty *) try let (_: int) = foldi (fun k v j -> if j <> i then j + 1 else begin res := (k, v); raise Found end ) m 0 in invalid_arg "Map.at_rank_exn: i >= (Map.cardinal s)" with Found -> !res (*$T at_rank_exn (empty |> add 1 true |> at_rank_exn 0) = (1, true) (empty |> add 1 true |> add 2 false |> at_rank_exn 1) = (2, false) try ignore(at_rank_exn (-1) empty); false with Invalid_argument _ -> true try ignore(at_rank_exn 0 empty); false with Not_found -> true try ignore(add 1 true empty |> at_rank_exn 1); false with Invalid_argument _ -> true *) let singleton x d = Node(Empty, x, d, Empty, 1) (* beware : those two functions assume that the added k is *strictly* smaller (or bigger) than all the present keys in the tree; it does not test for equality with the current min (or max) key. Indeed, they are only used during the "join" operation which respects this precondition. *) let rec add_min_binding k v = function | Empty -> singleton k v | Node (l, x, d, r, _h) -> bal (add_min_binding k v l) x d r let rec add_max_binding k v = function | Empty -> singleton k v | Node (l, x, d, r, _h) -> bal l x d (add_max_binding k v r) (* Same as create and bal, but no assumptions are made on the relative heights of l and r. The stdlib implementation was changed to use the new [add_{min,max}_binding] functions instead of the [add] function that would require to pass a comparison function. *) let rec join l v d r = match (l, r) with (Empty, _) -> add_min_binding v d r | (_, Empty) -> add_max_binding v d l | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) -> if lh > rh + 2 then bal ll lv ld (join lr v d r) else if rh > lh + 2 then bal (join l v d rl) rv rd rr else create l v d r (* split also is from stdlib 3.12 *) let rec split key cmp = function | Empty -> (Empty, None, Empty) | Node(l, x, d, r, _) -> let c = cmp key x in if c = 0 then (l, Some d, r) else if c < 0 then let (ll, pres, rl) = split key cmp l in (ll, pres, join rl x d r) else let (lr, pres, rr) = split key cmp r in (join l x d lr, pres, rr) type ('key,'a) iter = E | C of 'key * 'a * ('key,'a) map * ('key,'a) iter let cardinal map = let rec loop acc = function | Empty -> acc | Node (l, _, _, r, _) -> loop (loop (acc+1) r) l in loop 0 map let rec bindings_aux accu = function | Empty -> accu | Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l let bindings s = bindings_aux [] s let rec cons_iter s t = match s with | Empty -> t | Node (l, k, v, r, _) -> cons_iter l (C (k, v, r, t)) let rec rev_cons_iter s t = match s with | Empty -> t | Node (l, k, v, r, _) -> rev_cons_iter r (C (k, v, l, t)) let rec cons_iter_from cmp k2 m e = match m with | Empty -> e | Node (l, k, v, r, _) -> if cmp k2 k <= 0 then cons_iter_from cmp k2 l (C (k, v, r, e)) else cons_iter_from cmp k2 r e let enum_next l () = match !l with E -> raise BatEnum.No_more_elements | C (k, v, m, t) -> l := cons_iter m t; (k, v) let enum_backwards_next l () = match !l with E -> raise BatEnum.No_more_elements | C (k, v, m, t) -> l := rev_cons_iter m t; (k, v) let enum_count l () = let rec aux n = function | E -> n | C (_, _, m, t) -> aux (n + 1 + cardinal m) t in aux 0 !l let enum t = let rec make l = let l = ref l in let clone() = make !l in BatEnum.make ~next:(enum_next l) ~count:(enum_count l) ~clone in make (cons_iter t E) let backwards t = let rec make l = let l = ref l in let clone() = make !l in BatEnum.make ~next:(enum_backwards_next l) ~count:(enum_count l) ~clone in make (rev_cons_iter t E) let keys t = BatEnum.map fst (enum t) let values t = BatEnum.map snd (enum t) let of_enum cmp e = BatEnum.fold (fun m (k, v) -> add k v cmp m) empty e let print ?(first="{\n") ?(last="\n}") ?(sep=",\n") ?(kvsep=": ") print_k print_v out t = BatEnum.print ~first ~last ~sep (fun out (k,v) -> BatPrintf.fprintf out "%a%s%a" print_k k kvsep print_v v) out (enum t) (*We rely on [fold] rather than on ['a implementation] to make future changes of implementation in the base library's version of [Map] easier to track, even if the result is a tad slower.*) (* [filter{,i,_map} f t cmp] do not use [cmp] on [t], but only to build the result map. The unusual parameter order was chosen to reflect this. *) let filterv f t cmp = foldi (fun k a acc -> if f a then acc else remove k cmp acc) t t let filter f t cmp = foldi (fun k a acc -> if f k a then acc else remove k cmp acc) t t let filter_map f t cmp = foldi (fun k a acc -> match f k a with | None -> acc | Some v -> add k v cmp acc) t empty let for_all f map = let rec loop = function | Empty -> true | Node (l, k, v, r, _) -> f k v && loop l && loop r in loop map let exists f map = let rec loop = function | Empty -> false | Node (l, k, v, r, _) -> f k v || loop l || loop r in loop map let partition f cmp map = let rec loop m1 m2 = function | Empty -> (m1,m2) | Node (l, k, v, r, _) -> let m1, m2 = loop m1 m2 l in let m1, m2 = loop m1 m2 r in if f k v then (add k v cmp m1, m2) else (m1, add k v cmp m2) in loop empty empty map let choose = min_binding (*$= choose (empty |> add 0 1 |> add 1 1 |> choose) (empty |> add 1 1 |> add 0 1 |> choose) *) let choose_opt m = try Some (choose m) with Not_found -> None let any = function | Empty -> raise Not_found | Node (_, k, v, _, _) -> (k,v) let add_carry x d cmp map = let rec loop = function | Node (l, k, v, r, h) -> let c = cmp x k in if c = 0 then Node (l, x, d, r, h), Some v else if c < 0 then let nl,carry = loop l in bal nl k v r, carry else let nr, carry = loop r in bal l k v nr, carry | Empty -> Node (Empty, x, d, Empty, 1), None in loop map let modify x f cmp map = let rec loop = function | Node (l, k, v, r, h) -> let c = cmp x k in if c = 0 then Node (l, x, f v, r, h) else if c < 0 then let nl = loop l in bal nl k v r else let nr = loop r in bal l k v nr | Empty -> raise Not_found in loop map let modify_def v0 x f cmp map = let rec loop = function | Node (l, k, v, r, h) -> let c = cmp x k in if c = 0 then Node (l, x, f v, r, h) else if c < 0 then let nl = loop l in bal nl k v r else let nr = loop r in bal l k v nr | Empty -> Node (Empty, x, f v0, Empty, 1) in loop map let modify_opt x f cmp map = let rec loop = function | Node (l, k, v, r, h) -> let c = cmp x k in if c = 0 then match f (Some v) with | None -> merge l r | Some v' -> Node (l, x, v', r, h) else if c < 0 then let nl = loop l in bal nl k v r else let nr = loop r in bal l k v nr | Empty -> match f None with | None -> raise Exit (* fast exit *) | Some d -> Node (Empty, x, d, Empty, 1) in try loop map with Exit -> map let extract x cmp map = let rec loop = function | Node (l, k, v, r, _) -> let c = cmp x k in if c = 0 then v, merge l r else if c < 0 then let vout, nl = loop l in vout, bal nl k v r else let vout, nr = loop r in vout, bal l k v nr | Empty -> raise Not_found in loop map let pop map = match map with | Empty -> raise Not_found | Node (l, k, v, r, _) -> (k, v), merge l r (* 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 | (t, Empty) -> t | (_, _) -> let (x, d) = min_binding t2 in join t1 x d (remove_min_binding t2) let concat_or_join t1 v d t2 = match d with | Some d -> join t1 v d t2 | None -> concat t1 t2 let merge f cmp12 s1 s2 = let rec loop s1 s2 = match (s1, s2) with | (Empty, Empty) -> Empty | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 -> let (l2, d2, r2) = split v1 cmp12 s2 in (* TODO force correct evaluation order *) concat_or_join (loop l1 l2) v1 (f v1 (Some d1) d2) (loop r1 r2) | (_, Node (l2, v2, d2, r2, _h2)) -> let (l1, d1, r1) = split v2 cmp12 s1 in concat_or_join (loop l1 l2) v2 (f v2 d1 (Some d2)) (loop r1 r2) | _ -> assert false in loop s1 s2 let merge_diverse f cmp1 s1 cmp2 s2 = (* This implementation does not presuppose that the comparison function of s1 and s2 are the same. It is necessary in the PMap case, were we can't enforce that the same comparison function is used on both maps. For consistency, we will always return a result built with the comparison function of [m1]. The idea of the algorithm is the following : iterates on keys of (s1 union s2), computing the merge result for each f k (find_option k s1) (find_option k s2) , and adding values to the result s3 accordingly. The crucial point is that we need to iterate on both keys of s1 and s2. There are several possible implementations : 1. first build the union of the set of keys, then iterate on it. 2. iterate on s1, then reiterate on s2 checking that the key wasn't already in s1 3. iterate on s1, and remove keys from s2 during the traversal, then iterate on the remainder of s2. Method 1. allocates a temporary map the size of (s1 union s2), which I think is too costly. Method 3 may seem better than method 2 (as we only have at the end to iterate on the remaining keys, instead of dropping almost all keys because they were in s1 already), but is actually less efficient : the cost of removing is amortized during s1 traversal, but in effect we will, for all keys of s2, either remove it (in the first phase) or traverse it in the second phase. With method 2, we either ignore it or traverse it (both in the second phase). As removal induces rebalancing and allocation, it is indeed more costly. Method 2 only allocations and rebalancing are during the building of the final map : s1 and s2 are only looked at, never changed. This is optimal memory-wise. Those informal justifications ought to be tested with a concrete performance measurements, but the current benchmark methods, outside the module, don't make it easy to test Concrete values directly (as they're hidden by the interface). An old benchmark reports than method 2 is sensibly faster than method 1 : 2700 op/s vs 951 op/s on the test input. This algorithm is still sensibly slower than the 'merge' implementation using the same comparison on both maps : a 270% performance penalty has been measured (it runs three times slower). *) let first_phase_result = foldi (fun k v1 acc -> match f k (Some v1) (find_option k cmp2 s2) with | None -> acc | Some v3 -> add k v3 cmp1 acc) s1 empty in (* the second phase will return the result *) foldi (fun k v2 acc -> if mem k cmp1 s1 then acc else match f k None (Some v2) with | None -> acc | Some v3 -> add k v3 cmp1 acc) s2 first_phase_result (* Checks if a given map is "ordered" wrt. a given comparison function. This means that the key are ordered in strictly increasing order. If [ordered cmp s] holds, [cmp] can be used to search elements in the map *even* if it is not the original comparison function that was used to build the map; we know that the two comparison function "agree" on the present keys. Of course, adding an element with one or the other comparison function may break that relation. The [ordered] function will be useful to choose between different implementations having different comparison requirements. For example, the implementation of [merge] assuming both maps have the same comparison function is much faster than the implementation assuming heterogeneous maps. Before calling the heterogeneous implementation, one may first check if one of the comparison actually orders the other map, and in that case use the fast homogeneous implementation instead. This is the [heuristic_merge] function. *) let ordered cmp s = if s = Empty then true else try ignore (foldi (fun k _ last_k -> if cmp last_k k >= 0 then raise Exit else k) (remove_min_binding s) (fst (min_binding s))); true with Exit -> false (* Maps are considered compatible by their comparison function when either: - cmp1 and cmp2 are the *same* function (physical equality) - cmp1 is a correct ordering on m2 (see comment in [ordered]) *) let compatible_cmp cmp1 _m1 cmp2 m2 = cmp1 == cmp2 || ordered cmp1 m2 (* We first try to see if the comparison functions are compatible. If they are, then we use the [merge] function instead of a much slower [merge_diverse]. In the "same comparisons" case, we return a map ordered with the given comparison. In the other case, we arbitrarily use the comparison function of [m1]. *) let heuristic_merge f cmp1 m1 cmp2 m2 = if compatible_cmp cmp1 m1 cmp2 m2 then merge f cmp1 m1 m2 else merge_diverse f cmp1 m1 cmp2 m2 (* Binary PMap operations; When the comparison function are compatible, we use an efficient merge-based implementation. Otherwise, we compute the result so that the return comparison function is the same as the first map parameter. *) let union cmp1 m1 cmp2 m2 = if compatible_cmp cmp1 m1 cmp2 m2 then let merge_fun _k a b = if a <> None then a else b in merge merge_fun cmp2 m2 m1 else foldi (fun k v m -> add k v cmp1 m) m2 m1 let diff cmp1 m1 cmp2 m2 = if compatible_cmp cmp1 m1 cmp2 m2 then let merge_fun _k a b = if b <> None then None else a in merge merge_fun cmp1 m1 m2 else foldi (fun k _v m -> remove k cmp1 m) m2 m1 let intersect f cmp1 m1 cmp2 m2 = if compatible_cmp cmp1 m1 cmp2 m2 then let merge_fun _k a b = match a, b with | Some v1, Some v2 -> Some (f v1 v2) | None, _ | _, None -> None in merge merge_fun cmp1 m1 m2 else foldi (fun k v1 m -> match find_option k cmp2 m2 with | None -> m | Some v2 -> add k (f v1 v2) cmp1 m) m1 empty let add_seq cmp s m = BatSeq.fold_left (fun m (k, v) -> add k v cmp m) m s let of_seq cmp s = add_seq cmp s empty let rec seq_of_iter m () = match m with | E -> BatSeq.Nil | C(k, v, r, e) -> BatSeq.Cons ((k, v), seq_of_iter (cons_iter r e)) let to_seq m = seq_of_iter (cons_iter m E) let rec rev_seq_of_iter m () = match m with | E -> BatSeq.Nil | C(k, v, r, e) -> BatSeq.Cons ((k, v), rev_seq_of_iter (rev_cons_iter r e)) let to_rev_seq m = rev_seq_of_iter (rev_cons_iter m E) let to_seq_from cmp k m = seq_of_iter (cons_iter_from cmp k m E) let union_stdlib f cmp1 m1 cmp2 m2 = let fwrap a b1 b2 = match b1, b2 with | Some b1, Some b2 -> f a b1 b2 | x, None | None, x -> x in heuristic_merge fwrap cmp1 m1 cmp2 m2 let compare ckey cval m1 m2 = BatEnum.compare (fun (k1,v1) (k2,v2) -> BatOrd.bin_comp ckey k1 k2 cval v1 v2) (enum m1) (enum m2) let equal ckey eq_val m1 m2 = BatEnum.equal (fun (k1,v1) (k2,v2) -> ckey k1 k2 = 0 && eq_val v1 v2) (enum m1) (enum m2) end module type OrderedType = BatInterfaces.OrderedType module type S = sig type key type + ##V>=4.12## ! 'a t val empty: 'a t val is_empty: 'a t -> bool val cardinal: 'a t -> int val add: key -> 'a -> 'a t -> 'a t val update_stdlib: key -> ('a option -> 'a option) -> 'a t -> 'a t val update: key -> key -> 'a -> 'a t -> 'a t val find: key -> 'a t -> 'a val find_opt: key -> 'a t -> 'a option val find_default: 'a -> key -> 'a t -> 'a val find_first: (key -> bool) -> 'a t -> key * 'a val find_first_opt: (key -> bool) -> 'a t -> (key * 'a) option val find_last: (key -> bool) -> 'a t -> key * 'a val find_last_opt: (key -> bool) -> 'a t -> (key * 'a) option val remove: key -> 'a t -> 'a t val remove_exn: key -> 'a t -> 'a t val modify: key -> ('a -> 'a) -> 'a t -> 'a t val modify_def: 'a -> key -> ('a -> 'a) -> 'a t -> 'a t val modify_opt: key -> ('a option -> 'a option) -> 'a t -> 'a t val extract : key -> 'a t -> 'a * 'a t val pop : 'a t -> (key * 'a) * 'a t val mem: key -> 'a t -> bool val iter: (key -> 'a -> unit) -> 'a t -> unit val map: ('a -> 'b) -> 'a t -> 'b t val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val filterv: ('a -> bool) -> 'a t -> 'a t val filter: (key -> 'a -> bool) -> 'a t -> 'a t val filter_map: (key -> 'a -> 'b option) -> 'a t -> 'b t val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val keys : _ t -> key BatEnum.t val values: 'a t -> 'a BatEnum.t val min_binding : 'a t -> (key * 'a) val min_binding_opt : 'a t -> (key * 'a) option val pop_min_binding: 'a t -> (key * 'a) * 'a t val max_binding : 'a t -> (key * 'a) val max_binding_opt : 'a t -> (key * 'a) option val pop_max_binding: 'a t -> (key * 'a) * 'a t val choose : 'a t -> (key * 'a) val choose_opt : 'a t -> (key * 'a) option val any : 'a t -> (key * 'a) val split : key -> 'a t -> ('a t * 'a option * 'a t) val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t val singleton : key -> 'a -> 'a t val bindings : 'a t -> (key * 'a) list val enum : 'a t -> (key * 'a) BatEnum.t val backwards : 'a t -> (key * 'a) BatEnum.t val of_enum: (key * 'a) BatEnum.t -> 'a t val for_all: (key -> 'a -> bool) -> 'a t -> bool val exists: (key -> 'a -> bool) -> 'a t -> bool val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t val union: (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t val to_seq : 'a t -> (key * 'a) BatSeq.t val to_rev_seq : 'a t -> (key * 'a) BatSeq.t val to_seq_from : key -> 'a t -> (key * 'a) BatSeq.t val add_seq : (key * 'a) BatSeq.t -> 'a t -> 'a t val of_seq : (key * 'a) BatSeq.t -> 'a t (** {7 Printing}*) val print : ?first:string -> ?last:string -> ?sep:string -> ?kvsep:string -> ('a BatInnerIO.output -> key -> unit) -> ('a BatInnerIO.output -> 'c -> unit) -> 'a BatInnerIO.output -> 'c t -> unit module Exceptionless : sig val find: key -> 'a t -> 'a option val choose: 'a t -> (key * 'a) option val any: 'a t -> (key * 'a) option end module Infix : sig val (-->) : 'a t -> key -> 'a val (<--) : 'a t -> key * 'a -> 'a t end module Labels : sig val add : key:key -> data:'a -> 'a t -> 'a t val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit val map : f:('a -> 'b) -> 'a t -> 'b t val mapi : f:(key:key -> data:'a -> 'b) -> 'a t -> 'b t val filterv: f:('a -> bool) -> 'a t -> 'a t val filter: f:(key -> 'a -> bool) -> 'a t -> 'a t val fold : f:(key:key -> data:'a -> 'b -> 'b) -> 'a t -> init:'b -> 'b val compare: cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: cmp:('a -> 'a -> bool) -> 'a t -> 'a t -> bool end end module Make(Ord : OrderedType) = struct include Map.Make(Ord) (* We break the abstraction of stdlib's Map module by exposing it's underlying datatype, which is exactly ((key, 'a) Concrete.map). We therefore have O(1) conversion to and from Concrete, which allow us to add new features to the Map module while reusing stdlib's implementation (and, in fact, compiled code) for the old ones. If this was ever to be a problem, we could desynchronize our Map implementation from stdlib's, simply reusing Concrete implementations everywhere. Breaking this abstraction is not our fate, it's only a convenient choice for now. *) type 'a implementation = (key, 'a) Concrete.map external t_of_impl: 'a implementation -> 'a t = "%identity" external impl_of_t: 'a t -> 'a implementation = "%identity" let cardinal t = Concrete.cardinal (impl_of_t t) let enum t = Concrete.enum (impl_of_t t) let backwards t = Concrete.backwards (impl_of_t t) let keys t = Concrete.keys (impl_of_t t) let values t = Concrete.values (impl_of_t t) let update k1 k2 v2 t = t_of_impl (Concrete.update k1 k2 v2 Ord.compare (impl_of_t t)) let update_stdlib k f m = t_of_impl (Concrete.update_stdlib k f Ord.compare (impl_of_t m)) let find_default d k t = Concrete.find_default d k Ord.compare (impl_of_t t) let find_opt k t = Concrete.find_option k Ord.compare (impl_of_t t) let find_first f t = Concrete.find_first f (impl_of_t t) let find_first_opt f t = Concrete.find_first_opt f (impl_of_t t) let find_last f t = Concrete.find_last f (impl_of_t t) let find_last_opt f t = Concrete.find_last_opt f (impl_of_t t) let of_enum e = t_of_impl (Concrete.of_enum Ord.compare e) (* In Ocaml 3.11.2, the implementation of stdlib's Map.S.map(i) are slightly incorrect in that they don't apply their function parameter in increasing key order, as advertised in the documentation. This was fixed in 3.12. http://caml.inria.fr/mantis/view.php?id=4012 We replace map(i) implementations with the ones derived from Concrete, to have the expected evaluation order even with 3.11. *) let mapi f t = t_of_impl (Concrete.mapi f (impl_of_t t)) let map f t = t_of_impl (Concrete.map f (impl_of_t t)) let print ?first ?last ?sep ?kvsep print_k print_v out t = Concrete.print ?first ?last ?sep ?kvsep print_k print_v out (impl_of_t t) let filterv f t = t_of_impl (Concrete.filterv f (impl_of_t t) Ord.compare) let filter f t = t_of_impl (Concrete.filter f (impl_of_t t) Ord.compare) let filter_map f t = t_of_impl (Concrete.filter_map f (impl_of_t t) Ord.compare) let exists f t = Concrete.exists f (impl_of_t t) let for_all f t = Concrete.for_all f (impl_of_t t) let min_binding t = Concrete.min_binding (impl_of_t t) let pop_min_binding t = let mini, rest = Concrete.pop_min_binding (impl_of_t t) in (mini, t_of_impl rest) let max_binding t = Concrete.max_binding (impl_of_t t) let pop_max_binding t = let maxi, rest = Concrete.pop_max_binding (impl_of_t t) in (maxi, t_of_impl rest) let max_binding_opt t = Concrete.max_binding_opt (impl_of_t t) let min_binding_opt t = Concrete.min_binding_opt (impl_of_t t) let choose t = Concrete.choose (impl_of_t t) let choose_opt t = Concrete.choose_opt (impl_of_t t) let any t = Concrete.any (impl_of_t t) let split k t = let l, v, r = Concrete.split k Ord.compare (impl_of_t t) in (t_of_impl l, v, t_of_impl r) let partition p t = let l, r = Concrete.partition p Ord.compare (impl_of_t t) in (t_of_impl l, t_of_impl r) let remove_exn x m = t_of_impl (Concrete.remove_exn x Ord.compare (impl_of_t m)) let modify x f m = t_of_impl (Concrete.modify x f Ord.compare (impl_of_t m)) let modify_def v0 x f m = t_of_impl (Concrete.modify_def v0 x f Ord.compare (impl_of_t m)) let modify_opt x f m = t_of_impl (Concrete.modify_opt x f Ord.compare (impl_of_t m)) let extract k t = let (v, t') = Concrete.extract k Ord.compare (impl_of_t t) in (v, t_of_impl t') let pop t = let kv, t' = Concrete.pop (impl_of_t t) in kv, t_of_impl t' let singleton k v = t_of_impl (Concrete.singleton k v) let bindings t = Concrete.bindings (impl_of_t t) let union f m1 m2 = t_of_impl (Concrete.union_stdlib f Ord.compare (impl_of_t m1) Ord.compare (impl_of_t m2)) let merge f t1 t2 = t_of_impl (Concrete.merge f Ord.compare (impl_of_t t1) (impl_of_t t2)) let of_seq s = t_of_impl (Concrete.of_seq Ord.compare s) let add_seq s m = t_of_impl (Concrete.add_seq Ord.compare s (impl_of_t m)) let to_seq m = Concrete.to_seq (impl_of_t m) let to_rev_seq m = Concrete.to_rev_seq (impl_of_t m) let to_seq_from k m = Concrete.to_seq_from Ord.compare k (impl_of_t m) module Exceptionless = struct let find k t = try Some (find k t) with Not_found -> None let choose t = try Some (choose t) with Not_found -> None let any t = try Some (any t) with Not_found -> None end module Infix = struct let (-->) map key = find key map let (<--) map (key, value) = add key value map end module Labels = struct let add ~key ~data t = add key data t let iter ~f t = iter (fun key data -> f ~key ~data) t let map ~f t = map f t let mapi ~f t = mapi (fun key data -> f ~key ~data) t let fold ~f t ~init = fold (fun key data acc -> f ~key ~data acc) t init let compare ~cmp a b = compare cmp a b let equal ~cmp a b = equal cmp a b let filterv ~f = filterv f let filter ~f = filter f end end module Int = Make (BatInt) module Int32 = Make (BatInt32) module Int64 = Make (BatInt64) module Nativeint = Make (BatNativeint) module Float = Make (BatFloat) module Char = Make (BatChar) module String = Make (BatString) (** * PMap - Polymorphic maps *) type ('k, 'v) t = ('k, 'v) Concrete.map let empty = Concrete.empty let is_empty = Concrete.is_empty (*$T is_empty is_empty empty not(is_empty (empty |> add 1 1)) *) let add x d m = Concrete.add x d Pervasives.compare m let update k1 k2 v2 m = Concrete.update k1 k2 v2 Pervasives.compare m let update_stdlib k f m = Concrete.update_stdlib k f Pervasives.compare m (*$T update_stdlib let of_list l = of_enum (BatList.enum l) and cmp = Pervasives.( = ) in \ equal cmp (update_stdlib 1 (fun x -> assert(x = Some 1); Some 3) (of_list [1,1; 2,2])) (of_list [1,3;2,2]) let of_list l = of_enum (BatList.enum l) and cmp = Pervasives.( = ) in \ equal cmp (update_stdlib 3 (fun x -> assert(x = None); Some 3) (of_list [1,1; 2,2])) (of_list [1,1;2,2;3,3]) let of_list l = of_enum (BatList.enum l) and cmp = Pervasives.( = ) in \ equal cmp (update_stdlib 1 (fun x -> assert(x = Some 1); None) (of_list [1,1; 2,2])) (of_list [2,2]) let of_list l = of_enum (BatList.enum l) in \ let s = (of_list [1,1; 2,2]) in (update_stdlib 3 (fun x -> assert(x = None ); None ) s) == s let of_list l = of_enum (BatList.enum l) in \ let s = (of_list [1,1; 2,2]) in (update_stdlib 1 (fun x -> assert(x = Some 1); Some 1) s) == s *) let find x m = Concrete.find x Pervasives.compare m (*$T add; find empty |> add 1 true |> add 2 false |> find 1 empty |> add 1 true |> add 2 false |> find 2 |> not empty |> add 1 true |> add 2 false |> find 1 empty |> add 1 true |> add 2 false |> find 2 |> not empty |> add 2 'y' |> add 1 'x' |> find 1 = 'x' empty |> add 2 'y' |> add 1 'x' |> find 2 = 'y' *) let find_opt x m = Concrete.find_option x Pervasives.compare m (*$T find_opt find_opt 4 (add 1 2 empty) = None find_opt 1 (add 1 2 empty) = Some 2 *) let find_default def x m = Concrete.find_default def x Pervasives.compare m (*$T find_default find_default 3 4 (add 1 2 empty) = 3 find_default 3 1 (add 1 2 empty) = 2 *) let find_first f map = Concrete.find_first f map let find_first_opt f map = Concrete.find_first_opt f map let find_last f map = Concrete.find_last f map let find_last_opt f map = Concrete.find_last_opt f map (*$Q find ; add (Q.list Q.small_int) (fun xs -> \ let of_list xs y m0 = List.fold_left (fun acc x -> add x y acc) m0 xs in \ of_list (List.filter ((<>) 100) xs) false (singleton 100 true) |> find 100) *) let remove x m = Concrete.remove x Pervasives.compare m (*$Q add ; remove (Q.list Q.small_int) (fun xs -> \ let of_list xs y m0 = List.fold_left (fun acc x -> add x y acc) m0 xs in \ List.fold_left (fun acc x -> remove x acc) (of_list xs true empty) xs |> is_empty) *) let remove_exn x m = Concrete.remove_exn x Pervasives.compare m (*$Q add ; remove_exn (Q.list Q.small_int) (fun xs -> \ let xs = List.unique xs in \ let of_list xs y m0 = List.fold_left (fun acc x -> add x y acc) m0 xs in \ List.fold_left (fun acc x -> remove_exn x acc) (of_list xs true empty) xs |> is_empty) *) (*$T remove_exn try remove_exn 1 empty |> ignore ; false with Not_found -> true *) let mem x m = Concrete.mem x Pervasives.compare m let iter = Concrete.iter let map = Concrete.map let mapi = Concrete.mapi let fold = Concrete.fold let foldi = Concrete.foldi let at_rank_exn = Concrete.at_rank_exn (*$Q foldi (Q.list Q.small_int) (fun xs -> \ let m = List.fold_left (fun acc x -> add x true acc) empty xs in \ foldi (fun x _y acc -> x :: acc) m [] |> List.rev = List.sort_unique BatInt.compare xs) *) let enum = Concrete.enum (*$Q keys (Q.list Q.small_int) (fun xs -> \ List.fold_left (fun acc x -> add x true acc) \ empty xs |> keys |> List.of_enum \ = List.sort_unique BatInt.compare xs) *) let backwards = Concrete.backwards let keys t = BatEnum.map fst (enum t) let values t = BatEnum.map snd (enum t) let of_enum e = Concrete.of_enum Pervasives.compare e let print = Concrete.print let filterv f t = Concrete.filterv f t Pervasives.compare let filter f t = Concrete.filter f t Pervasives.compare let filter_map f t = Concrete.filter_map f t Pervasives.compare let choose = Concrete.choose let choose_opt = Concrete.choose_opt let any = Concrete.any let max_binding = Concrete.max_binding let min_binding = Concrete.min_binding let max_binding_opt = Concrete.max_binding_opt let min_binding_opt = Concrete.min_binding_opt let pop_min_binding = Concrete.pop_min_binding let pop_max_binding = Concrete.pop_max_binding (*$T pop_min_binding (empty |> add 1 true |> pop_min_binding) = ((1, true), empty) (empty |> add 1 true |> add 2 false |> pop_min_binding) = \ ((1, true), add 2 false empty) try ignore (pop_min_binding empty); false with Not_found -> true *) (*$T pop_max_binding (empty |> add 1 true |> pop_max_binding) = ((1, true), empty) (empty |> add 1 true |> add 2 false |> pop_max_binding) = \ ((2, false), add 1 true empty) try ignore (pop_max_binding empty); false with Not_found -> true *) (*$T choose let of_list l = of_enum (BatList.enum l) in \ (1,1) = choose (of_list [1,1]) try ignore(choose empty); false with Not_found -> true *) (*$T choose_opt let of_list l = of_enum (BatList.enum l) in \ Some (1,1) = choose_opt (of_list [1,1]) None = choose_opt (empty) *) (*$T max_binding let of_list l = of_enum (BatList.enum l) in \ (3,3) = max_binding (of_list [1,1;2,2;3,3]) try ignore(max_binding empty); false with Not_found -> true *) (*$T max_binding_opt let of_list l = of_enum (BatList.enum l) in \ Some (3,3) = max_binding_opt (of_list [1,1;2,2;3,3]) None = max_binding_opt empty *) (*$T min_binding let of_list l = of_enum (BatList.enum l) in \ (1,1) = min_binding (of_list [1,1;2,2;3,3]) try ignore(min_binding empty); false with Not_found -> true *) (*$T min_binding_opt let of_list l = of_enum (BatList.enum l) in \ Some (1,1) = min_binding_opt (of_list [1,1;2,2;3,3]) None = min_binding_opt empty *) (*$T add let s = empty |> add 1 1 |> add 2 2 in s == (s |> add 2 2) *) (*$T remove let s = empty |> add 1 1 |> add 2 2 in s == (s |> remove 4) *) (*$T update let s = empty |> add 1 1 |> add 2 2 in \ s == (s |> update 2 2 2) *) (*$T update_stdlib let s = empty |> add 1 1 |> add 2 2 in \ s == (s |> update_stdlib 2 (fun _ -> Some 2)) *) (*$T filter let s = empty |> add 1 1 |> add 2 2 in \ s == (filter (fun _ _ -> true) s) *) let of_seq s = Concrete.of_seq Pervasives.compare s let add_seq s m = Concrete.add_seq Pervasives.compare s m let to_seq = Concrete.to_seq let to_rev_seq = Concrete.to_rev_seq let to_seq_from x m = Concrete.to_seq_from Pervasives.compare x m let union_stdlib f m1 m2 = Concrete.union_stdlib f Pervasives.compare m1 Pervasives.compare m2 (*$T union_stdlib let cmp = Pervasives.( = ) in \ equal cmp (union_stdlib (fun _ -> failwith "must not be called") empty empty) empty let of_list l = of_enum (BatList.enum l) and cmp = Pervasives.( = ) in \ equal cmp (union_stdlib (fun _ -> failwith "must not be called") (of_list [1,1;2,2]) empty) (of_list [1,1;2,2]) let of_list l = of_enum (BatList.enum l) and cmp = Pervasives.( = ) in \ equal cmp (union_stdlib (fun _ -> failwith "must not be called") empty (of_list [1,1;2,2])) (of_list [1,1;2,2]) let of_list l = of_enum (BatList.enum l) and cmp = Pervasives.( = ) in \ equal cmp (union_stdlib (fun _ -> failwith "must not be called") (of_list [3,3;4,4]) (of_list [1,1;2,2])) (of_list [1,1;2,2;3,3;4,4]) *) let singleton k v = Concrete.singleton k v let for_all = Concrete.for_all let exists = Concrete.exists let partition f m = Concrete.partition f Pervasives.compare m let cardinal = Concrete.cardinal let split k m = Concrete.split k Pervasives.compare m let add_carry x d m = Concrete.add_carry x d Pervasives.compare m let modify x f m = Concrete.modify x f Pervasives.compare m let modify_def v0 x f m = Concrete.modify_def v0 x f Pervasives.compare m let modify_opt x f m = Concrete.modify_opt x f Pervasives.compare m (*$T modify_opt empty |> add 1 false |> \ modify_opt 1 (function Some false -> Some true | _ -> assert false) |> \ find 1 empty |> add 1 true |> \ modify_opt 1 (function Some true -> None | _ -> assert false) |> \ mem 1 |> not *) let extract x m = Concrete.extract x Pervasives.compare m let pop = Concrete.pop let split k m = Concrete.split k Pervasives.compare m (* We can't compare external primitives directly using the physical equality operator, since two different occurrences of an external primitive are two different closures. So we first make a local binding of [Pervasives.compare] and only then pass it to corresponding functions from Concrete. This way the physical equality check in [compatible_cmp] will work as needed *) let union m1 m2 = let comp = Pervasives.compare in Concrete.union comp m1 comp m2 (*$T union let m1 = empty |> add 1 1 |> add 2 2 in \ let m2 = empty |> add 2 20 |> add 3 30 in \ (union m1 m2 |> find 2 = 20) && (union m2 m1 |> find 2 = 2) *) let union_stdlib f m1 m2 = Concrete.union_stdlib f Pervasives.compare m1 Pervasives.compare m2 let diff m1 m2 = let comp = Pervasives.compare in Concrete.diff comp m1 comp m2 let intersect merge m1 m2 = let comp = Pervasives.compare in Concrete.intersect merge comp m1 comp m2 let merge f m1 m2 = Concrete.merge f Pervasives.compare m1 m2 let bindings = Concrete.bindings let compare cmp_val m1 m2 = Concrete.compare Pervasives.compare cmp_val m1 m2 let equal eq_val m1 m2 = Concrete.equal Pervasives.compare eq_val m1 m2 module Exceptionless = struct let find k m = try Some (find k m) with Not_found -> None let choose m = try Some (choose m) with Not_found -> None let any m = try Some (any m) with Not_found -> None end module Infix = struct let (-->) map key = find key map let (<--) map (key, value) = add key value map end include Infix module PMap = struct (*$< PMap *) (** * PMap - Polymorphic maps *) type ('k, 'v) t = { cmp : 'k -> 'k -> int; map : ('k, 'v) Concrete.map; } let create cmp = { cmp = cmp; map = Concrete.empty } let get_cmp {cmp; _} = cmp (*$T get_cmp get_cmp (create BatInt.compare) == BatInt.compare *) let empty = { cmp = Pervasives.compare; map = Concrete.empty } let get_cmp {cmp; _} = cmp let is_empty x = x.map = Concrete.Empty let add x d m = let newmap = Concrete.add x d m.cmp m.map in if newmap == m.map then m else { m with map = newmap } let update k1 k2 v2 m = let newmap = Concrete.update k1 k2 v2 m.cmp m.map in if newmap == m.map then m else { m with map = newmap } let update_stdlib k f m = let newmap = Concrete.update_stdlib k f m.cmp m.map in if newmap == m.map then m else { m with map = newmap } let find x m = Concrete.find x m.cmp m.map let find_opt x m = Concrete.find_option x m.cmp m.map let find_default def x m = Concrete.find_default def x m.cmp m.map (*$T add; find empty |> add 1 true |> add 2 false |> find 1 empty |> add 1 true |> add 2 false |> find 2 |> not create BatInt.compare |> add 1 true |> add 2 false |> find 1 create BatInt.compare |> add 1 true |> add 2 false |> find 2 |> not empty |> add 2 'y' |> add 1 'x' |> find 1 = 'x' empty |> add 2 'y' |> add 1 'x' |> find 2 = 'y' *) (*$T find_default find_default 3 4 (add 1 2 empty) = 3 find_default 3 1 (add 1 2 empty) = 2 *) let find_first f map = Concrete.find_first f map.map let find_first_opt f map = Concrete.find_first_opt f map.map let find_last f map = Concrete.find_last f map.map let find_last_opt f map = Concrete.find_last_opt f map.map (*$T update add 1 false empty |> update 1 1 true |> find 1 add 1 false empty |> update 1 2 true |> find 2 try ignore (update 1 1 false empty); false with Not_found -> true empty |> add 1 11 |> add 2 22 |> update 2 2 222 |> find 2 = 222 let m = empty |> add 1 11 |> add 2 22 in \ try ignore (m |> update 3 4 555); false with Not_found -> true *) (*$Q find ; add (Q.list Q.small_int) (fun xs -> \ let of_list xs y m0 = List.fold_left (fun acc x -> add x y acc) m0 xs in \ of_list (List.filter ((<>) 100) xs) false (singleton 100 true) |> find 100) *) let remove x m = { m with map = Concrete.remove x m.cmp m.map } (*$Q add ; remove (Q.list Q.small_int) (fun xs -> \ let of_list xs y m0 = List.fold_left (fun acc x -> add x y acc) m0 xs in \ List.fold_left (fun acc x -> remove x acc) (of_list xs true empty) xs |> is_empty) *) let remove_exn x m = { m with map = Concrete.remove_exn x m.cmp m.map } (*$Q add ; remove_exn (Q.list Q.small_int) (fun xs -> \ let xs = List.unique xs in \ let of_list xs y m0 = List.fold_left (fun acc x -> add x y acc) m0 xs in \ List.fold_left (fun acc x -> remove_exn x acc) (of_list xs true empty) xs |> is_empty) *) (*$T remove_exn add 1 false empty |> remove_exn 1 |> mem 1 |> not try remove_exn 1 empty |> ignore ; false with Not_found -> true *) let mem x m = Concrete.mem x m.cmp m.map let iter f m = Concrete.iter f m.map let map f m = { m with map = Concrete.map f m.map } let mapi f m = { m with map = Concrete.mapi f m.map } let fold f m acc = Concrete.fold f m.map acc let foldi f m acc = Concrete.foldi f m.map acc (*$Q foldi (Q.list Q.small_int) (fun xs -> \ let m = List.fold_left (fun acc x -> add x true acc) (create BatInt.compare) xs in \ foldi (fun x _y acc -> x :: acc) m [] |> List.rev = List.sort_unique BatInt.compare xs) *) let at_rank_exn i m = Concrete.at_rank_exn i m.map let enum t = Concrete.enum t.map (*$Q keys (Q.list Q.small_int) (fun xs -> \ List.fold_left (fun acc x -> add x true acc) \ (create BatInt.compare) xs |> keys |> List.of_enum \ = List.sort_unique BatInt.compare xs) *) let backwards t = Concrete.backwards t.map let keys t = BatEnum.map fst (enum t) let values t = BatEnum.map snd (enum t) let of_enum ?(cmp = Pervasives.compare) e = { cmp = cmp; map = Concrete.of_enum cmp e } let print ?first ?last ?sep ?kvsep print_k print_v out t = Concrete.print ?first ?last ?sep ?kvsep print_k print_v out t.map let filterv f t = { t with map = Concrete.filterv f t.map t.cmp } let filter_map f t = { t with map = Concrete.filter_map f t.map t.cmp } let filter f t = let newmap = Concrete.filter f t.map t.cmp in if newmap == t.map then t else { t with map = newmap } let max_binding t = Concrete.max_binding t.map let min_binding t = Concrete.min_binding t.map let max_binding_opt t = Concrete.max_binding_opt t.map let min_binding_opt t = Concrete.min_binding_opt t.map let pop_min_binding m = let mini, rest = Concrete.pop_min_binding m.map in (mini, { m with map = rest }) let pop_max_binding m = let maxi, rest = Concrete.pop_max_binding m.map in (maxi, { m with map = rest }) let singleton ?(cmp = Pervasives.compare) k v = { cmp = cmp; map = Concrete.singleton k v } let for_all f m = Concrete.for_all f m.map let exists f m = Concrete.exists f m.map let partition f m = let l, r = Concrete.partition f m.cmp m.map in { m with map = l }, { m with map = r } let cardinal m = Concrete.cardinal m.map let choose m = Concrete.choose m.map let choose_opt m = Concrete.choose_opt m.map let any m = Concrete.any m.map let split k m = let (l, v, r) = Concrete.split k m.cmp m.map in { m with map = l }, v, { m with map = r } let add_carry x d m = let map', carry = Concrete.add_carry x d m.cmp m.map in { m with map = map' }, carry let modify x f m = { m with map = Concrete.modify x f m.cmp m.map } let modify_def v0 x f m = { m with map = Concrete.modify_def v0 x f m.cmp m.map } let modify_opt x f m = { m with map = Concrete.modify_opt x f m.cmp m.map } let extract x m = let out, map' = Concrete.extract x m.cmp m.map in out, { m with map = map' } let pop m = let out, map' = Concrete.pop m.map in out, { m with map = map' } let split k m = let (l, v, r) = Concrete.split k m.cmp m.map in { m with map = l }, v, { m with map = r } let union m1 m2 = { m1 with map = Concrete.union m1.cmp m1.map m2.cmp m2.map } let diff m1 m2 = { m1 with map = Concrete.diff m1.cmp m1.map m2.cmp m2.map } let intersect merge m1 m2 = { m1 with map = Concrete.intersect merge m1.cmp m1.map m2.cmp m2.map } let merge f m1 m2 = { m1 with map = Concrete.heuristic_merge f m1.cmp m1.map m2.cmp m2.map } let merge_unsafe f m1 m2 = { m1 with map = Concrete.merge f m1.cmp m1.map m2.map } let of_seq ?(cmp = Pervasives.compare) s = { map = Concrete.of_seq cmp s; cmp = cmp } let to_seq m = Concrete.to_seq m.map let to_rev_seq m = Concrete.to_rev_seq m.map let to_seq_from k m = Concrete.to_seq_from m.cmp k m.map let add_seq s m = { m with map = Concrete.add_seq m.cmp s m.map } let union_stdlib f m1 m2 = { m1 with map = Concrete.union_stdlib f m1.cmp m1.map m2.cmp m2.map } let bindings m = Concrete.bindings m.map let compare cmp_val m1 m2 = Concrete.compare m1.cmp cmp_val m1.map m2.map let equal eq_val m1 m2 = Concrete.equal m1.cmp eq_val m1.map m2.map module Exceptionless = struct let find k m = try Some (find k m) with Not_found -> None let choose m = try Some (choose m) with Not_found -> None let any m = try Some (any m) with Not_found -> None end module Infix = struct let (-->) map key = find key map let (<--) map (key, value) = add key value map end include Infix end (*$>*) batteries-included-3.4.0/src/batMarshal.mliv000066400000000000000000000165771415601150500210410ustar00rootroot00000000000000(* * BatMarshal - Extended marshaling operations * Copyright (C) 1997 Xavier Leroy * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Marshaling of data structures. This module provides functions to encode arbitrary data structures as sequences of bytes, which can then be written on a file or sent over a pipe or network connection. The bytes can then be read back later, possibly in another process, and decoded back into a data structure. The format for the byte sequences is compatible across all machines for a given version of OCaml. Warning: marshaling is currently not type-safe. The type of marshaled data is not transmitted along the value of the data, making it impossible to check that the data read back possesses the type expected by the context. In particular, the result type of the [Marshal.from_*] functions is given as ['a], but this is misleading: the returned OCaml value does not possess type ['a] for all ['a]; it has one, unique type which cannot be determined at compile-type. The programmer should explicitly give the expected type of the returned value, using the following syntax: - [(Marshal.from_channel chan : type)]. Anything can happen at run-time if the object in the file does not belong to the given type. The representation of marshaled values is not human-readable, and uses bytes that are not printable characters. Therefore, input and output channels used in conjunction with {!Marshal.output} and {!Marshal.input} must be opened in binary mode, using e.g. {!BatPervasives.open_out_bin} or {!BatPervasives.open_in_bin}; channels opened in text mode will cause unmarshaling errors on platforms where text channels behave differently than binary channels, e.g. Windows. @author Xavier Leroy (base module) @author David Teller *) type extern_flags = Marshal.extern_flags = No_sharing (** Don't preserve sharing *) | Closures (** Send function closures *) ##V>=4.1## | Compat_32 (** Ensure 32-bit compatibility *) (** The flags to the [Marshal.to_*] functions below. *) val output: _ BatInnerIO.output -> ?sharing:bool -> ?closures:bool -> 'a -> unit (** [output out v] writes the representation of [v] on [chan]. @param sharing If [true] (default value), circularities and sharing inside the value [v] are detected and preserved in the sequence of bytes produced. In particular, this guarantees that marshaling always terminates. Sharing between values marshaled by successive calls to [output] is not detected, though. If [false], sharing is ignored. This results in faster marshaling if [v] contains no shared substructures, but may cause slower marshaling and larger byte representations if [v] actually contains sharing, or even non-termination if [v] contains cycles. @param closures If [false] (default value) marshaling fails when it encounters a functional value inside [v]: only ``pure'' data structures, containing neither functions nor objects, can safely be transmitted between different programs. If [true], functional values will be marshaled as a position in the code of the program. In this case, the output of marshaling can only be read back in processes that run exactly the same program, with exactly the same compiled code. (This is checked at un-marshaling time, using an MD5 digest of the code transmitted along with the code position.) *) ##V<4.7##external to_bytes : ##V<4.7## 'a -> extern_flags list -> Bytes.t = "caml_output_value_to_string" ##V>=4.7##external to_bytes : ##V>=4.7## 'a -> extern_flags list -> Bytes.t = "caml_output_value_to_bytes" (** [Marshal.to_bytes v flags] returns a byte sequence containing the representation of [v]. The [flags] argument has the same meaning as for {!Marshal.output}. @since 2.3.0 *) external to_string : 'a -> extern_flags list -> string = "caml_output_value_to_string" (** Same as [to_bytes] but return the result as a string instead of a byte sequence. *) val to_buffer : Bytes.t -> int -> int -> 'a -> extern_flags list -> int (** [Marshal.to_buffer buff ofs len v flags] marshals the value [v], storing its byte representation in the sequence [buff], starting at index [ofs], and writing at most [len] bytes. It returns the number of bytes actually written to the sequence. If the byte representation of [v] does not fit in [len] characters, the exception [Failure] is raised. *) val input : BatInnerIO.input -> 'a (** [input inp] reads from [inp] the byte representation of a structured value, as produced by one of the [Marshal.to_*] functions, and reconstructs and returns the corresponding value.*) val from_bytes : Bytes.t -> int -> 'a (** [Marshal.from_bytes buff ofs] unmarshals a structured value like {!Marshal.from_channel} does, except that the byte representation is not read from a channel, but taken from the byte sequence [buff], starting at position [ofs]. The byte sequence is not mutated. @since 2.3.0 *) val from_string : string -> int -> 'a (** Same as [from_bytes] but take a string as argument instead of a byte sequence. *) val header_size : int (** The bytes representing a marshaled value are composed of a fixed-size header and a variable-sized data part, whose size can be determined from the header. {!Marshal.header_size} is the size, in bytes, of the header. {!Marshal.data_size}[ buff ofs] is the size, in bytes, of the data part, assuming a valid header is stored in [buff] starting at position [ofs]. Finally, {!Marshal.total_size} [buff ofs] is the total size, in bytes, of the marshaled value. Both {!Marshal.data_size} and {!Marshal.total_size} raise [Failure] if [buff], [ofs] does not contain a valid header. To read the byte representation of a marshaled value into a byte sequence, the program needs to read first {!Marshal.header_size} bytes into the sequence, then determine the length of the remainder of the representation using {!Marshal.data_size}, make sure the sequence is large enough to hold the remaining data, then read it, and finally call {!Marshal.from_bytes} to unmarshal the value. *) val data_size : Bytes.t -> int -> int (** See {!Marshal.header_size}.*) val total_size : Bytes.t -> int -> int (** See {!Marshal.header_size}.*) (** {6 Deprecated} *) val to_channel : _ BatInnerIO.output -> 'a -> extern_flags list -> unit (** @deprecated Use {!output} instead *) val from_channel : BatInnerIO.input -> 'a (** @deprecated Use {!input} instead *) batteries-included-3.4.0/src/batMarshal.mlv000066400000000000000000000034771415601150500206630ustar00rootroot00000000000000(* * BatMarshal - Extended marshaling operations * Copyright (C) 1997 Xavier Leroy * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) include Marshal ##V<4.2##let from_bytes = from_string ##V<4.2##external to_bytes : ##V<4.2## 'a -> extern_flags list -> Bytes.t = "caml_output_value_to_string" let output out ?(sharing=true) ?(closures=false) v = let flags = match sharing, closures with | true, false -> [] | true, true -> [Closures] | false, false -> [No_sharing] | false, true -> [No_sharing; Closures] in let buf = to_string v flags in BatInnerIO.nwrite out buf let input inp = let header = Bytes.create header_size in let read = BatInnerIO.really_input inp header 0 header_size in assert (read = header_size); let data_size = data_size header 0 in let buf = Bytes.extend header 0 data_size in let read = BatInnerIO.really_input inp buf header_size data_size in assert (read = data_size); from_bytes buf 0 let from_channel = input let to_channel out v flags = BatInnerIO.nwrite out (to_string v flags) batteries-included-3.4.0/src/batMultiMap.ml000066400000000000000000000043631415601150500206310ustar00rootroot00000000000000(* * MultiMap - Polymorphic maps with multiple associations * Copyright (C) 1996-2003 Xavier Leroy, Nicolas Cannasse, Markus Mottl * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type ('a, 'b) t = ('a, 'b BatSet.t) BatMap.t let empty = BatMap.empty let is_empty = BatMap.is_empty let find k t = try BatMap.find k t with Not_found -> BatSet.empty let add k d t = BatMap.modify_def BatSet.empty k (BatSet.add d) t let remove_all k t = BatMap.remove k t let remove k d t = try let set = BatSet.remove d (BatMap.find k t) in if BatSet.is_empty set then BatMap.remove k t else BatMap.add k set t; with Not_found -> t let mem = BatMap.mem (* let exists = mem *) let iter = BatMap.iter let map = BatMap.map let mapi = BatMap.mapi let fold = BatMap.fold let foldi = BatMap.foldi let modify = BatMap.modify let modify_def = BatMap.modify_def let modify_opt = BatMap.modify_opt let (|>) x f = f x let enum t = BatMap.enum t |> BatEnum.map (fun (k,s) -> BatSet.enum s |> BatEnum.map (fun x -> (k,x))) |> BatEnum.concat let of_enum e = BatEnum.fold (fun acc (k,d) -> add k d acc) empty e let print ?(first="{\n") ?(last="\n}") ?(sep=",\n") ?(kvsep=": ") print_k print_v out t = let print_one out (k,v) = BatPrintf.fprintf out "%a%s%a" print_k k kvsep print_v v in BatEnum.print ~first ~last ~sep print_one out (enum t) module Infix = struct let (-->) map key = find key map let (<--) map (key, value) = add key value map end batteries-included-3.4.0/src/batMultiMap.mli000066400000000000000000000126261415601150500210030ustar00rootroot00000000000000(* * MultiPMap - Polymorphic maps with multiple associations * Copyright (C) 1996-2003 Xavier Leroy, Nicolas Cannasse, Markus Mottl * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Polymorphic Multi-Map. This is a polymorphic multi-map, i.e. an association from 1 to many. This implementation uses [Pervasives.compare] to compare both keys and values. @author Xavier Leroy @author Nicolas Cannasse @author Markus Mottle @author David Teller *) type ('a, 'b) t val empty : ('a, 'b) t (** The empty map, using [compare] as key comparison function. *) val is_empty : ('a, 'b) t -> bool (** returns true if the map is empty. *) val add : 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t (** [add x y m] returns a map containing the same bindings as [m], plus a binding of [x] to [y].*) val find : 'a -> ('a, 'b) t -> 'b BatSet.t (** [find x m] returns the current binding of [x] in [m]*) val remove_all : 'a -> ('a, 'b) t -> ('a, 'b) t (** [remove_all x m] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map. *) val remove : 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t (** [remove k d m] returns a map containing the same bindings as [m], except for [k] which is not bound to [d] anymore in the returned map. If [k] was not bound to [d], nothing is changed. If the operation removes the last binding of [k], then [k] is also removed from the set of keys.*) val mem : 'a -> ('a, 'b) t -> bool (** [mem x m] returns [true] if [m] contains at least a binding for [x], and [false] otherwise. *) val iter : ('a -> 'b BatSet.t-> unit) -> ('a, 'b) t -> unit (** [iter f m] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated value as second argument. The order in which the bindings are passed to [f] is unspecified. Only current bindings are presented to [f]: bindings hidden by more recent bindings are not passed to [f]. *) val map : ('b BatSet.t -> 'c BatSet.t) -> ('a, 'b) t -> ('a, 'c) t (** [map f m] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been replaced by the result of the application of [f] to [a]. The order in which the associated values are passed to [f] is unspecified. *) val mapi : ('a -> 'b BatSet.t -> 'c BatSet.t) -> ('a, 'b) t -> ('a, 'c) t (** Same as [map], but the function receives as arguments both the key and the associated value for each binding of the map. *) val fold : ('b BatSet.t -> 'c -> 'c) -> ('a , 'b) t -> 'c -> 'c (** [fold f m a] computes [(f kN dN ... (f k1 d1 (f k0 d0 a))...)], where [k0,k1..kN] are the keys of all bindings in [m], and [d0,d1..dN] are the associated data. The order in which the bindings are presented to [f] is unspecified. *) val foldi : ('a -> 'b BatSet.t -> 'c -> 'c) -> ('a , 'b) t -> 'c -> 'c (** Same as [fold], but the function receives as arguments both the key and the associated value for each binding of the map. *) val modify : 'a -> ('b BatSet.t -> 'b BatSet.t) -> ('a, 'b) t -> ('a, 'b) t (** [modify x f m] replaces the binding for [x] with [f] applied to these values. @since 2.1 @raise Not_found is [x] is unbound in [m] *) val modify_def : 'b BatSet.t -> 'a -> ('b BatSet.t -> 'b BatSet.t) -> ('a, 'b) t -> ('a, 'b) t (** [modify_def dfl x f m] performs as [modify x f m] but it adds [f dfl] in [m] instead of raising [Not_found] if [x] was unbound. @since 2.1 *) val modify_opt: 'a -> ('b BatSet.t option -> 'b BatSet.t option) -> ('a, 'b) t -> ('a, 'b) t (** [modify_opt x f m] allows to modify the bindings for [k] in [m] or absence thereof. @since 2.1 *) val enum : ('a, 'b) t -> ('a * 'b) BatEnum.t (** creates an enumeration for this map. *) val of_enum : ('a * 'b) BatEnum.t -> ('a, 'b) t (** creates a map from an enumeration, using the specified function for key comparison or [compare] by default. *) (** Infix operators over a {!BatMultiPMap} *) module Infix : sig val (-->) : ('a, 'b) t -> 'a -> 'b BatSet.t (** [map-->key] returns the current binding of [key] in [map]. Equivalent to [find key map]. *) val (<--) : ('a, 'b) t -> 'a * 'b -> ('a, 'b) t (** [map<--(key, value)] returns a map containing the same bindings as [map], plus a binding of [key] to [value]. Equivalent to [add key value map] *) end (** {6 Boilerplate code}*) (** {7 Printing}*) val print : ?first:string -> ?last:string -> ?sep:string -> ?kvsep:string -> ('a BatInnerIO.output -> 'b -> unit) -> ('a BatInnerIO.output -> 'c -> unit) -> 'a BatInnerIO.output -> ('b, 'c) t -> unit batteries-included-3.4.0/src/batMultiPMap.ml000066400000000000000000000061431415601150500207470ustar00rootroot00000000000000(* * MultiPMap - Polymorphic maps with multiple associations * Copyright (C) 1996-2003 Xavier Leroy, Nicolas Cannasse, Markus Mottl * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module S = BatSet.PSet module M = BatMap.PMap type ('a, 'b) t = { content : ('a, 'b S.t) M.t; keys : 'a -> 'a -> int; data : 'b -> 'b -> int } let empty = {content = M.empty; keys = compare; data = compare} let is_empty t = M.is_empty t.content let create keys data = { content = M.create keys; data = data; keys = keys } let find k t = try M.find k t.content with Not_found -> S.create t.data let add k d t = {(t) with content = M.add k (S.add d (find k t)) t.content} let remove_all k t = {(t) with content = M.remove k t.content} let remove k d t = try let set = S.remove d (M.find k t.content) in {(t) with content = if S.is_empty set then M.remove k t.content else M.add k set t.content; } with Not_found -> t let mem k d = M.mem k d.content (* let exists = mem *) let iter f d = M.iter f d.content let map (f:('b S.t -> 'c S.t)) (cmp:('b -> 'b -> int) -> ('c -> 'c -> int)) (t:('a, 'b) t) = { content = M.map f t.content; keys = t.keys; data = cmp t.data} let mapi (f:('a -> 'b S.t -> 'c S.t)) (cmp:('b -> 'b -> int) -> ('c -> 'c -> int)) (t:('a, 'b) t) = { content = M.mapi f t.content; keys = t.keys; data = cmp t.data} let fold f d i = M.fold f d.content i let foldi f d i = M.foldi f d.content i let modify k f t = {t with content = M.modify k f t.content} let modify_def dft k f t = {t with content = M.modify_def dft k f t.content} let modify_opt k f t = {t with content = M.modify_opt k f t.content} let enum t = BatEnum.concat (BatEnum.map (fun (k,e) -> BatEnum.map (fun x -> (k,x)) (S.enum e)) (M.enum t.content)) let of_enum ?(keys=compare) ?(data=compare) e = let base = create keys data in BatEnum.fold (fun acc (k,d) -> add k d acc) base e let print ?(first="{\n") ?(last="\n}") ?(sep=",\n") ?(kvsep=": ") print_k print_v out t = BatEnum.print ~first ~last ~sep (fun out (k, v) -> BatPrintf.fprintf out "%a%s%a" print_k k kvsep print_v v) out (enum t) module Infix = struct let (-->) map key = find key map let (<--) map (key, value) = add key value map end batteries-included-3.4.0/src/batMultiPMap.mli000066400000000000000000000135701415601150500211220ustar00rootroot00000000000000(* * MultiPMap - Polymorphic maps with multiple associations * Copyright (C) 1996-2003 Xavier Leroy, Nicolas Cannasse, Markus Mottl * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Polymorphic Multi-Map. This is a polymorphic multi-map, i.e. an association from 1 to many. @author Xavier Leroy @author Nicolas Cannasse @author Markus Mottle @author David Teller *) type ('a, 'b) t val empty : ('a, 'b) t (** The empty map, using [compare] as comparison function for both keys and values. *) val is_empty : ('a, 'b) t -> bool (** returns true if the map is empty. *) val create : ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t (** [create kcomp vcomp] creates a new empty map, using kcomp for key comparison and vcomp for value comparison.*) val add : 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t (** [add x y m] returns a map containing the same bindings as [m], plus a binding of [x] to [y].*) val find : 'a -> ('a, 'b) t -> 'b BatSet.PSet.t (** [find x m] returns the current binding of [x] in [m]*) val remove_all : 'a -> ('a, 'b) t -> ('a, 'b) t (** [remove_all x m] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map. *) val remove : 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t (** [remove k d m] returns a map containing the same bindings as [m], except for [k] which is not bound to [d] anymore in the returned map. If [k] was not bound to [d], nothing is changed. If the operation removes the last binding of [k], then [k] is also removed from the set of keys.*) val mem : 'a -> ('a, 'b) t -> bool (** [mem x m] returns [true] if [m] contains at least a binding for [x], and [false] otherwise. *) val iter : ('a -> 'b BatSet.PSet.t-> unit) -> ('a, 'b) t -> unit (** [iter f m] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated value as second argument. The order in which the bindings are passed to [f] is unspecified. Only current bindings are presented to [f]: bindings hidden by more recent bindings are not passed to [f]. *) val map : ('b BatSet.PSet.t -> 'c BatSet.PSet.t) -> (('b -> 'b -> int) -> ('c -> 'c -> int)) -> ('a, 'b) t -> ('a, 'c) t (** [map f vcompgen m] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been replaced by the result of the application of [f] to [a]. The order in which the associated values are passed to [f] is unspecified. [vcompgen] will use the vcomp function provided to [m] as an argument to generate a new value comparison function. *) val mapi : ('a -> 'b BatSet.PSet.t -> 'c BatSet.PSet.t) -> (('b -> 'b -> int) -> ('c -> 'c -> int)) -> ('a, 'b) t -> ('a, 'c) t (** Same as [map], but the function receives as arguments both the key and the associated value for each binding of the map. *) val fold : ('b BatSet.PSet.t -> 'c -> 'c) -> ('a , 'b) t -> 'c -> 'c (** [fold f m a] computes [(f kN dN ... (f k1 d1 (f k0 d0 a))...)], where [k0,k1..kN] are the keys of all bindings in [m], and [d0,d1..dN] are the associated data. The order in which the bindings are presented to [f] is unspecified. *) val foldi : ('a -> 'b BatSet.PSet.t -> 'c -> 'c) -> ('a , 'b) t -> 'c -> 'c (** Same as [fold], but the function receives as arguments both the key and the associated value for each binding of the map. *) val modify : 'a -> ('b BatSet.PSet.t -> 'b BatSet.PSet.t) -> ('a, 'b) t -> ('a, 'b) t (** [modify x f m] replaces the binding for [x] with [f] applied to these values. @since 2.1 @raise Not_found is [x] is unbound in [m] *) val modify_def : 'b BatSet.PSet.t -> 'a -> ('b BatSet.PSet.t -> 'b BatSet.PSet.t) -> ('a, 'b) t -> ('a, 'b) t (** [modify_def dfl x f m] performs as [modify x f m] but it adds [f dfl] in [m] instead of raising [Not_found] if [x] was unbound. @since 2.1 *) val modify_opt: 'a -> ('b BatSet.PSet.t option -> 'b BatSet.PSet.t option) -> ('a, 'b) t -> ('a, 'b) t (** [modify_opt x f m] allows to modify the bindings for [k] in [m] or absence thereof. @since 2.1 *) val enum : ('a, 'b) t -> ('a * 'b) BatEnum.t (** creates an enumeration for this map. *) val of_enum : ?keys:('a -> 'a -> int) -> ?data:('b -> 'b -> int) -> ('a * 'b) BatEnum.t -> ('a, 'b) t (** creates a map from an enumeration, using the specified function for key comparison or [compare] by default. *) (** Infix operators over a {!BatMultiPMap} *) module Infix : sig val (-->) : ('a, 'b) t -> 'a -> 'b BatSet.PSet.t (** [map-->key] returns the current binding of [key] in [map]. Equivalent to [find key map]. *) val (<--) : ('a, 'b) t -> 'a * 'b -> ('a, 'b) t (** [map<--(key, value)] returns a map containing the same bindings as [map], plus a binding of [key] to [value]. Equivalent to [add key value map] *) end (** {6 Boilerplate code}*) (** {7 Printing}*) val print : ?first:string -> ?last:string -> ?sep:string -> ?kvsep:string -> ('a BatInnerIO.output -> 'b -> unit) -> ('a BatInnerIO.output -> 'c -> unit) -> 'a BatInnerIO.output -> ('b, 'c) t -> unit batteries-included-3.4.0/src/batMutex.ml000066400000000000000000000042001415601150500201710ustar00rootroot00000000000000(* * BatMutex - Additional functions for Mutexes * Copyright (C) 1996 Xavier Leroy * 1996 Damien Doligez * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module DebugMutex = struct module M = struct type t = { mutex : Mutex.t; id : int } let unique = let counter = ref 0 and mutex = Mutex.create () in fun () -> Mutex.lock mutex; let result = !counter in incr counter; Mutex.unlock mutex; result let create () = { mutex = Mutex.create () ; id = unique () } let lock t = Printf.eprintf "[Mutex] Attempting to lock mutex %d\n" t.id; Mutex.lock t.mutex; Printf.eprintf "[Mutex] Mutex %d locked\n" t.id let unlock t = Printf.eprintf "[Mutex] Attempting to unlock mutex %d\n" t.id; Mutex.unlock t.mutex; Printf.eprintf "[Mutex] Mutex %d unlocked\n" t.id let try_lock t = Printf.eprintf "[Mutex] Attempting to trylock mutex %d\n" t.id; let result = Mutex.try_lock t.mutex in Printf.eprintf "[Mutex] Mutex %d trylocked\n" t.id; result end include M module Lock = BatConcurrent.MakeLock(M) let make = Lock.make let synchronize = Lock.synchronize end module Lock = BatConcurrent.MakeLock(Mutex) let make = Lock.make let synchronize = Lock.synchronize batteries-included-3.4.0/src/batMutex.mli000066400000000000000000000102301415601150500203420ustar00rootroot00000000000000(* * BatMutex - Additional functions for Mutexes * Copyright (C) 1996 Xavier Leroy * 1996 Damien Doligez * 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Locks for mutual exclusion. Mutexes (mutual-exclusion locks) are used to implement critical sections and protect shared mutable data structures against concurrent accesses. The typical use is (if [m] is the mutex associated with the data structure [D]): {[ Mutex.synchronize ~lock:m (fun () -> (* Critical section that operates over D *); ) () ]} This module implements {!Control.Concurrency.Common} @author Xavier Leroy (Base module) @author Damien Doligez (Base module) @author David Teller *) open Mutex val synchronize : ?lock:t -> ('a -> 'b) -> 'a -> 'b (** Protect a function. [synchronize f] returns a new function [f'] with the same behavior as [f] but such that concurrent calls to [f'] are queued if necessary to avoid races. [synchronize ~lock:l f] behaves as [synchronize f] but uses a user-specified lock [l], which may be useful to share a lock between several function. This is necessary in particular when the lock is specific to a data structure rather than to a function. In either case, the lock is acquired when entering the function and released when the function call ends, whether this is due to normal termination or to some exception being raised. *) val make : unit -> BatConcurrent.lock (** Create a new abstract lock based on Mutexes. *) (**/**) module DebugMutex: sig type t (** The type of mutexes. *) val create : unit -> t (** Return a new mutex. *) val lock : t -> unit (** Lock the given mutex. Only one thread can have the mutex locked at any time. A thread that attempts to lock a mutex already locked will suspend until the other mutex is unlocked. {b Note} attempting to lock a mutex you already have locked from the same thread will also suspend your thread, possibly forever. If this is not what you want, take a look at module {!RMutex}. *) val try_lock : t -> bool (** Same as {!Mutex.lock}, but does not suspend the calling thread if the mutex is already locked: just return [false] immediately in that case. If the mutex is unlocked, lock it and return [true]. *) val unlock : t -> unit (** Unlock the given mutex. Other threads suspended trying to lock the mutex will restart. If the mutex wasn't locked, nothing happens.*) val synchronize : ?lock:t -> ('a -> 'b) -> 'a -> 'b (** Protect a function. [synchronize f] returns a new function [f'] with the same behavior as [f] but such that concurrenty calls to [f'] are queued if necessary to avoid races. [synchronize ~lock:l f] behaves as [synchronize f] but uses a user-specified lock [l], which may be useful to share a lock between several function. This is necessary in particular when the lock is specific to a data structure rather than to a function. In either case, the lock is acquired when entering the function and released when the function call ends, whether this is due to normal termination or to some exception being raised. *) val make : unit -> BatConcurrent.lock (** Create a new abstract lock based on Mutexes. *) end (**/**) batteries-included-3.4.0/src/batNativeint.mliv000066400000000000000000000257151415601150500214050ustar00rootroot00000000000000(* * BatNativeint - Extended native ints * Copyright (C) 2005 Xavier Leroy * 2007 Bluestorm * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Processor-native integers. This module provides operations on the type [nativeint] of signed 32-bit integers (on 32-bit platforms) or signed 64-bit integers (on 64-bit platforms). This integer type has exactly the same width as that of a [long] integer type in the C compiler. All arithmetic operations over [nativeint] are taken modulo 2{^32} or 2{^64} depending on the word size of the architecture. Performance notice: values of type [nativeint] occupy more memory space than values of type [int], and arithmetic operations on [nativeint] are generally slower than those on [int]. Use [nativeint] only when the application requires the extra bit of precision over the [int] type. Any integer literal followed by [n] is taken to be a [nativeint]. For instance, [1n] is {!Native_int.one}. This module extends Stdlib's {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Nativeint.html}Nativeint} module, go there for documentation on the rest of the functions and types. @author Xavier Leroy (base module) @author Gabriel Scherer @author David Teller *) type t = nativeint (** An alias for the type of native integers. *) val zero : nativeint (** The native integer 0.*) val one : nativeint (** The native integer 1.*) val minus_one : nativeint (** The native integer -1.*) external neg : nativeint -> nativeint = "%nativeint_neg" (** Unary negation. *) external add : nativeint -> nativeint -> nativeint = "%nativeint_add" (** Addition. *) external sub : nativeint -> nativeint -> nativeint = "%nativeint_sub" (** Subtraction. *) external mul : nativeint -> nativeint -> nativeint = "%nativeint_mul" (** Multiplication. *) external div : nativeint -> nativeint -> nativeint = "%nativeint_div" (** Integer division. @raise Division_by_zero if the second argument is zero. This division rounds the real quotient of its arguments towards zero, as specified for {!Pervasives.(/)}. *) ##V>=4.08##val unsigned_div : nativeint -> nativeint -> nativeint ##V>=4.08##(** Same as {!div}, except that arguments and result are interpreted as {e ##V>=4.08## unsigned} native integers. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) external rem : nativeint -> nativeint -> nativeint = "%nativeint_mod" (** Integer remainder. If [y] is not zero, the result of [Nativeint.rem x y] satisfies the following properties: [Nativeint.zero <= Nativeint.rem x y < Nativeint.abs y] and [x = Nativeint.add (Nativeint.mul (Nativeint.div x y) y) (Nativeint.rem x y)]. If [y = 0], [Nativeint.rem x y] raises [Division_by_zero]. *) ##V>=4.08##val unsigned_rem : nativeint -> nativeint -> nativeint ##V>=4.08##(** Same as {!rem}, except that arguments and result are interpreted as {e ##V>=4.08## unsigned} native integers. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) val succ : nativeint -> nativeint (** Successor. [Nativeint.succ x] is [Nativeint.add x Nativeint.one]. *) val pred : nativeint -> nativeint (** Predecessor. [Nativeint.pred x] is [Nativeint.sub x Nativeint.one]. *) val abs : nativeint -> nativeint (** Return the absolute value of its argument. *) val size : int (** The size in bits of a native integer. This is equal to [32] on a 32-bit platform and to [64] on a 64-bit platform. *) val max_int : nativeint (** The greatest representable native integer, either 2{^31} - 1 on a 32-bit platform, or 2{^63} - 1 on a 64-bit platform. *) val min_int : nativeint (** The greatest representable native integer, either -2{^31} on a 32-bit platform, or -2{^63} on a 64-bit platform. *) external logand : nativeint -> nativeint -> nativeint = "%nativeint_and" (** Bitwise logical and. *) external logor : nativeint -> nativeint -> nativeint = "%nativeint_or" (** Bitwise logical or. *) external logxor : nativeint -> nativeint -> nativeint = "%nativeint_xor" (** Bitwise logical exclusive or. *) val lognot : nativeint -> nativeint (** Bitwise logical negation *) external shift_left : nativeint -> int -> nativeint = "%nativeint_lsl" (** [Nativeint.shift_left x y] shifts [x] to the left by [y] bits. The result is unspecified if [y < 0] or [y >= bitsize], where [bitsize] is [32] on a 32-bit platform and [64] on a 64-bit platform. *) external shift_right : nativeint -> int -> nativeint = "%nativeint_asr" (** [Nativeint.shift_right x y] shifts [x] to the right by [y] bits. This is an arithmetic shift: the sign bit of [x] is replicated and inserted in the vacated bits. The result is unspecified if [y < 0] or [y >= bitsize]. *) external shift_right_logical : nativeint -> int -> nativeint = "%nativeint_lsr" (** [Nativeint.shift_right_logical x y] shifts [x] to the right by [y] bits. This is a logical shift: zeroes are inserted in the vacated bits regardless of the sign of [x]. The result is unspecified if [y < 0] or [y >= bitsize]. *) val ( -- ) : t -> t -> t BatEnum.t (** Enumerate an interval. [5n -- 10n] is the enumeration 5n,6n,7n,8n,9n,10n. [10n -- 5n] is the empty enumeration*) val ( --- ) : t -> t -> t BatEnum.t (** Enumerate an interval. [5n -- 10n] is the enumeration 5n,6n,7n,8n,9n,10n. [10n -- 5n] is the enumeration 10n,9n,8n,7n,6n,5n.*) external of_int : int -> nativeint = "%nativeint_of_int" (** Convert the given integer (type [int]) to a native integer (type [nativeint]). *) external to_int : nativeint -> int = "%nativeint_to_int" (** Convert the given native integer (type [nativeint]) to an integer (type [int]). The high-order bit is lost during the conversion. *) ##V>=4.08##val unsigned_to_int : nativeint -> int option ##V>=4.08##(** Same as {!to_int}, but interprets the argument as an {e unsigned} integer. ##V>=4.08## Returns [None] if the unsigned value of the argument cannot fit into an ##V>=4.08## [int]. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) external of_float : float -> nativeint = "caml_nativeint_of_float" ##V>=4.3## "caml_nativeint_of_float_unboxed" [@@unboxed] [@@noalloc] (** Convert the given floating-point number to a native integer, discarding the fractional part (truncate towards 0). The result of the conversion is undefined if, after truncation, the number is outside the range \[{!Nativeint.min_int}, {!Nativeint.max_int}\]. *) external to_float : nativeint -> float = "caml_nativeint_to_float" ##V>=4.3## "caml_nativeint_to_float_unboxed" [@@unboxed] [@@noalloc] (** Convert the given native integer to a floating-point number. *) external of_int32 : int32 -> nativeint = "%nativeint_of_int32" (** Convert the given 32-bit integer (type [int32]) to a native integer. *) external to_int32 : nativeint -> int32 = "%nativeint_to_int32" (** Convert the given native integer to a 32-bit integer (type [int32]). On 64-bit platforms, the 64-bit native integer is taken modulo 2{^32}, i.e. the top 32 bits are lost. On 32-bit platforms, the conversion is exact. *) external of_int64 : int64 -> nativeint = "%int64_to_nativeint" (** Convert the given 64-bit integer (type [int64]) to a native integer. On 32-bit platforms, the top 32 bits are lost. *) external to_int64 : nativeint -> int64 = "%int64_of_nativeint" (** Convert the given native integer to a 64-bit integer (type [int64]). *) external of_string : string -> nativeint = "caml_nativeint_of_string" (** Convert the given string to a native integer. The string is read in decimal (by default) or in hexadecimal, octal or binary if the string begins with [0x], [0o] or [0b] respectively. @raise Failure if the given string is not a valid representation of an integer, or if the integer represented exceeds the range of integers representable in type [nativeint]. *) val of_string_opt: string -> nativeint option (** Same as [of_string], but return [None] instead of raising. @since 2.7.0 *) val to_string : nativeint -> string (** Return the string representation of its argument, in decimal. *) val compare : t -> t -> int (** The comparison function for native integers, with the same specification as {!Pervasives.compare}. Along with the type [t], this function [compare] allows the module [Nativeint] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) val min: t -> t -> t (** Return the smaller of the two. @since 3.4.0 *) val max: t -> t -> t (** Return the greater of the two. @since 3.4.0 *) ##V>=4.08##val unsigned_compare: t -> t -> int ##V>=4.08##(** Same as {!compare}, except that arguments are interpreted as {e unsigned} ##V>=4.08## native integers. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) val equal : t -> t -> bool (** Equality function for 64-bit integers, useful for {!HashedType}. *) val ord : t -> t -> BatOrd.order val modulo : nativeint -> nativeint -> nativeint val pow : nativeint -> nativeint -> nativeint val min_num : nativeint val max_num : nativeint val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t val ( ** ) : t -> t -> t (* Available only in `Compare` submodule val ( <> ) : t -> t -> bool val ( >= ) : t -> t -> bool val ( <= ) : t -> t -> bool val ( > ) : t -> t -> bool val ( < ) : t -> t -> bool val ( = ) : t -> t -> bool *) val operations : t BatNumber.numeric include BatNumber.Bounded with type bounded = t (** {6 Submodules grouping all infix operators} *) module Infix : BatNumber.Infix with type bat__infix_t = t module Compare : BatNumber.Compare with type bat__compare_t = t (** {6 Boilerplate code}*) (** {7 Printing}*) val print : (t,_) BatIO.printer (**/**) (** {6 Deprecated functions} *) external format : string -> nativeint -> string = "caml_nativeint_format" (** [Nativeint.format fmt n] return the string representation of the native integer [n] in the format specified by [fmt]. [fmt] is a [Printf]-style format consisting of exactly one [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification. @deprecated use {!Printf.sprintf} with a [%nx] format instead. *) (**/**) batteries-included-3.4.0/src/batNativeint.mlv000066400000000000000000000073261415601150500212320ustar00rootroot00000000000000(* * BatNativeInt - Extended native ints * Copyright (C) 2005 Damien Doligez * 2007 Bluestorm * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module BaseNativeint = struct include Nativeint let modulo = rem let pow = BatNumber.generic_pow ~zero ~one ~div_two:(fun n -> shift_right n 1) ~mod_two:(logand one) ~mul end include BatNumber.MakeNumeric(BaseNativeint) let min_int = Nativeint.min_int let max_int = Nativeint.max_int let minus_one = Nativeint.minus_one let lognot = Nativeint.lognot let size = Nativeint.size external neg : nativeint -> nativeint = "%nativeint_neg" external add : nativeint -> nativeint -> nativeint = "%nativeint_add" external sub : nativeint -> nativeint -> nativeint = "%nativeint_sub" external mul : nativeint -> nativeint -> nativeint = "%nativeint_mul" external div : nativeint -> nativeint -> nativeint = "%nativeint_div" external rem : nativeint -> nativeint -> nativeint = "%nativeint_mod" external logand : nativeint -> nativeint -> nativeint = "%nativeint_and" external logor : nativeint -> nativeint -> nativeint = "%nativeint_or" external logxor : nativeint -> nativeint -> nativeint = "%nativeint_xor" external shift_left : nativeint -> int -> nativeint = "%nativeint_lsl" external shift_right : nativeint -> int -> nativeint = "%nativeint_asr" external shift_right_logical : nativeint -> int -> nativeint = "%nativeint_lsr" external of_int : int -> nativeint = "%nativeint_of_int" external to_int : nativeint -> int = "%nativeint_to_int" external of_float : float -> nativeint = "caml_nativeint_of_float" ##V>=4.3## "caml_nativeint_of_float_unboxed" [@@unboxed] [@@noalloc] external to_float : nativeint -> float = "caml_nativeint_to_float" ##V>=4.3## "caml_nativeint_to_float_unboxed" [@@unboxed] [@@noalloc] external of_int32 : int32 -> nativeint = "%nativeint_of_int32" external to_int32 : nativeint -> int32 = "%nativeint_to_int32" external of_int64 : int64 -> nativeint = "%int64_to_nativeint" external to_int64 : nativeint -> int64 = "%int64_of_nativeint" (*$T of_int32 (of_int32 8l) = 8n *) (*$T to_int32 (to_int32 8n) = 8l *) (*$T of_int64 (of_int64 9L) = 9n *) (*$T to_int64 (to_int64 9n) = 9L *) external of_string : string -> nativeint = "caml_nativeint_of_string" ##V>=4.5##let of_string_opt = Nativeint.of_string_opt ##V<4.5##let of_string_opt s = try Some (Nativeint.of_string s) with _ -> None external format : string -> nativeint -> string = "caml_nativeint_format" ##V>=4.08##let unsigned_compare = Nativeint.unsigned_compare ##V>=4.08##let unsigned_to_int = Nativeint.unsigned_to_int ##V>=4.08##let unsigned_rem = Nativeint.unsigned_rem ##V>=4.08##let unsigned_div = Nativeint.unsigned_div type bounded = t let min_num, max_num = min_int, max_int let print out t = BatPrintf.fprintf out "%nx" t let t_printer _paren out t = print out t let min (x: t) (y: t): t = if x <= y then x else y let max (x: t) (y: t): t = if x >= y then x else y batteries-included-3.4.0/src/batNum.ml000066400000000000000000000066561415601150500176470ustar00rootroot00000000000000(* * BatNum - Operations on arbitrary-precision numbers * Copyright (C) 2008 Gabriel Scherer * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module BaseNum = struct include Num type t = num let zero = Int 0 let one = Int 1 let neg = minus_num let abs = abs_num let add = add_num let sub = sub_num let mul = mult_num let div = div_num let modulo = mod_num let pow = power_num let compare = compare_num let order = BatOrd.ord compare let equal = BatOrd.eq_comp compare let of_int = num_of_int let to_int = int_of_num let to_float = float_of_num let to_string = string_of_num let of_string = num_of_string let pred = pred_num let succ = succ_num let of_float f = match classify_float f with | FP_normal | FP_subnormal -> let x,e = frexp f in let n,e = Big_int.big_int_of_int64 (Int64.of_float (ldexp x 52)), (e-52) in if e >= 0 then Big_int (Big_int.shift_left_big_int n e) else div (Big_int n) (Big_int Big_int.(shift_left_big_int unit_big_int ~-e)) | FP_zero -> zero | FP_nan -> div zero zero | FP_infinite -> if f >= 0. then div one zero else div (neg one) zero end module TaggedInfix = struct let (=/), (/), (<=/), (>=/), (<>/) = Num.((=/), (/), (<=/), (>=/), (<>/)) let (+/), (-/), ( */ ), (//), ( **/ ) = Num.((+/), (-/), ( */ ), (//), ( **/ )) end module Infix = struct (* infix operators without / suffix: + - * / *) include BatNumber.MakeInfix (BaseNum) include TaggedInfix end include (BatNumber.MakeNumeric(BaseNum): BatNumber.Numeric with type t = Num.num and module Infix := Infix) include Num let round = round_num let floor = floor_num let ceil = ceiling_num let square= square_num let is_integer = is_integer_num let approx= integer_num let quo = quo_num let sign = sign_num let print out t = BatInnerIO.nwrite out (to_string t) let of_float_string a = try let ipart_s,fpart_s = BatString.split a ~by:"." in if fpart_s = "" then of_string ipart_s else let frac = pow (of_int 10) (of_int (String.length fpart_s)) in div (of_string (ipart_s ^ fpart_s)) frac with Not_found -> of_string a (*$T equal (of_float_string "2.5") (of_string "5/2") equal (of_float_string "-2.5") (of_string "-5/2") equal (of_float_string "-2.1") (of_string "-21/10") equal (of_float_string "2.") (of_string "2") equal (of_float_string ".5") (of_string "1/2") equal (of_float_string "-0.5") (of_string "-1/2") equal (of_float_string "-.5") (of_string "-1/2") *) batteries-included-3.4.0/src/batNum.mli000066400000000000000000000153041415601150500200060ustar00rootroot00000000000000(* * BatNum - Operations on arbitrary-precision numbers * Copyright (C) 1996 Valerie Menissier-Morain * 2008 Gabriel Scherer * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Operation on arbitrary-precision numbers. Numbers (type {!num}) are arbitrary-precision rational numbers, plus the special elements [1/0] (infinity) and [0/0] (undefined). @author Valerie Menissier-Morain (base module) @author Gabriel Scherer @author David Teller @documents Num *) open Nat open Big_int open Ratio (** The type of numbers. *) type num = Num.num = | Int of int | Big_int of big_int | Ratio of ratio type t = num (** {6 Usual operations}*) val zero : num val one : num val neg : num -> num val abs : num -> num val add : num -> num -> num val sub : num -> num -> num val mul : num -> num -> num val div : num -> num -> num val modulo : num -> num -> num val pow : num -> num -> num val compare : num -> num -> int val ord : num -> num -> BatOrd.order val equal : num -> num -> bool val of_int : int -> num val to_int : num -> int val of_float : float -> num val to_float : num -> float val of_string : string -> num val to_string : num -> string (** Convert a number to a string, using fractional notation. Two formats are recognized: simple integer literals and a pair of integer literals separated by a '/', to indicate a rational number.*) val of_float_string: string -> num (** Convert a simple floating point literal to a num. Plain integer literals are also accepted; numbers written with a trailing exponent are not currently accepted. *) val ( + ) : num -> num -> num val ( - ) : num -> num -> num val ( * ) : num -> num -> num val ( / ) : num -> num -> num val ( ** ) : num -> num -> num (* Available only in `Compare` submodule val ( <> ) : num -> num -> bool val ( >= ) : num -> num -> bool val ( <= ) : num -> num -> bool val ( > ) : num -> num -> bool val ( < ) : num -> num -> bool val ( = ) : num -> num -> bool *) val max_num : num -> num -> num val min_num : num -> num -> num (** {6 Additional operations}*) val quo : num -> num -> num (**Euclidian divisiom*) val square: num -> num val succ : num -> num (** @raise Invalid_argument ["Num.succ"] for [Num.Ratio _] argument *) val pred : num -> num (** @raise Invalid_argument ["Num.pred"] for [Num.Ratio _] argument *) val is_integer : num -> bool (** [is_integer x] returns [true] if [x] represents an integer value, [false] otherwise *) val round : num -> num val floor : num -> num val ceil : num -> num val approx: num -> num (**[approx n] return the integer closest to [n]*) val sign : num -> int (** Return [-1], [0] or [1] according to the sign of the argument. *) val operations : num BatNumber.numeric (** {6 Comparisons between numbers} *) val ( =/ ) : num -> num -> bool val ( num -> bool val ( >/ ) : num -> num -> bool val ( <=/ ) : num -> num -> bool val ( >=/ ) : num -> num -> bool val ( <>/ ) : num -> num -> bool val eq_num : num -> num -> bool val lt_num : num -> num -> bool val le_num : num -> num -> bool val gt_num : num -> num -> bool val ge_num : num -> num -> bool (** {6 Coercions with strings} *) val approx_num_fix : int -> num -> string (** See {!Num.approx_num_exp}.*) val approx_num_exp : int -> num -> string (** Approximate a number by a decimal. The first argument is the required precision. The second argument is the number to approximate. {!Num.approx_num_fix} uses decimal notation; the first argument is the number of digits after the decimal point. [approx_num_exp] uses scientific (exponential) notation; the first argument is the number of digits in the mantissa. *) (** {6 Coercions between numerical types} *) val nat_of_num : num -> nat val num_of_nat : nat -> num val num_of_big_int : big_int -> num val big_int_of_num : num -> big_int val ratio_of_num : num -> ratio val num_of_ratio : ratio -> num val float_of_num : num -> float (** {6 Boilerplate code}*) (** {7 Printing}*) val print: 'a BatInnerIO.output -> t -> unit (** {6 Submodules grouping all infix operators} *) module TaggedInfix : sig val ( =/ ) : num -> num -> bool val ( num -> bool val ( >/ ) : num -> num -> bool val ( <=/ ) : num -> num -> bool val ( >=/ ) : num -> num -> bool val ( <>/ ) : num -> num -> bool val ( +/ ) : num -> num -> num val ( -/ ) : num -> num -> num val ( */ ) : num -> num -> num val ( // ) : num -> num -> num val ( **/ ) : num -> num -> num end module Infix : sig include BatNumber.Infix with type bat__infix_t = t val ( =/ ) : num -> num -> bool val ( num -> bool val ( >/ ) : num -> num -> bool val ( <=/ ) : num -> num -> bool val ( >=/ ) : num -> num -> bool val ( <>/ ) : num -> num -> bool val ( +/ ) : num -> num -> num val ( -/ ) : num -> num -> num val ( */ ) : num -> num -> num val ( // ) : num -> num -> num val ( **/ ) : num -> num -> num end module Compare : BatNumber.Compare with type bat__compare_t = t (** {6 Deprecated} *) val ( +/ ) : num -> num -> num val add_num : num -> num -> num val minus_num : num -> num val ( -/ ) : num -> num -> num val sub_num : num -> num -> num val ( */ ) : num -> num -> num val mult_num : num -> num -> num val square_num : num -> num val ( // ) : num -> num -> num val div_num : num -> num -> num val quo_num : num -> num -> num val mod_num : num -> num -> num val ( **/ ) : num -> num -> num val power_num : num -> num -> num val abs_num : num -> num val succ_num : num -> num val pred_num : num -> num val incr_num : num ref -> unit val decr_num : num ref -> unit val is_integer_num : num -> bool val integer_num : num -> num val floor_num : num -> num val round_num : num -> num val ceiling_num : num -> num val sign_num : num -> int val string_of_num : num -> string val num_of_string : string -> num val int_of_num : num -> int val num_of_int : int -> num val compare_num : num -> num -> int batteries-included-3.4.0/src/batNumber.ml000066400000000000000000000171161415601150500203310ustar00rootroot00000000000000(* * Number - Generic interface for numbers * Copyright (C) 2007 Bluestorm * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type 'a numeric = { zero : 'a; one : 'a; neg : 'a -> 'a; succ : 'a -> 'a; pred : 'a -> 'a; abs : 'a -> 'a; add : 'a -> 'a -> 'a; sub : 'a -> 'a -> 'a; mul : 'a -> 'a -> 'a; div : 'a -> 'a -> 'a; modulo : 'a -> 'a -> 'a; pow : 'a -> 'a -> 'a; compare : 'a -> 'a -> int; of_int : int -> 'a; to_int : 'a -> int; of_string : string -> 'a; to_string : 'a -> string; of_float : float -> 'a; to_float : 'a -> float } (** The infix operators *) module type Infix = sig type bat__infix_t val ( + ) : bat__infix_t -> bat__infix_t -> bat__infix_t val ( - ) : bat__infix_t -> bat__infix_t -> bat__infix_t val ( * ) : bat__infix_t -> bat__infix_t -> bat__infix_t val ( / ) : bat__infix_t -> bat__infix_t -> bat__infix_t val ( ** ) : bat__infix_t -> bat__infix_t -> bat__infix_t val ( -- ): bat__infix_t -> bat__infix_t -> bat__infix_t BatEnum.t val ( --- ): bat__infix_t -> bat__infix_t -> bat__infix_t BatEnum.t end module type Compare = sig type bat__compare_t val ( <> ) : bat__compare_t -> bat__compare_t -> bool val ( >= ) : bat__compare_t -> bat__compare_t -> bool val ( <= ) : bat__compare_t -> bat__compare_t -> bool val ( > ) : bat__compare_t -> bat__compare_t -> bool val ( < ) : bat__compare_t -> bat__compare_t -> bool val ( = ) : bat__compare_t -> bat__compare_t -> bool end (** Idea from Shawn Wagner's mathlib *) module type RefOps = sig type bat__refops_t val (+=): bat__refops_t ref -> bat__refops_t -> unit val (-=): bat__refops_t ref -> bat__refops_t -> unit val ( *=): bat__refops_t ref -> bat__refops_t -> unit val (/=): bat__refops_t ref -> bat__refops_t -> unit end (** The full set of operations of a type of numbers *) module type Numeric = sig type t type discrete = t val zero : t val one : t val neg : t -> t val abs : t -> t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val div : t -> t -> t val modulo : t -> t -> t val pow : t -> t -> t val compare : t -> t -> int val equal : t -> t -> bool val ord : t BatOrd.ord val of_int : int -> t val to_int : t -> int val of_float: float -> t val to_float: t -> float val of_string : string -> t val to_string : t -> string val operations : t numeric val succ : t -> t val pred : t -> t module Infix : Infix with type bat__infix_t = t module Compare : Compare with type bat__compare_t = t include Infix with type bat__infix_t = t (* Removed compare operators from base module, as they shadow polymorphic ones from stdlib include Compare with type bat__compare_t = t*) include RefOps with type bat__refops_t = t end module type Bounded = sig type bounded val min_num: bounded val max_num: bounded end module type Discrete = sig type discrete val to_int: discrete -> int val succ : discrete -> discrete val pred : discrete -> discrete val ( -- ): discrete -> discrete -> discrete BatEnum.t val ( --- ): discrete -> discrete -> discrete BatEnum.t end (** The smallest set of operations supported by every set of numbers *) module type NUMERIC_BASE = sig type t (** A type of numbers*) val zero : t val one : t (** {6 Arithmetic operations} Depending on the implementation, some of these operations {i may} raise exceptions at run-time to represent over/under-flows.*) val neg : t -> t val succ : t -> t val pred : t -> t val abs : t -> t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val div : t -> t -> t val modulo : t -> t -> t val pow : t -> t -> t val compare : t -> t -> int (** {6 Conversions} *) val of_int : int -> t (** Convert this number to the closest integer.*) val to_int : t -> int (** Convert an integer to the closest element of set [t].*) val of_string : string -> t (** Convert the representation of a number to the corresponding number. @raise Invalid_argument if the string does not represent a valid number of type [t]*) val to_string : t -> string val of_float : float -> t val to_float : t -> float end (** Automatic generation of infix operators of a NUMERIC_BASE *) module MakeInfix (Base : NUMERIC_BASE) : Infix with type bat__infix_t = Base.t = struct type bat__infix_t = Base.t let ( + ), ( - ), ( * ), ( / ), ( ** ) = Base.add, Base.sub, Base.mul, Base.div, Base.pow let ( -- ) x y = BatEnum.seq x Base.succ (fun x -> Base.compare x y <= 0) let ( --- ) x y = if Base.compare x y <= 0 then x -- y else BatEnum.seq x Base.pred (fun x -> Base.compare x y >= 0) end (** Automatic generation of comparison operations of a NUMERIC_BASE *) module MakeCompare (Base : NUMERIC_BASE) : Compare with type bat__compare_t = Base.t = struct type bat__compare_t = Base.t let ( = ) a b = Base.compare a b = 0 let ( < ) a b = Base.compare a b < 0 let ( > ) a b = Base.compare a b > 0 let ( <= ) a b = Base.compare a b <= 0 let ( >= ) a b = Base.compare a b >= 0 let ( <> ) a b = Base.compare a b <> 0 end module MakeRefOps (Base: NUMERIC_BASE) : RefOps with type bat__refops_t = Base.t = struct type bat__refops_t = Base.t let (+=) a b = a := Base.add !a b let (-=) a b = a := Base.sub !a b let ( *=) a b = a := Base.mul !a b let (/=) a b = a := Base.div !a b end (** Automated definition of operators for a given numeric type. see open...in... *) module MakeNumeric (Base : NUMERIC_BASE) : Numeric with type t = Base.t = struct include Base let operations = { zero = Base.zero; one = Base.one; neg = Base.neg; succ = Base.succ; pred = Base.pred; abs = Base.abs; add = Base.add; sub = Base.sub; mul = Base.mul; div = Base.div; modulo = Base.modulo; pow = Base.pow; compare = Base.compare; of_int = Base.of_int; to_int = Base.to_int; of_float = Base.of_float; to_float = Base.to_float; of_string = Base.of_string; to_string = Base.to_string; } type discrete = t let equal x y = Base.compare x y = 0 let ord x y = BatOrd.ord0 (Base.compare x y) module Infix = MakeInfix (Base) module Compare = MakeCompare (Base) include Infix include MakeRefOps (Base) end (** A generic implementation of fast exponentiation *) let generic_pow ~zero ~one ~div_two ~mod_two ~mul:( * ) a n = let rec pow a n = if n = zero then one else if n = one then a else let b = pow a (div_two n) in b * b * (if mod_two n = zero then one else a) in if n < zero then invalid_arg "pow" else pow a n exception Overflow exception NaN batteries-included-3.4.0/src/batNumber.mli000066400000000000000000000171041415601150500204770ustar00rootroot00000000000000(* * Number - Generic interface for numbers * Copyright (C) 2007 Bluestorm * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** A common interface for numbers. @author Gabriel Scherer @author David Teller *) (** Arithmetic overflow. This kind of exception is raised by "safe" numeric modules whenever the number which should be returned is too large to be represented. Non-"safe" numeric modules will return a result which depends on the internal representation. For instance, with module {!Int}, [max_num + 1] returns [min_num]. By opposition, with module {!Safe_int}, [max_num + 1] raises [Overflow]. *) exception Overflow (** Not a Number This kind of exception is raised by "safe" modules whenever the number which should be returned is not a number. For instance, with module {!Safe_float}, [0.0 / 0.0] raises [NaN]. By opposition, with module {!Float}, [0.0 / 0.0] does not interrupt computation and returns a special value [nan]. *) exception NaN (** The smallest set of operations supported by every set of numbers. This is presented as record to permit lightweight typeclass-style computation. *) type 'a numeric = { zero : 'a; one : 'a; neg : 'a -> 'a; succ : 'a -> 'a; pred : 'a -> 'a; abs : 'a -> 'a; add : 'a -> 'a -> 'a; sub : 'a -> 'a -> 'a; mul : 'a -> 'a -> 'a; div : 'a -> 'a -> 'a; modulo : 'a -> 'a -> 'a; pow : 'a -> 'a -> 'a; compare : 'a -> 'a -> int; of_int : int -> 'a; to_int : 'a -> int; of_string : string -> 'a; to_string : 'a -> string; of_float: float -> 'a; to_float: 'a -> float; } (** The infix operators available with any type of numbers *) module type Infix = sig type bat__infix_t val ( + ) : bat__infix_t -> bat__infix_t -> bat__infix_t val ( - ) : bat__infix_t -> bat__infix_t -> bat__infix_t val ( * ) : bat__infix_t -> bat__infix_t -> bat__infix_t val ( / ) : bat__infix_t -> bat__infix_t -> bat__infix_t val ( ** ) : bat__infix_t -> bat__infix_t -> bat__infix_t val ( -- ): bat__infix_t -> bat__infix_t -> bat__infix_t BatEnum.t val ( --- ): bat__infix_t -> bat__infix_t -> bat__infix_t BatEnum.t end (** And if you are ready to drop generic comparison operators, then you can open this one as well *) module type Compare = sig type bat__compare_t val ( <> ) : bat__compare_t -> bat__compare_t -> bool val ( >= ) : bat__compare_t -> bat__compare_t -> bool val ( <= ) : bat__compare_t -> bat__compare_t -> bool val ( > ) : bat__compare_t -> bat__compare_t -> bool val ( < ) : bat__compare_t -> bat__compare_t -> bool val ( = ) : bat__compare_t -> bat__compare_t -> bool end (** Reference operators ala C. Mutates a reference value. [x -= y] is the same as [x := !x - y]. @since 2.0 *) module type RefOps = sig type bat__refops_t val (+=): bat__refops_t ref -> bat__refops_t -> unit val (-=): bat__refops_t ref -> bat__refops_t -> unit val ( *=): bat__refops_t ref -> bat__refops_t -> unit val (/=): bat__refops_t ref -> bat__refops_t -> unit end (** The full set of operations of a type of numbers *) module type Numeric = sig type t val zero : t val one : t val neg : t -> t val abs : t -> t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val div : t -> t -> t val modulo : t -> t -> t val pow : t -> t -> t val compare : t -> t -> int val equal : t -> t -> bool val ord : t BatOrd.ord (* t -> t -> [Eq|Gt|Lt] *) val of_int : int -> t val to_int : t -> int val of_float: float -> t val to_float: t -> float val of_string : string -> t val to_string : t -> string val operations : t numeric type discrete = t (* to_int already provided *) val succ : t -> t val pred : t -> t module Infix : Infix with type bat__infix_t = t module Compare : Compare with type bat__compare_t = t include Infix with type bat__infix_t = t (* Removed non-polymorphic compare from base module, as they shadow ones in stdlib. open Foo.Compare to get them. include Compare with type bat__compare_t = t*) include RefOps with type bat__refops_t = t end module type Bounded = sig type bounded val min_num: bounded val max_num: bounded end module type Discrete = sig type discrete val to_int: discrete -> int val succ : discrete -> discrete val pred : discrete -> discrete val ( -- ): discrete -> discrete -> discrete BatEnum.t val ( --- ): discrete -> discrete -> discrete BatEnum.t end (**/**) (** {6 Utilities}*) (** The smallest set of operations supported by every set of numbers *) module type NUMERIC_BASE = sig type t val zero : t val one : t (** {6 Arithmetic operations} Depending on the implementation, some of these operations {i may} raise exceptions at run-time to represent over/under-flows.*) val neg : t -> t val succ : t -> t val pred : t -> t val abs : t -> t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val div : t -> t -> t val modulo : t -> t -> t val pow : t -> t -> t val compare : t -> t -> int (** {6 Conversions} *) val of_int : int -> t (** Convert this number to the closest integer.*) val to_int : t -> int (** Convert an integer to the closest element of set [t].*) val of_string : string -> t (** Convert the representation of a number to the corresponding number. @raise Invalid_argument if the string does not represent a valid number of type [t]*) val to_string : t -> string val of_float : float -> t val to_float : t -> float end (** Automated definition of infix operators for a given numeric type, so that you can open it without polluting your namespace. (apart from the type bat__infix_t) *) module MakeInfix : functor (Base : NUMERIC_BASE) -> Infix with type bat__infix_t = Base.t (** Automated definition of infix comparison operators for a given numeric type, so that you can open it only when you mean it. (apart from the type bat__compare_t) *) module MakeCompare : functor (Base : NUMERIC_BASE) -> Compare with type bat__compare_t = Base.t (** Automated definition of reference operators for a given numeric type *) module MakeRefOps : functor (Base : NUMERIC_BASE) -> RefOps with type bat__refops_t = Base.t (** Automated definition of operators for a given numeric type. You will only need this if you develop your own numeric modules. @since 2.0 *) module MakeNumeric : functor (Base : NUMERIC_BASE) -> Numeric with type t = Base.t (* a generic exponentiation function which efficiently computes a^n as the product of repeated squares, depending on the base-2 expansion of the exponent. ex. a^1 * a^4 * ... a^8 for n=13 *) val generic_pow : zero:'a -> one:'a -> div_two:('a -> 'a) -> mod_two:('a -> 'a) -> mul:('a -> 'a -> 'a) -> 'a -> 'a -> 'a batteries-included-3.4.0/src/batOpaqueInnerSys.ml000066400000000000000000000001101415601150500220100ustar00rootroot00000000000000(* this file must be compiled with -opaque *) let opaque_identity x = x batteries-included-3.4.0/src/batOptParse.ml000066400000000000000000000530651415601150500206410ustar00rootroot00000000000000(* * optParse - Functions for parsing command line arguments. * Copyright (C) 2004 Bardur Arantsson * * Heavily influenced by the optparse.py module from the Python * standard library, but with lots of adaptation to the 'Ocaml Way' * * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open Printf let terminal_width = try int_of_string (Sys.getenv "COLUMNS") (* Might as well use it if it's there... *) with Failure _ -> 80 | Not_found -> 80 module GetOpt = struct type action = string -> string list -> unit type long_opt = string * int * action type short_opt = char * int * action exception Error of (string * string) let split1 haystack needle = try let (h, x) = BatString.split haystack ~by:needle in h, [x] with Not_found -> haystack, [] let find_opt format_name options s = let rec loop l = match l with (x, y, z) :: t -> if x = s then x, y, z else loop t | [] -> raise (Error (format_name s, "no such option")) in loop options let find_short_opt options = find_opt (fun c -> sprintf "-%c" c) options let find_long_opt options = find_opt (fun s -> "--" ^ s) options let parse only_leading_opts other find_short_opt find_long_opt args = let rec loop args = let gather_args name n args = try BatList.split_nth n args with Invalid_argument _ -> raise (Error (name, "missing required arguments")) in let gather_long_opt s args = let (h, t) = split1 s "=" in let (_, nargs, action) = find_long_opt (BatString.slice ~first:2 h) in let (accum, args') = gather_args h (nargs - List.length t) args in action h (t @ accum); args' in let rec gather_short_opt_concat seen_args s k args = if k < String.length s then let ostr = sprintf "-%c" s.[k] and (_, nargs, action) = find_short_opt s.[k] in if nargs = 0 then begin action ostr []; gather_short_opt_concat seen_args s (k + 1) args end else if not seen_args then let (accum, args') = gather_args ostr nargs args in action ostr accum; gather_short_opt_concat true s (k + 1) args' else raise (Error (sprintf "-%c" s.[k], sprintf "option list '%s' already contains an option requiring an argument" s)) else args in let gather_short_opt s k args = let ostr = sprintf "-%c" s.[k] in let (_, nargs, action) = find_short_opt s.[k] in if nargs = 0 then gather_short_opt_concat false s k args else let (accum, args') = let h = BatString.slice ~first:(k+1) s in if String.length h = 0 then gather_args ostr nargs args else let (t, args'') = gather_args ostr (nargs - 1) args in h :: t, args'' in action ostr accum; args' in match args with [] -> [] | arg :: args' -> if arg = "--" then args' else if BatString.starts_with arg "--" then loop (gather_long_opt arg args') else if arg = "-" then begin other arg; loop args' end else if BatString.starts_with arg "-" then loop (gather_short_opt arg 1 args') else if only_leading_opts then arg::args' else begin other arg; loop args' end in let args' = loop args in List.iter other args' end module Opt = struct exception No_value exception Option_error of string * string exception Option_help type 'a t = { option_set : string -> string list -> unit; option_set_value : 'a -> unit; option_get : unit -> 'a option; option_metavars : string list; option_defhelp : string option } let get opt = match opt.option_get () with Some x -> x | None -> raise No_value let set opt v = opt.option_set_value v let is_set opt = BatOption.is_some (opt.option_get ()) let opt opt = opt.option_get () let value_option metavar default coerce errfmt = let data = ref default in { option_metavars = [metavar]; option_defhelp = None; option_get = (fun _ -> !data); option_set_value = (fun x -> data := Some x); option_set = (fun option args -> let arg = List.hd args in try data := Some (coerce arg) with exn -> raise (Option_error (option, errfmt exn arg))) } let callback_option metavar coerce errfmt f = { option_metavars = [metavar]; option_defhelp = None; option_get = (fun _ -> Some ()); option_set_value = (fun () -> ()); option_set = (fun option args -> let arg = List.hd args in let datum = ref None in begin try datum := Some (coerce arg) with exn -> raise (Option_error (option, errfmt exn arg)) end; BatOption.may f !datum) } end module StdOpt = struct open Opt let store_const ?default const = let data = ref default in { option_metavars = []; option_defhelp = None; option_get = (fun _ -> !data); option_set_value = (fun x -> data := Some x); option_set = fun _ _ -> data := Some const } let store_true () = store_const ~default:false true let store_false () = store_const ~default:true false let int_option ?default ?(metavar = "INT") () = value_option metavar default int_of_string (fun _ s -> sprintf "invalid integer value '%s'" s) let int_callback ?(metavar = "INT") = callback_option metavar int_of_string (fun _ s -> sprintf "invalid integer value '%s'" s) let float_option ?default ?(metavar = "FLOAT") () = value_option metavar default float_of_string (fun _ s -> sprintf "invalid floating point value '%s'" s) let float_callback ?(metavar = "FLOAT") = callback_option metavar float_of_string (fun _ s -> sprintf "invalid floating point value '%s'" s) let str_option ?default ?(metavar = "STR") () = value_option metavar default (fun s -> s) (fun _ _ -> "cannot happen") let str_callback ?(metavar = "STR") = callback_option metavar (fun s -> s) (fun _ _ -> "cannot happen") let any_option ?(default = None) ?(metavar = "val") f = value_option metavar default f (fun _ _ -> "invalid option") let count_option ?(dest = ref 0) ?(increment = 1) () = { option_metavars = []; option_defhelp = None; option_get = (fun _ -> Some !dest); option_set_value = (fun x -> dest := x); option_set = fun _ _ -> dest := !dest + increment } let incr_option ?(dest = ref 0) = count_option ~dest ~increment:1 let decr_option ?(dest = ref 0) = count_option ~dest ~increment:(-1) let help_option () = { option_metavars = []; option_defhelp = Some "show this help message and exit"; option_get = (fun _ -> raise No_value); option_set_value = (fun _ -> ()); option_set = fun _ _ -> raise Option_help } let version_option vfunc = { option_metavars = []; option_defhelp = Some "show program's version and exit"; option_get = (fun _ -> raise No_value); option_set_value = (fun _ -> ()); option_set = fun _ _ -> print_endline (vfunc ()); exit 0 } end module Formatter = struct (* Note that the whitespace regexps must NOT treat the non-breaking space character as whitespace. *) let whitespace = "\t\n\013\014\r " let split_into_chunks s = let buf = Buffer.create (String.length s) in let flush () = let s = Buffer.contents buf in Buffer.clear buf; s in let rec loop state accum i = if (i 0 then loop (not state) (flush () :: accum) i else loop (not state) accum i else begin Buffer.add_char buf s.[i]; loop state accum (i+1) end else if Buffer.length buf > 0 then flush () :: accum else accum in List.rev (loop false [] 0) let is_whitespace s = let rec loop i = if i let n = tab_size - col mod tab_size in Buffer.add_string b (spaces n); expand (i + 1) (col + n) | '\n' -> Buffer.add_string b "\n"; expand (i + 1) 0 | c -> Buffer.add_char b c; expand (i + 1) (col + 1) in expand 0 0; Buffer.contents b let wrap ?(initial_indent = 0) ?(subsequent_indent = 0) text _width = let wrap_chunks_line width acc = let rec wrap (chunks, cur_line, cur_len) = match chunks with [] -> [], cur_line, cur_len | hd :: tl -> let l = String.length hd in if cur_len + l <= width then wrap (tl, hd :: cur_line, cur_len + l) else chunks, cur_line, cur_len in wrap acc in let wrap_long_last_word width (chunks, cur_line, cur_len) = match chunks with [] -> [], cur_line, cur_len | hd :: tl -> let l = String.length hd in if l > width then match cur_line with [] -> tl, [hd], cur_len + l | _ -> chunks, cur_line, cur_len else chunks, cur_line, cur_len in let wrap_remove_last_ws (chunks, cur_line, cur_len) = match cur_line with [] -> chunks, cur_line, cur_len | hd :: tl -> if is_whitespace hd then chunks, tl, cur_len - String.length hd else chunks, cur_line, cur_len in let rec wrap_chunks_lines chunks lines = let indent = match lines with [] -> initial_indent | _ -> subsequent_indent in let width = _width - indent in match chunks with hd :: tl -> if is_whitespace hd && lines <> [] then wrap_chunks_lines tl lines else (* skip *) let (chunks', cur_line, _) = wrap_remove_last_ws (wrap_long_last_word width (wrap_chunks_line width (chunks, [], 0))) in wrap_chunks_lines chunks' ((String.make indent ' ' ^ String.concat "" (List.rev cur_line)) :: lines) | [] -> List.rev lines in let chunks = split_into_chunks (expand_tabs text) in wrap_chunks_lines chunks [] let fill ?(initial_indent = 0) ?(subsequent_indent = 0) text width = String.concat "\n" (wrap ~initial_indent ~subsequent_indent text width) type t = { indent : unit -> unit; dedent : unit -> unit; format_usage : string -> string; format_heading : string -> string; format_description : string -> string; format_option : char list * string list -> string list -> string option -> string } let format_option_strings short_first (snames, lnames) metavars = let metavar = String.concat " " metavars in let lopts = List.map (match metavar with "" -> (fun z -> sprintf "--%s" z) | _ -> fun z -> sprintf "--%s=%s" z metavar) lnames and sopts = List.map (fun x -> sprintf "-%c%s" x metavar) snames in match short_first with true -> String.concat ", " (sopts @ lopts) | false -> String.concat ", " (lopts @ sopts) let indented_formatter ?level:(extlevel = ref 0) ?indent:(extindent = ref 0) ?(indent_increment = 2) ?(max_help_position = 24) ?(width = terminal_width - 1) ?(short_first = true) () = let indent = ref 0 and level = ref 0 in let help_position = ref max_help_position and help_width = ref (width - max_help_position) in { indent = (fun () -> indent := !indent + indent_increment; level := !level + 1; extindent := !indent; extlevel := !level); dedent = (fun () -> indent := !indent - indent_increment; level := !level - 1; assert (!level >= 0); extindent := !indent; extlevel := !level); format_usage = (fun usage -> sprintf "usage: %s\n" usage); format_heading = (fun heading -> sprintf "%*s%s:\n\n" !indent "" heading); format_description = (fun description -> let x = fill ~initial_indent:(!indent) ~subsequent_indent:(!indent) description (width - !indent) in if not (BatString.ends_with x "\n") then x ^ "\n\n" else x ^ "\n"); format_option = fun names metavars help -> let opt_width = !help_position - !indent - 2 in let opt_strings = format_option_strings short_first names metavars in let buf = Buffer.create 256 in let indent_first = if String.length opt_strings > opt_width then begin bprintf buf "%*s%s\n" !indent "" opt_strings; !help_position end else begin bprintf buf "%*s%-*s " !indent "" opt_width opt_strings; 0 end in BatOption.may (fun option_help -> let lines = wrap option_help !help_width in match lines with h :: t -> bprintf buf "%*s%s\n" indent_first "" h; List.iter (fun x -> bprintf buf "%*s%s\n" !help_position "" x) t | [] -> ()) help; let contents = Buffer.contents buf in if String.length contents > 0 && not (BatString.ends_with contents "\n") then contents ^ "\n" else contents } let titled_formatter ?(level = ref 0) ?(indent = ref 0) ?(indent_increment = 0) ?(max_help_position = 24) ?(width = terminal_width - 1) ?(short_first = true) () = let formatter = indented_formatter ~level ~indent ~indent_increment ~max_help_position ~width ~short_first () in let format_heading h = let c = match !level with 0 -> '=' | 1 -> '-' | _ -> failwith "titled_formatter: Too much indentation" in sprintf "%*s%s\n%*s%s\n\n" !indent "" (String.capitalize h) !indent "" (String.make (String.length h) c) in let format_usage usage = sprintf "%s %s\n" (format_heading "Usage") usage in { formatter with format_usage = format_usage; format_heading = format_heading } end open Opt open Formatter module OptParser = struct exception Option_conflict of string type group = { og_heading : string; og_description : string option; og_options : ((char list * string list) * string list * string option) BatRefList.t; og_children : group BatRefList.t } type t = { op_usage : string; op_suppress_usage : bool; op_only_leading : bool; op_prog : string; op_formatter : Formatter.t; op_long_options : GetOpt.long_opt BatRefList.t; op_short_options : GetOpt.short_opt BatRefList.t; op_groups : group } let unprogify optparser s = BatString.nreplace ~str:s ~sub:"%prog" ~by:optparser.op_prog let add optparser ?(group = optparser.op_groups) ?help ?(hide = false) ?short_name ?(short_names = []) ?long_name ?(long_names = []) opt = let lnames = match long_name with None -> long_names | Some x -> x :: long_names and snames = match short_name with None -> short_names | Some x -> x :: short_names in if lnames = [] && snames = [] then failwith "Options must have at least one name" else (* Checking for duplicates: *) let snames' = List.fold_left (fun r (x, _, _) -> x :: r) [] (BatRefList.to_list optparser.op_short_options) and lnames' = List.fold_left (fun r (x, _, _) -> x :: r) [] (BatRefList.to_list optparser.op_long_options) in let sconf = List.filter (fun e -> List.exists (( = ) e) snames') snames and lconf = List.filter (fun e -> List.exists (( = ) e) lnames') lnames in if List.length sconf > 0 then raise (Option_conflict (sprintf "-%c" (List.hd sconf))) else if List.length lconf > 0 then raise (Option_conflict (sprintf "--%s" (List.hd lconf))); (* Add to display list. *) if not hide then BatRefList.add group.og_options ((snames, lnames), opt.option_metavars, (match help with None -> opt.option_defhelp | Some _ -> help)); (* Getopt: *) let nargs = List.length opt.option_metavars in List.iter (fun short -> BatRefList.add optparser.op_short_options (short, nargs, opt.option_set)) snames; List.iter (fun long -> BatRefList.add optparser.op_long_options (long, nargs, opt.option_set)) lnames let add_group optparser ?(parent = optparser.op_groups) ?description heading = let g = { og_heading = heading; og_description = description; og_options = BatRefList.empty (); og_children = BatRefList.empty () } in BatRefList.add parent.og_children g; g let make ?(usage = "%prog [options]") ?description ?version ?(suppress_usage = false) ?(suppress_help = false) ?(only_leading_opts = false) ?prog ?(formatter = Formatter.indented_formatter ()) () = let optparser = { op_usage = usage; op_suppress_usage = suppress_usage; op_only_leading = only_leading_opts; op_prog = BatOption.default (Filename.basename Sys.argv.(0)) prog; op_formatter = formatter; op_short_options = BatRefList.empty (); op_long_options = BatRefList.empty (); op_groups = { og_heading = "options"; og_options = BatRefList.empty (); og_children = BatRefList.empty (); og_description = description } } in BatOption.may (* Add version option? *) (fun version -> add optparser ~long_name:"version" (StdOpt.version_option (fun () -> unprogify optparser version))) version; if not suppress_help then (* Add help option? *) add optparser ~short_name:'h' ~long_name:"help" (StdOpt.help_option ()); optparser let format_usage optparser eol = match optparser.op_suppress_usage with true -> "" | false -> unprogify optparser (optparser.op_formatter.format_usage optparser.op_usage) ^ eol let error optparser ?(chn = stderr) ?(status = 1) message = fprintf chn "%s%s: %s\n" (format_usage optparser "\n") optparser.op_prog message; flush chn; exit status let usage optparser ?(chn = stdout) () = let rec loop g = (* Heading: *) output_string chn (optparser.op_formatter.format_heading g.og_heading); optparser.op_formatter.indent (); (* Description: *) BatOption.may (fun x -> output_string chn (optparser.op_formatter.format_description x)) g.og_description; (* Options: *) BatRefList.iter (fun (names, metavars, help) -> output_string chn (optparser.op_formatter.format_option names metavars help)) g.og_options; (* Child groups: *) output_string chn "\n"; BatRefList.iter loop g.og_children; optparser.op_formatter.dedent () in output_string chn (format_usage optparser "\n"); loop optparser.op_groups; flush chn let parse optparser ?(first = 0) ?last argv = let args = BatRefList.empty () and n = match last with None -> Array.length argv - first | Some m -> m - first + 1 in begin try GetOpt.parse optparser.op_only_leading (BatRefList.push args) (GetOpt.find_short_opt (BatRefList.to_list optparser.op_short_options)) (GetOpt.find_long_opt (BatRefList.to_list optparser.op_long_options)) (Array.to_list (Array.sub argv first n)) with GetOpt.Error (opt, errmsg) -> error optparser (sprintf "option '%s': %s" opt errmsg) | Option_error (opt, errmsg) -> error optparser (sprintf "option '%s': %s" opt errmsg) | Option_help -> usage optparser (); exit 0 end; List.rev (BatRefList.to_list args) let parse_argv optparser = parse optparser ~first:1 Sys.argv end batteries-included-3.4.0/src/batOptParse.mli000066400000000000000000000411051415601150500210020ustar00rootroot00000000000000(* * optParse - Functions for parsing command line arguments. * Copyright (C) 2004 Bardur Arantsson * * Heavily influenced by the optparse.py module from the Python * standard library, but with lots of adaptation to the 'Ocaml Way' * * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Modules for GNU [getopt(3)]-style command line parsing. @author Bardur Arantsson *) (** This module contains the basic functions and types for defining new option types and accessing the values of options. *) module Opt : sig (** {6 Exceptions} *) exception No_value (** [No_value] gets raised by {!OptParse.Opt.get} when an option value is not available. *) exception Option_error of string * string (** This exception signals that an option value is invalid. The first string contains the option string ('-x' or '--long-name') and the second string contains an error message. This exception is only used when implementing custom option types and can never "escape" the scope of a {!OptParse.OptParser.parse}. The user should therefore not attempt to catch it. *) exception Option_help (** When an option wants to display a usage message, this exception may be raised. It can never "escape" the scope of a {!OptParse.OptParser.parse} call and the user should therefore not attempt to catch it. *) (** {6 Types} *) type 'a t = { option_set : string -> string list -> unit; option_set_value : 'a -> unit; option_get : unit -> 'a option; option_metavars : string list; option_defhelp : string option } (** Option type. [option_set] is a closure which converts and records the value of an option so that it can be retrieved with a later call to the [option_get] closure. It is called with the option name which was given on the command line and a list of strings, each representing one of the argument values given on the command line. It may raise [Option_error] if the value is invalid (for whatever reason). [option_set_value] is a closure which sets the value of an option to a particular value. [option_get] is a closure which retrieves the recorded value of the option. If the option value has not been set from the command line, the default value is used. If there is no default value, then [None] should be returned. [option_metavars] is a list of "meta-variables" (arguments) which this option accepts. This is mainly for display purposes, but the length of this list determines how many arguments the option parser accepts for this option (currently only lists of length 0 or 1 are supported). [option_defhelp] is the default help string (if any). It is used for displaying help messages whenever the user does {b not} specify a help string manually when adding this option. Using a non-None value here only makes sense for completely generic options like {!OptParse.StdOpt.help_option}. *) (** {6 Option value retrieval} *) val get : 'a t -> 'a (** Get the value of an option. @return the value of the option. If the option has not been encountered while parsing the command line, the default value is returned. @raise No_value if no default values has been given and the option value has not been set from the command line. *) val set : 'a t -> 'a -> unit (** Set the value of an option. *) val opt : 'a t -> 'a option (** Get the value of an option as an optional value. @return [Some x] if the option has value [x] (either by default or from the command line). If the option doesn't have a value [None] is returned. *) val is_set : 'a t -> bool (** Find out if the option has a value (either by default or from the command line). @return [True] iff the option has a value. *) (** {6 Option creation} *) val value_option : string -> 'a option -> (string -> 'a) -> (exn -> string -> string) -> 'a t (** Make an option which takes a single argument. [value_option metavar default coerce errfmt] returns an option which takes a single argument from the command line and calls [coerce] to coerce it to the proper type. If [coerce] raises an exception, [exn], then [errfmt exn argval] is called to generate an error message for display. [metavar] is the name of the metavariable of the option. [default] is the default value of the option. If [None], the option has no default value. @return the newly created option. *) val callback_option : string -> (string -> 'a) -> (exn -> string -> string) -> ('a -> unit) -> unit t (** Make a callback option which takes a single argument. [callback_option metavar coerce errfmt f] returns an option which takes a single argument from the command line and calls [coerce] to coerce it to the proper type. If [coerce] raises an exception [errfmt exn argval] is called to format an error message for display. If [coerce] succeeds, the callback function [f] is called with the coerced value. Finally, [metavar] is the name of the metavariable of the option. @return the newly created option. *) end (** This module contains various standard options. *) module StdOpt : sig (** {6 Flag options} *) val store_const : ?default: 'a -> 'a -> 'a Opt.t (** [store_const ?default const] returns a flag option which stores the constant value [const] when the option is encountered on the command line. *) val store_true : unit -> bool Opt.t (** [store_true ()] returns an option which is set to true when it is encountered on the command line. The default value is false. *) val store_false : unit -> bool Opt.t (** [store_false ()] returns an option which is set to false when it is encountered on the command line. The default value is true. *) val count_option : ?dest: int ref -> ?increment: int -> unit -> int Opt.t (** Create a counting option which increments its value each time the option is encountered on the command line. @param increment Increment to add to the option value each time the option is encountered. @param dest Reference to the option value. Useful for making options like '--quiet' and '--verbose' sharing a single value. @return the newly created option. *) val incr_option : ?dest: int ref -> unit -> int Opt.t (** Exactly identical to [count_option ~dest:dest ~increment:1 ()]. *) val decr_option : ?dest: int ref -> unit -> int Opt.t (** Exactly identical to [count_option ~dest:dest ~increment:(-1) ()]. *) (** {6 Value options} *) val int_option : ?default: int -> ?metavar: string -> unit -> int Opt.t (** [int_option ?default ?metavar ()] returns an option which takes a single integer argument. If [~default] is given it is the default value returned when the option has not been encountered on the command line. *) val float_option : ?default: float -> ?metavar: string -> unit -> float Opt.t (** See {!OptParse.StdOpt.int_option}. *) val str_option : ?default: string -> ?metavar: string -> unit -> string Opt.t (** See {!OptParse.StdOpt.int_option}. *) val any_option : ?default:'a option -> ?metavar: string -> (string -> 'a) -> 'a Opt.t (** [any_option ?default ?metavar coerce] returns an option which takes a single argument from the command line and calls [coerce] to coerce it to the proper type. [default] is the default value of the option. If [None], the option has no default value. *) (** {6 Callback options} *) val int_callback : ?metavar: string -> (int -> unit) -> unit Opt.t (** [int_callback ?metavar f] returns an option which takes a single integer argument and calls [f] with that argument when encountered on the command line. *) val float_callback : ?metavar: string -> (float -> unit) -> unit Opt.t (** See {!OptParse.StdOpt.int_callback}. *) val str_callback : ?metavar: string -> (string -> unit) -> unit Opt.t (** See {!OptParse.StdOpt.int_callback}. *) (** {6 Special options} *) val help_option : unit -> 'a Opt.t (** [help_option ()] returns the standard help option which displays a usage message and exits the program when encountered on the command line. *) val version_option : (unit -> string) -> 'a Opt.t (** [version_option f] returns the standard version option which displays the string returned by [f ()] (and nothing else) on standard output and exits. *) end (** This module contains the types and functions for implementing custom usage message formatters. *) module Formatter : sig type t = { indent : unit -> unit; (** Increase the indentation level. *) dedent : unit -> unit; (** Decrease the indentation level. *) format_usage : string -> string; (** Format usage string into style of this formatter. *) format_heading : string -> string; (** Format heading into style of this formatter. *) format_description : string -> string; (** Format description into style of this formatter. *) format_option : char list * string list -> string list -> string option -> string (** Format option into style of this formatter (see explanation below). *) } (** This is the type of a formatter. The [format_option] has signature [format_option (snames,lnames) metavars help], where [snames] is a list of the short option names, [lnames] is a list of the long option names, [metavars] is a list of the metavars the option takes as arguments, and [help] is the help string supplied by the user. *) (** {6 Standard formatters} *) val indented_formatter : ?level: int ref -> ?indent: int ref -> ?indent_increment: int -> ?max_help_position: int -> ?width: int -> ?short_first: bool -> unit -> t (** Create an "indented" formatter with the given options. @param width Total with of the usage messages printed. @param max_help_position Maximum starting column for the help messages relating to each option. @param short_first List all the short option names first? @param indent_increment Number of columns to indent by when more indentation is required. @param indent Reference to the current indentation amount. Its value reflects changes in indentation level. @param level Reference to the current indentation level. Its value reflects changes in indentation level. *) val titled_formatter : ?level: int ref -> ?indent: int ref -> ?indent_increment: int -> ?max_help_position: int -> ?width: int -> ?short_first: bool -> unit -> t (** Creates a titled formatter which is quite similar to the indented formatter. See {!OptParse.Formatter.indented_formatter} for a description of the options. *) (** {6 Low-level formatting} *) val wrap : ?initial_indent: int -> ?subsequent_indent: int -> string -> int -> string list (** [wrap text width] reflows the given text paragraph into lines of width at most [width] (lines may exceed this if the are single words that exceed this limit). @param initial_indent Indentation of the first line. @param subsequent_indent Indentation of the following lines. @return a list of lines making up the reformatted paragraph. *) val fill : ?initial_indent: int -> ?subsequent_indent: int -> string -> int -> string (** See {!OptParse.Formatter.wrap}. @return a string containing the reformatted paragraph. *) end (** This module contains the option parser itself. It provides functions to create, populate and use option parsers to parse command line arguments. *) module OptParser : sig (** {6 Exceptions} *) exception Option_conflict of string (** [Option_conflict name] is raised by {!OptParse.OptParser.add} when two different options are added with identical names. Usually this doesn't need to be caught since this error is usually easily fixed permanently by removing/renaming the conflicting option names. *) (** {6 Types} *) type t (** The type of an option parser. *) type group (** The type of an option group. *) (** {6 Option parser creation} *) val make : ?usage: string -> ?description: string -> ?version: string -> ?suppress_usage: bool -> ?suppress_help: bool -> ?only_leading_opts: bool -> ?prog: string -> ?formatter: Formatter.t -> unit -> t (** Creates a new option parser with the given options. @param usage Usage message. The default is a reasonable usage message for most programs. Any occurrence of the substring ["%prog"] in [usage] is replaced with the name of the program (see [prog]). @param prog Program name. The default is the base name of the executable. @param suppress_usage Suppress the usage message if set. @param suppress_help Suppress the 'help' option which is otherwise added by default. @param only_leading_opts Only consider leading options (options appearing before the first non-option argument). All arguments from the first non-option argument on are returned as the arguments. @param version Version string. If set, a '--version' option is automatically added. When encountered on the command line it causes [version] to be printed to the standard output and the program to exit. @param description: description of the main purpose of the program. @return the new option parser. *) val add : t -> ?group: group -> ?help: string -> ?hide: bool -> ?short_name: char -> ?short_names: char list -> ?long_name: string -> ?long_names: string list -> 'a Opt.t -> unit (** Add an option to the option parser. @raise Option_conflict if the short name(s) or long name(s) have already been used for some other option. @param help Short help message describing the option (for the usage message). @param hide If true, hide the option from the usage message. This can be used to implement "secret" options which are not shown, but work just the same as regular options in all other respects. @param short_name is the name for the short form of the option (e.g. ['x'] means that the option is invoked with [-x] on the command line). @param short_names is a list of names for the short form of the option (see [short_name]). @param long_name is the name for the long form of the option (e.g. ["xyzzy"] means that the option is invoked with [--xyzzy] on the command line). @param long_names is a list of names for the long form of the option (see [long_name]). *) val add_group : t -> ?parent: group -> ?description: string -> string -> group (** Add a group to the option parser. @param parent is the parent group (if any). @param description is a description of the group. @return the new group. *) (** {6 Output and error handling} *) val error : t -> ?chn: out_channel -> ?status: int -> string -> unit (** Display an error message and exit the program. The error message is printed to the channel [chn] (default is [Pervasives.stderr]) and the program exits with exit status [status] (default is 1). *) val usage : t -> ?chn: out_channel -> unit -> unit (** Display the usage message to the channel [chn] (default is [Pervasives.stdout]) and return. *) (** {6 Option parsing} *) val parse : t -> ?first: int -> ?last: int -> string array -> string list (** Parse arguments as if the arguments [args.(first)], [args.(first+1)], ..., [args.(last)] had been given on the command line. By default [first] is 0 and [last] is the index of the last element of the array. *) val parse_argv : t -> string list (** Parse all the arguments in [Sys.argv]. *) end batteries-included-3.4.0/src/batOption.ml000066400000000000000000000114171415601150500203470ustar00rootroot00000000000000(* * Option - functions for the option type * Copyright (C) 2003 Nicolas Cannasse * 2008 David Teller (Contributor) * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type 'a t = 'a option let some x = Some x let may f = function | None -> () | Some v -> f v (*$T may let x = ref 3 in may incr (Some x); !x = 4 *) let map f = function | None -> None | Some v -> Some (f v) (*$T map map succ None = None map succ (Some 3) = (Some 4) *) let apply = function | None -> (fun x -> x) | Some f -> f (*$T apply apply None 3 = 3 apply (Some succ) 3 = 4 *) let filter f = function | Some x when f x -> Some x | _ -> None (*$T filter filter (fun _ -> true) None = None filter (fun _ -> true) (Some 3) = Some 3 filter (fun _ -> false) (Some 3) = None *) let default v = function | None -> v | Some v -> v (*$T default default 3 None = 3 default 3 (Some 4) = 4 *) let default_delayed l = function | None -> l () | Some v -> v (*$T default_delayed default_delayed (fun () -> 3) None = 3 default_delayed (fun () -> assert false) (Some 4) = 4 *) let is_some = function | None -> false | _ -> true (*$T is_some not (is_some None) is_some (Some ()) *) let is_none = function | None -> true | _ -> false (*$T is_none is_none None not (is_none (Some ())) *) let get_exn s e = match s with | None -> raise e | Some v -> v (*$T get_exn try get_exn None Exit with Exit -> true try get_exn (Some true) Exit with Exit -> false *) let get s = get_exn s (Invalid_argument "Option.get") (*$T get try get None with Invalid_argument _ -> true try get (Some true) with Invalid_argument _ -> false *) let map_default f v = function | None -> v | Some v2 -> f v2 (*$T map_default map_default succ 2 None = 2 map_default succ 2 (Some 3) = 4 *) let map_default_delayed f l = function | None -> l () | Some v -> f v (*$T map_default_delayed map_default_delayed succ (fun () -> 2) None = 2 map_default_delayed succ (fun () -> assert false) (Some 3) = 4 *) let compare ?(cmp=Pervasives.compare) a b = match a with None -> (match b with None -> 0 | Some _ -> -1) | Some x -> (match b with None -> 1 | Some y -> cmp x y) (*$T compare compare (Some 0) (Some 1) < 0 compare (Some 0) (Some 0) = 0 compare (Some 0) (Some (-1)) > 0 compare None (Some ()) < 0 compare None None = 0 compare (Some ()) None > 0 compare ~cmp:(fun _ _ -> 0) (Some (fun x -> x)) (Some (fun y -> y)) = 0 *) let eq ?(eq=(=)) x y = match x,y with | None, None -> true | Some a, Some b -> eq a b | _ -> false (*$T eq eq ~eq:(fun a b -> (a land 1) = (b land 1)) (Some 1) (Some 3) eq (Some 3) (None) = false eq None None = true *) let enum = function | None -> BatEnum.from (fun () -> raise BatEnum.No_more_elements) | Some e -> BatEnum.singleton e (*$T enum BatList.of_enum (enum None) = [] BatList.of_enum (enum (Some 3)) = [3] *) let of_enum = BatEnum.get (*$T of_enum of_enum (BatList.enum []) = None let e = BatList.enum [1; 2; 3] in of_enum e = Some 1 && BatList.of_enum e = [2; 3] *) open BatOrd let ord o x y = match x, y with | None, None -> Eq | Some x', Some y' -> o x' y' | Some _, None -> Gt | None, Some _ -> Lt (*$T ord ord BatInt.ord (Some 1) (Some 2) = BatOrd.Lt ord BatInt.ord (Some 1) None = BatOrd.Gt *) let print print_a out = function | None -> BatInnerIO.nwrite out "None" | Some x -> BatPrintf.fprintf out "Some %a" print_a x let maybe_printer a_printer paren out = function | None -> () | Some x -> a_printer paren out x module Monad = struct type 'a m = 'a option let return x = Some x let bind m f = match m with | None -> None | Some x -> f x end let bind = Monad.bind (*$T bind bind None (fun s -> Some s) = None bind (Some ()) (fun s -> Some s) = Some () *) module Labels = struct let may ~f o = may f o let map ~f o = map f o let map_default ~f d o = map_default f d o end module Infix = struct let ( |? ) x def = default def x let (>>=) = Monad.bind end include Infix batteries-included-3.4.0/src/batOption.mli000066400000000000000000000136231415601150500205210ustar00rootroot00000000000000(* * Options - functions for the option type * Copyright (C) 2003 Nicolas Cannasse * 2008 David Teller (Contributor) * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Functions for the option type. Options are an Ocaml standard type that can be either [None] (undefined) or [Some x] where x can be any value. Options are widely used in Ocaml to represent undefined values (a little like NULL in C, but in a type and memory safe way). This module adds some functions for working with options. @author Nicolas Cannasse @author David Teller *) type 'a t = 'a option val some : 'a -> 'a option (** [some x] returns [Some x]. @since 2.2.0 *) val may : ('a -> unit) -> 'a option -> unit (** [may f (Some x)] calls [f x] and [may f None] does nothing. *) val map : ('a -> 'b) -> 'a option -> 'b option (** [map f (Some x)] returns [Some (f x)] and [map f None] returns [None]. *) val bind : 'a option -> ('a -> 'b option) -> 'b option (** [bind (Some x) f] returns [f x] and [bind None f] returns [None]. @example "Our functions return option types. Compose them to propagate [None]." {[ let pick_long case = try Some (List.find (fun data -> List.length data > 1000) case) with Not_found -> None let last_null data = List.rindex_of 0 data let interesting_positions dataset = List.filter_map (fun case -> Option.bind last_null (pick_long case)) dataset ]} *) val apply : ('a -> 'a) option -> 'a -> 'a (** [apply None x] returns [x] and [apply (Some f) x] returns [f x] *) val filter : ('a -> bool) -> 'a option -> 'a option (** [filter f None] returns [None], [filter f (Some x)] returns [Some x] if [f x] is true, and [None] otherwise. *) val default : 'a -> 'a option -> 'a (** [default x (Some v)] returns [v] and [default x None] returns [x]. *) val ( |? ) : 'a option -> 'a -> 'a (** Like {!default}, with the arguments reversed. [None |? 10] returns [10], while [Some "foo" |? "bar"] returns ["foo"]. {b Note} This operator does not short circuit like [( || )] and [( && )]. Both arguments will be evaluated. @since 2.0 *) val default_delayed : (unit -> 'a) -> 'a option -> 'a (** Like {!default}, but the default value is passed as a thunk that is only computed if needed. @since 2.1 *) val map_default : ('a -> 'b) -> 'b -> 'a option -> 'b (** [map_default f x (Some v)] returns [f v] and [map_default f x None] returns [x]. *) val map_default_delayed : ('a -> 'b) -> (unit -> 'b) -> 'a option -> 'b (** Like {!map_default}, but the default value is passed as a thunk that is only computed if needed. @since 2.1 *) val is_none : 'a option -> bool (** [is_none None] returns [true] otherwise it returns [false]. *) val is_some : 'a option -> bool (** [is_some (Some x)] returns [true] otherwise it returns [false]. *) val get : 'a option -> 'a (** [get (Some x)] returns [x]. @raise Invalid_argument on [get None]. *) val get_exn : 'a option -> exn -> 'a (** [get_exn (Some x) e] returns [x] and [get_exn None e] raises [e]. *) val compare : ?cmp:('a -> 'a -> int) -> 'a option -> 'a option -> int (** Compare two options, possibly using custom comparators for the value. [None] is always assumed to be less than [Some _]. The parameter [cmp] defaults to [Pervasives.compare]. *) val eq : ?eq:('a -> 'a -> bool) -> 'a option -> 'a option -> bool (** Test for equality between option types, possibly using a custom equality predicate. The parameter [eq] defaults to [Pervasives.(=)]. @since 1.4.0 *) val enum: 'a option -> 'a BatEnum.t (** [enum (Some x)] returns the singleton [x], while [enum None] returns the empty enumeration. *) val of_enum: 'a BatEnum.t -> 'a option (** [of_enum e] consumes the first element of [e], if it exists, and returns [Some e]. If [e] is empty, return [None]. *) (** {6 The Option Monad} *) (** This module provides everything needed to write and execute computations in the Option monad. *) module Monad : sig type 'a m = 'a option (** The type of values in this monad : option *) val return : 'a -> 'a m (** [return x] puts a value in the Option monad, that is, returns [Some x]. *) val bind : 'a m -> ('a -> 'b m) -> 'b m (** [bind m f] combines the calculation result [m] with the function [f]. E.g, in the Option monad : [bind (Some 1) (fun x -> if x = 1 then Some 4 else None)] returns Some 4. *) end (** {6 Boilerplate code}*) open BatOrd val ord : 'a ord -> 'a option ord (** Comparison between optional values @since 2.2.0 *) (** {7 Printing}*) val print : ('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> 'b t -> unit (** Operations on options, with labels.*) module Labels : sig val may : f:('a -> unit) -> 'a option -> unit val map : f:('a -> 'b) -> 'a option -> 'b option val map_default : f:('a -> 'b) -> 'b -> 'a option -> 'b end module Infix : sig val ( |? ) : 'a option -> 'a -> 'a (** Like {!default}, with the arguments reversed. [None |? 10] returns [10], while [Some "foo" |? "bar"] returns ["foo"]. *) val ( >>= ): 'a option -> ('a -> 'b option) -> 'b option (** as [Monad.bind] *) end batteries-included-3.4.0/src/batOrd.ml000066400000000000000000000063451415601150500176270ustar00rootroot00000000000000type order = Lt | Eq | Gt type 'a comp = 'a -> 'a -> int type 'a ord = 'a -> 'a -> order module type Comp = sig type t val compare : t comp end module type Ord = sig type t val ord : t ord end let ord0 n = if n < 0 then Lt else if n > 0 then Gt else Eq let ord comp = fun a b -> ord0 (comp a b) let poly_comp = Pervasives.compare (* eta-expand to avoid value restriction *) let poly_ord = fun a b -> ord poly_comp a b let poly = poly_ord module Ord (Comp : Comp) : Ord with type t = Comp.t = struct type t = Comp.t let ord = ord Comp.compare end let comp0 = function | Lt -> -1 | Eq -> 0 | Gt -> 1 let comp ord = fun a b -> comp0 (ord a b) module Comp (Ord : Ord) : Comp with type t = Ord.t = struct type t = Ord.t let compare = comp Ord.ord end let rev_ord0 = function | Lt -> Gt | Eq -> Eq | Gt -> Lt let rev_comp0 n = if n < 0 then 1 else if n > 0 then -1 else 0 let rev_ord ord = fun a b -> rev_ord0 (ord a b) let rev_comp comp = fun a b -> rev_comp0 (comp a b) let rev = rev_ord module RevOrd (Ord : Ord) : Ord with type t = Ord.t = struct type t = Ord.t let ord = rev Ord.ord end module RevComp (Comp : Comp) : Comp with type t = Comp.t = struct type t = Comp.t let compare = rev_comp Comp.compare end module Rev = RevOrd type 'a eq = 'a -> 'a -> bool let eq_ord0 = function | Eq -> true | Lt | Gt -> false let eq_comp0 = function | 0 -> true | _ -> false let eq_ord ord = fun a b -> eq_ord0 (ord a b) let eq_comp comp = fun a b -> eq_comp0 (comp a b) let eq = eq_ord module type Eq = sig type t val eq : t eq end module EqOrd (Ord : Ord) : Eq with type t = Ord.t = struct type t = Ord.t let eq = eq_ord Ord.ord end module EqComp (Comp : Comp) : Eq with type t = Comp.t = struct type t = Comp.t let eq = eq_comp Comp.compare end module Eq = EqOrd type 'a choice = 'a -> 'a -> 'a let min_ord ord = fun a b -> match ord a b with | Lt | Eq -> a | Gt -> b let min_comp comp = fun a b -> if comp a b <= 0 then a else b (*$T max_ord max_ord poly_ord 1 2 = 2 *) (*$T max_comp max_comp poly_comp 1 2 = 2 *) let max_ord ord = min_ord (rev_ord ord) let max_comp comp = min_comp (rev_comp comp) let min = min_ord let max = max_ord let bin_eq eq1 t1 t1' eq2 t2 t2' = eq1 t1 t1' && eq2 t2 t2' let bin_ord ord1 t1 t1' ord2 t2 t2' = match ord1 t1 t1' with | Eq -> ord2 t2 t2' | (Lt | Gt) as neq -> neq let bin_comp comp1 t1 t1' comp2 t2 t2' = match comp1 t1 t1' with | 0 -> comp2 t2 t2' | nzero -> nzero let map_eq f eq = fun a b -> eq (f a) (f b) let map_comp f comp = fun a b -> comp (f a) (f b) let map_ord f ord = fun a b -> ord (f a) (f b) (*$T map_eq map_eq List.length Int.equal [3] [7] not (map_eq List.length Int.equal [] [8;9]) *) (*$T map_comp map_comp Array.length Int.compare [|5;6;7|] [|1;2;3|] = 0 map_comp Array.length Int.compare [||] [|8|] < 0 *) (*$T map_ord map_ord List.hd String.ord ["foo"; "bar"] ["foo"] = Eq map_ord List.tl (List.ord Int.ord) [1;2;3] [8;2;3] = Eq map_ord String.length Int.ord "Foo" "Foobar" = Lt *) module Incubator = struct let eq_by proj = fun x y -> proj x = proj y let comp_by proj = fun x y -> Pervasives.compare (proj x) (proj y) let ord_by proj = fun x y -> ord0 (Pervasives.compare (proj x) (proj y)) end batteries-included-3.4.0/src/batOrd.mli000066400000000000000000000125231415601150500177730ustar00rootroot00000000000000 type order = Lt | Eq | Gt (** An algebraic datatype for ordering. Traditional OCaml code, under the influence of C comparison functions, has used int-returning comparisons (< 0, 0 or > 0). Using an algebraic datatype instead is actually nicer, both for comparison producers (no arbitrary choice of a positive and negative value) and consumers (nice pattern-matching elimination). *) type 'a ord = 'a -> 'a -> order (** The type of ordering functions returning an [order] variant. *) type 'a comp = 'a -> 'a -> int (** The legacy int-returning comparisons : - compare a b < 0 means a < b - compare a b = 0 means a = b - compare a b > 0 means a > b *) module type Comp = sig type t val compare : t comp end (** We use [compare] as member name instead of [comp], so that the Comp modules can be used as the legacy OrderedType interface. *) module type Ord = sig type t val ord : t ord end val ord0 : int -> order val ord : 'a comp -> 'a ord (** Returns a variant ordering from a legacy comparison *) module Ord : functor (Comp : Comp) -> Ord with type t = Comp.t val comp0 : order -> int val comp : 'a ord -> 'a comp (** Returns an legacy comparison from a variant ordering *) module Comp : functor (Ord : Ord) -> Comp with type t = Ord.t val poly_comp : 'a comp val poly_ord : 'a ord val poly : 'a ord (** Polymorphic comparison functions, based on the [Pervasives.compare] function from inria's stdlib, have polymorphic types: they claim to be able to compare values of any type. In practice, they work for only some types, may fail on function types and may not terminate on cyclic values. They work by runtime magic, inspecting the values in an untyped way. While being an useful hack for base types and simple composite types (say [(int * float) list], they do not play well with functions, type abstractions, and structures that would need a finer notion of equality/comparison. For example, if one represent sets as balanced binary tree, one may want set with equal elements but different balancings to be equal, which would not be the case using the polymorphic equality function. When possible, you should therefore avoid relying on these polymorphic comparison functions. You should be especially careful if your data structure may later evolve to allow cyclic data structures or functions. *) val rev_ord0 : order -> order val rev_comp0 : int -> int val rev_ord : 'a ord -> 'a ord val rev_comp : 'a comp -> 'a comp val rev : 'a ord -> 'a ord (** Reverse a given ordering. If [Int.ord] sorts integer by increasing order, [rev Int.ord] will sort them by decreasing order. *) module RevOrd (Ord : Ord) : Ord with type t = Ord.t module RevComp (Comp : Comp) : Comp with type t = Comp.t module Rev (Ord : Ord) : Ord with type t = Ord.t type 'a eq = 'a -> 'a -> bool (** The type for equality function. All ordered types also support equality, as equality can be derived from ordering. However, there are also cases where elements may be compared for equality, but have no natural ordering. It is therefore useful to provide equality as an independent notion. *) val eq_ord0 : order -> bool val eq_comp0 : int -> bool val eq_ord : 'a ord -> 'a eq val eq_comp : 'a comp -> 'a eq val eq : 'a ord -> 'a eq (** Derives an equality function from an ordering function. *) module type Eq = sig type t val eq : t eq end module EqOrd (Ord : Ord) : Eq with type t = Ord.t module EqComp (Comp : Comp) : Eq with type t = Comp.t module Eq (Ord : Ord) : Eq with type t = Ord.t type 'a choice = 'a -> 'a -> 'a (** choice functions, see [min] and [max]. *) val min_ord : 'a ord -> 'a choice val max_ord : 'a ord -> 'a choice val min_comp : 'a comp -> 'a choice val max_comp : 'a comp -> 'a choice val min : 'a ord -> 'a choice (** [min ord] will choose the smallest element, according to [ord]. For example, [min Int.ord 1 2] will return [1]. {[ (* the minimum element of a list *) let list_min ord = List.reduce (min ord) ]} *) val max : 'a ord -> 'a choice (** [max ord] will choose the biggest element according to [ord]. *) val bin_comp : 'a comp -> 'a -> 'a -> 'b comp -> 'b -> 'b -> int val bin_ord : 'a ord -> 'a -> 'a -> 'b ord -> 'b -> 'b -> order (** binary lifting of the comparison function, using lexicographic order: [bin_ord ord1 v1 v1' ord2 v2 v2'] is [ord2 v2 v2'] if [ord1 v1 v1' = Eq], and [ord1 v1 v1'] otherwise. *) val bin_eq : 'a eq -> 'a -> 'a -> 'b eq -> 'b -> 'b -> bool val map_eq : ('a -> 'b) -> 'b eq -> 'a eq val map_comp : ('a -> 'b) -> 'b comp -> 'a comp val map_ord : ('a -> 'b) -> 'b ord -> 'a ord (** These functions extend an existing equality/comparison/ordering to a new domain through a mapping function. For example, to order sets by their cardinality, use [map_ord Set.cardinal Int.ord]. The input of the mapping function is the type you want to compare, so this is the reverse of [List.map]. *) module Incubator : sig val eq_by : ('a -> 'b) -> 'a eq val comp_by : ('a -> 'b) -> 'a comp val ord_by : ('a -> 'b) -> 'a ord (** Build a [eq], [cmp] or [ord] function from a projection function. For example, if you wanted to compare integers based on their lowest 4 bits, you could write [let cmp_bot4 = cmp_by (fun x -> x land 0xf)] and use cmp_bot4 as the desired integer comparator. *) end batteries-included-3.4.0/src/batParserCo.ml000066400000000000000000000223361415601150500206170ustar00rootroot00000000000000open BatList open List open BatLazyList open BatIO open BatPrintf type 'a state = | Eof | State of 'a type 'a report = Report of ('a state * string * 'a report) list let ( &&& ) (Report l) (Report l') = Report (l @ l') let debug_mode = ref false (** {3 Positions} *) module Source = struct type ('a, 'b) t = ('a * 'b) BatLazyList.t let of_lazy_list l init f = let rec aux l acc = match get l with | None -> nil | Some (h, t) -> let acc' = f h acc in lazy( Cons ((h, acc'), (aux t acc'))) in aux l init let of_enum l = of_lazy_list (of_enum l) (**TODO: Handle EOF !*) let of_lexer _l = assert false (** LazyList.of_enum (BatEnum.from (fun () -> let open Lexing in l.refill_buff l; (l.lex_buffer, (l.lex_start_p, l.lex_curr_p))))*) let get_state l = match peek l with | Some (_, s) -> State s | None -> Eof let set_full_state l init f = let rec aux l acc = match get l with | None -> nil | Some ((h, _), t) -> let acc' = f h acc in lazy( Cons ((h, acc'), (aux t acc'))) in aux l init end open Source type ('a, 'b, 'c) result = | Success of 'b * ('a, 'c) Source.t (**Succeed and consume.*) | Backtrack of 'b * 'c report * ('a, 'c) Source.t (**Succeed because of backtracking, typically without consuming.*) | Setback of 'c report (**Error, backtracking in progress.*) | Failure of 'c report (**Fatal error.*) type ('a, 'b, 'c) t = ('a, 'c) Source.t -> ('a, 'b, 'c) result let apply p e = p e(**To improve reusability*) (** {3 Error-handling} *) (*exception Backtrack of Obj.t report*) (**Recoverable error. These errors are caused by [fail].*) (*exception Fail of Obj.t report*) (**Fatal error. These errors are caused by [must].*) let fail _e = Setback (Report []) let succeed v e = Success (v, e) let backtracked v r e = Backtrack (v, r, e) let return = succeed let fatal _e = Failure (Report []) (* Primitives *) let satisfy f e = match get e with | Some ((x,_),t) when f x -> succeed x t | _ -> fail e let depth = ref 0 let label s p e = if BatString.is_empty s then match apply p e with | Success _ as x -> x | Setback _c -> Setback (Report []) | Failure _c -> Failure (Report []) | Backtrack (b, _c, t) -> Backtrack (b, Report [], t) else let make_report c = Report [get_state e, s, c] in if !debug_mode then begin eprintf "%*s>>> %s\n" !depth " " s; incr depth; flush_all () end; match apply p e with | Success _ as x -> if !debug_mode then begin decr depth; eprintf "%*s<<< %s\n" !depth " " s; flush_all () end; x | Setback c -> if !debug_mode then begin decr depth; eprintf "%*s^^^ %s\n" !depth " " s; flush_all () end; Setback (make_report c) | Failure c -> if !debug_mode then begin decr depth; eprintf "%*s!!! %s\n" !depth " " s; flush_all () end; Failure (make_report c) | Backtrack (b, c, t) -> if !debug_mode then begin decr depth; eprintf "%*s/// %s\n" !depth " " s; flush_all () end; Backtrack (b, make_report c, t) let must p e = match apply p e with | Setback x -> Failure x | y -> y let should p e = match apply p e with | Failure x -> Setback x | y -> y let either l e = let rec aux err = function | [] -> Setback (Report err) | h::t -> match apply h e with | Success _ | Failure _ | Backtrack (_, _, _) as result -> result | Setback (Report labels) -> aux (err @ labels) t in aux [] l let ( <|> ) p1 p2 = either [p1;p2] let maybe p e = match apply p e with | Setback c -> Backtrack (None, c, e) | Success (result, rest) -> Success (Some result, rest) | Backtrack (result, report, rest) -> Backtrack (Some result, report, rest) | Failure _ as result -> result let (~?) = maybe (* [bind m f e] If [m] succeeded by backtracking and [f] fails or succeeds by backtracking, merge the reports of [m] and [f]. *) let bind m f e = match apply m e with | Setback _ | Failure _ as result -> result | Success (result, rest) -> apply f result rest | Backtrack (result, report, rest) -> match apply f result rest with | Backtrack (result', report', rest') -> Backtrack (result', report &&& report', rest') | Setback report' -> Setback (report &&& report') | Failure report' -> Failure (report &&& report') | Success _ as result -> result let ( >>= ) = bind let ( >>> ) p q = p >>= fun _ -> q let cons p q = p >>= fun p_result -> q >>= fun q_result -> return (p_result::q_result) let ( >:: ) = cons let state e = succeed (get_state e) e let eof e = label "End of file" (fun e -> match get e with | None -> succeed () e | _ -> fail e) e let any e = label "Anything" (fun e -> match get e with | None -> fail e | Some ((x,_),t) -> succeed x t) e let zero_plus ?sep p e = let p' = match sep with | None -> p | Some s -> s >>> p in let rec aux acc l = match apply p' l with | Success (x, rest) -> aux (x::acc) rest | Backtrack (result, report, rest) -> backtracked (List.rev (result::acc)) report rest | Setback report -> backtracked (List.rev acc) report l | Failure _ as result -> result in match apply p e with | Success (x, rest) -> aux [x] rest | Backtrack (result, report, rest) -> backtracked [result] report rest | Setback report -> backtracked [] report e | Failure _ as result -> result let ( ~* ) p = zero_plus p let ignore_zero_plus ?sep p e = let p' = match sep with | None -> p | Some s -> s >>> p in let rec aux l = match apply p' l with | Success (_x, rest) -> aux rest | Backtrack (_result, report, rest) -> backtracked () report rest | Setback report -> backtracked () report l | Failure _ as result -> result in match apply p e with | Success (_, rest) -> aux rest | Backtrack (_result, report, rest) -> backtracked () report rest | Setback report -> backtracked () report e | Failure _ as result -> result let one_plus ?sep p = p >:: match sep with | None -> zero_plus p | Some s -> zero_plus (s >>> p) let ( ~+ ) p = one_plus p let ignore_one_plus ?sep p = p >>> match sep with | None -> ignore_zero_plus p | Some s -> ignore_zero_plus (s >>> p) (** [prefix t l] returns [h] such that [[h::t] = l]*) let prefix suffix l = let rec aux acc rest = match get rest with | None -> [] | Some (h, t) when t == suffix -> List.rev (h::acc) | Some (h, t) -> aux (h::acc) t in aux [] l let scan p e = let just_prefix rest = List.map fst (prefix rest e) in match apply p e with (*First proceed with parsing*) | Success (_result, rest) -> succeed (just_prefix rest) rest | Backtrack (_result, report, rest) -> backtracked (just_prefix rest) report rest | Setback _ | Failure _ as result -> result let lookahead p e = match apply p e with | Setback c -> Backtrack (None, c, e) | Success (result, _) -> Success (Some result, e) | Backtrack (result, report, _) -> Backtrack (Some result, report, e) | Failure _ as result -> result let interpret_result = function | Setback f | Failure f -> BatInnerPervasives.Error f | Success (r, _) | Backtrack (r, _, _) -> BatInnerPervasives.Ok r let suspend : ('a, 'b, 'c) t -> ('a, (unit -> ('b, 'c report) BatInnerPervasives.result), 'c) t = fun s e -> let resume () = interpret_result (s e) in Success (resume, e) let run p e = interpret_result (apply p e) let source_map p e = let rec aux e = match peek e with | None -> nil | Some (_, c) -> match apply p e with | Success (result, rest) -> lazy (Cons ((result, c), (aux rest))) | Backtrack (result, _, rest) -> lazy (Cons ((result, c), (aux rest))) | Setback _ | Failure _ -> nil (*@TODO: improve error reporting !*) in aux e (** {3 Utilities} *) let filter f p = p >>= fun x -> if f x then return x else fail let exactly x = satisfy (( = ) x) let post_map f p = p >>= fun x -> return (f x) let times n p = let rec aux acc i = if i > 0 then p >>= fun x -> (aux (x::acc) ( i - 1 )) else return acc in (aux [] n) >>= fun x -> return (List.rev x) let ( ^^ ) p n = times n p let one_of l e = let exists x = List.exists (( = ) x) l in satisfy exists e let none_of l e = let for_all x = List.for_all (( <> ) x) l in satisfy for_all e let range a b = satisfy (fun x -> a <= x && x <= b) let sat f = (satisfy f) >>> return () module Infix = struct let (<|>), (~?), (>>=), (>>>), (>::), ( ~* ), (~+), (^^) = (<|>), (~?), (>>=), (>>>), (>::), ( ~* ), (~+), (^^) end batteries-included-3.4.0/src/batParserCo.mli000066400000000000000000000207251415601150500207700ustar00rootroot00000000000000(* * ParserCo - A simple monadic parser combinator library * Copyright (C) 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** A simple parser combinator library. This module permits the simple definition of highly modular, dynamic parsers with unlimited backtracking. It may be used to parse any form of enumeration, including regular text, latin-1 text, bits, etc. This library is vastly more powerful than {!Lexing}, {!Str}, {!Parsing} or {!Scanf}. It is also considerably slower. Module {!CharParser} contains pre-defined parsers to deal specifically with latin-1 text. Module {!Genlex} contains a number of pre-defined parsers to deal specifically with programming languages. {b Note} This library is still very rough and needs much testing. *) (** {6 Base definitions} *) (**The current state of the parser. The actual set of states is defined by the user. States are typically used to convey information, such as position in the file (i.e. line number and character). *) type 'a state = | Eof (**The end of the source has been reached.*) | State of 'a type 'a report = Report of ('a state * string * 'a report) list (**The final result of parsing*) (** A source for parsing. Unless you are parsing from exotic sources, you will probably not need to use this module directly. Rather, use {!CharParser.source_of_string} or {!CharParser.source_of_enum}. *) module Source : sig type ('a, 'b) t (** A source of elements of type ['a], with a user-defined state of type ['b] *) val get_state : ('a, 'b) t -> 'b state val set_full_state : ('a, 'b) t -> 'c -> ('a -> 'c -> 'c) -> ('a, 'c) t val of_enum : 'a BatEnum.t -> 'b -> ('a -> 'b -> 'b) -> ('a, 'b) t end (** {6 Primitives} *) type ('a, 'b, 'c) t (**A parser for elements of type ['a], producing elements of type ['b], with user-defined states of type ['c].*) val eof : (_, unit, _) t (**Accept the end of an enumeration.*) val either : ('a, 'b, 'c) t list -> ('a, 'b, 'c) t (**Accept one of several parsers.*) (*val risk : ('a, 'b) t list -> ('a, 'b) t (**Accept one of several parsers -- but without backtracking.*)*) val ( <|> ) : ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t (**Accept one of two parsers*) val maybe : ('a, 'b, 'c) t -> ('a, 'b option, 'c) t (**Accept an optional argument.*) val ( ~? ): ('a, 'b, 'c) t -> ('a, 'b option, 'c) t (**As [maybe] *) val bind : ('a, 'b, 'c) t -> ('b -> ('a, 'd, 'c) t ) -> ('a, 'd, 'c) t (**Monadic-style combination: [bind p f] results in a new parser which behaves as [p] then, in case of success, applies [f] to the result.*) (*val compose: ('a, 'b, 'c) t -> ('b, 'd, 'c) t -> ('a, 'd, 'c) t (**Composition of two successive parsers. [compose p q] results in a new parser which feeds the consecutive results of [p] into [q]. In case of error, positions are taken from [p].*)*) val ( >>= ) : ('a, 'b, 'c) t -> ('b -> ('a, 'd, 'c) t ) -> ('a, 'd, 'c) t (** As [bind]*) val ( >>> ) : ('a, _, 'c) t -> ('a, 'd, 'c) t -> ('a, 'd, 'c) t (** As [bind], but ignoring the result *) val cons : ('a, 'b, 'c) t -> ('a, 'b list, 'c) t -> ('a, 'b list, 'c) t (** [cons p q] applies parser [p] then parser [q] and conses the results into a list.*) val ( >::) : ('a, 'b, 'c) t -> ('a, 'b list, 'c) t -> ('a, 'b list, 'c) t (** As [cons] *) val label: string -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t (**Give a name to a parser, for debugging purposes.*) val state: (_, 'b state, 'b) t (**Succeed and return the state of the parser*) val any: ('a, 'a, _) t (**Accept any singleton value.*) val return: 'b -> (_, 'b, _) t (**A parser which always succeeds*) val satisfy: ('a -> bool) -> ('a, 'a, _) t (**[satisfy p] accepts one value [p x] such that [p x = true]*) val filter: ('b -> bool) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t (**[filter f p] is only accepts values [x] such that [p] accepts [x] and [f (p x)] is [true]*) val suspend : ('a, 'b, 'c) t -> ('a, (unit -> ('b, 'c report) BatPervasives.result), 'c) t (**[suspend s] returns the state of the parser in a form that can be resumed by calling the returned function. evaluation will resume from parser s *) val run: ('a, 'b, 'c) t -> ('a, 'c) Source.t -> ('b, 'c report) BatPervasives.result (**[run p s] executes parser [p] on source [s]. In case of success, returns [Ok v], where [v] is the return value of [p]. In case of failure, returns [Error f], with [f] containing details on the parsing error.*) (*val enum_runs: ('a, 'b, 'c) t -> ('a, 'c) Source.t -> 'b BatEnum.t val list_runs: ('a, 'b, 'c) t -> ('a, 'c) Source.t -> 'b LazyList.t*) val fail: (_, _, _) t (**Always fail, without consuming anything.*) val fatal: (_, _, _) t val lookahead: ('a, 'b, 'c) t -> ('a, 'b option, 'c) t (**[lookahead p] behaves as [maybe p] but without consuming anything*) (** {6 Utilities} *) (** {7 Singletons} *) val exactly : 'a -> ('a, 'a, 'c) t (**Accept exactly one singleton.*) val one_of : 'a list -> ('a, 'a, 'c) t (**Accept one of several values. Faster and more convenient than combining [satisfy] and [either].*) val none_of : 'a list -> ('a, 'a, 'c) t (**Accept any value not in a list Faster and more convenient than combining [satisfy] and [either].*) val range: 'a -> 'a -> ('a, 'a, 'c) t (**Accept any element from a given range.*) (** {7 Repetitions} *) val zero_plus : ?sep:('a, _, 'c) t -> ('a, 'b, 'c) t -> ('a, 'b list, 'c) t (**Accept a (possibly empty) list of expressions.*) val ignore_zero_plus : ?sep:('a, _, 'c) t -> ('a, _, 'c) t -> ('a, unit, 'c) t (**Ignore a (possibly empty) list of expressions. Optimized version of [zero_plus], for use when the list of expressions is unimportant.*) val ( ~* ) : ('a, 'b, 'c) t -> ('a, 'b list, 'c) t (**As [zero_plus] without arguments.*) val one_plus : ?sep:('a, _, 'c) t -> ('a, 'b, 'c) t -> ('a, 'b list, 'c) t (**Accept a (non-empty) list of expressions*) val ignore_one_plus : ?sep:('a, _, 'c) t -> ('a, _, 'c) t -> ('a, unit, 'c) t (**Ignore a (non-empty) list of expressions. Optimized version of [one_plus], for use when the list of expressions is unimportant.*) val ( ~+ ) : ('a, 'b, 'c) t -> ('a, 'b list, 'c) t (**As [one_plus]*) val times : int -> ('a, 'b, 'c) t -> ('a, 'b list, 'c) t (**[times n p] accepts a list of [n] expressions accepted by [p]*) val ( ^^ ) : ('a, 'b, 'c) t -> int -> ('a, 'b list, 'c) t (**[p ^^ n] is the same thing as [times n p] *) val must: ('a, 'b, 'c) t -> ('a, 'b, 'c) t (**Prevent backtracking.*) val should: ('a, 'b, 'c) t -> ('a, 'b, 'c) t (**Prevent backtracking.*) (** {7 Maps}*) val post_map : ('b -> 'c) -> ('a, 'b, 'd) t -> ('a, 'c, 'd) t (**Pass the (successful) result of some parser through a map.*) val source_map: ('a, 'b, 'c) t -> ('a, 'c) Source.t -> ('b, 'c) Source.t val scan: ('a, _, 'c) t -> ('a, 'a list, 'c) t (**Use a parser to extract list of tokens, but return that list of tokens instead of whatever the original parser returned.*) (** {7 Others}*) val sat: ('a -> bool) -> ('a, unit, _) t (**[satisfy p] accepts one value [p x] such that [p x = true]*) val debug_mode : bool ref (**If set to [true], debugging information will be printed to the standard error.*) (** {6 Infix submodule regrouping all infix operators} *) module Infix : sig val ( <|> ) : ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t val ( ~? ): ('a, 'b, 'c) t -> ('a, 'b option, 'c) t val ( >>= ) : ('a, 'b, 'c) t -> ('b -> ('a, 'd, 'c) t ) -> ('a, 'd, 'c) t val ( >>> ) : ('a, _, 'c) t -> ('a, 'd, 'c) t -> ('a, 'd, 'c) t val ( >::) : ('a, 'b, 'c) t -> ('a, 'b list, 'c) t -> ('a, 'b list, 'c) t val ( ~* ) : ('a, 'b, 'c) t -> ('a, 'b list, 'c) t val ( ~+ ) : ('a, 'b, 'c) t -> ('a, 'b list, 'c) t val ( ^^ ) : ('a, 'b, 'c) t -> int -> ('a, 'b list, 'c) t end batteries-included-3.4.0/src/batPathGen.ml000066400000000000000000000763471415601150500204420ustar00rootroot00000000000000(* * Path - Path and directory manipulation * Copyright (C) 2008 Dawid Toton * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (* TODO - test PathGen.OfRope - what about path components of length 0? - test on Windows - decide about platform-dependent val compare : t -> t -> int (useless?) - adopt from legacy Filename: is_implicit, check_suffix, chop_suffix, chop_extension, quote In related modules: - Windows: read directories and open files using Unicode functions - Directory.exists, Directory.make, etc. *) (* ----------------------- Copy of (most of) Path.mli How to avoid having the copy here? *) (** This signature lists few basic operations provided by all string types. *) module type StringType = sig (** The actual implementation may use any (coherent) scheme of indexing of strings. Below the term 'indexing unit' can stay either for byte or character (or whatever employed by the implementation). This determines meaning of all [int] arguments and results (excluding result of [compare]). *) type t (** Type for strings. *) val length : t -> int (** Length - number of indexing units *) type tchar val get : t -> int -> tchar val lift_char : char -> tchar val lift : string -> t (** Convert from UTF-8 encoded string of primitive [string] type. *) (* [PathGen] implementation requires [lift] to understand few characters which all have codes <128. Therefore [PathGen] can live with either latin1 or UTF-8 put into any primitive strings. [PathGen.OfString] uses [Str], which is byte-oriented and happy with UTF-8. However, if encoding of the argument of [lift] was left unspecified, it would be unusable outside this module. Sice primitive strings are UTF-8 encoded almost everywhere, we want to be UTF-8 friendly here. *) val to_string : t -> string val concat_with_separators : t -> t list -> t (** [concat_with_separators sep lst] catenates all {i n} elements of [lst] inserting {i (n-1)} copies of [sep] in between. *) val compare : t -> t -> int (** Usual comparison function. *) val iter : (tchar -> unit) -> t -> unit val iteri : (int -> tchar -> unit) -> t -> unit val sub : t -> int -> int -> t (** As {!String.sub}, but indexed in specific way. *) val rindex : t -> char -> int module Parse : sig val source : t -> (tchar, BatCharParser.position) BatParserCo.Source.t val letter : (tchar, tchar, BatCharParser.position) BatParserCo.t end end (** All implementations of [Path] functionality have this module type. *) module type PathType = sig type ustring (** Type of strings used. In case of {!Path.OfRope} it is {!Rope.t} and in {!Path.OfString} module it is [string]. *) type uchar (** Type of characters. It corresponds to [ustring] type. *) (** Convenience operator for lifting primitive strings to [ustring] type. @documents Future.Path.OperatorLift *) module OperatorLift : sig val (!!) : string -> ustring (** Prefix operator that converts primitive string to [ustring]. May raise some exceptions depending on actual strings implementation. You might want to [open Path.OperatorLift] to improve readability of path construction using string literals. Example: [Path.root/:!!"foo"/:!!"bar"] = [Path.root/:(S.lift "foo")/:(S.lift "bar")] (where [S.lift] converts to [ustring] type) *) end type t = ustring list (** A type for storing paths. It is reversed list of names. In case of absolute path, the last element of the list is empty string ({e Windows:} empty or letter-colon; details below). Empty list represents empty relative path. Examples: [\["a";"b";"c"\]] is c/b/a (relative path); [\["d";"e";""\]] stays for /e/d (absolute path). All examples here and below are given for [ustring]=[string] case for clarity. To have the code working with other string types, one should prepend the [!!] operator ({!OperatorLift.(!!)}) to all string literals. There are two infix operators provided to allow to write expressions in natural order. For example, to build a path using {!PathType.Operators.(/:)} one can write: [base_dir/:"bar"] instead of ["bar"::base_dir] However it may be sometimes inevitable to write components in reverse, for example: [let whose_readme = function "README"::app::"doc"::"share"::_ -> Some app | _ -> None] {e Windows:} Windows absolute paths start with "\\" or with drive letter. Use following representation: - [Path.root/:"."/:"pipe" = \["pipe";".";""\]] for "\\.\pipe" - [\["C:"\]/:"foo" = \["foo";"C:"\]] for "C:\foo" In principle the first type of paths has broader range of allowed characters, but this implementation applies more strict rules to both ({!default_validator}). *) (* If we wanted more safety, we'd have (making usage inconvenient): type t = private P of ustring list *) val is_relative : t -> bool val is_absolute : t -> bool (** {6 Construction} *) val root : t (** Root of the filesystem ([\[""\]]). It is minimal absolute path. Below it is called 'empty'. However it yields "/" or "\\" when converted to a string. {e Windows:} This path (root and nothing more) is meaningless, but for simplicity it is considered valid here. To create absolute path starting with drive letter, construct the list explicitly (as in [\["C:"\]/:"foo"]). A path consisting of drive letter only is also called 'empty' here. *) (* ocamldoc problem: try to get double_quot-backslash-double_quot in a docstring! *) val append : t -> ustring -> t (** Alternative name for {!Operators.(/:)} *) val concat : t -> t -> t (** Alternative name for {!Operators.(//@)} *) (** Infix operators for path construction. They are in separate module, so one can [open Path.Operators] to use them. @documents Future.Path.Operators *) module Operators : sig val (/:) : t -> ustring -> t (** [path/:name] is a path of [name] located in a directory [path]. For example: - {!PathType.root}[/:"var"/:"log"] builds absolute path "/var/log" - [\[user\]/:".ssh"] can be either: {ul {- absolute path "/.ssh" in case [user] is an empty string} {- relative path otherwise}} {!PathType.default_validator} is applied to the argument. [name] must not contain path separator (causes Illegal_char exception). @raise Illegal_char (raised by validator on any bad character) *) val (//@) : t -> t -> t (** [basepath//\@relpath] catenates two paths. {e Windows:} As a special exception it is possible to pass absolute path as [relpath], provided that [basepath] is simple absolute path (i.e. of the form [\[...; ""\]]) and [relpath] is not simple absolute path. @raise Invalid_argument if the second argument is an absolute path ({e Windows:} see above). *) end (** As other Operators modules in batteries are named "Infix" we provide Infix as well. This is a mere copy of Operators. *) module Infix : sig val (/:) : t -> ustring -> t val (//@) : t -> t -> t end exception Malformed_path val normalize_filepath : t -> t (** Consumes single dots where possible, e.g.: [normalize (\[".."\]/:"foo"/:"."/:"bar"/:"sub1"/:".."/:"sub2") = \[".."\]/:"foo"/:"bar"/:"sub1"/:".."/:"sub2"] {e Windows:} If single dot is next to root, it is preserved. *) val normalize_in_graph : t -> t (** Another name for {!normalize_filepath}. *) val normalize_in_tree : t -> t (** Consumes single dots and applies double dots where possible, e.g.: [normalize (\[".."\]/:"foo"/:"."/:"bar"/:"sub1"/:".."/:"sub2") = \[".."\]/:"foo"/:"bar"/:"sub2"] {e Windows:} If single dot is next to root, it is preserved. @raise Malformed_path when absolute path is given that contains double dots that would be applied to the root. *) val normalize : t -> t (** Deprecated name for {!normalize_in_tree} *) val parent : t -> t (** Returns parent path, i.e. immediate ancestor: [parent (foo/:bar) = foo] @raise Invalid_argument if empty path (relative [\[\]] or absolute [\[""\]]) is given *) val belongs : t -> t -> bool (** [belongs base sub] is [true] when [sub] descends from [base], i.e. [base] is a prefix of [sub]. If [base]=[sub] the function returns [true]. It is otherwise [false]. Both arguments must be absolute paths or both relative. If both arguments have a root portion with drive letter and these letters are different, [belongs base sub] returns false. @raise Invalid_argument if exactly one of given arguments is absolute path *) (* Should this function normalize its arguments? *) val relative_to_any : t -> t -> t (** [relative_to_any base sub] returns relative path [rel] such that [normalize (base/:rel) = normalize sub], i.e. common base is stripped and ".." are added if necessary. Both arguments must be absolute paths or both relative. This function normalizes [base] and [sub] before calculation of the relative path. {e Windows:} If [base] and [sub] are absolute, they must have the same root element: have the same drive letter or both starting with {!root} (i.e. [""] is the last element of the list). Exceptionally it is possible to get an absolute path as a result if drive letter is in [sub] but not as a root element (e .g. [base = root/:"bar"] and [sub = root/:bar//@(\["C:"\]/:"foo"]). @see 'relative_to_parent' may be sometimes more suitable @raise Invalid_argument if exactly one of given arguments is an absolute path @raise Malformed_path if normalization fails (see {!PathType.normalize}) *) exception Not_parent val relative_to_parent : t -> t -> t (** [relative_to_parent parent sub] returns relative path [rel] such that [(normalize parent)/:rel = normalize sub]. It is checked if [parent] is really a parent of [sub]. Both arguments must be absolute paths or both relative. This function normalizes [base] and [sub] before calculation of the relative path. {e Windows:} Exceptionally it is possible to get an absolute path as a result if drive letter is in [sub] but not as a root element (e .g. [base = root/:"bar"] and [sub = root/:bar//@(\["C:"\]/:"foo")]). @raise Not_parent if [sub] is not descendant of [parent] @raise Invalid_argument if exactly one of given arguments is absolute path @raise Malformed_path if normalization fails (see {!PathType.normalize}) *) (** {6 Validation} *) exception Illegal_char (** Raised by {!PathType.of_string}, {!PathType.append} and {!PathType.Operators.(/:)} when used validator finds illegal character. *) type validator = ustring -> bool (** Validators should check if all characters of given string can be used in a name (path component). Return true if the name is valid. Return false if illegal character is found. If a name should be rejected for some other reason, user defined validator may raise an exception. *) val default_validator : validator ref (** Forward slash and code zero are considered invalid. {e Windows:} Invalid characters are *?:\/<> and all with code <32. Exception: the function {!PathType.of_string} doesn't use validator against drive letter with colon. *) (*TODO: Windows: On reserved names and ones ending with dot (except "." and "..") Illegal_name is raised. *) (** {6 Conversions} *) val to_ustring : t -> ustring (** Convert to the chosen [ustring] type. Empty relative path is converted to "." (single dot). {e Windows:} backslash is used as a separator and double backslash for root. If the path is only a drive letter (empty absolute path) trailing backslash is added (e.g. [to_string \["C:"\] = "C:\"]). @see 'to_string' is likely to bo more useful "*)(* Dangling quote character because of ocamldoc lexer being apparently incompatible with OCaml. *) val to_string : t -> string (** Convert to type primitive string with UTF-8 content. The string is built in the same way as by [to_ustring] function. *) val of_string : ustring -> t (** Parse path in a given string. Any number of consecutive separators collapse ("a//b" becomes "a/b"). [Path.default_validator] is applied to each resulting name. {e Windows:} both slashes '\' and '/' are accepted as separators. Paths of the 'semi-relative' form "C:foo\bar" are not recognized. For example "C:" string is parsed as [\["C:"\]] which has different meaning (see {!to_string}). @raise Illegal_char when a character not allowed in paths is found. *) (** {7 Convenience aliases} *) val s : t -> string (** = {!to_string} *) val p : ustring -> t (** = {!of_string} *) (** {6 Name related functions} These functions do not accept empty paths, i.e. [\[\]], [\[""\]] or [\["C:"\]]. *) val name : t -> ustring (** Returns name of the object the pathname points to, i.e. [name (foo/:bar) = bar] @raise Invalid_argument if empty path (relative [\[\]] or absolute [\[""\]]) is given *) val map_name : (ustring -> ustring) -> t -> t (** [map_name fu path] returns [path] with the name replaced by [fu (]{!PathType.name}[ path)]. Example: [map_name (fun nn -> nn ^ ".backup") (["foo"]/:"bar") = ["foo"]/:"bar.backup"] {!PathType.default_validator} is applied to new name. @raise Illegal_char (raised by validator if any bad character is found) *) val ext : t -> ustring option (** Returns extension of the name of the object the pathname points to. Examples: [ext ["aa.bb"] = Some "bb"] [ext ["aa."] = Some ""] [ext ["aa"] = None] [ext [".hidden"] = Some "hidden"] {e (!)} Extension begins where the rightmost dot in the name is found. If the name ends with a dot, the extension is empty and [Some ""] is returned. If there is no extension (no dot) the function returns [None]. @example "Count unfinished music downloads (files ending with '.ogg.part')." {[ let count_music_parts download_dir = let files = Directory.files download_dir in let check file = match Path.ext file with | Some "part" -> ((Path.ext (Path.name_core file)) = "ogg") | _ -> false in let music_parts = List.filter check files in List.length music_parts ]} @raise Invalid_argument if empty path (relative [\[\]] or absolute [\[""\]]) is given *) val map_ext : (ustring option -> ustring option) -> t -> t (** [map_ext fu path] returns [path] but with the name with extension given by [fu (]{!PathType.ext}[ path)]. If [fu] returns [Some _], the original extension may be replaced (when [Some ext] is passed to [fu]) or new added (when [fu] gets [None]). In case [fu] returns [None], the extension is removed (if exists). @example "A name for file being encoded in a new format." {[ let pngname file = map_ext (function Some _ | None -> Some "png") file let new_bar = pngname (["foo"]/:"bar.jpeg") (* = ["foo"]/:"bar.png" *) ]} {!PathType.default_validator} is applied to the resulting name. The replacement string returned by the mapping function [fu] can contain dots. Consequently, this string doesn't need to be an extension as defined by the {!ext} function. Consider for example: {[ let before = foo/:"bar.mli" let replacement = "mli.off" let ext_before = Path.ext before (* = Some "mli" *) let after = Path.map_ext (fun _ -> Some replacement) before (* = foo/:"bar.mli.off" *) let ext_after = Path.ext after (* = Some "off" *) ]} Note the difference between [replacement] and [ext_after]! [(map_ext fu)] is idempotent only if [fu] always returns [Some _]. Otherwise it can remove the extension, possibly exposing part of the name that becomes the new extension. {e Windows:} If [fu] returns [Some ""] (to make a name with trailing period) [map_ext] returns a path that shouldn't be passed to the operating system (it is invalid). @raise Illegal_char (raised by validator if any bad character is found) @raise Invalid_argument if empty path (relative [\[\]] or absolute [\[""\]]) is given *) val name_core : t -> ustring (** Returns part of the name to the left of rightmost dot. Returns empty string if the name starts with a dot. @example "Label for a piece of GUI in which a file is edited." {[ let tab_label modified file = let text = (if modified then "*" else "") ^ (Path.name_core file) in GMisc.label ~text () ]} @raise Invalid_argument if empty path (relative [\[\]] or absolute [\[""\]]) is given *) type components = t * ustring * ustring option (** A [path] can be represented by the following triple: [(Path.parent path, Path.name_core path, Path.ext path)] *) val split : t -> components (** Dissect the path to its components (parent path, core part of name and possibly an extension). Resulting [name_core] string can be empty. For example, [Path.split (Path.root/:"home"/:"user"/:".bashrc")] equals [(Path.root/:"home"/:"user", "", Some "bashrc")]. @raise Invalid_argument if empty path (relative [\[\]] or absolute [\[""\]]) is given *) val join : components -> t (** Create a path from given components. @raise Illegal_char (raised by validator on any bad character) @example "Creating paths for a series of numbered images." {[ let get_animation_frames working_dir count = let frame_file num = Path.join (working_dir/:"rendering" ,"frame"^(stirng_of_int num) ,Some "png" ) in BatEnum.map frame_file (1 -- count) ]} *) val map : (components -> components) -> t -> t (** Map a path through a function that operates on separate components. @raise Illegal_char (raised by validator on any bad character) @raise Invalid_argument if empty path (relative [\[\]] or absolute [\[""\]]) is given @example "Insert a string just before file extension." {[ let extract_first_page file = let insert (parent, name_core, ext) = (parent, name_core ^ "_page1", ext) in let result_file = Path.map insert file in let code = Sys.command (String.concat ' ' ["psselect -p1 <"; P.s file ;" >"; P.s result_file ] ) in if code = 0 then result_file else failwith "psselect" ]} *) (** {6 Supplementary functions} *) val drive_letter : t -> uchar option (** Return drive letter of the given absolute path. {e Windows:} [drive_letter abs] returns [None] if [abs] is simple absolute path (i.e. begins with a separator), otherwise the root element of [abs] consists of a letter [ch] with a colon - in this case [Some ch] is returned. {e Other systems:} Returns [None] on all absolute paths. @example "(Windows only) Are the locations on the same partition?" {[let can_move_quickly ~path_from ~path_to = (drive_letter path_from) = (drive_letter path_to) ]} @raise Invalid_argument if relative path is given *) end (* End of the copy *) module Make = functor (S : StringType) -> struct exception Not_parent exception Illegal_char exception Malformed_path let windows = match Sys.os_type with | "Win32" -> true | _ -> false type ustring = S.t type uchar = S.tchar let strequal s1 s2 = (S.compare s1 s2) = 0 let lift ss = S.lift ss module OperatorLift = struct let (!!) = lift end open OperatorLift let full_match pars ss = let parser_final = BatParserCo.( >>> ) pars BatParserCo.eof in match BatParserCo.run parser_final (S.Parse.source ss) with | BatPervasives.Ok _ -> true | _ -> false (* let full_match_none_of raw_excluded ss = let excluded = List.map S.lift_char raw_excluded in let pars = ParserCo.ignore_zero_plus (ParserCo.none_of excluded) in full_match pars ss *) let split_delim separator_pred ss = let virtual_sep = (-1, 0) in let rev_separators = ref [virtual_sep] in let seen_sep_begin = ref None in let see_sep_end ssb sse = rev_separators := (ssb, sse) :: !rev_separators in let scan ix ch = match !seen_sep_begin, separator_pred ch with | None, false -> () | None, true -> seen_sep_begin := Some ix | Some _, true -> () | Some ssb, false -> (seen_sep_begin := None; see_sep_end ssb ix) in S.iteri scan ss; (match !seen_sep_begin with | None -> () | Some ssb -> see_sep_end ssb (S.length ss) ); let fold (right_sep_beg, result) (sep_beg, sep_end) = let beg = sep_end in let this_chunk = S.sub ss beg (right_sep_beg - beg) in (sep_beg, this_chunk :: result) in let _, result = List.fold_left fold (S.length ss, []) !rev_separators in result (* Returns true if windows and the argument is letter-colon, false otherwise *) let is_win_disk_letter = if windows then let pars = BatParserCo.(>>>) S.Parse.letter (BatParserCo.exactly (S.lift_char ':')) in (fun name -> full_match pars name) else (fun _ -> false) let isnul ss = strequal !!"" ss let isroot ss = (isnul ss) || (is_win_disk_letter ss) let isdot ss = strequal !!"." ss let isdotdot ss = strequal !!".." ss type t = ustring list let is_relative path = match List.rev path with | nm :: _ when isroot nm -> false | _ -> true let is_absolute path = not (is_relative path) let root = [!!""] type validator = ustring -> bool let validator_none_of forbidden = let lifted_forbidden = List.map S.lift_char forbidden in let ensure ch = if List.mem ch lifted_forbidden then raise Illegal_char else () in (fun name -> S.iter ensure name; true) (* (fun name -> full_match_none_of forbidden name) *) let validator_simple = validator_none_of ['/'; '\000'] let validator_windows = validator_none_of ['/'; '\\'; '*'; '?'; '<'; '>'; ':'; '\000'; '\001'; (*...*) '\031'] (*TODO: improve the validator *) (* (fun name -> full_match_none_of forbidden name) *) let default_validator = ref (if windows then validator_windows else validator_simple) let apply_default_validator name = if not (!default_validator name) then raise Illegal_char else name let append path name = (apply_default_validator name) :: path let concat basepath relpath = let simple_concat () = if is_relative relpath then relpath @ basepath else invalid_arg "PathGen.concat" in if windows then begin match basepath with | nm :: _ when isnul nm -> (* special rules *) begin match relpath with | nm :: _ when isnul nm -> invalid_arg "PathGen.concat" | _ -> relpath @ basepath (* allow drive-letter inside the path *) end | _ -> simple_concat () end else simple_concat () module Operators = struct let (/:) = append let (//@) = concat end module Infix = Operators let normalize_gen ~assume path = let can_dotdot = match assume with | `Tree -> true (* dealing with a tree => can apply ".." normally *) | `Graph -> false (* dealing with a graph => ".." has special meaning *) in let rec doit cback path = match cback, path with | 0, [] -> [] | nn, [] -> !!".." :: (doit (nn - 1) []) | 0, [rt] when isroot rt -> path | _nn, [rt] when isroot rt -> raise Malformed_path | _, dotdot :: rest when can_dotdot && isdotdot dotdot -> doit (cback + 1) rest | 0, [dot;nu] when windows && (isdot dot) && (isnul nu) -> path | _nn, [dot;nu] when windows && (isdot dot) && (isnul nu) -> raise Malformed_path | _, dot :: rest when isdot dot -> doit cback rest | 0, name :: rest -> name :: (doit 0 rest) | nn, _name :: rest -> doit (nn - 1) rest in doit 0 path let normalize_in_graph path = normalize_gen ~assume:`Graph path let normalize_in_tree path = normalize_gen ~assume:`Tree path let normalize_filepath path = normalize_gen ~assume:`Graph path let normalize path = normalize_gen ~assume:`Tree path (* should be removed *) let parent path = match path with | [] -> invalid_arg "PathGen.parent" | [rt] when isroot rt -> invalid_arg "PathGen.parent" | _ :: par -> par let belongs base sub = (* Would normalization be useful here? let base = normalize base in let sub = normalize sub in *) let rec fold rbase rsub = match rbase, rsub with | bname::brest, sname::srest when bname = sname -> fold brest srest | _::_brest, _ -> false | [], _ -> true in let rbase = List.rev base in let rsub = List.rev sub in match rbase, rsub with | hb::_, hs::_ when hb = hs -> fold rbase rsub | _hb::_, _hs::_ -> false | rt::_, _ when isroot rt -> invalid_arg "PathGen.belongs" | _, rt::_ when isroot rt -> invalid_arg "PathGen.belongs" | _, _ -> fold rbase rsub let gen_relative_to parent_only base sub = let base = normalize base in let sub = normalize sub in let rec fold rbase rsub = match rbase, rsub with | bname::brest, sname::srest when bname = sname -> fold brest srest | _::brest, _ -> if parent_only then raise Not_parent else fold brest (!!".." :: rsub) | [], _ -> rsub in let rbase = List.rev base in let rsub = List.rev sub in let rrel = match rbase, rsub with | hb::_, hs::_ when hb = hs -> fold rbase rsub | rt::_, _ when isroot rt -> invalid_arg "PathGen.relative_to_*" | _, rt::_ when isroot rt -> invalid_arg "PathGen.relative_to_*" | _, _ -> fold rbase rsub in List.rev rrel let relative_to_any base sub = gen_relative_to false base sub let relative_to_parent base sub = gen_relative_to true base sub let to_ustring path = let separator = if windows then !!"\\" else !!"/" in match List.rev path with | [] -> !!"." | nl :: abs when isnul nl -> let root = if windows then !!"\\\\" else !!"/" in S.concat_with_separators !!"" [root; S.concat_with_separators separator abs] | rel -> S.concat_with_separators separator rel (* also absolute but with drive letter *) let separator_pred = let charlist = List.map S.lift_char (if windows then ['/'; '\\'] else ['/']) in (fun ch -> List.mem ch charlist) let to_string path = S.to_string (to_ustring path) let of_string str = let parts = split_delim separator_pred str in (* Special rules apply to the first separator or leading win-disk-letter *) let head, relparts = match parts with | nm :: rest when isroot nm -> Some nm, rest | other -> None, other in (* Filter out redundant separator (at most one is removed here since separator_regexp is built with + operator) *) let filtered_relparts = List.filter (function nm when isnul nm -> false | _ -> true) relparts in let path = List.rev (match head with | Some nm -> nm :: filtered_relparts | None -> filtered_relparts ) in (* Validation excluding [head] contents: win-disk-letter or an empty string is omitted *) List.iter (fun name -> ignore (apply_default_validator name)) filtered_relparts; path let s = to_string let p = of_string let with_nonempty path fu = match path with | [] -> invalid_arg "PathGen.name" | [rt] when isroot rt -> invalid_arg "PathGen.name" | name :: parent -> (fu name parent) let name path = with_nonempty path (fun name _ -> name) let map_name fu path = with_nonempty path (fun name parent -> (apply_default_validator (fu name)) :: parent) let split_on_last_dot = (fun name -> let len = S.length name in try let dot_index = S.rindex name '.' in let len_ext = len - (dot_index + 1) in let ext = S.sub name (dot_index + 1) len_ext in (S.sub name 0 dot_index, (* excluding the dot *) Some ext (* possibly empty extension *) ) with Not_found -> (name, None) ) let ext path = let name = name path in snd (split_on_last_dot name) let map_ext fu path = with_nonempty path (fun name parent -> let part1, part2 = split_on_last_dot name in match fu part2 with | Some new_ext -> (apply_default_validator (S.concat_with_separators !!"." [part1; new_ext]) ) :: parent | None -> part1 :: parent ) let name_core path = with_nonempty path (fun name _ -> let name_core, _ = split_on_last_dot name in name_core ) type components = t * ustring * ustring option let split path = with_nonempty path (fun name parent -> let name_core, ext = split_on_last_dot name in (parent, name_core, ext) ) let join (parent, name_core, ext) = let name = match ext with | Some ext -> S.concat_with_separators !!"." [name_core; ext] | None -> name_core in (apply_default_validator name) :: parent let map fu path = join (fu (split path)) let drive_letter abs = match List.rev abs with | nul :: _ when isnul nul -> None | drv :: _ when is_win_disk_letter drv -> Some (S.get drv 0) | _ -> invalid_arg "PathGen.drive_letter" end module StringAdapter (*: StringType*) = struct type t = string let length = String.length type tchar = char let get = String.get let lift_char ch = ch let lift ss = ss let to_string ss = ss let concat_with_separators sep lst = String.concat sep lst let compare (r1 : string) (r2 : string) = compare r1 r2 let sub = String.sub let iter = String.iter let iteri = BatString.iteri let rindex = String.rindex module Parse = struct (* type source = (char, CharParser.position) ParserCo.Source.t*) let source = BatCharParser.source_of_string let letter = BatCharParser.letter end end module OfString : PathType with type ustring = string and type uchar = char = Make (StringAdapter) (* module TextAdapter = struct type t = Ulib.Text.t let length = Ulib.Text.length type tchar = Ulib.UChar.t let get = Ulib.Text.get let lift_char ch = Ulib.UChar.of_char ch let lift = Ulib.Text.of_string let to_string = Ulib.Text.to_string let concat_with_separators sep lst = Ulib.Text.concat sep lst let compare = Ulib.Text.compare let iter = Ulib.Text.iter let iteri fu ss = Ulib.Text.iteri fu ss let sub = Ulib.Text.sub let rindex ss pch = Ulib.Text.rindex ss (Ulib.UChar.of_char pch) module Parse = struct let source = BatUCharParser.source_of_rope let letter = BatUCharParser.letter end end module OfText = Make (TextAdapter) *) batteries-included-3.4.0/src/batPathGen.mli000066400000000000000000000506741415601150500206060ustar00rootroot00000000000000(* * Path - Path and directory manipulation * Copyright (C) 2008 Dawid Toton * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Filepath handling. Paths can be used with different string implementations: - see {!Path.OfRope} to use paths built of validated UTF-8 strings ({!Rope.t}) - see {!Path.OfString} to use paths based on primitive [string] type. Actual strings may use UTF-8 encoding. @author Dawid Toton *) (** {6 Functorized interface} *) (* the part copied to PathGen.ml starts here *) (** This signature lists few basic operations provided by all string types. *) module type StringType = sig (** The actual implementation may use any (coherent) scheme of indexing of strings. Below the term 'indexing unit' can stay either for byte or character (or whatever employed by the implementation). This determines meaning of all [int] arguments and results (excluding result of [compare]). *) type t (** Type for strings. *) val length : t -> int (** Length - number of indexing units *) type tchar (** Character type used by [t].*) val get : t -> int -> tchar (** Usual get function. *) val lift_char : char -> tchar (** Convert Latin-1 character to [tchar]. *) val lift : string -> t (** Convert from UTF-8 string of primitive [string] type. *) val to_string : t -> string (** Convert to primitive string with UTF-8 content. *) val concat_with_separators : t -> t list -> t (** [concat_with_separators sep lst] catenates all {i n} elements of [lst] inserting {i (n-1)} copies of [sep] in between. *) val compare : t -> t -> int (** Usual comparison function. *) val iter : (tchar -> unit) -> t -> unit val iteri : (int -> tchar -> unit) -> t -> unit val sub : t -> int -> int -> t (** As {!String.sub}, but indexed in specific way. *) val rindex : t -> char -> int module Parse : sig val source : t -> (tchar, BatCharParser.position) BatParserCo.Source.t val letter : (tchar, tchar, BatCharParser.position) BatParserCo.t end end (** All implementations of [Path] functionality have this module type. *) module type PathType = sig type ustring (** Type of strings used. In case of {!Path.OfRope} it is {!Rope.t} and in {!Path.OfString} module it is [string]. *) type uchar (** Type of characters. It corresponds to [ustring] type. *) (** Convenience operator for lifting primitive strings to [ustring] type. @documents Future.Path.OperatorLift *) module OperatorLift : sig val (!!) : string -> ustring (** Prefix operator that converts primitive string to [ustring]. May raise some exceptions depending on actual strings implementation. You might want to [open Path.OperatorLift] to improve readability of path construction using string literals. Example: [Path.root/:!!"foo"/:!!"bar"] = [Path.root/:(S.lift "foo")/:(S.lift "bar")] (where [S.lift] converts to [ustring] type) *) end type t = ustring list (** A type for storing paths. It is reversed list of names. In case of absolute path, the last element of the list is empty string ({e Windows:} empty or letter-colon; details below). Empty list represents empty relative path. Examples: [\["a";"b";"c"\]] is c/b/a (relative path); [\["d";"e";""\]] stays for /e/d (absolute path). All examples here and below are given for [ustring]=[string] case for clarity. To have the code working with other string types, one should prepend the [!!] operator ({!OperatorLift.(!!)}) to all string literals. There are two infix operators provided to allow to write expressions in natural order. For example, to build a path using {!PathType.Operators.(/:)} one can write: [base_dir/:"bar"] instead of ["bar"::base_dir] However it may be sometimes inevitable to write components in reverse, for example: [let whose_readme = function "README"::app::"doc"::"share"::_ -> Some app | _ -> None] {e Windows:} Windows absolute paths start with "\\" or with drive letter. Use following representation: - [Path.root/:"."/:"pipe" = \["pipe";".";""\]] for "\\.\pipe" - [\["C:"\]/:"foo" = \["foo";"C:"\]] for "C:\foo" In principle the first type of paths has broader range of allowed characters, but this implementation applies more strict rules to both ({!default_validator}). *) (* If we wanted more safety, we'd have (making usage inconvenient): type t = private P of ustring list *) val is_relative : t -> bool val is_absolute : t -> bool (** {6 Construction} *) val root : t (** Root of the filesystem ([\[""\]]). It is minimal absolute path. Below it is called 'empty'. However it yields "/" or "\\" when converted to a string. {e Windows:} This path (root and nothing more) is meaningless, but for simplicity it is considered valid here. To create absolute path starting with drive letter, construct the list explicitly (as in [\["C:"\]/:"foo"]). A path consisting of drive letter only is also called 'empty' here. *) (* ocamldoc problem: try to get double_quot-backslash-double_quot in a docstring! *) val append : t -> ustring -> t (** Alternative name for {!Operators.(/:)} *) val concat : t -> t -> t (** Alternative name for {!Operators.(//@)} *) (** Infix operators for path construction. They are in separate module, so one can [open Path.Operators] to use them. @documents Future.Path.Operators *) module Operators : sig val (/:) : t -> ustring -> t (** [path/:name] is a path of [name] located in a directory [path]. For example: - {!PathType.root}[/:"var"/:"log"] builds absolute path "/var/log" - [\[user\]/:".ssh"] can be either: {ul {- absolute path "/.ssh" in case [user] is an empty string} {- relative path otherwise}} {!PathType.default_validator} is applied to the argument. [name] must not contain path separator (causes Illegal_char exception). @raise Illegal_char (raised by validator on any bad character) *) val (//@) : t -> t -> t (** [basepath//\@relpath] catenates two paths. {e Windows:} As a special exception it is possible to pass absolute path as [relpath], provided that [basepath] is simple absolute path (i.e. of the form [\[...; ""\]]) and [relpath] is not simple absolute path. @raise Invalid_argument if the second argument is an absolute path ({e Windows:} see above). *) end (** As other Operators modules in batteries are named "Infix" we provide Infix as well. This is a mere copy of Operators. *) module Infix : sig val (/:) : t -> ustring -> t val (//@) : t -> t -> t end exception Malformed_path val normalize_filepath : t -> t (** Consumes single dots where possible, e.g.: [normalize (\[".."\]/:"foo"/:"."/:"bar"/:"sub1"/:".."/:"sub2") = \[".."\]/:"foo"/:"bar"/:"sub1"/:".."/:"sub2"] When a directory structure contains links, it can be not pefectly pure tree. Then meaing of the ".." symbol depends on the real nature of parent of what is denoted by the name that preceded the ".." symbol. This symbol cannot be resolved for a graph traversal case when dealing with abstract paths only. {e Windows:} If single dot is next to root, it is preserved. *) val normalize_in_graph : t -> t (** Another name for [normalize_filepath]. *) val normalize_in_tree : t -> t (** Consumes single dots and applies double dots where possible, e.g.: [normalize (\[".."\]/:"foo"/:"."/:"bar"/:"sub1"/:".."/:"sub2") = \[".."\]/:"foo"/:"bar"/:"sub2"] This normalization is useful when dealing with paths that describe locations in a tree and the ".." symbol always points to the only parent of what precedes this symbol. {e Windows:} If single dot is next to root, it is preserved. @raise Malformed_path when absolute path is given that contains double dots that would be applied to the root. *) val normalize : t -> t (** Deprecated name for [normalize_in_tree] *) val parent : t -> t (** Returns parent path, i.e. immediate ancestor: [parent (foo/:bar) = foo] @raise Invalid_argument if empty path (relative [\[\]] or absolute [\[""\]]) is given *) val belongs : t -> t -> bool (** [belongs base sub] is [true] when [sub] descends from [base], i.e. [base] is a prefix of [sub]. If [base]=[sub] the function returns [true]. It is otherwise [false]. Both arguments must be absolute paths or both relative. If both arguments have a root portion with drive letter and these letters are different, [belongs base sub] returns false. @raise Invalid_argument if exactly one of given arguments is absolute path *) (* Should this function normalize its arguments? *) val relative_to_any : t -> t -> t (** [relative_to_any base sub] returns relative path [rel] such that [normalize (base/:rel) = normalize sub], i.e. common base is stripped and ".." are added if necessary. Both arguments must be absolute paths or both relative. This function normalizes [base] and [sub] before calculation of the relative path. {e Windows:} If [base] and [sub] are absolute, they must have the same root element: have the same drive letter or both starting with {!root} (i.e. [""] is the last element of the list). Exceptionally it is possible to get an absolute path as a result if drive letter is in [sub] but not as a root element (e .g. [base = root/:"bar"] and [sub = root/:bar//@(\["C:"\]/:"foo"]). @see 'relative_to_parent' may be sometimes more suitable @raise Invalid_argument if exactly one of given arguments is an absolute path @raise Malformed_path if normalization fails (see {!PathType.normalize}) *) exception Not_parent val relative_to_parent : t -> t -> t (** [relative_to_parent parent sub] returns relative path [rel] such that [(normalize parent)/:rel = normalize sub]. It is checked if [sub] is really a descendant of [parent]. Both arguments must be absolute paths or both relative. This function normalizes [base] and [sub] before calculation of the relative path. {e Windows:} Exceptionally it is possible to get an absolute path as a result if drive letter is in [sub] but not as a root element (e .g. [base = root/:"bar"] and [sub = root/:bar//@(\["C:"\]/:"foo")]). @raise Not_parent if [sub] is not descendant of [parent] @raise Invalid_argument if exactly one of given arguments is absolute path @raise Malformed_path if normalization fails (see {!PathType.normalize}) *) (** {6 Validation} *) exception Illegal_char (** Raised by {!PathType.of_string}, {!PathType.append} and {!PathType.Operators.(/:)} when used validator finds illegal character. *) type validator = ustring -> bool (** Validators should check if all characters of given string can be used in a name (path component). Return true if the name is valid. Return false if illegal character is found. If a name should be rejected for some other reason, user defined validator may raise an exception. *) val default_validator : validator ref (** Forward slash and code zero are considered invalid. {e Windows:} Invalid characters are *?:\/<> and all with code <32. Exception: the function {!PathType.of_string} doesn't use validator against drive letter with colon. *) (*TODO: Windows: On reserved names and ones ending with dot (except "." and "..") Illegal_name is raised. *) (** {6 Conversions} *) val to_ustring : t -> ustring (** Convert to the chosen [ustring] type. Empty relative path is converted to "." (single dot). {e Windows:} backslash is used as a separator and double backslash for root. If the path is only a drive letter (empty absolute path) trailing backslash is added (e.g. [to_string \["C:"\] = "C:\"]). @see 'to_string' is likely to bo more useful "*)(* Dangling quote character because of ocamldoc lexer being apparently incompatible with OCaml. *) val to_string : t -> string (** Convert to type primitive string with UTF-8 content. The string is built in the same way as by [to_ustring] function. *) val of_string : ustring -> t (** Parse path in a given string. Any number of consecutive separators collapse ("a//b" becomes "a/b"). [Path.default_validator] is applied to each resulting name. {e Windows:} both slashes '\' and '/' are accepted as separators. Paths of the 'semi-relative' form "C:foo\bar" are not recognized. For example "C:" string is parsed as [\["C:"\]] which has different meaning (see {!to_string}). @raise Illegal_char when a character not allowed in paths is found. *) (** {7 Convenience aliases} *) val s : t -> string (** = {!to_string} *) val p : ustring -> t (** = {!of_string} *) (** {6 Name related functions} These functions do not accept empty paths, i.e. [\[\]], [\[""\]] or [\["C:"\]]. *) val name : t -> ustring (** Returns name of the object the pathname points to, i.e. [name (foo/:bar) = bar] @raise Invalid_argument if empty path (relative [\[\]] or absolute [\[""\]]) is given *) val map_name : (ustring -> ustring) -> t -> t (** [map_name fu path] returns [path] with the name replaced by [fu (]{!PathType.name}[ path)]. Example: [map_name (fun nn -> nn ^ ".backup") (["foo"]/:"bar") = ["foo"]/:"bar.backup"] {!PathType.default_validator} is applied to new name. @raise Illegal_char (raised by validator if any bad character is found) *) val ext : t -> ustring option (** Returns extension of the name of the object the pathname points to. Examples: [ext ["aa.bb"] = Some "bb"] [ext ["aa."] = Some ""] [ext ["aa"] = None] [ext [".hidden"] = Some "hidden"] {e (!)} Extension begins where the rightmost dot in the name is found. If the name ends with a dot, the extension is empty and [Some ""] is returned. If there is no extension (no dot) the function returns [None]. @example "Count unfinished music downloads (files ending with '.ogg.part')." {[ let count_music_parts download_dir = let files = Directory.files download_dir in let check file = match Path.ext file with | Some "part" -> ((Path.ext (Path.name_core file)) = "ogg") | _ -> false in let music_parts = List.filter check files in List.length music_parts ]} @raise Invalid_argument if empty path (relative [\[\]] or absolute [\[""\]]) is given *) val map_ext : (ustring option -> ustring option) -> t -> t (** [map_ext fu path] returns [path] but with the name with extension given by [fu (]{!PathType.ext}[ path)]. If [fu] returns [Some _], the original extension may be replaced (when [Some ext] is passed to [fu]) or new added (when [fu] gets [None]). In case [fu] returns [None], the extension is removed (if exists). @example "A name for file being encoded in a new format." {[ let pngname file = map_ext (function Some _ | None -> Some "png") file let new_bar = pngname (["foo"]/:"bar.jpeg") (* = ["foo"]/:"bar.png" *) ]} {!PathType.default_validator} is applied to the resulting name. The replacement string returned by the mapping function [fu] can contain dots. Consequently, this string doesn't need to be an extension as defined by the {!ext} function. Consider for example: {[ let before = foo/:"bar.mli" let replacement = "mli.off" let ext_before = Path.ext before (* = Some "mli" *) let after = Path.map_ext (fun _ -> Some replacement) before (* = foo/:"bar.mli.off" *) let ext_after = Path.ext after (* = Some "off" *) ]} Note the difference between [replacement] and [ext_after]! [(map_ext fu)] is idempotent only if [fu] always returns [Some _]. Otherwise it can remove the extension, possibly exposing part of the name that becomes the new extension. {e Windows:} If [fu] returns [Some ""] (to make a name with trailing period) [map_ext] returns a path that shouldn't be passed to the operating system (it is invalid). @raise Illegal_char (raised by validator if any bad character is found) @raise Invalid_argument if empty path (relative [\[\]] or absolute [\[""\]]) is given *) val name_core : t -> ustring (** Returns part of the name to the left of rightmost dot. Returns empty string if the name starts with a dot. @example "Label for a piece of GUI in which a file is edited." {[ let tab_label modified file = let text = (if modified then "*" else "") ^ (Path.name_core file) in GMisc.label ~text () ]} @raise Invalid_argument if empty path (relative [\[\]] or absolute [\[""\]]) is given *) type components = t * ustring * ustring option (** A [path] can be represented by the following triple: [(Path.parent path, Path.name_core path, Path.ext path)] *) val split : t -> components (** Dissect the path to its components (parent path, core part of name and possibly an extension). Resulting [name_core] string can be empty. For example, [Path.split (Path.root/:"home"/:"user"/:".bashrc")] equals [(Path.root/:"home"/:"user", "", Some "bashrc")]. @raise Invalid_argument if empty path (relative [\[\]] or absolute [\[""\]]) is given *) val join : components -> t (** Create a path from given components. @raise Illegal_char (raised by validator on any bad character) @example "Creating paths for a series of numbered images." {[ let get_animation_frames working_dir count = let frame_file num = Path.join (working_dir/:"rendering" ,"frame"^(stirng_of_int num) ,Some "png" ) in BatEnum.map frame_file (1 -- count) ]} *) val map : (components -> components) -> t -> t (** Map a path through a function that operates on separate components. @raise Illegal_char (raised by validator on any bad character) @raise Invalid_argument if empty path (relative [\[\]] or absolute [\[""\]]) is given @example "Insert a string just before file extension." {[ let extract_first_page file = let insert (parent, name_core, ext) = (parent, name_core ^ "_page1", ext) in let result_file = Path.map insert file in let code = Sys.command (String.concat ' ' ["psselect -p1 <"; P.s file ;" >"; P.s result_file ] ) in if code = 0 then result_file else failwith "psselect" ]} *) (** {6 Supplementary functions} *) val drive_letter : t -> uchar option (** Return drive letter of the given absolute path. {e Windows:} [drive_letter abs] returns [None] if [abs] is simple absolute path (i.e. begins with a separator), otherwise the root element of [abs] consists of a letter [ch] with a colon - in this case [Some ch] is returned. {e Other systems:} Returns [None] on all absolute paths. @example "(Windows only) Are the locations on the same partition?" {[let can_move_quickly ~path_from ~path_to = (drive_letter path_from) = (drive_letter path_to) ]} @raise Invalid_argument if relative path is given *) end (* end of the part that is copied to PathGen.ml *) module Make : functor (S : StringType) -> PathType with type ustring = S.t and type uchar = S.tchar (** Constructs path handling module for string-like type and its operations given in [S]. @documents Future.Path.Make *) module OfString : PathType with type ustring = string and type uchar = char (** This implementation can be used with UTF-8, but encoding of used strings is not verified. @documents Future.Path.OfString *) (* module OfRope : PathType with type ustring = Rope.t (** In this implementation used strings are always valid UTF-8. @documents Future.Path.OfRope *) *) batteries-included-3.4.0/src/batPervasives.ml000066400000000000000000000213471415601150500212310ustar00rootroot00000000000000(* * BatPervasives - Additional functions * Copyright (C) 1996 Xavier Leroy * 2003 Nicolas Cannasse * 2007 Zheng Li * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open Pervasives open BatEnum let input_lines ch = BatEnum.from (fun () -> try input_line ch with End_of_file -> raise BatEnum.No_more_elements) let input_chars ch = BatEnum.from (fun () -> try input_char ch with End_of_file -> raise BatEnum.No_more_elements) type 'a _mut_list = { hd : 'a; mutable tl : 'a _mut_list; } let input_list ch = let _empty = Obj.magic [] in let rec loop dst = let r = { hd = input_line ch; tl = _empty } in dst.tl <- r; loop r in let r = { hd = Obj.magic(); tl = _empty } in try loop r with End_of_file -> Obj.magic r.tl let buf_len = 8192 let input_all ic = let rec loop acc total buf ofs = let n = input ic buf ofs (buf_len - ofs) in if n = 0 then let res = Bytes.create total in let pos = total - ofs in let _ = Bytes.blit buf 0 res pos ofs in let coll pos buf = let new_pos = pos - buf_len in Bytes.blit buf 0 res new_pos buf_len; new_pos in let _ = List.fold_left coll pos acc in Bytes.unsafe_to_string res else let new_ofs = ofs + n in let new_total = total + n in if new_ofs = buf_len then loop (buf :: acc) new_total (Bytes.create buf_len) 0 else loop acc new_total buf new_ofs in loop [] 0 (Bytes.create buf_len) 0 let input_file ?(bin=false) fname = let ch = (if bin then open_in_bin else open_in) fname in let str = input_all ch in close_in ch; str let output_file ~filename ~text = let ch = open_out filename in output_string ch text; close_out ch let print_bool = function | true -> print_string "true" | false -> print_string "false" let prerr_bool = function | true -> prerr_string "true" | false -> prerr_string "false" let string_of_char c = String.make 1 c let rec dump r = if Obj.is_int r then string_of_int (Obj.magic r : int) else (* Block. *) let rec get_fields acc = function | 0 -> acc | n -> let n = n-1 in get_fields (Obj.field r n :: acc) n in let rec is_list r = if Obj.is_int r then r = Obj.repr 0 (* [] *) else let s = Obj.size r and t = Obj.tag r in t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *) in let rec get_list r = if Obj.is_int r then [] else let h = Obj.field r 0 and t = get_list (Obj.field r 1) in h :: t in let opaque name = (* XXX In future, print the address of value 'r'. Not possible * in pure OCaml at the moment. *) "<" ^ name ^ ">" in let s = Obj.size r and t = Obj.tag r in (* From the tag, determine the type of block. *) match t with | _ when is_list r -> let fields = get_list r in "[" ^ String.concat "; " (List.map dump fields) ^ "]" | 0 -> let fields = get_fields [] s in "(" ^ String.concat ", " (List.map dump fields) ^ ")" | x when x = Obj.lazy_tag -> (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not * clear if very large constructed values could have the same * tag. XXX *) opaque "lazy" | x when x = Obj.closure_tag -> opaque "closure" | x when x = Obj.object_tag -> let fields = get_fields [] s in let _clasz, id, slots = match fields with | h::h'::t -> h, h', t | _ -> assert false in (* No information on decoding the class (first field). So just print * out the ID and the slots. *) "Object #" ^ dump id ^ " (" ^ String.concat ", " (List.map dump slots) ^ ")" | x when x = Obj.infix_tag -> opaque "infix" | x when x = Obj.forward_tag -> opaque "forward" | x when x < Obj.no_scan_tag -> let fields = get_fields [] s in "Tag" ^ string_of_int t ^ " (" ^ String.concat ", " (List.map dump fields) ^ ")" | x when x = Obj.string_tag -> "\"" ^ String.escaped (Obj.magic r : string) ^ "\"" | x when x = Obj.double_tag -> string_of_float (Obj.magic r : float) | x when x = Obj.abstract_tag -> opaque "abstract" | x when x = Obj.custom_tag -> opaque "custom" | x when x = Obj.final_tag -> opaque "final" | x when x = Obj.double_array_tag -> BatIO.to_string (BatArray.print BatFloat.print) (Obj.magic r : float array) | _ -> opaque (Printf.sprintf "unknown: tag %d size %d" t s) let dump v = dump (Obj.repr v) let print_any oc v = BatIO.nwrite oc (dump v) include BatInnerPervasives let invisible_args = ref 1 (* the number or arguments to ignore at the beginning of Sys.argv, usually because program-name is put in argv.(0) *) let args () = let e = BatArray.enum Sys.argv in BatEnum.drop !invisible_args e; e let exe = Array.get Sys.argv 0 let argv = Sys.argv (** {6 I/O}*) let print_guess oc v = BatIO.nwrite oc (dump v) let prerr_guess v = prerr_endline (dump v) let stdin = BatIO.stdin let stdout = BatIO.stdout let stderr = BatIO.stderr let stdnull = BatIO.stdnull let open_out = BatFile.open_out let open_out_bin name = BatIO.output_channel ~cleanup:true (open_out_bin name) let open_out_gen mode perm name = BatIO.output_channel ~cleanup:true (open_out_gen mode perm name) let flush = BatIO.flush let flush_all = BatIO.flush_all let close_all = BatIO.close_all let output_char = BatChar.print let output_string = BatString.print let output oc buf pos len = ignore (BatIO.output oc buf pos len) let output_substring oc buf pos len = ignore (BatIO.output_substring oc buf pos len) let output_byte = BatIO.write_byte let output_binary_int = BatIO.write_i32 let output_binary_float out v= BatIO.write_i64 out (BatInt64.bits_of_float v) let output_value out v= BatMarshal.output out v let close_out = BatIO.close_out let close_out_noerr out = try BatIO.close_out out with _ -> () let open_in = BatFile.open_in let open_in_bin name = BatIO.input_channel ~cleanup:true (open_in_bin name) let open_in_gen mode perm filename = BatIO.input_channel ~cleanup:true (open_in_gen mode perm filename) let wrap_inner_io f a = try f a with BatIO.No_more_input -> raise End_of_file let input_char = wrap_inner_io BatIO.read let input_line = wrap_inner_io BatIO.read_line let input = wrap_inner_io BatIO.input let really_input inp buf pos len = wrap_inner_io ignore (BatIO.really_input inp buf pos len) let input_byte = wrap_inner_io BatIO.read_byte let input_binary_int = wrap_inner_io BatIO.read_i32 let input_binary_float inp = wrap_inner_io BatInt64.float_of_bits (BatIO.read_i64 inp) let close_in = BatIO.close_in let close_in_noerr inp= try BatIO.close_in inp with _ -> () let input_value = BatMarshal.input let print_all inp = BatIO.copy inp BatIO.stdout let prerr_all inp = BatIO.copy inp BatIO.stderr include BatList.Infix (**{6 Importing BatEnum}*) let foreach e f = iter f e let exists = exists let for_all = for_all let fold = fold let reduce = reduce let find = find let peek = peek let push = push let junk = junk let map = map let filter = filter let filter_map = filter_map let concat = concat let print = print let get = get let iter = iter let scanl = scanl include Infix (** {6 Operators}*) let undefined ?(message="Undefined") _ = failwith message (*$T undefined ignore (Obj.magic (undefined ~message:"")); true try ignore (undefined ~message:"FooBar" ()); false with Failure "FooBar" -> true *) let verify x ex = if x then () else raise ex let verify_arg x s = if x then () else invalid_arg s (** {6 Clean-up}*) let _ = at_exit close_all; (*Called second*) at_exit flush_all (*Called first*) batteries-included-3.4.0/src/batPervasives.mliv000066400000000000000000001033571415601150500215720ustar00rootroot00000000000000(* * BatPervasives - Additional functions * Copyright (C) 1996 Xavier Leroy * 2003 Nicolas Cannasse * 2007 Zheng Li * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** {6 Additional functions.} @author Xavier Leroy (Base module) @author Nicolas Cannasse @author David Teller @author Zheng Li *) open BatIO (** The initially opened module. This module provides the basic operations over the built-in types (numbers, booleans, strings, exceptions, references, lists, arrays, input-output channels, ...) This module is automatically opened at the beginning of each compilation. All components of this module can therefore be referred by their short name, without prefixing them by [BatPervasives]. @author Xavier Leroy (Base module) @author Nicolas Cannasse @author David Teller @author Zheng Li *) val input_lines : Pervasives.in_channel -> string BatEnum.t (** Returns an enumeration over lines of an input channel, as read by the [input_line] function. *) val input_chars : Pervasives.in_channel -> char BatEnum.t (** Returns an enumeration over characters of an input channel. *) val input_list : Pervasives.in_channel -> string list (** Returns the list of lines read from an input channel. *) val input_all : Pervasives.in_channel -> string (** Return the whole contents of an input channel as a single string. *) val dump : 'a -> string (** Attempt to convert a value to a string. Works well for a lot of cases such as non-empty lists, algebraic datatype, and records. However, since types are lost at compile-time, the representation might not match your type. (0, 1) will be printed as expected, but (1, 0) and [1] have the same representation and will get printed in the same way. The result of [dump] is unspecified and may change in future versions, so you should only use it for debugging and never have program behavior depend on the output. Here is a list of some of the surprising corner cases of the current implementation: - (3, 0) is printed [3], (0.5, 0) is printed [0.5], etc. - None, false and [] are printed 0 [dump] may fail for ill-formed values, such as obtained from a faulty C binding or crazy uses of [Obj.set_tag]. *) val print_any : 'b BatIO.output -> 'a -> unit (** Attempt to print a value to an output. Uses [dump] to convert the value to a string and prints that string to the output. *) (** {6 List operations} More list operations are provided in module {!List}. *) val ( @ ) : 'a list -> 'a list -> 'a list (** List concatenation. *) (** {6 Input/output} This section only contains the most common input/output operations. More operations may be found in modules {!BatIO} and {!File}. *) val stdin : input (** Standard input, as per Unix/Windows conventions (by default, keyboard). Use this input to read what the user is writing on the keyboard.*) val stdout: unit output (** Standard output, as per Unix/Windows conventions (by default, console). Use this output to display regular messages.*) val stderr: unit output (** Standard error output, as per Unix/Windows conventions. Use this output to display warnings and error messages.*) val stdnull: unit output (** An output which discards everything written to it. Use this output to ignore messages.*) val flush_all : unit -> unit (** Write all pending data to output channels, ignore all errors. It is normally not necessary to call this function, as all pending data is written when an output channel is closed or when the program itself terminates, either normally or because of an uncaught exception. However, this function is useful for debugging, as it forces pending data to be written immediately. *) (** {7 Output functions on standard output} *) val print_bool : bool -> unit (** Print a boolean on standard output. *) val print_guess : 'a BatIO.output -> 'b -> unit (** Attempt to print the representation of a runtime value on the standard output. See remarks for {!dump}. This function is useful mostly for debugging. As a general rule, it should not be used in production code.*) val print_all : input -> unit (** Print the contents of an input to the standard output.*) (** {7 Output functions on standard error} *) val prerr_bool : bool -> unit (** Print a boolean to stderr. *) val prerr_guess : 'a -> unit (** Attempt to print the representation of a runtime value on the error output. See remarks for {!dump}. This function is useful mostly for debugging.*) val prerr_all : input -> unit (** Print the contents of an input to the error output.*) (** {7 General output functions} *) val output_file : filename:string -> text:string -> unit (** creates a filename, write text into it and close it. *) val open_out : ?mode:(BatFile.open_out_flag list) -> ?perm:BatFile.permission -> string -> unit BatIO.output (** Open the named file for writing, and return a new output channel on that file. You will need to close the file once you have finished using it. You may use optional argument [mode] to decide whether the output will overwrite the contents of the file (by default) or to add things at the end of the file, whether the file should be created if it does not exist yet (the default) or not, whether this operation should proceed if the file exists already (the default) or not, whether the file should be opened as text (the default) or as binary, and whether the file should be opened for non-blocking operations. You may use optional argument [perm] to specify the permissions of the file, as per Unix conventions. By default, files are created with default permissions (which depend on your setup). @raise Sys_error if the file could not be opened. *) val open_out_bin : string -> unit BatIO.output (** Same as {!open_out}, but the file is opened in binary mode, so that no translation takes place during writes. On operating systems that do not distinguish between text mode and binary mode, this function behaves like {!open_out} without any [mode] or [perm]. *) val open_out_gen : open_flag list -> int -> string -> unit BatIO.output (** [open_out_gen mode perm filename] opens the named file for writing, as described above. The extra argument [mode] specifies the opening mode. The extra argument [perm] specifies the file permissions, in case the file must be created. @deprecated Use {!open_out instead}*) val flush : unit BatIO.output -> unit (** Flush the buffer associated with the given output, performing all pending writes on that channel. Interactive programs must be careful about flushing standard output and standard error at the right time. *) val output_char : unit BatIO.output -> char -> unit (** Write the character on the given output channel. *) val output_string : unit BatIO.output -> string -> unit (** Write the string on the given output channel. *) val output : unit BatIO.output -> Bytes.t -> int -> int -> unit (** [output oc buf pos len] writes [len] characters from byte sequence [buf], starting at offset [pos], to the given output channel [oc]. @raise Invalid_argument if [pos] and [len] do not designate a valid subsequence of [buf]. *) val output_substring : unit BatIO.output -> string -> int -> int -> unit (** [output_substring oc buf pos len] writes [len] characters from string [buf], starting at offset [pos], to the given output channel [oc]. @raise Invalid_argument if [pos] and [len] do not designate a valid substring of [buf]. *) val output_byte : unit BatIO.output -> int -> unit (** Write one 8-bit integer (as the single character with that code) on the given output channel. The given integer is taken modulo 256. *) val output_binary_int : unit BatIO.output -> int -> unit (** Write one integer in binary format (4 bytes, big-endian) on the given output channel. The given integer is taken modulo 2{^32}. The only reliable way to read it back is through the {!Pervasives.input_binary_int} function. The format is compatible across all machines for a given version of OCaml. *) val output_binary_float : unit BatIO.output -> float -> unit (** Write one float in binary format (8 bytes, IEEE 754 double format) on the given output channel. The only reliable way to read it back is through the {!Pervasives.input_binary_float} function. The format is compatible across all machines for a given version of OCaml. *) val output_value : unit BatIO.output -> 'a -> unit (** Write the representation of a structured value of any type to a channel. Circularities and sharing inside the value are detected and preserved. The object can be read back, by the function {!input_value}. See the description of module {!Marshal} for more information. {!output_value} is equivalent to {!Marshal.output} with an empty list of flags. *) val close_out : unit BatIO.output -> unit (** Close the given channel, flushing all buffered write operations. Output functions raise a [Sys_error] exception when they are applied to a closed output channel, except [close_out] and [flush], which do nothing when applied to an already closed channel. @raise Sys_error if the operating system signals an error when flushing or closing. *) val close_out_noerr : unit BatIO.output -> unit (** Same as [close_out], but ignore all errors. *) (** {7 General input functions} *) val input_file : ?bin:bool -> string -> string (** returns the data of a given filename. *) val open_in : ?mode:(BatFile.open_in_flag list) -> ?perm:BatFile.permission -> string -> BatIO.input (** Open the named file for reading. You will need to close the file once you have finished using it. You may use optional argument [mode] to decide whether the opening should fail if the file doesn't exist yet (by default) or whether the file should be created if it doesn't exist yet, whether the opening should fail if the file already exists or not (by default), whether the file should be read as binary (by default) or as text, and whether reading should be non-blocking. You may use optional argument [perm] to specify the permissions of the file, should it be created, as per Unix conventions. By default, files are created with default permissions (which depend on your setup). @raise Sys_error if the file could not be opened. *) val open_in_bin : string -> BatIO.input (** Same as {!Pervasives.open_in}, but the file is opened in binary mode, so that no translation takes place during reads. On operating systems that do not distinguish between text mode and binary mode, this function behaves like {!Pervasives.open_in}. *) val open_in_gen : open_flag list -> int -> string -> BatIO.input (** [open_in_gen mode perm filename] opens the named file for reading, as described above. The extra arguments [mode] and [perm] specify the opening mode and file permissions. {!Pervasives.open_in} and {!Pervasives.open_in_bin} are special cases of this function. @deprecated Use {!open_in instead}*) val input_char : BatIO.input -> char (** Read one character from the given input channel. @raise End_of_file if there are no more characters to read. *) val input_line : BatIO.input -> string (** Read characters from the given input channel, until a newline character is encountered. Return the string of all characters read, without the newline character at the end. @raise End_of_file if the end of the file is reached at the beginning of line. *) val input : BatIO.input -> Bytes.t -> int -> int -> int (** [input ic buf pos len] reads up to [len] characters from the given channel [ic], storing them in byte sequence [buf], starting at character number [pos]. It returns the actual number of characters read, between 0 and [len] (inclusive). A return value of 0 means that the end of file was reached. A return value between 0 and [len] exclusive means that not all requested [len] characters were read, either because no more characters were available at that time, or because the implementation found it convenient to do a partial read; [input] must be called again to read the remaining characters, if desired. (See also {!Pervasives.really_input} for reading exactly [len] characters.) @raise Invalid_argument if [pos] and [len] do not designate a valid subsequence of [buf]. *) val really_input : BatIO.input -> Bytes.t -> int -> int -> unit (** [really_input ic buf pos len] reads [len] characters from channel [ic], storing them in byte sequence [buf], starting at character number [pos]. @raise End_of_file if the end of file is reached before [len] characters have been read. @raise Invalid_argument if [pos] and [len] do not designate a valid subsequence of [buf]. *) val input_byte : BatIO.input -> int (** Same as {!Pervasives.input_char}, but return the 8-bit integer representing the character. @raise End_of_file if an end of file was reached. *) val input_binary_int : BatIO.input -> int (** Read an integer encoded in binary format (4 bytes, big-endian) from the given input channel. See {!Pervasives.output_binary_int}. @raise End_of_file if an end of file was reached while reading the integer. *) val input_binary_float : BatIO.input -> float (** Read a float encoded in binary format (8 bytes, IEEE 754 double format) from the given input channel. See {!Pervasives.output_binary_float}. @raise End_of_file if an end of file was reached while reading the float. *) val input_value : BatIO.input -> 'a (** Read the representation of a structured value, as produced by {!output_value}, and return the corresponding value. This function is identical to {!Marshal.input}; see the description of module {!Marshal} for more information, in particular concerning the lack of type safety. *) val close_in : BatIO.input -> unit (** Close the given channel. Input functions raise a [Sys_error] exception when they are applied to a closed input channel, except [close_in], which does nothing when applied to an already closed channel. @raise Sys_error if the operating system signals an error. *) val close_in_noerr : BatIO.input -> unit (** Same as [close_in], but ignore all errors. *) (** {6 Fundamental functions and operators} *) external identity : 'a -> 'a = "%identity" (** The identity function. *) val undefined : ?message:string -> 'a -> 'b (** The undefined function. Evaluating [undefined x] always fails and raises an exception "Undefined". Optional argument [message] permits the customization of the error message.*) ##V<4## val ( @@ ) : ('a -> 'b) -> 'a -> 'b ##V>=4## external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" (** Function application. [f @@ x] is equivalent to [f x]. However, it binds less tightly (between [::] and [=],[<],[>],etc) and is right-associative, which makes it useful for composing sequences of function calls without too many parentheses. It is similar to Haskell's [$]. Note that it replaces pre-2.0 [**>] and [<|]. *) val ( % ) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b (** Function composition: the mathematical [o] operator. [f % g] is [fun x -> f (g x)]. It is similar to Haskell's [.]. Examples: the following are equivalent: [f (g (h x))], [f @@ g @@ h x], [f % g % h @@ x]. *) ##V<4## val ( |> ) : 'a -> ('a -> 'b) -> 'b ##V>=4## external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply" (** The "pipe": function application. [x |> f] is equivalent to [f x]. This operator is commonly used to write a function composition by order of evaluation (the order used in object-oriented programming) rather than by inverse order (the order typically used in functional programming). For instance, [g (f x)] means "apply [f] to [x], then apply [g] to the result." The corresponding notation in most object-oriented programming languages would be somewhere along the lines of [x.f.g.h()], or "starting from [x], apply [f], then apply [g]." In OCaml, using the ( |> ) operator, this is written [x |> f |> g |> h]. This operator may also be useful for composing sequences of function calls without too many parentheses. *) val ( %> ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c (** Piping function composition. [f %> g] is [fun x -> g (f x)]. Whereas [f % g] applies [g] first and [f] second, [f %> g] applies [f], then [g]. Note that it plays well with pipes, so for instance [x |> f %> g %> h |> i %> j] yields the expected result... but in such cases it's still recommended to use [|>] only. Note that it replaces pre-2.0 [|-], which {i didn't} integrate with pipes. *) val ( |? ) : 'a option -> 'a -> 'a (** Like {!BatOption.default}, with the arguments reversed. [None |? 10] returns [10], while [Some "foo" |? "bar"] returns ["foo"]. {b Note} This operator does not short circuit like [( || )] and [( && )]. Both arguments will be evaluated. @since 2.0 *) val flip : ( 'a -> 'b -> 'c ) -> 'b -> 'a -> 'c (** Argument flipping. [flip f x y] is [f y x]. Don't abuse this function, it may shorten considerably your code but it also has the nasty habit of making it harder to read.*) val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c (** Convert a function which accepts a pair of arguments into a function which accepts two arguments. [curry f] is [fun x y -> f (x,y)]*) val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c (** Convert a function which accepts two arguments into a function which accepts a pair of arguments. [uncurry f] is [fun (x, y) -> f x y]*) val neg : ('a -> bool) -> 'a -> bool (** [neg p] returns a new predicate that is the negation of the given predicate. That is, the new predicate returns [false] when the input predicate returns [true] and vice versa. This is for predicates with one argument. [neg p] is [fun x -> not (p x)] *) val neg2 : ('a -> 'b -> bool) -> 'a -> 'b -> bool (** as [neg] but for predicates with two arguments *) val const : 'a -> (_ -> 'a) (** Ignore its second argument. [const x] is the function which always returns [x].*) val unique : unit -> int (** Returns an unique identifier every time it is called. {b Note} This is thread-safe.*) val tap : ('a -> unit) -> 'a -> 'a (** Allows application of a function in the middle of a pipe sequence without disturbing the sequence. [x |> tap f] evaluates to [x], but has the side effect of [f x]. Useful for debugging. *) val finally : (unit -> unit) -> ('a -> 'b) -> 'a -> 'b (** [finally fend f x] calls [f x] and then [fend()] even if [f x] raised an exception. *) val with_dispose : dispose:('a -> unit) -> ('a -> 'b) -> 'a -> 'b (** [with_dispose dispose f x] invokes [f] on [x], calling [dispose x] when [f] terminates (either with a return value or an exception). *) val forever : ('a -> 'b) -> 'a -> unit (** [forever f x] invokes [f] on [x] repeatedly (until an exception occurs). *) val ignore_exceptions : ('a -> 'b) -> 'a -> unit (** [ignore_exceptions f x] invokes [f] on [x], ignoring both the returned value and the exceptions that may be raised. *) val verify_arg : bool -> string -> unit (** [verify_arg condition message] will raise [Invalid_argument message] if [condition] is false, otherwise it does nothing. @since 2.0 *) val args : unit -> string BatEnum.t (** An enumeration of the arguments passed to this program through the command line. [args ()] is given by the elements of [Sys.argv], minus the first element.*) (**/**) val invisible_args : int ref (** The number of arguments which must never be returned by [args] Typically, [invisible_args] is [1], to drop the name of the executable. However, in some circumstances, it may be useful to pretend that some arguments need not be parsed. *) (**/**) val exe : string (** The name of the current executable. [exe] is given by the first argument of [Sys.argv]*) (** {6 Enumerations} In OCaml Batteries Included, all data structures are enumerable, which means that they support a number of standard operations, transformations, etc. The general manner of {i enumerating} the contents of a data structure is to invoke the [enum] function of your data structure. For instance, you may use the {!foreach} loop to apply a function [f] to all the consecutive elements of a string [s]. For this purpose, you may write either [foreach (String.enum s) f] or [open String in foreach (enum s) f]. Either possibility states that you are enumerating through a character string [s]. Should you prefer your enumeration to proceed from the end of the string to the beginning, you may replace {! String.enum} with {! String.backwards}. Therefore, either [foreach (String.backwards s) f] or [open String in foreach (backwards s) f] will apply [f] to all the consecutive elements of string [s], from the last to the first. Similarly, you may use {!List.enum} instead of {!String.enum} to visit the elements of a list in the usual order, or {!List.backwards} instead of {!String.backwards} to visit them in the opposite order, or {!Hashtbl.enum} for hash tables, etc. More operations on enumerations are defined in module {!BatEnum}, including the necessary constructors to make your own structures enumerable. The various kinds of loops are detailed further in this documentation. *) val foreach: 'a BatEnum.t -> ('a -> unit) -> unit (** Imperative loop on an enumeration. [foreach e f] applies function [f] to each successive element of [e]. For instance, [foreach (1 -- 10) print_int] invokes function [print_int] on [1], [2], ..., [10], printing [12345678910]. {b Note} This function is one of the many loops available on enumerations. Other commonly used loops are {!iter} (same usage scenario as [foreach], but with different notations), {!map} (convert an enumeration to another enumeration) or {!fold} (flatten an enumeration by applying an operation to each element). *) (** {7 General-purpose loops} {topic loops} The following functions are the three main general-purpose loops available in OCaml. By opposition to the loops available in imperative languages, OCaml loops are regular functions, which may be passed, composed, currified, etc. In particular, each of these loops may be considered either as a manner of applying a function to a data structure or as transforming a function into another function which will act on a whole data structure. For instance, if [f] is a function operating on one value, you may lift this function to operate on all values of an enumeration (and consequently on all values of any data structure of OCaml Batteries Included) by applying {!iter}, {!map} or {!fold} to this function. *) val iter : ('a -> unit) -> 'a BatEnum.t -> unit (** Imperative loop on an enumeration. This loop is typically used to lift a function with an effect but no meaningful result and get it to work on enumerations. If [f] is a function [iter f] is a function which behaves as [f] but acts upon enumerations rather than individual elements. As indicated in the type of [iter], [f] must produce values of type [unit] (i.e. [f] has no meaningful result) the resulting function produces no meaningful result either. In other words, [iter f] is a function which, when applied upon an enumeration [e], calls [f] with each element of [e] in turn. For instance, [iter f (1 -- 10)] invokes function [f] on [1], [2], ..., [10] and produces value [()]. *) val map : ('a -> 'b) -> 'a BatEnum.t -> 'b BatEnum.t (** Transformation loop on an enumeration, used to build an enumeration from another enumeration. This loop is typically used to transform an enumeration into another enumeration with the same number of elements, in the same order. If [f] is a function, [map f e] is a function which behaves as [f] but acts upon enumerations rather than individual elements -- and builds a new enumeration from the results of each application. In other words, [map f] is a function which, when applied upon an enumeration containing elements [e0], [e1], ..., produces enumeration [f e0], [f e1], ... For instance, if [odd] is the function which returns [true] when applied to an odd number or [false] when applied to an even number, [map odd (1 -- 10)] produces enumeration [true], [false], [true], ..., [false]. Similarly, if [square] is the function [fun x -> x * x], [map square (1 -- 10)] produces the enumeration of the square numbers of all numbers between [1] and [10]. *) val filter_map : ('a -> 'b option) -> 'a BatEnum.t -> 'b BatEnum.t (** Similar to a map, except that you can skip over some items of the incoming enumeration by returning None instead of Some value. Think of it as a {!filter} combined with a {!map}. *) val reduce : ('a -> 'a -> 'a) -> 'a BatEnum.t -> 'a (** Transformation loop on an enumeration, used to build a single value from an enumeration. If [f] is a function and [e] is an enumeration, [reduce f e] applies function [f] to the first two elements of [e], then to the result of this expression and to the third element of [e], then to the result of this new expression and to the fourth element of [e]... In other words, [reduce f e] returns [a0] if [e] contains only one element [a0], otherwise [f (... (f (f a0) a1) ...) aN] where [a0,a1..aN] are the elements of [e]. @raise Not_found if [e] is empty. For instance, if [add] is the function [fun x y -> x + y], [reduce add] is the function which computes the sum of the elements of an enumeration -- and doesn't work on empty enumerations. Therefore, [reduce add (1 -- 10)] produces result [55]. *) val fold : ('b -> 'a -> 'b) -> 'b -> 'a BatEnum.t -> 'b (** Transformation loop on an enumeration, used to build a single value from an enumeration. This is the most powerful general-purpose loop and also the most complex. If [f] is a function, [fold f v e] applies [f v] to the first element of [e], then, calling [acc_1] the result of this operation, applies [f acc_1] to the second element of [e], then, calling [acc_2] the result of this operation, applies [f acc_2] to the third element of [e]... In other words, [fold f v e] returns [v] if [e] is empty, otherwise [f (... (f (f v a0) a1) ...) aN] where a0,a1..aN are the elements of [e]. For instance, if [add] is the function [fun x y -> x + y], [fold add 0] is the function which computes the sum of the elements of an enumeration. Therefore, [fold add 0 (1 -- 10)] produces result [55]. *) val scanl : ('b -> 'a -> 'b) -> 'b -> 'a BatEnum.t -> 'b BatEnum.t (** Functional loop on an enumeration, used to build an enumeration from both an enumeration and an initial value. This function may be seen as a variant of {!fold} which returns not only the final result of {!fold} but the enumeration of all the intermediate results of {!fold}. If [f] is a function, [scanl f v e] is applies [f v] to the first element of [e], then, calling [acc_1] the result of this operation, applies [f acc_1] to the second element of [e], then, calling [acc_2] the result of this operation, applies [f acc_2] to the third element of [e]... For instance, if [add] is the function [fun x y -> x + y], [scanl add 0] is the function which computes the sum of the elements of an enumeration. Therefore, [scanl add 0 (1 -- 10)] produces result the enumeration with elements [0, 1, 3, 6, 10, 15, 21, 28, 36, 45, 55]. *) val ( /@ ) : 'a BatEnum.t -> ('a -> 'b) -> 'b BatEnum.t val ( @/ ) : ('a -> 'b) -> 'a BatEnum.t -> 'b BatEnum.t (** Mapping operators. These operators have the same meaning as function {!map} but are sometimes more readable than this function, when chaining several transformations in a row. *) val ( //@ ) : 'a BatEnum.t -> ('a -> 'b option) -> 'b BatEnum.t val ( @// ) : ('a -> 'b option) -> 'a BatEnum.t -> 'b BatEnum.t (** Map combined with filter. Same as {!filter_map}. *) (** {7 Other operations on enumerations} *) val exists: ('a -> bool) -> 'a BatEnum.t -> bool (** [exists f e] returns [true] if there is some [x] in [e] such that [f x]*) val for_all: ('a -> bool) -> 'a BatEnum.t -> bool (** [for_all f e] returns [true] if for every [x] in [e], [f x] is true*) val find : ('a -> bool) -> 'a BatEnum.t -> 'a (** [find f e] returns the first element [x] of [e] such that [f x] returns [true], consuming the enumeration up to and including the found element, or, raises [Not_found] if no such element exists in the enumeration, consuming the whole enumeration in the search. Since [find] consumes a prefix of the enumeration, it can be used several times on the same enumeration to find the next element. @raise Not_found if no element in the whole enumeration satisfies the predicate *) val peek : 'a BatEnum.t -> 'a option (** [peek e] returns [None] if [e] is empty or [Some x] where [x] is the next element of [e]. The element is not removed from the enumeration. *) val get : 'a BatEnum.t -> 'a option (** [get e] returns [None] if [e] is empty or [Some x] where [x] is the next element of [e], in which case the element is removed from the enumeration. *) val push : 'a BatEnum.t -> 'a -> unit (** [push e x] will add [x] at the beginning of [e]. *) val junk : 'a BatEnum.t -> unit (** [junk e] removes the first element from the enumeration, if any. *) val filter : ('a -> bool) -> 'a BatEnum.t -> 'a BatEnum.t (** [filter f e] returns an enumeration over all elements [x] of [e] such as [f x] returns [true]. *) val ( // ) : 'a BatEnum.t -> ('a -> bool) -> 'a BatEnum.t (** Filtering (pronounce this operator name "such that"). For instance, [(1 -- 37) // odd] is the enumeration of all odd numbers between 1 and 37.*) val concat : 'a BatEnum.t BatEnum.t -> 'a BatEnum.t (** [concat e] returns an enumeration over all elements of all enumerations of [e]. *) val ( -- ) : int -> int -> int BatEnum.t (** Enumerate numbers. [5 -- 10] is the enumeration 5,6,7,8,9,10. [10 -- 5] is the empty enumeration*) val ( --^ ) : int -> int -> int BatEnum.t (** Enumerate numbers, without the right endpoint [5 -- 10] is the enumeration 5,6,7,8,9. *) val ( --. ) : (float * float) -> float -> float BatEnum.t (** [(a, step) --. b)] creates a float enumeration from [a] to [b] with an increment of [step] between elements. [(5.0, 1.0) --. 10.0] is the enumeration 5.0,6.0,7.0,8.0,9.0,10.0. [(10.0, -1.0) --. 5.0] is the enumeration 10.0,9.0,8.0,7.0,6.0,5.0. [(10.0, 1.0) --. 1.0] is the empty enumeration. *) val ( --- ) : int -> int -> int BatEnum.t (** As [--], but accepts enumerations in reverse order. [5 --- 10] is the enumeration 5,6,7,8,9,10. [10 --- 5] is the enumeration 10,9,8,7,6,5.*) val ( --~ ) : char -> char -> char BatEnum.t (** As ( -- ), but for characters.*) val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> 'b BatEnum.t -> unit (** Print and consume the contents of an enumeration.*) (** {6 Results} *) (** This type represents the outcome of a function which has the possibility of failure. Normal results of type ['a] are marked with [Ok], while failure values of type ['b] are marked with [Error]. This is intended to be a safer alternative to functions raising exceptions to signal failure. It is safer in that the possibility of failure has to be handled before the result of that computation can be used. For more functions related to this type, see the {!BatResult} module. *) type ('a, 'e) result = ('a, 'e) BatInnerPervasives.result = | Ok of 'a | Error of 'e (** The result of a computation - either an [Ok] with the normal result or a [Error] with some value (often an exception) containing failure information*) val ignore_ok : ('a, exn) result -> unit (** [ignore_ok (f x)] ignores the result of [f x] if it's ok, but throws the exception contained if [Error] is returned. *) val ok : ('a, exn) result -> 'a (** [f x |> ok] unwraps the [Ok] result of [f x] and returns it, or throws the exception contained if [Error] is returned. *) val wrap : ('a -> 'b) -> 'a -> ('b, exn) result (** [wrap f x] wraps a function that would normally throw an exception on failure such that it now returns a result with either the [Ok] return value or the [Error] exception. *) (** {6 Thread-safety internals} Unless you are attempting to adapt Batteries Included to a new model of concurrency, you probably won't need this. *) val lock: BatConcurrent.lock ref (** A lock used to synchronize internal operations. By default, this is {!BatConcurrent.nolock}. However, if you're using a version of Batteries compiled in threaded mode, this uses {!BatMutex}. If you're attempting to use Batteries with another concurrency model, set the lock appropriately. *) batteries-included-3.4.0/src/batPrintexc.ml000066400000000000000000000021301415601150500206630ustar00rootroot00000000000000(* * BatPrintexc - Extended Printexc module * Copyright (C) 1996 Xavier Leroy * 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) include Printexc let pass = print let print out e = BatInnerIO.nwrite out (to_string e) let print_backtrace out = BatInnerIO.nwrite out (get_backtrace ()) batteries-included-3.4.0/src/batPrintexc.mliv000066400000000000000000000423141415601150500212320ustar00rootroot00000000000000(* * BatPrintexc - Extended Printexc module * Copyright (C) 1996 Xavier Leroy * 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Facilities for printing exceptions. @author Xavier Leroy (Base module) @author David Teller *) val pass : ('a -> 'b) -> 'a -> 'b (** [Printexc.pass fn x] applies [fn] to [x] and returns the result. If the evaluation of [fn x] raises any exception, the name of the exception is printed on standard error output, and the exception is raised again. The typical use is to catch and report exceptions that escape a function application. This function is a renamed version of [Printexc.print] from stdlib.*) val catch: ('a -> 'b) -> 'a -> 'b (** [Printexc.catch fn x] is similar to {!Printexc.print}, but aborts the program with exit code 2 after printing the uncaught exception. This function is deprecated: the runtime system is now able to print uncaught exceptions as precisely as [Printexc.catch] does. Moreover, calling [Printexc.catch] makes it harder to track the location of the exception using the debugger or the stack backtrace facility. So, do not use [Printexc.catch] in new code. *) val to_string: exn -> string (** [Printexc.to_string e] returns a string representation of the exception [e]. *) val print_backtrace: _ BatInnerIO.output -> unit (** [print_backtrace oc] Prints the an exception backtrace on the output channel [oc]. The backtrace lists the program locations where the most-recently raised exception was raised and where it was propagated through function calls. @since 1.4.0 *) val get_backtrace: unit -> string (** [Printexc.get_backtrace ()] returns a string containing the same exception backtrace that [Printexc.print_backtrace] would print. *) val record_backtrace: bool -> unit (** [Printexc.record_backtrace b] turns recording of exception backtraces on (if [b = true]) or off (if [b = false]). Initially, backtraces are not recorded, unless the [b] flag is given to the program through the [OCAMLRUNPARAM] variable. *) val backtrace_status: unit -> bool (** [Printexc.backtrace_status()] returns [true] if exception backtraces are currently recorded, [false] if not. *) val register_printer: (exn -> string option) -> unit (** [Printexc.register_printer fn] registers [fn] as an exception printer. The printer should return [None] or raise an exception if it does not know how to convert the passed exception, and [Some s] with [s] the resulting string if it can convert the passed exception. Exceptions raised by the printer are ignored. When converting an exception into a string, the printers will be invoked in the reverse order of their registrations, until a printer returns a [Some s] value (if no such printer exists, the runtime will use a generic printer). *) val print : _ BatInnerIO.output -> exn -> unit (** Print an exception. The stdlib [print] function is now named [!pass].*) ##V=4.1##(** {6 Raw backtraces} *) ##V=4.1## ##V=4.1##type raw_backtrace = Printexc.raw_backtrace ##V=4.1## ##V=4.1##(** The abstract type [backtrace] stores exception backtraces in ##V=4.1## a low-level format, instead of directly exposing them as string as ##V=4.1## the [get_backtrace()] function does. ##V=4.1## ##V=4.1## This allows to pay the performance overhead of representation ##V=4.1## conversion and formatting only at printing time, which is useful ##V=4.1## if you want to record more backtrace than you actually print. ##V=4.1##*) ##V=4.1## ##V=4.1##val get_raw_backtrace: unit -> raw_backtrace ##V=4.1##val print_raw_backtrace: out_channel -> raw_backtrace -> unit ##V=4.1##val raw_backtrace_to_string: raw_backtrace -> string ##V>=4.5##external raise_with_backtrace: exn -> Printexc.raw_backtrace -> 'a ##V>=4.5## = "%raise_with_backtrace" ##V>=4.5##(** Reraise the exception using the given raw_backtrace for the ##V>=4.5## origin of the exception ##V>=4.5## ##V>=4.5## @since 2.7.0 and OCaml 4.05.0 ##V>=4.5##*) ##V=4.1##(** {6 Current call stack} *) ##V=4.1## ##V=4.1##val get_callstack: int -> raw_backtrace ##V=4.1## ##V=4.1##(** [Printexc.get_callstack n] returns a description of the top of the ##V=4.1## call stack on the current program point (for the current thread), ##V=4.1## with at most [n] entries. (Note: this function is not related to ##V=4.1## exceptions at all, despite being part of the [Printexc] module.) ##V=4.1## ##V=4.1## @since 2.2.0 and OCaml 4.01.0 ##V=4.1##*) ##V>=4.2##(** {6 Raw backtraces} *) ##V>=4.2## ##V>=4.2##type raw_backtrace = Printexc.raw_backtrace ##V>=4.2##(** The abstract type [raw_backtrace] stores a backtrace in ##V>=4.2## a low-level format, instead of directly exposing them as string as ##V>=4.2## the [get_backtrace()] function does. ##V>=4.2## ##V>=4.2## This allows delaying the formatting of backtraces to when they are ##V>=4.2## actually printed, which may be useful if you record more ##V>=4.2## backtraces than you print. ##V>=4.2## ##V>=4.2## Raw backtraces cannot be marshalled. If you need marshalling, you ##V>=4.2## should use the array returned by the [backtrace_slots] function of ##V>=4.2## the next section. ##V>=4.2## ##V>=4.2## @since 2.2.0 and OCaml 4.01.0 ##V>=4.2##*) ##V>=4.2## ##V>=4.2##val get_raw_backtrace: unit -> raw_backtrace ##V>=4.2##(** [Printexc.get_raw_backtrace ()] returns the same exception ##V>=4.2## backtrace that [Printexc.print_backtrace] would print, but in ##V>=4.2## a raw format. ##V>=4.2## ##V>=4.2## @since 2.2.0 and OCaml 4.01.0 ##V>=4.2##*) ##V>=4.2## ##V>=4.2##val print_raw_backtrace: out_channel -> raw_backtrace -> unit ##V>=4.2##(** Print a raw backtrace in the same format ##V>=4.2## [Printexc.print_backtrace] uses. ##V>=4.2## ##V>=4.2## @since 2.2.0 and OCaml 4.01.0 ##V>=4.2##*) ##V>=4.2## ##V>=4.2##val raw_backtrace_to_string: raw_backtrace -> string ##V>=4.2##(** Return a string from a raw backtrace, in the same format ##V>=4.2## [Printexc.get_backtrace] uses. ##V>=4.2## ##V>=4.2## @since 2.2.0 and OCaml 4.01.0 ##V>=4.2##*) ##V>=4.2## ##V>=4.2##(** {6 Current call stack} *) ##V>=4.2## ##V>=4.2##val get_callstack: int -> raw_backtrace ##V>=4.10##external get_callstack : int -> raw_backtrace = "caml_get_current_callstack" ##V>=4.2##(** [Printexc.get_callstack n] returns a description of the top of the ##V>=4.2## call stack on the current program point (for the current thread), ##V>=4.2## with at most [n] entries. (Note: this function is not related to ##V>=4.2## exceptions at all, despite being part of the [Printexc] module.) ##V>=4.2## ##V>=4.2## @since 2.2.0 and OCaml 4.01.0 ##V>=4.2##*) ##V>=4.2## ##V>=4.2##(** {6 Uncaught exceptions} *) ##V>=4.2## ##V>=4.11##val default_uncaught_exception_handler: exn -> raw_backtrace -> unit ##V>=4.11##(** [Printexc.default_uncaught_exception_handler] prints the exception and ##V>=4.11## backtrace on standard error output. ##V>=4.11## ##V>=4.11## @since 4.11 ##V>=4.11##*) ##V>=4.11## ##V>=4.2##val set_uncaught_exception_handler: (exn -> raw_backtrace -> unit) -> unit ##V>=4.2##(** [Printexc.set_uncaught_exception_handler fn] registers [fn] as the handler ##V>=4.2## for uncaught exceptions. The default handler prints the exception and ##V>=4.2## backtrace on standard error output. ##V>=4.2## ##V>=4.2## Note that when [fn] is called all the functions registered with ##V>=4.2## {!Pervasives.at_exit} have already been called. Because of this you must ##V>=4.2## make sure any output channel [fn] writes on is flushed. ##V>=4.2## ##V>=4.2## If [fn] raises an exception, it is ignored. ##V>=4.2## ##V>=4.2## @since 2.3.0 and OCaml 4.02.0 ##V>=4.2##*) ##V>=4.2## ##V>=4.2## ##V>=4.2##(** {6 Manipulation of backtrace information} ##V>=4.2## ##V>=4.2## Those function allow to traverse the slots of a raw backtrace, ##V>=4.2## extract information from them in a programmer-friendly format. ##V>=4.2##*) ##V>=4.2## ##V>=4.2##type backtrace_slot = Printexc.backtrace_slot ##V>=4.2##(** The abstract type [backtrace_slot] represents a single slot of ##V>=4.2## a backtrace. ##V>=4.2## ##V>=4.2## @since 2.3.0 and OCaml 4.02 ##V>=4.2##*) ##V>=4.2## ##V>=4.2##val backtrace_slots : raw_backtrace -> backtrace_slot array option ##V>=4.2##(** Returns the slots of a raw backtrace, or [None] if none of them ##V>=4.2## contain useful information. ##V>=4.2## ##V>=4.2## In the return array, the slot at index [0] corresponds to the most ##V>=4.2## recent function call, raise, or primitive [get_backtrace] call in ##V>=4.2## the trace. ##V>=4.2## ##V>=4.2## Some possible reasons for returning [None] are as follow: ##V>=4.2## - none of the slots in the trace come from modules compiled with ##V>=4.2## debug information ([-g]) ##V>=4.2## - the program is a bytecode program that has not been linked with ##V>=4.2## debug information enabled ([ocamlc -g]) ##V>=4.2## ##V>=4.2## @since 2.3.0 and OCaml 4.02.0 ##V>=4.2##*) ##V>=4.2## ##V>=4.2##type location = Printexc.location = { ##V>=4.2## filename : string; ##V>=4.2## line_number : int; ##V>=4.2## start_char : int; ##V>=4.2## end_char : int; ##V>=4.2##} ##V>=4.2##(** The type of location information found in backtraces. [start_char] ##V>=4.2## and [end_char] are positions relative to the beginning of the ##V>=4.2## line. ##V>=4.2## ##V>=4.2## @since 2.3.0 and OCaml 4.02 ##V>=4.2##*) ##V>=4.2## ##V>=4.2##module Slot : sig ##V>=4.2## type t = backtrace_slot ##V>=4.2## ##V>=4.2## val is_raise : t -> bool ##V>=4.2## (** [is_raise slot] is [true] when [slot] refers to a raising ##V>=4.2## point in the code, and [false] when it comes from a simple ##V>=4.2## function call. ##V>=4.2## ##V>=4.2## @since 2.3.0 and OCaml 4.02 ##V>=4.2## *) ##V>=4.2## ##V>=4.4## ##V>=4.4## val is_inline : t -> bool ##V>=4.4## (** [is_inline slot] is [true] when [slot] refers to a call ##V>=4.4## that got inlined by the compiler, and [false] when it comes from ##V>=4.4## any other context. ##V>=4.4## ##V>=4.4## @since 4.04.0 ##V>=4.4## *) ##V>=4.4## ##V>=4.2## val location : t -> location option ##V>=4.2## (** [location slot] returns the location information of the slot, ##V>=4.2## if available, and [None] otherwise. ##V>=4.2## ##V>=4.2## Some possible reasons for failing to return a location are as follow: ##V>=4.2## - the slot corresponds to a compiler-inserted raise ##V>=4.2## - the slot corresponds to a part of the program that has not been ##V>=4.2## compiled with debug information ([-g]) ##V>=4.2## ##V>=4.2## @since 2.3.0 and OCaml 4.02 ##V>=4.2## *) ##V>=4.2## ##V>=4.11## val name : t -> string option ##V>=4.11## (** [name slot] returns the name of the function or definition ##V>=4.11## enclosing the location referred to by the slot. ##V>=4.11## ##V>=4.11## [name slot] returns None if the name is unavailable, which ##V>=4.11## may happen for the same reasons as [location] returning None. ##V>=4.11## ##V>=4.11## @since 4.11 ##V>=4.11## *) ##V>=4.11## ##V>=4.2## val format : int -> t -> string option ##V>=4.2## (** [format pos slot] returns the string representation of [slot] as ##V>=4.2## [raw_backtrace_to_string] would format it, assuming it is the ##V>=4.2## [pos]-th element of the backtrace: the [0]-th element is ##V>=4.2## pretty-printed differently than the others. ##V>=4.2## ##V>=4.2## Whole-backtrace printing functions also skip some uninformative ##V>=4.2## slots; in that case, [format pos slot] returns [None]. ##V>=4.2## ##V>=4.2## @since 2.3.0 and OCaml 4.02 ##V>=4.2## *) ##V>=4.2##end ##V>=4.2## ##V>=4.2## ##V>=4.2##(** {6 Raw backtrace slots} *) ##V>=4.2## ##V>=4.2##type raw_backtrace_slot = Printexc.raw_backtrace_slot ##V>=4.2##(** This type allows direct access to raw backtrace slots, without any ##V>=4.2## conversion in an OCaml-usable data-structure. Being ##V>=4.2## process-specific, they must absolutely not be marshalled, and are ##V>=4.2## unsafe to use for this reason (marshalling them may not fail, but ##V>=4.2## un-marshalling and using the result will result in ##V>=4.2## undefined behavior). ##V>=4.2## ##V>=4.2## Elements of this type can still be compared and hashed: when two ##V>=4.2## elements are equal, then they represent the same source location ##V>=4.2## (the converse is not necessarily true in presence of inlining, ##V>=4.2## for example). ##V>=4.2##*) ##V>=4.2## ##V>=4.2##val raw_backtrace_length : raw_backtrace -> int ##V>=4.2##(** [raw_backtrace_length bckt] returns the number of slots in the ##V>=4.2## backtrace [bckt]. ##V>=4.2## ##V>=4.2## @since 2.3.0 and OCaml 4.02 ##V>=4.2##*) ##V>=4.2## ##V>=4.2##val get_raw_backtrace_slot : raw_backtrace -> int -> raw_backtrace_slot ##V>=4.2##(** [get_raw_backtrace_slot bckt pos] returns the slot in position [pos] in the ##V>=4.2## backtrace [bckt]. ##V>=4.2## ##V>=4.2## @since 2.3.0 and OCaml 4.02 ##V>=4.2##*) ##V>=4.2## ##V>=4.2##val convert_raw_backtrace_slot : raw_backtrace_slot -> backtrace_slot ##V>=4.2##(** Extracts the user-friendly [backtrace_slot] from a low-level ##V>=4.2## [raw_backtrace_slot]. ##V>=4.2## ##V>=4.2## @since 2.3.0 and OCaml 4.02 ##V>=4.2##*) ##V>=4.4##val get_raw_backtrace_next_slot : ##V>=4.4## raw_backtrace_slot -> raw_backtrace_slot option ##V>=4.4##(** [get_raw_backtrace_next_slot slot] returns the next slot inlined, if any. ##V>=4.4## ##V>=4.4## @since 2.11.0 and OCaml 4.04 ##V>=4.4##*) ##V>=4.2##(** {6 Exception slots} *) ##V>=4.2## ##V>=4.2##val exn_slot_id: exn -> int ##V>=4.2##(** [Printexc.exn_slot_id] returns an integer which uniquely identifies ##V>=4.2## the constructor used to create the exception value [exn] ##V>=4.2## (in the current runtime). ##V>=4.2## ##V>=4.2## @since 2.3.0 and OCaml 4.02.0 ##V>=4.2##*) ##V>=4.2## ##V>=4.2##val exn_slot_name: exn -> string ##V>=4.2##(** [Printexc.exn_slot_name exn] returns the internal name of the constructor ##V>=4.2## used to create the exception value [exn]. ##V>=4.2## ##V>=4.2## @since 2.3.0 and OCaml 4.02.0 ##V>=4.2##*) ##V>=4.08##type t = exn = .. ##V>=4.08##(** The type of exception values. *) ##V>=4.09##val use_printers: exn -> string option ##V>=4.09##(** [Printexc.use_printers e] returns [None] if there are no registered ##V>=4.09## printers and [Some s] with else as the resulting string otherwise. ##V>=4.09## ##V>=4.09## @since 2.11.0 and OCaml 4.09 ##V>=4.09##*) ##V>=4.09##val to_string_default: exn -> string ##V>=4.09##(** [Printexc.to_string_default e] returns a string representation of the ##V>=4.09## exception [e], ignoring all registered exception printers. ##V>=4.09## ##V>=4.09## @since 2.11.0 and OCaml 4.09 ##V>=4.09##*) ##V>=4.12##type raw_backtrace_entry = Printexc.raw_backtrace_entry ##V>=4.12##(** A [raw_backtrace_entry] is an element of a [raw_backtrace]. ##V>=4.12## ##V>=4.12## Each [raw_backtrace_entry] is an opaque integer, whose value is not stable ##V>=4.12## between different programs, or even between different runs of the same ##V>=4.12## binary. ##V>=4.12## ##V>=4.12## A [raw_backtrace_entry] can be converted to a usable form using ##V>=4.12## [backtrace_slots_of_raw_entry] below. Note that, due to inlining, a ##V>=4.12## single [raw_backtrace_entry] may convert to several [backtrace_slot]s. ##V>=4.12## Since the values of a [raw_backtrace_entry] are not stable, they cannot ##V>=4.12## be marshalled. If they are to be converted, the conversion must be done ##V>=4.12## by the process that generated them. ##V>=4.12## ##V>=4.12## Again due to inlining, there may be multiple distinct raw_backtrace_entry ##V>=4.12## values that convert to equal [backtrace_slot]s. However, if two ##V>=4.12## [raw_backtrace_entry]s are equal as integers, then they represent the same ##V>=4.12## [backtrace_slot]s. ##V>=4.12## ##V>=4.12## @since 3.3.0 and 4.12.0 *) ##V>=4.12## ##V>=4.12##val raw_backtrace_entries : raw_backtrace -> raw_backtrace_entry array ##V>=4.12##(** @since 3.3.0 and 4.12.0 *) ##V>=4.12## ##V>=4.12##val backtrace_slots_of_raw_entry : ##V>=4.12## raw_backtrace_entry -> backtrace_slot array option ##V>=4.12##(** Returns the slots of a single raw backtrace entry, or [None] if this ##V>=4.12## entry lacks debug information. ##V>=4.12## ##V>=4.12## Slots are returned in the same order as [backtrace_slots]: the slot ##V>=4.12## at index [0] is the most recent call, raise, or primitive, and ##V>=4.12## subsequent slots represent callers. ##V>=4.12## ##V>=4.12## @since 3.3.0 and 4.12 ##V>=4.12##*) batteries-included-3.4.0/src/batPrintf.mliv000066400000000000000000000413031415601150500206750ustar00rootroot00000000000000(* * BatPrintf - Extended Printf module * Copyright (C) 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open BatInnerIO (** Formatted output functions (also known as unparsing). @author Xavier Leroy @author Pierre Weiss @author David Teller *) (** {6 General overview} The functions of this module produce output according to a {!Pervasives.format}, as described below. Some functions write to the standard output (i.e. the screen), some to error channels, some to strings or to buffers, or some to abstract outputs. {b Note} The types used in this module are confusing at first. If you are a beginner, you should probably ignore them in a first time and concentrate on formats. For a first explanation, we will concentrate on function {!printf}. As all the functions in this module, the behavior of {!printf} is dictated by a {!format}. This format is a string, composed of regular text and directives, and which dictates how to interpret the other arguments passed to the function. Every directive starts with character [%]. The most common directive is [%s], which serves to display a string, something quite useful for pretty-printing or translation. Anther common directive is [%i], which serves to display an integer. For instance, ["foobar"] is a format with no directive. Calling [printf "foobar"] prints ["foobar"] on the screen and returns [()]. On the other hand, ["%s"] is a format with one directive for printing strings. [printf "%s"] does nothing yet but returns a function with type [string -> unit]. In turn, [printf "%s" "foobar"] prints ["foobar"] on the screen and returns [()]. The main interest of this module is that directives may be combined together and with text, to allow more complex printing. For instance [printf "(%s)\n"] is a function with type [string -> unit] which, when passed string ["foobar"] prints ["(foobar)"] and ends the line. Similarly, [printf "Here's the result: %s.\n\tComputation took %i seconds.\n" "foobar" 5] prints {[Here's the result: foobar Computation took 5 seconds.]} Note that [\n] (the newline character) and [\t] (the tabulation) are not specific to this module but rather part of the conventions on characters strings in OCaml. Other directives and functions make this module extremely useful for printing, pretty-printing and translation of messages to the user's language. For more information, see the documentation of {!format} and the various functions.*) (** {6 Formats} *) type ('a, 'b, 'c) t = ('a, 'b, 'c) Pervasives.format (** The format to use for displaying the various arguments passed to the function. Syntactically, the format is a character string which contains two types of objects: plain characters, which are simply copied, and directives, each of which causes the conversion and printing of arguments. {7 Simple directives} All directives start with the [%] character. In their simplest form, a directive is [%] followed by exactly one character: - [%d], [%i], [%n], [%l], [%L], or [%N]: convert an integer argument to signed decimal. - [%u]: convert an integer argument to unsigned decimal. - [%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]: insert a string argument in OCaml syntax (double quotes, escapes). - [%c]: insert a character argument. - [%C]: insert a character argument in 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). - [%B]: convert a boolean argument to the string [true] or [false] - [%b]: convert a boolean argument (for backward compatibility; 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. - [!]: take no argument and flush the output. - [%]: take no argument and output one [%] character. - [,]: the no-op delimiter for conversion specifications {7 Unparsers} - [%a]: user-defined printer. Typically, this printer corresponds to two arguments: a printing function [f], with type ['a output -> 'c -> unit] and the item [x] you want to print, with type ['c]. Item [x] will be printing by calling [f out x], where [out] is the output you are currently using -- if you are calling {!printf}, this output is the standard output (i.e. the screen), if you are calling {!eprintf}, this will be the error channel, if you are calling {!fprintf}, this will be the output you provided yourself, etc. More generally, if your {!format} has type [('a, 'b, 'd) format] or [('a, 'b, 'd, 'e) format4], the printing function [f] must have type ['b -> 'c -> 'd], where [x] has type ['d]. - [%t]: same as [%a] but takes only a printing function [f], without an item. If your {!format} has type [('a, 'b, 'd) format] or [('a, 'b, 'd, 'e) format4], function [f] must have type ['b -> 'd]. {7 Formatting formats} - [%\{ fmt %\}]: convert a {!format} to a string. The format argument must have the same type as the internal format string [fmt]. In other words, [printf "%\{ %s %\}"] accepts an argument whose type must be the same as that of format ["%s"], and prints that format argument as if it were a character string. - [%( fmt %)]: format string substitution. Takes a format string argument and substitutes it to the internal format string [fmt] to print following arguments. The argument must have the same type as [fmt]. [printf "%\{ %s %\}"] accepts an argument whose type must be the same as that of format ["%s"], and uses that argument to print the following arguments. {7 Additional options} The general format of directives is [% \[flags\] \[width\] \[.precision\] type] [type] is one of [d], [i], [n], [l], [L], [N], [u], [x] ..., [( fmt %)] and behaves as explained above. The optional [flags] are: - [-]: left-justify the output (default is right justification). - [0]: for numerical conversions, pad with zeroes instead of spaces. - [+]: for numerical conversions, prefix number with a [+] sign if positive. - space: for numerical conversions, prefix number with a space if positive. - [#]: request an alternate formatting style for numbers. 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. *) (** {6 Common functions}*) val printf: ('b, 'a output, unit) t -> 'b (**The usual [printf] function, prints to the standard output {!stdout}, i.e. normally to the screen. If you are lost, this is probably the function you're looking for.*) val eprintf: ('b, 'a output, unit) t -> 'b (**The usual [eprintf] function, prints to the standard error output {!stderr}, used to display warnings and errors. Otherwise identical to {!printf}.*) val sprintf: ('a, unit, string) t -> 'a (** A function which doesn't print its result but returns it as a string. Useful for building messages, for translation purposes or for display in a window, for instance. While this function is quite convenient, don't abuse it to create very large strings such as files, that's not its role. For this kind of usage, prefer the more modular and usually faster {!fprintf}. Note that any function called with [%a] should return strings, i.e. should have type [unit -> string].*) val sprintf2: ('a, 'b output, unit, string) format4 -> 'a (** A function which doesn't print its result but returns it as a string. Useful for building messages, for translation purposes or for display in a window, for instance. While this function is quite convenient, don't abuse it to create very large strings such as files, that's not its role. For this kind of usage, prefer the more modular and usually faster {!fprintf}. Note that any function called with [%a] should be able to print its result, i.e. should have type ['b output -> unit]. Warning: a partial application of this function can only be used once, because the {!BatInnerIO.output} that it uses is closed afterwards. Example: [let f = sprintf2 "%a" Int.print in [f 1; f 2]] will fail. *) (** {6 General functions}*) val fprintf: 'a output -> ('b, 'a output, unit) t -> 'b (**General function. This function prints to any output. Typically, if you are attempting to build a large output such as a file, this is probably the function you are looking for. If you are writing a pretty-printer, this is probably the function you are looking for. If you are you are looking for a function to use for argument [%a] with {!printf}, {!eprintf}, {!sprintf2}, {!ifprintf}, {!bprintf2}, {!kfprintf}, {!ksprintf2}, {!kbprintf2} or any other function with type [(_, _ output, unit) format] or [(_, _ output, unit, _) format4], this is also probably the function you are looking for.*) val ifprintf: _ -> ('b, 'a output, unit) t -> 'b (**As {!fprintf} but doesn't actually print anything. Sometimes useful for debugging.*) val bprintf: Buffer.t -> ('a, Buffer.t, unit) t -> 'a (**As {!fprintf}, but with buffers instead of outputs. In particular, any unparser called with [%a] should write to a buffer rather than to an output*) val bprintf2: Buffer.t -> ('b, 'a output, unit) t -> 'b (**As {!printf} but writes to a buffer instead of printing to the output. By opposition to {!bprintf}, only the result is changed with respect to {!printf}, not the inner workings.*) (**{6 Functions with continuations}*) val kfprintf : ('a output -> 'b) -> 'a output -> ('c, 'a output, unit, 'b) format4 -> 'c (**Same as [fprintf], but instead of returning immediately, passes the [output] to its first argument at the end of printing.*) val ksprintf: (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b (** Same as [sprintf] above, but instead of returning the string, passes it to the first argument. *) val ksprintf2: (string -> 'b) -> ('c, 'a output, unit, 'b) format4 -> 'c (** Same as [sprintf2] above, but instead of returning the string, passes it to the first argument. *) val kbprintf : (Buffer.t -> 'a) -> Buffer.t -> ('b, Buffer.t, unit, 'a) format4 -> 'b (** Same as [bprintf], but instead of returning immediately, passes the buffer to its first argument at the end of printing. *) val kbprintf2 : (Buffer.t -> 'b) -> Buffer.t -> ('c, 'a output, unit, 'b) format4 -> 'c (** Same as [bprintf2], but instead of returning immediately, passes the buffer to its first argument at the end of printing.*) val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b (** @deprecated This is a deprecated synonym for [ksprintf]. *) (** {6 About formats} You only need to read this if you intend to create your new printf-like functions, which happens generally by toying with {!mkprintf}. {7 Format4} [('a, 'b, 'c, 'd) format4] is the type of arguments for [printf]-style functions such that - ['a] is the type of arguments, with a return type of ['d] {ul {- if your format looks like ["%s"], ['a] is [string -> 'd]} {- if your format looks like ["%s%s"], ['a] is [string -> string -> 'd]} {- ...} } - ['b] is the type of the first argument given to unparsers (i.e. functions introduced with [%a] or [%t]) {ul {- if your unparsers take a [unit] argument, ['b] should be [unit]} {- if your unparsers take a [string output], ['b] should be [string output]} {- ...} } - ['c] is the {b final} return type of unparsers {ul {- if you have an unparser introduced with [%t] and its result has type [unit], ['c] should be [unit]} {- if you have an unparser introduced with [%a] and its type is [string output -> string -> unit], ['c] should be [unit]} {- ...} } - ['d] is the final return value of the function once all arguments have been printed {7 Format} [('a, 'b, 'c) format] or [('a, 'b, 'c) t] is just a shortcut for [('a, 'b, 'c, 'c) format4]. {7 Important} Note that {!Obj.magic} is involved behind this, so be careful. *) (**/**) (* For OCaml system internal use only. Don't call directly. *) ##V<4.2##module CamlinternalPr : sig ##V<4.2## ##V<4.2## module Sformat : sig ##V<4.2## type index;; ##V<4.2## ##V<4.2## val index_of_int : int -> index;; ##V<4.2## external int_of_index : index -> int = "%identity";; ##V<4.2## external unsafe_index_of_int : int -> index = "%identity";; ##V<4.2## ##V<4.2## val succ_index : index -> index;; ##V<4.2## ##V<4.2## val sub : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> index -> int -> string;; ##V<4.2## val to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string;; ##V<4.2## external length : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int ##V<4.2## = "%string_length";; ##V<4.2## external get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char ##V<4.2## = "%string_safe_get";; ##V<4.2## external unsafe_to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string ##V<4.2## = "%identity";; ##V<4.2## external unsafe_get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char ##V<4.2## = "%string_unsafe_get";; ##V<4.2## ##V<4.2## end;; ##V<4.2## ##V<4.2## module Tformat : sig ##V<4.2## ##V<4.2## type ac = { ##V<4.2## mutable ac_rglr : int; ##V<4.2## mutable ac_skip : int; ##V<4.2## mutable ac_rdrs : int; ##V<4.2## };; ##V<4.2## ##V<4.2## val ac_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ac;; ##V<4.2## ##V<4.2## val sub_format : ##V<4.2## (('a, 'b, 'c, 'd, 'e, 'f) format6 -> int) -> ##V<4.2## (('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char -> int) -> ##V<4.2## char -> ##V<4.2## ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ##V<4.2## int -> ##V<4.2## int ##V<4.2## ##V<4.2## val summarize_format_type : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string ##V<4.2## ##V<4.2## val scan_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ##V<4.2## 'g array -> ##V<4.2## Sformat.index -> ##V<4.2## int -> ##V<4.2## (Sformat.index -> string -> int -> 'h) -> ##V<4.2## (Sformat.index -> 'i -> 'j -> int -> 'h) -> ##V<4.2## (Sformat.index -> 'k -> int -> 'h) -> ##V<4.2## (Sformat.index -> int -> 'h) -> ##V<4.2## (Sformat.index -> ('l, 'm, 'n, 'o, 'p, 'q) format6 -> int -> 'h) -> ##V<4.2## 'h ##V<4.2## ##V<4.2## val kapr : ##V<4.2## (('a, 'b, 'c, 'd, 'e, 'f) format6 -> Obj.t array -> 'g) -> ##V<4.2## ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ##V<4.2## 'g ##V<4.2## ##V<4.2## end;; ##V<4.2## ##V<4.2##end;; (**/**) batteries-included-3.4.0/src/batPrintf.mlv000066400000000000000000000443171415601150500205340ustar00rootroot00000000000000(* * BatPrintf - Extended Printf module * Copyright (C) 2008 David Teller (contributor) * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** {6 Printf} A reimplementation of Printf (with a few additional functions) based on [output]. We provide an internal signature to limit the dangers of {!Obj.magic}. {b Note} this module is inlined because of circular dependencies (themselves caused by the legacy definition of a function {!printf} in module {!BatIO}). *) open BatInnerIO external format_float: string -> float -> string = "caml_format_float" external format_int: string -> int -> string = "caml_format_int" external format_int32: string -> int32 -> string = "caml_int32_format" external format_nativeint: string -> nativeint -> string = "caml_nativeint_format" external format_int64: string -> int64 -> string = "caml_int64_format" module Sformat = struct type index;; external unsafe_index_of_int : int -> index = "%identity";; let index_of_int i = if i >= 0 then unsafe_index_of_int i else failwith ("index_of_int: negative argument " ^ string_of_int i);; external int_of_index : index -> int = "%identity";; let add_int_index i idx = index_of_int (i + int_of_index idx);; let succ_index = add_int_index 1;; let length fmt = String.length (string_of_format fmt) let get fmt i = String.get (string_of_format fmt) i let unsafe_get fmt i = String.unsafe_get (string_of_format fmt) i let unsafe_to_string = string_of_format let sub fmt idx len = String.sub (unsafe_to_string fmt) (int_of_index idx) len;; let to_string fmt = sub fmt (unsafe_index_of_int 0) (length fmt);; end;; let bad_conversion sfmt i c = invalid_arg ("printf: bad conversion %" ^ String.make 1 c ^ ", at char number " ^ string_of_int i ^ " in format string ``" ^ sfmt ^ "''");; let bad_conversion_format fmt i c = bad_conversion (Sformat.to_string fmt) i c;; let incomplete_format fmt = invalid_arg ("printf: premature end of format string ``" ^ Sformat.to_string fmt ^ "''");; (* Parses a string conversion to return the specified length and the padding direction. *) let parse_string_conversion sfmt = let rec parse neg i = if i >= String.length sfmt then (0, neg) else match String.unsafe_get sfmt i with | '1'..'9' -> (int_of_string (String.sub sfmt i (String.length sfmt - i - 1)), neg) | '-' -> parse true (succ i) | _ -> parse neg (succ i) in try parse false 1 with Failure _ -> bad_conversion sfmt 0 's' (* Pad a (sub) string into a blank string of length [p], on the right if [neg] is true, on the left otherwise. *) let pad_string pad_char p neg s i len = if p = len && i = 0 then s else if p <= len then String.sub s i len else let res = Bytes.make p pad_char in if neg then Bytes.blit_string s i res 0 len else Bytes.blit_string s i res (p - len) len; Bytes.unsafe_to_string res (* Format a string given a %s format, e.g. %40s or %-20s. To do: ignore other flags (#, +, etc)? *) let format_string sfmt s = let (p, neg) = parse_string_conversion sfmt in pad_string ' ' p neg s 0 (String.length s);; (* Extract a format string out of [fmt] between [start] and [stop] inclusive. '*' in the format are replaced by integers taken from the [widths] list. extract_format returns a string. *) let extract_format fmt start stop widths = let start = succ start in let b = Buffer.create (stop - start + 10) in Buffer.add_char b '%'; let rec fill_format i widths = if i <= stop then match (Sformat.unsafe_get fmt i, widths) with | ('*', h :: t) -> Buffer.add_string b (string_of_int h); let i = succ i in fill_format i t | ('*', []) -> assert false (* should not happen *) | (c, _) -> Buffer.add_char b c; fill_format (succ i) widths in fill_format start (List.rev widths); Buffer.contents b;; let extract_format_int conv fmt start stop widths = let sfmt = extract_format fmt start stop widths in match conv with | 'n' | 'N' -> let sfmt = Bytes.of_string sfmt in Bytes.set sfmt (Bytes.length sfmt - 1) 'u'; Bytes.unsafe_to_string sfmt | _ -> sfmt;; (* Returns the position of the next character following the meta format string, starting from position [i], inside a given format [fmt]. According to the character [conv], the meta format string is enclosed by the delimitors %{ and %} (when [conv = '{']) or %( and %) (when [conv = '(']). Hence, [sub_format] returns the index of the character following the [')'] or ['}'] that ends the meta format, according to the character [conv]. *) let sub_format incomplete_format bad_conversion_format conv fmt i = let len = Sformat.length fmt in let rec sub_fmt c i = let close = if c = '(' then ')' else (* '{' *) '}' in let rec sub j = if j >= len then incomplete_format fmt else match Sformat.get fmt j with | '%' -> sub_sub (succ j) | _ -> sub (succ j) and sub_sub j = if j >= len then incomplete_format fmt else match Sformat.get fmt j with | '(' | '{' as c -> let j = sub_fmt c (succ j) in sub (succ j) | '}' | ')' as c -> if c = close then succ j else bad_conversion_format fmt i c | _ -> sub (succ j) in sub i in sub_fmt conv i;; let sub_format_for_printf conv = sub_format incomplete_format bad_conversion_format conv;; let iter_on_format_args fmt add_conv add_char = let lim = Sformat.length fmt - 1 in let rec scan_flags skip i = if i > lim then incomplete_format fmt else match Sformat.unsafe_get fmt i with | '*' -> scan_flags skip (add_conv skip i 'i') | '#' | '-' | ' ' | '+' -> scan_flags skip (succ i) | '_' -> scan_flags true (succ i) | '0'..'9' | '.' -> scan_flags skip (succ i) | _ -> scan_conv skip i and scan_conv skip i = if i > lim then incomplete_format fmt else match Sformat.unsafe_get fmt i with | '%' | '!' | ',' -> succ i | 's' | 'S' | '[' -> add_conv skip i 's' | 'c' | 'C' -> add_conv skip i 'c' | 'd' | 'i' |'o' | 'u' | 'x' | 'X' | 'N' -> add_conv skip i 'i' | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> add_conv skip i 'f' | 'B' | 'b' -> add_conv skip i 'B' | 'a' | 'r' | 't' as conv -> add_conv skip i conv | 'l' | 'n' | 'L' as conv -> let j = succ i in if j > lim then add_conv skip i 'i' else begin match Sformat.get fmt j with | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> add_char (add_conv skip i conv) 'i' | _c -> add_conv skip i 'i' end | '{' as conv -> (* Just get a regular argument, skipping the specification. *) let i = add_conv skip i conv in (* To go on, find the index of the next char after the meta format. *) let j = sub_format_for_printf conv fmt i in (* Add the meta specification to the summary anyway. *) let rec loop i = if i < j - 2 then loop (add_char i (Sformat.get fmt i)) in loop i; (* Go on, starting at the closing brace to properly close the meta specification in the summary. *) scan_conv skip (j - 1) | '(' as conv -> (* Use the static format argument specification instead of the runtime format argument value: they must have the same type anyway. *) scan_fmt (add_conv skip i conv) | '}' | ')' as conv -> add_conv skip i conv | conv -> bad_conversion_format fmt i conv and scan_fmt i = if i < lim then if Sformat.get fmt i = '%' then scan_fmt (scan_flags false (succ i)) else scan_fmt (succ i) else i in ignore (scan_fmt 0);; (* Returns a string that summarizes the typing information that a given format string contains. For instance, [summarize_format_type "A number %d\n"] is "%i". It also checks the well-formedness of the format string. *) let summarize_format_type fmt = let len = Sformat.length fmt in let b = Buffer.create len in let add_char i c = Buffer.add_char b c; succ i in let add_conv skip i c = if skip then Buffer.add_string b "%_" else Buffer.add_char b '%'; add_char i c in iter_on_format_args fmt add_conv add_char; Buffer.contents b;; module Ac = struct type ac = { mutable ac_rglr : int; mutable ac_skip : int; mutable ac_rdrs : int; } end;; open Ac;; (* Computes the number of arguments of a format (including flag arguments if any). *) let ac_of_format fmt = let ac = { ac_rglr = 0; ac_skip = 0; ac_rdrs = 0; } in let incr_ac skip c = let inc = if c = 'a' then 2 else 1 in if c = 'r' then ac.ac_rdrs <- ac.ac_rdrs + 1; if skip then ac.ac_skip <- ac.ac_skip + inc else ac.ac_rglr <- ac.ac_rglr + inc in let add_conv skip i c = (* Just finishing a meta format: no additional argument to record. *) if c <> ')' && c <> '}' then incr_ac skip c; succ i and add_char i _c = succ i in iter_on_format_args fmt add_conv add_char; ac;; let count_arguments_of_format fmt = let ac = ac_of_format fmt in ac.ac_rglr + ac.ac_skip + ac.ac_rdrs;; let list_iter_i f l = let rec loop i = function | [] -> () | [x] -> f i x (* Tail calling [f] *) | x :: xs -> f i x; loop (succ i) xs in loop 0 l;; (* ``Abstracting'' version of kprintf: returns a (curried) function that will print when totally applied. Note: in the following, we are careful not to be badly caught by the compiler optimizations on the representation of arrays. *) let kapr kpr fmt = match count_arguments_of_format fmt with | 0 -> kpr fmt [||] | 1 -> Obj.magic (fun x -> let a = Array.make 1 (Obj.repr 0) in a.(0) <- x; kpr fmt a) | 2 -> Obj.magic (fun x y -> let a = Array.make 2 (Obj.repr 0) in a.(0) <- x; a.(1) <- y; kpr fmt a) | 3 -> Obj.magic (fun x y z -> let a = Array.make 3 (Obj.repr 0) in a.(0) <- x; a.(1) <- y; a.(2) <- z; kpr fmt a) | 4 -> Obj.magic (fun x y z t -> let a = Array.make 4 (Obj.repr 0) in a.(0) <- x; a.(1) <- y; a.(2) <- z; a.(3) <- t; kpr fmt a) | 5 -> Obj.magic (fun x y z t u -> let a = Array.make 5 (Obj.repr 0) in a.(0) <- x; a.(1) <- y; a.(2) <- z; a.(3) <- t; a.(4) <- u; kpr fmt a) | 6 -> Obj.magic (fun x y z t u v -> let a = Array.make 6 (Obj.repr 0) in a.(0) <- x; a.(1) <- y; a.(2) <- z; a.(3) <- t; a.(4) <- u; a.(5) <- v; kpr fmt a) | nargs -> let rec loop i args = if i >= nargs then let a = Array.make nargs (Obj.repr 0) in list_iter_i (fun i arg -> a.(nargs - i - 1) <- arg) args; kpr fmt a else Obj.magic (fun x -> loop (succ i) (x :: args)) in loop 0 [];; (* Get the index of the next argument to printf. *) let next_index n = Sformat.succ_index n;; (* Decode a format string and act on it. [fmt] is the printf format string, and [pos] points to a [%] character. After consuming the appropriate number of arguments and formatting them, one of the five continuations is called: [cont_s] for outputting a string (args: arg num, string, next pos) [cont_a] for performing a %a action (args: arg num, fn, arg, next pos) [cont_t] for performing a %t action (args: arg num, fn, next pos) [cont_f] for performing a flush action (args: arg num, next pos) [cont_m] for performing a %( action (args: arg num, sfmt, next pos) "arg num" is the index in array args of the next argument to printf. "next pos" is the position in [fmt] of the first character following the %conversion specification in [fmt]. *) (* Note: here, rather than test explicitly against [Sformat.length fmt] to detect the end of the format, we use [Sformat.unsafe_get] and rely on the fact that we'll get a "nul" character if we access one past the end of the string. These "nul" characters are then caught by the [_ -> bad_conversion] clauses below. Don't do this at home, kids. *) let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m = let get_arg n = Obj.magic (args.(Sformat.int_of_index n)) in let rec scan_flags n widths i = match Sformat.unsafe_get fmt i with | '*' -> let (width : int) = get_arg n in scan_flags (next_index n) (width :: widths) (succ i) | '0'..'9' | '.' | '#' | '-' | ' ' | '+' -> scan_flags n widths (succ i) | _ -> scan_conv n widths i and scan_conv n widths i = match Sformat.unsafe_get fmt i with | '%' -> cont_s n "%" (succ i) | 's' | 'S' as conv -> let (x : string) = get_arg n in let x = if conv = 's' then x else "\"" ^ String.escaped x ^ "\"" in let s = (* optimize for common case %s *) if i = succ pos then x else format_string (extract_format fmt pos i widths) x in cont_s (next_index n) s (succ i) | 'c' | 'C' as conv -> let (x : char) = get_arg n in let s = if conv = 'c' then String.make 1 x else "'" ^ Char.escaped x ^ "'" in cont_s (next_index n) s (succ i) | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' as conv -> let (x : int) = get_arg n in let s = format_int (extract_format_int conv fmt pos i widths) x in cont_s (next_index n) s (succ i) | 'f' | 'e' | 'E' | 'g' | 'G' -> let (x : float) = get_arg n in let s = format_float (extract_format fmt pos i widths) x in cont_s (next_index n) s (succ i) | 'F' -> let (x : float) = get_arg n in cont_s (next_index n) (string_of_float x) (succ i) | 'B' | 'b' -> let (x : bool) = get_arg n in cont_s (next_index n) (string_of_bool x) (succ i) | 'a' -> let printer = get_arg n in let n = Sformat.succ_index n in let arg = get_arg n in cont_a (next_index n) printer arg (succ i) | 't' -> let printer = get_arg n in cont_t (next_index n) printer (succ i) | 'l' | 'n' | 'L' as conv -> begin match Sformat.unsafe_get fmt (succ i) with | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> let i = succ i in let s = match conv with | 'l' -> let (x : int32) = get_arg n in format_int32 (extract_format fmt pos i widths) x | 'n' -> let (x : nativeint) = get_arg n in format_nativeint (extract_format fmt pos i widths) x | _ -> let (x : int64) = get_arg n in format_int64 (extract_format fmt pos i widths) x in cont_s (next_index n) s (succ i) | _ -> let (x : int) = get_arg n in let s = format_int (extract_format_int 'n' fmt pos i widths) x in cont_s (next_index n) s (succ i) end | ',' -> cont_s n "" (succ i) | '!' -> cont_f n (succ i) | '{' | '(' as conv (* ')' '}' *) -> let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg n in let i = succ i in let j = sub_format_for_printf conv fmt i in if conv = '{' (* '}' *) then (* Just print the format argument as a specification. *) cont_s (next_index n) (summarize_format_type xf) j else (* Use the format argument instead of the format specification. *) cont_m (next_index n) xf j | (* '(' *) ')' -> cont_s n "" (succ i) | conv -> bad_conversion_format fmt i conv in scan_flags n [] (succ pos);; (*Trimmed-down version of the legacy lib's [mkprintf]. Most of the generality is lifted to [output] rather than [mkprintf] itself.*) let mkprintf k out fmt = let rec pr k n fmt v = let len = Sformat.length fmt in let rec doprn n i = if i >= len then Obj.magic (k out) else match Sformat.unsafe_get fmt i with | '%' -> scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m | c -> write out c; doprn n (succ i) and cont_s n s i = nwrite out s; doprn n i and cont_a n printer arg i = printer out arg; doprn n i and cont_t n printer i = printer out; doprn n i and cont_f n i = flush out; doprn n i and cont_m n xf i = let m = Sformat.add_int_index (count_arguments_of_format xf) n in pr (Obj.magic (fun _ -> doprn m i)) n xf v in doprn n 0 in let kpr = pr k (Sformat.index_of_int 0) in kapr kpr fmt;; external identity : 'a -> 'a = "%identity"(*Inlined from [Std] to avoid cyclic dependencies*) let fprintf out fmt = mkprintf ignore out fmt let printf fmt = fprintf stdout fmt let eprintf fmt = fprintf stderr fmt let ifprintf _ fmt = fprintf stdnull fmt let ksprintf2 k fmt = let out = output_string () in mkprintf (fun out -> k (close_out out)) out fmt let kbprintf2 k buf fmt = let out = BatBuffer.output_buffer buf in mkprintf (fun _out -> k buf) out fmt let sprintf2 fmt = ksprintf2 (identity) fmt let bprintf2 buf fmt = kbprintf2 ignore buf fmt (* Other possible implementation of [sprintf2], left as example: [ let sprintf2 fmt = let out = output_string () in mkprintf (fun out -> close_out out) out fmt ] *) (* Other possible implementation of [bprintf2], left as example: [ let bprintf2 buf fmt = let out = output_buffer buf in mkprintf ignore out fmt ]*) type ('a, 'b, 'c) t = ('a, 'b, 'c) Pervasives.format let kfprintf = mkprintf let bprintf = Printf.bprintf let sprintf = Printf.sprintf let ksprintf = Printf.ksprintf let kbprintf = Printf.kbprintf let kprintf = Printf.kprintf ##V<4.2##module CamlinternalPr = Printf.CamlinternalPr batteries-included-3.4.0/src/batQueue.ml000066400000000000000000000105001415601150500201530ustar00rootroot00000000000000(* * BatQueue - Extended operations on queues * Copyright (C) 1996 Xavier Leroy * 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) include Queue type 'a enumerable = 'a t let map f q = let r = create () in iter (fun x -> add (f x) r) q; r (*$T map create () |> map (fun x -> x) |> is_empty create () |> tap (add 1) |> map (fun x -> x+1) \ |> enum |> BatList.of_enum |> (=) [2] create () |> tap (add 1) |> tap (add 2) |> map (fun x -> x+1) \ |> enum |> BatList.of_enum |> (=) [2;3] let q = Queue.create () in \ for i = 1 to 5 do Queue.push i q; done; \ let q = map ((+) 10) q in \ BatList.of_enum (enum q) = [11;12;13;14;15] *) let filter f q = let r = create () in iter (fun x -> if f x then add x r) q; r (*$T filter create () |> filter (fun n -> n>3) |> is_empty create () |> tap (add 1) |> filter (fun n -> n>3) |> is_empty create () |> tap (add 1) |> tap (add 2) |> filter (fun n -> n>3) |> is_empty create () |> tap (add 1) |> tap (add 2) |> filter (fun n -> n>1) |> enum |> BatList.of_enum |> (=) [2] create () |> tap (add 1) |> tap (add 2) |> filter (fun n -> n>0) |> enum |> BatList.of_enum |> (=) [1;2] *) let filter_map f q = let r = create () in iter (fun x -> match f x with | None -> () | Some v -> add v r) q; r (*$T filter_map create () |> filter_map (fun n -> None) |> is_empty create () |> tap (add 1) \ |> filter_map (fun n -> if n>3 then Some (n+1) else None) |> is_empty create () |> tap (add 1) |> tap (add 2) \ |> filter_map (fun n -> if n>3 then Some (n+1) else None) |> is_empty create () |> tap (add 1) |> tap (add 2) \ |> filter_map (fun n -> if n>1 then Some (n+1) else None) |> enum \ |> BatList.of_enum |> (=) [3] create () |> tap (add 1) |> tap (add 2) \ |> filter_map (fun n -> if n>0 then Some (n+1) else None) |> enum \ |> BatList.of_enum |> (=) [2;3] *) let filter_inplace f q = BatConcreteQueue.(filter_inplace f (of_abstr q)) (*$T filter_inplace let q1 = Queue.create () in \ for i = 1 to 5 do Queue.push i q1; done; \ let q2,q3 = Queue.copy q1, Queue.copy q1 in \ filter_inplace (fun a -> List.mem a [2;4]) q1; \ filter_inplace (fun a -> List.mem a [3]) q2; \ filter_inplace (fun a -> List.mem a []) q3; \ length q1 = 2 && \ length q2 = 1 && \ length q3 = 0 && \ BatList.of_enum (enum q1) = [2;4] && \ BatList.of_enum (enum q2) = [3] && \ BatList.of_enum (enum q3) = [] *) let of_enum e = let q = create () in BatEnum.iter (fun x -> push x q) e; q (*$Q of_enum (Q.list Q.int) (fun l -> \ let e = BatList.enum l in \ BatEnum.equal (=) (enum (of_enum (BatEnum.clone e))) e \ ) *) let enum q = BatEnum.from (fun () -> try pop q with Empty -> raise BatEnum.No_more_elements) (*$T enum let q = Queue.create () in \ for i = 0 to 10 do Queue.push i q; done; \ let e = enum q in \ let i = ref (-1) in \ BatEnum.count e = 11 && BatEnum.for_all (fun elt -> incr i; !i = elt) e *) let print ?(first="") ?(last="") ?(sep="") print_a out t = BatEnum.print ~first ~last ~sep print_a out (enum (copy t)) (*$T print BatIO.to_string (print ~sep:"," ~first:"[" ~last:"]" BatInt.print) (of_enum (BatArray.enum [|2;4;66|])) = "[2,4,66]" *) let compare cmp a b = BatEnum.compare cmp (enum a) (enum b) let equal eq a b = BatEnum.equal eq (enum a) (enum b) module Exceptionless = struct let peek q = try Some (peek q) with Empty -> None let take q = try Some (take q) with Empty -> None (*$T Exceptionless.peek (Queue.create ()) = None Exceptionless.take (Queue.create ()) = None *) end batteries-included-3.4.0/src/batQueue.mliv000066400000000000000000000133141415601150500205200ustar00rootroot00000000000000(* * BatQueue - Extended operations on queues * Copyright (C) 1996 Xavier Leroy * 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** First-in first-out queues. This module implements queues (FIFOs), with in-place modification. @author Xavier Leroy (Base module) @author David Teller *) type 'a t = 'a Queue.t (** The type of queues containing elements of type ['a]. *) exception Empty (** Raised when {!Queue.take} or {!Queue.peek} is applied to an empty queue. *) val create : unit -> 'a t (** Return a new queue, initially empty. *) val add : 'a -> 'a t -> unit (** [add x q] adds the element [x] at the end of the queue [q]. *) val push : 'a -> 'a t -> unit (** [push] is a synonym for [add]. *) val take : 'a t -> 'a (** [take q] removes and returns the first element in queue [q], or raises [Empty] if the queue is empty. *) ##V>=4.08##val take_opt : 'a t -> 'a option ##V>=4.08##(** [take_opt q] removes and returns the first element in queue [q], ##V>=4.08## or returns [None] if the queue is empty. ##V>=4.08## @since 2.10.0 and OCaml 4.08 *) val pop : 'a t -> 'a (** [pop] is a synonym for [take]. *) val peek : 'a t -> 'a (** [peek q] returns the first element in queue [q], without removing it from the queue, or raises [Empty] if the queue is empty. *) ##V>=4.08##val peek_opt : 'a t -> 'a option ##V>=4.08##(** [peek_opt q] returns the first element in queue [q], without removing ##V>=4.08## it from the queue, or returns [None] if the queue is empty. ##V>=4.08## @since 2.10.0 and OCaml 4.08 *) val top : 'a t -> 'a (** [top] is a synonym for [peek]. *) val clear : 'a t -> unit (** Discard all elements from a queue. *) val copy : 'a t -> 'a t (** Return a copy of the given queue. *) val is_empty : 'a t -> bool (** Return [true] if the given queue is empty, [false] otherwise. *) val length : 'a t -> int (** Return the number of elements in a queue. *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f q] applies [f] in turn to all elements of [q], from the least recently entered to the most recently entered. The queue itself is unchanged. *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f q] applies function [f] to each element of the queue and returns a new queue [q'] with the results returned by [f]. Order is preserved and [q] is not consumed. So that if [take q] returns [x] [take q'] will return [f x]. @since 2.3.0 *) val filter : ('a -> bool) -> 'a t -> 'a t (** [filter p q] returns a new queue that contain the elements of [q] that satisfy the predicate [p], in the same order. @since 2.4 *) val filter_map : ('a -> 'b option) -> 'a t -> 'b t (** [filter_map f q] applies [f] to the elements [a0,a1..an] of [q] in order, and returns the queue of the elements [bi] such that [f ai = Some bi], in the corresponding order. @since 2.4 *) val filter_inplace : ('a -> bool) -> 'a t -> unit (** [filter_inplace p q] removes all the elements of the queue [q] that don't satisfy the predicate [p]. The order of the elements in the queue is preserved. @since 2.4 *) val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b (** [fold f accu q] is equivalent to [List.fold_left f accu l], where [l] is the list of [q]'s elements. The queue remains unchanged. *) val transfer : 'a t -> 'a t -> unit (** [transfer q1 q2] adds all of [q1]'s elements at the end of the queue [q2], then clears [q1]. It is equivalent to the sequence [iter (fun x -> add x q2) q1; clear q1], but runs in constant time. *) type 'a enumerable = 'a t val enum : 'a t -> 'a BatEnum.t (** [enum q] returns a destructive enumeration of the elements of queue [q], from the least recently entered to the most recently entered. Reading the enumeration will progressively empty [q].*) val of_enum : 'a BatEnum.t -> 'a t (** [of_enum e] returns a new queue containing all the elements of [e]. This is equivalent to calling [push] with the first element of the enumeration, then with the second, etc.*) ##V>=4.07##(** {1 Iterators} *) ##V>=4.07##val to_seq : 'a t -> 'a Seq.t ##V>=4.07##(** Iterate on the queue, in front-to-back order. ##V>=4.07## The behavior is not defined if the queue is modified ##V>=4.07## during the iteration. ##V>=4.07## @since 2.10.0 and OCaml 4.07 *) ##V>=4.07##val add_seq : 'a t -> 'a Seq.t -> unit ##V>=4.07##(** Add the elements from the generator to the end of the queue ##V>=4.07## @since 2.10.0 and OCaml 4.07 *) ##V>=4.07##val of_seq : 'a Seq.t -> 'a t ##V>=4.07##(** Create a queue from the generator ##V>=4.07## @since 2.10.0 and OCaml 4.07 *) (** {6 Boilerplate code}*) (** {7 Printing}*) val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> 'b t -> unit val compare : 'a BatOrd.comp -> 'a t BatOrd.comp val equal : 'a BatOrd.eq -> 'a t BatOrd.eq module Exceptionless : sig val take : 'a t -> 'a option val peek : 'a t -> 'a option end batteries-included-3.4.0/src/batRMutex.ml000066400000000000000000000110311415601150500203130ustar00rootroot00000000000000(* * RMutex - Reentrant mutexes * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * 2011 Edgar Friendly * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module BaseRMutex = struct type owner = { thread : int; (**Identity of the latest owner (possibly the current owner)*) mutable depth : int (**Number of times the current owner owns the lock.*) } type t = { primitive : Mutex.t; (**A low-level mutex, used to protect access to [ownership]*) wait : Condition.t; (** a condition to wait on when the lock is locked *) mutable ownership : owner option; } let create () = { primitive = Mutex.create (); wait = Condition.create (); ownership = None } (** Attempt to acquire the mutex, waiting indefinitely *) let lock m = let id = Thread.id (Thread.self ()) in Mutex.lock m.primitive; (******Critical section begins*) ( match m.ownership with | None -> (*Lock belongs to nobody, I can take it. *) m.ownership <- Some {thread = id; depth = 1} | Some s when s.thread = id -> (*Lock already belongs to me, I can keep it. *) s.depth <- s.depth + 1 | _ -> (*Lock belongs to someone else. *) while not (m.ownership = None) do Condition.wait m.wait m.primitive done; m.ownership <- Some {thread = id; depth = 1} ); Mutex.unlock m.primitive (******Critical section ends*) (** Attempt to acquire the mutex, returning true if successful. If waiting would be required, return false instead. *) let try_lock m = let id = Thread.id (Thread.self ()) in Mutex.lock m.primitive; (******Critical section begins*) let r = match m.ownership with | None -> (*Lock belongs to nobody, I can take it. *) m.ownership <- Some {thread = id; depth = 1}; true | Some s when s.thread = id -> (*Lock already belongs to me, I can keep it. *) s.depth <- s.depth + 1; true | _ -> (*Lock belongs to someone else. *) false (* give up *) in Mutex.unlock m.primitive; (******Critical section ends*) r (** Unlock the mutex; this function checks that the thread calling unlock is the owner and raises an assertion failure if this is not the case. It will also raise an assertion failure if the mutex is not locked. *) let unlock m = let id = Thread.id (Thread.self ()) in Mutex.lock m.primitive; (******Critical section begins*) (match m.ownership with | Some s -> assert (s.thread = id); (*If I'm not the owner, we have a consistency issue.*) if s.depth > 1 then s.depth <- s.depth - 1 (*release one depth but we're still the owner*) else begin m.ownership <- None; (*release once and for all*) Condition.signal m.wait (*wake up waiting threads *) end | _ -> assert false ); Mutex.unlock m.primitive (******Critical section ends *) end module Lock = BatConcurrent.MakeLock(BaseRMutex) include BaseRMutex let make = Lock.make let synchronize = Lock.synchronize (*let synchronize ?lock:(l=create ()) f = fun x -> lock l; try let result = f x in lock l; result with e -> lock l; raise e*) (*$R create; lock; unlock let test num_threads work_per_thread = let l = create () in let count = ref 0 in let worker n = for i = 1 to work_per_thread do lock l; lock l; Thread.delay 0.001; incr count; unlock l; Thread.delay 0.0001; unlock l; done in let children = Array.init num_threads (Thread.create worker) in Array.iter Thread.join children; !count in assert_equal (30*30) (test 30 30) ~printer:string_of_int *) batteries-included-3.4.0/src/batRMutex.mli000066400000000000000000000062641415601150500205000ustar00rootroot00000000000000(* * RMutex - Reentrant mutexes * Copyright (C) 1996 Xavier Leroy * 1996 Damien Doligez * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Reentrant Mutexes Mutexes (mutual-exclusion locks) are used to implement critical sections and protect shared mutable data structures against concurrent accesses. The typical use is (if [m] is the mutex associated with the data structure [D]): {[ RMutex.synchronize ~lock:m (fun () -> (* Critical section that operates over D *); ) () ]} This module implements reentrant mutexes, i.e. a version of mutexes which may be locked again by their owner thread without blocking this thread. Reentrant mutexes are typically slower than regular mutexes but also safer. @documents RMutex @author Xavier Leroy (Base module) @author Damien Doligez (Base module) @author David Teller *) type t (** The type of mutexes. *) val create : unit -> t (** Return a new mutex. *) val lock : t -> unit (** Lock the given mutex. Only one thread can have the mutex locked at any time. A thread that attempts to lock a mutex already locked will suspend until the other mutex is unlocked. {b Note} attempting to lock a mutex you already have locked from the same thread will not suspend your thread. *) val try_lock : t -> bool (** Same as {!RMutex.lock}, but does not suspend the calling thread if the mutex is already locked: just return [false] immediately in that case. If the mutex is unlocked, lock it and return [true]. *) val unlock : t -> unit (** Unlock the given mutex. Other threads suspended trying to lock the mutex will restart. If the mutex wasn't locked, nothing happens.*) val synchronize : ?lock:t -> ('a -> 'b) -> 'a -> 'b (** Protect a function. [synchronize f] returns a new function [f'] with the same behavior as [f] but such that concurrenty calls to [f'] are queued if necessary to avoid races. [synchronize ~lock:l f] behaves as [synchronize f] but uses a user-specified lock [l], which may be useful to share a lock between several function. In either case, the lock is acquired when entering the function and released when the function call ends, whether this is due to normal termination or to some exception being raised. *) val make : unit -> BatConcurrent.lock (** Create a new abstract lock based on Reentrant Mutexes. *) batteries-included-3.4.0/src/batRandom.mliv000066400000000000000000000222711415601150500206560ustar00rootroot00000000000000(* * BatRandom - Additional randomization operations * Copyright (C) 1996 Damien Doligez * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Pseudo-random number generators (PRNG). This module extends Stdlib's {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Random.html}Random} module, go there for documentation on the rest of the functions and types. @author Damien Doligez (base library) @author David Teller @author Pierre Chambart @documents Random *) (** {6 Basic functions} *) val init : int -> unit (** Initialize the generator, using the argument as a seed. The same seed will always yield the same sequence of numbers. *) val full_init : int array -> unit (** Same as {!Random.init} but takes more data as seed. *) val self_init : unit -> unit (** Initialize the generator with a more-or-less random seed chosen in a system-dependent way. *) val bits : unit -> int (** Return 30 random bits in a nonnegative integer. *) val int : int -> int (** [Random.int bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0 and less than 2{^30}. *) ##V>=4.13##val full_int : int -> int ##V>=4.13##(** [Random.full_int bound] returns a random integer between 0 (inclusive) ##V>=4.13## and [bound] (exclusive). [bound] may be any positive integer. ##V>=4.13## ##V>=4.13## If [bound] is less than 2{^30}, [Random.full_int bound] is equal to ##V>=4.13## {!Random.int}[ bound]. If [bound] is greater than 2{^30} (on 64-bit systems ##V>=4.13## or non-standard environments, such as JavaScript), [Random.full_int] ##V>=4.13## returns a value, where {!Random.int} raises {!Invalid_argument}. ##V>=4.13## ##V>=4.13## @since 3.4.0 and OCaml 4.13.0 *) val int32 : Int32.t -> Int32.t (** [Random.int32 bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0. *) val nativeint : Nativeint.t -> Nativeint.t (** [Random.nativeint bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0. *) val int64 : Int64.t -> Int64.t (** [Random.int64 bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0. *) val float : float -> float (** [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 bool : unit -> bool (** [Random.bool ()] returns [true] or [false] with probability 0.5 each. *) val char : unit -> char (** Return a random Latin-1 character.*) (*val uchar : unit -> UChar.t (** Return a random Unicode character.*)*) val full_range_int : unit -> int (** [full_range_int ()] returns the maximum entropy possible in a single int: 31 bits on 32-bit platforms and 63 bits on 64-bit platforms. Intentionally gives different results on different platforms, so is not portable. *) (** {6 Enumerations of random values.} *) val enum_bits : unit -> int BatEnum.t val enum_int : int -> int BatEnum.t val enum_bool : unit -> bool BatEnum.t val enum_float : float -> float BatEnum.t val enum_int32 : Int32.t -> Int32.t BatEnum.t val enum_int64 : Int64.t -> Int64.t BatEnum.t val enum_nativeint : Nativeint.t -> Nativeint.t BatEnum.t val enum_char : unit -> char BatEnum.t (*val enum_uchar : unit -> UChar.t BatEnum.t*) (** {6 Working with data structures.} *) val choice : 'a BatEnum.t -> 'a (** [choice e] returns a randomly-chosen element of [e]. This function only works on finite enumerations with less than 2{^30} elements.*) val multi_choice : int -> 'a BatEnum.t -> 'a BatEnum.t (** [multi_choice n e] returns an enumeration of [n] randomly-chosen elements of [e]. *) val shuffle: 'a BatEnum.t -> 'a array (** [shuffle e] returns a new array, containing the same set of elements as [e], but in a random order. Shuffling is implemented using the Fisher-Yates algorithm and works in O(n), where n is the number of elements of [e]. This function only works on finite enumerations with less than 2{^30} elements. *) (** {6 Advanced functions} *) (** Manipulate the current state of the random generator. This allows using one or several deterministic PRNGs, even in a multi-threaded program, without interference from other parts of the program. *) module State : sig type t = Random.State.t (** The type of PRNG states. *) val make : int array -> t (** Create a new state and initialize it with the given seed. *) val make_self_init : unit -> t (** Create a new state and initialize it with a system-dependent low-entropy seed. *) val copy : t -> t (** Return a copy of the given state. *) val bits : t -> int val int : t -> int -> int ##V>=4.13##val full_int : t -> int -> int val int32 : t -> Int32.t -> Int32.t val nativeint : t -> Nativeint.t -> Nativeint.t val int64 : t -> Int64.t -> Int64.t val float : t -> float -> float val bool : t -> bool val char : t -> char (* val uchar : t -> UChar.t*) val enum_bits : t -> unit -> int BatEnum.t val enum_int : t -> int -> int BatEnum.t val enum_bool : t -> unit -> bool BatEnum.t val enum_float : t -> float -> float BatEnum.t val enum_int32 : t -> Int32.t -> Int32.t BatEnum.t val enum_int64 : t -> Int64.t -> Int64.t BatEnum.t val enum_nativeint : t -> Nativeint.t -> Nativeint.t BatEnum.t val enum_char : t -> unit -> char BatEnum.t (* val enum_uchar : t -> unit -> UChar.t BatEnum.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. *) end val get_state : unit -> State.t (** Return the current state of the generator used by the basic functions. *) val set_state : State.t -> unit (** Set the state of the generator used by the basic functions. *) module Incubator : sig module Private_state_enums : sig module State : sig (** same as BatRandom.State *) type t = Random.State.t (** The type of PRNG states. *) val make : int array -> t (** Create a new state and initialize it with the given seed. *) val make_self_init : unit -> t (** Create a new state and initialize it with a system-dependent low-entropy seed. *) val copy : t -> t (** Return a copy of the given state. *) val bits : t -> int val int : t -> int -> int val int32 : t -> Int32.t -> Int32.t val nativeint : t -> Nativeint.t -> Nativeint.t val int64 : t -> Int64.t -> Int64.t val float : t -> float -> float val bool : t -> bool val char : t -> char (** A copy of the input state is made to start these generators; the input state is not modified. This means that two enums constructed from the same state will produce the same value sequence. *) val enum_bits : t -> unit -> int BatEnum.t val enum_int : t -> int -> int BatEnum.t val enum_bool : t -> unit -> bool BatEnum.t val enum_float : t -> float -> float BatEnum.t val enum_int32 : t -> Int32.t -> Int32.t BatEnum.t val enum_int64 : t -> Int64.t -> Int64.t BatEnum.t val enum_nativeint : t -> Nativeint.t -> Nativeint.t BatEnum.t val enum_char : t -> unit -> char BatEnum.t (** [perturb s] returns a new state based on the given state that is, in a sense, the hash of the input state. This new state should be quite different from the input. *) val perturb : t -> t end (** These enumerations are built on a copy of the global RNG state. To keep successive constructions from using the same RNG state, when any of these functions is called, the global RNG state is perturbed by using its current internal state as seed to construct a new state. *) val enum_bits : unit -> int BatEnum.t val enum_int : int -> int BatEnum.t val enum_bool : unit -> bool BatEnum.t val enum_float : float -> float BatEnum.t val enum_int32 : Int32.t -> Int32.t BatEnum.t val enum_int64 : Int64.t -> Int64.t BatEnum.t val enum_nativeint : Nativeint.t -> Nativeint.t BatEnum.t val enum_char : unit -> char BatEnum.t end end batteries-included-3.4.0/src/batRandom.mlv000066400000000000000000000146721415601150500205130ustar00rootroot00000000000000(* * BatRandom - Additional randomization operations * Copyright (C) 1996 Damien Doligez * 2009 David Teller, LIFO, Universite d'Orleans * 2009 Pierre Chambart * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) let init = Random.init let full_init = Random.full_init let self_init = Random.self_init let bits = Random.bits let int = Random.int ##V>=4.13##let full_int = Random.full_int let int32 = Random.int32 let int64 = Random.int64 let nativeint = Random.nativeint let float = Random.float let bool = Random.bool let char () = Char.chr (int 256) let full_range_int = if Sys.word_size = 32 then (* need 31-bits of entropy, bits() gives 30 *) fun () -> if bool () then - (bits ())-1 else bits () else (* 64-bit words *) fun () -> (* need 63 bits of entropy , bits + bits + bits land 0b11 *) let b = (bits ()) lor (bits () lsl 30) lor ((bits () land 0b11) lsl 60) in if bool () then b else -b - 1 module State = struct include Random.State let char t = Char.chr (int t 256) (**A constructor for enumerations of random numbers. *) let enum_bits state () = BatEnum.from (fun () -> bits state) let enum_int state bound = BatEnum.from (fun () -> int state bound) let enum_int32 state bound = BatEnum.from (fun () -> int32 state bound) let enum_int64 state bound = BatEnum.from (fun () -> int64 state bound) let enum_float state bound = BatEnum.from (fun () -> float state bound) let enum_nativeint state bound = BatEnum.from (fun () -> nativeint state bound) let enum_bool state () = BatEnum.from (fun () -> bool state) let enum_char state () = BatEnum.from (fun () -> char state) end let enum_bits () = BatEnum.from bits let enum_int bound = BatEnum.from (fun () -> int bound) let enum_int32 bound = BatEnum.from (fun () -> int32 bound) let enum_int64 bound = BatEnum.from (fun () -> int64 bound) let enum_float bound = BatEnum.from (fun () -> float bound) let enum_nativeint bound = BatEnum.from (fun () -> nativeint bound) let enum_bool () = BatEnum.from bool let enum_char () = BatEnum.from char let choice e = BatEnum.drop (int (BatEnum.count e)) e; BatEnum.get_exn e (* Reservoir sampling algorithm (see for instance http://en.wikipedia.org/wiki/Reservoir_sampling) TODO: a more efficient algorithm when given enum length is known *) let multi_choice n e = if BatEnum.is_empty e then BatEnum.empty () else let next e = BatOption.get (BatEnum.get e) in (* Note: this assumes that Array.init will call the function for i = 0 to n-1 in that order *) let chosen = Array.init n (fun i -> next e, i) in BatEnum.iteri (fun i x -> let i = i + n + 1 in (* we've already chosen the n first items *) let r = Random.int i in if r < n then chosen.(r) <- x, i) e ; Array.sort (fun (_, i1) (_, i2) -> compare i1 i2) chosen ; BatArray.enum (Array.map fst chosen) (*$T multi_choice BatEnum.is_empty (multi_choice 0 (BatEnum.empty ())) BatEnum.count (multi_choice 3 (BatList.enum [1;2;3;4;5])) = 3 let l = [1;2;3;4;5] in let e = multi_choice 2 (BatList.enum l) in \ let a = BatOption.get (BatEnum.get e) in a < BatOption.get (BatEnum.get e) let x = BatEnum.repeat ~times:99 [0;1] /@ (fun l -> \ multi_choice 1 (BatList.enum l)) /@ \ BatEnum.get_exn |> \ reduce (+) in x > 0 && x < 99 *) (* Note: this last test check that the first nor the last item is always chosen *) let shuffle e = let a = BatArray.of_enum e in BatInnerShuffle.array_shuffle a; a let get_state = Random.get_state let set_state = Random.set_state module Incubator = struct module Private_state_enums = struct module State = struct include State (* the state we defined up above *) let random_enum state next = let rec aux state = let next () = next state in let count () = raise BatEnum.Infinite_enum in let clone () = aux ( copy state ) in BatEnum.make ~next ~count ~clone in aux (copy state) let enum_bits state () = random_enum state bits let enum_int state bound = random_enum state (fun state -> int state bound) let enum_int32 state bound = random_enum state (fun state -> int32 state bound) let enum_int64 state bound = random_enum state (fun state -> int64 state bound) let enum_float state bound = random_enum state (fun state -> float state bound) let enum_nativeint state bound = random_enum state (fun state -> nativeint state bound) let enum_bool state () = random_enum state bool let enum_char state () = random_enum state char type implementation = { st : int array; mutable idx : int };; (* external t_of_impl: implementation -> t = "%identity" *) external impl_of_t: t -> implementation = "%identity" let perturb state = let impl = impl_of_t state in make (Array.append impl.st [|impl.idx|]) end (* bumps the existing global RNG state (reseeding on its current array) and returns the previous state *) let perturb_global () = let s_in = get_state () in set_state (State.perturb s_in); s_in let enum_bits () = State.enum_bits (perturb_global ()) () let enum_bool () = State.enum_bool (perturb_global ()) () let enum_char () = State.enum_char (perturb_global ()) () let enum_int bound = State.enum_int (perturb_global ()) bound let enum_int32 bound = State.enum_int32 (perturb_global ()) bound let enum_int64 bound = State.enum_int64 (perturb_global ()) bound let enum_float bound = State.enum_float (perturb_global ()) bound let enum_nativeint bound = State.enum_nativeint (perturb_global ()) bound end end batteries-included-3.4.0/src/batRef.ml000066400000000000000000000060511415601150500176110ustar00rootroot00000000000000(* * Ref - Operations on references * Copyright (C) 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type 'a t = 'a ref let post r f = let old = !r in r := f old; old let pre r f = r := f !r; !r let swap a b = let buf = !a in a := !b; b := buf (*$T swap let a = ref 1 and b = ref 2 in swap a b; !a = 2 && !b = 1 *) let pre_incr r = pre r ( ( + ) 1 ) let pre_decr r = pre r ( ( + ) (-1) ) let post_incr r = post r ( ( + ) 1 ) let post_decr r = post r ( ( + ) (-1) ) (*$T pre_incr let r = ref 0 in pre_incr r = 1 && !r = 1 *) (*$T post_incr let r = ref 0 in post_incr r = 0 && !r = 1 *) let copy r = ref (!r) (*$T copy let r = ref 0 in let s = copy r in r := 1; !s == 0 && !r == 1 *) let protect r v body = let old = !r in try r := v; let res = body() in r := old; res with x -> r := old; raise x (*$T protect let r = ref 0 in let b () = incr r; !r in protect r 2 b = 3 && !r = 0 let r = ref 0 in let b () = incr r; if !r=3 then raise Not_found in (try protect r 2 b; false with Not_found -> true) && !r = 0 *) external ref : 'a -> 'a ref = "%makemutable" (** Return a fresh reference containing the given value. *) external ( ! ) : 'a ref -> 'a = "%field0" (** [!r] returns the current contents of reference [r]. Equivalent to [fun r -> r.contents]. *) external ( := ) : 'a ref -> 'a -> unit = "%setfield0" (** [r := a] stores the value of [a] in reference [r]. Equivalent to [fun r v -> r.contents <- v]. *) external set : 'a ref -> 'a -> unit = "%setfield0" (** As [ := ] *) external get : 'a ref -> 'a = "%field0" (** As [ ! ]*) let print print_a out r = print_a out !r let toggle r = r := not !r (*$T toggle let r = ref true in toggle r; !r = false let r = ref false in toggle r; !r = true *) let oset r x = r := Some x let oget_exn r = match !r with None -> raise Not_found | Some x -> x (* FAIL $T oset, oget_exn let r = ref None in oset r 3; oget_exn r = 3 *) let compare c x y = c !x !y (*$T compare let a = ref 1 and b = ref 2 in compare Int.compare a b < 0 *) let ord o x y = o !x !y (*$T ord let a = ref 1 and b = ref 2 in ord Int.ord a b = BatOrd.Lt *) let eq e x y = e !x !y (*$T eq let a = ref 1 and b = ref 2 in eq Int.equal a b = false let a = ref 1 and b = ref 1 in eq Int.equal a b = true *) batteries-included-3.4.0/src/batRef.mli000066400000000000000000000104721415601150500177640ustar00rootroot00000000000000(* * Ref - Operations on references * Copyright (C) 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Operations on references. References are mutable values, i.e. "variables" which may actually change value during their life-time, as variables in imperative languages. References can be understood as 1-cell arrays and are typically used to implement imperative algorithms in OCaml. References are useful but don't abuse them. @author Xavier Leroy (base module) @author David Teller *) type 'a t = 'a ref (** The type of references.*) external ref : 'a -> 'a ref = "%makemutable" (** Return a fresh reference containing the given value. *) external ( ! ) : 'a ref -> 'a = "%field0" (** [!r] returns the current contents of reference [r]. Equivalent to [fun r -> r.contents]. *) external ( := ) : 'a ref -> 'a -> unit = "%setfield0" (** [r := a] stores the value of [a] in reference [r]. Equivalent to [fun r v -> r.contents <- v]. *) external set : 'a ref -> 'a -> unit = "%setfield0" (** As [ := ] *) external get : 'a ref -> 'a = "%field0" (** As [ ! ]*) val copy: 'a ref -> 'a ref (** [copy r] returns a new reference with the same initial content as [r].*) val pre : 'a ref -> ( 'a -> 'a ) -> 'a (** Perform an operation on a reference and return the new value of that reference. For instance, if [x] is a reference to [1], [pre x ( ( + ) 1) ] returns [2] and sets [x] to [2].*) val post: 'a ref -> ('a -> 'a) -> 'a (** Perform an operation on a reference and return the previous value of that reference. For instance, if [x] is a reference to [1], [post x ( ( + ) 1)] returns [1] and sets [x] to [2].*) val swap: 'a ref -> 'a ref -> unit (**[swap a b] puts [!b] in [a] and [!a] in [b]*) val post_incr : int ref -> int (**Increment an integer, return the old value. Comparable to C or Java's [i++].*) val post_decr : int ref -> int (**Decrement an integer, return the old value. Comparable to C or Java 's [i--].*) val pre_incr: int ref -> int (**Increment an integer, return the new value. Comparable to C or Java's [++i]. *) val pre_decr: int ref -> int (**Increment an integer, return the new value. Comparable to C or Java's [--i]. *) val protect : 'a ref -> 'a -> (unit -> 'b) -> 'b (**Assign a reference temporarily. [protect r v body] sets the value of [r] to [v] and executes [body]. Once body has been executed, whether termination happens as a consequence of regular evaluation or exception, the previous value of [r] is restored. *) val toggle : bool ref -> unit (** Invert the boolean stored in the reference*) val oset : 'a option ref -> 'a -> unit (** Set the given option ref to [Some x] *) val oget_exn : 'a option ref -> 'a (** Get a value from an option ref; @raise Not_found on [oget_exn (ref None)] *) (** {6 Boilerplate code}*) val print: ('b BatInnerIO.output -> 'a -> unit) -> 'b BatInnerIO.output -> 'a t -> unit (** Given a printing function for the value in the ref, produce a printing function for the ref. Example: [IO.to_string (Ref.print Int.print) (ref 20) = "20"] *) val compare : 'a BatOrd.comp -> 'a ref BatOrd.comp (** Given a comparison function, produce a comparison function for refs of that type. Example: [let a = ref 10 and b = ref 20 in Ref.compare Int.compare a b = -1] *) val ord : 'a BatOrd.ord -> 'a ref BatOrd.ord (** Given an ordering function, produce an ordering function for refs of that type. Example: [let a = ref 10 and b = ref 20 in Ref.ord Int.ord a b = Ord.Lt] *) val eq : 'a BatOrd.eq -> 'a ref BatOrd.eq batteries-included-3.4.0/src/batRefList.ml000066400000000000000000000074131415601150500204500ustar00rootroot00000000000000(* * RefList - List reference * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) exception Empty_list type 'a t = 'a list ref let empty () = ref [] let is_empty x = match !x with | [] -> true | _ -> false let of_list l = ref l let to_list rl = !rl let copy ~dst ~src = dst := !src let copy_list ~dst ~src = dst := src let add rl item = rl := List.append !rl [item] let push rl item = rl := item::!rl let clear rl = rl := [] let length rl = List.length !rl let hd rl = try List.hd !rl with _ -> raise Empty_list let tl rl = try ref (List.tl !rl) with _ -> raise Empty_list let iter f rl = List.iter f !rl let for_all f rl = List.for_all f !rl let map f rl = ref (BatList.map f !rl) let transform f rl = rl := BatList.map f !rl let map_list f rl = BatList.map f !rl let find f rl = List.find f !rl let rev rl = rl := List.rev !rl let find_exn f exn rl = try List.find f !rl with _ -> raise exn let find_exc = find_exn let exists f rl = List.exists f !rl let sort ~cmp rl = rl := List.sort cmp !rl let rfind f rl = BatList.rfind f !rl let first = hd let last rl = let rec loop = function | x :: [] -> x | _ :: l -> loop l | [] -> assert false in match !rl with | [] -> raise Empty_list | l -> loop l let remove rl item = rl := BatList.remove !rl item let remove_if pred rl = rl := BatList.remove_if pred !rl let remove_all rl item = rl := BatList.remove_all !rl item let filter pred rl = rl := List.filter pred !rl let add_sort ~cmp rl item = let rec add_aux = function | x::lnext as l -> let r = cmp x item in if r < 0 then item::l else x::(add_aux lnext) | [] -> [item] in rl := add_aux !rl let pop rl = match !rl with | [] -> raise Empty_list | e::l -> rl := l; e let npop rl n = let rec pop_aux l n = if n = 0 then begin rl := l; [] end else match l with | [] -> raise Empty_list | x::l -> x::(pop_aux l (n-1)) in pop_aux !rl n let copy_enum ~dst ~src = dst := BatList.of_enum src let enum rl = BatList.enum !rl let of_enum e = ref (BatList.of_enum e) let backwards rl = BatList.backwards !rl let of_backwards e = ref (BatList.of_backwards e) let fold_left f a l = List.fold_left f a !l let fold_right f l a = BatList.fold_right f !l a module Index = struct let remove_at rl pos = let p = ref (-1) in let rec del_aux = function | x::l -> incr p; if !p = pos then l else x::(del_aux l) | [] -> invalid_arg "RefList.Index.remove_at: index not found" in rl := del_aux !rl let index pred rl = let index = ref (-1) in ignore (List.find (fun it -> incr index; pred it; ) !rl); !index let index_of rl item = let index = ref (-1) in ignore (List.find (fun it -> incr index; it = item; ) !rl); !index let at_index rl pos = List.nth !rl pos let set rl pos newitem = let p = ref (-1) in rl := List.map (fun item -> incr p; if !p = pos then newitem else item) !rl; if !p < pos || pos < 0 then invalid_arg "RefList.Index.set: Index out of range" end batteries-included-3.4.0/src/batRefList.mli000066400000000000000000000160201415601150500206130ustar00rootroot00000000000000(* * RefList - List reference * Copyright (C) 2003 Nicolas Cannasse * 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Reference on lists. RefList is a extended set of functions that manipulate list references. @author Nicolas Cannasse @author David Teller (Boilerplate code) *) exception Empty_list type 'a t (**The type of an empty ref list*) val empty : unit -> 'a t (** Returns a new empty ref list *) val is_empty : 'a t -> bool (** Return [true] if a ref list is empty *) val clear : 'a t -> unit (** Removes all elements *) val length : 'a t -> int (** Returns the number of elements - O(n) *) val copy : dst:'a t -> src:'a t -> unit (** Makes a copy of a ref list - O(1) *) val copy_list : dst:'a t -> src:'a list -> unit (** Makes a copy of a list - O(1) *) val copy_enum : dst:'a t -> src:'a BatEnum.t -> unit (** Makes a copy of a enum. @param dst A reflist, whose contents will be forgotten. *) val of_list : 'a list -> 'a t (** Creates a ref list from a list - O(1) *) val to_list : 'a t -> 'a list (** Returns the current elements as a list - O(1) *) val of_enum : 'a BatEnum.t -> 'a t (** Creates a ref list from an enumeration *) val enum : 'a t -> 'a BatEnum.t (** Returns an enumeration of current elements in the ref list *) val of_backwards : 'a BatEnum.t -> 'a t (** Creates a ref list from an enumeration, going from last to first *) val backwards : 'a t -> 'a BatEnum.t (** Returns an enumeration of current elements in the ref list, going from last to first *) val add : 'a t -> 'a -> unit (** Adds an element at the end - O(n) *) val push : 'a t -> 'a -> unit (** Adds an element at the head - O(1) *) val add_sort : cmp:('a -> 'a -> int) -> 'a t -> 'a -> unit (** Adds an element in a sorted list, using the given comparator. *) val first : 'a t -> 'a (** Returns the first element or raises [Empty_list] if the ref list is empty *) val last : 'a t -> 'a (** Returns the last element - O(n) or raises [Empty_list] if the ref list is empty *) val pop : 'a t -> 'a (** Removes and returns the first element or raises [Empty_list] if the ref list is empty *) val npop : 'a t -> int -> 'a list (** Removes and returns the n first elements or raises [Empty_list] if the ref list does not contain enough elements *) val hd : 'a t -> 'a (** same as [first] *) val tl : 'a t -> 'a t (** Returns a ref list containing the same elements but without the first one or raises [Empty_list] if the ref list is empty *) val rev : 'a t -> unit (** Reverses the ref list - O(n) *) (** {6 Functional Operations} *) val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (** [List.fold_left f a (ref [b0; b1; ...; bn])] is [f (... (f (f a b0) b1) ...) bn]. *) val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** [List.fold_right f (ref [a0; a1; ...; an]) b] is [f a0 (f a1 (... (f an b) ...))]. Tail-recursive. *) val iter : ('a -> unit) -> 'a t -> unit (** Apply the given function to all elements of the ref list, in respect with the order of the list *) val find : ('a -> bool) -> 'a t -> 'a (** Find the first element matching the specified predicate raise [Not_found] if no element is found *) val rfind : ('a -> bool) -> 'a t -> 'a (** Find the first element in the reversed ref list matching the specified predicate raise [Not_found] if no element is found *) val find_exn : ('a -> bool) -> exn -> 'a t -> 'a (** Same as find but takes an exception to be raised when no element is found as additional parameter. @since 3.2.0 *) val find_exc : ('a -> bool) -> exn -> 'a t -> 'a (** Alias for [find_exn]. @deprecated use {!find_exn} *) val exists : ('a -> bool) -> 'a t -> bool (** Return [true] if an element matches the specified predicate *) val for_all : ('a -> bool) -> 'a t -> bool (** Return [true] if all elements match the specified predicate *) val map : ('a -> 'b) -> 'a t -> 'b t (** Apply a function to all elements and return the ref list constructed with the function returned values *) val transform : ('a -> 'a) -> 'a t -> unit (** transform all elements in the ref list using a function. *) val map_list : ('a -> 'b) -> 'a t -> 'b list (** Apply a function to all elements and return the list constructed with the function returned values *) val sort : cmp:('a -> 'a -> int) -> 'a t -> unit (** Sort elements using the specified comparator *) val filter : ('a -> bool) -> 'a t -> unit (** Remove all elements that do not match the specified predicate *) val remove : 'a t -> 'a -> unit (** Remove an element from the ref list raise [Not_found] if the element is not found *) val remove_if : ('a -> bool) -> 'a t -> unit (** Remove the first element matching the specified predicate raise [Not_found] if no element has been removed *) val remove_all : 'a t -> 'a -> unit (** Remove all elements equal to the specified element from the ref list *) (** {6 Boilerplate code}*) (** Functions that operate on the element at index [i] in a list (with indices starting from 0). While it is sometimes necessary to perform these operations on lists (hence their inclusion here), the functions were moved to an inner module to prevent their overuse: all functions work in O(n) time. You might prefer to use [Array] or [DynArray] for constant time indexed element access. *) module Index : sig val index_of : 'a t -> 'a -> int (** Return the index (position : 0 starting) of an element in a ref list, using ( = ) for testing element equality raise [Not_found] if no element was found *) val index : ('a -> bool) -> 'a t -> int (** Return the index (position : 0 starting) of an element in a ref list, using the specified comparator raise [Not_found] if no element was found *) val at_index : 'a t -> int -> 'a (** Return the element of ref list at the specified index raise [Invalid_index] if the index is outside [0 ; length-1] *) val set : 'a t -> int -> 'a -> unit (** Change the element at the specified index raise [Invalid_index] if the index is outside [0 ; length-1] *) val remove_at : 'a t -> int -> unit (** Remove the element at the specified index raise [Invalid_index] if the index is outside [0 ; length-1] *) end batteries-included-3.4.0/src/batResult.ml000066400000000000000000000072561415601150500203630ustar00rootroot00000000000000(**************************************************************************) (* *) (* OCaml *) (* *) (* The OCaml programmers *) (* *) (* Copyright 2018 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) type ('a, 'e) t = ('a, 'e) BatPervasives.result = | Ok of 'a | Error of 'e let ok v = Ok v let error e = Error e let value r ~default = match r with Ok v -> v | Error _ -> default let get_ok = function Ok v -> v | Error _ -> invalid_arg "result is Error _" let get_error = function Error e -> e | Ok _ -> invalid_arg "result is Ok _" let bind r f = match r with Ok v -> f v | Error _ as e -> e let join = function Ok r -> r | Error _ as e -> e let map_error f = function Error e -> Error (f e) | Ok _ as v -> v let fold ~ok ~error = function Ok v -> ok v | Error e -> error e let iter f = function Ok v -> f v | Error _ -> () let iter_error f = function Error e -> f e | Ok _ -> () let is_error = function Error _ -> true | Ok _ -> false let equal ~ok ~error r0 r1 = match r0, r1 with | Ok v0, Ok v1 -> ok v0 v1 | Error e0, Error e1 -> error e0 e1 | _, _ -> false let compare ~ok ~error r0 r1 = match r0, r1 with | Ok v0, Ok v1 -> ok v0 v1 | Error e0, Error e1 -> error e0 e1 | Ok _, Error _ -> -1 | Error _, Ok _ -> 1 let to_list = function Ok v -> [v] | Error _ -> [] let to_seq = function Ok v -> BatSeq.(cons v nil) | Error _ -> BatSeq.nil let catch f x = try Ok (f x) with e -> Error e let catch2 f x y = try Ok (f x y) with e -> Error e let catch3 f x y z = try Ok (f x y z) with e -> Error e let of_option = function | Some x -> Ok x | None -> Error () let to_option = function | Ok x -> Some x | Error _-> None let default def = function | Ok x -> x | Error _ -> def let map f = function | Error e -> Error e | Ok v -> Ok (f v) (*$T map map succ (Error (-1)) = (Error (-1)) map succ (Error 0) = (Error 0) map succ (Ok 3) = (Ok 4) *) let map_both f g = function | Error e -> Error (g e) | Ok v -> Ok (f v) (*$T map_both map_both succ pred (Error (-1)) = (Error (-2)) map_both succ pred (Error 0) = (Error (-1)) map_both succ pred (Error 1) = (Error 0) map_both succ pred (Ok (-1)) = (Ok 0) map_both succ pred (Ok 0) = (Ok 1) map_both succ pred (Ok 1) = (Ok 2) *) let map_default def f = function | Ok x -> f x | Error _ -> def let is_ok = function Ok _ -> true | Error _ -> false let is_bad = function Error _ -> true | Ok _ -> false let is_exn e = function Error exn -> exn = e | Ok _ -> false let get = function Ok x -> x | Error e -> raise e let print print_val oc = function | Ok x -> BatPrintf.fprintf oc "Ok(%a)" print_val x | Error e -> BatPrintf.fprintf oc "Error(%a)" BatPrintexc.print e module Monad = struct let bind m k = match m with | Ok x -> k x | Error _ as e -> e let return x = Ok x let (>>=) = bind end module Infix = struct let (>>=) = Monad.bind end batteries-included-3.4.0/src/batResult.mli000066400000000000000000000132661415601150500205320ustar00rootroot00000000000000(** Monadic results of computations that can raise exceptions *) (** The type of a result. A result is either [Ok x] carrying the normal return value [x] or is [Error e] carrying some indication of an error. The value associated with a bad result is usually an exception ([exn]) that can be raised. @since 1.0 *) type ('a, 'e) t = ('a, 'e) BatPervasives.result = Ok of 'a | Error of 'e val ok : 'a -> ('a, 'b) t (** [ok v] is [Ok v]. @since 3.0.0 *) val error : 'e -> ('a, 'e) t (** [error e] is [Error e]. @since 3.0.0 *) val value : ('a, 'e) t -> default:'a -> 'a (** [value r ~default] is [v] if [r] is [Ok v] and [default] otherwise. @since 3.0.0 *) val default: 'a -> ('a, _) t -> 'a (** [default d r] evaluates to [d] if [r] is [Error] else [x] when [r] is [Ok x]. @see 'value' or a slightly different signature. @since 2.0 *) val get_ok : ('a, 'e) t -> 'a (** [get_ok r] is [v] if [r] is [Ok v] and @raise Invalid_argument otherwise. @since 3.0.0 *) val get_error : ('a, 'e) t -> 'e (** [get_error r] is [e] if [r] is [Error e] and @raise Invalid_argument otherwise. @since 3.0.0 *) val get : ('a, exn) t -> 'a (** [get (Ok x)] returns [x], and [get (Error e)] raises [e]. This function is, in a way, the opposite of the [catch] function @since 2.0 *) val catch: ('a -> 'e) -> 'a -> ('e, exn) t (** Execute a function and catch any exception as a result. This function encapsulates code that could throw an exception and returns that exception as a value. @since 1.0 *) val catch2: ('a -> 'b -> 'c) -> 'a -> 'b -> ('c, exn) t (** As [catch] but two parameters. This saves a closure construction @since 2.0 *) val catch3: ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> ('d, exn) t (** As [catch] but three parameters. This saves a closure construction @since 2.0 *) val bind : ('a, 'e) t -> ('a -> ('b, 'e) t) -> ('b, 'e) t (** [bind r f] is [f v] if [r] is [Ok v] and [r] if [r] is [Error _]. @since 3.0.0 *) val join : (('a, 'e) t, 'e) t -> ('a, 'e) t (** [join rr] is [r] if [rr] is [Ok r] and [rr] if [rr] is [Error _]. @since 3.0.0 *) val map : ('a -> 'b) -> ('a, 'e) t -> ('b, 'e) t (** [map f r] is [Ok (f v)] if [r] is [Ok v] and [r] if [r] is [Error _]. @since 3.0.0 *) val map_error : ('e -> 'f) -> ('a, 'e) t -> ('a, 'f) t (** [map_error f r] is [Error (f e)] if [r] is [Error e] and [r] if [r] is [Ok _]. @since 3.0.0 *) val map_both : ('a1 -> 'a2) -> ('b1 -> 'b2) -> ('a1, 'b1) t -> ('a2, 'b2) t (** [map_both f g (Ok x)] returns [Ok (f x)] and [map_both f g (Error e)] returns [Error (g e)]. @since 2.6.0 *) val map_default : 'b -> ('a -> 'b) -> ('a, _) t -> 'b (** [map_default d f r] evaluates to [d] if [r] is [Error] else [f x] when [r] is [Ok x] @since 2.0 *) val fold : ok:('a -> 'c) -> error:('e -> 'c) -> ('a, 'e) t -> 'c (** [fold ~ok ~error r] is [ok v] if [r] is [Ok v] and [error e] if [r] is [Error e]. @since 3.0.0 *) val iter : ('a -> unit) -> ('a, 'e) t -> unit (** [iter f r] is [f v] if [r] is [Ok v] and [()] otherwise. @since 3.0.0 *) val iter_error : ('e -> unit) -> ('a, 'e) t -> unit (** [iter_error f r] is [f e] if [r] is [Error e] and [()] otherwise. @since 3.0.0 *) (** {1:preds Predicates and comparisons} *) val is_ok : ('a, 'e) t -> bool (** [is_ok (Ok _)] is [true], otherwise [false]. @since 2.0 *) val is_error : ('a, 'e) t -> bool (** [is_error r] is [true] iff [r] is [Error _]. @since 3.0.0 *) val is_bad : ('a, 'e) t -> bool (** Same as [is_error]. @since 2.0 *) (** [is_exn e1 r] is [true] iff [r] is [Error e2] with [e1=e2] *) val is_exn : exn -> ('a, exn) t -> bool val equal : ok:('a -> 'a -> bool) -> error:('e -> 'e -> bool) -> ('a, 'e) t -> ('a, 'e) t -> bool (** [equal ~ok ~error r0 r1] tests equality of [r0] and [r1] using [ok] and [error] to respectively compare values wrapped by [Ok _] and [Error _]. @since 3.0.0 *) val compare : ok:('a -> 'a -> int) -> error:('e -> 'e -> int) -> ('a, 'e) t -> ('a, 'e) t -> int (** [compare ~ok ~error r0 r1] totally orders [r0] and [r1] using [ok] and [error] to respectively compare values wrapped by [Ok _ ] and [Error _]. [Ok _] values are smaller than [Error _] values. @since 3.0.0 *) (** {1:convert Converting} *) val to_option : ('a, _) t -> 'a option (** [to_option r] is [r] as an option, mapping [Ok v] to [Some v] and [Error _] to [None]. @since 1.0 *) val of_option: 'a option -> ('a, unit) t (** Convert an [option] to a [result] @since 1.0 *) val to_list : ('a, 'e) t -> 'a list (** [to_list r] is [[v]] if [r] is [Ok v] and [[]] otherwise. @since 3.0.0 *) val to_seq : ('a, 'e) t -> 'a BatSeq.t (** [to_seq r] is [r] as a sequence. [Ok v] is the singleton sequence containing [v] and [Error _] is the empty sequence. @since 3.0.0 *) (** {6 The Result Monad} *) (** This monad is very similar to the option monad, but instead of being [None] when an error occurs, the first error in the sequence is preserved as the return value. *) module Monad : sig (** Monadic composition. [bind r f] proceeds as [f x] if [r] is [Ok x], or returns [r] if [r] is an error. @since 2.0 *) val bind: ('a, 'e) t -> ('a -> ('c, 'e) t) -> ('c, 'e) t (** as [bind] *) val ( >>= ): ('a, 'e) t -> ('a -> ('c, 'e) t) -> ('c, 'e) t (** Monadic return, just encapsulates the given value with Ok *) val return : 'a -> ('a, _) t end (** {6 Infix} *) (** This infix module provides the operator [(>>=)] *) module Infix : sig val ( >>= ): ('a, 'e) t -> ('a -> ('c, 'e) t) -> ('c, 'e) t end (** Print a result as Ok(x) or Error(exn) *) val print : ('b BatInnerIO.output -> 'a -> unit) -> 'b BatInnerIO.output -> ('a, exn) t -> unit batteries-included-3.4.0/src/batReturn.ml000066400000000000000000000023771415601150500203630ustar00rootroot00000000000000(* * Return -- fast return in OCaml * Copyright (C) 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type 'a t = 'a -> exn let return label value = raise (label value) let label (type u) (f : u t -> u) : u = let module M = struct exception Return of u end in try f (fun x -> M.Return x) with M.Return u -> u let with_label = label (* testing nesting with_labels *) (*$T with_label with_label (fun label1 -> \ with_label (fun _label2 -> ignore (return label1 1)); 2 \ ) = 1 *) batteries-included-3.4.0/src/batReturn.mli000066400000000000000000000050631415601150500205270ustar00rootroot00000000000000(* * Return -- fast return in OCaml * Copyright (C) 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Local exceptions/labels/goto/return. This module defines a mechanism akin to SML's exception generators or to a generalization of C's [return], i.e. the ability to define local {i labels}, which may be used for immediately terminating an expression and returning a value. By opposition to usual OCaml exceptions, this mechanism - allows polymorphic return values - makes accidental exception catching slightly harder (while a local exception can escape its scope, it cannot be caught again by accident from this module). Example: {[ let find_in_array a e = label (fun label -> for i = 0 to Array.length a - 1 do if Array.get a i = e then return label (Some i) done; None) ]} @author David Teller @documents Return *) type 'a t (** A label which may be used to return values of type ['a]*) val label : ('a t -> 'a) -> 'a (** [label f] creates a new label [x] and invokes [f x]. If, during the execution of [f], [return x v] is invoked, the execution of [f x] stops immediately and [label f] returns [v]. Otherwise, if [f x] terminates normally and returns [y], [label f] returns [y]. Calling [return x v] from outside scope [f] is a run-time error and causes termination of the program.*) val with_label : ('a t -> 'a) -> 'a (**as [label]*) val return : 'a t -> 'a -> _ (** Return to a label. [return l v] returns to the point where label [l] was obtained and produces value [l]. Calling [return l v] from outside the scope of [l] (i.e. the call to function [label] which produced [l]) is a run-time error and causes termination of the program.*) batteries-included-3.4.0/src/batScanf.ml000066400000000000000000000031731415601150500201310ustar00rootroot00000000000000(* * BatScanf - Extended Scanf module * Copyright (C) 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module Scanning = struct include Scanf.Scanning let from_input inp = from_function (fun () -> try BatInnerIO.read inp with BatInnerIO.No_more_input -> raise End_of_file) (*$T bscanf (Scanning.from_input (BatIO.input_string "12 bc" )) "%d %s" (fun d s -> d = 12 && s = "bc") *) let from_channel = from_input let stdib = from_input (BatInnerIO.stdin) end type ('a, 'b, 'c, 'd) scanner = ('a, Scanning.scanbuf, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c open Scanf let fscanf = fscanf let sscanf = sscanf let scanf = scanf let kscanf = kscanf let bscanf = bscanf let bscanf_format = bscanf_format let sscanf_format = sscanf_format let format_from_string = format_from_string exception Scan_failure = Scan_failure batteries-included-3.4.0/src/batScanf.mli000066400000000000000000000477321415601150500203130ustar00rootroot00000000000000(* * BatScanf - Extended Scanf module * Copyright (C) 1996 Pierre Weis * 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Formatted input functions. @author Pierre Weis (Base module) @author David Teller *) (** {6 Introduction} *) (** {7 Functional input with format strings} *) (** The module [Scanf] provides formatted input functions or {e scanners}. The formatted input functions can read from any kind of input, including strings, files, or anything that can return characters. The more general source of characters is named a {e scanning buffer} and has type {!Scanning.scanbuf}. The more general formatted input function reads from any scanning buffer and is named [bscanf]. Generally speaking, the formatted input functions have 3 arguments: - the first argument is a source of characters for the input, - the second argument is a format string that specifies the values to read, - the third argument is a {e receiver function} that is applied to the values read. Hence, a typical call to the formatted input function {!Scanf.bscanf} is [bscanf ib fmt f], where: - [ib] is a source of characters (typically a {e scanning buffer} with type {!Scanning.scanbuf}), - [fmt] is a format string (the same format strings as those used to print material with module {!Printf} or {!Format}), - [f] is a function that has as many arguments as the number of values to read in the input. *) (** {7 A simple example} *) (** As suggested above, the expression [bscanf ib "%d" f] reads a decimal integer [n] from the source of characters [ib] and returns [f n]. For instance, - if we use [stdib] as the source of characters ({!Scanning.stdib} is the predefined input buffer that reads from standard input), - if we define the receiver [f] as [let f x = x + 1], then [bscanf stdib "%d" f] reads an integer [n] from the standard input and returns [f n] (that is [n + 1]). Thus, if we evaluate [bscanf stdib "%d" f], and then enter [41] at the keyboard, we get [42] as the final result. *) (** {7 Formatted input as a functional feature} *) (** The OCaml scanning facility is reminiscent of the corresponding C feature. However, it is also largely different, simpler, and yet more powerful: the formatted input functions are higher-order functionals and the parameter passing mechanism is just the regular function application not the variable assignment based mechanism which is typical for formatted input in imperative languages; the OCaml format strings also feature useful additions to easily define complex tokens; as expected within a functional programming language, the formatted input functions also support polymorphism, in particular arbitrary interaction with polymorphic user-defined scanners. Furthermore, the OCaml formatted input facility is fully type-checked at compile time. *) (** {6 Scanning buffers} *) module Scanning : sig type scanbuf = Scanf.Scanning.scanbuf (** The type of scanning buffers. A scanning buffer is the source from which a formatted input function gets characters. The scanning buffer holds the current state of the scan, plus a function to get the next char from the input, and a token buffer to store the string matched so far. Note: a scan may often require to examine one character in advance; when this ``lookahead'' character does not belong to the token read, it is stored back in the scanning buffer and becomes the next character read. *) val stdib : scanbuf (** The scanning buffer reading from [stdin]. [stdib] is equivalent to [Scanning.from_input stdin]. Note: when input is read interactively from [stdin], the newline character that triggers the evaluation is incorporated in the input; thus, scanning specifications must properly skip this character (simply add a ['\n'] as the last character of the format string). *) val from_string : string -> scanbuf (** [Scanning.from_string s] returns a scanning buffer which reads from the given string. Reading starts from the first character in the string. The end-of-input condition is set when the end of the string is reached. *) val from_file : string -> scanbuf (** Bufferized file reading in text mode. The efficient and usual way to scan text mode files (in effect, [from_file] returns a scanning buffer that reads characters in large chunks, rather than one character at a time as buffers returned by [from_channel] do). [Scanning.from_file fname] returns a scanning buffer which reads from the given file [fname] in text mode. *) val from_file_bin : string -> scanbuf (** Bufferized file reading in binary mode. *) val from_function : (unit -> char) -> scanbuf (** [Scanning.from_function f] returns a scanning buffer with the given function as its reading method. When scanning needs one more character, the given function is called. When the function has no more character to provide, it must signal an end-of-input condition by raising the exception [End_of_file]. *) val from_input : BatIO.input -> scanbuf (** [Scanning.from_input ic] returns a scanning buffer which reads from the input channel [ic], starting at the current reading position. *) val end_of_input : scanbuf -> bool (** [Scanning.end_of_input ib] tests the end-of-input condition of the given scanning buffer. *) val beginning_of_input : scanbuf -> bool (** [Scanning.beginning_of_input ib] tests the beginning of input condition of the given scanning buffer. *) val name_of_input : scanbuf -> string (** [Scanning.name_of_input ib] returns the name of the character source for the scanning buffer [ib]. *) (** {6 Obsolete} *) val from_channel : BatIO.input -> scanbuf (** @obsolete use {!from_input}*) end (** {6 Type of formatted input functions} *) type ('a, 'b, 'c, 'd) scanner = ('a, Scanning.scanbuf, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c (** The type of formatted input scanners: [('a, 'b, 'c, 'd) scanner] is the type of a formatted input function that reads from some scanning buffer according to some format string; more precisely, if [scan] is some formatted input function, then [scan ib fmt f] applies [f] to the arguments specified by the format string [fmt], when [scan] has read those arguments from the scanning input buffer [ib]. For instance, the [scanf] function below has type [('a, 'b, 'c, 'd) scanner], since it is a formatted input function that reads from [stdib]: [scanf fmt f] applies [f] to the arguments specified by [fmt], reading those arguments from [stdin] as expected. If the format [fmt] has some [%r] indications, the corresponding input functions must be provided before the receiver [f] argument. For instance, if [read_elem] is an input function for values of type [t], then [bscanf ib "%r;" read_elem f] reads a value [v] of type [t] followed by a [';'] character, and returns [f v]. *) exception Scan_failure of string (** The exception that formatted input functions raise when the input cannot be read according to the given format. *) (** {6 The general formatted input function} *) val bscanf : Scanning.scanbuf -> ('a, 'b, 'c, 'd) scanner (** [bscanf ib fmt r1 ... rN f] reads arguments for the function [f], from the scanning buffer [ib], according to the format string [fmt], and applies [f] to these values. The result of this call to [f] is returned as the result of the entire [bscanf] call. For instance, if [f] is the function [fun s i -> i + 1], then [Scanf.sscanf "x= 1" "%s = %i" f] returns [2]. Arguments [r1] to [rN] are user-defined input functions that read the argument corresponding to a [%r] conversion. *) (** {6 Format string description} *) (** The format is a character string which contains three types of objects: - plain characters, which are simply matched with the characters of the input, - conversion specifications, each of which causes reading and conversion of one argument for the function [f], - scanning indications to specify boundaries of tokens. *) (** {7 The space character in format strings} *) (** As mentioned above, a plain character in the format string is just matched with the characters of the input; however, one character is a special exception to this simple rule: the space character (ASCII code 32) does not match a single space character, but any amount of ``whitespace'' in the input. More precisely, a space inside the format string matches {e any number} of tab, space, line feed and carriage return characters. Matching {e any} amount of whitespace, a space in the format string also matches no amount of whitespace at all; hence, the call [bscanf ib "Price = %d $" (fun p -> p)] succeeds and returns [1] when reading an input with various whitespace in it, such as [Price = 1 $], [Price = 1 $], or even [Price=1$]. *) (** {7 Conversion specifications in format strings} *) (** Conversion specifications consist in the [%] character, followed by an optional flag, an optional field width, and followed by one or two conversion characters. The conversion characters and their meanings are: - [d]: reads an optionally signed decimal integer. - [i]: reads an optionally signed integer (usual input formats for hexadecimal ([0x[d]+] and [0X[d]+]), octal ([0o[d]+]), and binary [0b[d]+] notations are understood). - [u]: reads an unsigned decimal integer. - [x] or [X]: reads an unsigned hexadecimal integer. - [o]: reads an unsigned octal integer. - [s]: reads a string argument that spreads as much as possible, until the following bounding condition holds: a whitespace has been found, a scanning indication has been encountered, or the end-of-input has been reached. Hence, this conversion always succeeds: it returns an empty string, if the bounding condition holds when the scan begins. - [S]: reads a delimited string argument (delimiters and special escaped characters follow the lexical conventions of OCaml). - [c]: reads a single character. To test the current input character without reading it, specify a null field width, i.e. use specification [%0c]. @raise Invalid_argument, if the field width specification is greater than 1. - [C]: reads a single delimited character (delimiters and special escaped characters follow the lexical conventions of OCaml). - [f], [e], [E], [g], [G]: reads an optionally signed floating-point number in decimal notation, in the style [dddd.ddd e/E+-dd]. - [F]: reads a floating point number according to the lexical conventions of OCaml (hence the decimal point is mandatory if the exponent part is not mentioned). - [B]: reads a boolean argument ([true] or [false]). - [b]: reads a boolean argument (for backward compatibility; do not use in new programs). - [ld], [li], [lu], [lx], [lX], [lo]: reads an [int32] argument to the format specified by the second letter (decimal, hexadecimal, etc). - [nd], [ni], [nu], [nx], [nX], [no]: reads a [nativeint] argument to the format specified by the second letter. - [Ld], [Li], [Lu], [Lx], [LX], [Lo]: reads an [int64] argument to the format specified by the second letter. - [\[ range \]]: reads characters that matches one of the characters mentioned in the range of characters [range] (or not mentioned in it, if the range starts with [^]). Reads a [string] that can be empty, if the next input character does not match the range. The set of characters from [c1] to [c2] (inclusively) is denoted by [c1-c2]. Hence, [%\[0-9\]] returns a string representing a decimal number or an empty string if no decimal digit is found; similarly, [%\[\\048-\\057\\065-\\070\]] returns a string of hexadecimal digits. If a closing bracket appears in a range, it must occur as the first character of the range (or just after the [^] in case of range negation); hence [\[\]\]] matches a [\]] character and [\[^\]\]] matches any character that is not [\]]. - [r]: user-defined reader. Takes the next [ri] formatted input function and applies it to the scanning buffer [ib] to read the next argument. The input function [ri] must therefore have type [Scanning.scanbuf -> 'a] and the argument read has type ['a]. - [\{ fmt %\}]: reads a format string argument. The format string read must have the same type as the format string specification [fmt]. For instance, ["%\{%i%\}"] reads any format string that can read a value of type [int]; hence [Scanf.sscanf "fmt:\\\"number is %u\\\"" "fmt:%\{%i%\}"] succeeds and returns the format string ["number is %u"]. - [\( fmt %\)]: scanning format substitution. Reads a format string to replace [fmt]. The format string read must have the same type as the format string specification [fmt]. For instance, ["%\( %i% \)"] reads any format string that can read a value of type [int]; hence [Scanf.sscanf "\\\"%4d\\\"1234.00" "%\(%i%\)"] is equivalent to [Scanf.sscanf "1234.00" "%4d"]. - [l]: returns the number of lines read so far. - [n]: returns the number of characters read so far. - [N] or [L]: returns the number of tokens read so far. - [!]: matches the end of input condition. - [%]: matches one [%] character in the input. Following the [%] character that introduces a conversion, there may be the special flag [_]: the conversion that follows occurs as usual, but the resulting value is discarded. For instance, if [f] is the function [fun i -> i + 1], then [Scanf.sscanf "x = 1" "%_s = %i" f] returns [2]. The field width is composed of an optional integer literal indicating the maximal width of the token to read. For instance, [%6d] reads an integer, having at most 6 decimal digits; [%4f] reads a float with at most 4 characters; and [%8\[\\000-\\255\]] returns the next 8 characters (or all the characters still available, if fewer than 8 characters are available in the input). Notes: - as mentioned above, a [%s] conversion always succeeds, even if there is nothing to read in the input: it simply returns [""]. - in addition to the relevant digits, ['_'] characters may appear inside numbers (this is reminiscent to the usual OCaml lexical conventions). If stricter scanning is desired, use the range conversion facility instead of the number conversions. - the [scanf] facility is not intended for heavy duty lexical analysis and parsing. If it appears not expressive enough for your needs, several alternative exists: regular expressions (module [Str]), stream parsers, [ocamllex]-generated lexers, [ocamlyacc]-generated parsers. *) (** {7 Scanning indications in format strings} *) (** Scanning indications appear just after the string conversions [%s] and [%\[ range \]] to delimit the end of the token. A scanning indication is introduced by a [@] character, followed by some constant character [c]. It means that the string token should end just before the next matching [c] (which is skipped). If no [c] character is encountered, the string token spreads as much as possible. For instance, ["%s@\t"] reads a string up to the next tab character or to the end of input. If a scanning indication [\@c] does not follow a string conversion, it is treated as a plain [c] character. Note: - the scanning indications introduce slight differences in the syntax of [Scanf] format strings, compared to those used for the [Printf] module. However, the scanning indications are similar to those used in the [Format] module; hence, when producing formatted text to be scanned by [!Scanf.bscanf], it is wise to use printing functions from the [Format] module (or, if you need to use functions from [Printf], banish or carefully double check the format strings that contain ['\@'] characters). *) (** {7 Exceptions during scanning} *) (** Scanners may raise the following exceptions when the input cannot be read according to the format string: - @raise Scanf.Scan_failure if the input does not match the format. - @raise Failure if a conversion to a number is not possible. - @raise End_of_file if the end of input is encountered while some more characters are needed to read the current conversion specification. - @raise Invalid_argument if the format string is invalid. Note: - as a consequence, scanning a [%s] conversion never raises exception [End_of_file]: if the end of input is reached the conversion succeeds and simply returns the characters read so far, or [""] if none were read. *) (** {6 Specialized formatted input functions} *) val fscanf : in_channel -> ('a, 'b, 'c, 'd) scanner (** Same as {!Scanf.bscanf}, but reads from the given channel. Warning: since all formatted input functions operate from a scanning buffer, be aware that each [fscanf] invocation will operate with a scanning buffer reading from the given channel. This extra level of bufferization can lead to strange scanning behaviour if you use low level primitives on the channel (reading characters, seeking the reading position, and so on). As a consequence, never mixt direct low level reading and high level scanning from the same input channel. *) val sscanf : string -> ('a, 'b, 'c, 'd) scanner (** Same as {!Scanf.bscanf}, but reads from the given string. *) val scanf : ('a, 'b, 'c, 'd) scanner (** Same as {!Scanf.bscanf}, but reads from the predefined scanning buffer {!Scanf.Scanning.stdib} that is connected to [stdin]. *) val kscanf : Scanning.scanbuf -> (Scanning.scanbuf -> exn -> 'd) -> ('a, 'b, 'c, 'd) scanner (** Same as {!Scanf.bscanf}, but takes an additional function argument [ef] that is called in case of error: if the scanning process or some conversion fails, the scanning function aborts and calls the error handling function [ef] with the scanning buffer and the exception that aborted the scanning process. *) (** {6 Reading format strings from input} *) val bscanf_format : Scanning.scanbuf -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g (** [bscanf_format ib fmt f] reads a format string token from the scanning buffer [ib], according to the given format string [fmt], and applies [f] to the resulting format string value. @raise Scan_failure if the format string value read does not have the same type as [fmt]. *) val sscanf_format : string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g (** Same as {!Scanf.bscanf_format}, but reads from the given string. *) val format_from_string : string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6 (** [format_from_string s fmt] converts a string argument to a format string, according to the given format string [fmt]. @raise Scan_failure if [s], considered as a format string, does not have the same type as [fmt]. *) batteries-included-3.4.0/src/batSeq.mliv000066400000000000000000000271431415601150500201710ustar00rootroot00000000000000(* * Copyright (C) 2009 Jeremie Dimino * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Sequence of elements *) (** A sequence represent a collection of elements, for which you never construct the complete representation. Basically you should use a sequence when you would prefer using a list or a lazy-list but constructing the whole list explicitly would explode your memory. All functions returning a sequence operates in time and space O(1). Note that if you want a ``consumable sequence'', you should prefer using enumerations (from module {!BatEnum}). @author Jeremie Dimino *) ##V<4.7## type 'a t = unit -> 'a node ##V>=4.7## type 'a t = 'a Stdlib.Seq.t (** A sequence is a computation which returns a list-like node *) and 'a node = ##V>=4.7## 'a Stdlib.Seq.node = | Nil | Cons of 'a * 'a t include BatInterfaces.Mappable with type 'a mappable = 'a t val enum : 'a t -> 'a BatEnum.t (** [enum s] returns the enumeration of all element of [s]. Since enumerations are consumable and sequence are not, it is not possible to have the inverse operations, i.e. [of_enum] *) (** {6 Base operations} *) val length : 'a t -> int (** Return the number of elements of the given sequence. This may never return if the sequence is infinite. *) val hd : 'a t -> 'a (** Returns the first element of the sequence or raise [Invalid_argument] if the sequence is empty. *) val tl : 'a t -> 'a t (** Returns the sequence without its first elements or raise [Invalid_argument] if the sequence is empty. *) val is_empty : 'a t -> bool (** [is_empty e] returns true if [e] does not contains any element. *) val first : 'a t -> 'a (** Same as {!hd} *) val last : 'a t -> 'a (** Returns the last element of the sequence, or raise [Invalid_argument] if the sequence is empty. *) val at : 'a t -> int -> 'a (** [at l n] returns the element at index [n] (starting from [0]) in the sequence [l] or raise [Invalid_argument] is the index is outside of [l] bounds. *) val append : 'a t -> 'a t -> 'a t (** [append s1 s2] returns the sequence which first returns all elements of [s1] then all elements of [s2]. *) val concat : 'a t t -> 'a t (** [concat s] returns the sequence which returns all the elements of all the elements of [s], in the same order. *) val flatten : 'a t t -> 'a t (** Same as {!concat}. *) (** {6 Constructors} *) val nil : 'a t (** [nil = fun () -> Nil] *) val empty : 'a t (** the empty sequence, containing no elements @since 3.3.0 *) val return : 'a -> 'a t (** the singleton sequence, containing only the given element @since 3.3.0 *) val cons : 'a -> 'a t -> 'a t (** [cons e s = fun () -> Cons(e, s)] *) val make : int -> 'a -> 'a t (** [make n e] returns the sequence of length [n] where all elements are [e] *) val init : int -> (int -> 'a) -> 'a t (** [init n f] returns the sequence returning the results of [f 0], [f 1].... [f (n-1)]. @raise Invalid_argument if [n < 0]. *) val of_list : 'a list -> 'a t (** Convenience function to build a seq from a list. @since 2.2.0 *) val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t (** Build a sequence from a step function and an initial value. [unfold f u] returns [empty] if [f u] returns [None], or [fun () -> Cons (x, unfold f y)] if [f u] returns [Some (x, y)]. For example, [unfold (function [] -> None | h::t -> Some (h,t)) l] is equivalent to [List.to_seq l]. @since 3.3.0 *) val flat_map : ('a -> 'b t) -> 'a t -> 'b t (** Map each element to a subsequence, then return each element of this sub-sequence in turn. This transformation is lazy, it only applies when the result is traversed. @since 3.3.0 *) val concat_map: ('a -> 'b t) -> 'a t -> 'b t (** Alias for {!flat_map}. @since 3.4.0 *) (** {6 Iterators} *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f s] applies [f] to all the elements of the sequence. Eager. *) val iteri : (int -> 'a -> unit) -> 'a t -> unit (** [iteri f s] is the same as [iter f s], but [f] is given the index of each element (starting at 0). @since 2.2.0 *) val iter2 : ('a -> 'b -> unit) -> 'a t -> 'b t -> unit (** [iter2 f s1 s2] iterates on elements of [s1] and [s2] pairwise, and stops when it meets the end of [s1] or [s2] @since 2.2.0 *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f s] returns the sequence where elements are elements of [s] mapped with [f]. Lazy. *) val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t (** [mapi f s] lazily maps elements of [s] into a new sequence, using [f]. [f] is also given elements' indexes. @since 2.2.0 *) val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t (** [map2 f s1 s2] returns a sequence of elements, resulting from combininig elements of [s1] and [s2] at the same index using [f]. The result is as long as the shortest argument. @since 2.2.0 *) val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (** [fold_left f a (cons b0 (... bn))] is [f (... (f (f a b0) b1) ...) bn]. Tail-recursive, eager. *) val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** [fold_right f (cons a0 (cons a1 (cons a2 ...))) b] is [f a0 (f a1 (f a2 ...))]. Not tail-recursive, eager. *) val reduce : ('a -> 'a -> 'a) -> 'a t -> 'a (** [reduce f (cons e s)] is [fold_left f e s]. @raise Invalid_argument on empty sequences. *) val max : 'a t -> 'a (** [max s] returns the largest value in [s] as judged by [Pervasives.compare] @raise Invalid_argument on empty sequences. *) val min : 'a t -> 'a (** [min s] returns the smallest value in [s] as judged by [Pervasives.compare] @raise Invalid_argument on empty sequences. *) val equal : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** [equal ~eq s1 s2] compares elements of [s1] and [s2] pairwise using [eq] @param eq optional equality function (default {!Pervasives.(=)}) @since 2.2.0 *) (** {6 Sequence scanning} Most functions in the following sections have a shortcut semantic similar to the behavior of the usual (&&) and (||) operators : they will force the sequence until they find an satisfying element, and then return immediately. For example, [for_all] will only diverge if the sequence begins with an infinite number of true elements --- elements for which the predicate [p] returns [true]. *) val for_all : ('a -> bool) -> 'a t -> bool (** [for_all p (cons a0 (cons a1 ...))] checks if all elements of the given sequence satisfy the predicate [p]. That is, it returns [(p a0) && (p a1) && ...]. Eager, shortcut. *) val exists : ('a -> bool) -> 'a t -> bool (** [exists p (cons a0 (cons a1 ...))] checks if at least one element of the sequence satisfies the predicate [p]. That is, it returns [(p a0) || (p a1) || ...]. Eager, shortcut. *) val mem : 'a -> 'a t -> bool (** [mem a l] is true if and only if [a] is equal to an element of [l]. Eager, shortcut. *) (** {6 Sequence searching} *) val find : ('a -> bool) -> 'a t -> 'a option (** [find p s] returns the first element of [s] such as [p e] returns [true], if any. Eager, shortcut. *) val find_map : ('a -> 'b option) -> 'a t -> 'b option (** [find_map p s] finds the first element of [s] for which [p e] returns [Some r], if any. Eager, short-cut. *) val filter : ('a -> bool) -> 'a t -> 'a t (** [filter p s] returns the sequence of elements of [s] satisfying [p]. Lazy. {b Note} filter is lazy in that it returns a lazy sequence, but each element in the result is eagerly searched in the input sequence. Therefore, the access to a given element in the result will diverge if it is preceded, in the input sequence, by infinitely many false elements (elements on which the predicate [p] returns [false]). Other functions that may drop an unbound number of elements ([filter_map], [take_while], etc.) have the same behavior. *) val filter_map : ('a -> 'b option) -> 'a t -> 'b t (** [filter_map f s] returns the sequence of elements filtered and mapped by [f]. Lazy. *) (** {6 Association sequences} *) val assoc : 'a -> ('a * 'b) t -> 'b option (** [assoc a s] returns the value associated with key [a] in the sequence of pairs [s]. Eager, shortcut. *) (** {6 Sequence transformations} *) val take : int -> 'a t -> 'a t (** [take n s] returns up to the [n] first elements from sequence [s], if available. Lazy. *) val drop : int -> 'a t -> 'a t (** [drop n s] returns [s] without the first [n] elements, or the empty sequence if [s] have less than [n] elements. Lazy. *) val take_while : ('a -> bool) -> 'a t -> 'a t (** [take_while f s] returns the first elements of sequence [s] which satisfy the predicate [f]. Lazy. *) val drop_while : ('a -> bool) -> 'a t -> 'a t (** [drop_while f s] returns the sequence [s] with the first elements satisfying the predicate [f] dropped. Lazy. *) (** {6 Sequence of pairs} *) val split : ('a * 'b) t -> 'a t * 'b t (** [split s = (map fst s, map snd s)]. Lazy. *) val combine : 'a t -> 'b t -> ('a * 'b) t (** Transform a pair of sequences into a sequence of pairs. Lazy. @raise Invalid_argument if given sequences of different length. *) (** {6 Printing} *) val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> 'b t -> unit (**Print the contents of a sequence*) val to_buffer : ?first:string -> ?last:string -> ?sep:string -> ('a -> string) -> Buffer.t -> (unit -> 'a node) -> unit (** Convert a sequence to a string in the given buffer; eager. @since 2.10.0 *) val to_string : ?first:string -> ?last:string -> ?sep:string -> ('a -> string) -> 'a t -> string (** Convert the sequence to a string; eager. @since 2.10.0 *) val of_string : ?first:string -> ?last:string -> ?sep:string -> (string -> 'a) -> string -> 'a t (** Create a sequence by parsing a string. @raise Invalid_argument if the string is not prefixed by [first]. @raise Invalid_argument if the string is not suffixed by [last]. @since 2.10.0 *) module Infix : sig (** Infix operators matching those provided by {!BatEnum.Infix} *) val ( -- ) : int -> int -> int t val ( --^ ) : int -> int -> int t val ( --. ) : float * float -> float -> float t val ( --- ) : int -> int -> int t val ( --~ ) : char -> char -> char t val ( // ) : 'a t -> ('a -> bool) -> 'a t val ( /@ ) : 'a t -> ('a -> 'b) -> 'b t val ( @/ ) : ('a -> 'b) -> 'a t -> 'b t val ( //@ ) : 'a t -> ('a -> 'b option) -> 'b t val ( @// ) : ('a -> 'b option) -> 'a t -> 'b t end include module type of Infix module Exceptionless : sig val hd : 'a t -> 'a option val tl : 'a t -> 'a t option val first : 'a t -> 'a option val last : 'a t -> 'a option val at : 'a t -> int -> 'a option (* val make : int -> 'a -> 'a t val init : int -> (int -> 'a) -> 'a t *) val reduce : ('a -> 'a -> 'a) -> 'a t -> 'a option val max : 'a t -> 'a option val min : 'a t -> 'a option val combine : 'a t -> 'b t -> ('a * 'b) t end batteries-included-3.4.0/src/batSeq.mlv000066400000000000000000000274201415601150500200160ustar00rootroot00000000000000(* * Copyright (C) 2009 Jeremie Dimino * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type 'a node = ##V>=4.7## 'a Stdlib.Seq.node = | Nil | Cons of 'a * 'a t ##V<4.7## and 'a t = unit -> 'a node ##V>=4.7## and 'a t = 'a Stdlib.Seq.t type 'a mappable = 'a t let nil () = Nil let cons e s () = Cons(e, s) let length s = let rec aux acc s = match s () with | Nil -> acc | Cons(_, s) -> aux (acc + 1) s in aux 0 s let rec enum_of_ref r = BatEnum.make ~next:(fun _ -> match !r () with | Nil -> raise BatEnum.No_more_elements | Cons(e, s) -> r := s; e) ~count:(fun _ -> length !r) ~clone:(fun _ -> enum_of_ref (ref !r)) let enum s = enum_of_ref (ref s) let hd s = match s () with | Nil -> invalid_arg "Seq.hd" | Cons(e, _s) -> e let tl s = match s () with | Nil -> invalid_arg "Seq.tl" | Cons(_e, s) -> s let first s = match s () with | Nil -> invalid_arg "Seq.first" | Cons(e, _s) -> e let last s = let rec aux e s = match s () with | Nil -> e | Cons(e, s) -> aux e s in match s () with | Nil -> invalid_arg "Seq.last" | Cons(e, s) -> aux e s let is_empty s = s () = Nil let at s n = let rec aux s n = match s () with | Nil -> invalid_arg "Seq.at" | Cons(e, s) -> if n = 0 then e else aux s (n - 1) in if n < 0 then invalid_arg "Seq.at" else aux s n let rec append s1 s2 () = match s1 () with | Nil -> s2 () | Cons(e, s1) -> Cons(e, append s1 s2) let concat s = let rec aux current rest () = match current () with | Cons(e, s) -> Cons(e, aux s rest) | Nil -> match rest () with | Cons(e, s) -> aux e s () | Nil -> Nil in aux nil s let flatten = concat let make n e = let rec aux n () = if n = 0 then Nil else Cons(e, aux (n - 1)) in if n < 0 then invalid_arg "Seq.make" else aux n let init n f = let rec aux i () = if i = n then Nil else Cons(f i, aux (i + 1)) in if n < 0 then invalid_arg "Seq.init" else aux 0 let of_list l = let rec aux l () = match l with | [] -> Nil | x::l' -> Cons(x, aux l') in aux l let empty = nil (*$T empty length empty = 0 *) let return x = cons x empty (*$T return length (return 123) = 1 at (return 123) 0 = 123 equal (return 123) (of_list [123]) *) let rec unfold f u = match f u with | Some(v, r) -> (fun () -> Cons(v, unfold f r)) | None -> nil (*$T unfold equal (unfold (fun x -> if x = 0 then None else Some (x, x-1)) 5) (of_list [5;4;3;2;1]) fold_left (fun a b -> b :: a) [] (unfold (fun x -> if x = 0 then None else Some (x, x-1)) 5) = [1;2;3;4;5] *) let rec iter f s = match s () with | Nil -> () | Cons(e, s) -> f e; iter f s let iteri f s = let rec iteri f i s = match s () with | Nil -> () | Cons(e, s) -> f i e; iteri f (i+1) s in iteri f 0 s (*$T iteri try iteri (fun i x -> if i<>x then raise Exit) (of_list [0;1;2;3]); true \ with Exit -> false *) let rec iter2 f s1 s2 = match s1 (), s2 () with | Nil, _ | _, Nil -> () | Cons (x1, s1'), Cons (x2, s2') -> f x1 x2; iter2 f s1' s2' (*$T iter2 let r = ref 0 in \ iter2 (fun i j -> r := !r + i*j) (of_list [1;2]) (of_list [3;2;1]); \ !r = 3 + 2*2 *) let rec map f s () = match s () with | Nil -> Nil | Cons(x, s) -> Cons(f x, map f s) let flat_map f s = flatten (map f s) (*$T flat_map equal (flat_map of_list (of_list [[1;2;3];[4;5;6]])) (of_list [1;2;3;4;5;6]) *) (* alias *) let concat_map = flat_map let mapi f s = let rec mapi f i s () = match s () with | Nil -> Nil | Cons(x, s) -> Cons(f i x, mapi f (i+1) s) in mapi f 0 s (*$T mapi equal (of_list [0;0;0;0]) \ (mapi (fun i x -> i - x) (of_list [0;1;2;3])) *) let rec map2 f s1 s2 () = match s1 (), s2 () with | Nil, _ | _, Nil -> Nil | Cons (x1, s1'), Cons (x2, s2') -> Cons (f x1 x2, map2 f s1' s2') (*$T map2 equal (map2 (+) (of_list [1;2;3]) (of_list [3;2])) \ (of_list [4;4]) *) let rec fold_left f acc s = match s () with | Nil -> acc | Cons(e, s) -> fold_left f (f acc e) s let rec fold_right f s acc = match s () with | Nil -> acc | Cons(e, s) -> f e (fold_right f s acc) let reduce f s = match s () with | Nil -> invalid_arg "Seq.reduce" | Cons(e, s) -> fold_left f e s let max s = match s () with | Nil -> invalid_arg "Seq.max" | Cons(e, s) -> fold_left Pervasives.max e s let min s = match s () with | Nil -> invalid_arg "Seq.min" | Cons(e, s) -> fold_left Pervasives.min e s let equal ?(eq=(=)) s1 s2 = let rec recurse eq s1 s2 = match s1 (), s2 () with | Nil, Nil -> true | Nil, Cons _ | Cons _, Nil -> false | Cons (x1, s1'), Cons (x2, s2') -> eq x1 x2 && recurse eq s1' s2' in recurse eq s1 s2 (*$T of_list equal (of_list [1;2;3]) (nil |> cons 3 |> cons 2 |> cons 1) *) let rec for_all f s = match s () with | Nil -> true | Cons(e, s) -> f e && for_all f s let rec exists f s = match s () with | Nil -> false | Cons(e, s) -> f e || exists f s let mem e s = exists ((=) e) s let rec find f s = match s () with | Nil -> None | Cons(e, s) -> if f e then Some e else find f s let rec find_map f s = match s () with | Nil -> None | Cons(e, s) -> match f e with | None -> find_map f s | x -> x let rec filter f s () = match s () with | Nil -> Nil | Cons(e, s) -> if f e then Cons(e, filter f s) else filter f s () let rec filter_map f s () = match s () with | Nil -> Nil | Cons(e, s) -> match f e with | None -> filter_map f s () | Some e -> Cons(e, filter_map f s) let assoc key s = find_map (fun (k, v) -> if k = key then Some v else None) s let rec take n s () = if n <= 0 then Nil else match s () with | Nil -> Nil | Cons(e, s) -> Cons(e, take (n - 1) s) let rec drop n s = if n <= 0 then s else match s () with | Nil -> nil | Cons(_e, s) -> drop (n - 1) s let rec take_while f s () = match s () with | Nil -> Nil | Cons(e, s) -> if f e then Cons(e, take_while f s) else Nil let rec drop_while f s = match s () with | Nil -> nil | Cons(e, s) -> if f e then drop_while f s else cons e s let split s = (map fst s, map snd s) let rec combine s1 s2 () = match s1 (), s2 () with | Nil, Nil -> Nil | Cons(e1, s1), Cons(e2, s2) -> Cons((e1, e2), combine s1 s2) | _ -> invalid_arg "Seq.combine" let print ?(first="[") ?(last="]") ?(sep="; ") print_a out s = match s () with | Nil -> BatInnerIO.nwrite out first; BatInnerIO.nwrite out last | Cons(e, s) -> match s () with | Nil -> BatPrintf.fprintf out "%s%a%s" first print_a e last | _ -> BatInnerIO.nwrite out first; print_a out e; iter (BatPrintf.fprintf out "%s%a" sep print_a) s; BatInnerIO.nwrite out last let to_buffer ?(first="[") ?(last="]") ?(sep=";") to_str buff s = match s () with | Nil -> (Buffer.add_string buff first; Buffer.add_string buff last) | Cons(e, s) -> match s () with | Nil -> (Buffer.add_string buff first; Buffer.add_string buff (to_str e); Buffer.add_string buff last) | _ -> Buffer.add_string buff first; Buffer.add_string buff (to_str e); iter (fun e -> Buffer.add_string buff sep; Buffer.add_string buff (to_str e) ) s; Buffer.add_string buff last let to_string ?(first="[") ?(last="]") ?(sep=";") to_str s = let buff = Buffer.create 80 in to_buffer ~first ~last ~sep to_str buff s; Buffer.contents buff (*$T to_string to_string string_of_int (of_list [1;2;3]) = "[1;2;3]" to_string ~first:"{" ~sep:"," ~last:"}" string_of_int (of_list [1;2;3]) = "{1,2,3}" to_string string_of_int (of_list []) = "[]" *) let of_string ?(first="[") ?(last="]") ?(sep=";") of_str s = if not (BatString.starts_with s first) then raise (Invalid_argument ("Seq.of_string: wrong prefix: " ^ first ^ " not prefix of " ^ s)); if not (BatString.ends_with s last) then raise (Invalid_argument ("Seq.of_string: wrong suffix: " ^ last ^ " not suffix of " ^ s)); let prfx_len = String.length first in let sufx_len = String.length last in let n = String.length s in if n = prfx_len + sufx_len then nil else let body = BatString.chop ~l:prfx_len ~r:sufx_len s in let strings = BatString.nsplit ~by:sep body in of_list (List.map of_str strings) (*$T of_string equal (of_string int_of_string "[1;2;3]") (of_list [1;2;3]) equal (of_string int_of_string "[]") (of_list []) equal (of_string ~first:"{" ~sep:"," ~last:"}" int_of_string "{1,2,3}") (of_list [1;2;3]) try equal (of_string ~first:"{" int_of_string "[1;2;3]") (of_list []) with (Invalid_argument _) -> true try equal (of_string ~last:"}" int_of_string "[1;2;3]") (of_list []) with (Invalid_argument _) -> true *) module Infix = struct (** Infix operators matching those provided by {!BatEnum.Infix} *) let ( -- ) a b = if b < a then nil else init (b - a + 1) (fun x -> a + x) let ( --^ ) a b = a -- (b - 1) let ( --. ) (a, step) b = let n = int_of_float ((b -. a) /. step) + 1 in if n < 0 then nil else init n (fun i -> float_of_int i *. step +. a) let ( --- ) a b = let n = abs (b - a) in if b < a then init n (fun x -> a - x) else a -- b let ( --~ ) a b = map Char.chr (Char.code a -- Char.code b) let ( // ) s f = filter f s let ( /@ ) s f = map f s let ( @/ ) = map let ( //@ ) s f = filter_map f s let ( @// ) = filter_map end include Infix module Exceptionless = struct (*$< Exceptionless *) (* This function could be used to eliminate a lot of duplicate code below... let exceptionless_arg f s e = try Some (f s) with Invalid_argument e -> None *) let hd s = try Some (hd s) with Invalid_argument _ -> None let tl s = try Some (tl s) with Invalid_argument _ -> None let first s = try Some (first s) with Invalid_argument _ -> None let last s = try Some (last s) with Invalid_argument _ -> None let at s n = try Some (at s n) with Invalid_argument _ -> None (* let make n e = try Some (make n e) with Invalid_argument _ -> None let init n e = try Some (init n e) with Invalid_argument _ -> None *) let reduce f s = try Some (reduce f s) with Invalid_argument _ -> None let max s = try Some (max s) with Invalid_argument _ -> None let min s = try Some (min s) with Invalid_argument _ -> None let rec combine s1 s2 () = match s1 (), s2 () with | Nil, Nil -> Nil | Cons(e1, s1), Cons(e2, s2) -> Cons((e1, e2), combine s1 s2) | _ -> Nil (*$T combine equal (combine (of_list [1;2]) (of_list ["a";"b"])) (of_list [1,"a"; 2,"b"]) equal (combine (of_list [1;2]) (of_list ["a";"b";"c"])) (of_list [1,"a"; 2,"b"]) equal (combine (of_list [1;2;3]) (of_list ["a";"b"])) (of_list [1,"a"; 2,"b"]) *) (*$>*) end batteries-included-3.4.0/src/batSet.ml000066400000000000000000001264301415601150500176340ustar00rootroot00000000000000(* * BatSet - Extended operations on sets * Copyright (C) 1996 Xavier Leroy * 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module type OrderedType = BatInterfaces.OrderedType (** Input signature of the functor {!Set.Make}. *) module Concrete = struct type 'a set = | Empty | Node of 'a set * 'a * 'a set * int let empty = Empty let is_empty = function Empty -> true | _ -> false let is_singleton = function | Node (Empty, _x, Empty, _h) -> true | _ -> false (*$T is_singleton is_singleton (of_list []) = false is_singleton (of_list [1]) = true is_singleton (of_list [1;2]) = false *) (* Sets are represented by balanced binary trees (the heights of the children differ by at most 2 *) let height = function | Empty -> 0 | Node (_, _, _, h) -> h (* 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 | Node(_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1)) (* 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 | Node(_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in if hl > hr + 2 then begin match l with Empty -> invalid_arg "Set.bal" | Node(ll, lv, lr, _) -> if height ll >= height lr then create ll lv (create lr v r) else begin match lr with Empty -> invalid_arg "Set.bal" | Node(lrl, lrv, lrr, _)-> create (create ll lv lrl) lrv (create lrr v r) end end else if hr > hl + 2 then begin match r with Empty -> invalid_arg "Set.bal" | Node(rl, rv, rr, _) -> if height rr >= height rl then create (create l v rl) rv rr else begin match rl with Empty -> invalid_arg "Set.bal" | Node(rll, rlv, rlr, _) -> create (create l v rll) rlv (create rlr rv rr) end end else Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1)) (* Smallest and greatest element of a set *) let rec min_elt = function Empty -> raise Not_found | Node(Empty, v, _r, _) -> v | Node(l, _v, _r, _) -> min_elt l let rec min_elt_opt = function Empty -> None | Node(Empty, v, _r, _) -> Some v | Node(l, _v, _r, _) -> min_elt_opt l let get_root = function | Empty -> raise Not_found | Node(_l, v, _r, _) -> v let pop_min s = let mini = ref (get_root s) in let rec loop = function Empty -> raise Not_found | Node(Empty, v, r, _) -> mini := v; r | Node(l, v, r, _) -> bal (loop l) v r in let others = loop s in (!mini, others) let pop_max s = let maxi = ref (get_root s) in let rec loop = function Empty -> raise Not_found | Node(l, v, Empty, _) -> maxi := v; l | Node(l, v, r, _) -> bal l v (loop r) in let others = loop s in (!maxi, others) let rec max_elt = function Empty -> raise Not_found | Node(_l, v, Empty, _) -> v | Node(_l, _v, r, _) -> max_elt r let rec max_elt_opt = function Empty -> None | Node(_l, v, Empty, _) -> Some v | Node(_l, _v, r, _) -> max_elt_opt r (* Remove the smallest element of the given set *) let rec remove_min_elt = function Empty -> invalid_arg "Set.remove_min_elt" | Node(Empty, _v, 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 t2) (remove_min_elt t2) let pop s = match s with | Empty -> raise Not_found | Node (l, v, r, _) -> v, merge l r (* Insertion of one element *) let rec add cmp x = function | Empty -> Node(Empty, x, Empty, 1) | Node(l, v, r, _) as t -> let c = cmp x v in if c = 0 then t else if c < 0 then let nl = add cmp x l in if nl == l then t else bal nl v r else let nr = add cmp x r in if nr == r then t else bal l v nr let rec remove cmp x = function | Empty as t -> t | Node(l, v, r, _) as t -> let c = cmp x v in if c = 0 then merge l r else if c < 0 then let nl = remove cmp x l in if nl == l then t else bal nl v r else let nr = remove cmp x r in if nr == r then t else bal l v nr (* A variant of [remove] that throws [Not_found] on failure *) let rec remove_exn cmp x = function | Empty -> raise Not_found | Node (l, v, r, _) -> let c = cmp x v in if c = 0 then merge l r else if c < 0 then bal (remove_exn cmp x l) v r else bal l v (remove_exn cmp x r) let update cmp x y s = if cmp x y <> 0 then add cmp y (remove_exn cmp x s) else let rec loop = function | Empty -> raise Not_found | Node(l, v, r, h) as t -> let c = cmp x v in if c = 0 then if v == y then t else Node(l, y, r, h) else if c < 0 then let nl = loop l in if nl == l then t else Node(nl, v, r, h) else let nr = loop r in if nr == r then t else Node(l, v, nr, h) in loop s let rec mem cmp x = function Empty -> false | Node(l, v, r, _) -> let c = cmp x v in c = 0 || mem cmp x (if c < 0 then l else r) let rec find cmp x = function Empty -> raise Not_found | Node(l, v, r, _) -> let c = cmp x v in if c = 0 then v else find cmp x (if c < 0 then l else r) let rec find_opt cmp x = function Empty -> None | Node(l, v, r, _) -> let c = cmp x v in if c = 0 then Some v else find_opt cmp x (if c < 0 then l else r) let rec find_first_helper_found k0 f = function | Empty -> k0 | Node (l, k, r, _) -> if f k then find_first_helper_found k f l else find_first_helper_found k0 f r let rec find_first f m = match m with | Empty -> raise Not_found | Node (l, k, r, _) -> if f k then find_first_helper_found k f l else find_first f r let rec find_first_opt f m = match m with | Empty -> None | Node (l, k, r, _) -> if f k then Some (find_first_helper_found k f l) else find_first_opt f r let rec find_last_helper_found k0 f = function | Empty -> k0 | Node (l, k, r, _) -> if f k then find_last_helper_found k f r else find_last_helper_found k0 f l let rec find_last f m = match m with | Empty -> raise Not_found | Node (l, k, r, _) -> if f k then find_last_helper_found k f r else find_last f l let rec find_last_opt f m = match m with | Empty -> None | Node (l, k, r, _) -> if f k then Some (find_last_helper_found k f r) else find_last_opt f l let rec iter f = function Empty -> () | Node(l, v, r, _) -> iter f l; f v; iter f r let rec fold f s accu = match s with Empty -> accu | Node(l, v, r, _) -> fold f r (f v (fold f l accu)) exception Found let at_rank_exn i s = if i < 0 then invalid_arg "Set.at_rank_exn: negative index not allowed"; let res = ref (get_root s) in (* raises Not_found if empty *) try let (_: int) = fold (fun node j -> if j <> i then j + 1 else begin res := node; raise Found end ) s 0 in invalid_arg "Set.at_rank_exn i s: i >= (Set.cardinal s)" with Found -> !res let rec op_map f = function | Empty -> Empty | Node (l,x,r,h) -> Node (op_map f l, f x, op_map f r, h) let singleton x = Node(Empty, x, Empty, 1) let rec add_min v = function | Empty -> singleton v | Node (l, x, r, _h) -> bal (add_min v l) x r let rec add_max v = function | Empty -> singleton v | Node (l, x, r, _h) -> bal l x (add_max v r) (* 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 v l | (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 (* Splitting. split x s returns a triple (l, present, r) where - l is the set of elements of s that are < x - r is the set of elements of s that are > x - present is false if s contains no element equal to x, or true if s contains an element equal to x. *) let rec split cmp x = function Empty -> (Empty, false, Empty) | Node(l, v, r, _) -> let c = cmp x v in if c = 0 then (l, true, r) else if c < 0 then let (ll, pres, rl) = split cmp x l in (ll, pres, join rl v r) else let (lr, pres, rr) = split cmp x r in (join l v lr, pres, rr) (* split_opt x s returns a triple (l, maybe_v, r) where - l is the set of elements of s that are < x - r is the set of elements of s that are > x - maybe_v is None if s contains no element equal to x, or (Some v) if s contains an element v that compares equal to x. *) let rec split_opt cmp x = function | Empty -> (Empty, None, Empty) | Node(l, v, r, _) -> let c = cmp x v in if c = 0 then (l, Some v, r) else if c < 0 then let (ll, pres, rl) = split_opt cmp x l in (ll, pres, join rl v r) else (* c > 0 *) let (lr, pres, rr) = split_opt cmp x r in (join l v lr, pres, rr) (*$inject let s12 = of_list [1; 2 ] ;; let s45 = of_list [ 4; 5] ;; let s1245 = of_list [1; 2; 4; 5] ;; let s12345 = of_list [1; 2; 3; 4; 5] ;; *) (*$T split_opt let l1, mv1, r1 = split_opt 3 s1245 in \ (elements l1, mv1, elements r1) = ([1; 2], None , [4; 5]) let l2, mv2, r2 = split_opt 3 s12345 in \ (elements l2, mv2, elements r2) = ([1; 2], Some 3, [4; 5]) *) (* returns a pair of sets: ({y | y < x}, {y | y >= x}) *) let split_lt cmp x s = let l, maybe, r = split_opt cmp x s in match maybe with | None -> l, r | Some eq_x -> l, add cmp eq_x r (*$T split_lt let l, r = split_lt 3 s12345 in \ (elements l, elements r) = ([1; 2], [3; 4; 5]) let l, r = split_lt 3 s12 in \ (elements l, elements r) = ([1; 2], []) let l, r = split_lt 3 s45 in \ (elements l, elements r) = ([], [4; 5]) *) (* returns a pair of sets: ({y | y <= x}, {y | y > x}) *) let split_le cmp x s = let l, maybe, r = split_opt cmp x s in match maybe with | None -> l, r | Some eq_x -> add cmp eq_x l, r (*$T split_le let l, r = split_le 3 s12345 in \ (elements l, elements r) = ([1; 2; 3], [4; 5]) let l, r = split_le 3 s12 in \ (elements l, elements r) = ([1; 2], []) let l, r = split_le 3 s45 in \ (elements l, elements r) = ([], [4; 5]) *) type 'a iter = E | C of 'a * 'a set * 'a iter let rec cardinal = function Empty -> 0 | Node(l, _v, r, _) -> cardinal l + 1 + cardinal r let rec elements_aux accu = function Empty -> accu | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l let elements s = elements_aux [] s let to_list = elements let to_array s = match s with | Empty -> [||] | Node (_, e, _, _) -> let arr = Array.make (cardinal s) e in let i = ref 0 in iter (fun x -> Array.unsafe_set arr (!i) x; incr i) s; arr let rec cons_iter s t = match s with Empty -> t | Node (l, e, r, _) -> cons_iter l (C (e, r, t)) let rec rev_cons_iter s t = match s with Empty -> t | Node (l, e, r, _) -> rev_cons_iter r (C (e, l, t)) let rec cons_iter_from cmp k2 m e = match m with | Empty -> e | Node (l, k, r, _) -> if cmp k2 k <= 0 then cons_iter_from cmp k2 l (C (k, r, e)) else cons_iter_from cmp k2 r e let enum_next l () = match !l with E -> raise BatEnum.No_more_elements | C (e, s, t) -> l := cons_iter s t; e let enum_backwards_next l () = match !l with E -> raise BatEnum.No_more_elements | C (e, s, t) -> l := rev_cons_iter s t; e let enum_count l () = let rec aux n = function E -> n | C (_e, s, t) -> aux (n + 1 + cardinal s) t in aux 0 !l let enum t = let rec make l = let l = ref l in let clone() = make !l in BatEnum.make ~next:(enum_next l) ~count:(enum_count l) ~clone in make (cons_iter t E) let backwards t = let rec make l = let l = ref l in let clone() = make !l in BatEnum.make ~next:(enum_backwards_next l) ~count:(enum_count l) ~clone in make (rev_cons_iter t E) let of_enum cmp e = BatEnum.fold (fun acc elem -> add cmp elem acc) empty e let of_list cmp l = List.fold_left (fun a x -> add cmp x a) empty l let of_array cmp l = Array.fold_left (fun a x -> add cmp x a) empty l let print ?(first="{") ?(last="}") ?(sep=",") print_elt out t = BatEnum.print ~first ~last ~sep (fun out e -> BatPrintf.fprintf out "%a" print_elt e) out (enum t) let choose = min_elt (* I'd rather this chose the root, but okay *) (*$= choose 42 (empty |> add 42 |> choose) (empty |> add 0 |> add 1 |> choose) (empty |> add 1 |> add 0 |> choose) *) let choose_opt = min_elt_opt let any = get_root (*$T any empty |> add 42 |> any = 42 try empty |> any |> ignore ; false with Not_found -> true *) let rec for_all p = function Empty -> true | Node(l, v, r, _) -> p v && for_all p l && for_all p r let rec exists p = function Empty -> false | Node(l, v, r, _) -> p v || exists p l || exists p r let partition cmp p s = let rec part (t, f as accu) = function | Empty -> accu | Node(l, v, r, _) -> part (part (if p v then (add cmp v t, f) else (t, add cmp v f)) l) r in part (Empty, Empty) s let concat t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (_, _) -> join t1 (min_elt t2) (remove_min_elt t2) let rec cartesian_product a b = match a with | Empty -> Empty | Node (la, xa, ra, _) -> let lab = cartesian_product la b in let xab = op_map (fun xb -> (xa, xb)) b in let rab = cartesian_product ra b in concat lab (concat xab rab) let rec union cmp12 s1 s2 = match (s1, s2) with (Empty, t2) -> t2 | (t1, Empty) -> t1 | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> if h1 >= h2 then if h2 = 1 then add cmp12 v2 s1 else begin let (l2, _, r2) = split cmp12 v1 s2 in join (union cmp12 l1 l2) v1 (union cmp12 r1 r2) end else if h1 = 1 then add cmp12 v1 s2 else begin let (l1, _, r1) = split cmp12 v2 s1 in join (union cmp12 l1 l2) v2 (union cmp12 r1 r2) end let rec filter p = function Empty -> Empty | (Node(l,v,r,_)) as t -> (* call [p] in the expected left-to-right order *) let l' = filter p l in let pv = p v in let r' = filter p r in if pv then if l==l' && r==r' then t else join l' v r' else concat l' r' let try_join cmp l v r = (* [join l v r] can only be called when (elements of l < v < elements of r); use [try_join l v r] when this property may not hold, but you hope it does hold in the common case *) if (l = Empty || cmp (max_elt l) v < 0) && (r = Empty || cmp v (min_elt r) < 0) then join l v r else union cmp l (add cmp v r) let rec map_endo cmp f = function | Empty -> Empty | Node(l, v, r, _) as t -> (* enforce left-to-right evaluation order *) let l' = map_endo cmp f l in let v' = f v in let r' = map_endo cmp f r in if l == l' && v == v' && r == r' then t else try_join cmp l' v' r' let rec map cmp f = function | Empty -> Empty | Node(l, v, r, _) -> (* enforce left-to-right evaluation order *) let l' = map cmp f l in let v' = f v in let r' = map cmp f r in try_join cmp l' v' r' let try_concat cmp t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (_, _) -> try_join cmp t1 (min_elt t2) (remove_min_elt t2) let rec filter_map_endo cmp f = function | Empty -> Empty | Node(l, v, r, _) as t -> (* enforce left-to-right evaluation order *) let l' = filter_map_endo cmp f l in let v' = f v in let r' = filter_map_endo cmp f r in begin match v' with | Some v' -> if l == l' && v == v' && r == r' then t else try_join cmp l' v' r' | None -> try_concat cmp l' r' end let rec filter_map cmp f = function | Empty -> Empty | Node(l, v, r, _) -> (* enforce left-to-right evaluation order *) let l' = filter_map cmp f l in let v' = f v in let r' = filter_map cmp f r in begin match v' with | Some v' -> try_join cmp l' v' r' | None -> try_concat cmp l' r' end let rec sym_diff cmp12 s1 s2 = match (s1, s2) with (Empty, t2) -> t2 | (t1, Empty) -> t1 | (Node(l1, v1, r1, _), t2) -> match split cmp12 v1 t2 with (l2, false, r2) -> join (sym_diff cmp12 l1 l2) v1 (sym_diff cmp12 r1 r2) | (l2, true, r2) -> concat (sym_diff cmp12 l1 l2) (sym_diff cmp12 r1 r2) let rec inter cmp12 s1 s2 = match (s1, s2) with (Empty, _t2) -> Empty | (_t1, Empty) -> Empty | (Node(l1, v1, r1, _), t2) -> match split cmp12 v1 t2 with (l2, false, r2) -> concat (inter cmp12 l1 l2) (inter cmp12 r1 r2) | (l2, true, r2) -> join (inter cmp12 l1 l2) v1 (inter cmp12 r1 r2) let rec diff cmp12 s1 s2 = match (s1, s2) with (Empty, _t2) -> Empty | (t1, Empty) -> t1 | (Node(l1, v1, r1, _), t2) -> match split cmp12 v1 t2 with (l2, false, r2) -> join (diff cmp12 l1 l2) v1 (diff cmp12 r1 r2) | (l2, true, r2) -> concat (diff cmp12 l1 l2) (diff cmp12 r1 r2) let rec disjoint cmp12 s1 s2 = match (s1, s2) with (Empty, _) | (_, Empty) -> true | (Node(l1, v1, r1, _), t2) -> match split cmp12 v1 t2 with (l2, false, r2) -> disjoint cmp12 l1 l2 && disjoint cmp12 r1 r2 | (_l2, true, _r2) -> false let compare cmp s1 s2 = let rec compare_aux t1' t2' = match (t1', t2') with E, E -> 0 | E, _ -> -1 | _, E -> 1 | C (e1, r1, t1), C (e2, r2, t2) -> let c = cmp e1 e2 in if c = 0 then compare_aux (cons_iter r1 t1) (cons_iter r2 t2) else c in compare_aux (cons_iter s1 E) (cons_iter s2 E) let equal cmp s1 s2 = compare cmp s1 s2 = 0 let rec subset cmp s1 s2 = match (s1, s2) with Empty, _ -> true | _, Empty -> false | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) -> let c = cmp v1 v2 in if c = 0 then subset cmp l1 l2 && subset cmp r1 r2 else if c < 0 then subset cmp (Node (l1, v1, Empty, 0)) l2 && subset cmp r1 t2 else subset cmp (Node (Empty, v1, r1, 0)) r2 && subset cmp l1 t2 let add_seq cmp s m = BatSeq.fold_left (fun m e -> add cmp e m) m s let of_seq cmp s = add_seq cmp s empty let rec seq_of_iter m () = match m with | E -> BatSeq.Nil | C(k, r, e) -> BatSeq.Cons (k, seq_of_iter (cons_iter r e)) let to_seq m = seq_of_iter (cons_iter m E) let rec rev_seq_of_iter m () = match m with | E -> BatSeq.Nil | C(k, r, e) -> BatSeq.Cons (k, rev_seq_of_iter (rev_cons_iter r e)) let to_rev_seq m = rev_seq_of_iter (rev_cons_iter m E) let to_seq_from cmp k m = seq_of_iter (cons_iter_from cmp k m E) end module type S = sig type elt type t val empty: t val is_empty: t -> bool val is_singleton: t -> bool val singleton: elt -> t val mem: elt -> t -> bool val find: elt -> t -> elt val find_opt: elt -> t -> elt option val find_first : (elt -> bool) -> t -> elt val find_first_opt : (elt -> bool) -> t -> elt option val find_last : (elt -> bool) -> t -> elt val find_last_opt : (elt -> bool) -> t -> elt option val add: elt -> t -> t val remove: elt -> t -> t val remove_exn: elt -> t -> t val update: elt -> elt -> t -> t val union: t -> t -> t val inter: t -> t -> t val diff: t -> t -> t val sym_diff: t -> t -> t val compare: t -> t -> int val equal: t -> t -> bool val subset: t -> t -> bool val disjoint: t -> t -> bool val compare_subset: t -> t -> int val iter: (elt -> unit) -> t -> unit val at_rank_exn: int -> t -> elt val map: (elt -> elt) -> t -> t val filter: (elt -> bool) -> t -> t val filter_map: (elt -> elt option) -> t -> t val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a val for_all: (elt -> bool) -> t -> bool val exists: (elt -> bool) -> t -> bool val partition: (elt -> bool) -> t -> t * t val split: elt -> t -> t * bool * t val split_opt: elt -> t -> t * elt option * t val split_lt: elt -> t -> t * t val split_le: elt -> t -> t * t val cardinal: t -> int val elements: t -> elt list val to_list: t -> elt list val to_array: t -> elt array val min_elt: t -> elt val min_elt_opt: t -> elt option val pop_min: t -> elt * t val pop_max: t -> elt * t val max_elt: t -> elt val max_elt_opt: t -> elt option val choose: t -> elt val choose_opt: t -> elt option val any: t -> elt val pop: t -> elt * t val enum: t -> elt BatEnum.t val backwards: t -> elt BatEnum.t val of_enum: elt BatEnum.t -> t val of_list: elt list -> t val of_array: elt array -> t val to_seq : t -> elt BatSeq.t val to_rev_seq : t -> elt BatSeq.t val to_seq_from : elt -> t -> elt BatSeq.t val add_seq : elt BatSeq.t -> t -> t val of_seq : elt BatSeq.t -> t val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> elt -> unit) -> 'a BatInnerIO.output -> t -> unit (** Operations on {!Set} without exceptions.*) module Exceptionless : sig val min_elt: t -> elt option val max_elt: t -> elt option val choose: t -> elt option val any: t -> elt option val find: elt -> t -> elt option end (** Operations on {!Set} with labels. *) module Labels : sig val iter : f:(elt -> unit) -> t -> unit val fold : f:(elt -> 'a -> 'a) -> t -> init:'a -> 'a val for_all : f:(elt -> bool) -> t -> bool val exists : f:(elt -> bool) -> t -> bool val map: f:(elt -> elt) -> t -> t val filter : f:(elt -> bool) -> t -> t val filter_map: f:(elt -> elt option) -> t -> t val partition : f:(elt -> bool) -> t -> t * t end end (** Output signature of the functor {!Set.Make}. *) module Make (Ord : OrderedType) = struct include Set.Make(Ord) (*Breaking the abstraction*) type implementation = elt Concrete.set external impl_of_t : t -> implementation = "%identity" external t_of_impl : implementation -> t = "%identity" let cardinal t = Concrete.cardinal (impl_of_t t) let is_singleton t = Concrete.is_singleton (impl_of_t t) let enum t = Concrete.enum (impl_of_t t) let of_enum e = t_of_impl (Concrete.of_enum Ord.compare e) let backwards t = Concrete.backwards (impl_of_t t) let remove e t = t_of_impl (Concrete.remove Ord.compare e (impl_of_t t)) let remove_exn e t = t_of_impl (Concrete.remove_exn Ord.compare e (impl_of_t t)) let update e1 e2 t = t_of_impl (Concrete.update Ord.compare e1 e2 (impl_of_t t)) let add e t = t_of_impl (Concrete.add Ord.compare e (impl_of_t t)) let iter f t = Concrete.iter f (impl_of_t t) let at_rank_exn i t = Concrete.at_rank_exn i (impl_of_t t) let map f t = t_of_impl (Concrete.map_endo Ord.compare f (impl_of_t t)) let fold f t acc = Concrete.fold f (impl_of_t t) acc let filter f t = t_of_impl (Concrete.filter f (impl_of_t t)) let filter_map f t = t_of_impl (Concrete.filter_map_endo Ord.compare f (impl_of_t t)) let find x t = Concrete.find Ord.compare x (impl_of_t t) let find_opt x t = Concrete.find_opt Ord.compare x (impl_of_t t) let find_first f t = Concrete.find_first f (impl_of_t t) let find_first_opt f t = Concrete.find_first_opt f (impl_of_t t) let find_last f t = Concrete.find_last f (impl_of_t t) let find_last_opt f t = Concrete.find_last_opt f (impl_of_t t) let exists f t = Concrete.exists f (impl_of_t t) let for_all f t = Concrete.for_all f (impl_of_t t) let partition f t = let l, r = Concrete.partition Ord.compare f (impl_of_t t) in (t_of_impl l, t_of_impl r) let min_elt t = Concrete.min_elt (impl_of_t t) let min_elt_opt t = Concrete.min_elt_opt (impl_of_t t) let pop_min t = let mini, others = Concrete.pop_min (impl_of_t t) in (mini, t_of_impl others) let pop_max t = let maxi, others = Concrete.pop_max (impl_of_t t) in (maxi, t_of_impl others) let max_elt t = Concrete.max_elt (impl_of_t t) let max_elt_opt t = Concrete.max_elt_opt (impl_of_t t) let choose t = Concrete.choose (impl_of_t t) let choose_opt t = Concrete.choose_opt (impl_of_t t) let any t = Concrete.any (impl_of_t t) let pop t = let e, t = Concrete.pop (impl_of_t t) in e, t_of_impl t let split e s = let l, v, r = Concrete.split Ord.compare e (impl_of_t s) in (t_of_impl l, v, t_of_impl r) let split_opt e s = let l, maybe_v, r = Concrete.split_opt Ord.compare e (impl_of_t s) in (t_of_impl l, maybe_v, t_of_impl r) let split_lt e s = let l, r = Concrete.split_lt Ord.compare e (impl_of_t s) in (t_of_impl l, t_of_impl r) let split_le e s = let l, r = Concrete.split_le Ord.compare e (impl_of_t s) in (t_of_impl l, t_of_impl r) let singleton e = t_of_impl (Concrete.singleton e) let elements t = Concrete.elements (impl_of_t t) let to_list = elements let to_array t = Concrete.to_array (impl_of_t t) let union s1 s2 = t_of_impl (Concrete.union Ord.compare (impl_of_t s1) (impl_of_t s2)) let diff s1 s2 = t_of_impl (Concrete.diff Ord.compare (impl_of_t s1) (impl_of_t s2)) let inter s1 s2 = t_of_impl (Concrete.inter Ord.compare (impl_of_t s1) (impl_of_t s2)) let sym_diff s1 s2 = t_of_impl (Concrete.sym_diff Ord.compare (impl_of_t s1) (impl_of_t s2)) let compare t1 t2 = Concrete.compare Ord.compare (impl_of_t t1) (impl_of_t t2) let equal t1 t2 = Concrete.equal Ord.compare (impl_of_t t1) (impl_of_t t2) let subset t1 t2 = Concrete.subset Ord.compare (impl_of_t t1) (impl_of_t t2) let disjoint t1 t2 = Concrete.disjoint Ord.compare (impl_of_t t1) (impl_of_t t2) let add_seq s t = t_of_impl (Concrete.add_seq Ord.compare s (impl_of_t t)) let of_seq s = t_of_impl (Concrete.of_seq Ord.compare s) let to_seq t = Concrete.to_seq (impl_of_t t) let to_rev_seq t = Concrete.to_rev_seq (impl_of_t t) let to_seq_from k t = Concrete.to_seq_from Ord.compare k (impl_of_t t) let rec compare_subset s1 s2 = match (s1, impl_of_t s2) with (Concrete.Empty, Concrete.Empty) -> 0 | (Concrete.Empty, _t2) -> -1 | (_t1, Concrete.Empty) -> 1 | (Concrete.Node(l1, v1, r1, _), t2) -> match split v1 (t_of_impl t2) with (l2, true, r2) -> (* v1 in both s1 and s2 *) (match compare_subset l1 l2, compare_subset r1 r2 with | -1, -1 | -1, 0 | 0, -1 -> -1 | 0, 0 -> 0 | 1, 1 | 1, 0 | 0, 1 -> 1 | _ -> min_int) | (l2, false, r2) -> (* v1 in s1, but not in s2 *) if (compare_subset l1 l2) >= 0 && (compare_subset r1 r2) >= 0 then 1 else min_int let compare_subset s1 s2 = compare_subset (impl_of_t s1) s2 let of_list l = t_of_impl (Concrete.of_list Ord.compare l) let of_array a = t_of_impl (Concrete.of_array Ord.compare a) let print ?first ?last ?sep print_elt out t = Concrete.print ?first ?last ?sep print_elt out (impl_of_t t) module Exceptionless = struct let min_elt t = try Some (min_elt t) with Not_found -> None let max_elt t = try Some (max_elt t) with Not_found -> None let choose t = try Some (choose t) with Not_found -> None let any t = try Some (any t) with Not_found -> None let find e t = try Some (find e t) with Not_found -> None end module Labels = struct let iter ~f t = iter f t let fold ~f t ~init = fold f t init let for_all ~f t = for_all f t let exists ~f t = exists f t let map ~f t = map f t let filter ~f t = filter f t let filter_map ~f t = filter_map f t let partition ~f t = partition f t end end module Int = Make (BatInt) module Int32 = Make (BatInt32) module Int64 = Make (BatInt64) module Nativeint = Make (BatNativeint) module Float = Make (BatFloat) module Char = Make (BatChar) module String = Make (BatString) module Make2(O1 : OrderedType)(O2 : OrderedType) = struct module Set1 = Make(O1) module Set2 = Make(O2) module Product = Make( struct type t = O1.t * O2.t let compare (x1,y1)(x2,y2) = let c = O1.compare x1 x2 in if c = 0 then O2.compare y1 y2 else c end) let cartesian_product set1 set2 = let p = Concrete.cartesian_product (Set1.impl_of_t set1) (Set2.impl_of_t set2) in Product.t_of_impl p end (*$T let module S1 = Make(BatInt) in \ let module S2 = Make(BatString) in \ let module P = Make2(BatInt)(BatString) in \ P.cartesian_product \ (List.fold_right S1.add [1;2;3] S1.empty) \ (List.fold_right S2.add ["a";"b"] S2.empty) \ |> P.Product.to_list = [1, "a"; 1, "b"; 2, "a"; 2, "b"; 3, "a"; 3, "b"] *) module PSet = struct (*$< PSet *) type 'a t = { cmp : 'a -> 'a -> int; set : 'a Concrete.set; } type 'a enumerable = 'a t type 'a mappable = 'a t let empty = { cmp = compare; set = Concrete.empty } let create cmp = { cmp = cmp; set = Concrete.empty } let get_cmp {cmp; _} = cmp (*$T get_cmp get_cmp (create BatInt.compare) == BatInt.compare *) let singleton ?(cmp = compare) x = { cmp = cmp; set = Concrete.singleton x } let is_empty s = Concrete.is_empty s.set let is_singleton s = Concrete.is_singleton s.set let mem x s = Concrete.mem s.cmp x s.set let find x s = Concrete.find s.cmp x s.set let find_opt x s = Concrete.find_opt s.cmp x s.set let find_first f s = Concrete.find_first f s.set let find_first_opt f s = Concrete.find_first_opt f s.set let find_last f s = Concrete.find_last f s.set let find_last_opt f s = Concrete.find_last_opt f s.set let add x s = let newset = Concrete.add s.cmp x s.set in if newset == s.set then s else { s with set = newset } let remove x s = let newset = Concrete.remove s.cmp x s.set in if newset == s.set then s else { s with set = newset } let remove_exn x s = { s with set = Concrete.remove_exn s.cmp x s.set } let update x y s = let newset = Concrete.update s.cmp x y s.set in if newset == s.set then s else { s with set = newset } let iter f s = Concrete.iter f s.set let at_rank_exn i s = Concrete.at_rank_exn i s.set let fold f s acc = Concrete.fold f s.set acc let map f s = { cmp = Pervasives.compare; set = Concrete.map Pervasives.compare f s.set } let map_endo f s = let newset = Concrete.map_endo Pervasives.compare f s.set in if s.set == newset then s else { cmp = s.cmp; set = newset } let filter f s = let newset = Concrete.filter f s.set in if newset == s.set then s else { s with set = newset } let filter_map f s = { cmp = compare; set = Concrete.filter_map compare f s.set } let filter_map_endo f s = let newset = Concrete.filter_map_endo compare f s.set in if newset == s.set then s else { cmp = s.cmp; set = newset } let exists f s = Concrete.exists f s.set let cardinal s = fold (fun _ acc -> acc + 1) s 0 let elements s = Concrete.elements s.set let to_list = elements let to_array s = Concrete.to_array s.set let choose s = Concrete.choose s.set let choose_opt s = Concrete.choose_opt s.set let any s = Concrete.any s.set let min_elt s = Concrete.min_elt s.set let min_elt_opt s = Concrete.min_elt_opt s.set let pop_min s = let mini, others = Concrete.pop_min s.set in (mini, { s with set = others }) let pop_max s = let maxi, others = Concrete.pop_max s.set in (maxi, { s with set = others }) let max_elt s = Concrete.max_elt s.set let max_elt_opt s = Concrete.max_elt_opt s.set let enum s = Concrete.enum s.set let of_enum ?(cmp = compare) e = { cmp; set = Concrete.of_enum compare e } let of_enum_cmp ~cmp t = { cmp = cmp; set = Concrete.of_enum cmp t } let of_list ?(cmp = compare) l = { cmp; set = Concrete.of_list compare l } let of_array ?(cmp = compare) a = { cmp; set = Concrete.of_array compare a } let print ?first ?last ?sep print_elt out s = Concrete.print ?first ?last ?sep print_elt out s.set let for_all f s = Concrete.for_all f s.set let partition f s = let l, r = Concrete.partition s.cmp f s.set in { s with set = l }, { s with set = r } let pop s = let v, s' = Concrete.pop s.set in v, { s with set = s' } let split e s = let s1, found, s2 = Concrete.split s.cmp e s.set in { s with set = s1 }, found, { s with set = s2 } let split_opt e s = let s1, maybe_v, s2 = Concrete.split_opt s.cmp e s.set in { s with set = s1 }, maybe_v, { s with set = s2 } let split_lt e s = let s1, s2 = Concrete.split_lt s.cmp e s.set in { s with set = s1 }, {s with set = s2 } let split_le e s = let s1, s2 = Concrete.split_le s.cmp e s.set in { s with set = s1 }, {s with set = s2 } let union s1 s2 = { s1 with set = Concrete.union s1.cmp s1.set s2.set } let diff s1 s2 = { s1 with set = Concrete.diff s1.cmp s1.set s2.set } let sym_diff s1 s2 = { s1 with set = Concrete.sym_diff s1.cmp s1.set s2.set } let intersect s1 s2 = { s1 with set = Concrete.inter s1.cmp s1.set s2.set } let compare s1 s2 = Concrete.compare s1.cmp s1.set s2.set let equal s1 s2 = Concrete.equal s1.cmp s1.set s2.set let subset s1 s2 = Concrete.subset s1.cmp s1.set s2.set let disjoint s1 s2 = Concrete.disjoint s1.cmp s1.set s2.set let add_seq s t = { t with set = Concrete.add_seq t.cmp s t.set } let of_seq ?(cmp = Pervasives.compare) s = {set = Concrete.of_seq cmp s; cmp = cmp } let to_seq t = Concrete.to_seq t.set let to_rev_seq t = Concrete.to_rev_seq t.set let to_seq_from k t = Concrete.to_seq_from t.cmp k t.set end (*$>*) type 'a t = 'a Concrete.set type 'a enumerable = 'a t type 'a mappable = 'a t let empty = Concrete.empty let singleton x = Concrete.singleton x let is_empty s = s = Concrete.Empty let is_singleton s = Concrete.is_singleton s let mem x s = Concrete.mem Pervasives.compare x s let find x s = Concrete.find Pervasives.compare x s let find_opt x s = Concrete.find_opt Pervasives.compare x s let find_first f s = Concrete.find_first f s let find_last f s = Concrete.find_last f s let find_first_opt f s = Concrete.find_first_opt f s let find_last_opt f s = Concrete.find_last_opt f s (*$T find (find 1 (of_list [1;2;3;4;5;6;7;8])) == 1 (find 8 (of_list [1;2;3;4;5;6;7;8])) == 8 (find 1 (singleton 1)) == 1 let x = "abc" in (find "abc" (singleton x)) == x let x = (1,1) in (find (1,1) (singleton x)) == x let x,y = (1,1),(1,1) in find x (singleton y) == y let x,y = [|0|],[|0|] in find x (singleton y) != x try ignore (find (1,2) (singleton (1,1))); false with Not_found -> true *) let add x s = Concrete.add Pervasives.compare x s let remove x s = Concrete.remove Pervasives.compare x s let remove_exn x s = Concrete.remove_exn Pervasives.compare x s let update x y s = Concrete.update Pervasives.compare x y s let iter f s = Concrete.iter f s let at_rank_exn i s = Concrete.at_rank_exn i s (*$T at_rank_exn 0 (of_list [1;2]) == 1 at_rank_exn 1 (of_list [1;2]) == 2 try ignore (at_rank_exn 0 empty); false with Not_found -> true try ignore (at_rank_exn (-1) (singleton 1)); false \ with Invalid_argument _msg -> true try ignore (at_rank_exn 1 (singleton 1)); false \ with Invalid_argument _msg -> true *) let fold f s acc = Concrete.fold f s acc let map f s = Concrete.map Pervasives.compare f s let map_endo f s = Concrete.map_endo Pervasives.compare f s (*$T map map (fun _x -> 1) (of_list [1;2;3]) |> cardinal = 1 *) (*$T map_endo let s = of_list [1;2;3] in s == (map_endo (fun x -> x) s) let s = empty in s == (map_endo (fun x -> x+1) s) *) let filter f s = Concrete.filter f s (*$T filter let s = of_list [1;2;3] in s == (filter (fun x -> x < 10) s) let s = empty in s == (filter (fun x -> x > 10) s) *) let filter_map f s = Concrete.filter_map Pervasives.compare f s let filter_map_endo f s = Concrete.filter_map_endo Pervasives.compare f s (*$T filter_map_endo let s = of_list [1;2;3] in s == (filter_map_endo (fun x -> Some x) s) let s = empty in s == (filter_map_endo (fun x -> Some x) s) *) let exists f s = Concrete.exists f s let cardinal s = fold (fun _ acc -> acc + 1) s 0 let elements s = Concrete.elements s let to_list = elements let to_array s = Concrete.to_array s let choose s = Concrete.choose s let choose_opt s = Concrete.choose_opt s (*$T choose_opt choose_opt (of_list [1]) = Some 1 choose_opt (empty) = None choose_opt (of_list []) = None *) let any s = Concrete.any s let min_elt s = Concrete.min_elt s let min_elt_opt s = Concrete.min_elt_opt s (*$Q min_elt (Q.list Q.small_int) (fun l -> l = [] || \ let xs = List.map (fun i -> i mod 2, i) l in \ let s = ref (of_list xs) in \ let m = ref (min_elt !s) in \ while fst !m = 0 do \ s := remove !m !s; \ s := add (2,snd !m) !s; \ m := min_elt !s; \ done; \ for_all (fun (x,_) -> x <> 0) !s \ ) *) (*$T min_elt_opt min_elt_opt (of_list [1;2;3]) = Some 1 min_elt_opt (empty) = None min_elt_opt (of_list []) = None *) let pop_min s = Concrete.pop_min s (*$T pop_min try ignore (pop_min empty); false with Not_found -> true pop_min (of_list [1;2]) = (1, singleton 2) pop_min (singleton 2) = (2, empty) pop_min (of_list [4;5;6;7]) = (4, of_list [5;6;7]) *) let pop_max s = Concrete.pop_max s (*$T pop_max try ignore (pop_max empty); false with Not_found -> true pop_max (of_list [1;2]) = (2, singleton 1) pop_max (singleton 2) = (2, empty) let maxi, others = pop_max (of_list [4;5;6;7]) in \ maxi = 7 && diff others (of_list [4;5;6]) = empty *) let max_elt s = Concrete.max_elt s let max_elt_opt s = Concrete.max_elt_opt s (*$T max_elt_opt max_elt_opt (of_list [1;2;3]) = Some 3 max_elt_opt (empty) = None max_elt_opt (of_list []) = None *) let enum s = Concrete.enum s let of_enum e = Concrete.of_enum Pervasives.compare e let backwards s = Concrete.backwards s let of_list l = Concrete.of_list Pervasives.compare l (*$Q of_list (Q.list Q.small_int) (fun l -> let xs = List.map (fun i -> i mod 5, i) l in \ let s1 = of_list xs |> enum |> List.of_enum in \ let s2 = List.sort_unique Pervasives.compare xs in \ s1 = s2 \ ) *) let of_array a = Concrete.of_array Pervasives.compare a let print ?first ?last ?sep print_elt out s = Concrete.print ?first ?last ?sep print_elt out s let for_all f s = Concrete.for_all f s let partition f s = Concrete.partition Pervasives.compare f s let pop s = Concrete.pop s let cartesian_product = Concrete.cartesian_product let split e s = Concrete.split Pervasives.compare e s let split_opt e s = Concrete.split_opt Pervasives.compare e s let split_lt e s = Concrete.split_lt Pervasives.compare e s let split_le e s = Concrete.split_le Pervasives.compare e s let union s1 s2 = Concrete.union Pervasives.compare s1 s2 let diff s1 s2 = Concrete.diff Pervasives.compare s1 s2 let sym_diff s1 s2 = Concrete.sym_diff Pervasives.compare s1 s2 let intersect s1 s2 = Concrete.inter Pervasives.compare s1 s2 let compare s1 s2 = Concrete.compare Pervasives.compare s1 s2 let equal s1 s2 = Concrete.equal Pervasives.compare s1 s2 let subset s1 s2 = Concrete.subset Pervasives.compare s1 s2 let disjoint s1 s2 = Concrete.disjoint Pervasives.compare s1 s2 let add_seq s t = Concrete.add_seq Pervasives.compare s t let of_seq s = Concrete.of_seq Pervasives.compare s let to_seq t = Concrete.to_seq t let to_rev_seq t = Concrete.to_rev_seq t let to_seq_from k t = Concrete.to_seq_from Pervasives.compare k t (*$T subset subset (of_list [1;2;3]) (of_list [1;2;3;4]) not (subset (of_list [1;2;3;5]) (of_list [1;2;3;4])) not (subset (of_list [1;2;3;4]) (of_list [1;2;3])) *) (*$T compare compare (of_list [1;2;3]) (of_list [1;2;3;4]) <> 0 let a = of_list [1;2;3] and b = of_list [1;2;3;4] in compare a b = - (compare b a) let a = of_list [1;2;3] and b = of_list [1;2;3;4] and c = of_list [3;1;2] in\ compare a b = - (compare b c) compare (of_list [1;2;3]) (of_list [3;1;2]) = 0 *) (*$T cartesian_product cartesian_product (of_list [1;2;3]) (of_list ["a"; "b"]) |> to_list = \ [1, "a"; 1, "b"; 2, "a"; 2, "b"; 3, "a"; 3, "b"] is_empty @@ cartesian_product (of_list [1;2;3]) empty is_empty @@ cartesian_product empty (of_list [1;2;3]) let s1, s2 = of_list ["a"; "b"; "c"], of_list [1;2;3] in \ equal (cartesian_product s1 s2) \ (map BatTuple.Tuple2.swap (cartesian_product s2 s1)) *) (*$inject module TestSet = Set.Make (struct type t = int * int let compare (x, _) (y, _) = BatInt.compare x y end) ;; let ts = TestSet.of_list [(1,0);(2,0);(3,0)] ;; *) (*$T try ignore(TestSet.update (1, 0) (1, 1) TestSet.empty); false \ with Not_found -> true TestSet.update (1,0) (1,1) ts = TestSet.of_list [(1,1);(2,0);(3,0)] TestSet.update (2,0) (2,1) ts = TestSet.of_list [(1,0);(2,1);(3,0)] TestSet.update (3,0) (3,1) ts = TestSet.of_list [(1,0);(2,0);(3,1)] TestSet.update (3,0) (-1,0) ts = TestSet.of_list [(1,0);(2,0);(-1,0)] try ignore (TestSet.update (4,0) (44,00) ts); false with Not_found -> true *) module Incubator = struct (*$< Incubator *) let op_map f s = Concrete.op_map f s (*$T op_map of_enum (1--3) |> op_map ((+) 2) |> mem 5 of_enum (1--3) |> op_map ((+) 2) |> mem 4 of_enum (1--3) |> op_map ((+) 2) |> mem 3 *) end (*$>*) batteries-included-3.4.0/src/batSet.mli000066400000000000000000001317671415601150500200160ustar00rootroot00000000000000(* * BatSet - Extended operations on sets * Copyright (C) 1996 Xavier Leroy * 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Sets over ordered types. This module implements the set data structure, given a total ordering function over the set elements. All operations over sets are purely applicative (no side-effects). The implementation uses balanced binary trees, and is therefore reasonably efficient: insertion and membership take time logarithmic in the size of the set, for instance. {b Note} OCaml, Batteries Included, provides two implementations of sets: polymorphic sets and functorized sets. Functorized sets (see {!S} and {!Make}) are slightly more complex to use but offer stronger type-safety. Polymorphic sets make it easier to shoot yourself in the foot. In case of doubt, you should use functorized sets. The functorized set implementation is built upon Stdlib's {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Set.html}Set} module, but provides the complete interface. @author Xavier Leroy @author Nicolas Cannasse @author Markus Mottl @author David Rajchenbach-Teller *) (** {4 Functorized Sets} *) module type OrderedType = BatInterfaces.OrderedType (** Input signature of the functor {!Set.Make}. *) module type S = sig type elt (** The type of the set elements. *) type t (** The type of sets. *) val empty: t (** The empty set. *) val is_empty: t -> bool (** Test whether a set is empty or not. *) val is_singleton: t -> bool (** Test if the set is a singleton. *) val singleton: elt -> t (** [singleton x] returns the one-element set containing only [x]. *) val mem: elt -> t -> bool (** [mem x s] tests whether [x] belongs to the set [s]. *) val find : elt -> t -> elt (** [find x s] returns the element in s that tests equal to [x] under its comparison function. @raise Not_found if no element is equal *) val find_opt : elt -> t -> elt option (** [find_opt x s] returns [Some k] for the element [k] in [s] that tests equal to [x] under its comparison function. If no element is equal, return [None] @since 3.3.0 *) val find_first : (elt -> bool) -> t -> elt (** [find_first f m] returns the first element [e] for which [f e] is true or raises [Not_found] if there is no such element. [f] must be monotonically increasing, i.e. if [k1 < k2 && f k1] is true then [f k2] must also be true. @since 3.3.0 *) val find_first_opt : (elt -> bool) -> t -> elt option (** [find_first_opt f m] returns [Some e] for the first element [e] for which [f e] is true or returns [None] if there is no such element. [f] must be monotonically increasing, i.e. if [k1 < k2 && f k1] is true then [f k2] must also be true. @since 3.3.0 *) val find_last : (elt -> bool) -> t -> elt (** [find_last f m] returns the last element [e] for which [f e] is true or raises [Not_found] if there is no such element. [f] must be monotonically decreasing, i.e. if [k1 < k2 && f k2] is true then [f k1] must also be true. @since 3.3.0 *) val find_last_opt : (elt -> bool) -> t -> elt option (** [find_last_opt f m] returns [Some e] for the last element [e] for which [f e] is true or returns [None] if there is no such element. [f] must be monotonically decreasing, i.e. if [k1 < k2 && f k2] is true then [f k1] must also be true. @since 3.3.0 *) val add: elt -> t -> t (** [add x s] returns a set containing all elements of [s], plus [x]. If [x] was already in [s], [s] is returned unchanged. @before 3.3.0 Physical equality was not ensured. *) val remove: elt -> t -> t (** [remove x s] returns a set containing all elements of [s], except [x]. If [x] was not in [s], [s] is returned unchanged. @before 3.3.0 Physical equality was not ensured. *) val remove_exn: elt -> t -> t (** [remove_exn x s] behaves like [remove x s] except that it raises an exception if [x] is not in [s]. @raise Not_found if [x] is not in [s]. @since 3.2.0 *) val update: elt -> elt -> t -> t (** [update x y s] replace [x] by [y] in [s]. [update] is faster when [x] compares equal to [y] according to the comparison function used by your set. When [x] and [y] are physically equal, [m] is returned unchanged. @raise Not_found if [x] is not in [s]. @before 3.3.0 Physical equality was not ensured. @since 2.4 *) val union: t -> t -> t (** Set union. *) val inter: t -> t -> t (** Set intersection. *) val diff: t -> t -> t (** Set difference. *) val sym_diff: t -> t -> t (** [sym_diff s t] returns the set of all elements in [s] or [t] but not both. This is the same as [diff (union s t) (inter s t)]. *) val compare: t -> t -> int (** Total ordering between sets. Can be used as the ordering function for doing sets of sets. *) val equal: t -> t -> bool (** [equal s1 s2] tests whether the sets [s1] and [s2] are equal, that is, contain equal elements. *) val subset: t -> t -> bool (** [subset s1 s2] tests whether the set [s1] is a subset of the set [s2]. *) val disjoint: t -> t -> bool (** [disjoint s1 s2] tests whether the sets [s1] and [s2] contain no shared elements. (i.e. [inter s1 s2] is empty.) *) val compare_subset: t -> t -> int (** Partial ordering between sets as generated by [subset] *) val iter: (elt -> unit) -> t -> unit (** [iter f s] applies [f] in turn to all elements of [s]. The elements of [s] are presented to [f] in increasing order with respect to the ordering over the type of the elements. *) val at_rank_exn: int -> t -> elt (** [at_rank_exn i s] returns element at rank [i] in [s], that is the [i]-th element in increasing order (the [0]-th element being the smallest element of [s]). @raise Not_found if [s = empty]. @raise Invalid_argument error_message if [i < 0 || i >= cardinal s] @since 2.4 *) val map: (elt -> elt) -> t -> t (** [map f x] creates a new set with elements [f a0], [f a1]... [f aN], where [a0],[a1]..[aN] are the values contained in [x] if [f] returns all elements unmodified then [x] is returned unmodified. @before 3.3.0 Physical equality was not ensured. *) val filter: (elt -> bool) -> t -> t (** [filter p s] returns the set of all elements in [s] that satisfy predicate [p]. if [p] returns [true] for all elements then [s] is returned unmodified. @before 3.3.0 Physical equality was not ensured. *) val filter_map: (elt -> elt option) -> t -> t (** [filter_map f m] combines the features of [filter] and [map]. It calls [f a0], [f a1], [f aN] where [a0],[a1]..[aN] are the elements of [m] and returns the set of elements [bi] such as [f ai = Some bi] (when [f] returns [None], the corresponding element of [m] is discarded). if [f] returns [true] for all elements then [s] is returned unmodified. @before 3.3.0 Physical equality was not ensured. *) val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a (** [fold f s a] computes [(f xN ... (f x1 (f x0 a))...)], where [x0],[x1]..[xN] are the elements of [s], in increasing order. *) val for_all: (elt -> bool) -> t -> bool (** [for_all p s] checks if all elements of the set satisfy the predicate [p]. *) val exists: (elt -> bool) -> t -> bool (** [exists p s] checks if at least one element of the set satisfies the predicate [p]. *) val partition: (elt -> bool) -> t -> t * t (** [partition p s] returns a pair of sets [(s1, s2)], where [s1] is the set of all the elements of [s] that satisfy the predicate [p], and [s2] is the set of all the elements of [s] that do not satisfy [p]. *) val split: elt -> t -> t * bool * t (** [split x s] returns a triple [(l, present, r)], where [l] is the set of elements of [s] that are strictly less than [x]; [r] is the set of elements of [s] that are strictly greater than [x]; [present] is [false] if [s] contains no element equal to [x], or [true] if [s] contains an element equal to [x]. *) val split_opt: elt -> t -> t * elt option * t (** [split_opt x s] returns a triple [(l, maybe_v, r)], where [l] is the set of elements of [s] that are strictly less than [x]; [r] is the set of elements of [s] that are strictly greater than [x]; [maybe_v] is [None] if [s] contains no element equal to [x], or [Some v] if [s] contains an element [v] that compares equal to [x]. @since 2.2.0 *) val split_lt: elt -> t -> t * t (** [split_lt x s] returns a pair of sets [(l, r)], such that [l] is the subset of [s] with elements < [x]; [r] is the subset of [s] with elements >= [x]. @since 2.2.0 *) val split_le: elt -> t -> t * t (** [split_le x s] returns a pair of sets [(l, r)], such that [l] is the subset of [s] with elements <= [x]; [r] is the subset of [s] with elements > [x]. @since 2.2.0 *) val cardinal: t -> int (** Return the number of elements of a set. *) val elements: t -> elt list (** Return the list of all elements of the given set. The returned list is sorted in increasing order with respect to the ordering [Ord.compare], where [Ord] is the argument given to {!Set.Make}. *) val to_list: t -> elt list (** Alias for [elements]. @since 2.2.0 *) val to_array: t -> elt array (** Same as [to_list] but with an array instead of a list. @since 2.4 *) val min_elt: t -> elt (** Return the smallest element of the given set (with respect to the [Ord.compare] ordering). @raise Not_found if the set is empty. *) val min_elt_opt : t -> elt option (** Return [Some e] for the smallest element [e] of the given set (with respect to the [Ord.compare] ordering). Return None if the set is empty. @since 3.3.0 *) val pop_min: t -> elt * t (** Returns the smallest element of the given set along with the rest of the set. Semantically equivalent and faster than [let mini = min_elt s in (mini, remove mini s)] @raise Not_found if the set is empty. @since 2.4 *) val pop_max: t -> elt * t (** Returns the biggest element of the given set along with the rest of the set. Semantically equivalent and faster than [let maxi = max_elt s in (maxi, remove maxi s)] @raise Not_found if the set is empty. @since 2.4 *) val max_elt: t -> elt (** Same as {!Set.S.min_elt}, but returns the largest element of the given set. *) val max_elt_opt : t -> elt option (** Same as {!Set.S.min_elt_opt}, but for the largest element of the given set. @since 3.3.0 *) val choose: t -> elt (** Return one element of the given set. Which element is chosen is unspecified, but equal elements will be chosen for equal sets. @raise Not_found if the set is empty. *) val choose_opt : t -> elt option (** Return [Some e] for one element [e] of the given set. Which element is chosen is unspecified, but equal elements will be chosen for equal sets. Return [None] if the set is empty. @since 3.3.0 *) val any: t -> elt (** Return one element of the given set. The difference with choose is that there is no guarantee that equals elements will be picked for equal sets. This merely returns the quickest element to get (O(1)). @raise Not_found if the set is empty. *) val pop : t -> elt * t (** returns one element of the set and the set without that element. @raise Not_found if given an empty set *) val enum: t -> elt BatEnum.t (** Return an enumeration of all elements of the given set. The returned enumeration is sorted in increasing order with respect to the ordering [Ord.compare], where [Ord] is the argument given to {!Set.Make}. *) val backwards: t -> elt BatEnum.t (** Return an enumeration of all elements of the given set. The returned enumeration is sorted in decreasing order with respect to the ordering [Ord.compare], where [Ord] is the argument given to {!Set.Make}. *) val of_enum: elt BatEnum.t -> t val of_list: elt list -> t (** builds a set from the given list. @since 2.3.0 *) val of_array: elt array -> t (** builds a set from the given array. @since 2.4 *) val to_seq : t -> elt BatSeq.t (** Iterate on the whole set, in ascending order. @since 3.3.0 *) val to_rev_seq : t -> elt BatSeq.t (** Iterate on the whole set, in descending order. @since 3.3.0 *) val to_seq_from : elt -> t -> elt BatSeq.t (** [to_seq_from x s] iterates on a subset of the elements in [s], namely those greater or equal to [x], in ascending order. @since 3.3.0 *) val add_seq : elt BatSeq.t -> t -> t (** add the given elements to the set, in order. @since 3.3.0 *) val of_seq : elt BatSeq.t -> t (** build a set from the given elements @since 3.3.0 *) (** {6 Boilerplate code}*) (** {7 Printing}*) val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> elt -> unit) -> 'a BatInnerIO.output -> t -> unit (** {6 Override modules}*) (** The following modules replace functions defined in {!Set} with functions behaving slightly differently but having the same name. This is by design: the functions meant to override the corresponding functions of {!Set}. *) (** Operations on {!Set} without exceptions.*) module Exceptionless : sig val min_elt: t -> elt option val max_elt: t -> elt option val choose: t -> elt option val any: t -> elt option val find: elt -> t -> elt option end (** Operations on {!Set} with labels. This module overrides a number of functions of {!Set} by functions in which some arguments require labels. These labels are there to improve readability and safety and to let you change the order of arguments to functions. In every case, the behavior of the function is identical to that of the corresponding function of {!Set}. *) module Labels : sig val iter : f:(elt -> unit) -> t -> unit val fold : f:(elt -> 'a -> 'a) -> t -> init:'a -> 'a val for_all : f:(elt -> bool) -> t -> bool val exists : f:(elt -> bool) -> t -> bool val map: f:(elt -> elt) -> t -> t val filter : f:(elt -> bool) -> t -> t val filter_map: f:(elt -> elt option) -> t -> t val partition : f:(elt -> bool) -> t -> t * t end end (** Output signature of the functor {!Set.Make}. *) (* module IStringSet : S with type elt = String.t (** A set of strings. Comparison of strings ignores case (i.e. "foo" = "Foo")*) module NumStringSet : S with type elt = String.t (** A set of strings. Comparison of strings takes into account embedded numbers (i.e. "a23" < "a123", "a01" = "a1") *) module RopeSet : S with type elt = BatRope.t (** A set of ropes. Comparison of ropes takes case into account (i.e. r"foo" <> r"Foo")*) module IRopeSet : S with type elt = BatRope.t (** A set of ropes. Comparison of ropes ignores case (i.e. r"foo" = r"Foo")*) *) module Make (Ord : OrderedType) : S with type elt = Ord.t (** Functor building an implementation of the set structure given a totally ordered type. @documents Set.Make *) module Make2(O1 : OrderedType) (O2 : OrderedType) : sig module Product : S with type elt = O1.t * O2.t val cartesian_product : Make(O1).t -> Make(O2).t -> Product.t (** cartesian product of the two sets *) end (** {6 Common instantiations} *) module Int : S with type elt = int module Int32 : S with type elt = int32 module Int64 : S with type elt = int64 module Nativeint : S with type elt = nativeint module Float : S with type elt = float module Char : S with type elt = char module String : S with type elt = string (** {4 Polymorphic sets} The definitions below describe the polymorphic set interface. They are similar in functionality to the functorized {!Make} module, but the compiler cannot ensure that sets using different element ordering have different types: the responsibility of not mixing non-sensical comparison functions together is to the programmer. If in doubt, you should rather use the {!Make} functor for additional safety. @author Nicolas Cannasse @author Markus Mottl @author David Rajchenbach-Teller *) type 'a t (** The type of sets. *) include BatEnum.Enumerable with type 'a enumerable = 'a t include BatInterfaces.Mappable with type 'a mappable = 'a t val empty: 'a t (** The empty set, using [compare] as comparison function *) val is_empty: 'a t -> bool (** Test whether a set is empty or not. *) val is_singleton: 'a t -> bool (** Test if the set is a singleton. *) val singleton : 'a -> 'a t (** Creates a new set with the single given element in it. *) val mem: 'a -> 'a t -> bool (** [mem x s] tests whether [x] belongs to the set [s]. *) val find: 'a -> 'a t -> 'a (** [find x s] returns the set element that compares equal to [x]. @raise Not_found if no such element exists @since 2.1 *) val find_opt : 'a -> 'a t -> 'a option (** [find_opt x s] returns [Some k] for the element [k] in [s] that tests equal to [x] under its comparison function. If no element is equal, return [None] @since 3.3.0 *) val find_first : ('a -> bool) -> 'a t -> 'a (** [find_first f m] returns the first element [e] for which [f e] is true or raises [Not_found] if there is no such element. [f] must be monotonically increasing, i.e. if [k1 < k2 && f k1] is true then [f k2] must also be true. @since 3.3.0 *) val find_first_opt : ('a -> bool) -> 'a t -> 'a option (** [find_first_opt f m] returns [Some e] for the first element [e] for which [f e] is true or returns [None] if there is no such element. [f] must be monotonically increasing, i.e. if [k1 < k2 && f k1] is true then [f k2] must also be true. @since 3.3.0 *) val find_last : ('a -> bool) -> 'a t -> 'a (** [find_last f m] returns the last element [e] for which [f e] is true or raises [Not_found] if there is no such element. [f] must be monotonically decreasing, i.e. if [k1 < k2 && f k2] is true then [f k1] must also be true. @since 3.3.0 *) val find_last_opt : ('a -> bool) -> 'a t -> 'a option (** [find_last_opt f m] returns [Some e] for the last element [e] for which [f e] is true or returns [None] if there is no such element. [f] must be monotonically decreasing, i.e. if [k1 < k2 && f k2] is true then [f k1] must also be true. @since 3.3.0 *) val add: 'a -> 'a t -> 'a t (** [add x s] returns a set containing all elements of [s], plus [x]. If [x] was already in [s], [s] is returned unchanged. @before 3.3.0 Physical equality was not ensured. *) val remove: 'a -> 'a t -> 'a t (** [remove x s] returns a set containing all elements of [s], except [x]. If [x] was not in [s], [s] is returned unchanged. @before 3.3.0 Physical equality was not ensured. *) val remove_exn: 'a -> 'a t -> 'a t (** [remove_exn x s] behaves like [remove x s] except that it raises an exception if [x] is not in [s]. @raise Not_found if [x] is not in [s]. @since 3.2.0 *) val update: 'a -> 'a -> 'a t -> 'a t (** [update x y s] replace [x] by [y] in [s]. [update] is faster when [x] compares equal to [y] according to the comparison function used by your set. When [x] and [y] are physically equal, [m] is returned unchanged. @raise Not_found if [x] is not in [s]. @since 2.4 @before 3.3.0 Physical equality was not ensured. *) val union: 'a t -> 'a t -> 'a t (** [union s t] returns the union of [s] and [t] - the set containing all elements in either [s] and [t]. The returned set uses [t]'s comparison function. The current implementation works better for small [s]. *) (* Set.Make uses intersect *) val intersect: 'a t -> 'a t -> 'a t (** [intersect s t] returns a new set of those elements that are in both [s] and [t]. The returned set uses [s]'s comparison function. *) val diff: 'a t -> 'a t -> 'a t (** [diff s t] returns the set of all elements in [s] but not in [t]. The returned set uses [s]'s comparison function.*) val sym_diff: 'a t -> 'a t -> 'a t (** [sym_diff s t] returns the set of all elements in [s] or [t] but not both, also known as the symmetric difference. This is the same as [diff (union s t) (inter s t)]. The returned set uses [s]'s comparison function.*) val compare: 'a t -> 'a t -> int (** Total ordering between sets. Can be used as the ordering function for doing sets of sets. *) val equal: 'a t -> 'a t -> bool (** [equal s1 s2] tests whether the sets [s1] and [s2] are equal, that is, contain equal elements. *) val subset: 'a t -> 'a t -> bool (** [subset a b] returns true if [a] is a subset of [b]. O(|a|). *) val disjoint: 'a t -> 'a t -> bool (** [disjoint s1 s2] tests whether the sets [s1] and [s2] contain no shared elements. (i.e. [inter s1 s2] is empty.) *) val iter: ('a -> unit) -> 'a t -> unit (** [iter f s] applies [f] in turn to all elements of [s]. The elements of [s] are presented to [f] in increasing order with respect to the ordering over the type of the elements. *) val at_rank_exn: int -> 'a t -> 'a (** [at_rank_exn i s] returns element at rank [i] in [s], that is the [i]-th element in increasing order (the [0]-th element being the smallest element of [s]). @raise Not_found if [s = empty]. @raise Invalid_argument error_message if [i < 0 || i >= cardinal s] @since 2.4 *) val map: ('a -> 'b) -> 'a t -> 'b t (** [map f x] creates a new set with elements [f a0], [f a1]... [f aN], where [a0], [a1], ..., [aN] are the elements of [x]. This function places no restriction on [f]; it can map multiple input values to the same output value, in which case the resulting set will have smaller cardinality than the input. [f] does not need to be order preserving, although if it is, then [Incubator.op_map] may be more efficient. *) val map_endo: ('a -> 'a) -> 'a t -> 'a t (** [map_endo f x] creates a new set with elements [f a0], [f a1]... [f aN], where [a0], [a1], ..., [aN] are the elements of [x]. This function places no restriction on [f] (beyond the type signature being more restricted than for [map] above); it can map multiple input values to the same output value, in which case the resulting set will have smaller cardinality than the input. [f] does not need to be order preserving, although if it is, then [Incubator.op_map] may be more efficient. This version of map will result in a physically equal map if [f] returns physically equal keys. *) val filter: ('a -> bool) -> 'a t -> 'a t (** [filter p s] returns the set of all elements in [s] that satisfy predicate [p]. if [p] returns [true] for all elements then [s] is returned unmodified. @before 3.3.0 Physical equality was not ensured. *) (* as under-specified as 'map' *) val filter_map: ('a -> 'b option) -> 'a t -> 'b t (** [filter_map f m] combines the features of [filter] and [map]. It calls calls [f a0], [f a1], [f aN] where [a0,a1..an] are the elements of [m] and returns the set of pairs [bi] such as [f ai = Some bi] (when [f] returns [None], the corresponding element of [m] is discarded). The resulting map uses the polymorphic [compare] function to order elements. *) val filter_map_endo: ('a -> 'a option) -> 'a t -> 'a t (** [filter_map_endo f m] combines the features of [filter] and [map]. It calls calls [f a0], [f a1], [f aN] where [a0,a1..an] are the elements of [m] and returns the set of pairs [bi] such as [f ai = Some bi] (when [f] returns [None], the corresponding element of [m] is discarded). The resulting map uses the polymorphic [compare] function to order elements. If the filter function [f] returns [true] for all elements in [m], the resulting map is physically equal to [m]. *) val fold: ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** [fold f s a] computes [(f xN ... (f x1 (f x0 a))...)], where [x0,x1..xN] are the elements of [s], in increasing order. *) val exists: ('a -> bool) -> 'a t -> bool (** [exists p s] checks if at least one element of the set satisfies the predicate [p]. *) val for_all : ('a -> bool) -> 'a t -> bool (** Returns whether the given predicate applies to all elements in the set *) val partition : ('a -> bool) -> 'a t -> 'a t * 'a t (** returns two disjoint subsets, those that satisfy the given predicate and those that don't *) val split : 'a -> 'a t -> 'a t * bool * 'a t (** [split x s] returns a triple [(l, present, r)], where [l] is the set of elements of [s] that are strictly less than [x]; [r] is the set of elements of [s] that are strictly greater than [x]; [present] is [false] if [s] contains no element equal to [x], or [true] if [s] contains an element equal to [x]. *) val split_opt: 'a -> 'a t -> 'a t * 'a option * 'a t (** [split_opt x s] returns a triple [(l, maybe_v, r)], where [l] is the set of elements of [s] that are strictly less than [x]; [r] is the set of elements of [s] that are strictly greater than [x]; [maybe_v] is [None] if [s] contains no element equal to [x], or [Some v] if [s] contains an element [v] that compares equal to [x]. @since 2.2.0 *) val split_lt: 'a -> 'a t -> 'a t * 'a t (** [split_lt x s] returns a pair of sets [(l, r)], such that [l] is the subset of [s] with elements < [x]; [r] is the subset of [s] with elements >= [x]. @since 2.2.0 *) val split_le: 'a -> 'a t -> 'a t * 'a t (** [split_le x s] returns a pair of sets [(l, r)], such that [l] is the subset of [s] with elements <= [x]; [r] is the subset of [s] with elements > [x]. @since 2.2.0 *) val cardinal: 'a t -> int (** Return the number of elements of a set. *) val elements: 'a t -> 'a list (** Return the list of all elements of the given set. The returned list is sorted in increasing order with respect to the ordering of the given set. *) val to_list: 'a t -> 'a list (** Alias for [elements]. @since 2.2.0 *) val to_array: 'a t -> 'a array (** Same as [to_list] but with an array instead of a list. @since 2.4 *) val min_elt : 'a t -> 'a (** returns the smallest element of the set. @raise Not_found if given an empty set. *) val min_elt_opt : 'a t -> 'a option (** Return [Some e] for the smallest element [e] of the given set (with respect to the [Ord.compare] ordering). Return None if the set is empty. @since 3.3.0 *) val pop_min: 'a t -> 'a * 'a t (** Returns the smallest element of the given set along with the rest of the set. Semantically equivalent and faster than [let mini = min_elt s in (mini, remove mini s)] @raise Not_found if the set is empty. @since 2.4 *) val pop_max: 'a t -> 'a * 'a t (** Returns the biggest element of the given set along with the rest of the set. Semantically equivalent and faster than [let maxi = max_elt s in (maxi, remove maxi s)] @raise Not_found if the set is empty. @since 2.4 *) val max_elt : 'a t -> 'a (** returns the largest element of the set. @raise Not_found if given an empty set.*) val max_elt_opt : 'a t -> 'a option (** Same as {!Set.S.min_elt_opt}, but for the largest element of the given set. @since 3.3.0 *) val choose : 'a t -> 'a (** returns an arbitrary (but deterministic) element of the given set. @raise Not_found if given an empty set. *) val choose_opt : 'a t -> 'a option (** Return [Some e] for one element [e] of the given set. Which element is chosen is unspecified, but equal elements will be chosen for equal sets. Return [None] if the set is empty. @since 3.3.0 *) val any: 'a t -> 'a (** Return one element of the given set. The difference with choose is that there is no guarantee that equals elements will be picked for equal sets. This merely returns the quickest element to get (O(1)). @raise Not_found if the set is empty. *) val pop : 'a t -> 'a * 'a t (** returns one element of the set and the set without that element. @raise Not_found if given an empty set *) val cartesian_product : 'a t -> 'b t -> ('a * 'b) t (** cartesian product of the two sets @since 2.2.0 *) val enum: 'a t -> 'a BatEnum.t (** Return an enumeration of all elements of the given set. The returned enumeration is sorted in increasing order with respect to the ordering of this set.*) val of_enum: 'a BatEnum.t -> 'a t val backwards: 'a t -> 'a BatEnum.t (** Return an enumeration of all elements of the given set. The returned enumeration is sorted in decreasing order with respect to the ordering [Pervasives.compare]. *) val of_list: 'a list -> 'a t (** builds a set from the given list, using the default comparison function *) val of_array: 'a array -> 'a t (** builds a set from the given array, using the default comparison function *) val to_seq : 'a t -> 'a BatSeq.t (** Iterate on the whole set, in ascending order. @since 3.3.0 *) val to_rev_seq : 'a t -> 'a BatSeq.t (** Iterate on the whole set, in descending order. @since 3.3.0 *) val to_seq_from : 'a -> 'a t -> 'a BatSeq.t (** [to_seq_from x s] iterates on a subset of the elements in [s], namely those greater or equal to [x], in ascending order. @since 3.3.0 *) val add_seq : 'a BatSeq.t -> 'a t -> 'a t (** add the given elements to the set, in order. @since 3.3.0 *) val of_seq : 'a BatSeq.t -> 'a t (** build a set from the given elements @since 3.3.0 *) (** {6 Boilerplate code}*) (** {7 Printing}*) val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> 'c -> unit) -> 'a BatInnerIO.output -> 'c t -> unit (** {6 Incubator} *) module Incubator : sig val op_map : ('a -> 'b) -> 'a t -> 'b t (** Order Preserving map; as [map], but [f] must be order preserving; i.e. if [a < b] then [f a < f b]. This allows the tree structure to be maintained internally, resulting in O(n) work instead of O(n log n). @since 2.1 *) end module PSet : sig (** {6 Polymorphic sets} The definitions below describe the polymorphic set interface. They are similar in functionality to the functorized {!BatSet.Make} module, but the compiler cannot ensure that sets using different element ordering have different types: the responsibility of not mixing non-sensical comparison functions together is to the programmer. If you ever need a custom comparison function, it is recommended to use the {!BatSet.Make} functor for additional safety. @author Nicolas Cannasse @author Markus Mottl @author David Rajchenbach-Teller *) type 'a t (** The type of sets. *) include BatEnum.Enumerable with type 'a enumerable = 'a t include BatInterfaces.Mappable with type 'a mappable = 'a t val empty: 'a t (** The empty set, using [compare] as comparison function *) val create : ('a -> 'a -> int) -> 'a t (** Creates a new empty set, using the provided function for key comparison.*) val is_empty: 'a t -> bool (** Test whether a set is empty or not. *) val is_singleton: 'a t -> bool (** Test if the set is a singleton. *) val singleton : ?cmp:('a -> 'a -> int) -> 'a -> 'a t (** Creates a new set with the single given element in it. *) val mem: 'a -> 'a t -> bool (** [mem x s] tests whether [x] belongs to the set [s]. *) val find : 'a -> 'a t -> 'a (** [find x s] returns the element in s that tests equal to [x] under its comparison function. @raise Not_found if no element is equal *) val find_opt : 'a -> 'a t -> 'a option (** [find_opt x s] returns [Some k] for the element [k] in [s] that tests equal to [x] under its comparison function. If no element is equal, return [None] @since 3.3.0 *) val find_first : ('a -> bool) -> 'a t -> 'a (** [find_first f m] returns the first element [e] for which [f e] is true or raises [Not_found] if there is no such element. [f] must be monotonically increasing, i.e. if [k1 < k2 && f k1] is true then [f k2] must also be true. @since 3.3.0 *) val find_first_opt : ('a -> bool) -> 'a t -> 'a option (** [find_first_opt f m] returns [Some e] for the first element [e] for which [f e] is true or returns [None] if there is no such element. [f] must be monotonically increasing, i.e. if [k1 < k2 && f k1] is true then [f k2] must also be true. @since 3.3.0 *) val find_last : ('a -> bool) -> 'a t -> 'a (** [find_last f m] returns the last element [e] for which [f e] is true or raises [Not_found] if there is no such element. [f] must be monotonically decreasing, i.e. if [k1 < k2 && f k2] is true then [f k1] must also be true. @since 3.3.0 *) val find_last_opt : ('a -> bool) -> 'a t -> 'a option (** [find_last_opt f m] returns [Some e] for the last element [e] for which [f e] is true or returns [None] if there is no such element. [f] must be monotonically decreasing, i.e. if [k1 < k2 && f k2] is true then [f k1] must also be true. @since 3.3.0 *) val add: 'a -> 'a t -> 'a t (** [add x s] returns a set containing all elements of [s], plus [x]. If [x] was already in [s], [s] is returned unchanged. @before 3.3.0 Physical equality was not ensured. *) val remove: 'a -> 'a t -> 'a t (** [remove x s] returns a set containing all elements of [s], except [x]. If [x] was not in [s], [s] is returned unchanged. @before 3.3.0 Physical equality was not ensured. *) val remove_exn: 'a -> 'a t -> 'a t (** [remove_exn x s] behaves like [remove x s] except that it raises an exception if [x] is not in [s]. @raise Not_found if [x] is not in [s]. @since 3.2.0 *) val update: 'a -> 'a -> 'a t -> 'a t (** [update x y s] replace [x] by [y] in [s]. [update] is faster when [x] compares equal to [y] according to the comparison function used by your set. When [x] and [y] are physically equal, [m] is returned unchanged. @raise Not_found if [x] is not in [s]. @before 3.3.0 Physical equality was not ensured. @since 2.4 *) val union: 'a t -> 'a t -> 'a t (** [union s t] returns the union of [s] and [t] - the set containing all elements in either [s] and [t]. The returned set uses [t]'s comparison function. The current implementation works better for small [s]. *) (* Set.Make uses intersect *) val intersect: 'a t -> 'a t -> 'a t (** [intersect s t] returns a new set of those elements that are in both [s] and [t]. The returned set uses [s]'s comparison function. *) val diff: 'a t -> 'a t -> 'a t (** [diff s t] returns the set of all elements in [s] but not in [t]. The returned set uses [s]'s comparison function.*) val sym_diff: 'a t -> 'a t -> 'a t (** [sym_diff s t] returns the set of all elements in [s] or [t] but not both. This is the same as [diff (union s t) (inter s t)]. The returned set uses [s]'s comparison function.*) val compare: 'a t -> 'a t -> int (** Total ordering between sets. Can be used as the ordering function for doing sets of sets. *) val equal: 'a t -> 'a t -> bool (** [equal s1 s2] tests whether the sets [s1] and [s2] are equal, that is, contain equal elements. *) val subset: 'a t -> 'a t -> bool (** [subset a b] returns true if [a] is a subset of [b]. O(|a|). *) val disjoint: 'a t -> 'a t -> bool (** [disjoint s1 s2] tests whether the sets [s1] and [s2] contain no shared elements. (i.e. [inter s1 s2] is empty.) *) val iter: ('a -> unit) -> 'a t -> unit (** [iter f s] applies [f] in turn to all elements of [s]. The elements of [s] are presented to [f] in increasing order with respect to the ordering over the type of the elements. *) val at_rank_exn: int -> 'a t -> 'a (** [at_rank_exn i s] returns element at rank [i] in [s], that is the [i]-th element in increasing order (the [0]-th element being the smallest element of [s]). @raise Not_found if [s = empty]. @raise Invalid_argument error_message if [i < 0 || i >= cardinal s] @since 2.4 *) (* under-specified; either give a 'b comparison, or keep ('a -> 'a) (preferred choice) *) val map: ('a -> 'b) -> 'a t -> 'b t (** [map f x] creates a new set with elements [f a0], [f a1]... [f aN], where [a0], [a1], ..., [aN] are the values contained in [x] The resulting map uses the polymorphic [compare] function to order elements. *) val map_endo: ('a -> 'a) -> 'a t -> 'a t (** [map f x] creates a new set with elements [f a0], [f a1]... [f aN], where [a0], [a1], ..., [aN] are the values contained in [x] The resulting map uses the same [compare] function to order elements as [m] does. If [f] returns physically equal values for all elements in [m] then the resulting map will be physically equal to [m]. @since 3.3.0 *) val filter: ('a -> bool) -> 'a t -> 'a t (** [filter p s] returns the set of all elements in [s] that satisfy predicate [p]. if [p] returns [true] for all elements then [s] is returned unmodified. @before 3.3.0 Physical equality was not ensured. *) (* as under-specified as 'map' *) val filter_map: ('a -> 'b option) -> 'a t -> 'b t (** [filter_map f m] combines the features of [filter] and [map]. It calls calls [f a0], [f a1], [f aN] where [a0,a1..an] are the elements of [m] and returns the set of pairs [bi] such as [f ai = Some bi] (when [f] returns [None], the corresponding element of [m] is discarded). The resulting map uses the polymorphic [compare] function to order elements. *) val filter_map_endo: ('a -> 'a option) -> 'a t -> 'a t (** [filter_map_endo f m] combines the features of [filter] and [map]. It calls calls [f a0], [f a1], [f aN] where [a0,a1..an] are the elements of [m] and returns the set of pairs [bi] such as [f ai = Some bi] (when [f] returns [None], the corresponding element of [m] is discarded). The resulting map uses the same [compare] function to order elements as used for [m]. if the filter function [f] returns [true] for all elements in [m], the resulting map is physically equal to [m]. @since 3.3.0 *) val fold: ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** [fold f s a] computes [(f xN ... (f x1 (f x0 a))...)], where [x0,x1..xN] are the elements of [s], in increasing order. *) val exists: ('a -> bool) -> 'a t -> bool (** [exists p s] checks if at least one element of the set satisfies the predicate [p]. *) val for_all : ('a -> bool) -> 'a t -> bool (** Returns whether the given predicate applies to all elements in the set *) val partition : ('a -> bool) -> 'a t -> 'a t * 'a t (** returns two disjoint subsets, those that satisfy the given predicate and those that don't *) val split : 'a -> 'a t -> 'a t * bool * 'a t (** [split x s] returns a triple [(l, present, r)], where [l] is the set of elements of [s] that are strictly less than [x]; [r] is the set of elements of [s] that are strictly greater than [x]; [present] is [false] if [s] contains no element equal to [x], or [true] if [s] contains an element equal to [x]. *) val split_opt: 'a -> 'a t -> 'a t * 'a option * 'a t (** [split_opt x s] returns a triple [(l, maybe_v, r)], where [l] is the set of elements of [s] that are strictly less than [x]; [r] is the set of elements of [s] that are strictly greater than [x]; [maybe_v] is [None] if [s] contains no element equal to [x], or [Some v] if [s] contains an element [v] that compares equal to [x]. *) val split_lt: 'a -> 'a t -> 'a t * 'a t (** [split_lt x s] returns a pair of sets [(l, r)], such that [l] is the subset of [s] with elements < [x]; [r] is the subset of [s] with elements >= [x]. *) val split_le: 'a -> 'a t -> 'a t * 'a t (** [split_le x s] returns a pair of sets [(l, r)], such that [l] is the subset of [s] with elements <= [x]; [r] is the subset of [s] with elements > [x]. *) val cardinal: 'a t -> int (** Return the number of elements of a set. *) val elements: 'a t -> 'a list (** Return the list of all elements of the given set. The returned list is sorted in increasing order with respect to the ordering of the given set. *) val to_list: 'a t -> 'a list (** Alias for [elements]. *) val to_array: 'a t -> 'a array (** Same as [to_list] but with an array instead of a list. @since 2.4 *) val min_elt : 'a t -> 'a (** returns the smallest element of the set. @raise Not_found if given an empty set. *) val min_elt_opt : 'a t -> 'a option (** Return [Some e] for the smallest element [e] of the given set (with respect to the [Ord.compare] ordering). Return None if the set is empty. @since 3.3.0 *) val pop_min: 'a t -> 'a * 'a t (** Returns the smallest element of the given set along with the rest of the set. Semantically equivalent and faster than [let mini = min_elt s in (mini, remove mini s)] @raise Not_found if the set is empty. @since 2.4 *) val pop_max: 'a t -> 'a * 'a t (** Returns the biggest element of the given set along with the rest of the set. Semantically equivalent and faster than [let maxi = max_elt s in (maxi, remove maxi s)] @raise Not_found if the set is empty. @since 2.4 *) val max_elt : 'a t -> 'a (** returns the largest element of the set. @raise Not_found if given an empty set.*) val max_elt_opt : 'a t -> 'a option (** Same as {!Set.S.min_elt_opt}, but for the largest element of the given set. @since 3.3.0 *) val choose : 'a t -> 'a (** returns an arbitrary (but deterministic) element of the given set. @raise Not_found if given an empty set. *) val choose_opt : 'a t -> 'a option (** Return [Some e] for one element [e] of the given set. Which element is chosen is unspecified, but equal elements will be chosen for equal sets. Return [None] if the set is empty. @since 3.3.0 *) val any: 'a t -> 'a (** Return one element of the given set. The difference with choose is that there is no guarantee that equals elements will be picked for equal sets. This merely returns the quickest element to get (O(1)). @raise Not_found if the set is empty. *) val pop : 'a t -> 'a * 'a t (** returns one element of the set and the set without that element. @raise Not_found if given an empty set *) val enum: 'a t -> 'a BatEnum.t (** Return an enumeration of all elements of the given set. The returned enumeration is sorted in increasing order with respect to the ordering of this set.*) val of_enum: ?cmp:('a -> 'a -> int) -> 'a BatEnum.t -> 'a t val of_enum_cmp: cmp:('a -> 'a -> int) -> 'a BatEnum.t -> 'a t val of_list: ?cmp:('a -> 'a -> int) -> 'a list -> 'a t (** builds a set from the given list, using the default comparison function *) val of_array: ?cmp:('a -> 'a -> int) -> 'a array -> 'a t (** builds a set from the given array and comparison function *) val to_seq : 'a t -> 'a BatSeq.t (** Iterate on the whole set, in ascending order. @since 3.3.0 *) val to_rev_seq : 'a t -> 'a BatSeq.t (** Iterate on the whole set, in descending order. @since 3.3.0 *) val to_seq_from : 'a -> 'a t -> 'a BatSeq.t (** [to_seq_from x s] iterates on a subset of the elements in [s], namely those greater or equal to [x], in ascending order. @since 3.3.0 *) val add_seq : 'a BatSeq.t -> 'a t -> 'a t (** add the given elements to the set, in order. @since 3.3.0 *) val of_seq : ?cmp:('a -> 'a -> int) -> 'a BatSeq.t -> 'a t (** build a set from the given elements @since 3.3.0 *) (** {6 Boilerplate code}*) (** {7 Printing}*) val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> 'c -> unit) -> 'a BatInnerIO.output -> 'c t -> unit (** get the comparison function used for a polymorphic map *) val get_cmp : 'a t -> ('a -> 'a -> int) end batteries-included-3.4.0/src/batSplay.mli000066400000000000000000000031501415601150500203330ustar00rootroot00000000000000(* * Splay -- splay trees * Copyright (C) 2011 Batteries Included Development Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Maps over ordered types based on splay trees. Splay trees are ordered binary trees that have the most recently used element as the root of the tree. If another element is accessed (even read-only), the tree will be rearranged internally. Not threadsafe; even read-only functions will rearrange the tree, even though its contents will remain unchanged. *) module Map (Ord : BatInterfaces.OrderedType) : sig include BatMap.S with type key = Ord.t val print_as_list: ('a BatInnerIO.output -> key -> unit) -> ('a BatInnerIO.output -> 'c -> unit) -> 'a BatInnerIO.output -> 'c t -> unit val of_list : (Ord.t * 'a) list -> 'a t val to_list : 'a t -> (Ord.t * 'a) list end batteries-included-3.4.0/src/batSplay.mlv000066400000000000000000000655271415601150500203700ustar00rootroot00000000000000(* * Splay -- splay trees * Copyright (C) 2011 Batteries Included Development Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module List = struct include List include BatList end module Enum = BatEnum type 'a bst = Empty | Node of 'a bst * 'a * 'a bst let size = let rec count tr k = match tr with | Empty -> k 0 | Node (l, _, r) -> count l (fun m -> count r (fun n -> k (1 + m + n))) in fun tr -> count tr (fun n -> n) let bst_append l r = let rec cat = function | Empty -> r | Node (l, x, r) -> Node (l, x, cat r) in cat l type 'a step = | Left of 'a * 'a bst | Right of 'a bst * 'a type 'a cursor = C of 'a step list * 'a bst let rec top' cx t = match cx with | [] -> t | (Left (p, pr) :: cx) -> top' cx (Node (t, p, pr)) | (Right (pl, p) :: cx) -> top' cx (Node (pl, p, t)) let top (C (cx, t)) = top' cx t let rec csplay' cx l r = match cx with | [] -> (l, r) | [Left (p, pr)] -> (l, Node (r, p, pr)) | [Right (pl, px)] -> (Node (pl, px, l), r) | (Left (px, pr) :: Left (ppx, ppr) :: cx) -> (* zig zig *) let r = Node (r, px, Node (pr, ppx, ppr)) in csplay' cx l r | (Left (px, pr) :: Right (ppl, ppx) :: cx) -> (* zig zag *) let l = Node (ppl, ppx, l) in let r = Node (r, px, pr) in csplay' cx l r | (Right (pl, px) :: Right (ppl, ppx) :: cx) -> (* zig zig *) let l = Node (Node (ppl, ppx, pl), px, l) in csplay' cx l r | (Right (pl, px) :: Left (ppx, ppr) :: cx) -> (* zig zag *) let l = Node (pl, px, l) in let r = Node (r, ppx, ppr) in csplay' cx l r let csplay = function | C (cx, Node (l, x, r)) -> let l', r' = csplay' cx l r in Node (l', x, r') | _ -> raise Not_found let rec cfind ?(cx=[]) ~sel = function | Empty -> C (cx, Empty) | Node (l, x, r) as node -> let sx = sel x in if sx = 0 then C (cx, node) else if sx < 0 then cfind ~cx:(Left (x, r) :: cx) ~sel l else cfind ~cx:(Right (l, x) :: cx) ~sel r (* A splay tree is a binary tree that is dynamically balanced: when a key is accessed, the tree is rebalanced (by an internal mutation) so that the next accesses to the same or neighbouring keys are very fast. Despite the use of a mutation for rebalancing, the structure is observably pure/persistent, as the mutation does not change the set of elements. *) module StrongRef : sig type + ##V>=4.12## ! 'a t val ref : 'a -> 'a t val get : 'a t -> 'a val set : 'a t -> 'a -> unit end = struct (* Didactic implementation note : why that ugly Obj.magic below? What does StrongRef bring compared to the usual ('a ref) type? We want splay tree to respect the Map interface, which whose map type is covariant (type (+'a) t). OCaml checks the internal definition to verify that the internal datatype is consistent with the variance annotation. Using a reference in the implementation of BatSplay would make the compiler reject the implementation, because reference types must be invariant. Following is an explanation of covariance and reference invariance, feel free to skip it if you already know. The idea of covariance for data structure is the following : if you have an ('a list), and a type 'b which is less specific than 'a (a subtype, eg. with OCaml polymorphic variants or object types), you can at any type pretend that your list is a ('b list): if all 'a can be used as 'b, then all ('a list) can be used as ('b list). # type a = < f1 : int; f2 : float >;; # type b = < f1 : int >;; # let t : a = object method f1 = 1 method f2 = 2. end;; val t : a = # (t :> b);; - : b = # ([t] :> b list);; - : b list = [] But this is not true for ('a list ref), or else I may locally consider it a ('b list) and mutate it to add an element of type 'b in it, then observe it at type ('a list ref) again. This is unsound because the added 'b element won't behave correctly as a 'a. # let tref = ref [t];; # (tref :> b list ref);; Error: Type a list ref is not a subtype of b list ref Type a = < f1 : int; f2 : float > is not compatible with type b = < f1 : int > The second object type has no method f2 Imagine I think I know better, and break the type safety. # let forced_tref = (Obj.magic tref : b list ref);; Then I can add a element of type b to the list : # forced_tref := object method f1 = 1 end :: !forced_tref;; But this is unsound as I can now look at tref again, at type (a list ref). # !tref;; - : a list = [; ] # (List.hd !tref)#f2;; Segmentation fault So in general, reference types cannot be safely subtyped (note that Java has had a blatant flaw in its type system for years, as mutable Arrays were covariant). If we used a `ref` in the internal definition of BatSplay.t, the typer would reject the module (the interface claims its covariant, while it's invariant). Said otherwise, covariance of a type (+'a t) allows situations where a single value may have several distinct types simultaneously: - the empty list [] is both an (int list) and a (float list) (distinct types here come from instantiations of the polymorphic 'a list, generalized by the (relaxed) value restrict) - if a is a subtype of b, then all (a list) (even non-empty) are simultaneously of type (b list) Mutating such values is unsound in the general case, if the result of the mutation is a value that is not valid for some of those simultaneous types (adding a float in a ('a list ref) makes it invalid as an (int list ref)). In our case however, the mutations that actually happen (that are confined in the internal implementation of BatSplay) are soundly compatible with subtyping or polymorphic instantiation. Indeed, rebalancing never adds any element to the splay tree, it only reorders the element that were already there. In particular, sharing values between two different types (either through subtyping (cast) or polymorphic instantiation (relaxed value restriction)) is correct even if mutations happens on those shared value.. However, we must be careful to ensure that all rebalancings keep the set of elements of the splay tree unchanged (dropping elements would be ok-ish, but adding new elements would be unsound). We use the dirty Obj magic to create a type of "strong references" that are mutable yet covariant. Note that the mutations are confined to the "top" of the structure, the balanced tree itself is purely functional. Note that we must be careful (in the internal implementation) to allocate a new strong reference (with StrongRef.ref) each time we want to build a tree with a different set of elements than the one we started with. PS : No list reference were harmed during the implementation of this module. *) type 'a t = { ref : 'a } type 'a mut = { mutable mut_ref : 'a } let ref (x : 'a) = (Obj.magic { mut_ref = x } : 'a t) let get r = r.ref let set (r : 'a t) v = (Obj.magic r : 'a mut).mut_ref <- v end module Map (Ord : BatInterfaces.OrderedType) = struct (*$inject module TestMap = Splay.Map (Int) *) (*$< TestMap *) type key = Ord.t type 'a map = (key * 'a) bst type 'a t = 'a map StrongRef.t let sget = StrongRef.get let sref = StrongRef.ref let empty = sref Empty let is_empty m = let tr = sget m in tr = Empty (* let kcmp (j, _) (k, _) = Ord.compare j k*) let ksel j (k, _) = Ord.compare j k let singleton' k v = Node (Empty, (k, v), Empty) let singleton k v = sref (singleton' k v) let add k v tr = let tr = sget tr in sref begin csplay begin match cfind ~sel:(ksel k) tr with | C (cx, Node (l, (k, _), r)) -> C (cx, Node (l, (k, v), r)) | C (cx, Empty) -> C (cx, singleton' k v) end end let modify k fn tr = let tr = sget tr in sref begin csplay begin match cfind ~sel:(ksel k) tr with | C (cx, Node (l, (k, v), r)) -> C (cx, Node (l, (k, fn v), r)) | C (_cx, Empty) -> raise Not_found end end let modify_def def k fn tr = let tr = sget tr in sref begin csplay begin match cfind ~sel:(ksel k) tr with | C (cx, Node (l, (k, v), r)) -> C (cx, Node (l, (k, fn v), r)) | C (cx, Empty) -> C (cx, singleton' k (fn def)) end end let modify_opt k fn tr = let tr = sget tr in sref begin try match cfind ~sel:(ksel k) tr with | C (cx, Node (l, (k, v), r)) -> begin match fn (Some v) with | Some v' -> csplay (C (cx, Node (l, (k, v'), r))) | None -> bst_append l r end | C (cx, Empty) -> match fn None with | Some v -> csplay (C (cx, singleton' k v)) | None -> raise Exit with Exit -> tr end let rebalance m tr = StrongRef.set m tr let find k m = let tr = sget m in let tr = csplay (cfind ~sel:(ksel k) tr) in match tr with | Node (_, (_, v), _) -> rebalance m tr; v | _ -> raise Not_found let find_opt k m = try Some (find k m) with Not_found -> None let find_default def k m = try find k m with Not_found -> def let rec find_first_helper_found f kv map = function | Node (l, (k, v), r) -> if f k then find_first_helper_found f (k, v) map l else find_first_helper_found f kv map r | Empty -> (* dummy find to rebalance the tree *) ignore(find (fst kv) map); kv let find_first f (map : 'a t) = let rec loop_notfound f = function | Node(l, (k, v), r) -> if f k then find_first_helper_found f (k, v) map l else loop_notfound f r | Empty -> raise Not_found in loop_notfound f (sget map) let find_first_opt f map = let rec loop_notfound f = function | Node(l, (k, v), r) -> if f k then Some (find_first_helper_found f (k, v) map l) else loop_notfound f r | Empty -> None in loop_notfound f (sget map) let rec find_last_helper_found f kv map = function | Node (l, (k, v), r) -> if f k then find_last_helper_found f (k, v) map r else find_last_helper_found f kv map l | Empty -> (* dummy find to rebalance the tree *) ignore(find (fst kv) map); kv let find_last f (map : 'a t) = let rec loop_notfound f = function | Node(l, (k, v), r) -> if f k then find_last_helper_found f (k, v) map r else loop_notfound f l | Empty -> raise Not_found in loop_notfound f (sget map) let find_last_opt f map = let rec loop_notfound f = function | Node(l, (k, v), r) -> if f k then Some (find_last_helper_found f (k, v) map r) else loop_notfound f l | Empty -> None in loop_notfound f (sget map) (*$T find_first (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first (fun x -> x >= 0)) = ((1, 11)) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first (fun x -> x >= 1)) = ((1, 11)) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first (fun x -> x >= 2)) = ((2, 12)) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first (fun x -> x >= 3)) = ((3, 13)) try ignore(empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first (fun x -> x >= 4)); false with Not_found -> true try ignore(empty |> find_first (fun x -> x >= 3)); false with Not_found -> true *) (*$T find_first_opt (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first_opt (fun x -> x >= 0)) = (Some (1, 11)) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first_opt (fun x -> x >= 1)) = (Some (1, 11)) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first_opt (fun x -> x >= 2)) = (Some (2, 12)) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first_opt (fun x -> x >= 3)) = (Some (3, 13)) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_first_opt (fun x -> x >= 4)) = (None) (empty |> find_first_opt (fun x -> x >= 3)) = (None) *) (*$T find_last (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last (fun x -> x <= 1)) = (1, 11) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last (fun x -> x <= 2)) = (2, 12) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last (fun x -> x <= 3)) = (3, 13) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last (fun x -> x <= 4)) = (3, 13) try ignore(empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last (fun x -> x <= 0)); false with Not_found -> true try ignore(empty |> find_last (fun x -> x <= 3)); false with Not_found -> true *) (*$T find_last_opt (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last_opt (fun x -> x <= 0)) = None (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last_opt (fun x -> x <= 1)) = Some (1, 11) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last_opt (fun x -> x <= 2)) = Some (2, 12) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last_opt (fun x -> x <= 3)) = Some (3, 13) (empty |> add 1 11 |> add 2 12 |> add 3 13 |> find_last_opt (fun x -> x <= 4)) = Some (3, 13) (empty |> find_last_opt (fun x -> x <= 3)) = None *) let cchange fn (C (cx, t)) = C (cx, fn t) let remove k tr = let tr = sget tr in let replace = function | Empty -> Empty | Node (l, _, r) -> bst_append l r in let tr = top (cchange replace (cfind ~sel:(ksel k) tr)) in sref tr let remove_exn k tr = let tr = sget tr in let replace = function | Empty -> raise Not_found | Node (l, _, r) -> bst_append l r in let tr = top (cchange replace (cfind ~sel:(ksel k) tr)) in sref tr (*$T remove_exn try remove_exn 1 empty |> ignore ; false with Not_found -> true *) let update k1 k2 v2 tr = if Ord.compare k1 k2 <> 0 then add k2 v2 (remove k1 tr) else let tr = sget tr in sref begin csplay begin match cfind ~sel:(ksel k1) tr with | C (cx, Node (l, _kv, r)) -> C (cx, Node (l, (k2, v2), r)) | C (_cx, Empty) -> raise Not_found end end let update_stdlib k f m = match f (find_opt k m) with | Some x -> add k x m | None -> remove k m let mem k m = try ignore (find k m) ; true with Not_found -> false let iter fn tr = let tr = sget tr in let rec visit = function | Empty -> () | Node (l, (k, v), r) -> visit l ; fn k v ; visit r in visit tr let fold fn tr acc = let tr = sget tr in let rec visit acc = function | Empty -> acc | Node (l, (k, v), r) -> let acc = visit acc l in let acc = fn k v acc in visit acc r in visit acc tr let min_binding tr = let tr = sget tr in let rec bfind = function | Node (Empty, kv, _) -> kv | Node (l, _, _) -> bfind l | Empty -> raise Not_found in bfind tr let min_binding_opt tr = let tr = sget tr in let rec bfind = function | Node (Empty, kv, _) -> Some kv | Node (l, _, _) -> bfind l | Empty -> None in bfind tr let choose = min_binding (*$= choose (empty |> add 0 1 |> add 1 1 |> choose) \ (empty |> add 1 1 |> add 0 1 |> choose) *) (*$T choose try ignore (choose empty) ; false with Not_found -> true *) let choose_opt = min_binding_opt let any tr = match sget tr with | Empty -> raise Not_found | Node (_, kv, _) -> kv (*$T any try ignore (any empty) ; false with Not_found -> true *) let pop_min_binding tr = let mini = ref (choose tr) in let rec bfind = function | Node (Empty, kv, r) -> mini := kv; r | Node (l, kv, r) -> Node (bfind l, kv, r) | Empty -> assert(false) (* choose already raises Not_found on empty map *) in (!mini, sref (bfind (sget tr))) let max_binding tr = let tr = sget tr in let rec bfind = function | Node (_, kv, Empty) -> kv | Node (_, _, r) -> bfind r | Empty -> raise Not_found in bfind tr let max_binding_opt tr = let tr = sget tr in let rec bfind = function | Node (_, kv, Empty) -> Some kv | Node (_, _, r) -> bfind r | Empty -> None in bfind tr let pop_max_binding tr = let maxi = ref (choose tr) in let rec bfind = function | Node (l, kv, Empty) -> maxi := kv; l | Node (l, kv, r) -> Node (l, kv, bfind r) | Empty -> assert(false) (* choose already raises Not_found on empty map *) in (!maxi, sref (bfind (sget tr))) let filter_map (f : key -> 'a -> 'b option) : 'a t -> 'b t = let rec visit t cont = match t with | Empty -> cont Empty | Node (l, (k, v), r) -> visit l begin fun l -> let w = f k v in visit r begin fun r -> match w with | None -> cont (bst_append l r) | Some w -> cont (Node (l, (k, w), r)) end end in fun m -> visit (sget m) sref let filterv f t = filter_map (fun _ v -> if f v then Some v else None) t let filter f t = filter_map (fun k v -> if f k v then Some v else None) t let map f t = filter_map (fun _ v -> Some (f v)) t let mapi f t = filter_map (fun k v -> Some (f k v)) t let partition (p : key -> 'a -> bool) : 'a t -> 'a t * 'a t = let rec visit t cont = match t with | Empty -> cont Empty Empty | Node (l, ((k, v) as kv), r) -> visit l begin fun l1 l2 -> let b = p k v in visit r begin fun r1 r2 -> if b then cont (Node (l1, kv, r1)) (bst_append l2 r2) else cont (bst_append l1 r1) (Node (l2, kv, r2)) end end in fun m -> visit (sget m) (fun t1 t2 -> sref t1, sref t2) type 'a enumeration = | End | More of key * 'a * (key * 'a) bst * 'a enumeration let count_enum = let rec count k = function | End -> k | More (_, _, tr, en) -> count (1 + k + size tr) en in fun en -> count 0 en let rec cons_enum m e = match m with | Empty -> e | Node (l, (k, v), r) -> cons_enum l (More (k, v, r, e)) let rec rev_cons_enum m e = match m with | Empty -> e | Node (l, (k, v), r) -> rev_cons_enum r (More (k, v, l, e)) let rec cons_enum_from k2 m e = match m with | Empty -> e | Node (l, (k, v), r) -> if Ord.compare k2 k <= 0 then cons_enum_from k2 l (More (k, v, r, e)) else cons_enum_from k2 r e let compare cmp tr1 tr2 = let tr1, tr2 = sget tr1, sget tr2 in let rec aux e1 e2 = match (e1, e2) with | (End, End) -> 0 | (End, _) -> -1 | (_, End) -> 1 | (More (v1, d1, r1, e1), More (v2, d2, r2, e2)) -> let c = Ord.compare v1 v2 in if c <> 0 then c else let c = cmp d1 d2 in if c <> 0 then c else aux (cons_enum r1 e1) (cons_enum r2 e2) in aux (cons_enum tr1 End) (cons_enum tr2 End) let equal cmp tr1 tr2 = let tr1, tr2 = sget tr1, sget tr2 in let rec aux e1 e2 = match (e1, e2) with (End, End) -> true | (End, _) -> false | (_, End) -> false | (More (v1, d1, r1, e1), More (v2, d2, r2, e2)) -> Ord.compare v1 v2 = 0 && cmp d1 d2 && aux (cons_enum r1 e1) (cons_enum r2 e2) in aux (cons_enum tr1 End) (cons_enum tr2 End) let rec enum_bst cfn en = let cur = ref en in let next () = match !cur with | End -> raise Enum.No_more_elements | More (k, v, r, e) -> cur := cfn r e ; (k, v) in let count () = count_enum !cur in let clone () = enum_bst cfn !cur in Enum.make ~next ~count ~clone let enum tr = enum_bst cons_enum (cons_enum (sget tr) End) let backwards tr = enum_bst rev_cons_enum (rev_cons_enum (sget tr) End) let keys m = Enum.map fst (enum m) let values m = Enum.map snd (enum m) let of_enum e = Enum.fold begin fun acc (k, v) -> add k v acc end empty e let to_list m = List.of_enum (enum m) let of_list l = of_enum (List.enum l) let custom_print ~first ~last ~sep kvpr out m = Enum.print ~first ~last ~sep (fun out (k, v) -> kvpr out k v) out (enum m) let print ?(first="{\n") ?(last="}\n") ?(sep=",\n") ?(kvsep=": ") kpr vpr out m = custom_print ~first ~last ~sep (fun out k v -> BatPrintf.fprintf out "%a%s%a" kpr k kvsep vpr v) out m let print_as_list kpr vpr out m = print ~first:"[" ~last:"]" ~sep:"; " ~kvsep:", " kpr vpr out m module Labels = struct let add ~key ~data t = add key data t let iter ~f t = iter (fun key data -> f ~key ~data) t let map ~f t = map f t let mapi ~f t = mapi (fun key data -> f ~key ~data) t let fold ~f t ~init = fold (fun key data acc -> f ~key ~data acc) t init let compare ~cmp a b = compare cmp a b let equal ~cmp a b = equal cmp a b let filterv ~f = filterv f let filter ~f = filter f end module Exceptionless = struct let find k m = find_opt k m let choose m = try Some (choose m) with Not_found -> None let any m = try Some (any m) with Not_found -> None end module Infix = struct let ( --> ) m k = find k m let ( <-- ) m (k, v) = add k v m end let bindings m = List.of_enum (enum m) let exist_bool b f m = try iter (fun k v -> if f k v = b then raise Exit) m; false with Exit -> true let exists f m = exist_bool true f m let for_all f m = not (exist_bool false f m) let cardinal m = fold (fun _k _v -> succ) m 0 let split k m = let tr = sget m in let C (cx, center) = cfind ~sel:(ksel k) tr in match center with | Empty -> let l, r = csplay' cx Empty Empty in (sref l, None, sref r) | Node (l, x, r) -> let l', r' = csplay' cx l r in (* we rebalance as in 'find' *) rebalance m (Node (l', x, r')); (sref l', Some (snd x), sref r') let merge f m1 m2 = (* The implementation is a bit long, but has the important property of applying `f` in increasing key order. *) (* we will iterate on both enumerations in increasing order simultaneously *) let e1 = enum m1 in let e2 = enum m2 in (* we will push the results in increasing order from left to right; the result will be very unbalanced, but this will be corrected by the rebalancing at the first lookup in the splay tree. *) let maybe_push acc k maybe_v1 maybe_v2 = match f k maybe_v1 maybe_v2 with | None -> acc | Some v -> Node (acc, (k, v), Empty) in let push1 acc (k, v1) = maybe_push acc k (Some v1) None in let push2 acc (k, v2) = maybe_push acc k None (Some v2) in (* we iterate simultaneously on both inputs, in increasing order of keys. There are four different "states" to consider : - we have no idea of the inputs : none_known - we know the next (key, value) pair of e1, and that e2 is empty : only_e1 (k1, v1) - we know the next (key, value) pair of e2, and that e1 is empty : only_e2 (k2, v2) - we know the next (key, value) pair of both e1 and e2 : both_known (k1, v1) (k2, v2) *) let rec none_known acc = match Enum.peek e1, Enum.peek e2 with | None, None -> acc | None, Some kv2 -> Enum.junk e2; only_e2 acc kv2 | Some kv1, None -> Enum.junk e1; only_e1 acc kv1 | Some kv1, Some kv2 -> Enum.junk e1; Enum.junk e2; both_known acc kv1 kv2 and only_e1 acc kv1 = Enum.fold push1 (push1 acc kv1) e1 and only_e2 acc kv2 = Enum.fold push2 (push2 acc kv2) e2 and both_known acc ((k1, v1) as kv1) ((k2, v2) as kv2) = let cmp = Ord.compare k1 k2 in if cmp < 0 then begin let acc = push1 acc kv1 in match Enum.peek e1 with | None -> only_e2 acc kv2 | Some kv1' -> Enum.junk e1; both_known acc kv1' kv2 end else if cmp > 0 then begin let acc = push2 acc kv2 in match Enum.peek e2 with | None -> only_e1 acc kv1 | Some kv2' -> Enum.junk e2; both_known acc kv1 kv2' end else begin let acc = maybe_push acc k1 (Some v1) (Some v2) in none_known acc end in sref (none_known Empty) let pop m = match sget m with | Empty -> raise Not_found | Node (l, kv, r) -> kv, sref (bst_append l r) let add_seq s m = BatSeq.fold_left (fun m (k, v) -> add k v m) m s let of_seq s = add_seq s empty let rec seq_of_iter m () = match m with | End -> BatSeq.Nil | More(k, v, r, e) -> BatSeq.Cons ((k, v), seq_of_iter (cons_enum r e)) let to_seq m = seq_of_iter (cons_enum (sget m) End) let to_rev_seq m = seq_of_iter (rev_cons_enum (sget m) End) let to_seq_from k m = seq_of_iter (cons_enum_from k (sget m) End) let union f m1 m2 = fold (fun k v m -> match find_opt k m with | Some v1 -> (match f k v v1 with | Some vmerged -> add k vmerged m | None -> remove k m) | None -> add k v m) m1 m2 let extract k tr = let tr = sget tr in (* the reference here is a tad ugly but allows to reuse `cfind` without fuss *) let maybe_v = ref None in let replace = function | Empty -> Empty | Node (l, (_, v), r) -> maybe_v := Some v; bst_append l r in let tr = top (cchange replace (cfind ~sel:(ksel k) tr)) in (* like in the `remove` case, we don't bother rebalancing *) match !maybe_v with | None -> raise Not_found | Some v -> v, sref tr (*$>*) end batteries-included-3.4.0/src/batStack.ml000066400000000000000000000043661415601150500201510ustar00rootroot00000000000000(* * BatQueue - Extended operations on queues * Copyright (C) 1996 Xavier Leroy * 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) include Stack type 'a enumerable = 'a Stack.t let of_enum e = let s = create () in BatEnum.iter (fun x -> push x s) e; s (*$T of_enum let s = create () in push 3 s; push 5 s; [3;5] |> List.enum |> of_enum = s let s = create () in of_enum (BatEnum.empty ()) = s *) (* Consumes input stack *) let enum_destruct s = let get () = try pop s with Stack.Empty -> raise BatEnum.No_more_elements in BatEnum.from get (*$T enum_destruct let s = of_enum (List.enum [2;4;6;8]) in \ enum_destruct s |> List.of_enum = [8;6;4;2] && is_empty s *) (* consumes a copy *) let enum s = enum_destruct (copy s) let print ?(first="") ?(last="") ?(sep="") print_a out t = BatEnum.print ~first ~last ~sep print_a out (enum t) (*$T print IO.to_string (print Int.print) (of_enum (List.enum [2;4;6;8])) = "8642" *) let compare cmp a b = BatEnum.compare cmp (enum a) (enum b) let equal eq a b = BatEnum.equal eq (enum a) (enum b) (*$T equal not (equal Int.equal (create()) (of_enum (List.enum [2]))) equal Int.equal (create()) (create()) equal Int.equal (of_enum (List.enum [2])) (of_enum (List.enum [2])) *) (*$T compare 0 <> (compare Int.compare (create()) (of_enum (List.enum [2]))) *) module Exceptionless = struct let top s = try Some (top s) with Empty -> None let pop s = try Some (pop s) with Empty -> None end batteries-included-3.4.0/src/batStack.mli000066400000000000000000000071751415601150500203230ustar00rootroot00000000000000(* * BatQueue - Extended operations on queues * Copyright (C) 1996 Xavier Leroy * 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Last-in first-out stacks. This module implements stacks (LIFOs), with in-place modification. @author Xavier Leroy (Base module) @author David Teller *) type 'a t = 'a Stack.t (** The type of stacks containing elements of type ['a]. *) exception Empty (** Raised when {!Stack.pop} or {!Stack.top} is applied to an empty stack. *) val create : unit -> 'a t (** Return a new stack, initially empty. *) val push : 'a -> 'a t -> unit (** [push x s] adds the element [x] at the top of stack [s]. *) val pop : 'a t -> 'a (** [pop s] removes and returns the topmost element in stack [s], or @raise Empty if the stack is empty. *) val top : 'a t -> 'a (** [top s] returns the topmost element in stack [s], or @raise Empty if the stack is empty. *) val clear : 'a t -> unit (** Discard all elements from a stack. *) val copy : 'a t -> 'a t (** Return a copy of the given stack. *) val is_empty : 'a t -> bool (** Return [true] if the given stack is empty, [false] otherwise. *) val length : 'a t -> int (** Return the number of elements in a stack. *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f s] applies [f] in turn to all elements of [s], from the element at the top of the stack to the element at the bottom of the stack. The stack itself is unchanged. *) include BatEnum.Enumerable with type 'a enumerable = 'a t val enum : 'a t -> 'a BatEnum.t (** [enum s] returns an enumeration of the elements of stack [s], from the most recently entered to the least recently entered. This enumeration is made on a copy of the input stack, and reading from it will not affect [s]. *) val enum_destruct : 'a t -> 'a BatEnum.t (** [enum_destruct s] returns a destructive enumeration of the elements of stack [s], from the most recently entered to the least recently entered. Reading the enumeration will progressively empty [s].*) val of_enum : 'a BatEnum.t -> 'a t (** [of_enum e] returns a new stack containing all the elements of [e]. This is equivalent to calling [push] with the first element of the enumeration, then with the second, etc. Note: if [s] is a stack, [s <> of_enum (enum s)], as [of_enum] reverses the input order. *) (** {6 Boilerplate code}*) (** {7 Printing}*) (* Prints the contents of the given stack *) val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> 'b t -> unit (* Comparison and equality tests can be constructed based on a comparison or equality function for elements. *) val compare : 'a BatOrd.comp -> 'a t BatOrd.comp val equal : 'a BatOrd.eq -> 'a t BatOrd.eq module Exceptionless : sig val top : 'a t -> 'a option val pop : 'a t -> 'a option end batteries-included-3.4.0/src/batStream.mli000066400000000000000000000305521415601150500205040ustar00rootroot00000000000000(* * Stream - streams and stream parsers * Copyright (C) 1997 Daniel de Rauglaudre * 2007 Zheng Li * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Streams and stream parsers Streams are a read-and-forget data structure, comparable to enumerations. In Batteries Included, streams are deprecated in favor of enumerations, defined in module {!BatEnum}. {b Note} This module is provided essentially for backwards-compatibility. If you feel like using [Stream.t], please take a look at [BatEnum] or [LazyList]. This module is based on {{:http://www.pps.jussieu.fr/~li/software/sdflow/}Zheng Li's SDFlow} This module replaces Stdlib's {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Stream.html}Stream} module. @author Zheng Li (SDFlow) @author David Teller @documents Stream *) type 'a t = 'a Stream.t include BatEnum.Enumerable with type 'a enumerable = 'a t include BatInterfaces.Mappable with type 'a mappable = 'a t (** The type of streams holding values of type ['a]. *) exception Failure (** Raised by parsers when none of the first components of the stream patterns is accepted. *) exception Error of string (** Raised by parsers when the first component of a stream pattern is accepted, but one of the following components is rejected. *) (** {6 Stream builders} *) val from : (int -> 'a option) -> 'a t (** [Stream.from f] returns a stream built from the function [f]. To create a new stream element, the function [f] is called with the current stream count. The user function [f] must return either [Some ] for a value or [None] to specify the end of the stream. *) val of_list : 'a list -> 'a t (** Return the stream holding the elements of the list in the same order. *) val of_string : string -> char t (** Return the stream of the characters of the string parameter. *) val of_bytes : Bytes.t -> char t (** Return the stream of the characters of the bytes parameter. @since 2.3.0 *) val of_channel : in_channel -> char t (** Return the stream of the characters read from the input channel. *) (** {6 Other Stream builders} Warning: these functions create streams with fast access; it is illegal to mix them with streams built with [[< >]]; would raise [Failure] when accessing such mixed streams. *) val of_fun : (unit -> 'a) -> 'a t (** [Stream.of_fun f] returns a stream built from the function [f]. To create a new stream element, the function [f] is called with the current stream count. The user function [f] must return either [Some ] for a value or [None] to specify the end of the stream. *) (** {6 Stream iterator} *) val iter : ('a -> unit) -> 'a t -> unit (** [Stream.iter f s] scans the whole stream s, applying function [f] in turn to each stream element encountered. *) val foldl : ('a -> 'b -> 'a * bool option) -> 'a -> 'b t -> 'a (** [foldl f init stream] is a lazy fold_left. [f accu elt] should return [(new_accu, state)] where [new_accu] is normal accumulation result, and [state] is a flag representing whether the computation should continue and whether the last operation is valid: [None] means continue, [Some b] means stop where [b = true] means the last addition is still valid and [b = false] means the last addition is invalid and should be revert. *) val foldr : ('a -> 'b lazy_t -> 'b) -> 'b -> 'a t -> 'b (** [foldr f init stream] is a lazy fold_right. Unlike the normal fold_right, the accumulation parameter of [f elt accu] is lazy, hence it can decide not to force the evaluation of [accu] if the current element [elt] can determine the result by itself. *) val fold : ('a -> 'a -> 'a * bool option) -> 'a t -> 'a (** [fold] is [foldl] without initialization value, where the first element of stream is taken as [init]. It raises [End_of_stream] exception when the input stream is empty. *) val filter : ('a -> bool) -> 'a t -> 'a t (** [filter test stream] picks all the elements satisfying [test] from [stream] and return the results in the same order as a stream. *) (** {6 Predefined parsers} *) val next : 'a t -> 'a (** Return the first element of the stream and remove it from the stream. @raise Stream.Failure if the stream is empty. *) val empty : 'a t -> unit (** Return [()] if the stream is empty, else raise [Stream.Failure]. *) (** {6 Useful functions} *) val peek : 'a t -> 'a option (** Return [Some] of "the first element" of the stream, or [None] if the stream is empty. *) val junk : 'a t -> unit (** Remove the first element of the stream, possibly unfreezing it before. *) val count : 'a t -> int (** Return the current count of the stream elements, i.e. the number of the stream elements discarded. *) val npeek : int -> 'a t -> 'a list (** [npeek n] returns the list of the [n] first elements of the stream, or all its remaining elements if less than [n] elements are available. *) (** {6 Conversion functions} *) val enum : 'a t -> 'a BatEnum.t (** Convert a stream to an enumeration. Reading the resulting enumeration will consume elements from the stream. This is the preferred manner of converting from a stream to any other data structure.*) val of_enum : 'a BatEnum.t -> 'a t (** Convert an enumeration to a stream. Reading the resulting stream will consume elements from the enumeration. This is the preferred manner of creating a stream.*) val of_input : BatIO.input -> char t (** Convert an [input] to a stream.*) val to_list : 'a t -> 'a list (** Convert a stream to a list *) val to_string : char t -> string (** convert stream of chars to string, using buffer *) val to_string_fmt : ('a -> string, unit, string) format -> 'a t -> string (** convert stream to string, using Printf with given format *) val to_string_fun : ('a -> string) -> 'a t -> string (** convert stream to string, using given conversion function *) (** {6 Stream consumers} *) val on_output: 'a BatIO.output-> char t -> unit (** Convert an [output] to a stream.*) (** {6 Computation over stream} All the functions in this part are lazy. *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f stream] applies [f] in turn to elements from [stream] and return the results as a stream in the same order. *) val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t (** [map2 f streama streamb] applies [f] in turn to elements of corresponding positions from [streama] and [streamb]. The results are constructed in the same order as a stream. If one stream is short, excess elements of the longer stream are ignored. *) val scanl : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a t (** [scanl f init stream] returns a stream of successive reduced values from the left: [scanl f init [< 'e0; 'e1; ... >]] is equivalent to [[< 'init; '(f init e0); '(f (f init e0) e1); ... >]] *) val scan : ('a -> 'a -> 'a) -> 'a t -> 'a t (** [scan] is similar to [scanl] but without the [init] value: [scanl f init [< 'e0; 'e1; 'e2; ... >]] is equivalent to [[< 'e0; '(f e0 e1); '(f (f e0 e1) e2); ... >]] *) val concat : 'a t t -> 'a t (** concatenate a stream of streams *) val concat_map : ('a -> 'b t) -> 'a t -> 'b t (** Composition of {!concat} and {!map}. [concat_map f e] is the same as [concat (map f e)]. @since 2.3.0 *) val take : int -> 'a t -> 'a t (** [take n stream] returns the prefix of [stream] of length [n], or [stream] itself if [n] is greater than the length of [stream] *) val drop : int -> 'a t -> 'a t (** [drop n stream] returns the suffix of [stream] after the first [n] elements, or a empty stream if [n] is greater than the length of [stream] *) val take_while : ('a -> bool) -> 'a t -> 'a t (** [take_while test stream] returns the longest (possibly empty) prefix of [stream] of elements that satisfy [test]. *) val drop_while : ('a -> bool) -> 'a t -> 'a t (** [drop_while test stream] returns the remaining suffix of [take_while test stream]. *) (** {6 Streams pair arithmetic} All the functions in this part are lazy. *) val dup : 'a t -> 'a t * 'a t (** [dup stream] returns a pair of streams which are identical to [stream]. Note that stream is a destructive data structure, the point of [dup] is to return two streams can be used independently. NOT IMPLEMENTED CORRECTLY - WILL RAISE Failure UNTIL CORRECT IMPLEMENTATION FOUND *) val comb : 'a t * 'b t -> ('a * 'b) t (** [comb] transform a pair of stream into a stream of pairs of corresponding elements. If one stream is short, excess elements of the longer stream are ignored. *) val split : ('a * 'b) t -> 'a t * 'b t (** [split] is the opposite of [comb] *) val merge : (bool -> 'a -> bool) -> 'a t * 'a t -> 'a t (** [merge test (streama, streamb)] merge the elements from [streama] and [streamb] into a single stream. The [bool] type here represents the id of the two input streams where [true] is the first and [false] represents the second. The [test] function is applied to each element of the output stream together with the id of the input stream from which it was extracted, to decide which stream should the next element come from. The first element is always taken from [streama]. When a stream runs out of elements, the merge process will continue to take elements from the other stream until both streams reach their ends. *) val switch : ('a -> bool) -> 'a t -> 'a t * 'a t (** [switch test stream] split [stream] into two streams, where the first stream have all the elements satisfying [test], the second stream is opposite. The order of elements in the source stream is preserved. *) (** {6 Stream arithmetic} All the functions in this part are lazy.*) val cons : 'a -> 'a t -> 'a t (** [cons x stream] equals [[<'x; stream>]]. *) val apnd : 'a t -> 'a t -> 'a t (** [apnd fla flb] equals [[]]. *) val is_empty : 'a t -> bool (** [is_empty stream] tests whether [stream] is empty. But note that it forces the evaluation of the head element if any. *) (** {6 Predefined parsers} *) val next : 'a t -> 'a (** Return the first element of the stream and remove it from the stream. @raise Stream.Failure if the stream is empty. *) module StreamLabels : sig (** {b Note} This module is provided essentially for backwards-compatibility. If you feel like using [Stream.t], please take a look at [BatEnum] or [LazyList] and [GenParser]. See the complete [Stream] module for the function documentations. *) val iter : f:('a -> unit) -> 'a t -> unit val to_string_fmt : fmt:('a -> string, unit, string) format -> 'a t -> string val to_string_fun : fn:('a -> string) -> 'a t -> string val foldl : f:('a -> 'b -> 'a * bool option) -> init:'a -> 'b t -> 'a val foldr : f:('a -> 'b lazy_t -> 'b) -> init:'b -> 'a t -> 'b val fold : f:('a -> 'a -> 'a * bool option) -> init:'a t -> 'a val filter : f:('a -> bool) -> 'a t -> 'a t val map : f:('a -> 'b) -> 'a t -> 'b t val map2 : f:('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t val scanl : f:('a -> 'b -> 'a) -> 'a -> 'b t -> 'a t val scan : f:('a -> 'a -> 'a) -> 'a t -> 'a t val take_while : f:('a -> bool) -> 'a t -> 'a t val drop_while : f:('a -> bool) -> 'a t -> 'a t val merge : f:(bool -> 'a -> bool) -> 'a t * 'a t -> 'a t val switch : f:('a -> bool) -> 'a t -> 'a t * 'a t end (**/**) (* The following is for system use only. Do not call directly. *) val iapp : 'a t -> 'a t -> 'a t val icons : 'a -> 'a t -> 'a t val ising : 'a -> 'a t val lapp : (unit -> 'a t) -> 'a t -> 'a t val lcons : (unit -> 'a) -> 'a t -> 'a t val lsing : (unit -> 'a) -> 'a t val sempty : 'a t val slazy : (unit -> 'a t) -> 'a t val dump : ('a -> unit) -> 'a t -> unit (**/**) batteries-included-3.4.0/src/batStream.mlv000066400000000000000000000407061415601150500205230ustar00rootroot00000000000000(* * Stream - streams and stream parsers * Copyright (C) 1997 Daniel de Rauglaudre * 2007 Zheng Li * 2008 David Teller * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) include Stream type 'a enumerable = 'a t type 'a mappable = 'a t exception End_of_flow = Failure let ( |> ) x f = f x let ( |- ) f g x = g (f x) let ( // ) f g (x, y) = ((f x), (g y)) let curry f x y = f (x, y) let uncurry f (x, y) = f x y let id x = x let rec of_fun f = Stream.slazy (fun _ -> try let h = f () in Stream.icons h (Stream.slazy (fun _ -> of_fun f)) with | End_of_flow -> Stream.sempty) let to_fun fl () = next fl let to_list fl = let buf = ref [] in iter (fun x -> buf := x :: !buf) fl; List.rev !buf let to_string fl = let buf = Buffer.create 16 in iter (Buffer.add_char buf) fl; Buffer.contents buf let to_string_fmt fmt fl = let buf = Buffer.create 16 in Stream.iter (fun it -> Buffer.add_string buf (Printf.sprintf fmt it)) fl; Buffer.contents buf let to_string_fun fn fl = let buf = Buffer.create 16 in Stream.iter (fun it -> Buffer.add_string buf (fn it)) fl; Buffer.contents buf (*UNUSED let on_channel ch = iter (output_char ch) *) let on_output o = iter (BatIO.write o) let rec of_input i = Stream.slazy (fun _ -> try let h = BatIO.read i in Stream.icons h (Stream.slazy (fun _ -> of_input i)) with | BatIO.No_more_input -> Stream.sempty) let rec cycle times x = match times with | None -> Stream.iapp x (Stream.slazy (fun _ -> cycle None x)) | Some 1 -> x | (* in case of destriction *) Some n when n <= 0 -> Stream.sempty | Some n -> Stream.iapp x (Stream.slazy (fun _ -> cycle (Some (n - 1)) x)) let repeat times x = cycle times (Stream.ising x) let rec seq init step cont = if cont init then Stream.icons init (Stream.slazy (fun _ -> seq (step init) step cont)) else Stream.sempty let range n until = let step x = (x + 1) land max_int in let cont = match until with | None -> (fun _ -> true) | Some x -> ( >= ) x in seq n step cont let ( -- ) p q = range p (Some q) let next (__strm : _ Stream.t) = match Stream.peek __strm with | Some h -> (Stream.junk __strm; h) | _ -> raise End_of_flow let rec foldl f init s = match peek s with | Some h -> (match f init h with | (accu, None) -> (junk s; foldl f accu s) | (accu, Some true) -> (junk s; accu) | (_, Some false) -> init) | None -> init let rec foldr f init s = let (__strm : _ Stream.t) = s in match Stream.peek __strm with | Some h -> (Stream.junk __strm; f h (lazy (foldr f init s))) | _ -> init let fold f s = let (__strm : _ Stream.t) = s in match Stream.peek __strm with | Some h -> (Stream.junk __strm; foldl f h s) | _ -> raise End_of_flow let cons x s = Stream.icons x s let apnd s1 s2 = Stream.iapp s1 s2 let is_empty s = match peek s with | None -> true | _ -> false let rec concat ss = Stream.slazy (fun _ -> let (__strm : _ Stream.t) = ss in match Stream.peek __strm with | Some p -> (Stream.junk __strm; Stream.iapp p (Stream.slazy (fun _ -> concat ss))) | _ -> Stream.sempty) let rec concat_map f l = Stream.slazy (fun () -> match Stream.peek l with | Some p -> let p' = f p in Stream.junk l; Stream.iapp p' (Stream.slazy (fun () -> concat_map f l)) | None -> Stream.sempty) let rec filter f s = Stream.slazy (fun _ -> let (__strm : _ Stream.t) = s in match Stream.peek __strm with | Some h -> (Stream.junk __strm; if f h then Stream.icons h (Stream.slazy (fun _ -> filter f s)) else Stream.slazy (fun _ -> filter f s)) | _ -> Stream.sempty) let take n fl = let i = ref n in of_fun (fun () -> (if !i <= 0 then raise End_of_flow else decr i; next fl)) let drop n fl = let i = ref n in let rec f () = if !i <= 0 then next fl else (ignore (next fl); decr i; f ()) in of_fun f let rec take_while f s = Stream.slazy (fun _ -> match peek s with | Some h -> if f h then (junk s; Stream.icons h (Stream.slazy (fun _ -> take_while f s))) else Stream.sempty | None -> Stream.sempty) let rec drop_while f s = Stream.slazy (fun _ -> let (__strm : _ Stream.t) = s in match Stream.peek __strm with | Some h -> (Stream.junk __strm; if f h then Stream.slazy (fun _ -> drop_while f s) else Stream.icons h s) | _ -> Stream.sempty) let span p s = let q = Queue.create () and sr = ref None in let rec get_head () = Stream.slazy (fun _ -> if not (Queue.is_empty q) then Stream.lcons (fun _ -> Queue.take q) (Stream.slazy get_head) else (let (__strm : _ Stream.t) = s in match Stream.peek __strm with | Some h -> (Stream.junk __strm; if p h then Stream.icons h (Stream.slazy get_head) else (sr := Some h; Stream.sempty)) | _ -> Stream.sempty)) in let rec get_tail () = match !sr with | Some v -> Stream.icons v s | None -> Stream.slazy (fun _ -> let (__strm : _ Stream.t) = s in match Stream.peek __strm with | Some h -> (Stream.junk __strm; if p h then Queue.add h q else sr := Some h; get_tail ()) | _ -> Stream.sempty) in ((get_head ()), (Stream.slazy get_tail)) let break p s = span (p |- not) s let rec group p s = Stream.slazy (fun _ -> match peek s with | None -> Stream.sempty | Some v -> if p v then group_aux p s else group_aux (p |- not) s) and group_aux p s = match peek s with | None -> Stream.sempty | Some _ -> let h = next s in let (s1, s2) = span p s in Stream.lcons (fun _ -> Stream.icons h s1) (Stream.slazy (fun _ -> group_aux (p |- not) s2)) let rec map f s = Stream.slazy (fun _ -> let (__strm : _ Stream.t) = s in match Stream.peek __strm with | Some h -> (Stream.junk __strm; Stream.lcons (fun _ -> f h) (Stream.slazy (fun _ -> map f s))) | _ -> Stream.sempty) let dup (_s: 'a Stream.t) = failwith "Correct implementation needed" (* let rec gen q_in q_out = Printf.printf "0%!"; Stream.slazy (fun () -> Printf.printf "a%!"; if Queue.is_empty q_in then (* take from stream, put onto other queue *) match Stream.peek s with | Some h -> Printf.printf "b%!"; Stream.junk s; Queue.add h q_out; Stream.icons h (Stream.slazy (fun () -> gen q_in q_out)) | _ -> Stream.sempty else ( (* take from queue *) Printf.printf "c%!"; Stream.lcons (fun () -> Queue.take q_in) (Stream.slazy (fun () -> gen q_in q_out)))) in let q1 = Queue.create () in let q2 = Queue.create () in Printf.printf "!!%!"; gen q1 q2, gen q2 q1 *) (* dup let block_stream = let x = ref 10 in BatStream.of_fun (fun pos -> decr x; if !x < 0 then None else Some !x) in let rec show count stream = match BatStream.next block_stream with | Some x -> show (succ count) stream | None -> count in let q1, q2 = BatStream.dup block_stream in Printf.printf "x%!"; assert_equal ~msg:"Second stream from dup length wrong" ~printer:(IO.to_string Int.print) 10 (show 0 q2); Printf.printf "x%!"; assert_equal ~msg:"First stream from dup length wrong" ~printer:(IO.to_string Int.print) 10 (show 0 q1); Printf.printf "x%!"; () **) (*NOT EXPORTED let rec combn sa = Stream.slazy (fun _ -> if Array.fold_left (fun b s -> b || (is_empty s)) false sa then Stream.sempty else Stream.lcons (fun _ -> Array.map next sa) (Stream.slazy (fun _ -> combn sa))) *) let rec comb (s1, s2) = Stream.slazy (fun _ -> match peek s1 with | Some h1 -> (match peek s2 with | Some h2 -> (junk s1; junk s2; Stream.lcons (fun _ -> (h1, h2)) (Stream.slazy (fun _ -> comb (s1, s2)))) | None -> Stream.sempty) | None -> Stream.sempty) (*NOT EXPORTED let dupn n s = let qa = Array.init n (fun _ -> Queue.create ()) in let rec gen i = Stream.slazy (fun _ -> if not (Queue.is_empty qa.(i)) then Stream.lcons (fun _ -> Queue.take qa.(i)) (Stream.slazy (fun _ -> gen i)) else (let (__strm : _ Stream.t) = s in match Stream.peek __strm with | Some h -> (Stream.junk __strm; for i = 0 to n - 1 do Queue.add h qa.(i) done; gen i) | _ -> Stream.sempty)) in Array.init n gen let splitn n s = let qa = Array.init n (fun _ -> Queue.create ()) in let rec gen i = Stream.slazy (fun _ -> if not (Queue.is_empty qa.(i)) then Stream.lcons (fun _ -> Queue.take qa.(i)) (Stream.slazy (fun _ -> gen i)) else (let (__strm : _ Stream.t) = s in match Stream.peek __strm with | Some h -> (Stream.junk __strm; for i = 0 to n - 1 do Queue.add h.(i) qa.(i) done; gen i) | _ -> Stream.sempty)) in Array.init n gen *) let split s = ( |- ) dup ((map fst) // (map snd)) s let mergen f sa = let n = Array.length sa in let pt = Array.init n id in let rec alt x i = (i < n) && (if pt.((x + i) mod n) = pt.(x) then alt x (i + 1) else (for j = 0 to i - 1 do pt.((x + j) mod n) <- pt.((x + i) mod n) done; true)) in let rec aux i = Stream.slazy (fun _ -> let (__strm : _ Stream.t) = sa.(pt.(i)) in match Stream.peek __strm with | Some h -> (Stream.junk __strm; let i' = pt.(i) in Stream.icons h (Stream.slazy (fun _ -> aux pt.((f i' h) mod n)))) | _ -> if alt i 1 then aux i else Stream.sempty) in aux 0 let merge f (s1, s2) = let i2b = function | 0 -> true | 1 -> false | _ -> assert false and b2i = function | true -> 0 | false -> 1 in mergen (fun i x -> b2i (f (i2b i) x)) [| s1; s2 |] let switchn n f s = let qa = Array.init n (fun _ -> Queue.create ()) in let rec gen i = Stream.slazy (fun _ -> if not (Queue.is_empty qa.(i)) then Stream.lcons (fun _ -> Queue.take qa.(i)) (Stream.slazy (fun _ -> gen i)) else (let (__strm : _ Stream.t) = s in match Stream.peek __strm with | Some h -> (Stream.junk __strm; let i' = (f h) mod n in if i' = i then Stream.icons h (Stream.slazy (fun _ -> gen i)) else (Queue.add h qa.(i'); Stream.slazy (fun _ -> gen i))) | _ -> Stream.sempty)) in Array.init n gen let switch f s = let sa = switchn 2 (fun x -> if f x then 0 else 1) s in ((sa.(0)), (sa.(1))) let rec scanl f init s = Stream.slazy (fun _ -> let (__strm : _ Stream.t) = s in match Stream.peek __strm with | Some h -> (Stream.junk __strm; Stream.icons init (Stream.slazy (fun _ -> scanl f (f init h) s))) | _ -> Stream.ising init) let scan f s = Stream.slazy (fun _ -> let (__strm : _ Stream.t) = s in match Stream.peek __strm with | Some h -> (Stream.junk __strm; Stream.slazy (fun _ -> scanl f h s)) | _ -> Stream.sempty) let map2 f = (comb |- (map (uncurry f))) |> curry (*NOT EXPORTED let rec map_fold f s = Stream.slazy (fun _ -> match peek s with | None -> Stream.sempty | Some _ -> Stream.lcons (fun _ -> fold f s) (Stream.slazy (fun _ -> map_fold f s))) *) let feed stf vf delay exp = let s_in' = ref Stream.sempty in let out = exp (Stream.iapp delay (Stream.slazy (fun _ -> !s_in'))) in let s_in = stf out and s_out = vf out in (s_in' := s_in; s_out) let feedl delay exp = feed fst snd delay exp (* NOT EXPORTED let feedr delay exp = feed snd fst delay exp *) (* NOT EXPORTED let circ delay exp = feedl delay (exp |- dup) *) let while_do size test exp = let size = match size with | Some n when n >= 1 -> n | _ -> 1 in let inside = ref 0 in let judge x = if test x then (incr inside; true) else false in let choose b _ = (if not b then decr inside else (); !inside < size) in ((((merge choose) |- (switch judge)) |- (exp // id)) |> curry) |- (feedl Stream.sempty) let do_while size test exp = let size = match size with | Some n when n >= 1 -> n | _ -> 1 in let inside = ref 0 in let judge x = if test x then (incr inside; true) else false in let choose b _ = (if not b then decr inside else (); !inside < size) in ((((merge choose) |- exp) |- (switch judge)) |> curry) |- (feedl Stream.sempty) let farm par size path exp_gen s = let par = match par with | None -> 1 | Some p -> p in let size = match size with | None -> (fun _ -> 1) | Some f -> f in let path = match path with | None -> ignore |- (to_fun (cycle None (0 -- (par - 1)))) | Some f -> f in let par = if par < 1 then 1 else par in let count = Array.make par 0 in let size x = let s = size x in if s < 1 then 1 else s in let path x = let i = path x in (count.(i) <- succ count.(i); i) in let choose = let rec find_next cond last i = if i < par then (let j = (last + i) mod par in if cond j then Some j else find_next cond last (i + 1)) else None in fun last _ -> (count.(last) <- count.(last) - 1; let nth = match find_next (fun i -> count.(i) >= (size i)) last 1 with | Some j -> j | None -> (match find_next (fun i -> count.(i) > 0) last 1 with | Some j -> j | None -> last + (1 mod par)) in nth) in let sa_in = switchn par path s in let sa_out = Array.mapi exp_gen sa_in in mergen choose sa_out (* let ( ||| ) exp1 exp2 = exp1 |- exp2 *) let enum x = BatEnum.from (fun () -> try next x with | End_of_flow -> raise BatEnum.No_more_elements) let rec of_enum e = Stream.slazy (fun _ -> match BatEnum.get e with | Some h -> Stream.icons h (Stream.slazy (fun _ -> of_enum e)) | None -> Stream.sempty) ##V<4.2##let of_bytes = of_string module StreamLabels = struct let iter ~f x = iter f x let switch ~f x = switch f x let to_string_fmt ~fmt = to_string_fmt fmt let to_string_fun ~fn = to_string_fun fn let foldl ~f ~init = foldl f init let foldr ~f ~init = foldr f init let fold ~f ~init = fold f init let filter ~f = filter f let map ~f = map f let map2 ~f = map2 f let scanl ~f = scanl f let scan ~f = scan f let while_do ?size ~f = while_do size f let do_while ?size ~f = do_while size f let range ?until p = range p until let repeat ?times = repeat times let cycle ?times = cycle times let take_while ~f = take_while f let drop_while ~f = drop_while f let span ~f = span f let break ~f = break f let group ~f = group f let merge ~f = merge f let mergen ~f = mergen f let switchn x ~f = switchn x f let farm ?par ?size ?path = farm par size path end batteries-included-3.4.0/src/batString.mliv000066400000000000000000001435761415601150500207200ustar00rootroot00000000000000(* * BatString - Additional functions for string manipulations. * Copyright (C) 2003 Nicolas Cannasse * Copyright (C) 1996 Xavier Leroy, INRIA Rocquencourt * Copyright (C) 2008 Edgar Friendly * Copyright (C) 2009 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** String operations. Given a string [s] of length [l], we call character number in [s] the index of a character in [s]. Indexes start at [0], and we will call a character number valid in [s] if it falls within the range [[0...l-1]]. A position is the point between two characters or at the beginning or end of the string. We call a position valid in [s] if it falls within the range [[0...l]]. Note that character number [n] is between positions [n] and [n+1]. Two parameters [start] and [len] are said to designate a valid substring of [s] if [len >= 0] and [start] and [start+len] are valid positions in [s]. This module replaces Stdlib's {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/String.html}String} module. If you're going to do a lot of string slicing, BatSubstring might be a useful module to represent slices of strings, as it doesn't allocate new strings on every operation. @author Xavier Leroy (base library) @author Nicolas Cannasse @author David Teller @author Edgar Friendly *) val init : int -> (int -> char) -> string (** [init l f] returns the string of length [l] with the chars f 0 , f 1 , f 2 ... f (l-1). Example: [String.init 256 char_of_int] *) val empty : string (** The empty string. @since 3.4.0 *) val is_empty : string -> bool (** [is_empty s] returns [true] if [s] is the empty string, [false] otherwise. Usually a tad faster than comparing [s] with [""]. Example (for some string [s]): [ if String.is_empty s then "(Empty)" else s ] *) val of_bytes : bytes -> string (** Return a new string that contains the same bytes as the given byte sequence. @since 3.4.0 *) val to_bytes : string -> bytes (** Return a new byte sequence that contains the same bytes as the given string. @since 3.4.0 *) val cat : string -> string -> string (** [cat s1 s2] concatenates s1 and s2 (equivalent to [s1 ^ s2]). @raise Invalid_argument if the result is longer then than {!Sys.max_string_length} bytes. @since 3.4.0 *) val for_all : (char -> bool) -> string -> bool (** [for_all p s] check if all chars in [s] satisfy the predicate [p]. @since 3.4.0 *) external length : string -> int = "%string_length" (** Return the length (number of characters) of the given string. *) external get : string -> int -> char = "%string_safe_get" (** [String.get s n] returns character number [n] in string [s]. You can also write [s.[n]] instead of [String.get s n]. @raise Invalid_argument if [n] not a valid character number in [s]. *) external set : Bytes.t -> int -> char -> unit = "%string_safe_set" (** [String.set s n c] modifies string [s] in place, replacing the character number [n] by [c]. You can also write [s.[n] <- c] instead of [String.set s n c]. @raise Invalid_argument if [n] is not a valid character number in [s]. *) external create : int -> Bytes.t = "caml_create_string" (** [String.create n] returns a fresh string of length [n]. The string initially contains arbitrary characters. @raise Invalid_argument if [n < 0] or [n > ]{!Sys.max_string_length}. *) val make : int -> char -> string (** [String.make n c] returns a fresh string of length [n], filled with the character [c]. @raise Invalid_argument if [n < 0] or [n > ]{!Sys.max_string_length}.*) val copy : string -> string (** Return a copy of the given string. *) val sub : string -> int -> int -> string (** [String.sub s start len] returns a fresh string of length [len], containing the substring of [s] that starts at position [start] and has length [len]. @raise Invalid_argument if [start] and [len] do not designate a valid substring of [s]. *) val fill : Bytes.t -> int -> int -> char -> unit (** [String.fill s start len c] modifies the byte sequence [s] in place, replacing [len] characters by [c], starting at [start]. @raise Invalid_argument if [start] and [len] do not designate a valid substring of [s]. *) val blit : string -> int -> Bytes.t -> int -> int -> unit (** [String.blit src srcoff dst dstoff len] copies [len] characters from string [src], starting at character number [srcoff], to the byte sequence [dst], starting at character number [dstoff]. @raise Invalid_argument if [srcoff] and [len] do not designate a valid substring of [src], or if [dstoff] and [len] do not designate a valid substring of [dst]. *) val concat : string -> string list -> string (** [String.concat sep sl] concatenates the list of strings [sl], inserting the separator string [sep] between each. *) val iter : (char -> unit) -> string -> unit (** [String.iter f s] applies function [f] in turn to all the characters of [s]. It is equivalent to [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *) val iteri : (int -> char -> unit) -> string -> unit (** Same as {!String.iter}, but the function is applied to the index of the element as first argument (counting from 0), and the character itself as second argument. @since 4.00.0 *) val map : (char -> char) -> string -> string (** [String.map f s] applies function [f] in turn to all the characters of [s] and stores the results in a new string that is returned. @since 4.00.0 *) val mapi : (int -> char -> char) -> string -> string (** [String.mapi f s] calls [f] with each character of [s] and its index (in increasing index order) and stores the results in a new string that is returned. @since 4.02.0 *) val trim : string -> string (** Return a copy of the argument, without leading and trailing whitespace (according to {!BatChar.is_whitespace}). The characters regarded as whitespace are: [' '], ['\n'], ['\r'], ['\t'], ['\012'] and ['\026']. If there is no leading nor trailing whitespace character in the argument, return the original string itself, not a copy. @since 4.00.0 *) val escaped : string -> string (** Return a copy of the argument, with special characters represented by escape sequences, following the lexical conventions of OCaml. If there is no special character in the argument, return the original string itself, not a copy. Its inverse function is Scanf.unescaped. *) val index : string -> char -> int (** [String.index s c] returns the character number of the first occurrence of character [c] in string [s]. @raise Not_found if [c] does not occur in [s]. *) val index_opt: string -> char -> int option (** [String.index_opt s c] returns the index of the first occurrence of character [c] in string [s], or [None] if [c] does not occur in [s]. @since 2.7.0 *) val rindex : string -> char -> int (** [String.rindex s c] returns the character number of the last occurrence of character [c] in string [s]. @raise Not_found if [c] does not occur in [s]. *) val rindex_opt: string -> char -> int option (** [String.rindex_opt s c] returns the index of the last occurrence of character [c] in string [s], or [None] if [c] does not occur in [s]. @since 2.7.0 *) val index_from : string -> int -> char -> int (** [String.index_from s i c] returns the character number of the first occurrence of character [c] in string [s] after or at position [i]. [String.index s c] is equivalent to [String.index_from s 0 c]. @raise Invalid_argument if [i] is not a valid position in [s]. @raise Not_found if [c] does not occur in [s] after position [i]. *) val index_from_opt: string -> int -> char -> int option (** [String.index_from_opt s i c] returns the index of the first occurrence of character [c] in string [s] after position [i] or [None] if [c] does not occur in [s] after position [i]. [String.index_opt s c] is equivalent to [String.index_from_opt s 0 c]. Raise [Invalid_argument] if [i] is not a valid position in [s]. @since 2.7.0 *) val rindex_from : string -> int -> char -> int (** [String.rindex_from s i c] returns the character number of the last occurrence of character [c] in string [s] before position [i+1]. [String.rindex s c] is equivalent to [String.rindex_from s (String.length s - 1) c]. @raise Invalid_argument if [i+1] is not a valid position in [s]. @raise Not_found if [c] does not occur in [s] before position [i+1]. *) val rindex_from_opt: string -> int -> char -> int option (** [String.rindex_from_opt s i c] returns the index of the last occurrence of character [c] in string [s] before position [i+1] or [None] if [c] does not occur in [s] before position [i+1]. [String.rindex_opt s c] is equivalent to [String.rindex_from_opt s (String.length s - 1) c]. Raise [Invalid_argument] if [i+1] is not a valid position in [s]. @since 2.7.0 *) val index_after_n : char -> int -> string -> int (** [index_after_n chr n str] returns the index of the character that comes immediately after the [n]-th occurrence of [chr] in [str]. - {b Occurrences are numbered from 1}: [n] = 1 returns the index of the character located immediately after the first occurrence of [chr]. - [n] = 0 always returns [0]. - If the [n]-th occurrence of [chr] is the last character of [str], returns the length of [str]. @raise Invalid_argument if [n < 0]. @raise Not_found if there are strictly less than [n] occurrences of [chr] in [str]. @since 2.9.0 *) val contains : string -> char -> bool (** [String.contains s c] tests if character [c] appears in the string [s]. *) val contains_from : string -> int -> char -> bool (** [String.contains_from s start c] tests if character [c] appears in [s] after position [start]. [String.contains s c] is equivalent to [String.contains_from s 0 c]. @raise Invalid_argument if [start] is not a valid position in [s]. *) val rcontains_from : string -> int -> char -> bool (** [String.rcontains_from s stop c] tests if character [c] appears in [s] before position [stop+1]. @raise Invalid_argument if [stop < 0] or [stop+1] is not a valid position in [s]. *) val uppercase : string -> string (** Return a copy of the argument, with all lowercase letters translated to uppercase, including accented letters of the ISO Latin-1 (8859-1) character set. *) val lowercase : string -> string (** Return a copy of the argument, with all uppercase letters translated to lowercase, including accented letters of the ISO Latin-1 (8859-1) character set. *) val capitalize : string -> string (** Return a copy of the argument, with the first character set to uppercase. *) val uncapitalize : string -> string (** Return a copy of the argument, with the first character set to lowercase. *) val uppercase_ascii : string -> string (** Return a copy of the argument, with all lowercase letters translated to uppercase, using the US-ASCII character set. @since 2.5.0 *) val lowercase_ascii : string -> string (** Return a copy of the argument, with all uppercase letters translated to lowercase, using the US-ASCII character set. @since 2.5.0 *) val capitalize_ascii : string -> string (** Return a copy of the argument, with the first character set to uppercase, using the US-ASCII character set. @since 2.5.0 *) val uncapitalize_ascii : string -> string (** Return a copy of the argument, with the first character set to lowercase, using the US-ASCII character set. @since 2.5.0 *) type t = string (** An alias for the type of strings. *) val compare: t -> t -> int (** The comparison function for strings, with the same specification as {!Pervasives.compare}. Along with the type [t], this function [compare] allows the module [String] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) (** {6 Conversions} *) val enum : string -> char BatEnum.t (** Returns an enumeration of the characters of a string. The behaviour is unspecified if the string is mutated while it is enumerated. Examples: ["foo" |> String.enum |> List.of_enum = ['f'; 'o'; 'o']] [String.enum "a b c" // ((<>) ' ') |> String.of_enum = "abc"] *) val of_enum : char BatEnum.t -> string (** Creates a string from a character enumeration. Example: [['f'; 'o'; 'o'] |> List.enum |> String.of_enum = "foo"] *) val backwards : string -> char BatEnum.t (** Returns an enumeration of the characters of a string, from last to first. Examples: [ "foo" |> String.backwards |> String.of_enum = "oof" ] [ let rev s = String.backwards s |> String.of_enum ] *) val of_backwards : char BatEnum.t -> string (** Build a string from an enumeration, starting with last character, ending with first. Examples: [ "foo" |> String.enum |> String.of_backwards = "oof" ] [ "foo" |> String.backwards |> String.of_backwards = "foo" ] [ let rev s = String.enum s |> String.of_backwards ] *) val of_list : char list -> string (** Converts a list of characters to a string. Example: [ ['c'; 'h'; 'a'; 'r'; 's'] |> String.of_list = "chars" ] *) val to_list : string -> char list (** Converts a string to the list of its characters. Example: [ String.to_list "string" |> List.interleave ';' |> String.of_list = "s;t;r;i;n;g" ] *) val of_int : int -> string (** Returns the string representation of an int. Example: [ String.of_int 56 = "56" && String.of_int (-1) = "-1" ] *) val of_float : float -> string (** Returns the string representation of an float. Example: [ String.of_float 1.246 = "1.246" ] *) val of_char : char -> string (** Returns a string containing one given character. Example: [ String.of_char 's' = "s" ] *) val to_int : string -> int (** Returns the integer represented by the given string or @raise Failure if the string does not represent an integer. This follows OCaml's int literal rules, so "0x" prefixes hexadecimal integers, "0o" for octal and "0b" for binary. Underscores within the number are allowed for readability but ignored. Examples: [ String.to_int "8_480" = String.to_int "0x21_20" ] [ try ignore(String.to_int "2,3"); false with Failure _ -> true ] @raise Failure if the string does not represent an integer. *) val to_float : string -> float (** Returns the float represented by the given string or @raise Failure if the string does not represent a float. Decimal points aren't required in the given string, as they are for float literals in OCaml, but otherwise the rules for float literals apply. Examples: [String.to_float "12.34e-1" = String.to_float "1.234"] [String.to_float "1" = 1.] [try ignore(String.to_float ""); false with Failure _ -> true] @raise Failure if the string does not represent a float. *) (** {6 String traversals} *) val map : (char -> char) -> string -> string (** [map f s] returns a string where all characters [c] in [s] have been replaced by [f c]. Example: [String.map Char.uppercase "Five" = "FIVE"] **) val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a (** [fold_left f a s] is [f (... (f (f a s.[0]) s.[1]) ...) s.[n-1]] Examples: [String.fold_left (fun li c -> c::li) [] "foo" = ['o';'o';'f']] [String.fold_left max 'a' "apples" = 's'] *) val fold_lefti : ('a -> int -> char -> 'a) -> 'a -> string -> 'a (** As [fold_left], but with the index of the element as additional argument @since 2.3.0 *) val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a (** [fold_right f s b] is [f s.[0] (f s.[1] (... (f s.[n-1] b) ...))] Examples: [String.fold_right List.cons "foo" [] = ['f';'o';'o']] [String.fold_right (fun c a -> if c = ' ' then a+1 else a) "a b c" 0 = 2] *) val fold_righti : (int -> char -> 'a -> 'a) -> string -> 'a -> 'a (** As [fold_right], but with the index of the element as additional argument @since 2.3.0 *) val filter : (char -> bool) -> string -> string (** [filter f s] returns a copy of string [s] in which only characters [c] such that [f c = true] remain. Example: [ String.filter ((<>) ' ') "a b c" = "abc" ] *) val filter_map : (char -> char option) -> string -> string (** [filter_map f s] calls [(f a0) (f a1).... (f an)] where [a0..an] are the characters of [s]. It returns the string of characters [ci] such as [f ai = Some ci] (when [f] returns [None], the corresponding element of [s] is discarded). Example: [ String.filter_map (function 'a'..'z' as c -> Some (Char.uppercase c) | _ -> None) "a b c" = "ABC" ] *) val iteri : (int -> char -> unit) -> string -> unit (** [String.iteri f s] is equivalent to [f 0 s.[0]; f 1 s.[1]; ...; f len s.[len]] where [len] is length of string [s]. Example: {[ let letter_positions word = let positions = Array.make 256 [] in let count_letter pos c = positions.(int_of_char c) <- pos :: positions.(int_of_char c) in String.iteri count_letter word; Array.mapi (fun c pos -> (char_of_int c, List.rev pos)) positions |> Array.to_list |> List.filter (fun (c,pos) -> pos <> []) in letter_positions "hello" = ['e',[1]; 'h',[0]; 'l',[2;3]; 'o',[4] ] ]} *) (** {6 Finding}*) val find : string -> string -> int (** [find s x] returns the starting index of the first occurrence of string [x] within string [s]. {b Note} This implementation is optimized for short strings. @raise Not_found if [x] is not a substring of [s]. Example: [String.find "foobarbaz" "bar" = 3] *) val find_from: string -> int -> string -> int (** [find_from s pos x] behaves as [find s x] but starts searching at position [pos]. [find s x] is equivalent to [find_from s 0 x]. @raise Not_found if not substring is found @raise Invalid_argument if [pos] is not a valid position in the string. Example: [String.find_from "foobarbaz" 4 "ba" = 6] *) val rfind : string -> string -> int (** [rfind s x] returns the starting index of the last occurrence of string [x] within string [s]. {b Note} This implementation is optimized for short strings. @raise Not_found if [x] is not a substring of [s]. Example: [String.rfind "foobarbaz" "ba" = 6] *) val rfind_from: string -> int -> string -> int (** [rfind_from s pos x] behaves as [rfind s x] but starts searching from the right at position [pos + 1]. [rfind s x] is equivalent to [rfind_from s (String.length s - 1) x]. {b Beware}, it search between the {e beginning} of the string to the position [pos + 1], {e not} between [pos + 1] and the end. @raise Not_found if not substring is found @raise Invalid_argument if [pos] is not a valid position in the string. Example: [String.rfind_from "foobarbaz" 6 "ba" = 6] *) val find_all : string -> string -> int BatEnum.t (** [find_all s x] enumerates positions of [s] at which [x] occurs. Example: [find_all "aabaabaa" "aba" |> List.of_enum] will return the list [[1; 4]]. @since 2.2.0 *) val count_string : string -> string -> int (** [count_string s x] count how many times [x] is found in [s]. @since 2.9.0 *) val ends_with : string -> string -> bool (** [ends_with s x] returns [true] if the string [s] is ending with [x], [false] otherwise. Example: [String.ends_with "foobarbaz" "rbaz" = true] *) val starts_with : string -> string -> bool (** [starts_with s x] returns [true] if [s] is starting with [x], [false] otherwise. Example: [String.starts_with "foobarbaz" "fooz" = false] *) val starts_with_stdlib : prefix:string -> string -> bool (** Equivalent to [starts_with] but the prefix is a labelled parameter. @since 3.4.0 *) val ends_with_stdlib : suffix:string -> string -> bool (** Equivalent to [ends_with] but the suffix is a labelled parameter. @since 3.4.0 *) val exists : string -> string -> bool (** [exists str sub] returns true if [sub] is a substring of [str] or false otherwise. Example: [String.exists "foobarbaz" "obar" = true] *) val exists_stdlib : (char -> bool) -> string -> bool (** [exists_stdlib p str] check if at least one char of [str] satisfies the predicate [p]. @since 3.4.0 *) val count_char : string -> char -> int (** [count_char str c] returns the number of times [c] is used in [str]. *) (** {6 Transformations}*) val lchop : ?n:int -> string -> string (** Returns the same string but without the first [n] characters. By default [n] is 1. If [n] is strictly less than zero @raise Invalid_argument. If the string has [n] or less characters, returns the empty string. Example: [String.lchop "Weeble" = "eeble"] [String.lchop ~n:3 "Weeble" = "ble"] [String.lchop ~n:1000 "Weeble" = ""] *) val rchop : ?n:int -> string -> string (** Returns the same string but without the last [n] characters. By default [n] is 1. If [n] is strictly less than zero @raise Invalid_argument. If the string has [n] or less characters , returns the empty string. Example: [String.rchop "Weeble" = "Weebl"] [String.rchop ~n:3 "Weeble" = "Wee"] [String.rchop ~n:1000 "Weeble" = ""] *) val chop : ?l:int -> ?r:int -> string -> string (** Returns the same string but with the first [l] characters on the left and the first [r] characters on the right removed. By default, [l] and [r] are both 1. [chop ~l ~r s] is equivalent to [lchop ~n:l (rchop ~n:r s)]. @raise Invalid_argument if either [l] or [r] is less than zero. Examples: [String.chop "\"Weeble\"" = "Weeble"] [String.chop ~l:2 ~r:3 "01234567" = "234"] *) val quote : string -> string (** Add quotes around a string and escape any quote or escape appearing in that string. This function is used typically when you need to generate source code from a string. Examples: [String.quote "foo" = "\"foo\""] [String.quote "\"foo\"" = "\"\\\"foo\\\"\""] [String.quote "\n" = "\"\\n\""] etc. More precisely, the returned string conforms to the OCaml syntax: if printed, it outputs a representation of the input string as an OCaml string litteral. *) val left : string -> int -> string (**[left r len] returns the string containing the [len] first characters of [r]. If [r] contains less than [len] characters, it returns [r]. Examples: [String.left "Weeble" 4 = "Weeb"] [String.left "Weeble" 0 = ""] [String.left "Weeble" 10 = "Weeble"] *) val right : string -> int -> string (**[right r len] returns the string containing the [len] last characters of [r]. If [r] contains less than [len] characters, it returns [r]. Example: [String.right "Weeble" 4 = "eble"] *) val head : string -> int -> string (**as {!left}*) val tail : string -> int -> string (**[tail r pos] returns the string containing all but the [pos] first characters of [r] Example: [String.tail "Weeble" 4 = "le"] *) val strip : ?chars:string -> string -> string (** Returns the string without the chars if they are at the beginning or at the end of the string. By default chars are " \t\r\n". Examples: [String.strip " foo " = "foo"] [String.strip ~chars:" ,()" " boo() bar()" = "boo() bar"] *) val replace_chars : (char -> string) -> string -> string (** [replace_chars f s] returns a string where all chars [c] of [s] have been replaced by the string returned by [f c]. Example: [String.replace_chars (function ' ' -> "(space)" | c -> String.of_char c) "foo bar" = "foo(space)bar"] *) val replace : str:string -> sub:string -> by:string -> bool * string (** [replace ~str ~sub ~by] returns a tuple consisting of a boolean and a string where the first occurrence of the string [sub] within [str] has been replaced by the string [by]. The boolean is true if a substitution has taken place. Example: [String.replace "foobarbaz" "bar" "rab" = (true, "foorabbaz")] *) val nreplace : str:string -> sub:string -> by:string -> string (** [nreplace ~str ~sub ~by] returns a string obtained by iteratively replacing each occurrence of [sub] by [by] in [str], from right to left. It returns a copy of [str] if [sub] has no occurrence in [str]. Example: [nreplace ~str:"bar foo aaa bar" ~sub:"aa" ~by:"foo" = "bar foo afoo bar"] *) val repeat: string -> int -> string (** [repeat s n] returns [s ^ s ^ ... ^ s] Example: [String.repeat "foo" 4 = "foofoofoofoo"] *) val rev : string -> string (** [rev s] returns the reverse of string [s] @since 2.1 *) (** {6 In-Place Transformations}*) val rev_in_place : Bytes.t -> unit (** [rev_in_place s] mutates the byte sequence [s], so that its new value is the mirror of its old one: for instance if s contained ["Example!"], after the mutation it will contain ["!elpmaxE"]. *) val in_place_mirror : Bytes.t -> unit (** @deprecated Use {!String.rev_in_place} instead *) (** {6 Splitting around}*) val split_on_char: char -> string -> string list (** [String.split_on_char sep s] returns the list of all (possibly empty) substrings of [s] that are delimited by the [sep] character. The function's output is specified by the following invariants: - The list is not empty. - Concatenating its elements using [sep] as a separator returns a string equal to the input ([String.concat (String.make 1 sep) (String.split_on_char sep s) = s]). - No string in the result contains the [sep] character. Note: prior to 2.11.0 [split_on_char _ ""] used to return an empty list. @since 2.5.3 *) val split : string -> by:string -> string * string (** [split s sep] splits the string [s] between the first occurrence of [sep], and returns the two parts before and after the occurrence (excluded). @raise Not_found if the separator is not found. Examples: [String.split "abcabcabc" "bc" = ("a","abcabc")] [String.split "abcabcabc" "" = ("","abcabcabc")] *) val rsplit : string -> by:string -> string * string (** [rsplit s sep] splits the string [s] between the last occurrence of [sep], and returns the two parts before and after the occurrence (excluded). @raise Not_found if the separator is not found. Example: [String.rsplit "abcabcabc" "bc" = ("abcabca","")] *) val nsplit : string -> by:string -> string list ##V>=4.2## [@@ocaml.deprecated "Use split_on_string instead."] (** [nsplit s sep] splits the string [s] into a list of strings which are separated by [sep] (excluded). [nsplit "" _] returns a single empty string. Note: prior to 2.11.0 [nsplit "" _] used to return an empty list. Example: [String.nsplit "abcabcabc" "bc" = ["a"; "a"; "a"; ""]] @deprecated use {!split_on_string} *) val split_on_string : by:string -> string -> string list (** [split_on_string sep s] splits the string [s] into a list of strings which are separated by [sep] (excluded). [split_on_string _ ""] returns a single empty string. Note: [split_on_string sep s] is identical to [nsplit s sep] but for empty strings. Example: [String.split_on_string "bc" "abcabcabc" = ["a"; "a"; "a"; ""]] @since 2.11.0 *) val cut_on_char : char -> int -> string -> string (** Similar to Unix [cut]. [cut_on_char chr n str] returns the substring of [str] located strictly between the [n]-th occurrence of [chr] and the [n+1]-th one. - {b Occurrences of [chr] are numbered from 1}. - If [n = 0], returns the substring from the beginning of [str] to the first occurrence of [chr]. - If there are exactly [n] occurrences of [chr] in [str], returns the substring between the last occurrence of [chr] and the end of [str]. - These behaviours cumulate: if [n] equals [0] and [chr] is absent from [str], returns the full string [str]. {b Remark:} [cut_on_char] can return the empty string. Examples of this behaviour are [cut_on_char ',' 1 "foo,,bar"] and [cut_on_char ',' 0 ",foo"]. @raise Not_found if there are strictly less than [n] occurrences of [chr] in str. @raise Invalid_argument if [n < 0]. @since 2.9.0 *) val join : string -> string list -> string (** Same as {!concat} *) val slice : ?first:int -> ?last:int -> string -> string (** [slice ?first ?last s] returns a "slice" of the string which corresponds to the characters [s.[first]], [s.[first+1]], ..., [s[last-1]]. Note that the character at index [last] is {b not} included! If [first] is omitted it defaults to the start of the string, i.e. index 0, and if [last] is omitted is defaults to point just past the end of [s], i.e. [length s]. Thus, [slice s] is equivalent to [copy s]. Negative indexes are interpreted as counting from the end of the string. For example, [slice ~last:(-2) s] will return the string [s], but without the last two characters. This function {b never} raises any exceptions. If the indexes are out of bounds they are automatically clipped. Example: [String.slice ~first:1 ~last:(-3) " foo bar baz" = "foo bar "] *) val splice: string -> int -> int -> string -> string (** [String.splice s off len rep] cuts out the section of [s] indicated by [off] and [len] and replaces it by [rep] Negative indexes are interpreted as counting from the end of the string. If [off+len] is greater than [length s], the end of the string is used, regardless of the value of [len]. If [len] is zero or negative, [rep] is inserted at position [off] without replacing any of [s]. Example: [String.splice "foo bar baz" 3 5 "XXX" = "fooXXXbaz"] *) val explode : string -> char list (** [explode s] returns the list of characters in the string [s]. Example: [String.explode "foo" = ['f'; 'o'; 'o']] *) val implode : char list -> string (** [implode cs] returns a string resulting from concatenating the characters in the list [cs]. Example: [String.implode ['b'; 'a'; 'r'] = "bar"] *) ##V>=4.07##(** {6 Iterators} *) ##V>=4.07##val to_seq : t -> char Seq.t ##V>=4.07##(** Iterate on the string, in increasing index order. Modifications of the ##V>=4.07## string during iteration will be reflected in the iterator. ##V>=4.07## @since 2.10.0 and OCaml 4.07 *) ##V>=4.07##val to_seqi : t -> (int * char) Seq.t ##V>=4.07##(** Iterate on the string, in increasing order, yielding indices along chars ##V>=4.07## @since 2.10.0 and OCaml 4.07 *) ##V>=4.07##val of_seq : char Seq.t -> t ##V>=4.07##(** Create a string from the generator ##V>=4.07## @since 2.10.0 and OCaml 4.07 *) (** {6 Binary decoding of integers} *) (** The functions in this section binary decode integers from strings. All following functions raise [Invalid_argument] if the characters needed at index [i] to decode the integer are not available. Little-endian (resp. big-endian) encoding means that least (resp. most) significant bytes are stored first. Big-endian is also known as network byte order. Native-endian encoding is either little-endian or big-endian depending on {!Sys.big_endian}. 32-bit and 64-bit integers are represented by the [int32] and [int64] types, which can be interpreted either as signed or unsigned numbers. 8-bit and 16-bit integers are represented by the [int] type, which has more bits than the binary encoding. These extra bits are sign-extended (or zero-extended) for functions which decode 8-bit or 16-bit integers and represented them with [int] values. *) val get_uint8 : string -> int -> int (** [get_uint8 b i] is [b]'s unsigned 8-bit integer starting at character index [i]. @since 3.4.0 *) ##V>=4.08##val get_int8 : string -> int -> int ##V>=4.08##(** [get_int8 b i] is [b]'s signed 8-bit integer starting at character ##V>=4.08## index [i]. ##V>=4.08## @since 3.4.0 and OCaml 4.08 *) ##V>=4.08##val get_uint16_ne : string -> int -> int ##V>=4.08##(** [get_uint16_ne b i] is [b]'s native-endian unsigned 16-bit integer ##V>=4.08## starting at character index [i]. ##V>=4.08## @since 3.4.0 and OCaml 4.08 *) ##V>=4.08##val get_uint16_be : string -> int -> int ##V>=4.08##(** [get_uint16_be b i] is [b]'s big-endian unsigned 16-bit integer ##V>=4.08## starting at character index [i]. ##V>=4.08## @since 3.4.0 and OCaml 4.08 *) ##V>=4.08##val get_uint16_le : string -> int -> int ##V>=4.08##(** [get_uint16_le b i] is [b]'s little-endian unsigned 16-bit integer ##V>=4.08## starting at character index [i]. ##V>=4.08## @since 3.4.0 and OCaml 4.08 *) ##V>=4.08##val get_int16_ne : string -> int -> int ##V>=4.08##(** [get_int16_ne b i] is [b]'s native-endian signed 16-bit integer ##V>=4.08## starting at character index [i]. ##V>=4.08## @since 3.4.0 and OCaml 4.08 *) ##V>=4.08##val get_int16_be : string -> int -> int ##V>=4.08##(** [get_int16_be b i] is [b]'s big-endian signed 16-bit integer ##V>=4.08## starting at character index [i]. ##V>=4.08## @since 3.4.0 and OCaml 4.08 *) ##V>=4.08##val get_int16_le : string -> int -> int ##V>=4.08##(** [get_int16_le b i] is [b]'s little-endian signed 16-bit integer ##V>=4.08## starting at character index [i]. ##V>=4.08## @since 3.4.0 and OCaml 4.08 *) ##V>=4.08##val get_int32_ne : string -> int -> int32 ##V>=4.08##(** [get_int32_ne b i] is [b]'s native-endian 32-bit integer ##V>=4.08## starting at character index [i]. ##V>=4.08## @since 3.4.0 and OCaml 4.08 *) ##V>=4.08##val get_int32_be : string -> int -> int32 ##V>=4.08##(** [get_int32_be b i] is [b]'s big-endian 32-bit integer ##V>=4.08## starting at character index [i]. ##V>=4.08## @since 3.4.0 and OCaml 4.08 *) ##V>=4.08##val get_int32_le : string -> int -> int32 ##V>=4.08##(** [get_int32_le b i] is [b]'s little-endian 32-bit integer ##V>=4.08## starting at character index [i]. ##V>=4.08## @since 3.4.0 and OCaml 4.08 *) ##V>=4.08##val get_int64_ne : string -> int -> int64 ##V>=4.08##(** [get_int64_ne b i] is [b]'s native-endian 64-bit integer ##V>=4.08## starting at character index [i]. ##V>=4.08## @since 3.4.0 and OCaml 4.08 *) ##V>=4.08##val get_int64_be : string -> int -> int64 ##V>=4.08##(** [get_int64_be b i] is [b]'s big-endian 64-bit integer ##V>=4.08## starting at character index [i]. ##V>=4.08## @since 3.4.0 and OCaml 4.08 *) ##V>=4.08##val get_int64_le : string -> int -> int64 ##V>=4.08##(** [get_int64_le b i] is [b]'s little-endian 64-bit integer ##V>=4.08## starting at character index [i]. ##V>=4.08## @since 3.4.0 and OCaml 4.08 *) (** {6 Comparisons}*) val equal : t -> t -> bool (** String equality *) val ord : t -> t -> BatOrd.order (** Ordering function for strings, see {!BatOrd} *) val compare: t -> t -> int (** The comparison function for strings, with the same specification as {!Pervasives.compare}. Along with the type [t], this function [compare] allows the module [String] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. Example: [String.compare "FOO" "bar" = -1] i.e. "FOO" < "bar" *) val icompare: t -> t -> int (** Compare two strings, case-insensitive. Example: [String.icompare "FOO" "bar" = 1] i.e. "foo" > "bar" *) module IString : BatInterfaces.OrderedType with type t = t (** uses icompare as ordering function Example: [module Nameset = Set.Make(String.IString)] *) val numeric_compare: t -> t -> int (** Compare two strings, sorting "abc32def" before "abc210abc". Algorithm: splits both strings into lists of (strings of digits) or (strings of non digits) ([["abc"; "32"; "def"]] and [["abc"; "210"; "abc"]]) Then both lists are compared lexicographically by comparing elements numerically when both are numbers or lexicographically in other cases. Example: [String.numeric_compare "xx32" "xx210" < 0] *) module NumString : BatInterfaces.OrderedType with type t = t (** uses numeric_compare as its ordering function Example: [module FilenameSet = Set.Make(String.NumString)] *) val edit_distance : t -> t -> int (** Edition distance (also known as "Levenshtein distance"). See {{:http://en.wikipedia.org/wiki/Levenshtein_distance} wikipedia} @since 2.2.0 *) (** {6 Boilerplate code}*) (** {7 Printing}*) val print: 'a BatInnerIO.output -> string -> unit (**Print a string. Example: [String.print stdout "foo\n"] *) val println: 'a BatInnerIO.output -> string -> unit (**Print a string, end the line. Example: [String.println stdout "foo"] *) val print_quoted: 'a BatInnerIO.output -> string -> unit (**Print a string, with quotes as added by the [quote] function. [String.print_quoted stdout "foo"] prints ["foo"] (with the quotes). [String.print_quoted stdout "\"bar\""] prints ["\"bar\""] (with the quotes). [String.print_quoted stdout "\n"] prints ["\n"] (not the escaped character, but ['\'] then ['n']). *) (** Exceptionless counterparts for error-raising operations *) module Exceptionless : sig val to_int : string -> int option (** Returns the integer represented by the given string or [None] if the string does not represent an integer.*) val to_float : string -> float option (** Returns the float represented by the given string or [None] if the string does not represent a float. *) val index : string -> char -> int option (** [index s c] returns [Some p], the position of the leftmost occurrence of character [c] in string [s] or [None] if [c] does not occur in [s]. *) val rindex : string -> char -> int option (** [rindex s c] returns [Some p], the position of the rightmost occurrence of character [c] in string [s] or [None] if [c] does not occur in [s]. *) val index_from : string -> int -> char -> int option (** Same as {!String.Exceptionless.index}, but start searching at the character position given as second argument. [index s c] is equivalent to [index_from s 0 c].*) val rindex_from : string -> int -> char -> int option (** Same as {!String.Exceptionless.rindex}, but start searching at the character position given as second argument. [rindex s c] is equivalent to [rindex_from s (String.length s - 1) c]. *) val find : string -> string -> int option (** [find s x] returns [Some i], the starting index of the first occurrence of string [x] within string [s], or [None] if [x] is not a substring of [s]. {b Note} This implementation is optimized for short strings. *) val find_from : string -> int -> string -> int option (** [find_from s ofs x] behaves as [find s x] but starts searching at offset [ofs]. [find s x] is equivalent to [find_from s 0 x].*) val rfind : string -> string -> int option (** [rfind s x] returns [Some i], the starting index of the last occurrence of string [x] within string [s], or [None] if [x] is not a substring of [s]. {b Note} This implementation is optimized for short strings. *) val rfind_from: string -> int -> string -> int option (** [rfind_from s ofs x] behaves as [rfind s x] but starts searching at offset [ofs]. [rfind s x] is equivalent to [rfind_from s (String.length s - 1) x]. *) val split : string -> by:string -> (string * string) option (** [split s sep] splits the string [s] between the first occurrence of [sep], or returns [None] if the separator is not found. *) val rsplit : string -> by:string -> (string * string) option (** [rsplit s sep] splits the string [s] between the last occurrence of [sep], or returns [None] if the separator is not found. *) end (* String.Exceptionless *) (** Capabilities for strings. This modules provides the same set of features as {!String}, but with the added twist that strings can be made read-only or write-only. Read-only strings may then be safely shared and distributed. @since 2.8.0 the interface and implementation of the Cap module changed to accommodate the -safe-string transition. OCaml now uses two distinct types for mutable and immutable string, which is a good design but is not as expressive as the present Cap interface, and actually makes implementing Cap harder than it previously was. We are aware that current state is not optimal for heavy Cap users; if you are one of them, please get in touch (on the Batteries issue tracker for example) so that we can discuss code refactoring and improvements for this sub-module. *) module Cap: sig type 'a t (** The type of capability strings. If ['a] contains [[`Read]], the contents of the string may be read. If ['a] contains [[`Write]], the contents of the string may be written. Other (user-defined) capabilities may be added without loss of performance or features. For instance, a string could be labelled [[`Read | `UTF8]] to state that it contains UTF-8 encoded data and may be used only for reading. Conversely, a string labelled with [[]] (i.e. nothing) can neither be read nor written. It can only be compared for textual equality using OCaml's built-in [compare] or for physical equality using OCaml's built-in [==]. *) external length : _ t -> int = "%string_length" val is_empty : _ t -> bool external get : [> `Read] t -> int -> char = "%string_safe_get" external set : [> `Write] t -> int -> char -> unit = "%string_safe_set" external create : int -> _ t = "caml_create_string" (** {6 Constructors}*) external of_string : Bytes.t -> _ t = "%identity" ##V>=4.2## [@@ocaml.deprecated "Use Cap.of_bytes instead"] (**Adopt a regular byte sequence. One could give a perfectly safe semantics to an [of_string : string -> _ t] function, but this requires making a copy of the string. Previous versions of this interface advertised the absence of performance overhead, so it's better to warn the user and let them decide (through the use of either Bytes.of_string or Bytes.unsafe_of_string) whether they can safely avoid a copy or need to insert one. *) val of_bytes : Bytes.t -> _ t (** Adopt a regular byte sequence. Note that adopting a byte sequence, even at the restrictive [`Read] type, does not make a copy. Having a [`Read] string prevents you (and anyone you pass it to) from writing it, but your parent may have knowledge of the string at a more permissive type and perform writes on it. If you want to use a [`Read] string and assume it will not get written to, you should either properly "adopt" it by ensuring unique ownership (this cannot be guaranteed by the type system), or make a copy of it at adoption time: [Cap.of_bytes (Bytes.copy buf)]. @since 2.8.0 *) external to_string : [`Read | `Write] t -> Bytes.t = "%identity" ##V>=4.2## [@@ocaml.deprecated "Use Cap.to_bytes instead"] (** Return a capability string as a regular byte sequence. We cannot return a [string] here, and it would be incorrect to do so even if we required [[< `Read] t] as input. Indeed, one can start from a writeable byte sequence, and then use the [read_only] function below to cast it into a [[`Read] t]. Capabilities are used to enforce local protocol (only reads, only writes, both reads and writes...), they don't guarantee that other users of the same (shared) value all follow the same protocol. To safely reason about mutability one needs stronger ownership guarantees. If you want to obtain an immutable [string] out of a capability string, you should first convert it to a mutable byte sequence and then copy it into an immutable string. If you have extra knowledge about the ownership of the value, you may use unsafe conversion functions to avoid the copy, see the documentation of unsafe conversion functions. *) external to_bytes : [`Read | `Write] t -> Bytes.t = "%identity" (** Return a capability string as a regular byte sequence. @since 2.8.0 *) external read_only : [> `Read] t -> [`Read] t = "%identity" (** Drop capabilities to read only.*) external write_only: [> `Write] t -> [`Write] t = "%identity" (** Drop capabilities to write only.*) val make : int -> char -> _ t val init : int -> (int -> char) -> _ t (** {6 Conversions}*) val enum : [> `Read] t -> char BatEnum.t val of_enum : char BatEnum.t -> _ t val backwards : [> `Read] t -> char BatEnum.t val of_backwards : char BatEnum.t -> _ t val of_list : char list -> _ t val to_list : [> `Read] t -> char list val of_int : int -> _ t val of_float : float -> _ t val of_char : char -> _ t val to_int : [> `Read] t -> int val to_float : [> `Read] t -> float (** {6 String traversals}*) val map : (char -> char) -> [>`Read] t -> _ t val mapi : (int -> char -> char) -> [>`Read] t -> _ t val fold_left : ('a -> char -> 'a) -> 'a -> [> `Read] t -> 'a val fold_lefti : ('a -> int -> char -> 'a) -> 'a -> [> `Read] t -> 'a val fold_right : (char -> 'a -> 'a) -> [> `Read] t -> 'a -> 'a val fold_righti : (int -> char -> 'a -> 'a) -> [> `Read] t -> 'a -> 'a val filter : (char -> bool) -> [> `Read] t -> _ t val filter_map : (char -> char option) -> [> `Read] t -> _ t val iter : (char -> unit) -> [> `Read] t -> unit (** {6 Finding}*) val index : [>`Read] t -> char -> int val rindex : [> `Read] t -> char -> int val index_from : [> `Read] t -> int -> char -> int val rindex_from : [> `Read] t -> int -> char -> int val contains : [> `Read] t -> char -> bool val contains_from : [> `Read] t -> int -> char -> bool val rcontains_from : [> `Read] t -> int -> char -> bool val find : [> `Read] t -> [> `Read] t -> int val find_from: [> `Read] t -> int -> [> `Read] t -> int val rfind : [> `Read] t -> [> `Read] t -> int val rfind_from: [> `Read] t -> int -> [> `Read] t -> int val ends_with : [> `Read] t -> [> `Read] t -> bool val starts_with : [> `Read] t -> [> `Read] t -> bool val exists : [> `Read] t -> [> `Read] t -> bool val count_char : [> `Read] t -> char -> int (** {6 Transformations}*) val lchop : ?n:int -> [> `Read] t -> _ t val rchop : ?n:int -> [> `Read] t -> _ t val chop : ?l:int -> ?r:int -> [> `Read] t -> _ t val trim : [> `Read] t -> _ t val quote : [> `Read] t -> string val left : [> `Read] t -> int -> _ t val right : [> `Read] t -> int -> _ t val head : [> `Read] t -> int -> _ t val tail : [> `Read] t -> int -> _ t val strip : ?chars:[> `Read] t -> [> `Read] t -> _ t val uppercase : [> `Read] t -> _ t val lowercase : [> `Read] t -> _ t val capitalize : [> `Read] t -> _ t val uncapitalize : [> `Read] t -> _ t val copy : [> `Read] t -> _ t val sub : [> `Read] t -> int -> int -> _ t val fill : [> `Write] t -> int -> int -> char -> unit val blit : [> `Read] t -> int -> [> `Write] t -> int -> int -> unit val concat : [> `Read] t -> [> `Read] t list -> _ t val escaped : [> `Read] t -> _ t val replace_chars : (char -> [> `Read] t) -> [> `Read] t -> _ t val replace : str:[> `Read] t -> sub:[> `Read] t -> by:[> `Read] t -> bool * _ t val nreplace : str:[> `Read] t -> sub:[> `Read] t -> by:[> `Read] t -> _ t val repeat: [> `Read] t -> int -> _ t (** {6 Splitting around}*) val split : [> `Read] t -> by:[> `Read] t -> _ t * _ t val rsplit : [> `Read] t -> by:[> `Read] t -> _ t * _ t val nsplit : [> `Read] t -> by:[> `Read] t -> _ t list val splice: [ `Read | `Write] t -> int -> int -> [> `Read] t -> _ t val join : [> `Read] t -> [> `Read] t list -> _ t val slice : ?first:int -> ?last:int -> [> `Read] t -> _ t val explode : [> `Read] t -> char list val implode : char list -> _ t (** {6 Comparisons}*) val compare: [> `Read] t -> [> `Read] t -> int val icompare: [> `Read] t -> [> `Read] t -> int (** {7 Printing}*) val print: 'a BatInnerIO.output -> [> `Read] t -> unit val println: 'a BatInnerIO.output -> [> `Read] t -> unit val print_quoted: 'a BatInnerIO.output -> [> `Read] t -> unit (**/**) (** {6 Undocumented operations} *) external unsafe_get : [> `Read] t -> int -> char = "%string_unsafe_get" external unsafe_set : [> `Write] t -> int -> char -> unit = "%string_unsafe_set" external unsafe_blit : [> `Read] t -> int -> [> `Write] t -> int -> int -> unit = "caml_blit_string" ##V<4.3## "noalloc" ##V>=4.3## [@@noalloc] external unsafe_fill : [> `Write] t -> int -> int -> char -> unit = "caml_fill_string" ##V<4.3## "noalloc" ##V>=4.3## [@@noalloc] (**/**) (** Exceptionless counterparts for error-raising operations *) module Exceptionless : sig val to_int : [> `Read] t -> int option val to_float : [> `Read] t -> float option val index : [>`Read] t -> char -> int option val rindex : [> `Read] t -> char -> int option val index_from : [> `Read] t -> int -> char -> int option val rindex_from : [> `Read] t -> int -> char -> int option val find : [> `Read] t -> [> `Read] t -> int option val find_from: [> `Read] t -> int -> [> `Read] t -> int option val rfind : [> `Read] t -> [> `Read] t -> int option val rfind_from: [> `Read] t -> int -> [> `Read] t -> int option val split : [> `Read] t -> by:[> `Read] t -> (_ t * _ t) option val rsplit : [> `Read] t -> by:[> `Read] t -> (_ t * _ t) option end (* String.Cap.Exceptionless *) end (**/**) (* The following is for system use only. Do not call directly. *) external unsafe_get : string -> int -> char = "%string_unsafe_get" external unsafe_set : Bytes.t -> int -> char -> unit = "%string_unsafe_set" external unsafe_blit : string -> int -> Bytes.t -> int -> int -> unit = "caml_blit_string" ##V<4.3## "noalloc" ##V>=4.3## [@@noalloc] external unsafe_fill : Bytes.t -> int -> int -> char -> unit = "caml_fill_string" ##V<4.3## "noalloc" ##V>=4.3## [@@noalloc] (**/**) batteries-included-3.4.0/src/batString.mlv000066400000000000000000001246321415601150500205370ustar00rootroot00000000000000(* * BatString - Additional functions for string manipulations. * Copyright (C) 2003 Nicolas Cannasse * 2008 David Teller * 2008 Edgar Friendly * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) include String let compare = String.compare (*$T compare compare "FOO" "bar" = -1 *) let equal a b = String.compare a b = 0 let ord = BatOrd.ord String.compare let init = BatBytesCompat.string_init (*$T init init 5 (fun i -> BatChar.chr (i + int_of_char '0')) = "01234"; *) let of_bytes = Bytes.to_string let to_bytes = Bytes.of_string (* named alias for operator *) let cat = (^) let starts_with str p = let len = length p in if length str < len then false else (* length str >= length p *) let rec loop str p i = if i = len then true else (* 0 <= i < length p *) if unsafe_get str i <> unsafe_get p i then false else loop str p (i + 1) in loop str p 0 (*$T starts_with starts_with "foobarbaz" "foob" starts_with "foobarbaz" "" starts_with "" "" not (starts_with "bar" "foobar") not (starts_with "" "foo") starts_with "Jon \"Maddog\" Orwant" "Jon" not (starts_with "Jon \"Maddog\" Orwant" "Jon \"Maddog\" Orwants") not (starts_with "Jon \"Maddog\" Orwant" "Orwants") *) let starts_with_stdlib ~prefix s = starts_with s prefix let for_all p s = BatBytes.(for_all p (unsafe_of_string s)) (* Bytes.for_all already has a unit test *) let ends_with str p = let el = length p and sl = length str in let diff = sl - el in (* diff = length str - length p *) if diff < 0 then false (*string is too short*) else (* diff >= 0 *) let rec loop str p diff i = if i = el then true else (* 0 <= i < length p *) (* diff = length str - length p ==> diff <= i + diff < length str *) if unsafe_get str (diff + i) <> unsafe_get p i then false else loop str p diff (i + 1) in loop str p diff 0 (*$T ends_with ends_with "foobarbaz" "rbaz" ends_with "foobarbaz" "" ends_with "" "" not (ends_with "foo" "foobar") not (ends_with "" "foo") ends_with "Jon \"Maddog\" Orwant" "want" not (ends_with "Jon \"Maddog\" Orwant" "I'm Jon \"Maddog\" Orwant") not (ends_with "Jon \"Maddog\" Orwant" "Jon") *) let ends_with_stdlib ~suffix s = ends_with s suffix let find_from str pos sub = let len = length str in let sublen = length sub in if pos < 0 || pos > len then invalid_arg "String.find_from"; if sublen = 0 then pos else let rec find ~str ~sub i = if i > len - sublen then raise Not_found else (* 0 <= i <= length str - length sub *) let rec loop ~str ~sub i j = if j = sublen then i else (* 0 <= j < length sub *) (* ==> 0 <= i + j < length str *) if unsafe_get str (i + j) <> unsafe_get sub j then find ~str ~sub (i + 1) else loop ~str ~sub i (j + 1) in loop ~str ~sub i 0 in find ~str ~sub pos (*$Q find_from (Q.triple Q.string Q.char Q.small_int) ~count:1000 (fun (s, c, ofs) -> \ let v1 = try `res (find_from s ofs (String.make 1 c)) with Not_found -> `nf | Invalid_argument _ -> `inv in \ let v2 = try `res (String.index_from s ofs c) with Not_found -> `nf | Invalid_argument _ -> `inv in \ (match v1, v2 with `res s1, `res s2 when s1 = s2 -> true | `nf, `nf | `inv, `inv -> true | _ -> false) \ ) (Q.triple Q.string Q.string Q.small_int) ~count:1000 (fun (s, s2, ofs) -> \ let v1 = try `res (ofs + find (String.sub s ofs (String.length s - ofs)) s2) with Not_found -> `nf | Invalid_argument _ -> `inv in \ let v2 = try `res (find_from s ofs s2) with Not_found -> `nf | Invalid_argument _ -> `inv in \ (match v1, v2 with `res s1, `res s2 when s1 = s2 -> true | `nf, `nf | `inv, `inv -> true | _ -> false) \ ) *) (*$T find_from find_from "foobarbaz" 4 "ba" = 6 find_from "foobarbaz" 7 "" = 7 try ignore (find_from "" 0 "a"); false with Not_found -> true try ignore (find_from "foo" 2 "foo"); false with Not_found -> true try ignore (find_from "foo" 3 "foo"); false with Not_found -> true try ignore (find_from "foo" 4 "foo"); false with Invalid_argument _ -> true try ignore (find_from "foo" (-1) "foo"); false with Invalid_argument _ -> true *) let find str sub = find_from str 0 sub (*$T find find "foobarbaz" "bar" = 3 try ignore (find "foo" "bar"); false with Not_found -> true *) let rfind_from str pos sub = let sublen = length sub and len = length str in if pos + 1 < 0 || pos + 1 > len then invalid_arg "String.rfind_from"; (* 0 <= pos + 1 <= length str *) if sublen = 0 then pos + 1 else (* length sub > 0 *) (* (pos + 1 - sublen) <= length str - length sub < length str *) let rec find ~str ~sub i = if i < 0 then raise Not_found else (* 0 <= i <= length str - length sub < length str *) let rec loop ~str ~sub i j = if j = sublen then i else (* 0 <= j < length sub *) (* ==> 0 <= i + j < length str *) if unsafe_get str (i + j) <> unsafe_get sub j then find ~str ~sub (i - 1) else loop ~str ~sub i (j + 1) in loop ~str ~sub i 0 in find ~str ~sub (pos - sublen + 1) (*$Q rfind_from (Q.triple Q.string Q.char Q.small_int) ~count:1000 (fun (s, c, ofs) -> \ let v1 = try `res (rfind_from s ofs (String.make 1 c)) with Not_found -> `nf | Invalid_argument _ -> `inv in \ let v2 = try `res (String.rindex_from s ofs c) with Not_found -> `nf | Invalid_argument _ -> `inv in \ (match v1, v2 with `res s1, `res s2 when s1 = s2 -> true | `nf, `nf | `inv, `inv -> true | _ -> false) \ ) (Q.triple Q.string Q.string Q.small_int) ~count:1000 (fun (s, s2, ofs) -> \ let v1 = try `res (rfind (String.sub s 0 (ofs + 1)) s2) with Not_found -> `nf | Invalid_argument _ -> `inv in \ let v2 = try `res (rfind_from s ofs s2) with Not_found -> `nf | Invalid_argument _ -> `inv in \ (match v1, v2 with `res s1, `res s2 when s1 = s2 -> true | `nf, `nf | `inv, `inv -> true | _ -> false) \ ) *) (*$T rfind_from rfind_from "foobarbaz" 5 "ba" = 3 rfind_from "foobarbaz" 7 "ba" = 6 rfind_from "foobarbaz" 6 "ba" = 3 rfind_from "foobarbaz" 7 "" = 8 try ignore (rfind_from "" 3 ""); false with Invalid_argument _ -> true try ignore (rfind_from "" (-1) "a"); false with Not_found -> true try ignore (rfind_from "foobarbaz" 2 "ba"); false with Not_found -> true try ignore (rfind_from "foo" 3 "foo"); false with Invalid_argument _ -> true try ignore (rfind_from "foo" (-2) "foo"); false with Invalid_argument _ -> true *) let rfind str sub = rfind_from str (String.length str - 1) sub (*$T rfind rfind "foobarbaz" "ba" = 6 try ignore (rfind "foo" "barr"); false with Not_found -> true *) let index_after_n chr n str = if n < 0 then raise (Invalid_argument "String.index_after_n: n < 0") else let rec loop n i = if n = 0 then i else let i = String.index_from str i chr in loop (n - 1) (i + 1) in loop n 0 (*$T index_after_n index_after_n ',' 0 "aa,bb,cc" = 0 index_after_n ',' 1 "aa,bb,cc" = 3 index_after_n ',' 2 "aa,bb,cc" = 6 index_after_n ',' 0 "" = 0 index_after_n '-' 0 "aa,bb,cc" = 0 try ignore (index_after_n ',' (-1) "aa,bb,cc"); false with Invalid_argument _ -> true try ignore (index_after_n ',' 3 "aa,bb,cc"); false with Not_found -> true try ignore (index_after_n '-' 1 "aa,bb,cc"); false with Not_found -> true index_after_n ',' 0 ",ab" = 0 index_after_n ',' 1 ",ab" = 1 index_after_n ',' 1 "a,,b" = 2 index_after_n ',' 2 "a,,b" = 3 index_after_n ',' 1 "a," = 2 *) let find_all str sub = (* enumerator *) let next r () = try let i = find_from str !r sub in r := i+1; i with Not_found -> raise BatEnum.No_more_elements in let count r () = let n = ref 0 in let r' = BatRef.copy r in begin try while true do ignore (next r' ()); incr n; done; with BatEnum.No_more_elements -> (); end; !n in let rec clone r () = make (BatRef.copy r) and make r = BatEnum.make ~next:(next r) ~count:(count r) ~clone:(clone r) in let r = ref 0 in make r (*$T find_all find_all "aaabbaabaaa" "aa" |> List.of_enum = [0;1;5;8;9] find_all "abcde" "bd" |> List.of_enum = [] find_all "baaaaaaaaaaaaaaaaaaaab" "baa" |> List.of_enum = [0] find_all "aaabbaabaaa" "aa" |> Enum.skip 1 |> Enum.clone \ |> List.of_enum = [1;5;8;9] find_all "aaabbaabaaa" "aa" |> Enum.skip 1 |> Enum.count = 4 find_all "" "foo" |> BatEnum.is_empty let e = find_all "aaabbaabaaa" "aa" in \ Enum.drop 2 e; let e' = Enum.clone e in \ (List.of_enum e = [5;8;9]) && (Enum.skip 1 e' |> List.of_enum = [8;9]) *) let count_string str sub = if sub = "" then invalid_arg "String.count_string"; let m = length str in let n = length sub in let rec loop acc i = if i >= m then acc else try let j = find_from str i sub in loop (acc + 1) (j + n) with Not_found -> acc in loop 0 0 (*$T count_string try let _ = count_string "abc" "" in false with Invalid_argument _ -> true count_string "aaa" "a" = 3 count_string "aaa" "aa" = 1 count_string "coucou" "cou" = 2 *) let exists str sub = try ignore (find str sub); true with Not_found -> false (*$T exists exists "foobarbaz" "obar" exists "obar" "obar" exists "foobarbaz" "" exists "" "" not (exists "foobar" "obb") not (exists "" "foo") exists "a" "" not (exists "" "a") exists "ab" "a" exists "ab" "b" not (exists "ab" "c") *) let exists_stdlib p s = BatBytes.(exists p (unsafe_of_string s)) let strip_default = " \t\r\n" let strip ?(chars = strip_default) s = let p = ref 0 in let l = length s in while !p < l && contains chars (unsafe_get s !p) do incr p; done; let p = !p in let l = ref (l - 1) in while !l >= p && contains chars (unsafe_get s !l) do decr l; done; sub s p (!l - p + 1) (*$T strip strip ~chars:" ,()" " boo() bar()" = "boo() bar" strip ~chars:"abc" "abbcbab" = "" *) let left s len = if len >= length s then s else sub s 0 len let right s len = let slen = length s in if len >= slen then s else sub s (slen - len) len let head s pos = left s pos let tail s pos = let slen = length s in if pos >= slen then "" else sub s pos (slen - pos) (*$T left left "abc" 1 = "a" left "ab" 3 = "ab" left "abc" 3 = "abc" left "abc" 10 = "abc" left "abc" 0 = "" *) (*$T right right "abc" 1 = "c" right "ab" 3 = "ab" right "abc" 3 = "abc" right "abc" 0 = "" right "abc" 10 = "abc" *) (*$T tail tail "abc" 1 = "bc" tail "ab" 3 = "" tail "abc" 3 = "" tail "abc" 10 = "" tail "abc" 0 = "abc" *) (*$T head head "abc" 0 = "" head "abc" 10 = "abc" head "abc" 3 = "abc" *) let split str ~by:sep = let p = find str sep in let len = length sep in let slen = length str in sub str 0 p, sub str (p + len) (slen - p - len) (*$T split split "abcGxyzG123" ~by:"G" = ("abc","xyzG123") split "abcGHIzyxGHI123" ~by:"GHI" = ("abc", "zyxGHI123") split "abcGHIzyxGHI123" ~by:"" = ("", "abcGHIzyxGHI123") try split "abcxyz" ~by:"G" |> ignore; false with Not_found -> true split "abcabc" ~by:"abc" = ("", "abc") split "abcabcd" ~by:"abcd" = ("abc", "") *) let rsplit str ~by:sep = let p = rfind str sep in let len = length sep in let slen = length str in sub str 0 p, sub str (p + len) (slen - p - len) (*$T rsplit rsplit "abcGxyzG123" ~by:"G" = ("abcGxyz","123") rsplit "abcGHIzyxGHI123" ~by:"GHI" = ("abcGHIzyx", "123") rsplit "abcGHIzyxGHI123" ~by:"" = ("abcGHIzyxGHI123", "") try rsplit "abcxyz" ~by:"G" |> ignore; false with Not_found -> true *) (* An implementation of [split_on_string] in one pass. This implementation traverses the string backwards, hence building the list of substrings from the end to the beginning, so as to avoid a call to [List.rev]. *) let split_on_string_comp ?(on_empty=[""]) ~by:sep str = if str = "" then on_empty else if sep = "" then invalid_arg "String.split_on_string: empty sep not allowed" else (* str is non empty *) let seplen = String.length sep in let rec aux acc ofs = if ofs >= 0 then ( match try Some (rfind_from str ofs sep) with Not_found -> None with | Some idx -> (* sep found *) let end_of_sep = idx + seplen - 1 in if end_of_sep = ofs (* sep at end of str *) then aux (""::acc) (idx - 1) else let token = sub str (end_of_sep + 1) (ofs - end_of_sep) in aux (token::acc) (idx - 1) | None -> (* sep NOT found *) (sub str 0 (ofs + 1))::acc ) else (* Negative ofs: the last sep started at the beginning of str *) ""::acc in aux [] (length str - 1 ) let nsplit str ~by = split_on_string_comp ~on_empty:[] ~by str let split_on_string ~by str = split_on_string_comp ~by str (*$T split_on_string split_on_string ~by:";" "a;b;c" = ["a"; "b"; "c"] split_on_string ~by:"x" "" = [""] try split_on_string ~by:"" "abc" = ["a"; "b"; "c"] with Invalid_argument _ -> true split_on_string ~by:"/" "a/b/c" = ["a"; "b"; "c"] split_on_string ~by:"/" "/a/b/c//" = [""; "a"; "b"; "c"; ""; ""] split_on_string ~by:"FOO" "FOOaFOObFOOcFOOFOO" = [""; "a"; "b"; "c"; ""; ""] *) let split_on_char sep str = if str = "" then [""] else (* str is non empty *) let rec loop acc ofs limit = if ofs < 0 then sub str 0 limit :: acc (* ofs >= 0 && ofs < length str *) else if unsafe_get str ofs <> sep then loop acc (ofs - 1) limit else loop (sub str (ofs + 1) (limit - ofs - 1) :: acc) (ofs - 1) ofs in let len = length str in loop [] (len - 1) len (*$T split_on_char split_on_char ';' "a;b;c" = ["a"; "b"; "c"] split_on_char 'x' "" = [""] split_on_char '/' "a/b/c" = ["a"; "b"; "c"] split_on_char '/' "/a/b/c//" = [""; "a"; "b"; "c"; ""; ""] *) let cut_on_char chr pos str = let i = index_after_n chr pos str in let j = try index_from str i chr with Not_found -> length str in sub str i (j - i) (*$T cut_on_char cut_on_char ',' 0 "aa,bb,cc" = "aa" cut_on_char ',' 1 "aa,bb,cc" = "bb" cut_on_char ',' 2 "aa,bb,cc" = "cc" cut_on_char '-' 0 "aa,bb,cc" = "aa,bb,cc" cut_on_char ',' 0 "" = "" try ignore (cut_on_char ',' (-1) "aa,bb,cc"); false with Invalid_argument _ -> true try ignore (cut_on_char ',' 3 "aa,bb,cc"); false with Not_found -> true try ignore (cut_on_char '-' 1 "aa,bb,cc"); false with Not_found -> true cut_on_char ',' 0 ",ab" = "" cut_on_char ',' 1 "a,,b" = "" cut_on_char ',' 1 "a," = "" *) let join = concat let unsafe_slice i j s = if i >= j || i = length s then "" else sub s i (j-i) let clip ~lo ~hi (x:int) = if x < lo then lo else if x > hi then hi else x let wrap (x:int) ~hi = if x < 0 then hi + x else x let slice ?(first = 0) ?(last = Sys.max_string_length) s = let lo = 0 and hi = length s in let i = clip ~lo ~hi (wrap first ~hi) in let j = clip ~lo ~hi (wrap last ~hi) in unsafe_slice i j s (*$T slice slice ~first:1 ~last:(-3) " foo bar baz" = "foo bar " slice "foo" = "foo" slice ~first:0 ~last:10 "foo" = "foo" slice ~first:(-2) "foo" = "oo" slice ~first:(-3) ~last:(-1) "foob" = "oo" slice ~first:5 ~last:4 "foobarbaz" = "" *) let lchop ?(n = 1) s = if n < 0 then invalid_arg "String.lchop: number of characters to chop is negative" else let slen = length s in if slen <= n then "" else sub s n (slen - n) (*$T lchop lchop "Weeble" = "eeble" lchop "" = "" lchop ~n:3 "Weeble" = "ble" lchop ~n:1000 "Weeble" = "" lchop ~n:0 "Weeble" = "Weeble" try ignore (lchop ~n:(-1) "Weeble"); false with Invalid_argument _ -> true *) let rchop ?(n = 1) s = if n < 0 then invalid_arg "String.rchop: number of characters to chop is negative" else let slen = length s in if slen <= n then "" else sub s 0 (slen - n) (*$T rchop rchop "Weeble" = "Weebl" rchop "" = "" rchop ~n:3 "Weeble" = "Wee" rchop ~n:1000 "Weeble" = "" try ignore (rchop ~n:(-1) "Weeble"); false with Invalid_argument _ -> true *) let chop ?(l = 1) ?(r = 1) s = if l < 0 then invalid_arg "String.chop: number of characters to chop on the left is negative"; if r < 0 then invalid_arg "String.chop: number of characters to chop on the right is negative"; let slen = length s in if slen < l + r then "" else sub s l (slen - l - r) (*$T chop chop "\"Weeble\"" = "Weeble" chop "" = "" chop ~l:2 ~r:3 "01234567" = "234" chop ~l:1000 "Weeble" = "" chop ~r:1000 "Weeble" = "" try ignore (chop ~l:(-1) "Weeble"); false with Invalid_argument _ -> true try ignore (chop ~r:(-1) "Weeble"); false with Invalid_argument _ -> true *) let of_int = string_of_int (*$T of_int of_int 56 = "56" of_int (-1) = "-1" *) let of_float = string_of_float let of_char = make 1 (*$T of_char of_char 's' = "s" of_char '\000' = "\000" *) let to_int s = int_of_string s (*$T to_int to_int "8_480" = to_int "0x21_20" try ignore (to_int ""); false with Failure "int_of_string" -> true try ignore (to_int "2,3"); false with Failure "int_of_string" -> true *) let to_float s = float_of_string s (*$T to_float to_float "12.34e-1" = to_float "1.234" to_float "1" = 1. try ignore (to_float ""); false with Failure _ -> true *) let enum s = let l = length s in let rec make i = BatEnum.make ~next:(fun () -> if !i = l then raise BatEnum.No_more_elements else unsafe_get s (BatRef.post_incr i) ) ~count:(fun () -> l - !i) ~clone:(fun () -> make (BatRef.copy i)) in make (ref 0) (*$T enum "" |> enum |> List.of_enum = [] "foo" |> enum |> List.of_enum = ['f'; 'o'; 'o'] let e = enum "abcdef" in \ for _i = 0 to 2 do BatEnum.junk e done; \ let e2 = BatEnum.clone e in \ implode (BatList.of_enum e) = "def" && implode (BatList.of_enum e2) = "def" *) let backwards s = let rec make i = BatEnum.make ~next:(fun () -> if !i <= 0 then raise BatEnum.No_more_elements else unsafe_get s (BatRef.pre_decr i) ) ~count:(fun () -> !i) ~clone:(fun () -> make (BatRef.copy i)) in make (ref (length s)) (*$T backwards "" |> backwards |> of_enum = "" "foo" |> backwards |> of_enum = "oof" let e = backwards "abcdef" in \ for _i = 0 to 2 do BatEnum.junk e done; \ let e2 = BatEnum.clone e in \ implode (BatList.of_enum e) = "cba" && implode (BatList.of_enum e2) = "cba" *) let of_enum e = (* TODO: use a buffer when not fast_count *) let l = BatEnum.count e in let s = Bytes.create l in let i = ref 0 in BatEnum.iter (fun c -> Bytes.unsafe_set s (BatRef.post_incr i) c) e; Bytes.unsafe_to_string s (*$T of_enum Enum.init 3 (fun i -> char_of_int (i + int_of_char '0')) |> of_enum = "012" Enum.init 0 (fun _i -> ' ') |> of_enum = "" *) let of_backwards e = (* TODO: use a buffer when not fast_count *) let l = BatEnum.count e in let s = Bytes.create l in let i = ref (l - 1) in BatEnum.iter (fun c -> Bytes.unsafe_set s (BatRef.post_decr i) c) e; Bytes.unsafe_to_string s (*$T of_backwards "" |> enum |> of_backwards = "" "foo" |> enum |> of_backwards = "oof" "foo" |> backwards |> of_backwards = "foo" *) let map f s = let len = length s in let sc = Bytes.create len in for i = 0 to len - 1 do Bytes.unsafe_set sc i (f (unsafe_get s i)) done; Bytes.unsafe_to_string sc (*$T map map Char.uppercase "Five" = "FIVE" map Char.uppercase "" = "" map (String.of_char %> failwith) "" = "" *) let mapi f s = let len = length s in let sc = Bytes.create len in for i = 0 to len - 1 do Bytes.unsafe_set sc i (f i (unsafe_get s i)) done; Bytes.unsafe_to_string sc (*$T mapi mapi (fun _ -> Char.uppercase) "Five" = "FIVE" mapi (fun _ -> Char.uppercase) "" = "" mapi (fun _ -> String.of_char %> failwith) "" = "" mapi (fun i _c -> "0123456789".[9-i]) "0123456789" = "9876543210" ignore (let last = ref (-1) in mapi (fun i _c -> assert (i > !last); last := i; '0') "012345"); true *) let filter_map f s = let len = length s in let sc = Buffer.create len in for i = 0 to len - 1 do match f (unsafe_get s i) with | Some c -> Buffer.add_char sc c | None -> () done; Buffer.contents sc (*$T filter_map filter_map (function 'a'..'z' as c -> Some (Char.uppercase c) | _ -> None) "a b c" = "ABC" *) let filter f s = let len = length s in let sc = Buffer.create len in for i = 0 to len - 1 do let c = unsafe_get s i in if f c then Buffer.add_char sc c done; Buffer.contents sc (*$T filter filter ((<>) ' ') "a b c" = "abc" *) (* fold_left and fold_right by Eric C. Cooper *) let fold_left f init str = let n = String.length str in let rec loop i result = if i = n then result else loop (i + 1) (f result (unsafe_get str i)) in loop 0 init (*$T fold_left fold_left (fun li c -> c::li) [] "foo" = ['o';'o';'f'] fold_left max 'a' "apples" = 's' *) let count_char str char = let count = ref 0 in let n = length str in for i = 0 to n - 1 do if (unsafe_get str i) = char then incr count done; !count (*$T count_char count_char "abc" 'd' = 0 count_char "" 'd' = 0 count_char "dad" 'd' = 2 *) let fold_lefti f init str = let n = String.length str in let rec loop i result = if i = n then result (* i >= 0 && i < len str *) else loop (i + 1) (f result i (unsafe_get str i)) in loop 0 init (*$T fold_lefti fold_lefti (fun a i c->(i,c)::a) [] "foo"=[(2,'o');(1,'o');(0,'f')] fold_lefti (fun a i _->i+a) 0 "" = 0 *) let fold_right f str init = let n = String.length str in let rec loop i result = if i = 0 then result else (* i > 0 && i <= len str *) let i' = i - 1 in (* i' >= 0 && i' < len str *) loop i' (f (unsafe_get str i') result) in loop n init (*$T fold_right fold_right List.cons "foo" [] = ['f';'o';'o'] fold_right (fun c a -> if c = ' ' then a+1 else a) "a b c" 0 = 2 *) let fold_righti f str init = let n = String.length str in let rec loop i result = if i = 0 then result else (* i > 0 && i <= len str *) let i' = i - 1 in (* i' >= 0 && i' < len str *) loop i' (f i' (unsafe_get str i') result) in loop n init (*$T fold_righti fold_righti (fun i c a->(i,c)::a) "foo" []=[(0,'f');(1,'o');(2,'o')] fold_righti (fun i _ a -> a + i) "" 0 = 0 *) let iteri f str = for i = 0 to String.length str - 1 do f i (unsafe_get str i) done (*$R iteri let letter_positions word = let positions = Array.make 256 [] in let count_letter pos c = positions.(int_of_char c) <- pos :: positions.(int_of_char c) in iteri count_letter word; Array.mapi (fun c pos -> (char_of_int c, List.rev pos)) positions |> Array.to_list |> List.filter (fun (_c, pos) -> pos <> []) in assert_equal ~msg:"String.iteri test" (letter_positions "hello") ['e',[1]; 'h',[0]; 'l',[2;3]; 'o',[4] ] *) (* explode and implode from the OCaml Expert FAQ. *) let explode s = let rec loop i l = if i < 0 then l else (* i >= 0 && i < length s *) loop (i - 1) (unsafe_get s i :: l) in loop (String.length s - 1) [] (*$T explode explode "foo" = ['f'; 'o'; 'o'] explode "" = [] *) let to_list = explode (*$T to_list to_list "string" |> List.interleave ';' |> of_list = "s;t;r;i;n;g" *) let implode l = let res = Bytes.create (List.length l) in let rec imp i = function | [] -> () | c :: l -> Bytes.set res i c; imp (i + 1) l in imp 0 l; Bytes.unsafe_to_string res (*$T implode implode ['b';'a';'r'] = "bar" implode [] = "" *) let of_list = implode (*$T of_list ['c'; 'h'; 'a'; 'r'; 's'] |> of_list = "chars" [] |> of_list = "" *) let replace_chars f s = let len = String.length s in let tlen = ref 0 in let rec loop i acc = if i = len then acc else let s = f (unsafe_get s i) in tlen := !tlen + length s; loop (i+1) (s :: acc) in let strs = loop 0 [] in let sbuf = Bytes.create !tlen in let pos = ref !tlen in let rec loop2 = function | [] -> () | s :: acc -> let len = length s in pos := !pos - len; Bytes.blit_string s 0 sbuf !pos len; loop2 acc in loop2 strs; Bytes.unsafe_to_string sbuf (*$T replace_chars replace_chars (function ' ' -> "(space)" | c -> of_char c) "foo bar" = "foo(space)bar" replace_chars (fun _ -> "") "foo" = "" replace_chars (fun _ -> assert false) "" = "" *) let replace ~str ~sub ~by = try let subpos = find str sub in let strlen = length str in let sublen = length sub in let bylen = length by in let newstr = Bytes.create (strlen - sublen + bylen) in blit str 0 newstr 0 subpos ; blit by 0 newstr subpos bylen ; blit str (subpos + sublen) newstr (subpos + bylen) (strlen - subpos - sublen) ; (true, Bytes.unsafe_to_string newstr) with Not_found -> (* find failed *) (false, str) (*$T replace replace ~str:"foobarbaz" ~sub:"bar" ~by:"rab" = (true, "foorabbaz") replace ~str:"foo" ~sub:"bar" ~by:"" = (false, "foo") *) let nreplace ~str ~sub ~by = if sub = "" then invalid_arg "String.nreplace: cannot replace all empty substrings" ; let strlen = length str in let sublen = length sub in let bylen = length by in let dlen = bylen - sublen in let rec loop_subst idxes newlen i = match (try rfind_from str (i-1) sub with Not_found -> -1) with | -1 -> idxes, newlen | i' -> loop_subst (i'::idxes) (newlen+dlen) i' in let idxes, newlen = loop_subst [] strlen strlen in let newstr = Bytes.create newlen in let rec loop_copy i j idxes = match idxes with | [] -> (* still need the last chunk *) Bytes.blit_string str i newstr j (strlen-i) | i'::rest -> let di = i' - i in Bytes.blit_string str i newstr j di ; Bytes.blit_string by 0 newstr (j + di) bylen ; loop_copy (i + di + sublen) (j + di + bylen) rest in loop_copy 0 0 idxes ; Bytes.unsafe_to_string newstr (*$T nreplace nreplace ~str:"bar foo aaa bar" ~sub:"aa" ~by:"foo" = "bar foo afoo bar" nreplace ~str:"bar foo bar" ~sub:"bar" ~by:"foo" = "foo foo foo" nreplace ~str:"aaaaaa" ~sub:"aa" ~by:"aaa" = "aaaaaaaaa" nreplace ~str:"" ~sub:"aa" ~by:"bb" = "" nreplace ~str:"foo bar baz" ~sub:"foo bar baz" ~by:"" = "" nreplace ~str:"abc" ~sub:"abc" ~by:"def" = "def" *) let rev_in_place s = let len = Bytes.length s in if len > 0 then for k = 0 to (len - 1)/2 do let old = Bytes.get s k and mirror = len - 1 - k in Bytes.set s k (Bytes.get s mirror); Bytes.set s mirror old; done (*$= rev_in_place as f & ~printer:identity (let s=Bytes.of_string "" in f s; Bytes.to_string s) "" (let s=Bytes.of_string "1" in f s; Bytes.to_string s) "1" (let s=Bytes.of_string "12" in f s; Bytes.to_string s) "21" (let s=Bytes.of_string "Example!" in f s; Bytes.to_string s) "!elpmaxE" *) let in_place_mirror = rev_in_place let repeat s n = let buf = Buffer.create ( n * (String.length s) ) in for _i = 1 to n do Buffer.add_string buf s done; Buffer.contents buf (*$T repeat repeat "fo" 4 = "fofofofo" repeat "fo" 0 = "" repeat "" 4 = "" *) let rev s = let len = String.length s in let reversed = Bytes.create len in for i = 0 to len - 1 do Bytes.unsafe_set reversed (len - i - 1) (unsafe_get s i) done; Bytes.unsafe_to_string reversed (*$T rev rev "" = "" rev "batteries" = "seirettab" rev "even" = "neve" *) let trim s = let len = length s in let rec aux_1 i = (*locate leading whitespaces*) if i = len then None (*The whole string is whitespace*) else if BatChar.is_whitespace (unsafe_get s i) then aux_1 (i + 1) else Some i in match aux_1 0 with | None -> "" | Some last_leading_whitespace -> let rec aux_2 i = assert (i >= 0); if BatChar.is_whitespace (unsafe_get s i) then aux_2 (i - 1) else i in let first_trailing_whitespace = aux_2 (len - 1) in unsafe_slice last_leading_whitespace (first_trailing_whitespace + 1) s (*$T trim trim " \t foo\n " = "foo" trim " foo bar " = "foo bar" trim " \t " = "" trim "" = "" *) let splice s1 off len s2 = let len1 = length s1 and len2 = length s2 in let off = wrap off ~hi:len1 in let len = clip ~lo:0 ~hi:(len1 - off) len in let out_len = len1 - len + len2 in let s = Bytes.create out_len in Bytes.blit_string s1 0 s 0 off; (* s1 before splice point *) Bytes.blit_string s2 0 s off len2; (* s2 at splice point *) Bytes.blit_string (* s1 after off+len *) s1 (off+len) s (off+len2) (len1 - (off+len)); Bytes.unsafe_to_string s (*$T splice splice "foo bar baz" 3 5 "XXX" = "fooXXXbaz" splice "foo bar baz" 5 0 "XXX" = "foo bXXXar baz" splice "foo bar baz" 5 (-10) "XXX" = "foo bXXXar baz" splice "foo bar baz" 5 50 "XXX" = "foo bXXX" splice "foo bar baz" (-4) 2 "XXX" = "foo barXXXaz" splice "bar baz" (-4) 2 "XXX" = "barXXXaz" *) let empty = "" let is_empty s = length s = 0 (*$T is_empty is_empty "" not (is_empty "foo") is_empty (String.make 0 'a') *) let icompare s1 s2 = compare (String.lowercase s1) (String.lowercase s2) (*$T icompare icompare "FOO" "bar" = 1 *) type t_alias = t (* needed for IString breaks type t = t *) module IString = struct type t = t_alias let compare = icompare end let numeric_compare s1 s2 = let e1 = BatEnum.group BatChar.is_digit (enum s1) in let e2 = BatEnum.group BatChar.is_digit (enum s2) in BatEnum.compare (fun g1 g2 -> let s1 = of_enum g1 in let s2 = of_enum g2 in if BatChar.is_digit s1.[0] && BatChar.is_digit s2.[0] then let n1 = Big_int.big_int_of_string s1 in let n2 = Big_int.big_int_of_string s2 in Big_int.compare_big_int n1 n2 else String.compare s1 s2 ) e1 e2 (*$T numeric_compare numeric_compare "xx43" "xx320" = -1 numeric_compare "xx3" "xx21" = -1 numeric_compare "xx02" "xx2" = 0 numeric_compare "xx20" "xx5" = 1 numeric_compare "abc" "def" = compare "abc" "def" numeric_compare "x50y" "x51y" = -1 numeric_compare "a23d" "a234" < 0 numeric_compare "a234" "a23d" > 0 numeric_compare "a1b" "a01c" < 0 numeric_compare "a1b" "a01b" = 0 numeric_compare "a1b2" "a01b01" > 0 *) (*$Q numeric_compare (Q.triple Q.printable_string Q.pos_int Q.pos_int) (fun (s,m,n) -> numeric_compare (s ^ string_of_int m) (s ^ string_of_int n) = BatInt.compare m n) *) ##V<4.3##let uppercase_ascii s = map BatChar.uppercase_ascii s ##V<4.3##let lowercase_ascii s = map BatChar.lowercase_ascii s (*$T uppercase_ascii equal ("five" |> uppercase_ascii) "FIVE" equal ("école" |> uppercase_ascii) "éCOLE" *) (*$T lowercase_ascii equal ("FIVE" |> lowercase_ascii) "five" equal ("ÉCOLE" |> lowercase_ascii) "École" *) ##V<4.3##let map_first_char f s = ##V<4.3## let r = Bytes.of_string s in ##V<4.3## if Bytes.length r > 0 then ##V<4.3## Bytes.unsafe_set r 0 (f (unsafe_get s 0)); ##V<4.3## Bytes.unsafe_to_string r ##V<4.3##let capitalize_ascii s = map_first_char BatChar.uppercase_ascii s ##V<4.3##let uncapitalize_ascii s = map_first_char BatChar.lowercase_ascii s (*$T capitalize_ascii equal ("five" |> capitalize_ascii) "Five" equal ("école" |> capitalize_ascii) "école" *) (*$T uncapitalize_ascii equal ("Five" |> uncapitalize_ascii) "five" equal ("École" |> uncapitalize_ascii) "École" *) module NumString = struct type t = t_alias let compare = numeric_compare end module A = Array let edit_distance s1 s2 = let len1 = String.length s1 in let len2 = String.length s2 in if len1 = 0 then len2 else if len2 = 0 then len1 else if s1 = s2 then 0 else begin (* distance vectors (v0=previous, v1=current) *) let v0 = A.make (len2 + 1) 0 in let v1 = A.make (len2 + 1) 0 in (* initialize v0: v0(i) = A(0)(i) = delete i chars from t *) for i = 0 to len2 do A.unsafe_set v0 i i done; (* main loop for the bottom up dynamic algorithm *) for i = 0 to len1 - 1 do (* first edit distance is the deletion of i+1 elements from s *) A.unsafe_set v1 0 (i + 1); (* try add/delete/replace operations *) for j = 0 to len2 - 1 do (* i >= 0 && i < length s1 *) (* j >= 0 && j < length s2 *) let cost = if unsafe_get s1 i = unsafe_get s2 j then 0 else 1 in A.unsafe_set v1 (j + 1) (min ((A.unsafe_get v1 j) + 1) (min ((A.unsafe_get v0 (j + 1)) + 1) ((A.unsafe_get v0 j) + cost))); done; (* copy v1 into v0 for next iteration *) A.blit v1 0 v0 0 (len2 + 1); done; A.unsafe_get v1 len2 end (*$T edit_distance edit_distance "foo" "fo0" = 1 edit_distance "hello" "hell" = 1 edit_distance "kitten" "sitton" = 2 *) (*$Q edit_distance Q.(pair string string) (fun (s1, s2) -> edit_distance s1 s2 = edit_distance s2 s1) *) let print = BatInnerIO.nwrite let println out s = BatInnerIO.nwrite out s; BatInnerIO.write out '\n' (*$T BatIO.to_string print "\n" = "\n" BatIO.to_string println "\n" = "\n\n" BatIO.to_string print_quoted "\n" = "\"\\n\"" quote "\n" = "\"\\n\"" *) (* Beware: the documentation of print_quoted claims that its behavior is compatible with this "quote" function. This is currently true as they both use "%S", but any change in 'quote' here should be careful to preserve this consistency. *) let quote s = Printf.sprintf "%S" s (*$T quote quote "foo" = "\"foo\"" quote "\"foo\"" = "\"\\\"foo\\\"\"" quote "\n" = "\"\\n\"" *) let print_quoted out s = BatInnerIO.nwrite out (quote s) module Exceptionless = struct let find_from str ofs sub = try Some (find_from str ofs sub) with Not_found -> None let find str sub = find_from str 0 sub (*$T Exceptionless.find "a" "b" = None *) let rfind_from str suf sub = try Some (rfind_from str suf sub) with Not_found -> None let rfind str sub = rfind_from str (String.length str - 1) sub (*$T Exceptionless.rfind "a" "b" = None *) let to_int s = try Some (to_int s) with Failure _ -> None (*$T Exceptionless.to_int "" = None *) let to_float s = try Some (to_float s) with Failure _ -> None (*$T Exceptionless.to_float "" = None *) let index s c = try Some (index s c) with Not_found -> None (*$T Exceptionless.index "a" 'b' = None *) let index_from s i c = try Some (index_from s i c) with Not_found -> None (*$T Exceptionless.index_from "a" 0 'b' = None *) let rindex_from s i c = try Some (rindex_from s i c) with Not_found -> None (*$T Exceptionless.rindex_from "a" 0 'b' = None *) let rindex s c = try Some (rindex s c) with Not_found -> None (*$T Exceptionless.rindex "a" 'b' = None *) let split str ~by = try Some (split str ~by) with Not_found -> None (*$T Exceptionless.split "a" ~by:"e" = None *) let rsplit str ~by = try Some (rsplit str ~by) with Not_found -> None (*$T Exceptionless.rsplit "a" ~by:"e" = None *) end (* String.Exceptionless *) ##V<4.5##let index_opt = Exceptionless.index ##V<4.5##let rindex_opt = Exceptionless.rindex ##V<4.5##let index_from_opt = Exceptionless.index_from ##V<4.5##let rindex_from_opt = Exceptionless.rindex_from external get_uint8 : string -> int -> int = "%string_safe_get" ##V>=4.08##let get_int8 s i = Bytes.(get_int8 (unsafe_of_string s) i) ##V>=4.08##let get_uint16_le s i = Bytes.(get_uint16_le (unsafe_of_string s) i) ##V>=4.08##let get_uint16_be s i = Bytes.(get_uint16_be (unsafe_of_string s) i) ##V>=4.08##let get_uint16_ne s i = Bytes.(get_uint16_ne (unsafe_of_string s) i) ##V>=4.08##let get_int16_ne s i = Bytes.(get_int16_ne (unsafe_of_string s) i) ##V>=4.08##let get_int16_le s i = Bytes.(get_int16_le (unsafe_of_string s) i) ##V>=4.08##let get_int16_be s i = Bytes.(get_int16_be (unsafe_of_string s) i) ##V>=4.08##let get_int32_le s i = Bytes.(get_int32_le (unsafe_of_string s) i) ##V>=4.08##let get_int32_be s i = Bytes.(get_int32_be (unsafe_of_string s) i) ##V>=4.08##let get_int32_ne s i = Bytes.(get_int32_ne (unsafe_of_string s) i) ##V>=4.08##let get_int64_le s i = Bytes.(get_int64_le (unsafe_of_string s) i) ##V>=4.08##let get_int64_be s i = Bytes.(get_int64_be (unsafe_of_string s) i) ##V>=4.08##let get_int64_ne s i = Bytes.(get_int64_ne (unsafe_of_string s) i) module Cap = struct type 'a t = Bytes.t let ubos = Bytes.unsafe_of_string let usob = Bytes.unsafe_to_string let make = Bytes.make let is_empty b = is_empty (usob b) let init n f = ubos (init n f) let enum b = enum (usob b) let of_enum e = ubos (of_enum e) let backwards b = backwards (usob b) let of_backwards e = ubos (of_backwards e) let of_int n = ubos (of_int n) let of_float x = ubos (of_float x) let of_char c = ubos (of_char c) let to_int b = to_int (usob b) let to_float b = to_float (usob b) let map f b = ubos (map f (usob b)) let mapi f b = ubos (mapi f (usob b)) let fold_left f v b = fold_left f v (usob b) let fold_right f b v = fold_right f (usob b) v let fold_lefti f v b = fold_lefti f v (usob b) let fold_righti f b v = fold_righti f (usob b) v let iter f b = iter f (usob b) let index b c = index (usob b) c let rindex b c = rindex (usob b) c let index_from b i c = index_from (usob b) i c let rindex_from b i c = rindex_from (usob b) i c let contains b c = contains (usob b) c let contains_from b i c = contains_from (usob b) i c let rcontains_from b i c = rcontains_from (usob b) i c let find b1 b2 = find (usob b1) (usob b2) let find_from b1 i b2 = find_from (usob b1) i (usob b2) let rfind b1 b2 = rfind (usob b1) (usob b2) let rfind_from b1 i b2 = rfind_from (usob b1) i (usob b2) let ends_with b1 b2 = ends_with (usob b1) (usob b2) let starts_with b1 b2 = starts_with (usob b1) (usob b2) let exists b1 b2 = exists (usob b1) (usob b2) let count_char s c = count_char (usob s) c let lchop ?n b = ubos (lchop ?n (usob b)) let rchop ?n b = ubos (rchop ?n (usob b)) let chop ?l ?r b = ubos (chop ?l ?r (usob b)) let strip ?(chars = ubos strip_default) b = ubos (strip ~chars:(usob chars) (usob b)) let uppercase b = ubos (uppercase (usob b)) let lowercase b = ubos (lowercase (usob b)) let capitalize b = ubos (capitalize (usob b)) let uncapitalize b = ubos (uncapitalize (usob b)) let copy = Bytes.copy let sub = Bytes.sub let fill = Bytes.fill let blit = Bytes.blit let concat = Bytes.concat let escaped = Bytes.escaped let replace_chars f b = ubos (replace_chars (fun c -> usob (f c)) (usob b)) let replace ~str ~sub ~by = let (b, s) = replace ~str:(usob str) ~sub:(usob sub) ~by:(usob by) in (b, ubos s) let nreplace ~str ~sub ~by = ubos (nreplace ~str:(usob str) ~sub:(usob sub) ~by:(usob by)) let split b ~by = let (a, b) = split (usob b) ~by:(usob by) in (ubos a, ubos b) let repeat b i = ubos (repeat (usob b) i) let rsplit b ~by = let (a, b) = rsplit (usob b) ~by:(usob by) in (ubos a, ubos b) let nsplit b ~by = List.map ubos (nsplit (usob b) ~by:(usob by)) let split_on_string ~by b = List.map ubos (split_on_string ~by:(usob by) (usob b)) let join = Bytes.concat let slice ?first ?last b = ubos (slice ?first ?last (usob b)) let explode b = explode (usob b) let implode cs = ubos (implode cs) let compare b1 b2 = compare (usob b1) (usob b2) let icompare b1 b2 = icompare (usob b1) (usob b2) let splice b1 i1 i2 b2 = ubos (splice (usob b1) i1 i2 (usob b2)) let trim b = ubos (trim (usob b)) let quote b = quote (usob b) let left b i = ubos (left (usob b) i) let right b i = ubos (right (usob b) i) let head b i = ubos (head (usob b) i) let tail b i = ubos (tail (usob b) i) let filter_map f b = ubos (filter_map f (usob b)) let filter f b = ubos (filter f (usob b)) let of_list li = ubos (of_list li) let to_list b = to_list (usob b) let print io b = print io (usob b) let println io b = println io (usob b) let print_quoted io b = print_quoted io (usob b) external of_string : Bytes.t -> _ t = "%identity" external of_bytes : Bytes.t -> _ t = "%identity" external to_string : [`Read | `Write] t -> Bytes.t = "%identity" external to_bytes : [`Read | `Write] t -> Bytes.t = "%identity" external read_only : [> `Read] t -> [`Read] t = "%identity" external write_only: [> `Write] t -> [`Write] t = "%identity" external length : _ t -> int = "%string_length" external get : [> `Read] t -> int -> char = "%string_safe_get" external set : [> `Write] t -> int -> char -> unit = "%string_safe_set" external create : int -> _ t = "caml_create_string" external unsafe_get : [> `Read] t -> int -> char = "%string_unsafe_get" external unsafe_set : [> `Write] t -> int -> char -> unit = "%string_unsafe_set" external unsafe_blit : [> `Read] t -> int -> [> `Write] t -> int -> int -> unit = "caml_blit_string" "noalloc" external unsafe_fill : [> `Write] t -> int -> int -> char -> unit = "caml_fill_string" "noalloc" module Exceptionless = struct let find_from b1 i b2 = Exceptionless.find_from (usob b1) i (usob b2) let find b1 b2 = Exceptionless.find (usob b1) (usob b2) let rfind_from b1 i b2 = Exceptionless.rfind_from (usob b1) i (usob b2) let rfind b1 b2 = Exceptionless.rfind (usob b1) (usob b2) let to_int b = Exceptionless.to_int (usob b) let to_float b = Exceptionless.to_float (usob b) let index b c = Exceptionless.index (usob b) c let index_from b i c = Exceptionless.index_from (usob b) i c let rindex_from b i c = Exceptionless.rindex_from (usob b) i c let rindex b c = Exceptionless.rindex (usob b) c let split b ~by = match Exceptionless.split (usob b) ~by:(usob by) with | None -> None | Some (a, b) -> Some (ubos a, ubos b) let rsplit b ~by = match Exceptionless.rsplit (usob b) ~by:(usob by) with | None -> None | Some (a, b) -> Some (ubos a, ubos b) end (* String.Cap.Exceptionless *) end (* String.Cap *) batteries-included-3.4.0/src/batSubstring.ml000066400000000000000000000472271415601150500210670ustar00rootroot00000000000000(* * re-implementation of SML's Substring library in OCaml. * Copyright (C) 2008 Edgar Friendly * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * See http://www.itu.dk/~sestoft/mosmllib/Substring.html for documentation * *) type t = string * int * int (* string, offset, length *) let empty () = "", 0, 0 (*$T to_string (empty () ) = "" *) let to_string (s,o,l) = String.sub s o l (*$T to_string to_string (substring "foobar" 1 3) = "oob" to_string (substring "" 0 0) = "" *) let of_string s = s, 0, String.length s (*$T of_string of_string "foo" = substring "foo" 0 3 of_string "" = empty () *) let make len c = String.make len c, 0, len (*$T make make 3 'f' = substring "fff" 0 3 (make 3 'f' = substring "ffff" 0 3) = false make 0 ' ' = empty () *) let create len = String.make len '\000', 0, len (*$T create create 0 = empty () *) let equal (s1,o1,l1) (s2,o2,l2) = if l1 <> l2 then false else let rec loop i = if i = l1 then true else if s1.[i+o1] <> s2.[i+o2] then false else loop (i + 1) in loop 0 (*$T equal equal (of_string "abc") (of_string "abc") = true equal (substring "aba" 0 1) (substring "aba" 2 1) = true equal (substring "aba" 1 1) (substring "aba" 2 1) = false equal (substring "abc" 0 2) (substring "cab" 1 2) = true *) (* let of_chan chan = let tempsize = 16384 in let buf = Buffer.create tempsize and tmp = String.create tempsize in let n = ref 0 in while n := input chan tmp 0 tempsize; !n > 0 do Buffer.add_substring buf tmp 0 !n; done; Buffer.contents buf, 0, Buffer.length buf *) let of_input inp = let tempsize = 16384 in let buf = Buffer.create tempsize and tmp = Bytes.create tempsize in let n = ref 0 in while n := BatIO.input inp tmp 0 tempsize; !n > 0 do BatBytesCompat.buffer_add_subbytes buf tmp 0 !n; done; Buffer.contents buf, 0, Buffer.length buf let substring str off len = let sl = String.length str in if off < 0 then invalid_arg "Substring.substring: negative offset not allowed"; if len < 0 then invalid_arg "Substring.substring: negative length not allowed"; if off + len > sl then invalid_arg "Substring.substring: offset + length past end of string"; (str,off,len) (*$T substring (try (substring "foo" (-1) 2) with Invalid_argument "Substring.substring: negative offset not allowed" -> (substring "foo" 0 2)) = (substring "foo" 0 2) (try (substring "foo" 0 (-1)) with Invalid_argument "Substring.substring: negative length not allowed" -> (substring "foo" 0 2)) = (substring "foo" 0 2) (try (substring "foo" 0 10) with Invalid_argument "Substring.substring: offset + length past end of string" -> (substring "foo" 0 2)) = (substring "foo" 0 2) to_string (substring "foobar" 1 3) = "oob" *) let unsafe_substring str off len = (str, off, len) (*$T unsafe_substring (unsafe_substring "foobar" 1 3) = (substring "foobar" 1 3) *) let extract s o = function Some len -> substring s o len | None -> substring s o (String.length s - o) (*$T extract extract "foobar" 1 None = substring "foobar" 1 5 extract "foobar" 1 (Some 3) = substring "foobar" 1 3 *) let all = of_string let base s = s (*$T base base (substring "foobar" 1 3) = ("foobar", 1, 3) *) let is_empty (_,_,len) = len = 0 (*$T is_empty is_empty (substring "foobar" 0 0) = true is_empty (substring "foobar" 0 2) = false *) let getc (str,off,len) = if len = 0 then None else Some (str.[off], (str, off+1, len-1)) (*$T getc getc (substring "foobar" 1 3) = Some ('o', substring "foobar" 2 2) getc (empty ()) = None *) let first (str,off,len) = if len = 0 then None else Some str.[off] (*$T first first (substring "foobar" 1 3) = Some 'o' first (substring "foobar" 0 0) = None *) let triml k (str,off,len) = if k < 0 then invalid_arg "Substring.triml: negative trim not allowed"; if k > len then (str, off+len, 0) else (str, off+k, len-k) (*$T triml triml 10 ("foobar" |> of_string ) |> to_string = "" triml 0 (substring "foobar" 1 3) = (substring "foobar" 1 3) triml 1 (substring "foobar" 1 3) = (substring "foobar" 2 2) (try (triml (-5) ("foobar" |> of_string)) with Invalid_argument _ -> substring "foo" 0 3) = substring "foo" 0 3 *) let trimr k (str,off,len) = if k < 0 then invalid_arg "Substring.trimr: negative trim not allowed"; if k > len then (str, off, 0) else (str, off, len-k) (*$T trimr trimr 10 ("foobar" |> of_string ) |> to_string = "" trimr 0 (substring "foobar" 1 3) = (substring "foobar" 1 3) trimr 1 (substring "foobar" 1 3) = (substring "foobar" 1 2) (try (trimr (-5) ("foobar" |> of_string)) with Invalid_argument _ -> substring "foo" 0 3) = substring "foo" 0 3 *) let get (str, off, len) k = if k < 0 then invalid_arg "Substring.get: negative index not allowed"; if k > len then invalid_arg "Substring.get: index outside of substring"; str.[off+k] (*$T get get (substring "foobar" 1 3) 0 = 'o' (try (get (substring "foobar" 1 3) (-1)) with Invalid_argument "Substring.get: negative index not allowed" -> 'a') = 'a' (try (get (substring "foobar" 1 3) 15) with Invalid_argument "Substring.get: index outside of substring" -> 'a') = 'a' *) let size (_,_,len) = len let length = size (*$T size size (substring "foobar" 0 0) = 0 size (substring "foobar" 1 3) = 3 *) let slice (str,off,len) off2 len2_opt = if off2 < 0 then invalid_arg "Substring.slice: negative offset not allowed"; let len2 = match len2_opt with None -> len-off2 | Some i -> i in if len2 + off2 > len then invalid_arg "Substring.slice: invalid slice"; (str, off+off2, len2) (*$T slice (try (slice (substring "foobar" 1 3) (-1) None) with Invalid_argument "Substring.slice: negative offset not allowed" -> empty ()) = empty () (try (slice (substring "foobar" 1 3) 0 (Some 20)) with Invalid_argument "Substring.slice: invalid slice" -> empty ()) = empty () slice (substring "foobar" 1 4) 2 None = (substring "foobar" 3 2) is_empty (slice (substring "foobar" 0 3) 3 None) = true *) let concat ssl = let len = List.fold_left (fun acc (_,_,l) ->acc+l) 0 ssl in let item = Bytes.create len in let write = let pos = ref 0 in fun (s,o,len) -> Bytes.blit_string s o item !pos len; pos := !pos + len in List.iter write ssl; Bytes.unsafe_to_string item (*$T concat concat [empty ()] = "" concat [substring "foobar" 1 3; empty ()] = "oob" concat [empty (); substring "foobar" 1 3] = "oob" concat [substring "foobar" 3 3 ; substring "foobar" 0 3] = "barfoo" *) let explode (str,off,len) = let rec exp i l = if i < off then l else exp (i - 1) (str.[i] :: l) in exp (off+len-1) [] (*$T explode explode (substring "foobar" 1 3) = ['o';'o';'b'] explode (empty ()) = [] *) let is_prefix str1 (str2, off, len) = let l1 = String.length str1 in if l1 > len then false else let rec loop i = if i < 0 then true else if str1.[i] <> str2.[off+i] then false else loop (i-1) in loop (pred l1) (*$T is_prefix is_prefix "foo" (empty ()) = false is_prefix "oob" (substring "foobar" 1 4) = true is_prefix "" (empty ()) = true *) let compare (str1, off1, len1) (str2, off2, len2) = let rec loop i = if i >= len1 then if i >= len2 then 0 else -1 else if i >= len2 then 1 else let c1 = str1.[off1+i] and c2 = str2.[off2+i] in if c1 > c2 then 1 else if c1 < c2 then -1 else loop (i+1) in loop 0 (*$T compare compare (empty ()) (empty ()) = 0 compare (empty ()) (substring "foobar" 1 3) = -1 compare (substring "foobar" 1 3) (empty ()) = 1 compare (substring "foobar" 1 3) (substring "barfoo" 1 3) = 1 *) let index_from (str, off, len) i c = let rec aux k = if k = len then raise Not_found else if str.[off+k] = c then k else aux (k+1) in if i > len || i < 0 then invalid_arg "Substring.index_from" else aux i (*$T index_from (try (index_from (substring "foobar" 1 3) 2 'o') with Not_found -> 0) = 0 (try (index_from (substring "foobar" 1 3) (-3) 'o') with Invalid_argument "Substring.index_from" -> 0) = 0 (try (index_from (substring "foobar" 1 3) 20 'o') with Invalid_argument "Substring.index_from" -> 0) = 0 index_from (substring "foobar" 1 3) 1 'b' = 2 *) let index sus c = index_from sus 0 c (*$T index (try (index (substring "foobar" 1 3) 'y') with Not_found -> 0) = 0 index (substring "foobar" 1 3) 'b' = 2 *) let rindex_from (str, off, len) i c = let rec aux k = if k < 0 then raise Not_found else if str.[off+k] = c then k else aux (k-1) in if i > len || i < 0 then invalid_arg "Substring.rindex_from" else aux i (*$T rindex_from (try (rindex_from (substring "foobar" 1 3) 2 'y') with Not_found -> 0) = 0 (try (rindex_from (substring "foobar" 1 3) (-3) 'o') with Invalid_argument "Substring.rindex_from" -> 0) = 0 (try (rindex_from (substring "foobar" 1 3) 20 'o') with Invalid_argument "Substring.rindex_from" -> 0) = 0 rindex_from (substring "foobar" 1 3) 3 'b' = 2 *) let rindex sus c = rindex_from sus (size sus - 1) c (*$T rindex (try (rindex (substring "foobar" 1 3) 'y') with Not_found -> 0) = 0 rindex (substring "foobar" 1 3) 'b' = 2 *) let contains ss c = try ignore (index ss c); true with Not_found -> false (*$T contains contains (of_string "foobar") 'c' = false contains (of_string "foobar") 'o' = true contains (of_string "") 'Z' = false *) (** not implemented: collate *) let dropl p (str,off,len) = let i = ref 0 in while !i < len && p str.[off+ !i] do incr i; done; (str, off+ !i, len- !i) (*$T dropl dropl (fun c -> c = 'f') (substring "foobar" 0 6) = (substring "foobar" 1 5) dropl (fun c -> c = 'o') (substring "foobar" 0 6) = (substring "foobar" 0 6) dropl (fun c -> c = 'o'||c='f') (substring "foobar" 0 6) = (substring "foobar" 3 3) dropl (fun c -> c = 'o'||c='f') (empty()) = empty () *) let dropr p (str, off, len) = let i = ref len in while !i > 0 && p str.[off+ !i - 1] do decr i; done; (str, off, !i) (*$T dropr dropr (fun c -> c = 'r') (substring "foobar" 0 6) = (substring "foobar" 0 5) dropr (fun c -> c = 'o') (substring "foobar" 0 6) = (substring "foobar" 0 6) dropr (fun c -> c = 'a'||c='r') (substring "foobar" 0 6) = (substring "foobar" 0 4) dropr (fun c -> c = 'o'||c='f') (empty()) = empty () *) let takel p (str,off,len) = let i = ref 0 in while !i < len && p str.[off+ !i] do incr i; done; (str, off, !i) (*$T takel takel (fun c -> c = 'f' || c = 'o') (substring "foobar" 0 6) = (substring "foobar" 0 3) (takel (fun c -> c = 'x') (substring "foobar" 0 6) |> is_empty) = true takel (fun c -> c = 'x') (empty ()) = empty () *) let taker p (str, off, len) = let i = ref len in while !i > 0 && p str.[off+ !i - 1] do decr i; done; (str, off+ !i, len- !i) (*$T taker taker (fun c -> c = 'r' || c = 'a') (substring "foobar" 0 6) = substring "foobar" 4 2 taker (fun c -> c = 'b' || c = 'c') (substring "foobar" 0 6) |> is_empty = true *) let splitl p (str, off, len) = let i = ref 0 in while !i < len && p str.[off+ !i] do incr i; done; (str, off, !i), (str, off+ !i, len- !i) (*$T splitl splitl (fun c -> c = 'f') (substring "foobar" 0 6) = (substring "foobar" 0 1, substring "foobar" 1 5) splitl (fun c -> c = 'f' || c = 'o') (substring "foobar" 0 6) = (substring "foobar" 0 3, substring "foobar" 3 3) splitl (fun c -> c = 'f') (empty ()) = (empty (), empty ()) splitl (fun c -> c = 'o' || c = 'b') (substring "foobar" 0 6) = (substring "foobar" 0 0, substring "foobar" 0 6) *) let splitr p (str, off, len) = let i = ref len in while !i > 0 && p str.[off+ !i - 1] do decr i; done; (str, off, !i), (str, off+ !i, len- !i) (*$T splitr splitr (fun c -> c = 'b' || c = 'o') (substring "foobar" 0 6) = (substring "foobar" 0 6, substring "foobar" 6 0) splitr (fun c -> c = 'b' || c = 'o') (substring "foobar" 0 6) = (substring "foobar" 0 6, substring "foobar" 6 0) splitr (fun c -> c = 'b' || c = 'a' || c = 'r') (substring "foobar" 0 6) = (substring "foobar" 0 3, substring "foobar" 3 3) splitr (fun c -> c = 'y') (empty ()) = (empty (), empty ()) *) let split_at k (str, off, len) = if k < 0 then invalid_arg "Substring.split_at: negative index"; if k > len then invalid_arg "Substring.split_at: can't split past end of string"; (str, off, k), (str, off+k, len-k) (*$T split_at (try (Some (split_at (-1) (empty ()))) with Invalid_argument "Substring.split_at: negative index" -> None ) = None (try (Some (split_at 12 (substring "foobar" 0 6))) with Invalid_argument "Substring.split_at: can't split past end of string" -> None ) = None split_at 3 (substring "foobar" 0 6) = (substring "foobar" 0 3, substring "foobar" 3 3) split_at 0 (empty ()) = (empty (), empty ()) *) (** not implemented: position *) let span (str1, off1, _len1) (str2, off2, len2) = if str1 <> str2 then invalid_arg "Substring.span: must be substrings of same parent"; if off1 > off2 + len2 then invalid_arg "Substring.span: first substring must not be to the right of the second"; (str1, off1, off2+len2-off1) (*$T span (try (span (substring "foo" 0 3) (substring "bar" 0 3)) with Invalid_argument "Substring.span: must be substrings of same parent" -> empty ()) = empty () (try (span (substring "foobar" 4 2) (substring "foobar" 0 3)) with Invalid_argument "Substring.span: first substring must not be to the right of the second" -> empty ()) = empty () span (substring "foobar" 0 3) (substring "foobar" 3 3) = (substring "foobar" 0 6) span (substring "foobar" 3 3) (substring "foobar" 0 3) = (substring "foobar" 3 0) *) let translate f (str,off,len) = BatString.init len (fun i -> f str.[off+i]) (*$T translate translate (function 'o' -> 'a' | x -> x)(substring "foobar" 1 3) = "aab" translate (fun x -> x) (empty ()) = "" *) let tokens p (str,off,len) = let i = ref 0 and j = ref 0 and acc = BatRefList.empty () in while !j < len do while !i < len && p str.[off+ !i] do incr i; done; j := !i+1; while !j < len && not (p str.[off+ !j]) do incr j; done; BatRefList.push acc (str, !i, !j - !i); i := !j+1; done; BatRefList.to_list acc (*$T tokens tokens (fun x -> x = ';') (substring "foo;bar" 0 7) = [substring "foo;bar" 4 3; substring "foo;bar" 0 3] tokens (fun x -> x = ';') (substring "foo;;bar" 0 8) = [substring "foo;;bar" 5 3; substring "foo;;bar" 0 3] tokens (fun x -> x = ';') (empty ()) = [] *) let fields p (str, off, len) = let i = ref 0 and j = ref 0 and acc = BatRefList.empty() in while !j < len do while !j < len && not (p str.[off+ !j]) do incr j; done; BatRefList.push acc (str, !i, !j - !i); incr j; i := !j; done; BatRefList.to_list acc (*$T fields fields (fun x -> x = ';') (substring "foo;;bar" 0 8) = [substring "foo;;bar" 5 3; substring "foo;;bar" 4 0; substring "foo;;bar" 0 3] fields (fun x -> x = ';') (substring "foo;bar" 0 7) = [substring "foo;bar" 4 3; substring "foo;bar" 0 3] fields (fun x -> x = ';') (empty ()) = [] *) let fold_left f init (str, off, len) = let rec loop i result = if (i-off) = len then result else loop (i + 1) (f result str.[i]) in loop off init (*$T fold_left fold_left (fun a c -> c::a) [] (substring "foobar" 1 3)=['b';'o';'o'] fold_left (fun a _ -> a+1) 0 (empty ()) = 0 *) let fold_lefti f init (str, off, len) = let rec loop i result = if (i-off) = len then result else loop (i + 1) (f result (i-off) str.[i]) in loop off init (*$T fold_lefti fold_lefti (fun a i _ -> a+i) 0 (substring "foobar" 1 3) = 3 fold_lefti (fun a i _ -> a+i) 1 (empty ()) = 1 *) let fold_right f (str, off, len) init = let rec loop i result = if i = off then result else loop (i - 1) (f str.[i-1] result) in loop (off+len) init (*$T fold_right fold_right (fun c a -> c::a) (substring "foobar" 0 3) []=['f';'o';'o'] fold_right (fun c a -> c::a) (empty ()) [] = [] *) let fold_righti f (str, off, len) init = let rec loop i result = if i = off then result else let i' = i - 1 in loop (i - 1) (f (i' - off) str.[i'] result) in loop (off+len) init (*$T fold_righti fold_righti (fun i _ a -> a+i) (substring "foobar" 1 4) 0 = 6 fold_righti (fun i _ a -> a+i) (empty ()) 12 = 12 *) let iter f (str, off, len) = for i = off to off+len-1 do f str.[i]; done let iteri f (str, off, len) = for i = 0 to len-1 do f i str.[i+off] done let trim x = dropl BatChar.is_whitespace (dropr BatChar.is_whitespace x) (*$T trim trim (empty ()) = empty () trim (of_string " foobar ") = substring " foobar " 1 6 trim (of_string "foobar") = of_string "foobar" *) let split_on_char c (str, off, len) = let rec loop acc last_pos pos = if pos = off - 1 then (str, off, last_pos - off) :: acc else if str.[pos] = c then let pos1 = pos + 1 in let sub_str = str,pos1,(last_pos - pos1) in loop (sub_str :: acc) pos (pos - 1) else loop acc last_pos (pos - 1) in loop [] (off+len) (off + len - 1) (*$T split_on_char split_on_char ';' (of_string "foo;bar;oof") = [substring "foo;bar;oof" 0 3;substring "foo;bar;oof" 4 3; substring "foo;bar;oof" 8 3] split_on_char ';' (of_string "foo;;bar;oof") = [substring "foo;;bar;oof" 0 3; substring "foo;;bar;oof" 4 0; substring "foo;;bar;oof" 5 3; substring "foo;;bar;oof" 9 3] split_on_char ';' (empty ()) = [empty ()] *) let split_on_pipe str = split_on_char '|' str (*$T split_on_pipe split_on_pipe (of_string "foo|bar|oof") = [substring "foo|bar|oof" 0 3;substring "foo|bar|oof" 4 3; substring "foo|bar|oof" 8 3] split_on_pipe (empty ()) = [empty ()] *) let split_on_dot str = split_on_char '.' str (*$T split_on_dot split_on_dot (of_string "foo.bar.oof") = [substring "foo.bar.oof" 0 3;substring "foo.bar.oof" 4 3; substring "foo.bar.oof" 8 3] split_on_dot (empty ()) = [empty ()] *) let split_on_comma str = split_on_char ',' str (*$T split_on_comma split_on_comma (of_string "foo,bar,oof") = [substring "foo,bar,oof" 0 3;substring "foo,bar,oof" 4 3; substring "foo,bar,oof" 8 3] split_on_comma (empty ()) = [empty ()] *) let split_on_slash str = split_on_char '/' str (*$T split_on_slash split_on_slash (of_string "foo/bar/oof") = [substring "foo/bar/oof" 0 3;substring "foo/bar/oof" 4 3; substring "foo/bar/oof" 8 3] split_on_slash (empty ()) = [empty ()] *) let rec enum (str, off, len) = let last_element = off + len - 1 in let i = ref off in BatEnum.make ~next:(fun () -> if !i > last_element then raise BatEnum.No_more_elements else str.[BatRef.post_incr i] ) ~count:(fun () -> len - !i) ~clone:(fun () -> enum (str, !i, len - !i)) (*$T enum Enum.compare Char.compare (enum (of_string "foo")) (String.enum "foo") = 0 Enum.compare Char.compare (enum (of_string "foo")) (String.enum "fob") <> 0 Enum.compare Char.compare (enum (empty ())) (String.enum "") = 0 Enum.compare Char.compare (enum (empty ())) (String.enum "P") <> 0 *) let print oc ss = iter (fun c -> BatIO.write oc c) ss let append_to_buffer buff ss = let str, ofs, len = base ss in BatBuffer.add_substring buff str ofs len (*$T append_to_buffer let buff = BatBuffer.create 10 in \ let ss = substring "toto" 0 3 in \ append_to_buffer buff ss; \ BatBuffer.contents buff = "tot" *) batteries-included-3.4.0/src/batSubstring.mli000066400000000000000000000304601415601150500212270ustar00rootroot00000000000000(*TODO: What is this module? Is it meant for public use?*) type t (** [Substring.t] is the type of substrings of a basestring, an efficient representation of a piece of a string. A substring (s,i,n) is valid if 0 <= i <= i+n <= size s, or equivalently, 0 <= i and 0 <= n and i+n <= size s. A valid substring (s, i, n) represents the string s[i...i+n-1]. Invariant in the implementation: Any value of type [Substring.t] is valid. *) val empty : unit -> t val to_string : t -> string (** [string sus] is the string s[i..i+n-1] represented by sus = (s, i, n). *) val of_string : string -> t val make : int -> char -> t val create : int -> t val equal : t -> t -> bool (** Substring equality @since 2.1 *) val of_input : BatIO.input -> t val substring : string -> int -> int -> t (** [substring s o l] returns a substring with base-string [s], offset [o] and length [l]. Arguments are checked for validity [substring s i n] creates the substring [(s, i, n)], consisting of the substring of s with length n starting at i. @raise Inavlid_argument if [i<0] or [n<0] or [i+n > size s]. Equivalent to [extract s i (Some n)]. *) val unsafe_substring : string -> int -> int -> t (** [unsafe_substring] behaves like [substring], but does not perform any sanity check on the position and length. *) val extract : string -> int -> int option -> t (** [extract s i None] creates the substring (s, i, size s-i) consisting of the tail of s starting at i. @raise Invalid_argument if [i<0] or [i > size s]. [extract s i (Some n)] creates the substring (s, i, n), consisting of the substring of s with length n starting at i. @raise Invalid_argument if [i<0] or [n<0] or [i+n > size s]. *) val all : string -> t (** [all s] is the substring [(s, 0, size s)]. *) val base : t -> string * int * int (** [base sus] is the concrete triple [(s, i, n)], where [psus = (s, i, n)]. *) val is_empty : t -> bool (** [is_empty (s, i, n)] true if the substring is empty (that is, [n = 0]). *) val getc : t -> (char * t) option (** [getc sus] returns [Some(c, rst)] where [c] is the first character and [rst] the remainder of [sus], if [sus] is non-empty; otherwise returns [None]. *) val first : t -> char option (** [first sus] returns [Some c] where [c] is the first character in [sus], if [sus] is non-empty; otherwise returns [None]. *) val triml : int -> t -> t (** [triml k sus] returns sus less its leftmost k characters; or the empty string at the end of sus if it has less than k characters. @raise Invalid_argument if [k < 0], even in the partial application [triml k]. *) val trimr : int -> t -> t (** [trimr k sus] returns sus less its rightmost k characters; or the empty string at the beginning of sus if it has less than k characters. @raise Invalid_argument if [k < 0], even in the partial application [trimr k]. *) val get : t -> int -> char (** [get sus k] returns the k'th character of the substring; that is, s(i+k) where sus = (s, i, n). @raise Invalid_argument if [k<0] or [k>=n]. *) val size : t -> int (** [size (s, i, n)] returns the size of the substring, that is, [n]. *) val length: t -> int (** Equivalent to {!size}. *) val slice : t -> int -> int option -> t (** [slice sus i' None] returns the substring [(s, i+i', n-i')], where [sus = (s, i, n)]. @raise Invalid_argument if [i' < 0] or [i' > n]. [slice sus i' (Some n')] returns the substring [(s, i+i', n')], where [sus] = [(s, i, n)]. @raise Invalid_argument if [i' < 0] or [n' < 0] or [i'+n' >= n]. *) val concat : t list -> string (** [concat suss] returns a string consisting of the concatenation of the substrings. Equivalent to [String.concat (List.map to_string suss)]. *) val explode : t -> char list (** [explode sus] returns the list of characters of sus, that is, [s(i), s(i+1), ..., s(i+n-1)] where [sus = (s, i, n)]. Equivalent to [String.explode (to_string ss)]. *) val is_prefix : string -> t -> bool (** [is_prefix s1 s2] is true if [s1] is a prefix of [s2]. That is, if there exists a string [t] such that string [s1 ^ t = to_string s2]. *) val compare : t -> t -> int (** [compare sus1 sus2] performs lexicographic comparison, using the standard ordering Char.compare on the characters.p Equivalent to, but more efficient than, [String.compare (to_string sus1) (to_string sus2)]. *) (* NOT IMPLEMENTED [collate cmp (sus1, sus2)] performs lexicographic comparison, using the given ordering cmp on characters. Equivalent to, but more efficient than, String.collate cmp (string sus1, string sus2). *) val index : t -> char -> int (** [index sus c] returns the index of the first occurrence of [c] in [sus] or @raise Not_found otherwise. *) val index_from : t -> int -> char -> int (** [index_from sus i c] returns the index of the first occurrence of [c] in [sus] after the index [i] or @raise Not_found otherwise. If [i] is beyond the range of [sus], @raise Invalid_argument. It is equivalent to [i + index (triml i sus) c]. *) val rindex : t -> char -> int (** [rindex sus c] returns the index of the last occurrence of [c] in [sus] or @raise Not_found otherwise. *) val rindex_from : t -> int -> char -> int (** [index_from sus i c] returns the index of the last occurrence of [c] in [sus] before the index [i] or @raise Not_found otherwise. If [i] is beyond the range of [sus], @raise Invalid_argument. It is equivalent to [rindex (trimr i sus) c]. *) val contains : t -> char -> bool (** [contains s c] tests if character [c] appears in the substring [s]. @since 2.1 *) val dropl : (char -> bool) -> t -> t (** [dropl p sus] drops the longest prefix (left substring) of [sus] all of whose characters satisfy predicate [p]. If all characters do, it returns the empty substring [(s, i+n, 0)] where [sus = (s, i, n)]. *) val dropr : (char -> bool) -> t -> t (** [dropr p sus] drops the longest suffix (right substring) of sus all of whose characters satisfy predicate [p]. If all characters do, it returns the empty substring [(s, i, 0)] where [sus = (s, i, n)]. *) val takel : (char -> bool) -> t -> t (** [takel p sus] returns the longest prefix (left substring) of [sus] all of whose characters satisfy predicate [p]. That is, if the left-most character does not satisfy p, returns the empty [(s, i, 0)] where [sus = (s, i, n)]. *) val taker : (char -> bool) -> t -> t (** [taker p sus] returns the longest suffix (right substring) of [sus] all of whose characters satisfy predicate [p]. That is, if the right-most character satisfies [p], returns the empty [(s, i+n, 0)] where [sus = (s, i, n)]. Let [p] be a predicate and xxxxfyyyyfzzzz a string where all characters in xxxx and zzzz satisfy [p], and f a character not satisfying [p]. Then sus = xxxxfyyyyfzzzz sus = xxxxzzzz ------------------------------------------------------ dropl p sus = fyyyyfzzzz dropr p sus = xxxxfyyyyf takel p sus = xxxx xxxxzzzz taker p sus = zzzz xxxxzzzz It also holds that [concat (takel p sus) (dropl p sus) = string sus] [concat (dropr p sus) (taker p sus) = string sus] *) val splitl : (char -> bool) -> t -> t * t (** [splitl p sus] splits [sus] into a pair [(sus1, sus2)] of substrings where [sus1] is the longest prefix (left substring) all of whose characters satisfy [p], and [sus2] is the rest. That is, [sus2] begins with the leftmost character not satisfying [p]. Disregarding sideeffects, we have: [splitl p sus = (takel p sus, dropl p sus)]. *) val splitr : (char -> bool) -> t -> t * t (** [splitr p sus] splits [sus] into a pair [(sus1, sus2)] of substrings where [sus2] is the longest suffix (right substring) all of whose characters satisfy [p], and [sus1] is the rest. That is, [sus1] ends with the rightmost character not satisfying [p]. Disregarding sideeffects, we have: [splitr p sus = (dropr p sus, taker p sus)] *) val split_at : int -> t -> t * t (** [split_at sus k] returns the pair [(sus1, sus2)] of substrings, where [sus1] contains the first [k] characters of [sus], and [sus2] contains the rest. @raise Invalid_argument if [k < 0] or [k > size sus]. *) (* NOT IMPLEMENTED [position s (s',i,n)] splits the substring into a pair (pref, suff) of substrings, where suff is the longest suffix of (s', i, n) which has s as a prefix. More precisely, let m = size s. If there is a least index k in i..i+n-m for which s = s'[k..k+m-1], then the result is pref = (s', i, k-i) and suff = (s', k, n-(k-i)); otherwise the result is pref = (s', i, n) and suff = (s', i+n, 0). *) val span : t -> t -> t (** [span sus1 sus2] returns a substring spanning from the start of [sus1] to the end of [sus2], provided this is well-defined: [sus1] and [sus2] must have the same underlying string, and the start of [sus1] must not be to the right of the end of [sus2]; otherwise @raise Invalid_argument. More precisely, if [base sus1 = (s,i,n)] and [base sus2 = (s',i',n')] and [s = s'] and [i <= i'+n'], then [base (span sus1 sus2) = (s, i, i'+n'-i)]. This may be used to compute [span], [union], and [intersection]. *) val translate : (char -> char) -> t -> string (** [translate f sus] applies [f] to every character of [sus], from left to right, and returns the concatenation of the results. Equivalent to [String.of_list (List.map f (explode sus))]. *) val tokens : (char -> bool) -> t -> t list (** [tokens p sus] returns the list of tokens in [sus], from left to right, where a token is a non-empty maximal substring of [sus] not containing any delimiter, and a delimiter is a character satisfying [p]. *) val fields : (char -> bool) -> t -> t list (** [fields p sus] returns the list of fields in [sus], from left to right, where a field is a (possibly empty) maximal substring of [sus] not containing any delimiter, and a delimiter is a character satisfying [p]. Two tokens may be separated by more than one delimiter, whereas two fields are separated by exactly one delimiter. If the only delimiter is the character ['|'], then "abc||def" contains two tokens: "abc" and "def" "abc||def" contains three fields: "abc" and "" and "def" *) val fold_left : ('a -> char -> 'a) -> 'a -> t -> 'a (** [fold_left f e sus] folds [f] over [sus] from left to right. That is, evaluates [f s.[i+n-1] (f ... (f s.[i+1] (f s.[i] e)) ...)] tail-recursively, where [sus = (s, i, n)]. Equivalent to [List.fold_left f e (explode sus)]. *) val fold_lefti : ('a -> int -> char -> 'a) -> 'a -> t -> 'a (** As [fold_left], but with the index of the element as additional argument @since 2.3.0 *) val fold_right : (char -> 'a -> 'a) -> t -> 'a -> 'a (** [fold_right f e sus] folds [f] over [sus] from right to left. That is, evaluates [f s.[i] (f s.[i+1] (f ... (f s.[i+n-1] e) ...))] tail-recursively, where [sus = (s, i, n)]. Equivalent to [List.fold_right f e (explode sus)]. *) val fold_righti : (int -> char -> 'a -> 'a) -> t -> 'a -> 'a (** As [fold_right], but with the index of the element as additional argument @since 2.3.0 *) val iter : (char -> unit) -> t -> unit (** [iter f sus] applies [f] to all characters of [sus], from left to right. Equivalent to [List.iter f (explode sus)]. *) val iteri : (int -> char -> unit) -> t -> unit (** Same as {!iter}, but the function is applied to the index of the element as first argument (counting from 0), and the character itself as second argument. @since 2.1 *) val trim : t -> t (** removes whitespace from left and right ends of input *) val split_on_char : char -> t -> t list (** [split_on_char c ss] returns substrings of input [ss] as divided by [c] *) val split_on_pipe : t -> t list val split_on_dot : t -> t list val split_on_comma : t -> t list val split_on_slash : t -> t list val enum : t -> char BatEnum.t (** [enum ss] returns an enumeration of the characters represented by ss. It does no copying so beweare of mutating the original string. @since 2.1 *) val print : 'a BatIO.output -> t -> unit (** [print oc ss] prints [ss] to the output channel [oc] *) val append_to_buffer: BatBuffer.t -> t -> unit (** [append_to_buffer buff ss] appends the sub string [ss] to buffer [b]. *) batteries-included-3.4.0/src/batSys.mliv000066400000000000000000000275411415601150500202210ustar00rootroot00000000000000(* * BatSys - additional and modified functions for System * Copyright (C) 1996 Xavier Leroy * Copyright (C) 2009 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** System interface. This module defines higher-level functions than the {!Unix} module and should, wherever possible, be used rather than the {!Unix} module to ensure portability. @author Xavier Leroy (Base module) @author David Teller *) ##V>=4.09##external argv : string array = "%sys_argv" ##V<4.09##val argv : string array (** 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. *) val executable_name : string (** The name of the file containing the executable currently running. *) external file_exists : string -> bool = "caml_sys_file_exists" (** Test if a file with the given name exists. *) external is_directory : string -> bool = "caml_sys_is_directory" (** Returns [true] if the given name refers to a directory, [false] if it refers to another kind of file. @raise Sys_error if no file exists with the given name. @since 3.10.0 *) external remove : string -> unit = "caml_sys_remove" (** Remove the given file name from the file system. *) external rename : string -> string -> unit = "caml_sys_rename" (** Rename a file. The first argument is the old name and the second is the new name. If there is already another file under the new name, [rename] may replace it, or raise an exception, depending on your operating system. *) external getenv : string -> string = "caml_sys_getenv" (** Return the value associated to a variable in the process environment. @raise Not_found if the variable is unbound. *) val getenv_opt: string -> string option (** Return the value associated to a variable in the process environment or [None] if the variable is unbound. @since 4.05 *) external command : string -> int = "caml_sys_system_command" (** Execute the given shell command and return its exit code. *) ##V<4.3##external time : unit -> float = "caml_sys_time" ##V>=4.3##external time : unit -> (float [@unboxed]) = ##V>=4.3## "caml_sys_time" "caml_sys_time_unboxed" [@@noalloc] (** Return the processor time, in seconds, used by the program since the beginning of execution. *) external chdir : string -> unit = "caml_sys_chdir" (** Change the current working directory of the process. *) external getcwd : unit -> string = "caml_sys_getcwd" (** Return the current working directory of the process. *) external readdir : string -> string array = "caml_sys_read_directory" (** Return the names of all files present in the given directory. Names denoting the current directory and the parent directory (["."] and [".."] in Unix) are not returned. Each string in the result is a file name rather than a complete path. There is no guarantee that the name strings in the resulting array will appear in any specific order; they are not, in particular, guaranteed to appear in alphabetical order. *) val interactive : bool ref (** This reference is initially set to [false] in standalone programs and to [true] if the code is being executed under the interactive toplevel system [ocaml]. *) val os_type : string (** Operating system currently executing the OCaml program. One of - ["Unix"] (for all Unix versions, including Linux and Mac OS X), - ["Win32"] (for MS-Windows, OCaml compiled with MSVC++ or Mingw), - ["Cygwin"] (for MS-Windows, OCaml compiled with Cygwin). *) ##V>=4.4##type backend_type = Sys.backend_type = ##V>=4.4## | Native ##V>=4.4## | Bytecode ##V>=4.4## | Other of string (**) ##V>=4.4##(** Currently, the official distribution only supports [Native] and ##V>=4.4## [Bytecode], but it can be other backends with alternative ##V>=4.4## compilers, for example, javascript. ##V>=4.4## ##V>=4.4## @since 2.5.3 and 4.04 *) ##V>=4.4## ##V>=4.4##val backend_type : backend_type ##V>=4.4##(** Backend type currently executing the OCaml program. ##V>=4.4## @ since 2.5.3 and 4.04 ##V>=4.4## *) ##V>=4.1##val unix : bool ##V>=4.1##(** True if [Sys.os_type = "Unix"]. ##V>=4.1## @since 4.01.0 *) ##V>=4.1## ##V>=4.1##val win32 : bool ##V>=4.1##(** True if [Sys.os_type = "Win32"]. ##V>=4.1## @since 4.01.0 *) ##V>=4.1## ##V>=4.1##val cygwin : bool ##V>=4.1##(** True if [Sys.os_type = "Cygwin"]. ##V>=4.1## @since 4.01.0 *) val word_size : int (** Size of one word on the machine currently executing the OCaml program, in bits: 32 or 64. *) ##V>=4.3##val int_size : int ##V>=4.3##(** Size of an int. It is 31 bits (resp. 63 bits) when using the ##V>=4.3## OCaml compiler on a 32 bits (resp. 64 bits) platform. It may ##V>=4.3## differ for other compilers, e.g. it is 32 bits when compiling to ##V>=4.3## JavaScript. ##V>=4.3## @since 2.5.0 and OCaml 4.03.0 *) val big_endian : bool (** Whether the machine currently executing the OCaml program is big-endian. @since 4.00.0 *) val max_string_length : int (** Maximum length of a string. *) val max_array_length : int (** Maximum length of a normal array. The maximum length of a float array is [max_array_length/2] on 32-bit machines and [max_array_length] on 64-bit machines. *) ##V>=4.08##val max_floatarray_length : int ##V>=4.08##(** Maximum length of a floatarray. This is also the maximum length of ##V>=4.08## a [float array] when OCaml is configured with ##V>=4.08## [--enable-flat-float-array]. *) ##V>=4.3##external runtime_variant : unit -> string = "caml_runtime_variant" ##V>=4.3##(** Return the name of the runtime variant the program is running on. ##V>=4.3## This is normally the argument given to [-runtime-variant] at compile ##V>=4.3## time, but for byte-code it can be changed after compilation. ##V>=4.3## @since 2.5.0 and OCaml 4.03.0 *) ##V>=4.3##external runtime_parameters : unit -> string = "caml_runtime_parameters" ##V>=4.3##(** Return the value of the runtime parameters, in the same format ##V>=4.3## as the contents of the [OCAMLRUNPARAM] environment variable. ##V>=4.3## @since 2.5.0 and OCaml 4.03.0 *) (** {6 Signal handling} *) type signal_behavior = Sys.signal_behavior = Signal_default | Signal_ignore | Signal_handle of (int -> unit) (** What to do when receiving a signal: - [Signal_default]: take the default behavior (usually: abort the program) - [Signal_ignore]: ignore the signal - [Signal_handle f]: call function [f], giving it the signal number as argument. *) external signal : int -> signal_behavior -> signal_behavior = "caml_install_signal_handler" (** Set the behavior of the system on receipt of a given signal. The first argument is the signal number. Return the behavior previously associated with the signal. @raise Invalid_argument If the signal number is invalid (or not available on your system). *) val set_signal : int -> signal_behavior -> unit (** Same as {!Sys.signal} but return value is ignored. *) (** {7 Signal numbers for the standard POSIX signals.} *) val sigabrt : int (** Abnormal termination *) val sigalrm : int (** Timeout *) val sigfpe : int (** Arithmetic exception *) val sighup : int (** Hangup on controlling terminal *) val sigill : int (** Invalid hardware instruction *) val sigint : int (** Interactive interrupt (ctrl-C) *) val sigkill : int (** Termination (cannot be ignored) *) val sigpipe : int (** Broken pipe *) val sigquit : int (** Interactive termination *) val sigsegv : int (** Invalid memory reference *) val sigterm : int (** Termination *) val sigusr1 : int (** Application-defined signal 1 *) val sigusr2 : int (** Application-defined signal 2 *) val sigchld : int (** Child process terminated *) val sigcont : int (** Continue *) val sigstop : int (** Stop *) val sigtstp : int (** Interactive stop *) val sigttin : int (** Terminal read from background process *) val sigttou : int (** Terminal write from background process *) val sigvtalrm : int (** Timeout in virtual time *) val sigprof : int (** Profiling interrupt *) val sigbus : int (** Bus error @since 2.5.0 *) val sigpoll : int (** Pollable event @since 2.5.0 *) val sigsys : int (** Bad argument to routine @since 2.5.0 *) val sigtrap : int (** Trace/breakpoint trap @since 2.5.0 *) val sigurg : int (** Urgent condition on socket @since 2.5.0 *) val sigxcpu : int (** Timeout in cpu time @since 2.5.0 *) val sigxfsz : int (** File size limit exceeded @since 2.5.0 *) exception Break (** Exception raised on interactive interrupt if {!Sys.catch_break} is on. *) val catch_break : bool -> unit (** [catch_break] governs whether interactive interrupt (ctrl-C) terminates the program or raises [Break]. Call [catch_break true] to enable raising [Break], and [catch_break false] to let the system terminate the program on user interrupt. *) val ocaml_version : string (** [ocaml_version] is the version of OCaml. 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 files_of: string -> string BatEnum.t (**As {!readdir} but the results are presented as an enumeration of names.*) ##V>=4.3##val enable_runtime_warnings: bool -> unit ##V>=4.3##(** Control whether the OCaml runtime system can emit warnings ##V>=4.3## on stderr. Currently, the only supported warning is triggered ##V>=4.3## when a channel created by [open_*] functions is finalized without ##V>=4.3## being closed. Runtime warnings are enabled by default. ##V>=4.3## @since 2.5.0 and OCaml 4.03 *) ##V>=4.3##val runtime_warnings_enabled: unit -> bool ##V>=4.3##(** Return whether runtime warnings are currently enabled. ##V>=4.3## @since 2.5.0 and OCaml 4.03 *) (** {6 Optimization} *) ##V>=4.3##external opaque_identity : 'a -> 'a = "%opaque" ##V=4.2##val opaque_identity : 'a -> 'a (** 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 ]} The compiler primitive was added to OCaml 4.03, but we emulate it under 4.02 using the -opaque compilation flag. There is no easy way for Batteries to emulate it correctly under older OCaml versions. @since 2.5.0 and OCaml 4.02 *) ##V>=4.10##module Immediate64 = Sys.Immediate64 ##V>=4.12##external mkdir : string -> int -> unit = "caml_sys_mkdir" ##V>=4.12##(** Create a directory with the given permissions. ##V>=4.12## ##V>=4.12## @since 3.3.0 and 4.12.0 ##V>=4.12##*) ##V>=4.12## ##V>=4.12##external rmdir : string -> unit = "caml_sys_rmdir" ##V>=4.12##(** Remove an empty directory. ##V>=4.12## ##V>=4.12## @since 3.3.0 and 4.12.0 ##V>=4.12##*) batteries-included-3.4.0/src/batSys.mlv000066400000000000000000000027261415601150500200460ustar00rootroot00000000000000(* * BatSys - additional and modified functions for System * Copyright (C) 1996 Xavier Leroy * Copyright (C) 2009 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) let big_endian = false (* overridden by real big_endian value in 4.00 and above *) include Sys let files_of d = BatArray.enum (readdir d) ##V<4.3##let sigbus = -22 ##V<4.3##let sigpoll = -23 ##V<4.3##let sigsys = -24 ##V<4.3##let sigtrap = -25 ##V<4.3##let sigurg = -26 ##V<4.3##let sigxcpu = -27 ##V<4.3##let sigxfsz = -28 ##V>=4.3##external opaque_identity : 'a -> 'a = "%opaque" ##V<4.3##let opaque_identity = BatOpaqueInnerSys.opaque_identity ##V<4.5##let getenv_opt v = try Some (getenv v) with Not_found -> None batteries-included-3.4.0/src/batText.ml000066400000000000000000001043301415601150500200200ustar00rootroot00000000000000(* * BatText - Unicode text library * * Copyright (C) 2012 The Batteries Included Team * Copyright (C) 2007 Mauricio Fernandez * Copyright (C) 2008 Edgar Friendly * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * Rope: Rope: an implementation of the data structure described in * * Boehm, H., Atkinson, R., and Plass, M. 1995. Ropes: an alternative to * strings. Softw. Pract. Exper. 25, 12 (Dec. 1995), 1315-1330. * * Motivated by Luca de Alfaro's extensible array implementation Vec. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module UTF8 = BatUTF8 module UChar = BatUChar (**Low-level optimization*) let int_max (x:int) (y:int) = if x < y then y else x let int_min (x:int) (y:int) = if x < y then x else y let splice s1 off len s2 = let len1 = String.length s1 and len2 = String.length s2 in let off = if off < 0 then len1 + off - 1 else off in let len = int_min (len1 - off) len in let out_len = len1 - len + len2 in let s = Bytes.create out_len in Bytes.blit_string s1 0 s 0 off; (* s1 before splice point *) Bytes.blit_string s2 0 s off len2; (* s2 at splice point *) Bytes.blit_string (* s1 after off+len *) s1 (off+len) s (off+len2) (len1 - (off+len)); Bytes.unsafe_to_string s type t = Empty (**An empty rope*) | Concat of t * int * t * int * int (**[Concat l ls r rs h] is the concatenation of ropes [l] and [r], where [ls] is the total length of [l], [rs] is the length of [r] and [h] is the height of the node in the tree, used for rebalancing. *) | Leaf of int * UTF8.t (**[Leaf l t] is string [t] with length [l], measured in number of Unicode characters.*) type forest_element = { mutable c : t; mutable len : int } let str_append = (^) let empty_str = "" let string_of_string_list l = String.concat empty_str l (* 48 limits max rope size to 220GB on 64 bit, * ~ 700MB on 32bit (length fields overflow after that) *) let max_height = 48 (* actual size will be that plus 1 word header; * the code assumes it's an even num. * 256 gives up to a 50% overhead in the worst case (all leaf nodes near * half-filled *) let leaf_size = 256 (* utf-8 characters, not bytes *) (* MAIN CODE STARTS HERE *) exception Out_of_bounds let empty = Empty (* by construction, there cannot be Empty or Leaf "" leaves *) let is_empty = function Empty -> true | _ -> false let height = function | Empty | Leaf _ -> 0 | Concat(_,_,_,_,h) -> h let length = function | Empty -> 0 | Leaf (l,_) -> l | Concat(_,cl,_,cr,_) -> cl + cr let make_concat l r = let hl = height l and hr = height r in let cl = length l and cr = length r in Concat(l, cl, r, cr, if hl >= hr then hl + 1 else hr + 1) let min_len = let fib_tbl = Array.make max_height 0 in let rec fib n = match fib_tbl.(n) with | 0 -> let last = fib (n - 1) and prev = fib (n - 2) in let r = last + prev in let r = if r > last then r else last in (* check overflow *) fib_tbl.(n) <- r; r | n -> n in fib_tbl.(0) <- leaf_size + 1; fib_tbl.(1) <- 3 * leaf_size / 2 + 1; Array.init max_height (fun i -> if i = 0 then 1 else fib (i - 1)) let max_length = min_len.(Array.length min_len - 1) let concat_fast l r = match l with | Empty -> r | Leaf _ | Concat(_,_,_,_,_) -> match r with | Empty -> l | Leaf _ | Concat(_,_,_,_,_) -> make_concat l r (* based on Hans-J. Boehm's *) let add_forest forest rope len = let i = ref 0 in let sum = ref empty in while len > min_len.(!i+1) do if forest.(!i).c <> Empty then begin sum := concat_fast forest.(!i).c !sum; forest.(!i).c <- Empty end; incr i done; sum := concat_fast !sum rope; let sum_len = ref (length !sum) in while !sum_len >= min_len.(!i) do if forest.(!i).c <> Empty then begin sum := concat_fast forest.(!i).c !sum; sum_len := !sum_len + forest.(!i).len; forest.(!i).c <- Empty; end; incr i done; decr i; forest.(!i).c <- !sum; forest.(!i).len <- !sum_len let concat_forest forest = Array.fold_left (fun s x -> concat_fast x.c s) Empty forest let rec balance_insert rope len forest = match rope with | Empty -> () | Leaf _ -> add_forest forest rope len | Concat(l,cl,r,cr,h) when h >= max_height || len < min_len.(h) -> balance_insert l cl forest; balance_insert r cr forest | x -> add_forest forest x len (* function or balanced *) let balance r = match r with | Empty | Leaf _ -> r | _ -> let forest = Array.init max_height (fun _ -> {c = Empty; len = 0}) in balance_insert r (length r) forest; concat_forest forest let bal_if_needed l r = let r = make_concat l r in if height r < max_height then r else balance r let concat_str l = function | Empty | Concat(_,_,_,_,_) -> invalid_arg "Text.concat_str" | Leaf (lenr, rs) as r -> match l with | Empty -> r | Leaf (lenl, ls) -> let slen = lenr + lenl in if slen <= leaf_size then Leaf ((lenl+lenr),(str_append ls rs)) else make_concat l r (* height = 1 *) | Concat(ll, cll, Leaf (lenlr ,lrs), clr, h) -> let slen = clr + lenr in if clr + lenr <= leaf_size then Concat(ll, cll, Leaf ((lenlr + lenr),(str_append lrs rs)), slen, h) else bal_if_needed l r | _ -> bal_if_needed l r let append_char c r = concat_str r (Leaf (1, (UTF8.make 1 c))) let append l = function | Empty -> l | Leaf _ as r -> concat_str l r | Concat(Leaf (lenrl,rls),rlc,rr,rc,h) as r -> (match l with Empty -> r | Concat(_,_,_,_,_) -> bal_if_needed l r | Leaf (lenl, ls) -> let slen = rlc + lenl in if slen <= leaf_size then Concat(Leaf((lenrl+lenl),(str_append ls rls)), slen, rr, rc, h) else bal_if_needed l r) | r -> (match l with Empty -> r | _ -> bal_if_needed l r) let ( ^^^ ) = append let prepend_char c r = append (Leaf (1,(UTF8.make 1 c))) r let get r i = let rec aux i = function Empty -> raise Out_of_bounds | Leaf (lens, s) -> if i >= 0 && i < lens then UTF8.get s i else raise Out_of_bounds | Concat (l, cl, r, _cr, _) -> if i < cl then aux i l else aux (i - cl) r in aux i r let copy_set us cpos c = let ipos = UTF8.ByteIndex.of_char_idx us cpos in let jpos = UTF8.ByteIndex.next us ipos in let i = UTF8.ByteIndex.to_int ipos and j = UTF8.ByteIndex.to_int jpos in splice us i (j-i) (UTF8.of_char c) let set r i v = let rec aux i = function Empty -> raise Out_of_bounds | Leaf (lens, s) -> if i >= 0 && i < lens then let s = copy_set s i v in Leaf (lens, s) else raise Out_of_bounds | Concat(l, cl, r, _cr, _) -> if i < cl then append (aux i l) r else append l (aux (i - cl) r) in aux i r module Iter = struct (* Iterators are used for iterating efficiently over multiple ropes at the same time *) type iterator = { (* Current leaf in which the iterator is *) mutable leaf : UTF8.t; (* Current byte position of the iterator *) mutable idx : UTF8.ByteIndex.b_idx; (* Ropes not yet visited *) mutable rest : t list; } let copy i = {i with idx=i.idx; } (* Initial iterator state: *) let make rope = { leaf = UTF8.empty; idx = UTF8.ByteIndex.first; rest = if rope = Empty then [] else [rope] } let rec next_leaf = function | Empty :: l -> next_leaf l | Leaf(_len, str) :: l -> Some(str, l) | Concat(left, _left_len, right, _right_len, _height) :: l -> next_leaf (left :: right :: l) | [] -> None (* Advance the iterator to the next position, and return current character: *) let next iter = if UTF8.ByteIndex.at_end iter.leaf iter.idx then (* We are at the end of the current leaf, find another one: *) match next_leaf iter.rest with | None -> None | Some(leaf, rest) -> iter.leaf <- leaf; iter.idx <- UTF8.ByteIndex.next leaf UTF8.ByteIndex.first; iter.rest <- rest; Some(UTF8.ByteIndex.look leaf UTF8.ByteIndex.first) else begin (* Just advance in the current leaf: *) let ch = UTF8.ByteIndex.look iter.leaf iter.idx in iter.idx <- UTF8.ByteIndex.next iter.leaf iter.idx; Some ch end (* Same thing but map leafs: *) let next_map f iter = if UTF8.ByteIndex.at_end iter.leaf iter.idx then match next_leaf iter.rest with | None -> None | Some(leaf, rest) -> let leaf = f leaf in iter.leaf <- leaf; iter.idx <- UTF8.ByteIndex.next leaf UTF8.ByteIndex.first; iter.rest <- rest; Some(UTF8.ByteIndex.look leaf UTF8.ByteIndex.first) else begin let ch = UTF8.ByteIndex.look iter.leaf iter.idx in iter.idx <- UTF8.ByteIndex.next iter.leaf iter.idx; Some ch end (* Same thing but in reverse order: *) let rec prev_leaf = function | Empty :: l -> prev_leaf l | Leaf(_len, str) :: l -> Some(str, l) | Concat(left, _left_len, right, _right_len, _height) :: l -> prev_leaf (right :: left :: l) | [] -> None let prev iter = if iter.idx = UTF8.ByteIndex.first then match prev_leaf iter.rest with | None -> None | Some(leaf, rest) -> iter.leaf <- leaf; iter.idx <- UTF8.ByteIndex.last leaf; iter.rest <- rest; Some(UTF8.ByteIndex.look leaf iter.idx) else begin iter.idx <- UTF8.ByteIndex.prev iter.leaf iter.idx; Some(UTF8.ByteIndex.look iter.leaf iter.idx) end end (* Can be improved? *) let compare a b = let ia = Iter.make a and ib = Iter.make b in let rec loop _ = match Iter.next ia, Iter.next ib with | None, None -> 0 | None, _ -> -1 | _, None -> 1 | Some ca, Some cb -> match UChar.compare ca cb with | 0 -> loop () | n -> n in loop () let of_ustring ustr = (* We need fast access to raw bytes: *) let bytes = ustr in let byte_length = String.length bytes in (* - [rope] is the accumulator - [start_byte_idx] is the byte position of the current slice - [current_byte_idx] is the current byte position - [slice_size] is the number of unicode characters contained between [start_byte_idx] and [current_byte_idx] *) let rec loop rope start_byte_idx current_byte_idx slice_size = if current_byte_idx = byte_length then begin if slice_size = 0 then rope else add_slice rope start_byte_idx current_byte_idx slice_size end else begin if slice_size = leaf_size then (* We have enough unicode characters for this slice, extract it and add a leaf to the rope: *) loop (add_slice rope start_byte_idx current_byte_idx slice_size) current_byte_idx current_byte_idx 0 else let next_byte_idx = UTF8.next ustr current_byte_idx in loop rope start_byte_idx next_byte_idx (slice_size + 1) end and add_slice rope start_byte_idx end_byte_idx slice_size = append rope (Leaf(slice_size, (* This is correct, we are just extracting a sequence of well-formed UTF-8 encoded unicode characters: *) UTF8.of_string_unsafe (String.sub bytes start_byte_idx (end_byte_idx - start_byte_idx)))) in loop Empty 0 0 0 let of_string s = (* Validate + unsafe to avoid an extra copy (it is OK because of_ustring do not reuse its argument in the resulting rope): *) UTF8.validate s; of_ustring (UTF8.of_string_unsafe s) let append_us r us = append r (of_ustring us) let rec make len c = let rec concatloop len i r = if i <= len then (*TODO: test for sharing among substrings *) concatloop len (i * 2) (append r r) else r in if len = 0 then Empty else if len <= leaf_size then Leaf (len, (UTF8.make len c)) else let rope = concatloop len 2 (of_ustring (UTF8.make 1 c)) in append rope (make (len - length rope) c) let of_uchar c = make 1 c let of_char c = of_uchar (UChar.of_char c) let sub r start len = let rec aux start len = function Empty -> if start <> 0 || len <> 0 then raise Out_of_bounds else Empty | Leaf (lens, s) -> if len < 0 || start < 0 || start + len > lens then raise Out_of_bounds else if len > 0 then (* Leaf "" cannot happen *) (try Leaf (len, (UTF8.sub s start len)) with _ -> raise Out_of_bounds) else Empty | Concat(l,cl,r,cr,_) -> if start < 0 || len < 0 || start + len > cl + cr then raise Out_of_bounds; let left = if start = 0 then if len >= cl then l else aux 0 len l else if start > cl then Empty else if start + len >= cl then aux start (cl - start) l else aux start len l in let right = if start <= cl then let upto = start + len in if upto = cl + cr then r else if upto < cl then Empty else aux 0 (upto - cl) r else aux (start - cl) len r in append left right in aux start len r let insert start rope r = append (append (sub r 0 start) rope) (sub r start (length r - start)) let remove start len r = append (sub r 0 start) (sub r (start + len) (length r - start - len)) let to_ustring r = let rec strings l = function | Empty -> l | Leaf (_,s) -> s :: l | Concat(left,_,right,_,_) -> strings (strings l right) left in string_of_string_list (strings [] r) let rec bulk_iter f = function | Empty -> () | Leaf (_,s) -> f s | Concat(l,_,r,_,_) -> bulk_iter f l; bulk_iter f r let rec bulk_iteri ?(base=0) f = function | Empty -> () | Leaf (_,s) -> f base s | Concat(l,cl,r,_,_) -> bulk_iteri ~base f l; bulk_iteri ~base:(base+cl) f r let rec iter f = function | Empty -> () | Leaf (_,s) -> UTF8.iter f s | Concat(l,_,r,_,_) -> iter f l; iter f r let rec iteri ?(base=0) f = function | Empty -> () | Leaf (_,s) -> UTF8.iteri (fun c j -> f (base + j) c) s | Concat(l,cl,r,_,_) -> iteri ~base f l; iteri ~base:(base + cl) f r let rec bulk_iteri_backwards ~top f = function | Empty -> () | Leaf (_lens,s) -> f top s | Concat(l,_,r,cr,_) -> bulk_iteri_backwards ~top f r; bulk_iteri_backwards ~top:(top-cr) f l let rec range_iter f start len = function | Empty -> if start <> 0 || len <> 0 then raise Out_of_bounds | Leaf (lens, s) -> let n = start + len in if start >= 0 && len >= 0 && n <= lens then for i = start to n - 1 do f (UTF8.look s (UTF8.nth s i)) (*TODO: use enum to iterate efficiently*) done else raise Out_of_bounds | Concat(l,cl,r,cr,_) -> if start < 0 || len < 0 || start + len > cl + cr then raise Out_of_bounds; if start < cl then begin let upto = start + len in if upto <= cl then range_iter f start len l else begin range_iter f start (cl - start) l; range_iter f 0 (upto - cl) r end end else begin range_iter f (start - cl) len r end let rec range_iteri f ?(base = 0) start len = function | Empty -> if start <> 0 || len <> 0 then raise Out_of_bounds | Leaf (lens, s) -> let n = start + len in if start >= 0 && len >= 0 && n <= lens then for i = start to n - 1 do f (base+i) (UTF8.look s (UTF8.nth s i)) (*TODO: use enum to iterate efficiently*) done else raise Out_of_bounds | Concat(l,cl,r,cr,_) -> if start < 0 || len < 0 || start + len > cl + cr then raise Out_of_bounds; if start < cl then begin let upto = start + len in if upto <= cl then range_iteri f ~base start len l else begin range_iteri f ~base start (cl - start) l; range_iteri f ~base:(base + cl - start) 0 (upto - cl) r end end else begin range_iteri f ~base (start - cl) len r end let rec fold f a = function | Empty -> a | Leaf (_,s) -> UTF8.fold (fun a c -> f a c) a s | Concat(l,_,r,_,_) -> fold f (fold f a l) r let rec bulk_fold f a = function | Empty -> a | Leaf (_, s) -> f a s | Concat (l, _, r, _, _) -> bulk_fold f (bulk_fold f a l) r let to_string t = (* We use unsafe version to avoid the copy of the non-reachable temporary string: *) UTF8.to_string_unsafe (to_ustring t) let init len f = Leaf (len, UTF8.init len f) let of_string_unsafe s = of_ustring (UTF8.of_string_unsafe s) let of_int i = of_string_unsafe (string_of_int i) let of_float f = of_string_unsafe (string_of_float f) let to_int r = int_of_string (UTF8.to_string_unsafe (to_ustring r)) let to_float r = float_of_string (UTF8.to_string_unsafe (to_ustring r)) let bulk_map f r = bulk_fold (fun acc s -> append_us acc (f s)) Empty r let map f r = bulk_map (fun s -> UTF8.map f s) r let bulk_filter_map f r = bulk_fold (fun acc s -> match f s with None -> acc | Some r -> append_us acc r) Empty r let filter_map f r = bulk_map (UTF8.filter_map f) r let filter f r = bulk_map (UTF8.filter f) r let left r len = sub r 0 len let right r len = let rlen = length r in sub r (rlen - len) len let head = left let tail r pos = sub r pos (length r - pos) let index r u = let i = Iter.make r in let rec loop n = match Iter.next i with | None -> raise Not_found | Some u' -> if UChar.eq u u' then n else loop (n + 1) in loop 0 let enum r = let next iter () = match Iter.next iter with | None -> raise BatEnum.No_more_elements | Some x -> x and count iter () = let n = ref 0 in let iter' = Iter.copy iter in begin try while true do match Iter.next iter' with None -> raise Exit | Some _ -> incr n done with Exit -> () end; !n in let rec make iter = BatEnum.make ~next:(next iter) ~clone:(clone iter) ~count:(count iter) and clone iter () = make (Iter.copy iter) in make (Iter.make r) let backwards r = let next iter () = match Iter.prev iter with | None -> raise BatEnum.No_more_elements | Some x -> x and count iter () = let n = ref 0 in let iter' = Iter.copy iter in begin try while true do match Iter.prev iter' with None -> raise Exit | Some _ -> incr n done with Exit -> () end; !n in let rec make iter = BatEnum.make ~next:(next iter) ~clone:(clone iter) ~count:(count iter) and clone iter () = make (Iter.copy iter) in make (Iter.make r) let of_enum e = let size = BatEnum.count e in init size (fun _i -> try BatEnum.get_exn e with BatEnum.No_more_elements -> assert false) (*$Q enum; of_enum (Q.array Q.small_int) (fun a -> \ let s = BatUTF8.init (Array.length a) (fun i -> BatUChar.chr (Array.get a i)) in \ s = (of_string s |> enum |> of_enum |> to_string)) *) module Return = BatReturn let index_from r base item = Return.with_label (fun label -> let index_aux i c = if c = item then Return.return label i in range_iteri index_aux base (length r - base) r; raise Not_found) (*$T index_from index_from (of_string "batteries") 0 (BatUChar.of_char 't') = 2 index_from (of_string "batteries") 3 (BatUChar.of_char 't') = 3 Result.(catch (index_from (of_string "batteries") 4) (BatUChar.of_char 't') \ |> is_exn Not_found) Result.(catch (index_from (of_string "batteries") 20) (BatUChar.of_char 't') \ |> is_exn Out_of_bounds) *) let rindex r char = Return.with_label (fun label -> let index_aux i us = try let p = UTF8.rindex us char in Return.return label (p+i) with Not_found -> () in bulk_iteri_backwards ~top:(length r - 1) index_aux r; raise Not_found) (*$T rindex rindex (of_string "batteries") (BatUChar.of_char 't') = 3 rindex (of_string "batt") (BatUChar.of_char 't') = 3 try ignore (rindex (of_string "batteries") (BatUChar.of_char 'y')); false with Not_found -> true *) let rindex_from r start char = let rsub = left r (start + 1) in (rindex rsub char) (*$T rindex_from let s = "batteries" in rindex_from (of_string s) (String.length s - 1) (BatUChar.of_char 't') = 3 let s = "batteries" in rindex_from (of_string s) 2 (BatUChar.of_char 't') = 2 try ignore (rindex_from (of_string "batteries") 4 (BatUChar.of_char 'y')); false with Not_found -> true try ignore (rindex_from (of_string "batteries") 20 (BatUChar.of_char 'y')); false with Out_of_bounds -> true *) let contains r char = Return.with_label (fun label -> let contains_aux us = if UTF8.contains us char then Return.return label true in bulk_iter contains_aux r; false) (*$T contains contains empty (BatUChar.of_char 't') = false contains (of_string "") (BatUChar.of_char 't') = false contains (of_string "batteries") (BatUChar.of_char 't') = true contains (of_string "batteries") (BatUChar.of_char 'y') = false *) let contains_from r start char = Return.with_label (fun label -> let contains_aux c = if c = char then Return.return label true in range_iter contains_aux start (length r - start) r; false) (*$T contains_from try ignore (contains_from empty 4 (BatUChar.of_char 't')); false with Out_of_bounds -> true try ignore (contains_from (of_string "") 4 (BatUChar.of_char 't')); false with Out_of_bounds -> true contains_from (of_string "batteries") 4 (BatUChar.of_char 't') = false contains_from (of_string "batteries") 3 (BatUChar.of_char 't') = true contains_from (of_string "batteries") 2 (BatUChar.of_char 't') = true contains_from (of_string "batteries") 1 (BatUChar.of_char 't') = true contains_from (of_string "batteries") 4 (BatUChar.of_char 'y') = false *) let rcontains_from r stop char = Return.with_label (fun label -> let contains_aux c = if c = char then Return.return label true in range_iter contains_aux 0 (stop + 1) r; false) (*$T rcontains_from try ignore (rcontains_from empty 4 (BatUChar.of_char 't')); false with Out_of_bounds -> true try ignore (rcontains_from (of_string "") 4 (BatUChar.of_char 't')); false with Out_of_bounds -> true rcontains_from (of_string "batteries") 4 (BatUChar.of_char 't') = true rcontains_from (of_string "batteries") 3 (BatUChar.of_char 't') = true rcontains_from (of_string "batteries") 2 (BatUChar.of_char 't') = true rcontains_from (of_string "batteries") 1 (BatUChar.of_char 't') = false rcontains_from (of_string "batteries") 4 (BatUChar.of_char 'y') = false *) let equal r1 r2 = compare r1 r2 = 0 let starts_with r prefix = let ir = Iter.make r and iprefix = Iter.make prefix in let rec loop _ = match Iter.next iprefix with | None -> true | Some ch1 -> match Iter.next ir with | None -> false | Some ch2 -> UChar.compare ch1 ch2 = 0 && loop () in loop () let ends_with r suffix = let ir = Iter.make r and isuffix = Iter.make suffix in let rec loop _ = match Iter.prev isuffix with | None -> true | Some ch1 -> match Iter.prev ir with | None -> false | Some ch2 -> UChar.compare ch1 ch2 = 0 && loop () in loop () (** find [sub] within [rop] or raises Not_found *) let find_from rop ofs sub_rop = let len = length rop in if ofs < 0 || ofs > len then raise Out_of_bounds; let matchlen = length sub_rop in let sub_rop = to_ustring sub_rop in let check_at pos = sub_rop = (to_ustring (sub rop pos matchlen)) in (* TODO: inefficient *) Return.with_label (fun label -> for i = ofs to len - matchlen do if check_at i then Return.return label i done; raise Not_found) (*$T find_from find_from (of_string "foobarbaz") 4 (of_string "ba") = 6 find_from (of_string "foobarbaz") 7 (of_string "") = 7 Result.(catch (find_from (of_string "") 0) (of_string "a") |> is_exn Not_found) let foo = of_string "foo" in Result.(catch (find_from foo 2) foo |> is_exn Not_found) let foo = of_string "foo" in Result.(catch (find_from foo 3) foo |> is_exn Not_found) let foo = of_string "foo" in Result.(catch (find_from foo 4) foo |> is_exn Out_of_bounds) let foo = of_string "foo" in Result.(catch (find_from foo (-1)) foo |> is_exn Out_of_bounds) *) let find rop sub = find_from rop 0 sub let rfind_from rop suf sub_rop = if suf + 1 < 0 || suf + 1 > length rop then raise Out_of_bounds; let matchlen = length sub_rop in let sub_rop = to_ustring sub_rop in let check_at pos = sub_rop = (to_ustring (sub rop pos matchlen)) in (* TODO: inefficient *) Return.with_label (fun label -> for i = suf - matchlen + 1 downto 0 do if check_at i then Return.return label i done; raise Not_found) (*$T rfind_from rfind_from (of_string "foobarbaz") 5 (of_string "ba") = 3 rfind_from (of_string "foobarbaz") 7 (of_string "ba") = 6 rfind_from (of_string "foobarbaz") 6 (of_string "ba") = 3 rfind_from (of_string "foobarbaz") 7 (of_string "") = 8 Result.(catch (rfind_from (of_string "") 3) empty |> is_exn Out_of_bounds) Result.(catch (rfind_from (of_string "") (-1)) (of_string "a") |> is_exn Not_found) Result.(catch (rfind_from (of_string "foobarbaz") 2) (of_string "ba") |> is_exn Not_found) Result.(catch (rfind_from (of_string "foo") 3) (of_string "foo") |> is_exn Out_of_bounds) Result.(catch (rfind_from (of_string "foo") (-2)) (of_string "foo") |> is_exn Out_of_bounds) *) let rfind rop sub = rfind_from rop (length rop - 1) sub let exists r_str r_sub = try ignore(find r_str r_sub); true with Not_found -> false let strip_default_chars = List.map UChar.of_char [' ';'\t';'\r';'\n'] let strip ?(chars=strip_default_chars) rope = let rec strip_left n iter = match Iter.next iter with | None -> Empty | Some ch when List.mem ch chars -> strip_left (n + 1) iter | _ -> sub rope n (strip_right (length rope - n) (Iter.make rope)) and strip_right n iter = match Iter.prev iter with | None -> assert false | Some ch when List.mem ch chars -> strip_right (n - 1) iter | _ -> n in strip_left 0 (Iter.make rope) let lchop = function | Empty -> Empty | str -> sub str 1 (length str - 1) let rchop = function | Empty -> Empty | str -> sub str 0 (length str - 1) let of_list l = let e = ref l in let get_leaf () = Return.label (fun label -> let b = Buffer.create 256 in for _i = 1 to 256 do match !e with [] -> Return.return label (false, UTF8.of_string_unsafe (Buffer.contents b)) | c :: rest -> Buffer.add_string b (UTF8.to_string_unsafe (UTF8.of_char c)); e := rest done; (true, UTF8.of_string_unsafe (Buffer.contents b) )) in let rec loop r = (* concat 256 characters at a time *) match get_leaf () with (true, us) -> loop (append r (of_ustring us)) | (false, us) -> append r (of_ustring us) in loop Empty let splice r start len new_sub = let start = if start >= 0 then start else (length r) + start in append (left r start) (append new_sub (tail r (start+len))) let fill r start len char = splice r start len (make len char) let blit rsrc offsrc rdst offdst len = splice rdst offdst len (sub rsrc offsrc len) let concat sep r_list = match r_list with | [] -> empty | h :: t -> List.fold_left (fun r1 r2 -> append r1 (append sep r2)) h t (**T concat Text.concat (Text.of_string "xyz") [] = Text.empty **) let escaped r = bulk_map UTF8.escaped r let replace_chars f r = fold (fun acc s -> append_us acc (f s)) Empty r let split r sep = let i = find r sep in head r i, tail r (i+length sep) (*$T split split (of_string "OCaml, the coolest FP language.") (of_char ' ') = \ (of_string "OCaml,", of_string "the coolest FP language.") split (of_string "OCaml, the coolest FP language.") (of_char '.') = \ (of_string "OCaml, the coolest FP language", empty) Result.(catch (split (of_string "OCaml, the coolest FP language.")) \ (of_char '!') |> is_exn Not_found) *) let rsplit (r:t) sep = let i = rfind r sep in head r i, tail r (i+length sep) (*$T rsplit rsplit (of_string "OCaml, the coolest FP language.") (of_char ' ') = \ (of_string "OCaml, the coolest FP", of_string "language.") rsplit (of_string "OCaml, the coolest FP language.") (of_char 'O') = \ (empty, of_string "Caml, the coolest FP language.") Result.(catch (rsplit (of_string "OCaml, the coolest FP language.")) \ (of_char '!') |> is_exn Not_found) *) (** An implementation of [nsplit] in one pass. This implementation traverses the string backwards, hence building the list of substrings from the end to the beginning, so as to avoid a call to [List.rev]. *) let nsplit str sep = if is_empty str then [] else if is_empty sep then invalid_arg "Text.nsplit: empty sep not allowed" else (* str is not empty *) let seplen = length sep in let rec aux acc ofs = if ofs >= 0 then ( match try Some (rfind_from str ofs sep) with Not_found -> None with | Some idx -> (* sep found *) let end_of_sep = idx + seplen - 1 in if end_of_sep = ofs (* sep at end of str *) then aux (empty::acc) (idx - 1) else let token = sub str (end_of_sep + 1) (ofs - end_of_sep) in aux (token::acc) (idx - 1) | None -> (* sep NOT found *) (sub str 0 (ofs + 1))::acc ) else (* Negative ofs: the last sep started at the beginning of str *) empty::acc in aux [] (length str - 1 ) (*$T nsplit nsplit (of_string "OCaml, the coolest FP language.") (of_char 'o') \ |> List.map to_string = ["OCaml, the c"; ""; "lest FP language."] nsplit (of_string "OCaml, the coolest FP language.") (of_char '!') \ |> List.map to_string = ["OCaml, the coolest FP language."] nsplit (of_string "1,2,3") (of_string ",") \ |> List.map to_string = ["1"; "2"; "3"] nsplit (of_string "a;b;c") (of_string ";") \ |> List.map to_string = ["a"; "b"; "c"] nsplit (of_string "") (of_string "x") = [] try ignore (nsplit (of_string "abc") (of_string "")); false \ with Invalid_argument _ -> true nsplit (of_string "a/b/c") (of_string "/") |> List.map to_string \ = ["a"; "b"; "c"] nsplit (of_string "/a/b/c//") (of_string "/") |> List.map to_string \ = [""; "a"; "b"; "c"; ""; ""] nsplit (of_string "FOOaFOObFOOcFOOFOO") (of_string "FOO") |> List.map to_string \ = [""; "a"; "b"; "c"; ""; ""] *) let join = concat let slice ?(first=0) ?(last=max_int) s = let clip _min _max x = int_max _min (int_min _max x) in let i = clip 0 (length s) (if (first<0) then (length s) + first else first) and j = clip 0 (length s) (if (last<0) then (length s) + last else last) in if i>=j || i=length s then Empty else sub s i (j-i) let replace ~str ~sub ~by = try let i = find str sub in (true, append (slice ~last:i str) (append by (slice ~first:(i+(length sub)) str))) with Not_found -> (false, str) let explode r = List.rev (fold (fun a u -> u :: a) [] r) (*$T explode explode (of_string "foo") = List.map UChar.of_char ['f'; 'o'; 'o'] explode (of_string "ếẶ") = List.map UChar.chr [0x1ebf; 0x1eb6] explode (of_string "") = [] *) let implode l = of_list l (*$T implode implode (List.map UChar.of_char ['f'; 'o'; 'o']) = of_string "foo" implode (List.map UChar.chr [0x1ebf; 0x1eb6]) = of_string "ếẶ" implode [] = of_string "" *) let of_latin1 s = of_ustring (UTF8.of_latin1 s) let print out t = bulk_iter (BatIO.nwrite out) t open BatIO (** {6 Unicode}*) (** {7 Reading unicode} All these functions assume that the input is UTF-8 encoded. *) (*val read_uchar: input -> UChar.t*) (** read one UChar from a UTF-8 encoded input*) let read_char i = let n0 = read i in let len = UTF8.length0 (Char.code n0) in if len = 1 then UChar.of_char n0 else let s = Bytes.create len in Bytes.set s 0 n0; let n = really_input i s 1 (len - 1) in assert (n = len - 1); let s = Bytes.unsafe_to_string s in UTF8.get s 0 (*val uchars_of : input -> UChar.t BatEnum.t*) (** offer the characters of an UTF-8 encoded input as an enumeration*) let chars_of i = make_enum read_char i (*val read_rope: input -> int -> Rope.t*) (** read up to n uchars from a UTF-8 encoded input*) let read_text i n = let rec loop r j = if j = 0 then r else loop (append_char (read_char i) r) (j-1) (* TODO: make more efficient by appending a string of Rope.leaf_size (256) chars at a time *) in if n <= 0 then empty else loop empty n (** read the whole contents of a UTF-8 encoded input*) let read_all i = of_string (BatIO.read_all i) (* TODO: make efficient - possibly similar to above - buffering leaf_size chars at a time *) (** read a line of UTF-8*) let read_line i = let line = read_line i in UTF8.validate line; of_string line (** offer the lines of a UTF-8 encoded input as an enumeration*) let lines_of i = BatIO.make_enum read_line i (** {7 Writing unicode} All these functions assume that the output is UTF-8 encoded.*) let write_string o c = write_string o c (*val write_uchar: _ output -> UChar.t -> unit*) let write_char o c = write_string o (UTF8.init 1 (fun _ -> c)) (*val write_rope : _ output -> Rope.t -> unit*) let write_text = print (*val write_uline: _ output -> Rope.t -> unit*) let write_line o r = write_text o r; write o '\n' (*val write_ulines : _ output -> Rope.t BatEnum.t -> unit*) let write_lines o re = BatEnum.iter (write_line o) re (*val write_ropes : _ output -> Rope.t BatEnum.t -> unit*) let write_texts o re = BatEnum.iter (write_text o) re (*val write_uchars : _ output -> UChar.t BatEnum.t -> unit*) let write_chars o uce = BatEnum.iter (write_char o) uce let sprintf fmt = BatPrintf.ksprintf of_string fmt let ksprintf k fmt = BatPrintf.ksprintf (fun s -> k (of_string s)) fmt let output_text = print batteries-included-3.4.0/src/batText.mli000066400000000000000000000426701415601150500202010ustar00rootroot00000000000000(* * BatText - Unicode text library * Copyright (C) 2012 The Batteries Included Team * Copyright (C) 2011 Yoriyuki Yamagata * 2007 Mauricio Fernandez http://eigenclass.org * * Uses a simple implementation of ropes as described in * * Boehm, H., Atkinson, R., and Plass, M. 1995. Ropes: an alternative to * strings. Softw. Pract. Exper. 25, 12 (Dec. 1995), 1315-1330. * * Motivated by Luca de Alfaro's extensible array implementation Vec. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Heavyweight strings ("ropes") This module implements ropes as described in Boehm, H., Atkinson, R., and Plass, M. 1995. Ropes: an alternative to strings. Softw. Pract. Exper. 25, 12 (Dec. 1995), 1315-1330. Ropes are an alternative to strings which support efficient operations: - determining the length of a rope in constant time - appending or prepending a small rope to an arbitrarily large one in amortized constant time - concat, substring, insert, remove operations in amortized logarithmic time - access to and modification of ropes in logarithmic time {8 Functional nature and persistence} All operations are non-destructive: the original rope is never modified. When a new rope is returned as the result of an operation, it will share as much data as possible with its "parent". For instance, if a rope of length [n] undergoes [m] operations (assume [n >> m]) like set, append or prepend, the modified rope will only require [O(m)] space in addition to that taken by the original one. However, Rope is an amortized data structure, and its use in a persistent setting can easily degrade its amortized time bounds. It is thus mainly intended to be used ephemerally. In some cases, it is possible to use Rope persistently with the same amortized bounds by explicitly rebalancing ropes to be reused using [balance]. Special care must be taken to avoid calling [balance] too frequently; in the limit, calling [balance] after each modification would defeat the purpose of amortization. {8 Limitations} The length of ropes is limited to approximately 700 Mb on 32-bit architectures, 220 Gb on 64 bit architectures. @author Mauricio Fernandez, Yoriyuki Yamagata, The Batteries Included Team *) type t (** The type of the rope. *) exception Out_of_bounds (** Raised when an operation violates the bounds of the rope. *) val max_length : int (** Maximum length of the rope (number of UTF-8 characters). *) (** {6 Creation and conversions} *) val empty : t (** The empty rope. *) val of_latin1 : string -> t (** Constructs a unicode rope from a latin-1 string. *) val of_string : string -> t (** [of_string s] returns a rope corresponding to the UTF-8 encoded string [s].*) val to_string : t -> string (** [to_string t] returns a UTF-8 encoded string representing [t]*) val of_uchar : BatUChar.t -> t (** [of_uchar c] returns a rope containing exactly character [c].*) val of_char : char -> t (** [of_char c] returns a rope containing exactly Latin-1 character [c].*) val make : int -> BatUChar.t -> t (** [make i c] returns a rope of length [i] consisting of [c] chars; it is similar to String.make *) val join : t -> t list -> t (** Same as {!concat} *) val explode : t -> BatUChar.t list (** [explode s] returns the list of characters in the rope [s]. *) val implode : BatUChar.t list -> t (** [implode cs] returns a rope resulting from concatenating the characters in the list [cs]. *) (** {6 Properties } *) val is_empty : t -> bool (** Returns whether the rope is empty or not. *) val length : t -> int (** Returns the length of the rope ([O(1)]). This is number of UTF-8 characters. *) val height : t -> int (** Returns the height (depth) of the rope. *) val balance : t -> t (** [balance r] returns a balanced copy of the [r] rope. Note that ropes are automatically rebalanced when their height exceeds a given threshold, but [balance] allows to invoke that operation explicitly. *) (** {6 Operations } *) val append : t -> t -> t (** [append r u] concatenates the [r] and [u] ropes. In general, it operates in [O(log(min n1 n2))] amortized time. Small ropes are treated specially and can be appended/prepended in amortized [O(1)] time. *) val ( ^^^ ): t -> t -> t (** As {!append}*) val append_char : BatUChar.t -> t -> t (** [append_char c r] returns a new rope with the [c] character at the end in amortized [O(1)] time. *) val prepend_char : BatUChar.t -> t -> t (** [prepend_char c r] returns a new rope with the [c] character at the beginning in amortized [O(1)] time. *) val get : t -> int -> BatUChar.t (** [get r n] returns the (n+1)th character from the rope [r]; i.e. [get r 0] returns the first character. Operates in worst-case [O(log size)] time. @raise Out_of_bounds if a character out of bounds is requested. *) val set : t -> int -> BatUChar.t -> t (** [set r n c] returns a copy of rope [r] where the (n+1)th character has been set to [c]. See also {!get}. Operates in worst-case [O(log size)] time. *) val sub : t -> int -> int -> t (** [sub r m n] returns a sub-rope of [r] containing all characters whose indexes range from [m] to [m + n - 1] (included). Operates in worst-case [O(log size)] time. @raise Out_of_bounds in the same cases as sub. *) val insert : int -> t -> t -> t (** [insert n r u] returns a copy of the [u] rope where [r] has been inserted between the characters with index [n] and [n + 1] in the original rope. The length of the new rope is [length u + length r]. Operates in amortized [O(log(size r) + log(size u))] time. *) val remove : int -> int -> t -> t (** [remove m n r] returns the rope resulting from deleting the characters with indexes ranging from [m] to [m + n - 1] (included) from the original rope [r]. The length of the new rope is [length r - n]. Operates in amortized [O(log(size r))] time. *) val concat : t -> t list -> t (** [concat sep sl] concatenates the list of ropes [sl], inserting the separator rope [sep] between each. *) (** {6 Iteration} *) val iter : (BatUChar.t -> unit) -> t -> unit (** [iter f r] applies [f] to all the characters in the [r] rope, in order. *) val iteri : ?base:int -> (int -> BatUChar.t -> unit) -> t -> unit (** Operates like [iter], but also passes the index of the character to the given function. *) val range_iter : (BatUChar.t -> unit) -> int -> int -> t -> unit (** [range_iter f m n r] applies [f] to all the characters whose indices [k] satisfy [m] <= [k] < [m + n]. It is thus equivalent to [iter f (sub m n r)], but does not create an intermediary rope. [range_iter] operates in worst-case [O(n + log m)] time, which improves on the [O(n log m)] bound from an explicit loop using [get]. @raise Out_of_bounds in the same cases as [sub]. *) val range_iteri : (int -> BatUChar.t -> unit) -> ?base:int -> int -> int -> t -> unit (** As [range_iter], but passes base + index of the character in the subrope defined by next to arguments. *) val fold : ('a -> BatUChar.t -> 'a ) -> 'a -> t -> 'a (** [Rope.fold f a r] computes [ f (... (f (f a r0) r1)...) rN-1 ] where [rn = Rope.get n r ] and [N = length r]. *) val init : int -> (int -> BatUChar.t) -> t (** [init l f] returns the rope of length [l] with the chars f 0 , f 1 , f 2 ... f (l-1). *) val map : (BatUChar.t -> BatUChar.t) -> t -> t (** [map f s] returns a rope where all characters [c] in [s] have been replaced by [f c]. **) val filter_map : (BatUChar.t -> BatUChar.t option) -> t -> t (** [filter_map f l] calls [(f a0) (f a1).... (f an)] where [a0..an] are the characters of [l]. It returns the list of elements [bi] such as [f ai = Some bi] (when [f] returns [None], the corresponding element of [l] is discarded). *) val filter : (BatUChar.t -> bool) -> t -> t (** [filter f s] returns a copy of rope [s] in which only characters [c] such that [f c = true] remain.*) val enum : t -> BatUChar.t BatEnum.t (** enumerate the rope's characters @since 2.2.0 *) val backwards : t -> BatUChar.t BatEnum.t (** enumerates the rope's characters, in reverse order @since 2.2.0 *) val of_enum : BatUChar.t BatEnum.t -> t (** converts the enumeration into a rope @since 2.2.0 *) (** {6 Finding}*) val index : t -> BatUChar.t -> int (** [index s c] returns the position of the leftmost occurrence of character [c] in rope [s]. @raise Not_found if [c] does not occur in [s]. *) val index_from : t -> int -> BatUChar.t -> int (** [index_from r i c] returns the character number of the first occurrence of character [c] in rope [r] after position [i]. [index s c] is equivalent to [index_from s 0 c]. @raise Out_of_bounds if [i] is not a valid position in [r]. @raise Not_found if [c] does not occur in [r] after position [i]. *) val rindex : t -> BatUChar.t -> int (** [Rope.rindex s c] returns the position of the rightmost occurrence of character [c] in rope [s]. @raise Not_found if [c] does not occur in [s]. *) val rindex_from : t -> int -> BatUChar.t -> int (** Same as {!rindex}, but start searching at the character position given as second argument. [rindex s c] is equivalent to [rindex_from s (length s - 1) c]. *) val contains : t -> BatUChar.t -> bool (** [contains s c] tests if character [c] appears in the rope [s]. *) val contains_from : t -> int -> BatUChar.t -> bool (** [contains_from s start c] tests if character [c] appears in the subrope of [s] starting from [start] to the end of [s]. @raise Out_of_bounds if [start] is not a valid index of [s]. *) val rcontains_from : t -> int -> BatUChar.t -> bool (** [rcontains_from s stop c] tests if character [c] appears in the subrope of [s] starting from the beginning of [s] to index [stop] (included). @raise Out_of_bounds if [stop] is not a valid index of [s]. *) val find : t -> t -> int (** [find s x] returns the starting index of the first occurrence of rope [x] within rope [s]. {b Note} This implementation is optimized for short ropes. @raise Not_found if [x] is not a subrope of [s]. *) val find_from : t -> int -> t -> int (** [find_from s ofs x] behaves as [find s x] but starts searching at offset [ofs]. [find s x] is equivalent to [find_from s 0 x]. @raise Out_of_bounds if [ofs] is not a valid_position in [s]. @raise Not_found if [x] is not a subrope of [s]. *) val rfind : t -> t -> int (** [rfind s x] returns the starting index of the last occurrence of rope [x] within rope [s]. {b Note} This implementation is optimized for short ropes. @raise Not_found if [x] is not a subrope of [s]. *) val rfind_from : t -> int -> t -> int (** [rfind_from s ofs x] behaves as [rfind s x] but starts searching at offset [ofs]. [rfind s x] is equivalent to [rfind_from s (length s - 1) x]. @raise Out_of_bounds if [ofs] is not a valid_position in [s]. @raise Not_found if [x] is not a subrope of [s]. *) val starts_with : t -> t -> bool (** [starts_with s x] returns [true] if [s] is starting with [x], [false] otherwise. *) val ends_with : t -> t -> bool (** [ends_with s x] returns [true] if the rope [s] is ending with [x], [false] otherwise. *) val exists : t -> t -> bool (** [exists str sub] returns true if [sub] is a subrope of [str] or false otherwise. *) val left : t -> int -> t (**[left r len] returns the rope containing the [len] first characters of [r]*) val right : t -> int -> t (**[left r len] returns the rope containing the [len] last characters of [r]*) val head : t -> int -> t (**as {!left}*) val tail : t -> int -> t (**[tail r pos] returns the rope containing all but the [pos] first characters of [r]*) val strip : ?chars:(BatUChar.t list) -> t -> t (** Returns the rope without the chars if they are at the beginning or at the end of the rope. By default chars are " \t\r\n". *) val lchop : t -> t (** Returns the same rope but without the first character. does nothing if the rope is empty. *) val rchop : t -> t (** Returns the same rope but without the last character. does nothing if the rope is empty. *) val slice : ?first:int -> ?last:int -> t -> t (** [slice ?first ?last s] returns a "slice" of the rope which corresponds to the characters [s.[first]], [s.[first+1]], ..., [s[last-1]]. Note that the character at index [last] is {b not} included! If [first] is omitted it defaults to the start of the rope, i.e. index 0, and if [last] is omitted is defaults to point just past the end of [s], i.e. [length s]. Thus, [slice s] is equivalent to [copy s]. Negative indexes are interpreted as counting from the end of the rope. For example, [slice ~last:-2 s] will return the rope [s], but without the last two characters. This function {b never} raises any exceptions. If the indexes are out of bounds they are automatically clipped. *) val splice : t -> int -> int -> t -> t (** [splice s off len rep] returns the rope in which the section of [s] indicated by [off] and [len] has been cut and replaced by [rep]. Negative indices are interpreted as counting from the end of the string.*) val fill : t -> int -> int -> BatUChar.t -> t (** [fill s start len c] returns the rope in which characters number [start] to [start + len - 1] of [s] has been replaced by [c]. @raise Invalid_argument if [start] and [len] do not designate a valid subrope of [s]. *) val blit : t -> int -> t -> int -> int -> t (** [blit src srcoff dst dstoff len] returns a copy of [dst] in which [len] characters have been copied from rope [src], starting at character number [srcoff], to rope [dst], starting at character number [dstoff]. It works correctly even if [src] and [dst] are the same rope, and the source and destination chunks overlap. @raise Invalid_argument if [srcoff] and [len] do not designate a valid subrope of [src], or if [dstoff] and [len] do not designate a valid subrope of [dst]. *) val concat : t -> t list -> t (** [concat sep sl] concatenates the list of ropes [sl], inserting the separator rope [sep] between each. *) val replace : str:t -> sub:t -> by:t -> bool * t (** [replace ~str ~sub ~by] returns a tuple constisting of a boolean and a rope where the first occurrence of the rope [sub] within [str] has been replaced by the rope [by]. The boolean is [true] if a substitution has taken place, [false] otherwise. *) (** {6 Splitting around}*) val split : t -> t -> t * t (** [split s sep] splits the rope [s] between the first occurrence of [sep]. @raise Not_found if the separator is not found. *) val rsplit : t -> t -> t * t (** [rsplit s sep] splits the rope [s] between the last occurrence of [sep]. @raise Not_found if the separator is not found. *) val nsplit : t -> t -> t list (** [nsplit s sep] splits the rope [s] into a list of ropes which are separated by [sep]. [nsplit "" _] returns the empty list. If the separator is not found, it returns a list of the rope [s]. If two occurrences of the separator are consecutive (with nothing in between), the empty rope is added in the sequence. For example, [nsplit "a//b/" "/"] is ["a"; ""; "b"; ""]. @raise Invalid_argument if the separator is empty *) val compare : t -> t -> int (** The comparison function for ropes, with the same specification as {!Pervasives.compare}. Along with the type [t], this function [compare] allows the module [Rope] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) val equal : t -> t -> bool (** Equality of ropes (based on compare) @since 2.2.0 *) open BatIO val print : (t,_) printer (** Prints a rope to the given out_channel *) (* From BatIO *) val read_char: input -> BatUChar.t (** Read one Unicode char from a UTF-8 encoded input*) val read_text: input -> int -> t (** Read up to n chars from a UTF-8 encoded input*) val read_line: input -> t (** Read a line of UTF-8*) val read_all : input -> t (** Read the whole contents of a UTF-8 encoded input*) val write_char: (BatUChar.t, _) printer (** Write one uchar to a UTF-8 encoded output.*) val write_text : (t, _) printer (** Write a character text onto a UTF-8 encoded output.*) val write_line: (t, _) printer (** Write one line onto a UTF-8 encoded output, followed by a \n.*) val lines_of : input -> t BatEnum.t (** offer the lines of a UTF-8 encoded input as an enumeration*) val chars_of : input -> BatUChar.t BatEnum.t (** offer the characters of an UTF-8 encoded input as an enumeration*) (* From pervasives *) val output_text : unit BatIO.output -> t -> unit (** Write the text on the given output channel. *) (**/**) val write_lines : (t BatEnum.t, 'a) printer val write_texts : (t BatEnum.t, 'a) printer val write_chars : (BatUChar.t BatEnum.t, 'a) printer (**/**) batteries-included-3.4.0/src/batTuple.ml000066400000000000000000000320221415601150500201630ustar00rootroot00000000000000(* * Tuples - functions for tuples * Copyright (C) 2003 Nicolas Cannasse * 2008 David Teller (Contributor) * 2011 Ashish Agarwal * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module Tuple2 = struct type ('a,'b) t = 'a * 'b type 'a enumerable = 'a * 'a let make a b = (a, b) external first : 'a * 'b -> 'a = "%field0" external second : 'a * 'b -> 'b = "%field1" let swap (a,b) = (b,a) let map f g (a,b) = let a = f a in (a, g b) let mapn f (x,y) = (* force left-to-right evaluation order (this principle of least surprise is already applied in stdlib's List.map) *) let a = f x in (a, f y) let map1 f (a,b) = (f a, b) let map2 f (a,b) = (a, f b) let curry f x y = f (x,y) let uncurry f (x,y) = f x y let enum (x,y) = BatList.enum [x;y] (* Make efficient? *) let of_enum e = match BatEnum.get e with None -> failwith "Tuple2.of_enum: not enough elements" | Some x -> match BatEnum.get e with None -> failwith "Tuple2.of_enum: not enough elements" | Some y -> (x,y) let print ?(first="(") ?(sep=",") ?(last=")") print_a print_b out (a,b) = BatIO.nwrite out first; print_a out a; BatIO.nwrite out sep; print_b out b; BatIO.nwrite out last let printn ?(first="(") ?(sep=",") ?(last=")") printer out pair = print ~first ~sep ~last printer printer out pair let compare ?(cmp1=Pervasives.compare) ?(cmp2=Pervasives.compare) (a,b) (c,d) = let comp = cmp1 a c in if comp <> 0 then comp else cmp2 b d open BatOrd let eq eq1 eq2 = fun (t1, t2) (t1', t2') -> bin_eq eq1 t1 t1' eq2 t2 t2' let ord ord1 ord2 = fun (t1, t2) (t1', t2') -> bin_ord ord1 t1 t1' ord2 t2 t2' let comp comp1 comp2 = fun (t1, t2) (t1', t2') -> bin_comp comp1 t1 t1' comp2 t2 t2' module Eq (A : Eq) (B : Eq) = struct type t = A.t * B.t let eq = eq A.eq B.eq end module Ord (A : Ord) (B : Ord) = struct type t = A.t * B.t let ord = ord A.ord B.ord end module Comp (A : Comp) (B : Comp) = struct type t = A.t * B.t let compare = comp A.compare B.compare end end module Tuple3 = struct type ('a,'b,'c) t = 'a * 'b * 'c type 'a enumerable = 'a * 'a * 'a let make a b c = (a, b, c) let first (a,_,_) = a let second (_,b,_) = b let third (_,_,c) = c let get12 (a,b,_) = (a,b) let get13 (a,_,c) = (a,c) let get23 (_,b,c) = (b,c) let map f1 f2 f3 (a,b,c) = let a = f1 a in let b = f2 b in (a, b, f3 c) let mapn f (a,b,c) = let a = f a in let b = f b in (a, b, f c) let map1 f (a,b,c) = (f a, b, c) let map2 f (a,b,c) = (a, f b, c) let map3 f (a,b,c) = (a, b, f c) let curry f a b c = f (a,b,c) let uncurry f (a,b,c) = f a b c let enum (a,b,c) = BatList.enum [a;b;c] (* Make efficient? *) let of_enum e = match BatEnum.get e with None -> failwith "Tuple3.of_enum: not enough elements" | Some a -> match BatEnum.get e with None -> failwith "Tuple3.of_enum: not enough elements" | Some b -> match BatEnum.get e with None -> failwith "Tuple3.of_enum: not enough elements" | Some c -> (a,b,c) let print ?(first="(") ?(sep=",") ?(last=")") print_a print_b print_c out (a,b,c) = BatIO.nwrite out first; print_a out a; BatIO.nwrite out sep; print_b out b; BatIO.nwrite out sep; print_c out c; BatIO.nwrite out last let printn ?(first="(") ?(sep=",") ?(last=")") printer out pair = print ~first ~sep ~last printer printer printer out pair let compare ?(cmp1=Pervasives.compare) ?(cmp2=Pervasives.compare) ?(cmp3=Pervasives.compare) (a1,a2,a3) (b1,b2,b3) = let c1 = cmp1 a1 b1 in if c1 <> 0 then c1 else let c2 = cmp2 a2 b2 in if c2 <> 0 then c2 else cmp3 a3 b3 open BatOrd let eq eq1 eq2 eq3 = fun (t1, t2, t3) (t1', t2', t3') -> bin_eq eq1 t1 t1' (bin_eq eq2 t2 t2' eq3) t3 t3' let ord ord1 ord2 ord3 = fun (t1, t2, t3) (t1', t2', t3') -> bin_ord ord1 t1 t1' (bin_ord ord2 t2 t2' ord3) t3 t3' let comp comp1 comp2 comp3 = fun (t1, t2, t3) (t1', t2', t3') -> bin_comp comp1 t1 t1' (bin_comp comp2 t2 t2' comp3) t3 t3' module Eq (A : Eq) (B : Eq) (C : Eq) = struct type t = A.t * B.t * C.t let eq = eq A.eq B.eq C.eq end module Ord (A : Ord) (B : Ord) (C : Ord) = struct type t = A.t * B.t * C.t let ord = ord A.ord B.ord C.ord end module Comp (A : Comp) (B : Comp) (C : Comp)= struct type t = A.t * B.t * C.t let compare = comp A.compare B.compare C.compare end end module Tuple4 = struct type ('a,'b,'c,'d) t = 'a * 'b * 'c * 'd type 'a enumerable = 'a * 'a * 'a * 'a let make a b c d = (a, b, c, d) let first (a,_,_,_) = a let second (_,b,_,_) = b let third (_,_,c,_) = c let fourth (_,_,_,d) = d let get12 (a,b,_,_) = (a,b) let get13 (a,_,c,_) = (a,c) let get14 (a,_,_,d) = (a,d) let get23 (_,b,c,_) = (b,c) let get24 (_,b,_,d) = (b,d) let get34 (_,_,c,d) = (c,d) let get123 (a,b,c,_) = (a,b,c) let get124 (a,b,_,d) = (a,b,d) let get234 (_,b,c,d) = (b,c,d) let map f1 f2 f3 f4 (a,b,c,d) = let a = f1 a in let b = f2 b in let c = f3 c in (a, b, c, f4 d) let mapn f (a,b,c,d) = let a = f a in let b = f b in let c = f c in (a, b, c, f d) let map1 f (a,b,c,d) = (f a, b, c, d) let map2 f (a,b,c,d) = (a, f b, c, d) let map3 f (a,b,c,d) = (a, b, f c, d) let map4 f (a,b,c,d) = (a, b, c, f d) let curry f a b c d = f (a,b,c,d) let uncurry f (a,b,c,d) = f a b c d let enum (a,b,c,d) = BatList.enum [a;b;c;d] (* Make efficient? *) let of_enum e = match BatEnum.get e with None -> failwith "Tuple4.of_enum: not enough elements" | Some a -> match BatEnum.get e with None -> failwith "Tuple4.of_enum: not enough elements" | Some b -> match BatEnum.get e with None -> failwith "Tuple4.of_enum: not enough elements" | Some c -> match BatEnum.get e with None -> failwith "Tuple4.of_enum: not enough elements" | Some d -> (a,b,c,d) let print ?(first="(") ?(sep=",") ?(last=")") print_a print_b print_c print_d out (a,b,c,d) = BatIO.nwrite out first; print_a out a; BatIO.nwrite out sep; print_b out b; BatIO.nwrite out sep; print_c out c; BatIO.nwrite out sep; print_d out d; BatIO.nwrite out last let printn ?(first="(") ?(sep=",") ?(last=")") printer out pair = print ~first ~sep ~last printer printer printer printer out pair let compare ?(cmp1=Pervasives.compare) ?(cmp2=Pervasives.compare) ?(cmp3=Pervasives.compare) ?(cmp4=Pervasives.compare) (a1,a2,a3,a4) (b1,b2,b3,b4) = let c1 = cmp1 a1 b1 in if c1 <> 0 then c1 else let c2 = cmp2 a2 b2 in if c2 <> 0 then c2 else let c3 = cmp3 a3 b3 in if c3 <> 0 then c3 else cmp4 a4 b4 open BatOrd let eq eq1 eq2 eq3 eq4 = fun (t1, t2, t3, t4) (t1', t2', t3', t4') -> bin_eq eq1 t1 t1' (bin_eq eq2 t2 t2' (bin_eq eq3 t3 t3' eq4)) t4 t4' let ord ord1 ord2 ord3 ord4 = fun (t1, t2, t3, t4) (t1', t2', t3', t4') -> bin_ord ord1 t1 t1' (bin_ord ord2 t2 t2' (bin_ord ord3 t3 t3' ord4)) t4 t4' let comp comp1 comp2 comp3 comp4 = fun (t1, t2, t3, t4) (t1', t2', t3', t4') -> bin_comp comp1 t1 t1' (bin_comp comp2 t2 t2' (bin_comp comp3 t3 t3' comp4)) t4 t4' module Eq (A : Eq) (B : Eq) (C : Eq) (D : Eq) = struct type t = A.t * B.t * C.t * D.t let eq = eq A.eq B.eq C.eq D.eq end module Ord (A : Ord) (B : Ord) (C : Ord) (D : Ord) = struct type t = A.t * B.t * C.t * D.t let ord = ord A.ord B.ord C.ord D.ord end module Comp (A : Comp) (B : Comp) (C : Comp) (D : Comp) = struct type t = A.t * B.t * C.t * D.t let compare = comp A.compare B.compare C.compare D.compare end end module Tuple5 = struct type ('a,'b,'c,'d,'e) t = 'a * 'b * 'c * 'd * 'e type 'a enumerable = 'a * 'a * 'a * 'a * 'a let make a b c d e = (a, b, c, d, e) let first (a,_,_,_,_) = a let second (_,b,_,_,_) = b let third (_,_,c,_,_) = c let fourth (_,_,_,d,_) = d let fifth (_,_,_,_,e) = e let get12 (a,b,_,_,_) = (a,b) let get13 (a,_,c,_,_) = (a,c) let get14 (a,_,_,d,_) = (a,d) let get15 (a,_,_,_,e) = (a,e) let get23 (_,b,c,_,_) = (b,c) let get24 (_,b,_,d,_) = (b,d) let get25 (_,b,_,_,e) = (b,e) let get34 (_,_,c,d,_) = (c,d) let get35 (_,_,c,_,e) = (c,e) let get45 (_,_,_,d,e) = (d,e) let get123 (a,b,c,_,_) = (a,b,c) let get124 (a,b,_,d,_) = (a,b,d) let get125 (a,b,_,_,e) = (a,b,e) let get134 (a,_,c,d,_) = (a,c,d) let get135 (a,_,c,_,e) = (a,c,e) let get145 (a,_,_,d,e) = (a,d,e) let get234 (_,b,c,d,_) = (b,c,d) let get235 (_,b,c,_,e) = (b,c,e) let get245 (_,b,_,d,e) = (b,d,e) let get345 (_,_,c,d,e) = (c,d,e) let get1234 (a,b,c,d,_) = (a,b,c,d) let get1235 (a,b,c,_,e) = (a,b,c,e) let get1245 (a,b,_,d,e) = (a,b,d,e) let get1345 (a,_,c,d,e) = (a,c,d,e) let get2345 (_,b,c,d,e) = (b,c,d,e) let map f1 f2 f3 f4 f5 (a,b,c,d,e) = let a = f1 a in let b = f2 b in let c = f3 c in let d = f4 d in (a, b, c, d, f5 e) let mapn f (a,b,c,d,e) = let a = f a in let b = f b in let c = f c in let d = f d in (a, b, c, d, f e) let map1 f (a,b,c,d,e) = (f a, b, c, d, e) let map2 f (a,b,c,d,e) = (a, f b, c, d, e) let map3 f (a,b,c,d,e) = (a, b, f c, d, e) let map4 f (a,b,c,d,e) = (a, b, c, f d, e) let map5 f (a,b,c,d,e) = (a, b, c, d, f e) let curry f a b c d e = f (a,b,c,d,e) let uncurry f (a,b,c,d,e) = f a b c d e let enum (a,b,c,d,e) = BatList.enum [a;b;c;d;e] (* Make efficient? *) let of_enum e = match BatEnum.get e with None -> failwith "Tuple5.of_enum: not enough elements" | Some a -> match BatEnum.get e with None -> failwith "Tuple5.of_enum: not enough elements" | Some b -> match BatEnum.get e with None -> failwith "Tuple5.of_enum: not enough elements" | Some c -> match BatEnum.get e with None -> failwith "Tuple5.of_enum: not enough elements" | Some d -> match BatEnum.get e with None -> failwith "Tuple5.of_enum: not enough elements" | Some e -> (a,b,c,d,e) let print ?(first="(") ?(sep=",") ?(last=")") print_a print_b print_c print_d print_e out (a,b,c,d,e) = BatIO.nwrite out first; print_a out a; BatIO.nwrite out sep; print_b out b; BatIO.nwrite out sep; print_c out c; BatIO.nwrite out sep; print_d out d; BatIO.nwrite out sep; print_e out e; BatIO.nwrite out last let printn ?(first="(") ?(sep=",") ?(last=")") printer out pair = print ~first ~sep ~last printer printer printer printer printer out pair let compare ?(cmp1=Pervasives.compare) ?(cmp2=Pervasives.compare) ?(cmp3=Pervasives.compare) ?(cmp4=Pervasives.compare) ?(cmp5=Pervasives.compare) (a1,a2,a3,a4,a5) (b1,b2,b3,b4,b5) = let c1 = cmp1 a1 b1 in if c1 <> 0 then c1 else let c2 = cmp2 a2 b2 in if c2 <> 0 then c2 else let c3 = cmp3 a3 b3 in if c3 <> 0 then c3 else let c4 = cmp4 a4 b4 in if c4 <> 0 then c4 else cmp5 a5 b5 open BatOrd let eq eq1 eq2 eq3 eq4 eq5 = fun (t1, t2, t3, t4, t5) (t1', t2', t3', t4', t5') -> bin_eq eq1 t1 t1' (bin_eq eq2 t2 t2' (bin_eq eq3 t3 t3' (bin_eq eq4 t4 t4' eq5))) t5 t5' let ord ord1 ord2 ord3 ord4 ord5 = fun (t1, t2, t3, t4, t5) (t1', t2', t3', t4', t5') -> bin_ord ord1 t1 t1' (bin_ord ord2 t2 t2' (bin_ord ord3 t3 t3' (bin_ord ord4 t4 t4' ord5))) t5 t5' let comp comp1 comp2 comp3 comp4 comp5 = fun (t1, t2, t3, t4, t5) (t1', t2', t3', t4', t5') -> bin_comp comp1 t1 t1' (bin_comp comp2 t2 t2' (bin_comp comp3 t3 t3' (bin_comp comp4 t4 t4' comp5))) t5 t5' module Eq (A : Eq) (B : Eq) (C : Eq) (D : Eq) (E : Eq) = struct type t = A.t * B.t * C.t * D.t * E.t let eq = eq A.eq B.eq C.eq D.eq E.eq end module Ord (A : Ord) (B : Ord) (C : Ord) (D : Ord) (E : Ord) = struct type t = A.t * B.t * C.t * D.t * E.t let ord = ord A.ord B.ord C.ord D.ord E.ord end module Comp (A : Comp) (B : Comp) (C : Comp) (D : Comp) (E : Comp) = struct type t = A.t * B.t * C.t * D.t * E.t let compare = comp A.compare B.compare C.compare D.compare E.compare end end batteries-included-3.4.0/src/batTuple.mli000066400000000000000000000336711415601150500203470ustar00rootroot00000000000000(* * Tuples - functions for tuples * Copyright (C) 2009 Edgar Friendly * 2011 Ashish Agarwal * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Tuples. NOTE: API changes are expected in a future release. Modules are provided for tuples with 2, 3, 4, and 5 elements. Each provides the following categories of functions. Creation. Functions [make] take [n] arguments and build a [n]-tuple. Projection. Functions [first], [second], [third], [fourth], and [fifth] extract a single element. Also, multiple elements can be extracted. For example, {!Tuple3.get13} returns the first and third elements of a 3-tuple. All possible combinations are provided. Note there are no [get] functions in Tuple2 because [first] and [second] already cover all possibilities. However, [swap] is provided, which can be thought of as projecting items in a different order. Mapping. Apply a function to one or all elements of a tuple. Functions [map1], [map2], etc. map a given function to the first, second, etc. element of a tuple. All elements can be mapped using [map] or [mapn]. For example, {!Tuple3.map} [f g h] will apply [f], [g], and [h] to the three elements, respectively, of a 3-tuple. Function [mapn] is similar but applies the same function to all elements, which thus requires the elements to be of the same type. Currying. Every tuple has a [curry] and [uncurry] function, which allow converting between functions that take [n] arguments to ones that take a single [n]-tuple argument. Enumeration. Every [n]-tuple can be converted to an enum with [n] elements using its [enum] function, and can be constructed from an enum using [of_enum]. Tuples satisfy {!BatEnum.Enumerable}. Printing. Function [print] prints a tuple given a method for printing each of its elements. The simpler [printn] function can be used when all elements are of the same type. Comparison. Every tuple has a [compare] function, which can optionally be customized by specifying methods for comparing each element. {!Pervasives.compare} is used by default. *) (** Pairs. Some of the functions here are also exposed in {!Pervasives}, as documented below. @author Edgar Friendly @author Ashish Agarwal *) module Tuple2 : sig type ('a,'b) t = 'a * 'b val make : 'a -> 'b -> 'a * 'b external first : 'a * 'b -> 'a = "%field0" (** Equivalent to {!Pervasives.fst}. *) external second : 'a * 'b -> 'b = "%field1" (** Equivalent to {!Pervasives.snd}. *) val swap : ('a * 'b) -> ('b * 'a) val map : ('a -> 'c) -> ('b -> 'd) -> 'a * 'b -> 'c * 'd (** Equivalent to {!BatPervasives.(***)}. *) val mapn : ('a -> 'b) -> ('a * 'a) -> ('b * 'b) (** Like {!map} but specialized for tuples with elements of the same type. [mapn f] is equivalent to [map f f]. *) val map1 : ('a -> 'c) -> ('a * 'b) -> ('c * 'b) (** [map1 f (x,y)] returns (f x,y) *) val map2 : ('b -> 'c) -> ('a * 'b) -> ('a * 'c) (** [map2 f (x,y)] returns (x,f y) *) val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c val enum : ('a * 'a) -> 'a BatEnum.t val of_enum : 'a BatEnum.t -> ('a * 'a) (** @raise Failure if enum does not contain at least 2 elements. *) val print : ?first:string -> ?sep:string -> ?last:string -> ('o BatIO.output -> 'a -> unit) -> ('o BatIO.output -> 'b -> unit) -> 'o BatIO.output -> ('a * 'b) -> unit val printn : ?first:string -> ?sep:string -> ?last:string -> ('o BatIO.output -> 'a -> unit) -> 'o BatIO.output -> ('a * 'a) -> unit val compare : ?cmp1:('a -> 'a -> int) -> ?cmp2:('b -> 'b -> int) -> ('a * 'b) -> ('a * 'b) -> int include BatEnum.Enumerable with type 'a enumerable = 'a * 'a open BatOrd val eq : 'a eq -> 'b eq -> ('a * 'b) eq val ord : 'a ord -> 'b ord -> ('a * 'b) ord val comp : 'a comp -> 'b comp -> ('a * 'b) comp module Eq (T1 : Eq) (T2 : Eq) : Eq with type t = T1.t * T2.t module Ord (T1 : Ord) (T2 : Ord) : Ord with type t = T1.t * T2.t module Comp (T1 : Comp) (T2 : Comp) : Comp with type t = T1.t * T2.t end (** Triples. @author Ashish Agarwal *) module Tuple3 : sig type ('a,'b,'c) t = 'a * 'b * 'c val make : 'a -> 'b -> 'c -> 'a * 'b * 'c val first : 'a * 'b * 'c -> 'a val second : 'a * 'b * 'c -> 'b val third : 'a * 'b * 'c -> 'c val get12 : 'a * 'b * 'c -> 'a * 'b val get13 : 'a * 'b * 'c -> 'a * 'c val get23 : 'a * 'b * 'c -> 'b * 'c val map : ('a -> 'd) -> ('b -> 'e) -> ('c -> 'f) -> 'a * 'b * 'c -> 'd * 'e * 'f val mapn : ('a -> 'b) -> ('a * 'a * 'a) -> ('b * 'b * 'b) (** Like {!map} but specialized for tuples with elements of the same type. [mapn f] is equivalent to [map f f f]. *) val map1 : ('a -> 'd) -> ('a * 'b * 'c) -> ('d * 'b * 'c) val map2 : ('b -> 'd) -> ('a * 'b * 'c) -> ('a * 'd * 'c) val map3 : ('c -> 'd) -> ('a * 'b * 'c) -> ('a * 'b * 'd) val curry : ('a * 'b * 'c -> 'd) -> 'a -> 'b -> 'c -> 'd val uncurry : ('a -> 'b -> 'c -> 'd) -> 'a * 'b * 'c -> 'd val enum : ('a * 'a * 'a) -> 'a BatEnum.t val of_enum : 'a BatEnum.t -> ('a * 'a * 'a) (** @raise Failure if enum does not contain at least 3 elements. *) val print : ?first:string -> ?sep:string -> ?last:string -> ('o BatIO.output -> 'a -> unit) -> ('o BatIO.output -> 'b -> unit) -> ('o BatIO.output -> 'c -> unit) -> 'o BatIO.output -> ('a * 'b * 'c) -> unit val printn : ?first:string -> ?sep:string -> ?last:string -> ('o BatIO.output -> 'a -> unit) -> 'o BatIO.output -> ('a * 'a * 'a) -> unit val compare : ?cmp1:('a -> 'a -> int) -> ?cmp2:('b -> 'b -> int) -> ?cmp3:('c -> 'c -> int) -> ('a * 'b * 'c) -> ('a * 'b * 'c) -> int include BatEnum.Enumerable with type 'a enumerable = 'a * 'a * 'a open BatOrd val eq : 'a eq -> 'b eq -> 'c eq -> ('a * 'b * 'c) eq val ord : 'a ord -> 'b ord -> 'c ord -> ('a * 'b * 'c) ord val comp : 'a comp -> 'b comp -> 'c comp -> ('a * 'b * 'c) comp module Eq (T1 : Eq) (T2 : Eq) (T3 : Eq) : Eq with type t = T1.t * T2.t * T3.t module Ord (T1 : Ord) (T2 : Ord) (T3 : Ord) : Ord with type t = T1.t * T2.t * T3.t module Comp (T1 : Comp) (T2 : Comp) (T3 : Comp) : Comp with type t = T1.t * T2.t * T3.t end (** 4-Tuples. @author Ashish Agarwal *) module Tuple4 : sig type ('a,'b,'c,'d) t = 'a * 'b * 'c * 'd val make : 'a -> 'b -> 'c -> 'd -> 'a * 'b * 'c * 'd val first : 'a * 'b * 'c * 'd -> 'a val second : 'a * 'b * 'c * 'd -> 'b val third : 'a * 'b * 'c * 'd -> 'c val fourth : 'a * 'b * 'c * 'd -> 'd val get12 : 'a * 'b * 'c * 'd -> 'a * 'b val get13 : 'a * 'b * 'c * 'd -> 'a * 'c val get14 : 'a * 'b * 'c * 'd -> 'a * 'd val get23 : 'a * 'b * 'c * 'd -> 'b * 'c val get24 : 'a * 'b * 'c * 'd -> 'b * 'd val get34 : 'a * 'b * 'c * 'd -> 'c * 'd val get123 : 'a * 'b * 'c * 'd -> 'a * 'b * 'c val get124 : 'a * 'b * 'c * 'd -> 'a * 'b * 'd val get234 : 'a * 'b * 'c * 'd -> 'b * 'c * 'd val map : ('a -> 'e) -> ('b -> 'f) -> ('c -> 'g) -> ('d -> 'h) -> 'a * 'b * 'c * 'd -> 'e * 'f * 'g * 'h val mapn : ('a -> 'b) -> ('a * 'a * 'a * 'a) -> ('b * 'b * 'b * 'b) (** Like {!map} but specialized for tuples with elements of the same type. [mapn f] is equivalent to [map f f f f]. *) val map1 : ('a -> 'e) -> ('a * 'b * 'c * 'd) -> ('e * 'b * 'c * 'd) val map2 : ('b -> 'e) -> ('a * 'b * 'c * 'd) -> ('a * 'e * 'c * 'd) val map3 : ('c -> 'e) -> ('a * 'b * 'c * 'd) -> ('a * 'b * 'e * 'd) val map4 : ('d -> 'e) -> ('a * 'b * 'c * 'd) -> ('a * 'b * 'c * 'e) val curry : ('a * 'b * 'c * 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e val uncurry : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a * 'b * 'c * 'd -> 'e val enum : ('a * 'a * 'a * 'a) -> 'a BatEnum.t val of_enum : 'a BatEnum.t -> ('a * 'a * 'a * 'a) (** @raise Failure if enum does not contain at least 4 elements. *) val print : ?first:string -> ?sep:string -> ?last:string -> ('o BatIO.output -> 'a -> unit) -> ('o BatIO.output -> 'b -> unit) -> ('o BatIO.output -> 'c -> unit) -> ('o BatIO.output -> 'd -> unit) -> 'o BatIO.output -> ('a * 'b * 'c * 'd) -> unit val printn : ?first:string -> ?sep:string -> ?last:string -> ('o BatIO.output -> 'a -> unit) -> 'o BatIO.output -> ('a * 'a * 'a * 'a) -> unit val compare : ?cmp1:('a -> 'a -> int) -> ?cmp2:('b -> 'b -> int) -> ?cmp3:('c -> 'c -> int) -> ?cmp4:('d -> 'd -> int) -> ('a * 'b * 'c * 'd) -> ('a * 'b * 'c * 'd) -> int include BatEnum.Enumerable with type 'a enumerable = 'a * 'a * 'a * 'a open BatOrd val eq : 'a eq -> 'b eq -> 'c eq -> 'd eq -> ('a * 'b * 'c * 'd) eq val ord : 'a ord -> 'b ord -> 'c ord -> 'd ord -> ('a * 'b * 'c * 'd) ord val comp : 'a comp -> 'b comp -> 'c comp -> 'd comp -> ('a * 'b * 'c * 'd) comp module Eq (T1 : Eq) (T2 : Eq) (T3 : Eq) (T4 : Eq) : Eq with type t = T1.t * T2.t * T3.t * T4.t module Ord (T1 : Ord) (T2 : Ord) (T3 : Ord) (T4 : Ord) : Ord with type t = T1.t * T2.t * T3.t * T4.t module Comp (T1 : Comp) (T2 : Comp) (T3 : Comp) (T4 : Comp) : Comp with type t = T1.t * T2.t * T3.t * T4.t end (** 5-Tuples. @author Ashish Agarwal *) module Tuple5 : sig type ('a,'b,'c,'d,'e) t = 'a * 'b * 'c * 'd * 'e val make : 'a -> 'b -> 'c -> 'd -> 'e -> 'a * 'b * 'c * 'd * 'e val first : 'a * 'b * 'c * 'd * 'e -> 'a val second : 'a * 'b * 'c * 'd * 'e -> 'b val third : 'a * 'b * 'c * 'd * 'e -> 'c val fourth : 'a * 'b * 'c * 'd * 'e -> 'd val fifth : 'a * 'b * 'c * 'd * 'e -> 'e val get12 : 'a * 'b * 'c * 'd * 'e -> 'a * 'b val get13 : 'a * 'b * 'c * 'd * 'e -> 'a * 'c val get14 : 'a * 'b * 'c * 'd * 'e -> 'a * 'd val get15 : 'a * 'b * 'c * 'd * 'e -> 'a * 'e val get23 : 'a * 'b * 'c * 'd * 'e -> 'b * 'c val get24 : 'a * 'b * 'c * 'd * 'e -> 'b * 'd val get25 : 'a * 'b * 'c * 'd * 'e -> 'b * 'e val get34 : 'a * 'b * 'c * 'd * 'e -> 'c * 'd val get35 : 'a * 'b * 'c * 'd * 'e -> 'c * 'e val get45 : 'a * 'b * 'c * 'd * 'e -> 'd * 'e val get123 : 'a * 'b * 'c * 'd * 'e -> 'a * 'b * 'c val get124 : 'a * 'b * 'c * 'd * 'e -> 'a * 'b * 'd val get125 : 'a * 'b * 'c * 'd * 'e -> 'a * 'b * 'e val get134 : 'a * 'b * 'c * 'd * 'e -> 'a * 'c * 'd val get135 : 'a * 'b * 'c * 'd * 'e -> 'a * 'c * 'e val get145 : 'a * 'b * 'c * 'd * 'e -> 'a * 'd * 'e val get234 : 'a * 'b * 'c * 'd * 'e -> 'b * 'c * 'd val get235 : 'a * 'b * 'c * 'd * 'e -> 'b * 'c * 'e val get245 : 'a * 'b * 'c * 'd * 'e -> 'b * 'd * 'e val get345 : 'a * 'b * 'c * 'd * 'e -> 'c * 'd * 'e val get1234 : 'a * 'b * 'c * 'd * 'e -> 'a * 'b * 'c * 'd val get1235 : 'a * 'b * 'c * 'd * 'e -> 'a * 'b * 'c * 'e val get1245 : 'a * 'b * 'c * 'd * 'e -> 'a * 'b * 'd * 'e val get1345 : 'a * 'b * 'c * 'd * 'e -> 'a * 'c * 'd * 'e val get2345 : 'a * 'b * 'c * 'd * 'e -> 'b * 'c * 'd * 'e val map : ('a -> 'f) -> ('b -> 'g) -> ('c -> 'h) -> ('d -> 'i) -> ('e -> 'j) -> 'a * 'b * 'c * 'd * 'e -> 'f * 'g * 'h * 'i * 'j val mapn : ('a -> 'b) -> ('a * 'a * 'a * 'a * 'a) -> ('b * 'b * 'b * 'b * 'b) (** Like {!map} but specialized for tuples with elements of the same type. [mapn f] is equivalent to [map f f f f f]. *) val map1 : ('a -> 'f) -> ('a * 'b * 'c * 'd * 'e) -> ('f * 'b * 'c * 'd * 'e) val map2 : ('b -> 'f) -> ('a * 'b * 'c * 'd * 'e) -> ('a * 'f * 'c * 'd * 'e) val map3 : ('c -> 'f) -> ('a * 'b * 'c * 'd * 'e) -> ('a * 'b * 'f * 'd * 'e) val map4 : ('d -> 'f) -> ('a * 'b * 'c * 'd * 'e) -> ('a * 'b * 'c * 'f * 'e) val map5 : ('e -> 'f) -> ('a * 'b * 'c * 'd * 'e) -> ('a * 'b * 'c * 'd * 'f) val curry : ('a * 'b * 'c * 'd * 'e -> 'f) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f val uncurry : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a * 'b * 'c * 'd * 'e -> 'f val enum : ('a * 'a * 'a * 'a * 'a) -> 'a BatEnum.t val of_enum : 'a BatEnum.t -> ('a * 'a * 'a * 'a * 'a) (** @raise Failure if enum does not contain at least 5 elements. *) val print : ?first:string -> ?sep:string -> ?last:string -> ('o BatIO.output -> 'a -> unit) -> ('o BatIO.output -> 'b -> unit) -> ('o BatIO.output -> 'c -> unit) -> ('o BatIO.output -> 'd -> unit) -> ('o BatIO.output -> 'e -> unit) -> 'o BatIO.output -> ('a * 'b * 'c * 'd * 'e) -> unit val printn : ?first:string -> ?sep:string -> ?last:string -> ('o BatIO.output -> 'a -> unit) -> 'o BatIO.output -> ('a * 'a * 'a * 'a * 'a) -> unit val compare : ?cmp1:('a -> 'a -> int) -> ?cmp2:('b -> 'b -> int) -> ?cmp3:('c -> 'c -> int) -> ?cmp4:('d -> 'd -> int) -> ?cmp5:('e -> 'e -> int) -> ('a * 'b * 'c * 'd * 'e) -> ('a * 'b * 'c * 'd * 'e) -> int include BatEnum.Enumerable with type 'a enumerable = 'a * 'a * 'a * 'a * 'a open BatOrd val eq : 'a eq -> 'b eq -> 'c eq -> 'd eq -> 'e eq -> ('a * 'b * 'c * 'd * 'e) eq val ord : 'a ord -> 'b ord -> 'c ord -> 'd ord -> 'e ord -> ('a * 'b * 'c * 'd * 'e) ord val comp : 'a comp -> 'b comp -> 'c comp -> 'd comp -> 'e comp -> ('a * 'b * 'c * 'd * 'e) comp module Eq (T1 : Eq) (T2 : Eq) (T3 : Eq) (T4 : Eq) (T5 : Eq) : Eq with type t = T1.t * T2.t * T3.t * T4.t * T5.t module Ord (T1 : Ord) (T2 : Ord) (T3 : Ord) (T4 : Ord) (T5 : Ord) : Ord with type t = T1.t * T2.t * T3.t * T4.t * T5.t module Comp (T1 : Comp) (T2 : Comp) (T3 : Comp) (T4 : Comp) (T5 : Comp) : Comp with type t = T1.t * T2.t * T3.t * T4.t * T5.t end batteries-included-3.4.0/src/batUChar.ml000066400000000000000000000046001415601150500200750ustar00rootroot00000000000000(** Unicode (ISO-UCS) characters. This module implements Unicode characters. *) (* Copyright (C) 2002, 2003, 2004 Yamagata Yoriyuki. *) (* This library is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Lesser General Public License *) (* as published by the Free Software Foundation; either version 2 of *) (* the License, or (at your option) any later version. *) (* As a special exception to the GNU Library General Public License, you *) (* may link, statically or dynamically, a "work that uses this library" *) (* with a publicly distributed version of this library to produce an *) (* executable file containing portions of this library, and distribute *) (* that executable file under terms of your choice, without any of the *) (* additional requirements listed in clause 6 of the GNU Library General *) (* Public License. By "a publicly distributed version of this library", *) (* we mean either the unmodified Library as distributed by the authors, *) (* or a modified version of this library that is distributed under the *) (* conditions defined in clause 3 of the GNU Library General Public *) (* License. This exception does not however invalidate any other reasons *) (* why the executable file might be covered by the GNU Library General *) (* Public License . *) (* This library is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *) (* Lesser General Public License for more details. *) (* You should have received a copy of the GNU Lesser General Public *) (* License along with this library; if not, write to the Free Software *) (* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 *) (* USA *) (* You can contact the authour by sending email to *) (* yoriyuki.y@gmail.com *) type t = int exception Out_of_range external code : t -> int = "%identity" let char_of c = if c >= 0 && c < 0x100 then Char.chr c else raise Out_of_range let of_char = Char.code (* valid range: U+0000..U+D7FF and U+E000..U+10FFFF *) let chr n = if (n >= 0 && n <= 0xd7ff) || (n >= 0xe000 && n <= 0x10ffff) then n else raise Out_of_range let unsafe_chr n = n let eq (u1 : t) (u2 : t) = u1 = u2 let compare u1 u2 = u1 - u2 type uchar = t let int_of u = code u let of_int n = chr n let is_ascii u = u < 128 batteries-included-3.4.0/src/batUChar.mli000066400000000000000000000060731415601150500202540ustar00rootroot00000000000000(** Unicode characters. This module implements Unicode characters. *) (* Copyright (C) 2002, 2003, 2004, 2011 Yamagata Yoriyuki. *) (* This library is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Lesser General Public License *) (* as published by the Free Software Foundation; either version 2 of *) (* the License, or (at your option) any later version. *) (* As a special exception to the GNU Library General Public License, you *) (* may link, statically or dynamically, a "work that uses this library" *) (* with a publicly distributed version of this library to produce an *) (* executable file containing portions of this library, and distribute *) (* that executable file under terms of your choice, without any of the *) (* additional requirements listed in clause 6 of the GNU Library General *) (* Public License. By "a publicly distributed version of this library", *) (* we mean either the unmodified Library as distributed by the authors, *) (* or a modified version of this library that is distributed under the *) (* conditions defined in clause 3 of the GNU Library General Public *) (* License. This exception does not however invalidate any other reasons *) (* why the executable file might be covered by the GNU Library General *) (* Public License . *) (* This library is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *) (* Lesser General Public License for more details. *) (* You should have received a copy of the GNU Lesser General Public *) (* License along with this library; if not, write to the Free Software *) (* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 *) (* USA *) (* You can contact the authour by sending email to *) (* yori@users.sourceforge.net *) type t exception Out_of_range (** [char_of u] returns the Latin-1 representation of [u]. If [u] can not be represented by Latin-1, raises Out_of_range *) val char_of : t -> char (** [of_char c] returns the Unicode character of the Latin-1 character [c] *) val of_char : char -> t (** [code u] returns the Unicode code number of [u]. *) external code : t -> int = "%identity" (** [chr n] returns the Unicode character with the code number [n]. If n does not lay in the valid range of Unicode or designates a surrogate character, raises Out_of_range *) val chr : int -> t (** Equality by code point comparison *) val eq : t -> t -> bool (** [compare u1 u2] returns, a value > 0 if [u1] has a larger Unicode code number than [u2], 0 if [u1] and [u2] are the same Unicode character, a value < 0 if [u1] has a smaller Unicode code number than [u2]. *) val compare : t -> t -> int (** Aliases of [type t] *) type uchar = t (** Alias of [code] *) val int_of : uchar -> int (** Alias of [chr] *) val of_int : int -> uchar (** [true] if the char is a regular ascii char, i.e. if its code is <= 127 @since 2.2.0 *) val is_ascii : uchar -> bool (**/**) val unsafe_chr : int -> t (**/**) batteries-included-3.4.0/src/batUTF8.ml000066400000000000000000000235251415601150500176300ustar00rootroot00000000000000(** UTF-8 encoded Unicode strings. The type is normal string. *) (* Copyright (C) 2002, 2003 Yamagata Yoriyuki. *) (* This library is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Lesser General Public License *) (* as published by the Free Software Foundation; either version 2 of *) (* the License, or (at your option) any later version. *) (* As a special exception to the GNU Library General Public License, you *) (* may link, statically or dynamically, a "work that uses this library" *) (* with a publicly distributed version of this library to produce an *) (* executable file containing portions of this library, and distribute *) (* that executable file under terms of your choice, without any of the *) (* additional requirements listed in clause 6 of the GNU Library General *) (* Public License. By "a publicly distributed version of this library", *) (* we mean either the unmodified Library as distributed by the authors, *) (* or a modified version of this library that is distributed under the *) (* conditions defined in clause 3 of the GNU Library General Public *) (* License. This exception does not however invalidate any other reasons *) (* why the executable file might be covered by the GNU Library General *) (* Public License . *) (* This library is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *) (* Lesser General Public License for more details. *) (* You should have received a copy of the GNU Lesser General Public *) (* License along with this library; if not, write to the Free Software *) (* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 *) (* USA *) (* You can contact the authour by sending email to *) (* yoriyuki.y@gmail.com *) type t = string let empty = "" type index = int let length0 n = if n < 0x80 then 1 else if n < 0xe0 then 2 else if n < 0xf0 then 3 else 4 let look s i = let n' = let n = Char.code (String.unsafe_get s i) in if n < 0x80 then n else if n <= 0xdf then (n - 0xc0) lsl 6 lor (0x7f land (Char.code (String.unsafe_get s (i + 1)))) else if n <= 0xef then let n' = n - 0xe0 in let m = Char.code (String.unsafe_get s (i + 1)) in let n' = n' lsl 6 lor (0x7f land m) in let m = Char.code (String.unsafe_get s (i + 2)) in n' lsl 6 lor (0x7f land m) else let n' = n - 0xf0 in let m = Char.code (String.unsafe_get s (i + 1)) in let n' = n' lsl 6 lor (0x7f land m) in let m = Char.code (String.unsafe_get s (i + 2)) in let n' = n' lsl 6 lor (0x7f land m) in let m = Char.code (String.unsafe_get s (i + 3)) in n' lsl 6 lor (0x7f land m) in BatUChar.unsafe_chr n' let next s i = let n = Char.code s.[i] in if n < 0x80 then i + 1 else if n <= 0xdf then i + 2 else if n <= 0xef then i + 3 else i + 4 let rec search_head_backward s i = if i < 0 then -1 else let n = Char.code s.[i] in if n < 0x80 || n >= 0xc2 then i else search_head_backward s (i - 1) let prev s i = search_head_backward s (i - 1) let move s i n = if n >= 0 then let rec loop i n = if n <= 0 then i else loop (next s i) (n - 1) in loop i n else let rec loop i n = if n >= 0 then i else loop (prev s i) (n + 1) in loop i n let rec nth_aux s i n = if n = 0 then i else nth_aux s (next s i) (n - 1) let nth s n = nth_aux s 0 n let first _ = 0 let last s = search_head_backward s (String.length s - 1) let out_of_range s i = i < 0 || i >= String.length s let compare_index _ i j = i - j let get s n = look s (nth s n) let add_uchar buf u = let masq = 0b111111 in let k = BatUChar.code u in if k <= 0x7f then Buffer.add_char buf (Char.unsafe_chr k) else if k <= 0x7ff then begin Buffer.add_char buf (Char.unsafe_chr (0xc0 lor (k lsr 6))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq))) end else if k <= 0xffff then begin Buffer.add_char buf (Char.unsafe_chr (0xe0 lor (k lsr 12))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq))); end else begin Buffer.add_char buf (Char.unsafe_chr (0xf0 + (k lsr 18))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 12) land masq))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq))); end let init len f = let buf = Buffer.create len in for c = 0 to len - 1 do add_uchar buf (f c) done; Buffer.contents buf let make len u = init len (fun _ -> u) let of_char u = make 1 u let of_string_unsafe s = s let to_string_unsafe s = s let rec length_aux s c i = if i >= String.length s then c else let n = Char.code (String.unsafe_get s i) in let k = if n < 0x80 then 1 else if n < 0xe0 then 2 else if n < 0xf0 then 3 else 4 in length_aux s (c + 1) (i + k) let length s = length_aux s 0 0 let rec iter_aux proc s i = if i >= String.length s then () else let u = look s i in proc u; iter_aux proc s (next s i) let iter proc s = iter_aux proc s 0 let rec iteri_aux f s i count = if i >= String.length s then () else let u = look s i in f u count; iteri_aux f s (next s i) (count + 1) let iteri f s = iteri_aux f s 0 0 let compare s1 s2 = String.compare s1 s2 let sub s n len = let ipos = move s (first s) n in let jpos = move s ipos len in String.sub s ipos (jpos-ipos) exception Malformed_code let validate s = let rec trail c i a = if c = 0 then a else if i >= String.length s then raise Malformed_code else let n = Char.code (String.unsafe_get s i) in if n < 0x80 || n >= 0xc0 then raise Malformed_code else trail (c - 1) (i + 1) (a lsl 6 lor (0x7f land n)) in let rec main i = if i >= String.length s then () else let n = Char.code (String.unsafe_get s i) in if n < 0x80 then main (i + 1) else if n < 0xc2 then raise Malformed_code else if n <= 0xdf then if trail 1 (i + 1) (n - 0xc0) < 0x80 then raise Malformed_code else main (i + 2) else if n <= 0xef then let n' = trail 2 (i + 1) (n - 0xe0) in if n' < 0x800 then raise Malformed_code else if n' >= 0xd800 && n' <= 0xdfff then raise Malformed_code else main (i + 3) else if n <= 0xf4 then let n = trail 3 (i + 1) (n - 0xf0) in if n < 0x10000 || n > 0x10FFFF then raise Malformed_code else main (i + 4) else raise Malformed_code in main 0 let of_ascii s = for i = 0 to String.length s - 1 do if Char.code s.[i] >= 0x80 then raise Malformed_code; done; String.copy s let of_latin1 s = init (String.length s) (fun i -> BatUChar.of_char s.[i]) module Buf = struct include Buffer type buf = t let add_char = add_uchar end let map f us = let b = Buf.create (length us) in iter (fun c -> Buf.add_char b (f c)) us; Buf.contents b let filter_map f us = let b = Buf.create (length us) in iter (fun c -> match f c with None -> () | Some c -> Buf.add_char b c) us; Buf.contents b let filter p us = let b = Buf.create (length us) in iter (fun c -> if p c then Buf.add_char b c) us; Buf.contents b let fold f a s = let rec loop a i = if out_of_range s i then a else let a' = f a (look s i) in loop a' (next s i) in loop a 0 let enum s = let sl = String.length s in let i = (ref (first s)) in BatEnum.from (fun () -> if !i = sl then raise BatEnum.No_more_elements else begin let c = look s !i in i := next s !i; c end ) (*$T enum "" |> of_latin1 |> enum |> BatList.of_enum = [] "foo" |> of_latin1 |> enum |> BatList.of_enum = List.map BatUChar.of_char ['f'; 'o'; 'o'] let e = of_latin1 "abcdef" |> enum in \ for _i = 0 to 2 do BatEnum.junk e done; \ let e2 = BatEnum.clone e in \ let to_string en = BatList.of_enum en |> List.map BatUChar.char_of |> BatString.implode in \ to_string e = "def" && to_string e2 = "def" init 3 (fun i -> BatUChar.of_int (1211+i)) |> enum |> BatList.of_enum = List.map BatUChar.of_int [1211;1212;1213] *) (* The last test checks that we can make a round-trip of non-ASCII strings like "һҼҽ" *) let escaped = String.escaped module ByteIndex : sig type t = string type b_idx(* = private int*) type char_idx = int val of_int_unsafe : int -> b_idx val to_int : b_idx -> int val next : t -> b_idx -> b_idx val prev : t -> b_idx -> b_idx val of_char_idx : t -> char_idx -> b_idx val at_end : t -> b_idx -> bool val out_of_range : t -> b_idx -> bool val first : b_idx val last : t -> b_idx val move : t -> b_idx -> int -> b_idx val look : t -> b_idx -> BatUChar.t end = struct type t = string type b_idx = int type char_idx = int external of_int_unsafe : int -> b_idx = "%identity" external to_int : b_idx -> int = "%identity" let look = look let next = next let prev = prev let first = 0 let last us = prev us (String.length us) let at_end us bi = bi = String.length us let out_of_range us bi = bi < 0 || bi >= String.length us let move us bi n = (* faster moving positive than negative n *) let bi = ref bi in let step = if n > 0 then next else prev in for _j = 1 to abs n do bi := step us !bi done; !bi let of_char_idx us ci = move us first ci end (* Could be improved. *) let rindex us ch = let rec aux ci bi = if ByteIndex.out_of_range us bi then raise Not_found; if ByteIndex.look us bi = ch then ci else aux (ci-1) (ByteIndex.prev us bi) in aux 0 (ByteIndex.last us) let rec contains_aux step bi us ch = if ByteIndex.out_of_range us bi then false else if ByteIndex.look us bi = ch then true else contains_aux step (step us bi) us ch let contains us ch = contains_aux ByteIndex.next ByteIndex.first us ch batteries-included-3.4.0/src/batUTF8.mli000066400000000000000000000165651415601150500200070ustar00rootroot00000000000000(** UTF-8 encoded Unicode strings. The type is normal string. *) (* Copyright (C) 2002, 2003, 2011 Yamagata Yoriyuki. *) (* This library is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Lesser General Public License *) (* as published by the Free Software Foundation; either version 2 of *) (* the License, or (at your option) any later version. *) (* As a special exception to the GNU Library General Public License, you *) (* may link, statically or dynamically, a "work that uses this library" *) (* with a publicly distributed version of this library to produce an *) (* executable file containing portions of this library, and distribute *) (* that executable file under terms of your choice, without any of the *) (* additional requirements listed in clause 6 of the GNU Library General *) (* Public License. By "a publicly distributed version of this library", *) (* we mean either the unmodified Library as distributed by the authors, *) (* or a modified version of this library that is distributed under the *) (* conditions defined in clause 3 of the GNU Library General Public *) (* License. This exception does not however invalidate any other reasons *) (* why the executable file might be covered by the GNU Library General *) (* Public License . *) (* This library is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *) (* Lesser General Public License for more details. *) (* You should have received a copy of the GNU Lesser General Public *) (* License along with this library; if not, write to the Free Software *) (* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 *) (* USA *) (* You can contact the authour by sending email to *) (* yori@users.sourceforge.net *) (** UTF-8 encoded Unicode strings. The type is normal string. *) type t = string exception Malformed_code (** [validate s] successes if s is valid UTF-8, otherwise raises Malformed_code. Other functions assume strings are valid UTF-8, so it is prudent to test their validity for strings from untrusted origins. *) val validate : t -> unit (* All functions below assume string are valid UTF-8. If not, * the result is unspecified. *) (** [get s n] returns [n]-th Unicode character of [s]. The call requires O(n)-time. *) val get : t -> int -> BatUChar.t (** [init len f] returns a new string which contains [len] Unicode characters. The i-th Unicode character is initialized by [f i] *) val init : int -> (int -> BatUChar.t) -> t (** [length s] returns the number of Unicode characters contained in s *) val length : t -> int (** Positions in the string represented by the number of bytes from the head. The location of the first character is [0] *) type index = int (** [nth s n] returns the position of the [n]-th Unicode character. The call requires O(n)-time *) val nth : t -> int -> index (** The position of the head of the first Unicode character. *) val first : t -> index (** The position of the head of the last Unicode character. *) val last : t -> index (** [look s i] returns the Unicode character of the location [i] in the string [s]. *) val look : t -> index -> BatUChar.t (** [out_of_range s i] tests whether [i] is a position inside of [s]. *) val out_of_range : t -> index -> bool (** [compare_index s i1 i2] returns a value < 0 if [i1] is the position located before [i2], 0 if [i1] and [i2] points the same location, a value > 0 if [i1] is the position located after [i2]. *) val compare_index : t -> index -> index -> int (** [next s i] returns the position of the head of the Unicode character located immediately after [i]. If [i] is inside of [s], the function always successes. If [i] is inside of [s] and there is no Unicode character after [i], the position outside [s] is returned. If [i] is not inside of [s], the behaviour is unspecified. *) val next : t -> index -> index (** [prev s i] returns the position of the head of the Unicode character located immediately before [i]. If [i] is inside of [s], the function always successes. If [i] is inside of [s] and there is no Unicode character before [i], the position outside [s] is returned. If [i] is not inside of [s], the behaviour is unspecified. *) val prev : t -> index -> index (** [move s i n] returns [n]-th Unicode character after [i] if n >= 0, [n]-th Unicode character before [i] if n < 0. If there is no such character, the result is unspecified. *) val move : t -> index -> int -> index (** [iter f s] applies [f] to all Unicode characters in [s]. The order of application is same to the order of the Unicode characters in [s]. *) val iter : (BatUChar.t -> unit) -> t -> unit (** Code point comparison by the lexicographic order. [compare s1 s2] returns a positive integer if [s1] > [s2], 0 if [s1] = [s2], a negative integer if [s1] < [s2]. *) val compare : t -> t -> int (** Buffer module for UTF-8 strings *) module Buf : sig (** Buffers for UTF-8 strings. *) type buf (** [create n] creates the buffer with the initial size [n]-bytes. *) val create : int -> buf (* The rest of functions is similar to the ones of Buffer in stdlib. *) (** [contents buf] returns the contents of the buffer. *) val contents : buf -> t (** Empty the buffer, but retains the internal storage which was holding the contents *) val clear : buf -> unit (** Empty the buffer and de-allocate the internal storage. *) val reset : buf -> unit (** Add one Unicode character to the buffer. *) val add_char : buf -> BatUChar.t -> unit (** Add the UTF-8 string to the buffer. *) val add_string : buf -> t -> unit (** [add_buffer b1 b2] adds the contents of [b2] to [b1]. The contents of [b2] is not changed. *) val add_buffer : buf -> buf -> unit end with type buf = Buffer.t (**/**) (* Functions "privately" exported for BatText's rope implementation *) (** [make len c] returns a new string which contains [len] copies of unicode character [c] *) val make : int -> BatUChar.t -> t val of_string_unsafe : string -> t val to_string_unsafe : t -> string (** [of_char c] returns a new string composed of just the given character *) val of_char : BatUChar.t -> t (** The empty unicode string *) val empty : t val sub : t -> int -> int -> t val iteri : (BatUChar.t -> int -> unit) -> t -> unit val fold : ('a -> BatUChar.t -> 'a) -> 'a -> t -> 'a val enum : t -> BatUChar.t BatEnum.t val map : (BatUChar.t -> BatUChar.t) -> t -> t val filter_map : (BatUChar.t -> BatUChar.t option) -> t -> t val filter : (BatUChar.t -> bool) -> t -> t val rindex : t -> BatUChar.t -> int val contains : t -> BatUChar.t -> bool val escaped : t -> t val of_latin1 : string -> t (* Returns the length of the Unicode character starting at the given byte index *) val length0 : int -> int module ByteIndex : sig type t = string type b_idx(* = private int*) type char_idx = int val of_int_unsafe : int -> b_idx val to_int : b_idx -> int val next : t -> b_idx -> b_idx val prev : t -> b_idx -> b_idx val of_char_idx : t -> char_idx -> b_idx val at_end : t -> b_idx -> bool val out_of_range : t -> b_idx -> bool val first : b_idx val last : t -> b_idx val move : t -> b_idx -> int -> b_idx val look : t -> b_idx -> BatUChar.t end (**/**) batteries-included-3.4.0/src/batUnit.ml000066400000000000000000000021451415601150500200140ustar00rootroot00000000000000(* * BatUnit - Operations on Unit * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc. *) let unit_string = "()" type t = unit let string_of () = unit_string let of_string = function | "()" -> () | _ -> invalid_arg "Unit.of_string" let compare () () = 0 let ord () () = BatOrd.Eq let equal () () = true let print out () = BatInnerIO.nwrite out unit_string batteries-included-3.4.0/src/batUnit.mli000066400000000000000000000027671415601150500201770ustar00rootroot00000000000000(* * BatUnit - Operations on Unit * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc. *) (** Operations on [unit]. @author David Teller *) type t = unit (**The unit type, i.e. a type with only one element, [()].*) val string_of : t -> string (**Convert the given unit to a string. Returns ["()"]. *) val of_string : string -> t (**Convert the given string to a unit. Accepts ["()"]. @raise Invalid_argument if the given string is not ["()"]. *) val compare : t -> t -> int (** Compare two units. Always returns 0.*) val ord : t -> t -> BatOrd.order (** Always returns [BatOrd.Eq] *) val equal : t -> t -> bool (** Always returns true. *) (** {6 Boilerplate code}*) (** {7 Printing}*) val print: 'a BatInnerIO.output -> unit -> unit batteries-included-3.4.0/src/batUnix.mliv000066400000000000000000002270571415601150500203720ustar00rootroot00000000000000(* * BatUnix - additional and modified functions for Unix and Unix-compatible systems. * Copyright (C) 1996 Xavier Leroy * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Low-level interface to the operating system (both Unix and Windows). This module only provides low-level functions and types. Unless you know that you need low-level access to the operating system, you probably don't. For higher-level functions, see modules {!BatIO}, {!BatFile}. {b Note} This module is thread-safe. @author Xavier Leroy (Base module) @author David Teller @documents Unix *) (** {6 Error report} *) type error = Unix.error = E2BIG (** Argument list too long *) | EACCES (** Permission denied *) | EAGAIN (** Resource temporarily unavailable; try again *) | EBADF (** Bad file descriptor *) | EBUSY (** Resource unavailable *) | ECHILD (** No child process *) | EDEADLK (** Resource deadlock would occur *) | EDOM (** Domain error for math functions, etc. *) | EEXIST (** File exists *) | EFAULT (** Bad address *) | EFBIG (** File too large *) | EINTR (** Function interrupted by signal *) | EINVAL (** Invalid argument *) | EIO (** Hardware I/O error *) | EISDIR (** Is a directory *) | EMFILE (** Too many open files by the process *) | EMLINK (** Too many links *) | ENAMETOOLONG (** Filename too long *) | ENFILE (** Too many open files in the system *) | ENODEV (** No such device *) | ENOENT (** No such file or directory *) | ENOEXEC (** Not an executable file *) | ENOLCK (** No locks available *) | ENOMEM (** Not enough memory *) | ENOSPC (** No space left on device *) | ENOSYS (** Function not supported *) | ENOTDIR (** Not a directory *) | ENOTEMPTY (** Directory not empty *) | ENOTTY (** Inappropriate I/O control operation *) | ENXIO (** No such device or address *) | EPERM (** Operation not permitted *) | EPIPE (** Broken pipe *) | ERANGE (** Result too large *) | EROFS (** Read-only file system *) | ESPIPE (** Invalid seek e.g. on a pipe *) | ESRCH (** No such process *) | EXDEV (** Invalid link *) | EWOULDBLOCK (** Operation would block *) | EINPROGRESS (** Operation now in progress *) | EALREADY (** Operation already in progress *) | ENOTSOCK (** Socket operation on non-socket *) | EDESTADDRREQ (** Destination address required *) | EMSGSIZE (** Message too long *) | EPROTOTYPE (** Protocol wrong type for socket *) | ENOPROTOOPT (** Protocol not available *) | EPROTONOSUPPORT (** Protocol not supported *) | ESOCKTNOSUPPORT (** Socket type not supported *) | EOPNOTSUPP (** Operation not supported on socket *) | EPFNOSUPPORT (** Protocol family not supported *) | EAFNOSUPPORT (** Address family not supported by protocol family *) | EADDRINUSE (** Address already in use *) | EADDRNOTAVAIL (** Can't assign requested address *) | ENETDOWN (** Network is down *) | ENETUNREACH (** Network is unreachable *) | ENETRESET (** Network dropped connection on reset *) | ECONNABORTED (** Software caused connection abort *) | ECONNRESET (** Connection reset by peer *) | ENOBUFS (** No buffer space available *) | EISCONN (** Socket is already connected *) | ENOTCONN (** Socket is not connected *) | ESHUTDOWN (** Can't send after socket shutdown *) | ETOOMANYREFS (** Too many references: can't splice *) | ETIMEDOUT (** Connection timed out *) | ECONNREFUSED (** Connection refused *) | EHOSTDOWN (** Host is down *) | EHOSTUNREACH (** No route to host *) | ELOOP (** Too many levels of symbolic links *) | EOVERFLOW (** File size or position not representable *) | EUNKNOWNERR of int (** Unknown error *) (** The type of error codes. Errors defined in the POSIX standard and additional errors from UNIX98 and BSD. All other errors are mapped to EUNKNOWNERR. *) exception Unix_error of error * string * string (** Raised by the system calls below when an error is encountered. The first component is the error code; the second component is the function name; the third component is the string parameter to the function, if it has one, or the empty string otherwise. *) val error_message : error -> string (** Return a string describing the given error code. *) val handle_unix_error : ('a -> 'b) -> 'a -> 'b (** [handle_unix_error f x] applies [f] to [x] and returns the result. If the exception [Unix_error] is raised, it prints a message describing the error and exits with code 2. *) (** {6 Access to the process environment} *) val environment : unit -> string array (** Return the process environment, as an array of strings with the format ``variable=value''. *) ##V>=4.6##val unsafe_environment : unit -> string array ##V>=4.6##(** Return the process environment, as an array of strings with the ##V>=4.6## format ``variable=value''. Unlike {!environment}, this function ##V>=4.6## returns a populated array even if the process has special ##V>=4.6## privileges. See the documentation for {!unsafe_getenv} for more ##V>=4.6## details. ##V>=4.6## ##V>=4.6## @since 2.8.0 and OCaml 4.06.0 *) val getenv : string -> string (** Return the value associated to a variable in the process environment. @raise Not_found if the variable is unbound. (This function is identical to {!Sys.getenv}.) *) ##V>=4.6##val unsafe_getenv : string -> string ##V>=4.6##(** Return the value associated to a variable in the process ##V>=4.6## environment. ##V>=4.6## ##V>=4.6## Unlike {!getenv}, this function returns the value even if the ##V>=4.6## process has special privileges. It is considered unsafe because the ##V>=4.6## programmer of a setuid or setgid program must be careful to avoid ##V>=4.6## using maliciously crafted environment variables in the search path ##V>=4.6## for executables, the locations for temporary files or logs, and the ##V>=4.6## like. ##V>=4.6## ##V>=4.6## @raise Not_found if the variable is unbound. ##V>=4.6## @since 2.8.0 and 4.06.0 *) val putenv : string -> string -> unit (** [Unix.putenv name value] sets the value associated to a variable in the process environment. [name] is the name of the environment variable, and [value] its new associated value. *) (** {6 Process handling} *) type process_status = Unix.process_status = WEXITED of int (** The process terminated normally by [exit]; the argument is the return code. *) | WSIGNALED of int (** The process was killed by a signal; the argument is the signal number. *) | WSTOPPED of int (** The process was stopped by a signal; the argument is the signal number. *) (** The termination status of a process. See module {!Sys} for the definitions of the standard signal numbers. Note that they are not the numbers used by the OS. *) type wait_flag = Unix.wait_flag = WNOHANG (** do not block if no child has died yet, but immediately return with a pid equal to 0.*) | WUNTRACED (** report also the children that receive stop signals. *) (** Flags for {!Unix.waitpid}. *) val execv : string -> string array -> 'a (** [execv prog args] execute the program in file [prog], with the arguments [args], and the current process environment. These [execv*] functions never return: on success, the current program is replaced by the new one; @raise Unix.Unix_error on failure. *) val execve : string -> string array -> string array -> 'a (** Same as {!Unix.execv}, except that the third argument provides the environment to the program executed. *) val execvp : string -> string array -> 'a (** Same as {!Unix.execv}, except that the program is searched in the path. *) val execvpe : string -> string array -> string array -> 'a (** Same as {!Unix.execve}, except that the program is searched in the path. *) val fork : unit -> int (** Fork a new process. The returned integer is 0 for the child process, the pid of the child process for the parent process. *) val wait : unit -> int * process_status (** Wait until one of the children processes die, and return its pid and termination status. *) val waitpid : wait_flag list -> int -> int * process_status (** Same as {!Unix.wait}, but waits for the child process whose pid is given. A pid of [-1] means wait for any child. A pid of [0] means wait for any child in the same process group as the current process. Negative pid arguments represent process groups. The list of options indicates whether [waitpid] should return immediately without waiting, or also report stopped children. *) val system : string -> process_status (** Execute the given command, wait until it terminates, and return its termination status. The string is interpreted by the shell [/bin/sh] and therefore can contain redirections, quotes, variables, etc. The result [WEXITED 127] indicates that the shell couldn't be executed. *) val run_and_read : string -> process_status * string (** [(stat, output) = run_and_read cmd] run the command [cmd] (via Unix.system) then return its exit status [stat] and output string [output] as read from its standard output (which was redirected to a temporary file). @since 2.4 *) ##V>=4.12##val _exit : int -> 'a ##V>=4.12##(** Terminate the calling process immediately, returning the given ##V>=4.12## status code to the operating system: usually 0 to indicate no ##V>=4.12## errors, and a small positive integer to indicate failure. ##V>=4.12## Unlike {!Stdlib.exit}, {!Unix._exit} performs no finalization ##V>=4.12## whatsoever: functions registered with {!Stdlib.at_exit} are not called, ##V>=4.12## input/output channels are not flushed, and the C run-time system ##V>=4.12## is not finalized either. ##V>=4.12## ##V>=4.12## The typical use of {!Unix._exit} is after a {!Unix.fork} operation, ##V>=4.12## when the child process runs into a fatal error and must exit. In ##V>=4.12## this case, it is preferable to not perform any finalization action ##V>=4.12## in the child process, as these actions could interfere with similar ##V>=4.12## actions performed by the parent process. For example, output ##V>=4.12## channels should not be flushed by the child process, as the parent ##V>=4.12## process may flush them again later, resulting in duplicate ##V>=4.12## output. ##V>=4.12## ##V>=4.12## @since 3.3.0 and 4.12.0 *) val getpid : unit -> int (** Return the pid of the process. *) val getppid : unit -> int (** Return the pid of the parent process. *) val nice : int -> int (** Change the process priority. The integer argument is added to the ``nice'' value. (Higher values of the ``nice'' value mean lower priorities.) Return the new nice value. *) (** {6 Basic file input/output} *) type file_descr = Unix.file_descr (** The abstract type of file descriptors. *) val stdin : file_descr (** File descriptor for standard input.*) val stdout : file_descr (** File descriptor for standard output.*) val stderr : file_descr (** File descriptor for standard error. *) type open_flag = Unix.open_flag = O_RDONLY (** Open for reading *) | O_WRONLY (** Open for writing *) | O_RDWR (** Open for reading and writing *) | O_NONBLOCK (** Open in non-blocking mode *) | O_APPEND (** Open for append *) | O_CREAT (** Create if nonexistent *) | O_TRUNC (** Truncate to 0 length if existing *) | O_EXCL (** Fail if existing *) | O_NOCTTY (** Don't make this dev a controlling tty *) | O_DSYNC (** Writes complete as `Synchronised I/O data integrity completion' *) | O_SYNC (** Writes complete as `Synchronised I/O file integrity completion' *) | O_RSYNC (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *) ##V>=4## | O_SHARE_DELETE (** OCaml 4 and Windows only: allow the file to be deleted ##V>=4## while still open *) ##V>=4.1## | O_CLOEXEC (** Set the close-on-exec flag on the ##V>=4.1## descriptor returned by {!openfile} ##V>=4.1## ##V>=4.1## Since OCaml 4.1 *) ##V>=4.5## | O_KEEPEXEC (** The flags to {!Unix.openfile}. *) type file_perm = int (** The type of file access rights, e.g. [0o640] is read and write for user, read for group, none for others *) val openfile : string -> open_flag list -> file_perm -> file_descr (** Open the named file with the given flags. Third argument is the permissions to give to the file if it is created. Return a file descriptor on the named file. *) val close : file_descr -> unit (** Close a file descriptor. *) ##V>=4.08##val fsync : file_descr -> unit ##V>=4.08##(** Flush file buffers to disk. *) val read : file_descr -> Bytes.t -> int -> int -> int (** [read fd buff ofs len] reads [len] characters from descriptor [fd], storing them in string [buff], starting at position [ofs] in string [buff]. Return the number of characters actually read. *) val write : file_descr -> Bytes.t -> int -> int -> int (** [write fd buff ofs len] writes [len] characters to descriptor [fd], taking them from string [buff], starting at position [ofs] in string [buff]. Return the number of characters actually written. [write] repeats the writing operation until all characters have been written or an error occurs. *) val single_write : file_descr -> Bytes.t -> int -> int -> int (** Same as [write], but attempts to write only once. Thus, if an error occurs, [single_write] guarantees that no data has been written. *) val write_substring : file_descr -> string -> int -> int -> int (** Same as [write], but take the data from a string instead of a byte sequence. @since 2.3.0 *) val single_write_substring : file_descr -> string -> int -> int -> int (** Same as [single_write], but take the data from a string instead of a byte sequence. @since 2.3.0 *) (** {6 Interfacing with the standard input/output library} *) val in_channel_of_descr : file_descr -> in_channel (** Create an input channel reading from the given descriptor. The channel is initially in binary mode; use [set_binary_mode_in ic false] if text mode is desired. *) val out_channel_of_descr : file_descr -> out_channel (** Create an output channel writing on the given descriptor. The channel is initially in binary mode; use [set_binary_mode_out oc false] if text mode is desired. *) val descr_of_in_channel : in_channel -> file_descr (** Return the descriptor corresponding to an input channel. *) val descr_of_out_channel : out_channel -> file_descr (** Return the descriptor corresponding to an output channel. *) (** {6 Interfacing with the standard input/output library} *) val input_of_descr: ?autoclose:bool -> ?cleanup:bool -> file_descr -> BatInnerIO.input (** Create an {!type:input} reading from the given descriptor. The {!type: input} is initially in binary mode; use [set_binary_mode_in ic false] if text mode is desired. @param autoclose If true (default value), close the input automatically once there is no more content to read. Otherwise, the input will be closed according to the usual rules of module {!BatIO}. Barring very specific needs (e.g. using file descriptors as locks), you probably want [autoclose] to be [true]. @param cleanup If true, close the underlying file descriptor when the {!type:input} is closed. If false or unspecified, do nothing, in which case you will need to close the underlying file descriptor yourself to ensure proper cleanup. *) val output_of_descr: ?cleanup:bool -> file_descr -> unit BatInnerIO.output (** Create an {!type:output} writing on the given descriptor. The {!type:output} is initially in binary mode; use [set_binary_mode_out oc false] if text mode is desired. @param cleanup If true, close the underlying file descriptor when the {!type:output} is closed. If false or unspecified, do nothing, in which case you will need to close the underlying file descriptor yourself to ensure proper cleanup. *) val descr_of_input : BatInnerIO.input -> file_descr (** Return the descriptor corresponding to an input. Not all inputs have file descriptors. This function works only for inputs which have been created using module {!Unix}. @raise Invalid_argument if this input channel doesn't have a file descriptor *) val descr_of_output : unit BatInnerIO.output -> file_descr (** Return the descriptor corresponding to an output. Not all inputs have file descriptors. This function works only for inputs which have been created from module Unix. @raise Invalid_argument if this input channel doesn't have a file descriptor *) (*val pipeio: unit -> file_descr * file_descr (** As {!pipe} but return an input and an output for the *)*) (** {6 Seeking and truncating} *) type seek_command = Unix.seek_command = SEEK_SET (** indicates positions relative to the beginning of the file *) | SEEK_CUR (** indicates positions relative to the current position *) | SEEK_END (** indicates positions relative to the end of the file *) (** Positioning modes for {!Unix.lseek}. *) val lseek : file_descr -> int -> seek_command -> int (** Set the current position for a file descriptor *) val truncate : string -> int -> unit (** Truncates the named file to the given size. *) val ftruncate : file_descr -> int -> unit (** Truncates the file corresponding to the given descriptor to the given size. *) (** {6 File status} *) type file_kind = Unix.file_kind = S_REG (** Regular file *) | S_DIR (** Directory *) | S_CHR (** Character device *) | S_BLK (** Block device *) | S_LNK (** Symbolic link *) | S_FIFO (** Named pipe *) | S_SOCK (** Socket *) type stats = Unix.stats = { st_dev : int; (** Device number *) st_ino : int; (** Inode number *) st_kind : file_kind; (** Kind of the file *) st_perm : file_perm; (** Access rights *) st_nlink : int; (** Number of links *) st_uid : int; (** User id of the owner *) st_gid : int; (** Group ID of the file's group *) st_rdev : int; (** Device minor number *) st_size : int; (** Size in bytes *) st_atime : float; (** Last access time *) st_mtime : float; (** Last modification time *) st_ctime : float; (** Last status change time *) } (** The information returned by the {!Unix.stat} calls. *) val stat : string -> stats (** Return the information for the named file. *) val lstat : string -> stats (** Same as {!Unix.stat}, but in case the file is a symbolic link, return the information for the link itself. *) val fstat : file_descr -> stats (** Return the information for the file associated with the given descriptor. *) val isatty : file_descr -> bool (** Return [true] if the given file descriptor refers to a terminal or console window, [false] otherwise. *) (** {6 File operations on large files} *) module LargeFile : sig val lseek : file_descr -> int64 -> seek_command -> int64 val truncate : string -> int64 -> unit val ftruncate : file_descr -> int64 -> unit type stats = Unix.LargeFile.stats = { st_dev : int; (** Device number *) st_ino : int; (** Inode number *) st_kind : file_kind; (** Kind of the file *) st_perm : file_perm; (** Access rights *) st_nlink : int; (** Number of links *) st_uid : int; (** User id of the owner *) st_gid : int; (** Group ID of the file's group *) st_rdev : int; (** Device minor number *) st_size : int64; (** Size in bytes *) st_atime : float; (** Last access time *) st_mtime : float; (** Last modification time *) st_ctime : float; (** Last status change time *) } val stat : string -> stats val lstat : string -> stats val fstat : file_descr -> stats end (** File operations on large files. This sub-module provides 64-bit variants of the functions {!Unix.lseek} (for positioning a file descriptor), {!Unix.truncate} and {!Unix.ftruncate} (for changing the size of a file), and {!Unix.stat}, {!Unix.lstat} and {!Unix.fstat} (for obtaining information on files). These alternate functions represent positions and sizes by 64-bit integers (type [int64]) instead of regular integers (type [int]), thus allowing operating on files whose sizes are greater than [max_int]. *) ##V>=4.6##(** {6 Mapping files into memory} *) ##V>=4.6## ##V=4.6##val map_file : ##V=4.6## file_descr -> ?pos:int64 -> ('a, 'b) CamlinternalBigarray.kind -> ##V=4.6## 'c CamlinternalBigarray.layout -> bool -> int array -> ##V=4.6## ('a, 'b, 'c) CamlinternalBigarray.genarray ##V>4.6##val map_file : ##V>4.6## file_descr -> ?pos:int64 -> ('a, 'b) Bigarray.kind -> ##V>4.6## 'c Bigarray.layout -> bool -> int array -> ##V>4.6## ('a, 'b, 'c) Bigarray.Genarray.t ##V>=4.6##(** Memory mapping of a file as a big array. ##V>=4.6## [map_file fd kind layout shared dims] ##V>=4.6## returns a big array of kind [kind], layout [layout], ##V>=4.6## and dimensions as specified in [dims]. The data contained in ##V>=4.6## this big array are the contents of the file referred to by ##V>=4.6## the file descriptor [fd] (as opened previously with ##V>=4.6## [Unix.openfile], for example). The optional [pos] parameter ##V>=4.6## is the byte offset in the file of the data being mapped; ##V>=4.6## it defaults to 0 (map from the beginning of the file). ##V>=4.6## ##V>=4.6## If [shared] is [true], all modifications performed on the array ##V>=4.6## are reflected in the file. This requires that [fd] be opened ##V>=4.6## with write permissions. If [shared] is [false], modifications ##V>=4.6## performed on the array are done in memory only, using ##V>=4.6## copy-on-write of the modified pages; the underlying file is not ##V>=4.6## affected. ##V>=4.6## ##V>=4.6## [Genarray.map_file] is much more efficient than reading ##V>=4.6## the whole file in a big array, modifying that big array, ##V>=4.6## and writing it afterwards. ##V>=4.6## ##V>=4.6## To adjust automatically the dimensions of the big array to ##V>=4.6## the actual size of the file, the major dimension (that is, ##V>=4.6## the first dimension for an array with C layout, and the last ##V>=4.6## dimension for an array with Fortran layout) can be given as ##V>=4.6## [-1]. [Genarray.map_file] then determines the major dimension ##V>=4.6## from the size of the file. The file must contain an integral ##V>=4.6## number of sub-arrays as determined by the non-major dimensions, ##V>=4.6## otherwise [Failure] is raised. ##V>=4.6## ##V>=4.6## If all dimensions of the big array are given, the file size is ##V>=4.6## matched against the size of the big array. If the file is larger ##V>=4.6## than the big array, only the initial portion of the file is ##V>=4.6## mapped to the big array. If the file is smaller than the big ##V>=4.6## array, the file is automatically grown to the size of the big array. ##V>=4.6## This requires write permissions on [fd]. ##V>=4.6## ##V>=4.6## Array accesses are bounds-checked, but the bounds are determined by ##V>=4.6## the initial call to [map_file]. Therefore, you should make sure no ##V>=4.6## other process modifies the mapped file while you're accessing it, ##V>=4.6## or a SIGBUS signal may be raised. This happens, for instance, if the ##V>=4.6## file is shrunk. ##V>=4.6## ##V>=4.6## [Invalid_argument] or [Failure] may be raised in cases where argument ##V>=4.6## validation fails. ##V>=4.6## @since 2.8.0 and OCaml 4.06.0 *) (** {6 Operations on file names} *) val unlink : string -> unit (** Removes the named file *) val rename : string -> string -> unit (** [rename old new] changes the name of a file from [old] to [new]. *) ##V<4.8##val link : string -> string -> unit ##V<4.8##(** [link source dest] creates a hard link named [dest] to the file ##V<4.8## named [source]. *) ##V>=4.8##val link : ?follow:bool -> string -> string -> unit ##V>=4.8##(** [link ?follow source dest] creates a hard link named [dest] to the file ##V>=4.8## named [source]. ##V>=4.8## ##V>=4.8## @param follow indicates whether a [source] symlink is followed or a ##V>=4.8## hardlink to [source] itself will be created. On {e Unix} systems this is ##V>=4.8## done using the [linkat(2)] function. If [?follow] is not provided, then the ##V>=4.8## [link(2)] function is used whose behaviour is OS-dependent, but more widely ##V>=4.8## available. ##V>=4.8## ##V>=4.8## @param follow is only available since 2.10.0 and OCaml 4.08. ##V>=4.8## ##V>=4.8## @raise ENOSYS On {e Unix} if [~follow:_] is requested, but linkat is ##V>=4.8## unavailable. ##V>=4.8## @raise ENOSYS On {e Windows} if [~follow:false] is requested. *) ##V>=4.13##val realpath : string -> string ##V>=4.13##(** [realpath p] is an absolute pathname for [p] obtained by resolving ##V>=4.13## all extra [/] characters, relative path segments and symbolic links. ##V>=4.13## ##V>=4.13## @since 3.4.0 and OCaml 4.13.0 *) (** {6 File permissions and ownership} *) type access_permission = Unix.access_permission = R_OK (** Read permission *) | W_OK (** Write permission *) | X_OK (** Execution permission *) | F_OK (** File exists *) (** Flags for the {!Unix.access} call. *) val chmod : string -> file_perm -> unit (** Change the permissions of the named file. *) val fchmod : file_descr -> file_perm -> unit (** Change the permissions of an opened file. *) val chown : string -> int -> int -> unit (** Change the owner uid and owner gid of the named file. *) val fchown : file_descr -> int -> int -> unit (** Change the owner uid and owner gid of an opened file. *) val umask : int -> int (** Set the process's file mode creation mask, and return the previous mask. *) val access : string -> access_permission list -> unit (** Check that the process has the given permissions over the named file. @raise Unix_error otherwise. *) (** {6 Operations on file descriptors} *) val dup : ##V>=4.5## ?cloexec:bool -> file_descr -> file_descr (** Return a new file descriptor referencing the same file as the given descriptor. *) val dup2 : ##V>=4.5## ?cloexec:bool -> file_descr -> file_descr -> unit (** [dup2 fd1 fd2] duplicates [fd1] to [fd2], closing [fd2] if already opened. *) val set_nonblock : file_descr -> unit (** Set the ``non-blocking'' flag on the given descriptor. When the non-blocking flag is set, reading on a descriptor on which there is temporarily no data available raises EAGAIN or EWOULDBLOCK error instead of blocking; writing on a descriptor on which there is temporarily no room for writing also raises EAGAIN or EWOULDBLOCK. *) val clear_nonblock : file_descr -> unit (** Clear the ``non-blocking'' flag on the given descriptor. See {!Unix.set_nonblock}.*) val set_close_on_exec : file_descr -> unit (** Set the ``close-on-exec'' flag on the given descriptor. A descriptor with the close-on-exec flag is automatically closed when the current process starts another program with one of the [exec] functions. *) val clear_close_on_exec : file_descr -> unit (** Clear the ``close-on-exec'' flag on the given descriptor. See {!Unix.set_close_on_exec}.*) (** {6 Directories} *) val mkdir : string -> file_perm -> unit (** Create a directory with the given permissions. *) val rmdir : string -> unit (** Remove an empty directory. *) val chdir : string -> unit (** Change the process working directory. *) val getcwd : unit -> string (** Return the name of the current working directory. *) val chroot : string -> unit (** Change the process root directory. *) type dir_handle = Unix.dir_handle (** The type of descriptors over opened directories. *) val opendir : string -> dir_handle (** Open a descriptor on a directory *) val readdir : dir_handle -> string (** Return the next entry in a directory. @raise End_of_file when the end of the directory has been reached. *) val rewinddir : dir_handle -> unit (** Reposition the descriptor to the beginning of the directory *) val closedir : dir_handle -> unit (** Close a directory descriptor. *) (** {6 Pipes and redirections} *) val pipe : ##V>=4.5## ?cloexec:bool -> unit -> file_descr * file_descr (** Create a pipe. The first component of the result is opened for reading, that's the exit to the pipe. The second component is opened for writing, that's the entrance to the pipe. *) val mkfifo : string -> file_perm -> unit (** Create a named pipe with the given permissions. *) (** {6 High-level process and redirection management} *) val open_process_in : ?autoclose: bool -> ?cleanup:bool -> string -> BatInnerIO.input (** High-level pipe and process management. This function runs the given command in parallel with the program. The standard output of the command is redirected to a pipe, which can be read via the returned input. The command is interpreted by the shell [/bin/sh] (cf. [system]). @param autoclose If true (default value), close the input automatically once there is no more content to read. Otherwise, the input will be closed according to the usual rules of module {!BatIO}. Barring very specific needs (e.g. using file descriptors as locks), you probably want [autoclose] to be [true]. @param cleanup If true or unspecified, close the process when the {!type:input} is closed. If false, do nothing, in which case you will need to close the process yourself to ensure proper cleanup. *) val open_process_out : ?cleanup:bool -> string -> unit BatInnerIO.output (** Same as {!Unix.open_process_in}, but redirect the standard input of the command to a pipe. Data written to the returned output is sent to the standard input of the command. {b Warning} writes on outputs are buffered, hence be careful to call {!Pervasives.flush} at the right times to ensure correct synchronization. @param cleanup If true or unspecified, close the process when the {!type:output} is closed. If false, do nothing, in which case you will need to close the process yourself to ensure proper cleanup. *) val open_process : ?autoclose:bool -> ?cleanup:bool -> string -> BatInnerIO.input * unit BatInnerIO.output (** Same as {!Unix.open_process_out}, but redirects both the standard input and standard output of the command to pipes connected to the two returned {!type: input}/{!type: output}. The returned {!type: input} is connected to the output of the command, and the returned {!type: output} to the input of the command. @param autoclose If true (default value), close the input automatically once there is no more content to read. Otherwise, the input will be closed according to the usual rules of module {!BatIO}. Barring very specific needs (e.g. using file descriptors as locks), you probably want [autoclose] to be [true]. @param cleanup If true or unspecified, close the process when either the {!type:output} or the {!type:output} is closed. If false, do nothing, in which case you will need to close the process yourself to ensure proper cleanup. *) val open_process_full : ?autoclose:bool -> ?cleanup:bool -> string -> string array -> BatInnerIO.input * unit BatInnerIO.output * BatInnerIO.input (** Similar to {!Unix.open_process}, but the second argument specifies the environment passed to the command. The result is a triple of {!type:input}/{!type:output} connected respectively to the standard output, standard input, and standard error of the command. @param autoclose If true (default value), close the input automatically once there is no more content to read. Otherwise, the input will be closed according to the usual rules of module {!BatIO}. Barring very specific needs (e.g. using file descriptors as locks), you probably want [autoclose] to be [true]. @param cleanup If true or unspecified, close the process when either the {!type:output} or the {!type:output} is closed. If false, do nothing, in which case you will need to close the process yourself to ensure proper cleanup. *) ##V>=4.08##val open_process_args_in : string -> string array -> in_channel ##V>=4.08##(** High-level pipe and process management. The first argument specifies the ##V>=4.08## command to run, and the second argument specifies the argument array passed ##V>=4.08## to the command. This function runs the command in parallel with the program. ##V>=4.08## The standard output of the command is redirected to a pipe, which can be read ##V>=4.08## via the returned input channel. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) ##V>=4.08##val open_process_args_out : string -> string array -> out_channel ##V>=4.08##(** Same as {!Unix.open_process_args_in}, but redirect the standard input of the ##V>=4.08## command to a pipe. Data written to the returned output channel is sent to ##V>=4.08## the standard input of the command. Warning: writes on output channels are ##V>=4.08## buffered, hence be careful to call {!Stdlib.flush} at the right times to ##V>=4.08## ensure correct synchronization. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) ##V>=4.08##val open_process_args : string -> string array -> in_channel * out_channel ##V>=4.08##(** Same as {!Unix.open_process_args_out}, but redirects both the standard input ##V>=4.08## and standard output of the command to pipes connected to the two returned ##V>=4.08## channels. The input channel is connected to the output of the command, and ##V>=4.08## the output channel to the input of the command. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) ##V>=4.08##val open_process_args_full : ##V>=4.08## string -> string array -> string array -> ##V>=4.08## in_channel * out_channel * in_channel ##V>=4.08##(** Similar to {!Unix.open_process_args}, but the third argument specifies the ##V>=4.08## environment passed to the command. The result is a triple of channels ##V>=4.08## connected respectively to the standard output, standard input, and standard ##V>=4.08## error of the command. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) ##V>=4.08##val process_in_pid : in_channel -> int ##V>=4.08##(** Return the pid of a process opened via {!Unix.open_process_in} or ##V>=4.08## {!Unix.open_process_args_in}. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) ##V>=4.08##val process_out_pid : out_channel -> int ##V>=4.08##(** Return the pid of a process opened via {!Unix.open_process_out} or ##V>=4.08## {!Unix.open_process_args_out}. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) ##V>=4.08##val process_pid : in_channel * out_channel -> int ##V>=4.08##(** Return the pid of a process opened via {!Unix.open_process} or ##V>=4.08## {!Unix.open_process_args}. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) ##V>=4.08##val process_full_pid : in_channel * out_channel * in_channel -> int ##V>=4.08##(** Return the pid of a process opened via {!Unix.open_process_full} or ##V>=4.08## {!Unix.open_process_args_full}. ##V>=4.08## ##V>=4.08## @since 2.10.0 and OCaml 4.08.0 *) val close_process_in : BatInnerIO.input -> process_status (** Close {!type:input} opened by {!Unix.open_process_in}, wait for the associated command to terminate, and return its termination status. @raise Unix_error(EBADF, "close_process_in", "") if the argument is not an {!type:input} opened by {!Unix.open_process_in}. *) val close_process_out : unit BatInnerIO.output -> process_status (** Close {!type:output} opened by {!Unix.open_process_out}, wait for the associated command to terminate, and return its termination status. @raise Unix_error(EBADF, "close_process_out", "") if the argument is not an {!type:output} opened by {!Unix.open_process_out}. *) val close_process : BatInnerIO.input * unit BatInnerIO.output -> process_status (** Close {!type:input}/{!type:output} opened by {!Unix.open_process}, wait for the associated command to terminate, and return its termination status. @raise Unix_error(EBADF, "close_process", "") if the argument is not pair of {!type:input}/{!type:output} opened by {!Unix.open_process}. *) val close_process_full : BatInnerIO.input * unit BatInnerIO.output * BatInnerIO.input -> process_status (** Close i/o opened by {!Unix.open_process_full}, wait for the associated command to terminate, and return its termination status. @raise Unix_error(EBADF, "close_process_full", "") if the argument is not a triple of {!type:input}/{!type:output} opened by {!Unix.open_process_full}. *) val create_process : string -> string array -> file_descr -> file_descr -> file_descr -> int (** [create_process prog args new_stdin new_stdout new_stderr] forks a new process that executes the program in file [prog], with arguments [args]. The pid of the new process is returned immediately; the new process executes concurrently with the current process. The standard input and outputs of the new process are connected to the descriptors [new_stdin], [new_stdout] and [new_stderr]. Passing e.g. [stdout] for [new_stdout] prevents the redirection and causes the new process to have the same standard output as the current process. The executable file [prog] is searched in the path. The new process has the same environment as the current process. *) val create_process_env : string -> string array -> string array -> file_descr -> file_descr -> file_descr -> int (** [create_process_env prog args env new_stdin new_stdout new_stderr] works as {!Unix.create_process}, except that the extra argument [env] specifies the environment passed to the program. *) (** {6 Symbolic links} *) ##V<4.3##val symlink : string -> string -> unit ##V<4.3##(** [symlink source dest] creates the file [dest] as a symbolic link ##V<4.3## to the file [source]. *) ##V>=4.3##val symlink : ?to_dir:bool -> string -> string -> unit ##V>=4.3##(** [symlink ?to_dir source dest] creates the file [dest] as ##V>=4.3## a symbolic link to the file [source]. On Windows, [~to_dir] ##V>=4.3## indicates if the symbolic link points to a directory or a file; ##V>=4.3## if omitted, [symlink] examines [source] using [stat] and picks ##V>=4.3## appropriately, if [source] does not exist then [false] is ##V>=4.3## assumed (for this reason, it is recommended that the [~to_dir] ##V>=4.3## parameter be specified in new code). On Unix, [~to_dir] ##V>=4.3## ignored. ##V>=4.3## ##V>=4.3## Windows symbolic links are available in Windows Vista ##V>=4.3## onwards. There are some important differences between Windows ##V>=4.3## symlinks and their POSIX counterparts. ##V>=4.3## ##V>=4.3## Windows symbolic links come in two flavours: directory and ##V>=4.3## regular, which designate whether the symbolic link points to ##V>=4.3## a directory or a file. The type must be correct - a directory ##V>=4.3## symlink which actually points to a file cannot be selected with ##V>=4.3## chdir and a file symlink which actually points to a directory ##V>=4.3## cannot be read or written (note that Cygwin's emulation layer ##V>=4.3## ignores this distinction). ##V>=4.3## ##V>=4.3## When symbolic links are created to existing targets, this ##V>=4.3## distinction doesn't matter and [symlink] will automatically ##V>=4.3## create the correct kind of symbolic link. The distinction ##V>=4.3## matters when a symbolic link is created to a non-existent ##V>=4.3## target. ##V>=4.3## ##V>=4.3## The other caveat is that by default symbolic links are ##V>=4.3## a privileged operation. Administrators will always need to be ##V>=4.3## running elevated (or with UAC disabled) and by default normal ##V>=4.3## user accounts need to be granted the ##V>=4.3## SeCreateSymbolicLinkPrivilege via Local Security Policy ##V>=4.3## (secpol.msc) or via Active Directory. ##V>=4.3## ##V>=4.3## {!has_symlink} can be used to check that a process is able to ##V>=4.3## create symbolic links. ##V>=4.3## ##V>=4.3## @since 4.03 the optional argument ?to_dir was added in 4.03 ##V>=4.3##*) ##V>=4.3##val has_symlink : unit -> bool ##V>=4.3##(** Returns [true] if the user is able to create symbolic links. On Windows, ##V>=4.3## this indicates that the user not only has the SeCreateSymbolicLinkPrivilege ##V>=4.3## but is also running elevated, if necessary. On other platforms, this is ##V>=4.3## simply indicates that the symlink system call is available. ##V>=4.3## ##V>=4.3## @since 2.5.0 and OCaml 4.03 *) val readlink : string -> string (** Read the contents of a link. *) (** {6 Polling} *) val select : file_descr list -> file_descr list -> file_descr list -> float -> file_descr list * file_descr list * file_descr list (** Wait until some input/output operations become possible on some channels. The three list arguments are, respectively, a set of descriptors to check for reading (first argument), for writing (second argument), or for exceptional conditions (third argument). The fourth argument is the maximal timeout, in seconds; a negative fourth argument means no timeout (unbounded wait). The result is composed of three sets of descriptors: those ready for reading (first component), ready for writing (second component), and over which an exceptional condition is pending (third component). *) (** {6 Locking} *) type lock_command = Unix.lock_command = F_ULOCK (** Unlock a region *) | F_LOCK (** Lock a region for writing, and block if already locked *) | F_TLOCK (** Lock a region for writing, or fail if already locked *) | F_TEST (** Test a region for other process locks *) | F_RLOCK (** Lock a region for reading, and block if already locked *) | F_TRLOCK (** Lock a region for reading, or fail if already locked *) (** Commands for {!Unix.lockf}. *) val lockf : file_descr -> lock_command -> int -> unit (** [lockf fd cmd size] puts a lock on a region of the file opened as [fd]. The region starts at the current read/write position for [fd] (as set by {!Unix.lseek}), and extends [size] bytes forward if [size] is positive, [size] bytes backwards if [size] is negative, or to the end of the file if [size] is zero. A write lock prevents any other process from acquiring a read or write lock on the region. A read lock prevents any other process from acquiring a write lock on the region, but lets other processes acquire read locks on it. The [F_LOCK] and [F_TLOCK] commands attempts to put a write lock on the specified region. The [F_RLOCK] and [F_TRLOCK] commands attempts to put a read lock on the specified region. If one or several locks put by another process prevent the current process from acquiring the lock, [F_LOCK] and [F_RLOCK] block until these locks are removed, while [F_TLOCK] and [F_TRLOCK] fail immediately with an exception. The [F_ULOCK] removes whatever locks the current process has on the specified region. Finally, the [F_TEST] command tests whether a write lock can be acquired on the specified region, without actually putting a lock. It returns immediately if successful, or fails otherwise. *) val with_locked_file : kind:[`Read|`Write] -> string -> (file_descr -> 'a) -> 'a (** [with_locked_file ~kind filename f] puts a lock (using lockf) on the whole file named [filename], calls [f] with the file descriptor, and returns its result after the file is unlocked. The file is opened with permissions matching [kind], and created if it does not exist yet. If [f ()] raises an exception the exception is re-raised after the file is unlocked. @param kind specifies whether the lock is read-only or read-write. *) (** {6 Signals} Note: installation of signal handlers is performed via the functions {!Sys.signal} and {!Sys.set_signal}. *) val kill : int -> int -> unit (** [kill pid sig] sends signal number [sig] to the process with id [pid]. *) type sigprocmask_command = Unix.sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK val sigprocmask : sigprocmask_command -> int list -> int list (** [sigprocmask cmd sigs] changes the set of blocked signals. If [cmd] is [SIG_SETMASK], blocked signals are set to those in the list [sigs]. If [cmd] is [SIG_BLOCK], the signals in [sigs] are added to the set of blocked signals. If [cmd] is [SIG_UNBLOCK], the signals in [sigs] are removed from the set of blocked signals. [sigprocmask] returns the set of previously blocked signals. *) val sigpending : unit -> int list (** Return the set of blocked signals that are currently pending. *) val sigsuspend : int list -> unit (** [sigsuspend sigs] atomically sets the blocked signals to [sigs] and waits for a non-ignored, non-blocked signal to be delivered. On return, the blocked signals are reset to their initial value. *) val pause : unit -> unit (** Wait until a non-ignored, non-blocked signal is delivered. *) (** {6 Time functions} *) type process_times = Unix.process_times = { tms_utime : float; (** User time for the process *) tms_stime : float; (** System time for the process *) tms_cutime : float; (** User time for the children processes *) tms_cstime : float; (** System time for the children processes *) } (** The execution times (CPU times) of a process. *) type tm = Unix.tm = { tm_sec : int; (** Seconds 0..60 *) tm_min : int; (** Minutes 0..59 *) tm_hour : int; (** Hours 0..23 *) tm_mday : int; (** Day of month 1..31 *) tm_mon : int; (** Month of year 0..11 *) tm_year : int; (** Year - 1900 *) tm_wday : int; (** Day of week (Sunday is 0) *) tm_yday : int; (** Day of year 0..365 *) tm_isdst : bool; (** Daylight time savings in effect *) } (** The type representing wallclock time and calendar date. *) val time : unit -> float (** Return the current time since 00:00:00 GMT, Jan. 1, 1970, in seconds. *) val gettimeofday : unit -> float (** Same as {!Unix.time}, but with resolution better than 1 second. *) val gmtime : float -> tm (** Convert a time in seconds, as returned by {!Unix.time}, into a date and a time. Assumes UTC (Coordinated Universal Time), also known as GMT. *) val localtime : float -> tm (** Convert a time in seconds, as returned by {!Unix.time}, into a date and a time. Assumes the local time zone. *) val mktime : tm -> float * tm (** Convert a date and time, specified by the [tm] argument, into a time in seconds, as returned by {!Unix.time}. The [tm_isdst], [tm_wday] and [tm_yday] fields of [tm] are ignored. Also return a normalized copy of the given [tm] record, with the [tm_wday], [tm_yday], and [tm_isdst] fields recomputed from the other fields, and the other fields normalized (so that, e.g., 40 October is changed into 9 November). The [tm] argument is interpreted in the local time zone. *) val alarm : int -> int (** Schedule a [SIGALRM] signal after the given number of seconds. *) val sleep : int -> unit (** Stop execution for the given number of seconds. *) val sleepf : float -> unit (** Stop execution for the given number of seconds. Like [sleep], but fractions of seconds are supported. @since 2.5.0 *) val times : unit -> process_times (** Return the execution times of the process. *) val utimes : string -> float -> float -> unit (** Set the last access time (second arg) and last modification time (third arg) for a file. Times are expressed in seconds from 00:00:00 GMT, Jan. 1, 1970. A time of [0.0] is interpreted as the current time. *) type interval_timer = Unix.interval_timer = ITIMER_REAL (** decrements in real time, and sends the signal [SIGALRM] when expired.*) | ITIMER_VIRTUAL (** decrements in process virtual time, and sends [SIGVTALRM] when expired. *) | ITIMER_PROF (** (for profiling) decrements both when the process is running and when the system is running on behalf of the process; it sends [SIGPROF] when expired. *) (** The three kinds of interval timers. *) type interval_timer_status = Unix.interval_timer_status = { it_interval : float; (** Period *) it_value : float; (** Current value of the timer *) } (** The type describing the status of an interval timer *) val getitimer : interval_timer -> interval_timer_status (** Return the current status of the given interval timer. *) val setitimer : interval_timer -> interval_timer_status -> interval_timer_status (** [setitimer t s] sets the interval timer [t] and returns its previous status. The [s] argument is interpreted as follows: [s.it_value], if nonzero, is the time to the next timer expiration; [s.it_interval], if nonzero, specifies a value to be used in reloading it_value when the timer expires. Setting [s.it_value] to zero disable the timer. Setting [s.it_interval] to zero causes the timer to be disabled after its next expiration. *) (** {6 User id, group id} *) val getuid : unit -> int (** Return the user id of the user executing the process. *) val geteuid : unit -> int (** Return the effective user id under which the process runs. *) val setuid : int -> unit (** Set the real user id and effective user id for the process. *) val getgid : unit -> int (** Return the group id of the user executing the process. *) val getegid : unit -> int (** Return the effective group id under which the process runs. *) val setgid : int -> unit (** Set the real group id and effective group id for the process. *) val getgroups : unit -> int array (** Return the list of groups to which the user executing the process belongs. *) val setgroups : int array -> unit (** [setgroups groups] sets the supplementary group IDs for the calling process. Appropriate privileges are required. *) val initgroups : string -> int -> unit (** [initgroups user group] initializes the group access list by reading the group database /etc/group and using all groups of which [user] is a member. The additional group [group] is also added to the list. *) type passwd_entry = Unix.passwd_entry = { pw_name : string; pw_passwd : string; pw_uid : int; pw_gid : int; pw_gecos : string; pw_dir : string; pw_shell : string } (** Structure of entries in the [passwd] database. *) type group_entry = Unix.group_entry = { gr_name : string; gr_passwd : string; gr_gid : int; gr_mem : string array } (** Structure of entries in the [groups] database. *) val getlogin : unit -> string (** Return the login name of the user executing the process. *) val getpwnam : string -> passwd_entry (** Find an entry in [passwd] with the given name. @raise Not_found if no such entry can be found. *) val getgrnam : string -> group_entry (** Find an entry in [group] with the given name. @raise Not_found if no such entry can be found. *) val getpwuid : int -> passwd_entry (** Find an entry in [passwd] with the given user id. @raise Not_found if no such entry can be found. *) val getgrgid : int -> group_entry (** Find an entry in [group] with the given group id. @raise Not_found if no such entry can be found. *) (** {6 Internet addresses} *) type inet_addr = Unix.inet_addr (** The abstract type of Internet addresses. *) val inet_addr_of_string : string -> inet_addr (** Conversion from the printable representation of an Internet address to its internal representation. The argument string consists of 4 numbers separated by periods ([XXX.YYY.ZZZ.TTT]) for IPv4 addresses, and up to 8 numbers separated by colons for IPv6 addresses. @raise Failure when given a string that does not match these formats. *) val string_of_inet_addr : inet_addr -> string (** Return the printable representation of the given Internet address. See {!Unix.inet_addr_of_string} for a description of the printable representation. *) val inet_addr_any : inet_addr (** A special IPv4 address, for use only with [bind], representing all the Internet addresses that the host machine possesses. *) val inet_addr_loopback : inet_addr (** A special IPv4 address representing the host machine ([127.0.0.1]). *) val inet6_addr_any : inet_addr (** A special IPv6 address, for use only with [bind], representing all the Internet addresses that the host machine possesses. *) val inet6_addr_loopback : inet_addr (** A special IPv6 address representing the host machine ([::1]). *) ##V>=4.12##val is_inet6_addr : inet_addr -> bool ##V>=4.12##(** Whether the given [inet_addr] is an IPv6 address. ##V>=4.12## @since 3.3.0 and 4.12.0 *) (** {6 Sockets} *) type socket_domain = Unix.socket_domain = PF_UNIX (** Unix domain *) | PF_INET (** Internet domain (IPv4) *) | PF_INET6 (** Internet domain (IPv6) *) (** The type of socket domains. Not all platforms support IPv6 sockets (type [PF_INET6]). *) type socket_type = Unix.socket_type = SOCK_STREAM (** Stream socket *) | SOCK_DGRAM (** Datagram socket *) | SOCK_RAW (** Raw socket *) | SOCK_SEQPACKET (** Sequenced packets socket *) (** The type of socket kinds, specifying the semantics of communications. *) type sockaddr = Unix.sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int (** The type of socket addresses. [ADDR_UNIX name] is a socket address in the Unix domain; [name] is a file name in the file system. [ADDR_INET(addr,port)] is a socket address in the Internet domain; [addr] is the Internet address of the machine, and [port] is the port number. *) val socket : ##V>=4.5## ?cloexec:bool -> socket_domain -> socket_type -> int -> file_descr (** Create a new socket in the given domain, and with the given kind. The third argument is the protocol type; 0 selects the default protocol for that kind of sockets. *) val domain_of_sockaddr: sockaddr -> socket_domain (** Return the socket domain adequate for the given socket address. *) val socketpair : ##V>=4.5## ?cloexec:bool -> socket_domain -> socket_type -> int -> file_descr * file_descr (** Create a pair of unnamed sockets, connected together. *) val accept : ##V>=4.5## ?cloexec:bool -> file_descr -> file_descr * sockaddr (** Accept connections on the given socket. The returned descriptor is a socket connected to the client; the returned address is the address of the connecting client. *) val bind : file_descr -> sockaddr -> unit (** Bind a socket to an address. *) val connect : file_descr -> sockaddr -> unit (** Connect a socket to an address. *) val listen : file_descr -> int -> unit (** Set up a socket for receiving connection requests. The integer argument is the maximal number of pending requests. *) type shutdown_command = Unix.shutdown_command = SHUTDOWN_RECEIVE (** Close for receiving *) | SHUTDOWN_SEND (** Close for sending *) | SHUTDOWN_ALL (** Close both *) (** The type of commands for [shutdown]. *) val shutdown : file_descr -> shutdown_command -> unit (** Shutdown a socket connection. [SHUTDOWN_SEND] as second argument causes reads on the other end of the connection to return an end-of-file condition. [SHUTDOWN_RECEIVE] causes writes on the other end of the connection to return a closed pipe condition ([SIGPIPE] signal). *) val getsockname : file_descr -> sockaddr (** Return the address of the given socket. *) val getpeername : file_descr -> sockaddr (** Return the address of the host connected to the given socket. *) type msg_flag = Unix.msg_flag = MSG_OOB | MSG_DONTROUTE | MSG_PEEK (** The flags for {!Unix.recv}, {!Unix.recvfrom}, {!Unix.send} and {!Unix.sendto}. *) val recv : file_descr -> Bytes.t -> int -> int -> msg_flag list -> int (** Receive data from a connected socket. *) val recvfrom : file_descr -> Bytes.t -> int -> int -> msg_flag list -> int * sockaddr (** Receive data from an unconnected socket. *) val send : file_descr -> Bytes.t -> int -> int -> msg_flag list -> int (** Send data over a connected socket. *) val send_substring : file_descr -> string -> int -> int -> msg_flag list -> int (** Same as [send], but take the data from a string instead of a byte sequence. @since 2.3.0 *) val sendto : file_descr -> Bytes.t -> int -> int -> msg_flag list -> sockaddr -> int (** Send data over an unconnected socket. *) val sendto_substring : file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int (** Same as [sendto], but take the data from a string instead of a byte sequence. @since 2.3.0 *) (** {6 Socket options} *) type socket_bool_option = Unix.socket_bool_option = SO_DEBUG (** Record debugging information *) | SO_BROADCAST (** Permit sending of broadcast messages *) | SO_REUSEADDR (** Allow reuse of local addresses for bind *) | SO_KEEPALIVE (** Keep connection active *) | SO_DONTROUTE (** Bypass the standard routing algorithms *) | SO_OOBINLINE (** Leave out-of-band data in line *) | SO_ACCEPTCONN (** Report whether socket listening is enabled *) | TCP_NODELAY (** Control the Nagle algorithm for TCP sockets *) | IPV6_ONLY (** Forbid binding an IPv6 socket to an IPv4 address *) ##V>=4.12## | SO_REUSEPORT (** Allow connection active *) (** The socket options that can be consulted with {!Unix.getsockopt} and modified with {!Unix.setsockopt}. These options have a boolean ([true]/[false]) value. *) type socket_int_option = Unix.socket_int_option = SO_SNDBUF (** Size of send buffer *) | SO_RCVBUF (** Size of received buffer *) | SO_ERROR (** Deprecated. Use {!Unix.getsockopt_error} instead. *) | SO_TYPE (** Report the socket type *) | SO_RCVLOWAT (** Minimum number of bytes to process for input operations*) | SO_SNDLOWAT (** Minimum number of bytes to process for output operations *) (** The socket options that can be consulted with {!Unix.getsockopt_int} and modified with {!Unix.setsockopt_int}. These options have an integer value. *) type socket_optint_option = Unix.socket_optint_option = SO_LINGER (** Whether to linger on closed connections that have data present, and for how long (in seconds) *) (** The socket options that can be consulted with {!Unix.getsockopt_optint} and modified with {!Unix.setsockopt_optint}. These options have a value of type [int option], with [None] meaning ``disabled''. *) type socket_float_option = Unix.socket_float_option = SO_RCVTIMEO (** Timeout for input operations *) | SO_SNDTIMEO (** Timeout for output operations *) (** The socket options that can be consulted with {!Unix.getsockopt_float} and modified with {!Unix.setsockopt_float}. These options have a floating-point value representing a time in seconds. The value 0 means infinite timeout. *) val getsockopt : file_descr -> socket_bool_option -> bool (** Return the current status of a boolean-valued option in the given socket. *) val setsockopt : file_descr -> socket_bool_option -> bool -> unit (** Set or clear a boolean-valued option in the given socket. *) val getsockopt_int : file_descr -> socket_int_option -> int (** Same as {!Unix.getsockopt} for an integer-valued socket option. *) val setsockopt_int : file_descr -> socket_int_option -> int -> unit (** Same as {!Unix.setsockopt} for an integer-valued socket option. *) val getsockopt_optint : file_descr -> socket_optint_option -> int option (** Same as {!Unix.getsockopt} for a socket option whose value is an [int option]. *) val setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit (** Same as {!Unix.setsockopt} for a socket option whose value is an [int option]. *) val getsockopt_float : file_descr -> socket_float_option -> float (** Same as {!Unix.getsockopt} for a socket option whose value is a floating-point number. *) val setsockopt_float : file_descr -> socket_float_option -> float -> unit (** Same as {!Unix.setsockopt} for a socket option whose value is a floating-point number. *) val getsockopt_error : file_descr -> error option (** Return the error condition associated with the given socket, and clear it. *) (** {6 High-level network connection functions} *) val open_connection : ?autoclose:bool -> sockaddr -> BatInnerIO.input * unit BatInnerIO.output (** Connect to a server at the given address. Return a pair of input/output connected to the server. The connection is closed whenever either the input or the output is closed. Remember to call {!Pervasives.flush} on the output at the right times to ensure correct synchronization. @param autoclose If true (default value), close the input automatically once there is no more content to read. Otherwise, the input will be closed according to the usual rules of module {!BatIO}. Barring very specific needs (e.g. using file descriptors as locks), you probably want [autoclose] to be [true]. *) val shutdown_connection : BatInnerIO.input -> unit (** ``Shut down'' a connection established with {!Unix.open_connection}; that is, transmit an end-of-file condition to the server reading on the other side of the connection. @deprecated Connections do not require a special function anymore. Use regular function {!BatIO.close_in} for closing connections. *) val establish_server : ?autoclose:bool -> ?cleanup:bool -> (BatInnerIO.input -> unit BatInnerIO.output -> unit) -> sockaddr -> unit (** Establish a server on the given address. [establish_server f addr] establishes a server on address [addr]. For each connection on this address, function [f] is called with two buffered channels connected to the client. A new process is created for each connection. The function {!Unix.establish_server} never returns normally. @param autoclose If true (default value), inputs passed to [f] close the input automatically once there is no more content to read. Otherwise, the input will be closed according to the usual rules of module {!BatIO}. Barring very specific needs (e.g. using file descriptors as locks), you probably want [autoclose] to be [true]. @param cleanup If true or unspecified, close the connection when the {!type:input} or the {!type:output} is closed or garbage-collected. If false, do nothing, in which case you will need to shutdown the connection using {!shutdown_connection} to ensure proper cleanup. *) (** {6 Host and protocol databases} *) type host_entry = Unix.host_entry = { h_name : string; h_aliases : string array; h_addrtype : socket_domain; h_addr_list : inet_addr array } (** Structure of entries in the [hosts] database. *) type protocol_entry = Unix.protocol_entry = { p_name : string; p_aliases : string array; p_proto : int } (** Structure of entries in the [protocols] database. *) type service_entry = Unix.service_entry = { s_name : string; s_aliases : string array; s_port : int; s_proto : string } (** Structure of entries in the [services] database. *) val gethostname : unit -> string (** Return the name of the local host. *) val gethostbyname : string -> host_entry (** Find an entry in [hosts] with the given name. @raise Not_found if no such entry can be found. *) val gethostbyaddr : inet_addr -> host_entry (** Find an entry in [hosts] with the given address. @raise Not_found if no such entry can be found. *) val getprotobyname : string -> protocol_entry (** Find an entry in [protocols] with the given name @raise Not_found if no such entry can be found. *) val getprotobynumber : int -> protocol_entry (** Find an entry in [protocols] with the given protocol number. @raise Not_found if no such entry can be found. *) val getservbyname : string -> string -> service_entry (** Find an entry in [services] with the given name. @raise Not_found if no such entry can be found. *) val getservbyport : int -> string -> service_entry (** Find an entry in [services] with the given service number. @raise Not_found if no such entry can be found. *) type addr_info = Unix.addr_info = { ai_family : socket_domain; (** Socket domain *) ai_socktype : socket_type; (** Socket type *) ai_protocol : int; (** Socket protocol number *) ai_addr : sockaddr; (** Address *) ai_canonname : string (** Canonical host name *) } (** Address information returned by {!Unix.getaddrinfo}. *) type getaddrinfo_option = Unix.getaddrinfo_option = AI_FAMILY of socket_domain (** Impose the given socket domain *) | AI_SOCKTYPE of socket_type (** Impose the given socket type *) | AI_PROTOCOL of int (** Impose the given protocol *) | AI_NUMERICHOST (** Do not call name resolver, expect numeric IP address *) | AI_CANONNAME (** Fill the [ai_canonname] field of the result *) | AI_PASSIVE (** Set address to ``any'' address for use with {!Unix.bind} *) (** Options to {!Unix.getaddrinfo}. *) val getaddrinfo: string -> string -> getaddrinfo_option list -> addr_info list (** [getaddrinfo host service opts] returns a list of {!Unix.addr_info} records describing socket parameters and addresses suitable for communicating with the given host and service. The empty list is returned if the host or service names are unknown, or the constraints expressed in [opts] cannot be satisfied. [host] is either a host name or the string representation of an IP address. [host] can be given as the empty string; in this case, the ``any'' address or the ``loopback'' address are used, depending whether [opts] contains [AI_PASSIVE]. [service] is either a service name or the string representation of a port number. [service] can be given as the empty string; in this case, the port field of the returned addresses is set to 0. [opts] is a possibly empty list of options that allows the caller to force a particular socket domain (e.g. IPv6 only or IPv4 only) or a particular socket type (e.g. TCP only or UDP only). *) type name_info = Unix.name_info = { ni_hostname : string; (** Name or IP address of host *) ni_service : string; (** Name of service or port number *) } (** Host and service information returned by {!Unix.getnameinfo}. *) type getnameinfo_option = Unix.getnameinfo_option = NI_NOFQDN (** Do not qualify local host names *) | NI_NUMERICHOST (** Always return host as IP address *) | NI_NAMEREQD (** Fail if host name cannot be determined *) | NI_NUMERICSERV (** Always return service as port number *) | NI_DGRAM (** Consider the service as UDP-based instead of the default TCP *) (** Options to {!Unix.getnameinfo}. *) val getnameinfo : sockaddr -> getnameinfo_option list -> name_info (** [getnameinfo addr opts] returns the host name and service name corresponding to the socket address [addr]. [opts] is a possibly empty list of options that governs how these names are obtained. @raise Not_found if an error occurs. *) (** {6 Terminal interface} *) (** The following functions implement the POSIX standard terminal interface. They provide control over asynchronous communication ports and pseudo-terminals. Refer to the [termios] man page for a complete description. *) type terminal_io = Unix.terminal_io = { (* input modes *) mutable c_ignbrk : bool; (** Ignore the break condition. *) mutable c_brkint : bool; (** Signal interrupt on break condition. *) mutable c_ignpar : bool; (** Ignore characters with parity errors. *) mutable c_parmrk : bool; (** Mark parity errors. *) mutable c_inpck : bool; (** Enable parity check on input. *) mutable c_istrip : bool; (** Strip 8th bit on input characters. *) mutable c_inlcr : bool; (** Map NL to CR on input. *) mutable c_igncr : bool; (** Ignore CR on input. *) mutable c_icrnl : bool; (** Map CR to NL on input. *) mutable c_ixon : bool; (** Recognize XON/XOFF characters on input. *) mutable c_ixoff : bool; (** Emit XON/XOFF chars to control input flow. *) (* Output modes: *) mutable c_opost : bool; (** Enable output processing. *) (* Control modes: *) mutable c_obaud : int; (** Output baud rate (0 means close connection).*) mutable c_ibaud : int; (** Input baud rate. *) mutable c_csize : int; (** Number of bits per character (5-8). *) mutable c_cstopb : int; (** Number of stop bits (1-2). *) mutable c_cread : bool; (** Reception is enabled. *) mutable c_parenb : bool; (** Enable parity generation and detection. *) mutable c_parodd : bool; (** Specify odd parity instead of even. *) mutable c_hupcl : bool; (** Hang up on last close. *) mutable c_clocal : bool; (** Ignore modem status lines. *) (* Local modes: *) mutable c_isig : bool; (** Generate signal on INTR, QUIT, SUSP. *) mutable c_icanon : bool; (** Enable canonical processing (line buffering and editing) *) mutable c_noflsh : bool; (** Disable flush after INTR, QUIT, SUSP. *) mutable c_echo : bool; (** Echo input characters. *) mutable c_echoe : bool; (** Echo ERASE (to erase previous character). *) mutable c_echok : bool; (** Echo KILL (to erase the current line). *) mutable c_echonl : bool; (** Echo NL even if c_echo is not set. *) (* Control characters: *) mutable c_vintr : char; (** Interrupt character (usually ctrl-C). *) mutable c_vquit : char; (** Quit character (usually ctrl-\). *) mutable c_verase : char; (** Erase character (usually DEL or ctrl-H). *) mutable c_vkill : char; (** Kill line character (usually ctrl-U). *) mutable c_veof : char; (** End-of-file character (usually ctrl-D). *) mutable c_veol : char; (** Alternate end-of-line char. (usually none). *) mutable c_vmin : int; (** Minimum number of characters to read before the read request is satisfied. *) mutable c_vtime : int; (** Maximum read wait (in 0.1s units). *) mutable c_vstart : char; (** Start character (usually ctrl-Q). *) mutable c_vstop : char; (** Stop character (usually ctrl-S). *) } val tcgetattr : file_descr -> terminal_io (** Return the status of the terminal referred to by the given file descriptor. *) type setattr_when = Unix.setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH val tcsetattr : file_descr -> setattr_when -> terminal_io -> unit (** Set the status of the terminal referred to by the given file descriptor. The second argument indicates when the status change takes place: immediately ([TCSANOW]), when all pending output has been transmitted ([TCSADRAIN]), or after flushing all input that has been received but not read ([TCSAFLUSH]). [TCSADRAIN] is recommended when changing the output parameters; [TCSAFLUSH], when changing the input parameters. *) val tcsendbreak : file_descr -> int -> unit (** Send a break condition on the given file descriptor. The second argument is the duration of the break, in 0.1s units; 0 means standard duration (0.25s). *) val tcdrain : file_descr -> unit (** Waits until all output written on the given file descriptor has been transmitted. *) type flush_queue = Unix.flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH val tcflush : file_descr -> flush_queue -> unit (** Discard data written on the given file descriptor but not yet transmitted, or data received but not yet read, depending on the second argument: [TCIFLUSH] flushes data received but not read, [TCOFLUSH] flushes data written but not transmitted, and [TCIOFLUSH] flushes both. *) type flow_action = Unix.flow_action = TCOOFF | TCOON | TCIOFF | TCION val tcflow : file_descr -> flow_action -> unit (** Suspend or restart reception or transmission of data on the given file descriptor, depending on the second argument: [TCOOFF] suspends output, [TCOON] restarts output, [TCIOFF] transmits a STOP character to suspend input, and [TCION] transmits a START character to restart input. *) val setsid : unit -> int (** Put the calling process in a new session and detach it from its controlling terminal. *) (** {6 Small tools} *) val is_directory : string -> bool (** [is_directory filename] returns true if [filename] refers to a directory (or symlink of a directory) *) val restart_on_EINTR : ('a -> 'b) -> 'a -> 'b (** [restart_on_EINTR f x] invokes [f] on [x] repetedly until the function returns a value or raises another exception than EINTR. *) (** {6 Thread-safety internals} Unless you are attempting to adapt Batteries Included to a new model of concurrency, you probably won't need this. *) val lock: BatConcurrent.lock ref (** A lock used to synchronize internal operations. By default, this is {!BatConcurrent.nolock}. However, if you're using a version of Batteries compiled in threaded mode, this uses {!BatMutex}. If you're attempting to use Batteries with another concurrency model, set the lock appropriately. *) (** {6 Obsolete stuff} *) val in_channel_of_descr: file_descr -> BatInnerIO.input (** @deprecated use {!input_of_descr}*) val out_channel_of_descr: file_descr -> unit BatInnerIO.output (** @deprecated use {!output_of_descr}. *) val descr_of_in_channel : BatInnerIO.input -> file_descr (** @deprecated use {!descr_of_input}. *) val descr_of_out_channel : unit BatInnerIO.output -> file_descr (** @deprecated use {!descr_of_output}. *) batteries-included-3.4.0/src/batUnix.mlv000066400000000000000000000205021415601150500202030ustar00rootroot00000000000000(* * BatUnix - additional and modified functions for Unix and Unix-compatible systems. * Copyright (C) 1996 Xavier Leroy * Copyright (C) 2009 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) include Unix ##V<4.8##external link : string -> string -> unit = "unix_link" ##V>=4.8##external link : ?follow:bool -> string -> string -> unit = "unix_link" ##V<4.2##let write_substring = write ##V<4.2##let single_write_substring = single_write ##V<4.2##let send_substring = send ##V<4.2##let sendto_substring = sendto ##V<4.3##let sleepf (timeout: float): unit = ##V<4.3## let elapsed = ref 0.0 in ##V<4.3## while !elapsed < timeout do ##V<4.3## let start = gettimeofday () in ##V<4.3## begin ##V<4.3## try ignore(select [] [] [] (timeout -. !elapsed)) ##V<4.3## with Unix_error(EINTR, _, _) -> () ##V<4.3## end; ##V<4.3## let stop = gettimeofday () in ##V<4.3## let dt = stop -. start in ##V<4.3## elapsed := !elapsed +. dt ##V<4.3## done; ##V<4.3## () (* chronometer is useful to test sleepf *) (*$inject let chronometer f = let start = gettimeofday () in let res = f () in let stop = gettimeofday () in let dt = stop -. start in (dt, res) ;; *) (* do not underestimate the imprecission of sleepf and so don't be too harsh when testing it *) (*$T sleepf let dt, _ = chronometer (fun () -> sleepf 0.002) in \ dt >= 0.002 *) let run_and_read cmd = (* This code is before the open of BatInnerIO to avoid using batteries' wrapped IOs *) let string_of_file fn = let buff_size = 1024 in let buff = Buffer.create buff_size in let ic = open_in fn in let line_buff = Bytes.create buff_size in begin let was_read = ref (input ic line_buff 0 buff_size) in while !was_read <> 0 do BatBytesCompat.buffer_add_subbytes buff line_buff 0 !was_read; was_read := input ic line_buff 0 buff_size; done; close_in ic; end; Buffer.contents buff in let tmp_fn = Filename.temp_file "" "" in let cmd_to_run = cmd ^ " > " ^ tmp_fn in let status = Unix.system cmd_to_run in let output = string_of_file tmp_fn in Unix.unlink tmp_fn; (status, output) (*$T run_and_read run_and_read "echo" = (WEXITED 0, "\n") run_and_read "echo toto" = (WEXITED 0, "toto\n") run_and_read "seq 1 3" = (WEXITED 0, "1\n2\n3\n") run_and_read "printf 'abc'" = (WEXITED 0, "abc") *) open BatInnerIO (** {6 Thread-safety internals} *) let lock = ref BatConcurrent.nolock (** {6 Tracking additional information on inputs/outputs} {b Note} Having [input]/[output] as objects would have made this easier. Here, we need to maintain an external weak hashtable to track low-level information on our [input]s/[output]s. *) module Wrapped_in = BatInnerWeaktbl.Make(Input) (*input -> in_channel *) module Wrapped_out = BatInnerWeaktbl.Make(Output)(*output -> out_channel*) let wrapped_in = Wrapped_in.create 16 let wrapped_out = Wrapped_out.create 16 let input_add k v = BatConcurrent.sync !lock (Wrapped_in.add wrapped_in k) v let input_get k = BatConcurrent.sync !lock (Wrapped_in.find wrapped_in) k let output_add k v = BatConcurrent.sync !lock (Wrapped_out.add wrapped_out k) v let output_get k = BatConcurrent.sync !lock (Wrapped_out.find wrapped_out) k let wrap_in ?autoclose ?cleanup cin = let input = BatInnerIO.input_channel ?autoclose ?cleanup cin in BatConcurrent.sync !lock (Wrapped_in.add wrapped_in input) cin; input let wrap_out ?cleanup cout = let output = cast_output (BatInnerIO.output_channel ?cleanup cout) in BatConcurrent.sync !lock (Wrapped_out.add wrapped_out output) cout; output let _ = input_add stdin Pervasives.stdin; output_add stdout Pervasives.stdout; output_add stderr Pervasives.stderr (** {6 File descriptors} *) let input_of_descr ?autoclose ?cleanup fd = wrap_in ?autoclose ?cleanup (in_channel_of_descr fd) let descr_of_input cin = try descr_of_in_channel (input_get cin) with Not_found -> invalid_arg "Unix.descr_of_input" let output_of_descr ?cleanup fd = wrap_out ?cleanup (out_channel_of_descr fd) let descr_of_output cout = try descr_of_out_channel (output_get (cast_output cout)) with Not_found -> invalid_arg "Unix.descr_of_output" let in_channel_of_descr fd = input_of_descr ~autoclose:false ~cleanup:true fd let descr_of_in_channel = descr_of_input let out_channel_of_descr fd = output_of_descr ~cleanup:true fd let descr_of_out_channel = descr_of_output (** {6 Processes} *) let open_process_in ?autoclose ?(cleanup=true) s = wrap_in ?autoclose ~cleanup (open_process_in s) let open_process_out ?(cleanup=true) s = wrap_out ~cleanup (open_process_out s) let open_process ?autoclose ?(cleanup=true) s = let (cin, cout) = open_process s in (wrap_in ?autoclose cin, wrap_out ~cleanup cout) (*$T open_process let s = "hello world" in let r,w = open_process "cat" in \ Printf.fprintf w "%s\n" s; IO.close_out w; \ IO.read_line r = s try \ let r,w = open_process "cat" in \ Printf.fprintf w "hello world\n"; \ IO.close_out w; \ while true do ignore (input_char r) done; false \ with e -> e=IO.No_more_input || e=End_of_file *) let open_process_full ?autoclose ?(cleanup=true) s args = let (a,b,c) = open_process_full s args in (wrap_in ?autoclose ~cleanup a, wrap_out ~cleanup b, wrap_in ?autoclose ~cleanup c) (**@TODO in a future version, [close_process_in] should also work on processes opened with [open_process] or [open_process_full]. Same thing for [close_process_out].*) let close_process_in cin = try close_process_in (input_get cin) with Not_found -> raise (Unix_error(EBADF, "close_process_in", "")) let close_process_out cout = try close_process_out (output_get cout) with Not_found -> raise (Unix_error(EBADF, "close_process_out", "")) let close_process (cin, cout) = try let pin = input_get cin and pout= output_get cout in close_process (pin, pout) with Not_found -> raise (Unix_error(EBADF, "close_process", "")) let close_process_full (cin, cout, cin2) = try close_process_full (input_get cin, output_get cout, input_get cin2) with Not_found -> raise (Unix_error(EBADF, "close_process_full", "")) (** {6 Network} *) let shutdown_connection cin = try shutdown_connection (input_get cin) with Not_found -> invalid_arg "Unix.shutdown_connection" let open_connection ?autoclose addr = let (cin, cout) = open_connection addr in let (cin',cout')= (wrap_in ?autoclose ~cleanup:true cin, wrap_out ~cleanup:true cout) in let close () = shutdown_connection cin' in (inherit_in cin' ~close, inherit_out cout' ~close) let establish_server ?autoclose ?cleanup f addr = let f' cin cout = f (wrap_in ?autoclose ?cleanup cin) (wrap_out cout) in establish_server f' addr (** {6 Tools} *) let is_directory fn = (lstat fn).st_kind = S_DIR let rec restart_on_EINTR f x = try f x with Unix_error(EINTR, _, _) -> restart_on_EINTR f x (** {6 Locking} *) let with_locked_file ~kind filename f = let perms = [O_CREAT ; match kind with `Read -> O_RDONLY | `Write -> O_RDWR] in let lock_file = openfile filename perms 0o644 in let lock_action = match kind with | `Read -> F_RLOCK | `Write -> F_LOCK in lockf lock_file lock_action 0; BatInnerPervasives.finally (fun () -> (* Although the user might expect EINTR to interrupt locking, we must * not allow such interrupt here since there is no way to restart the * unlock: *) ignore (restart_on_EINTR (lseek lock_file 0) SEEK_SET); restart_on_EINTR (lockf lock_file F_ULOCK) 0; restart_on_EINTR close lock_file) f lock_file batteries-included-3.4.0/src/batUref.ml000066400000000000000000000061171415601150500200010ustar00rootroot00000000000000(* * Uref -- unifiable references * Copyright (C) 2011 Batteries Included Development Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (* Implements union-find with ranks and path-compression *) type 'a uref_contents = | Ranked of 'a * int | Ptr of 'a uref and 'a uref = 'a uref_contents ref type 'a t = 'a uref let rec find ur = match !ur with | Ptr p -> let vr = find p in ur := Ptr vr ; vr | Ranked _ -> ur let uref x = ref (Ranked (x, 0)) let uget ur = match !(find ur) with | Ptr _ -> assert false | Ranked (x, _) -> x let uset ur x = let ur = find ur in match !ur with | Ptr _ -> assert false | Ranked (_, r) -> ur := Ranked (x, r) let equal ur vr = find ur == find vr let unite ?sel ur vr = (* we use ?sel instead of ?(sel=(fun x _y -> x)) because we want to be able to know whether a selection function was passed, for optimization purposes: when sel is the default (expected common case), we can take a short path in the (ur == vr) case. *) let ur = find ur in let vr = find vr in if ur == vr then begin match sel with | None -> () | Some sel -> (* even when ur and vr are the same reference, we need to apply the selection function, as [sel x x] may be different from [x]. For example, [unite ~sel:(fun _ _ -> v) r r] would fail to set the content of [r] to [v] otherwise. *) match !ur with | Ptr _ -> assert false | Ranked (x, r) -> let x' = sel x x in ur := Ranked(x', r) end else match !ur, !vr with | _, Ptr _ | Ptr _, _ -> assert false | Ranked (x, xr), Ranked (y, yr) -> let z = match sel with | None -> x (* in the default case, pick x *) | Some sel -> sel x y in if xr = yr then begin ur := Ranked (z, xr + 1) ; vr := Ptr ur end else if xr < yr then begin ur := Ranked (z, xr) ; vr := Ptr ur end else begin vr := Ranked (z, yr) ; ur := Ptr vr end let print elepr out ur = match !(find ur) with | Ptr _ -> assert false | Ranked (x, _) -> BatInnerIO.nwrite out "uref " ; elepr out x (*$T print let u1 = uref 2 and u2 = uref 3 in unite ~sel:(+) u1 u2; \ BatIO.to_string (print BatInt.print) u1 = "uref 5" && \ BatIO.to_string (print BatInt.print) u2 = "uref 5" *) batteries-included-3.4.0/src/batUref.mli000066400000000000000000000037531415601150500201550ustar00rootroot00000000000000(* * Uref -- unifiable references * Copyright (C) 2011 Batteries Included Development Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Unifiable references using destructive union-find *) type 'a uref (** A [t uref] is a reference to a cell that contains a value of type [t]. *) type 'a t = 'a uref (** A synonym for convenience *) val uref : 'a -> 'a uref (** [uref x] allocates a new uref and places the value [x] in it. *) val uget : 'a uref -> 'a (** [uget ur] returns the value stored in the uref [ur]. *) val uset : 'a uref -> 'a -> unit (** [uset ur x] updates the contents of [ur] with [x]. *) val unite : ?sel:('a -> 'a -> 'a) -> 'a uref -> 'a uref -> unit (** [unite ~sel ur1 ur2] unites the urefs [ur1] and [ur2], selecting the result of [sel (uget ur1) (uget ur2)] for the contents of the resulting united uref. After this operation, [uget ur1 == uget ur2]. By default, [sel] is [fun x _y -> x]. *) val equal : 'a uref -> 'a uref -> bool (** [equal ur1 ur2] returns [true] iff [ur1] and [ur2] are equal urefs, either because they are physically the same or because they have been {!unite}d. *) (** {6 Printing} *) val print : ('a, 'b) BatIO.printer -> ('a uref, 'b) BatIO.printer (** Print the uref. *) batteries-included-3.4.0/src/batVect.ml000066400000000000000000001155311415601150500200020ustar00rootroot00000000000000(* * Vect - Extensible arrays based on ropes * Copyright (C) 2007 Mauricio Fernandez * 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module STRING : sig (* this module must provide the following functions: *) type 'a t = 'a array val length : 'a t -> int val make : int -> 'a -> 'a t val copy : 'a t -> 'a t val unsafe_get : 'a t -> int -> 'a val unsafe_set : 'a t -> int -> 'a -> unit val sub : 'a t -> int -> int -> 'a t val iter : ('a -> unit) -> 'a t -> unit val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b val append : 'a t -> 'a t -> 'a t val concat : 'a t list -> 'a t end = BatArray type 'a t = | Empty | Concat of 'a t * int * 'a t * int * int | Leaf of 'a STRING.t (* these invariants may be incomplete, feel free to improve it *) let invariants t = let rec inv_height = function | Empty | Leaf _ -> 0 | Concat (l, _, r, _, h) -> assert (h = 1 + max (inv_height l) (inv_height r)); h in let rec inv_length = function | Empty -> 0 | Leaf a -> STRING.length a | Concat (l, cl, r, cr, _) -> assert (inv_length l = cl); assert (inv_length r = cr); cl + cr in let rec other_inv depth = function | Empty -> assert (depth = 0) | Leaf a -> assert (STRING.length a > 0) | Concat (l, _, r, _, _) -> other_inv (depth + 1) l; other_inv (depth + 1) r in ignore (inv_height t); ignore (inv_length t); other_inv 0 t type 'a forest_element = { mutable c : 'a t; mutable len : int } let str_append = STRING.append let string_of_string_list = STRING.concat let singleton x = Leaf [|x|] (* 48 limits max rope size to 236.10^9 elements on 64 bit, * ~ 734.10^6 on 32bit (length fields overflow after that) *) let max_height = 48 (* actual size will be that plus 1 word header; * the code assumes it's an even num. * 32 gives up to 50% overhead in the worst case (all leaf nodes near * half-filled; 8 words for bookkeeping, 16 words worth of data per leaf node *) let leaf_size = 16 exception Out_of_bounds let empty = Empty (* by construction, there cannot be Empty or Leaf "" leaves *) let is_empty = function | Empty -> true | Leaf _ | Concat _ -> false let height = function | Empty | Leaf _ -> 0 | Concat (_, _, _, _, h) -> h let length = function | Empty -> 0 | Leaf s -> STRING.length s | Concat (_, cl, _, cr, _) -> cl + cr let make_concat l r = let hl = height l and hr = height r in let cl = length l and cr = length r in Concat (l, cl, r, cr, if hl >= hr then hl + 1 else hr + 1) let min_len = let fib_tbl = Array.make max_height 0 in let rec fib n = match fib_tbl.(n) with | 0 -> let last = fib (n - 1) and prev = fib (n - 2) in let r = last + prev in let r = if r > last then r else last in (* check overflow *) fib_tbl.(n) <- r; r | n -> n in fib_tbl.(0) <- leaf_size + 1; fib_tbl.(1) <- 3 * leaf_size / 2 + 1; Array.init max_height (fun i -> if i = 0 then 1 else fib (i - 1)) let max_length = min_len.(Array.length min_len - 1) let concat_fast l r = match l with | Empty -> r | Leaf _ | Concat _ -> match r with | Empty -> l | Leaf _ | Concat _ -> make_concat l r (* based on Hans-J. Boehm's *) let add_forest forest rope len = let i = ref 0 in let sum = ref empty in while len > min_len.(!i+1) do if forest.(!i).c <> Empty then begin sum := concat_fast forest.(!i).c !sum; forest.(!i).c <- Empty end; incr i done; sum := concat_fast !sum rope; let sum_len = ref (length !sum) in while !sum_len >= min_len.(!i) do if forest.(!i).c <> Empty then begin sum := concat_fast forest.(!i).c !sum; sum_len := !sum_len + forest.(!i).len; forest.(!i).c <- Empty; end; incr i done; decr i; forest.(!i).c <- !sum; forest.(!i).len <- !sum_len let concat_forest forest = Array.fold_left (fun s x -> concat_fast x.c s) Empty forest let rec balance_insert rope len forest = match rope with | Empty -> () | Leaf _ -> add_forest forest rope len | Concat (l, cl, r, cr, h) when h >= max_height || len < min_len.(h) -> balance_insert l cl forest; balance_insert r cr forest | Concat _ as x -> add_forest forest x len (* function or balanced *) let balance r = match r with | Empty -> Empty | Leaf _ -> r | Concat _ -> let forest = Array.init max_height (fun _ -> {c = Empty; len = 0}) in balance_insert r (length r) forest; concat_forest forest let bal_if_needed l r = let r = make_concat l r in if height r < max_height then r else balance r let concat_str l = function | Empty | Concat _ -> assert false | Leaf rs as r -> let lenr = STRING.length rs in match l with | Empty -> r | Leaf ls -> let slen = lenr + STRING.length ls in if slen <= leaf_size then Leaf (str_append ls rs) else make_concat l r (* height = 1 *) | Concat (ll, cll, Leaf lrs, clr, h) -> let slen = clr + lenr in if clr + lenr <= leaf_size then Concat (ll, cll, Leaf (str_append lrs rs), slen, h) else bal_if_needed l r | Concat _ -> bal_if_needed l r let append_char c r = concat_str r (Leaf (STRING.make 1 c)) let concat l = function | Empty -> l | Leaf _ as r -> concat_str l r | Concat (Leaf rls, rlc, rr, rc, h) as r -> ( match l with | Empty -> r | Concat _ -> bal_if_needed l r | Leaf ls -> let slen = rlc + STRING.length ls in if slen <= leaf_size then Concat (Leaf (str_append ls rls), slen, rr, rc, h) else bal_if_needed l r ) | Concat _ as r -> ( match l with | Empty -> r | Leaf _ | Concat _ -> bal_if_needed l r ) let prepend_char c r = concat (Leaf (STRING.make 1 c)) r let rec get t i = match t with | Empty -> raise Out_of_bounds | Leaf s -> if i >= 0 && i < STRING.length s then STRING.unsafe_get s i else raise Out_of_bounds | Concat (l, cl, r, _cr, _) -> if i < cl then get l i else get r (i - cl) let rec set t i x = match t with | Empty -> raise Out_of_bounds | Leaf s -> if i >= 0 && i < STRING.length s then ( let s = STRING.copy s in STRING.unsafe_set s i x; Leaf s ) else raise Out_of_bounds | Concat (l, cl, r, _cr, _) -> if i < cl then concat (set l i x) r else concat l (set r (i - cl) x) let at = get let rec modify t i f = match t with | Empty -> raise Out_of_bounds | Leaf s -> if i >= 0 && i < STRING.length s then ( let s = STRING.copy s in STRING.unsafe_set s i (f (STRING.unsafe_get s i)); Leaf s ) else raise Out_of_bounds | Concat (l, cl, r, _cr, _) -> if i < cl then concat (modify l i f) r else concat l (modify r (i - cl) f) let of_string = function | [||] -> Empty | s -> let rec loop r s len i = if i < len then (* len - i > 0, thus Leaf "" can't happen *) loop (concat r (Leaf (STRING.sub s i (BatInt.min (len - i) leaf_size)))) s len (i + leaf_size) else r in loop Empty s (STRING.length s) 0 let rec make len c = let rec concatloop len i r = if i <= len then concatloop len (i * 2) (concat r r) else r in if len = 0 then Empty else if len <= leaf_size then Leaf (STRING.make len c) else let rope = concatloop len 2 (of_string (STRING.make 1 c)) in concat rope (make (len - length rope) c) (* overridden argument order below *) let rec sub start len = function | Empty -> if start <> 0 || len <> 0 then raise Out_of_bounds else Empty | Leaf s -> if len > 0 then (* Leaf "" cannot happen *) (try Leaf (STRING.sub s start len) with _ -> raise Out_of_bounds) else if len < 0 || start < 0 || start > STRING.length s then raise Out_of_bounds else Empty | Concat (l, cl, r, cr, _) -> if start < 0 || len < 0 || start + len > cl + cr then raise Out_of_bounds; let left = if start = 0 then if len >= cl then l else sub 0 len l else if start > cl then Empty else if start + len >= cl then sub start (cl - start) l else sub start len l in let right = if start <= cl then let upto = start + len in if upto = cl + cr then r else if upto < cl then Empty else sub 0 (upto - cl) r else sub (start - cl) len r in concat left right (* change argument order on Vect.sub *) let sub v s l = sub s l v let insert start rope r = concat (concat (sub r 0 start) rope) (sub r start (length r - start)) (*$T insert (of_list [0;1;2;3] |> insert 0 (singleton 10) |> to_list) = [10;0;1;2;3] (of_list [0;1;2;3] |> insert 1 (singleton 10) |> to_list) = [0;10;1;2;3] (of_list [0;1;2;3] |> insert 2 (singleton 10) |> to_list) = [0;1;10;2;3] (of_list [0;1;2;3] |> insert 3 (singleton 10) |> to_list) = [0;1;2;10;3] (of_list [0;1;2;3] |> insert 4 (singleton 10) |> to_list) = [0;1;2;3;10] try of_list [0;1;2;3] |> insert (-1) (singleton 10) |> to_list |> ignore; false; with _ -> true try of_list [0;1;2;3] |> insert 5 (singleton 10) |> to_list |> ignore; false; with _ -> true (of_list [] |> insert 0 (singleton 1) |> to_list) = [1] (of_list [0] |> insert 0 (singleton 1) |> to_list) = [1; 0] (of_list [0] |> insert 1 (singleton 1) |> to_list) = [0; 1] *) let remove start len r = concat (sub r 0 start) (sub r (start + len) (length r - start - len)) (*$Q remove (Q.pair (Q.pair Q.small_int Q.small_int) (Q.small_int)) \ (fun ((n1, n2), lr) -> \ let init len = of_list (BatList.init len (fun i -> i)) in \ let n, lu = min n1 n2, max n1 n2 in \ let u, r = init lu, init lr in \ equal (=) u (u |> insert n r |> remove n (length r))) *) let to_string r = let rec strings l = function | Empty -> l | Leaf s -> s :: l | Concat (left, _, right, _, _) -> strings (strings l right) left in string_of_string_list (strings [] r) let rec iter f = function | Empty -> () | Leaf s -> STRING.iter f s | Concat (l, _, r, _, _) -> iter f l; iter f r type 'a iter = E | C of 'a STRING.t * int * 'a t * 'a iter let rec cons_iter s t = match s with | Empty -> t | Leaf s -> C (s, 0, Empty, t) | Concat (l, _llen, r, _rlen, _h) -> cons_iter l (cons_iter r t) let rec rev_cons_iter s t = match s with | Empty -> t | Leaf s -> C (s, (STRING.length s - 1), Empty, t) | Concat (l, _, r, _, _) -> rev_cons_iter r (rev_cons_iter l t) let enum_next l () = match !l with | E -> raise BatEnum.No_more_elements | C (s, p, r, t) -> if p + 1 = STRING.length s then l := cons_iter r t else l := C (s, p + 1, r, t); STRING.unsafe_get s p let enum_backwards_next l () = match !l with | E -> raise BatEnum.No_more_elements | C (s, p, r, t) -> if p = 0 then l := rev_cons_iter r t else l := C (s, p - 1, r, t); STRING.unsafe_get s p let enum_count l () = let rec aux n = function | E -> n | C (s, p, m, t) -> aux (n + (STRING.length s - p) + length m) t in aux 0 !l let rev_enum_count l () = let rec aux n = function | E -> n | C (_s, p, m, t) -> aux (n + (p + 1) + length m) t in aux 0 !l let enum t = let rec make l = let l = ref l in let clone () = make !l in BatEnum.make ~next:(enum_next l) ~count:(enum_count l) ~clone in make (cons_iter t E) let backwards t = let rec make l = let l = ref l in let clone () = make !l in BatEnum.make ~next:(enum_backwards_next l) ~count:(rev_enum_count l) ~clone in make (rev_cons_iter t E) let of_enum e = BatEnum.fold (fun acc x -> append_char x acc) empty e let of_backwards e = BatEnum.fold (fun acc x -> prepend_char x acc) empty e let iteri f r = let rec aux f i = function | Empty -> () | Leaf s -> for j = 0 to STRING.length s - 1 do f (i + j) (STRING.unsafe_get s j) done | Concat (l, cl, r, _, _) -> aux f i l; aux f (i + cl) r in aux f 0 r let rec rangeiter f start len = function | Empty -> if start <> 0 || len <> 0 then raise Out_of_bounds | Leaf s -> let n = start + len in let lens = STRING.length s in if start >= 0 && len >= 0 && n <= lens then for i = start to n - 1 do f (STRING.unsafe_get s i) done else raise Out_of_bounds | Concat (l, cl, r, cr, _) -> if start < 0 || len < 0 || start + len > cl + cr then raise Out_of_bounds; if start < cl then begin let upto = start + len in if upto <= cl then rangeiter f start len l else begin rangeiter f start (cl - start) l; rangeiter f 0 (upto - cl) r end end else begin rangeiter f (start - cl) len r end let rec fold f a = function | Empty -> a | Leaf s -> let acc = ref a in for i = 0 to STRING.length s - 1 do acc := f !acc (STRING.unsafe_get s i) done; !acc | Concat (l, _, r, _, _) -> fold f (fold f a l) r let foldi f a v = let rec aux i a = function | Empty -> a | Leaf s -> let acc = ref a in for j = 0 to STRING.length s - 1 do acc := f (i+j) !acc (STRING.unsafe_get s j) done; !acc | Concat (l, cl, r, _, _) -> aux (i+cl) (aux i a l) r in aux 0 a v let fold_left = fold let fold_right (f:'a -> 'b -> 'b) (v:'a t) (acc:'b) : 'b = let rec aux (acc:'b) = function | Empty -> acc | Leaf s -> STRING.fold_right f s acc | Concat (l, _, r, _, _) -> aux (aux acc r) l in aux acc v let reduce f v = let acc = ref (get v 0) in rangeiter (fun e -> acc := f !acc e) 1 (length v - 1) v; !acc let of_array = of_string let to_array = to_string let append = append_char let prepend = prepend_char let rec map f = function | Empty -> Empty | Leaf a -> Leaf (BatArray.map f a) | Concat (l, cl, r, cr, h) -> let l = map f l in let r = map f r in Concat (l, cl, r, cr, h) let mapi f v = let off = ref 0 in map (fun x -> f (BatRef.post_incr off) x) v let rec exists f = function | Empty -> false | Leaf a -> BatArray.exists f a | Concat (l, _, r, _, _) -> exists f l || exists f r (*$T exists exists (fun x -> x = 2) empty = false exists (fun x -> x = 2) (singleton 2) = true exists (fun x -> x = 2) (singleton 3) = false exists (fun x -> x = 2) (of_array [|1; 3|]) = false exists (fun x -> x = 2) (of_array [|2; 3|]) = true exists (fun x -> x = 2) (concat (singleton 1) (singleton 3)) = false exists (fun x -> x = 2) (concat (singleton 1) (of_array [|2|])) = true exists (fun x -> x = 2) (concat (singleton 2) (singleton 3)) = true *) (*$Q exists (Q.list Q.small_int) (fun li -> let p i = (i mod 4 = 0) in List.exists p li = exists p (of_list li)) *) let rec for_all f = function | Empty -> true | Leaf a -> BatArray.for_all f a | Concat (l, _, r, _, _) -> for_all f l && for_all f r (*$T for_all for_all (fun x -> x = 2) empty = true for_all (fun x -> x = 2) (singleton 2) = true for_all (fun x -> x = 2) (singleton 3) = false for_all (fun x -> x = 2) (of_array [|2; 3|]) = false for_all (fun x -> x = 2) (of_array [|2; 2|]) = true for_all (fun x -> x = 2) (concat (singleton 1) (singleton 2)) = false for_all (fun x -> x = 2) (concat (singleton 2) (of_array [|2|])) = true for_all (fun x -> x = 2) (concat (singleton 2) (singleton 3)) = false *) (*$Q for_all (Q.list Q.small_int) (fun li -> let p i = (i mod 4 > 0) in List.for_all p li = for_all p (of_list li)) *) let rec find_opt f = function | Empty -> None | Leaf a -> BatArray.Exceptionless.find f a | Concat (l, _, r, _, _) -> begin match find_opt f l with | Some _ as result -> result | None -> find_opt f r end (*$T find_opt [0;1;2;3] |> of_list |> find_opt ((=) 2) = Some 2 [0;1;2;3] |> of_list |> find_opt ((=) 4) = None [] |> of_list |> find_opt ((=) 2) = None concat (of_list [0; 1]) (of_list ([2; 3])) |> find_opt (fun n -> n > 0) = Some 1 *) let find f v = match find_opt f v with | None -> raise Not_found | Some x -> x (*$T find [0;1;2;3] |> of_list |> find ((=) 2) = 2 try [0;1;2;3] |> of_list |> find ((=) 4) |> ignore; false with Not_found -> true try [] |> of_list |> find ((=) 2) |> ignore; false with Not_found -> true concat (of_list [0; 1]) (of_list ([2; 3])) |> find (fun n -> n > 0) = 1 *) let findi f v = let off = ref (-1) in ignore (find (fun x -> let result = f x in incr off; result) v); !off let partition p v = fold_left (fun (yes, no) x -> if p x then (append x yes, no) else (yes, append x no)) (empty, empty) v let find_all p v = fold_left (fun acc x -> if p x then append x acc else acc) empty v let mem m v = try let _ = find ( ( = ) m ) v in true with Not_found -> false let memq m v = try let _ = find ( ( == ) m ) v in true with Not_found -> false let first v = get v 0 let last v = get v (length v - 1) let shift v = first v, sub v 1 (length v - 1) let pop v = last v, sub v 0 (length v - 1) let to_list r = let rec aux acc = function | Empty -> acc | Leaf a -> Array.fold_right (fun x l -> x :: l) a acc | Concat (l, _, r, _, _) -> aux (aux acc r) l in aux [] r let filter = find_all let filter_map f = fold (fun acc x -> match f x with | None -> acc | Some v -> append v acc ) Empty let destructive_set v i x = let rec aux i = function | Empty -> raise Out_of_bounds | Leaf s -> if i >= 0 && i < STRING.length s then STRING.unsafe_set s i x else raise Out_of_bounds | Concat (l, cl, r, _cr, _) -> if i < cl then aux i l else aux (i - cl) r in aux i v let of_list l = of_array (Array.of_list l) let init n f = if n < 0 || n > max_length then invalid_arg "Vect.init"; (* Create as many arrays as we need to store all the data *) let rec aux off acc = if off >= n then acc else let len = min leaf_size (n - off) in let arr = Array.init len (fun i -> f ( off + i ) ) in aux (off + len) (arr::acc) in let base = aux 0 [] in (* And then concatenate them *) List.fold_left (fun (acc:'a t) (array:'a array) -> concat (of_array array) acc) (empty:'a t) (base:'a array list) (*$T init init 1000 (fun x -> x * x) |> to_array = Array.init 1000 (fun x -> x * x) *) let print ?(first="[|") ?(last="|]") ?(sep="; ") print_a out t = BatEnum.print ~first ~last ~sep print_a out (enum t) let compare cmp_val v1 v2 = BatEnum.compare cmp_val (enum v1) (enum v2) let equal eq_val v1 v2 = BatEnum.equal eq_val (enum v1) (enum v2) let ord ord_val v1 v2 = let cmp_val = BatOrd.comp ord_val in BatOrd.ord0 (BatEnum.compare cmp_val (enum v1) (enum v2)) module Labels = struct let init n ~f = init n f let get v ~n = get v n let at v ~n = at v n let set v ~n ~elem = set v n elem let modify v ~n ~f = modify v n f let sub v ~m ~n = sub v m n let insert ~n ~sub = insert n sub let remove ~m ~n = remove m n let iter ~f = iter f let iteri ~f = iteri f let map ~f = map f let mapi ~f = mapi f let for_all ~f = for_all f let exists ~f = exists f let find ~f = find f let mem ~elem = mem elem let memq ~elem = memq elem let findi ~f = findi f let filter ~f = filter f let filter_map ~f = filter_map f let find_all ~f = find_all f let partition ~f = partition f let destructive_set v ~n ~elem = destructive_set v n elem let rangeiter ~f ~m ~n = rangeiter f m n let fold_left ~f ~init = fold_left f init let fold ~f ~init = fold f init let reduce ~f = reduce f let fold_right ~f v ~init = fold_right f v init let foldi ~f ~init = foldi f init end (* Functorial interface *) module type RANDOMACCESS = sig type 'a t val empty : 'a t 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 append : 'a t -> 'a t -> 'a t val concat : 'a t list -> 'a t val length : 'a t -> int val copy : 'a t -> 'a t val sub : 'a t -> int -> int -> 'a t val make : int -> 'a -> 'a t val iter : ('a -> unit) -> 'a t -> unit val map : ('a -> 'b) -> 'a t -> 'b t val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b val enum : 'a t -> 'a BatEnum.t val backwards : 'a t -> 'a BatEnum.t val of_enum : 'a BatEnum.t -> 'a t val of_backwards : 'a BatEnum.t -> 'a t end module Make(RANDOMACCESS : RANDOMACCESS) (PARAM : sig val max_height : int val leaf_size : int end)= struct module STRING = RANDOMACCESS (*$inject module Test_functor = struct module STRING = struct include BatArray let empty = [||] end module PARAM = struct let max_height = 256 let leaf_size = 256 end module Instance = Make(STRING)(PARAM) open Instance *) type 'a t = | Empty | Concat of 'a t * int * 'a t * int * int | Leaf of 'a STRING.t let max_height = PARAM.max_height let leaf_size = PARAM.leaf_size let min_len = let fib_tbl = Array.make max_height 0 in let rec fib n = match fib_tbl.(n) with | 0 -> let last = fib (n - 1) and prev = fib (n - 2) in let r = last + prev in let r = if r > last then r else last in (* check overflow *) fib_tbl.(n) <- r; r | n -> n in fib_tbl.(0) <- leaf_size + 1; fib_tbl.(1) <- 3 * leaf_size / 2 + 1; Array.init max_height (fun i -> if i = 0 then 1 else fib (i - 1)) let max_length = min_len.(Array.length min_len - 1) let invariants t = let rec inv_height = function | Empty | Leaf _ -> 0 | Concat (l, _, r, _, h) -> assert (h = 1 + max (inv_height l) (inv_height r)); h in let rec inv_length = function | Empty -> 0 | Leaf a -> STRING.length a | Concat (l, cl, r, cr, _) -> assert (inv_length l = cl); assert (inv_length r = cr); cl + cr in let rec other_inv depth = function | Empty -> assert (depth = 0) | Leaf a -> assert (STRING.length a > 0) | Concat (l, _, r, _, _) -> other_inv (depth + 1) l; other_inv (depth + 1) r in ignore (inv_height t); assert (inv_length t < max_length); other_inv 0 t type 'a forest_element = { mutable c : 'a t; mutable len : int } let str_append = STRING.append let string_of_string_list = STRING.concat let singleton x = Leaf (STRING.make 1 x) exception Out_of_bounds let empty = Empty (* by construction, there cannot be Empty or Leaf "" leaves *) let is_empty = function | Empty -> true | Leaf _ | Concat _ -> false let height = function | Empty | Leaf _ -> 0 | Concat (_, _, _, _, h) -> h let length = function | Empty -> 0 | Leaf s -> STRING.length s | Concat (_, cl, _, cr, _) -> cl + cr let make_concat l r = let hl = height l and hr = height r in let cl = length l and cr = length r in Concat (l, cl, r, cr, if hl >= hr then hl + 1 else hr + 1) let concat_fast l r = match l with | Empty -> r | Leaf _ | Concat _ -> match r with | Empty -> l | Leaf _ | Concat _ -> make_concat l r (* based on Hans-J. Boehm's *) let add_forest forest rope len = let i = ref 0 in let sum = ref empty in while len > min_len.(!i+1) do if forest.(!i).c <> Empty then begin sum := concat_fast forest.(!i).c !sum; forest.(!i).c <- Empty end; incr i done; sum := concat_fast !sum rope; let sum_len = ref (length !sum) in while !sum_len >= min_len.(!i) do if forest.(!i).c <> Empty then begin sum := concat_fast forest.(!i).c !sum; sum_len := !sum_len + forest.(!i).len; forest.(!i).c <- Empty; end; incr i done; decr i; forest.(!i).c <- !sum; forest.(!i).len <- !sum_len let concat_forest forest = Array.fold_left (fun s x -> concat_fast x.c s) Empty forest let rec balance_insert rope len forest = match rope with | Empty -> () | Leaf _ -> add_forest forest rope len | Concat (l, cl, r, cr, h) when h >= max_height || len < min_len.(h) -> balance_insert l cl forest; balance_insert r cr forest | Concat _ as x -> add_forest forest x len (* function or balanced *) let balance r = match r with | Empty -> Empty | Leaf _ -> r | Concat _ -> let forest = Array.init max_height (fun _ -> {c = Empty; len = 0}) in balance_insert r (length r) forest; concat_forest forest let bal_if_needed l r = let r = make_concat l r in if height r < max_height then r else balance r let concat_str l = function | Empty | Concat _ -> assert false | Leaf rs as r -> let lenr = STRING.length rs in match l with | Empty -> r | Leaf ls -> let slen = lenr + STRING.length ls in if slen <= leaf_size then Leaf (str_append ls rs) else make_concat l r (* height = 1 *) | Concat (ll, cll, Leaf lrs, clr, h) -> let slen = clr + lenr in if clr + lenr <= leaf_size then Concat (ll, cll, Leaf (str_append lrs rs), slen, h) else bal_if_needed l r | Concat _ -> bal_if_needed l r let append_char c r = concat_str r (Leaf (STRING.make 1 c)) let concat l = function | Empty -> l | Leaf _ as r -> concat_str l r | Concat (Leaf rls, rlc, rr, rc, h) as r -> ( match l with | Empty -> r | Concat _ -> bal_if_needed l r | Leaf ls -> let slen = rlc + STRING.length ls in if slen <= leaf_size then Concat (Leaf (str_append ls rls), slen, rr, rc, h) else bal_if_needed l r ) | Concat _ as r -> ( match l with | Empty -> r | Leaf _ | Concat _ -> bal_if_needed l r ) let prepend_char c r = concat (Leaf (STRING.make 1 c)) r let rec get t i = match t with | Empty -> raise Out_of_bounds | Leaf s -> if i >= 0 && i < STRING.length s then STRING.unsafe_get s i else raise Out_of_bounds | Concat (l, cl, r, _cr, _) -> if i < cl then get l i else get r (i - cl) let rec set t i x = match t with | Empty -> raise Out_of_bounds | Leaf s -> if i >= 0 && i < STRING.length s then ( let s = STRING.copy s in STRING.unsafe_set s i x; Leaf s ) else raise Out_of_bounds | Concat (l, cl, r, _cr, _) -> if i < cl then concat (set l i x) r else concat l (set r (i - cl) x) let at = get let rec modify t i f = match t with | Empty -> raise Out_of_bounds | Leaf s -> if i >= 0 && i < STRING.length s then ( let s = STRING.copy s in STRING.unsafe_set s i (f (STRING.unsafe_get s i)); Leaf s ) else raise Out_of_bounds | Concat (l, cl, r, _cr, _) -> if i < cl then concat (modify l i f) r else concat l (modify r (i - cl) f) let of_string s = if STRING.length s = 0 then Empty else let rec loop r s len i = if i < len then (* len - i > 0, thus Leaf "" can't happen *) loop (concat r (Leaf (STRING.sub s i (BatInt.min (len - i) leaf_size)))) s len (i + leaf_size) else r in loop Empty s (STRING.length s) 0 let rec make len c = let rec concatloop len i r = if i <= len then concatloop len (i * 2) (concat r r) else r in if len = 0 then Empty else if len <= leaf_size then Leaf (STRING.make len c) else let rope = concatloop len 2 (of_string (STRING.make 1 c)) in concat rope (make (len - length rope) c) (* overridden argument order below *) let rec sub start len = function | Empty -> if start <> 0 || len <> 0 then raise Out_of_bounds else Empty | Leaf s -> if len > 0 then (* Leaf "" cannot happen *) (try Leaf (STRING.sub s start len) with _ -> raise Out_of_bounds) else if len < 0 || start < 0 || start > STRING.length s then raise Out_of_bounds else Empty | Concat (l, cl, r, cr, _) -> if start < 0 || len < 0 || start + len > cl + cr then raise Out_of_bounds; let left = if start = 0 then if len >= cl then l else sub 0 len l else if start > cl then Empty else if start + len >= cl then sub start (cl - start) l else sub start len l in let right = if start <= cl then let upto = start + len in if upto = cl + cr then r else if upto < cl then Empty else sub 0 (upto - cl) r else sub (start - cl) len r in concat left right (* change argument order on Vect.sub *) let sub v s l = sub s l v let insert start rope r = concat (concat (sub r 0 start) rope) (sub r start (length r - start)) let remove start len r = concat (sub r 0 start) (sub r (start + len) (length r - start - len)) let to_string r = let rec strings l = function | Empty -> l | Leaf s -> s :: l | Concat (left, _, right, _, _) -> strings (strings l right) left in string_of_string_list (strings [] r) let rec iter f = function | Empty -> () | Leaf s -> STRING.iter f s | Concat (l, _, r, _, _) -> iter f l; iter f r type 'a iter = E | C of 'a STRING.t * int * 'a t * 'a iter let rec cons_iter s t = match s with | Empty -> t | Leaf s -> C (s, 0, Empty, t) | Concat (l, _llen, r, _rlen, _h) -> cons_iter l (cons_iter r t) let rec rev_cons_iter s t = match s with | Empty -> t | Leaf s -> C (s, (STRING.length s - 1), Empty, t) | Concat (l, _, r, _, _) -> rev_cons_iter r (rev_cons_iter l t) let enum_next l () = match !l with | E -> raise BatEnum.No_more_elements | C (s, p, r, t) -> if p + 1 = STRING.length s then l := cons_iter r t else l := C (s, p + 1, r, t); STRING.unsafe_get s p let enum_backwards_next l () = match !l with | E -> raise BatEnum.No_more_elements | C (s, p, r, t) -> if p = 0 then l := rev_cons_iter r t else l := C (s, p - 1, r, t); STRING.unsafe_get s p let enum_count l () = let rec aux n = function | E -> n | C (s, p, m, t) -> aux (n + (STRING.length s - p) + length m) t in aux 0 !l let rev_enum_count l () = let rec aux n = function | E -> n | C (_s, p, m, t) -> aux (n + (p + 1) + length m) t in aux 0 !l let enum t = let rec make l = let l = ref l in let clone () = make !l in BatEnum.make ~next:(enum_next l) ~count:(enum_count l) ~clone in make (cons_iter t E) let backwards t = let rec make l = let l = ref l in let clone () = make !l in BatEnum.make ~next:(enum_backwards_next l) ~count:(rev_enum_count l) ~clone in make (rev_cons_iter t E) let of_enum e = BatEnum.fold (fun acc x -> append_char x acc) empty e let of_backwards e = BatEnum.fold (fun acc x -> prepend_char x acc) empty e let iteri f r = let rec aux f i = function | Empty -> () | Leaf s -> for j = 0 to STRING.length s - 1 do f (i + j) (STRING.unsafe_get s j) done | Concat (l, cl, r, _, _) -> aux f i l; aux f (i + cl) r in aux f 0 r let rec rangeiter f start len = function | Empty -> if start <> 0 || len <> 0 then raise Out_of_bounds | Leaf s -> let n = start + len in let lens = STRING.length s in if start >= 0 && len >= 0 && n <= lens then for i = start to n - 1 do f (STRING.unsafe_get s i) done else raise Out_of_bounds | Concat (l, cl, r, cr, _) -> if start < 0 || len < 0 || start + len > cl + cr then raise Out_of_bounds; if start < cl then begin let upto = start + len in if upto <= cl then rangeiter f start len l else begin rangeiter f start (cl - start) l; rangeiter f 0 (upto - cl) r end end else begin rangeiter f (start - cl) len r end let rec fold f a = function | Empty -> a | Leaf s -> let acc = ref a in for i = 0 to STRING.length s - 1 do acc := f !acc (STRING.unsafe_get s i) done; !acc | Concat (l, _, r, _, _) -> fold f (fold f a l) r let foldi f a v = let rec aux i a = function | Empty -> a | Leaf s -> let acc = ref a in for j = 0 to STRING.length s - 1 do acc := f (i+j) !acc (STRING.unsafe_get s j) done; !acc | Concat (l, cl, r, _, _) -> aux (i+cl) (aux i a l) r in aux 0 a v let fold_left = fold let fold_right (f:'a -> 'b -> 'b) (v:'a t) (acc:'b) : 'b = let rec aux (acc:'b) = function | Empty -> acc | Leaf s -> STRING.fold_right f s acc | Concat (l, _, r, _, _) -> aux (aux acc r) l in aux acc v let reduce f v = let acc = ref (get v 0) in rangeiter (fun e -> acc := f !acc e) 1 (length v - 1) v; !acc let of_array a = of_string (STRING.of_enum (BatArray.enum a)) let to_array t = BatArray.of_enum (enum t) let of_container = of_string let to_container = to_string let append = append_char let prepend = prepend_char let rec map f = function | Empty -> Empty | Leaf a -> Leaf (STRING.map f a) | Concat (l, cl, r, cr, h) -> let l = map f l in let r = map f r in Concat (l, cl, r, cr, h) let mapi f v = let off = ref 0 in map (fun x -> f (BatRef.post_incr off) x) v let rec exists f = function | Empty -> false | Leaf a -> let rec aux f a len i = (i < len) && (f (STRING.unsafe_get a i) || aux f a len (i + 1)) in aux f a (STRING.length a) 0 | Concat (l, _, r, _, _) -> exists f l || exists f r (*$T exists exists (fun x -> true) empty = false exists (fun x -> false) (of_array [|0;1;2|]) = false exists (fun x -> x mod 2 <> 0) (of_array [|0;1;2|]) = true exists (fun x -> x mod 2 <> 0) (of_array [|0;2|]) = false *) let rec for_all f = function | Empty -> true | Leaf a -> let rec aux f a len i = (i >= len) || (f (STRING.unsafe_get a i) && aux f a len (i + 1)) in aux f a (STRING.length a) 0 | Concat (l, _, r, _, _) -> for_all f l && for_all f r (*$T for_all for_all (fun x -> true) empty = true for_all (fun x -> true) (of_array [|0;1;2|]) = true for_all (fun x -> x mod 2 = 0) (of_array [|0;1;2|]) = false for_all (fun x -> x mod 2 = 0) (of_array [|0;2|]) = true *) let rec find_opt f = function | Empty -> None | Leaf a -> let rec aux f a len i = if i >= len then None else begin let x = STRING.unsafe_get a i in if f x then Some x else aux f a len (i + 1) end in aux f a (STRING.length a) 0 | Concat (l, _, r, _, _) -> begin match find_opt f l with | Some _ as res -> res | None -> find_opt f r end (*$T find_opt find_opt (fun x -> true) empty = None find_opt (fun x -> true) (of_array [|0;1;2|]) = Some 0 find_opt (fun x -> x mod 2 <> 0) (of_array [|0;1;2|]) = Some 1 find_opt (fun x -> x mod 2 <> 0) (of_array [|0;2|]) = None *) let find f v = match find_opt f v with | None -> raise Not_found | Some a -> a (*$T find try ignore (find (fun x -> true) empty); false with Not_found -> true find (fun x -> true) (of_array [|0;1;2|]) = 0 find (fun x -> x mod 2 <> 0) (of_array [|0;1;2|]) = 1 try ignore (find (fun x -> x mod 2 <> 0) (of_array [|0;2|])); false with Not_found -> true *) let findi f v = let off = ref (-1) in ignore (find (fun x -> let result = f x in incr off; result) v); !off let partition p v = fold_left (fun (yes, no) x -> if p x then (append x yes, no) else (yes, append x no)) (empty, empty) v let find_all p v = fold_left (fun acc x -> if p x then append x acc else acc) empty v let mem m v = try let _ = find ( ( = ) m ) v in true with Not_found -> false let memq m v = try let _ = find ( ( == ) m ) v in true with Not_found -> false let first v = get v 0 let last v = get v (length v - 1) let shift v = first v, sub v 1 (length v - 1) let pop v = last v, sub v 0 (length v - 1) let to_list r = let rec aux acc = function | Empty -> acc | Leaf a -> STRING.fold_right (fun x l -> x :: l) a acc | Concat (l, _, r, _, _) -> aux (aux acc r) l in aux [] r let filter = find_all let filter_map f = fold (fun acc x -> match f x with | None -> acc | Some v -> append v acc ) Empty let destructive_set v i x = let rec aux i = function | Empty -> raise Out_of_bounds | Leaf s -> if i >= 0 && i < STRING.length s then STRING.unsafe_set s i x else raise Out_of_bounds | Concat (l, cl, r, _cr, _) -> if i < cl then aux i l else aux (i - cl) r in aux i v let of_list l = of_array (Array.of_list l) let init n f = if n < 0 || n > max_length then invalid_arg "Vect.init"; (* Create as many arrays as we need to store all the data *) let rec aux off acc = if off >= n then acc else let len = min leaf_size (n - off) in let arr = Array.init len (fun i -> f ( off + i ) ) in aux (off + len) (arr::acc) in let base = aux 0 [] in (* And then concatenate them *) List.fold_left (fun (acc:'a t) (array:'a array) -> concat (of_array array) acc) (empty:'a t) (base:'a array list) let print ?(first="[|") ?(last="|]") ?(sep="; ") print_a out t = BatEnum.print ~first ~last ~sep print_a out (enum t) module Labels = struct let init n ~f = init n f let get v ~n = get v n let at v ~n = at v n let set v ~n ~elem = set v n elem let modify v ~n ~f = modify v n f let sub v ~m ~n = sub v m n let insert ~n ~sub = insert n sub let remove ~m ~n = remove m n let iter ~f = iter f let iteri ~f = iteri f let map ~f = map f let mapi ~f = mapi f let for_all ~f = for_all f let exists ~f = exists f let find ~f = find f let mem ~elem = mem elem let memq ~elem = memq elem let findi ~f = findi f let filter ~f = filter f let filter_map ~f = filter_map f let find_all ~f = find_all f let partition ~f = partition f let destructive_set v ~n ~elem = destructive_set v n elem let rangeiter ~f ~m ~n = rangeiter f m n let fold_left ~f ~init = fold_left f init let fold ~f ~init = fold f init let reduce ~f = reduce f let fold_right ~f v ~init = fold_right f v init let foldi ~f ~init = foldi f init end (*$inject end *) end batteries-included-3.4.0/src/batVect.mli000066400000000000000000000675111415601150500201570ustar00rootroot00000000000000(* * Vect - Extensible arrays based on ropes * Copyright (C) 2007 Mauricio Fernandez * 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (* Vect: extensible arrays based on ropes as described in Boehm, H., Atkinson, R., and Plass, M. 1995. Ropes: an alternative to strings. Softw. Pract. Exper. 25, 12 (Dec. 1995), 1315-1330. Motivated by Luca de Alfaro's extensible array implementation Vec. *) (** Extensible vectors with constant-time append/prepend. This module implements extensible arrays which work very much like ropes as described in {b Boehm, H., Atkinson, R., and Plass, M.} 1995. {e Ropes: an alternative to strings.} Softw. Pract. Exper. 25, 12 (Dec. 1995), 1315-1330. These vectors have some interesting properties: - lower space overhead than other structures based on balanced trees such as Vec. The overhead can be adjusted, allowing to make get faster at the expense of set and viceversa. - appending or prepending a small vector to an arbitrarily large one in amortized constant time - concat, substring, insert, remove operations in amortized logarithmic time - access to and modification of vectors in logarithmic time {8 Functional nature and persistence} All operations but [destructive_set] (provided for efficient ephemeral usage) are non-destructive: the original vect is never modified. When a new vect is returned as the result of an operation, it will share as much data as possible with its "parent". For instance, if a vect of length [n] undergoes [m] operations (assume [n >> m]) like set, append or prepend, the modified vector will only require [O(m)] space in addition to that taken by the original vect. However, Vect is an amortized data structure, and its use in a persistent setting can easily degrade its amortized time bounds. It is thus mainly intended to be used ephemerally. In some cases, it is possible to use Vect persistently with the same amortized bounds by explicitly rebalancing vects to be reused using [balance]. Special care must be taken to avoid calling [balance] too frequently; in the limit, calling [balance] after each modification would defeat the purpose of amortization. This module is not thread-safe. @author Mauricio Fernandez *) type 'a t (** The type of a polymorphic vect. *) exception Out_of_bounds (** Raised when an operation violates the bounds of the vect. *) val max_length : int (** Maximum length of the vect. *) (** {6 Creation and conversions} *) val empty : 'a t (** The empty vect. *) val singleton : 'a -> 'a t (** Returns a vect of length 1 holding only the given element.*) val of_array : 'a array -> 'a t (** [of_array s] returns a vect corresponding to the array [s]. Operates in [O(n)] time. *) val to_array : 'a t -> 'a array (** [to_array r] returns an array corresponding to the vect [r]. *) val to_list : 'a t -> 'a list (** Returns a list with the elements contained in the vect. *) val of_list : 'a list -> 'a t val make : int -> 'a -> 'a t (** [make i c] returns a vect of length [i] whose elements are all equal to [c]; it is similar to Array.make *) val init : int -> (int -> 'a) -> 'a t (** [init n f] returns a fresh vect of length [n], with element number [i] initialized to the result of [f i]. In other terms, [init n f] tabulates the results of [f] applied to the integers [0] to [n-1]. @raise Invalid_argument if [n < 0] or [n > max_length].*) (** {6 Properties } *) val is_empty : 'a t -> bool (** Returns whether the vect is empty or not. *) val height : 'a t -> int (** Returns the height (depth) of the vect. *) val length : 'a t -> int (** Returns the length of the vect ([O(1)]). *) (** {6 Operations } *) val balance : 'a t -> 'a t (** [balance r] returns a balanced copy of the [r] vect. Note that vects are automatically rebalanced when their height exceeds a given threshold, but [balance] allows to invoke that operation explicitly. *) val concat : 'a t -> 'a t -> 'a t (** [concat r u] concatenates the [r] and [u] vects. In general, it operates in [O(log(min n1 n2))] amortized time. Small vects are treated specially and can be appended/prepended in amortized [O(1)] time. *) val append : 'a -> 'a t -> 'a t (** [append c r] returns a new vect with the [c] element at the end in amortized [O(1)] time. *) val prepend : 'a -> 'a t -> 'a t (** [prepend c r] returns a new vect with the [c] character at the beginning in amortized [O(1)] time. *) val get : 'a t -> int -> 'a (** [get v n] returns the (n+1)th element from the vect [v]; i.e. [get v 0] returns the first element. Operates in worst-case [O(log size)] time. @raise Out_of_bounds if a character out of bounds is requested. *) val at : 'a t -> int -> 'a (** as [get] *) val set : 'a t -> int -> 'a -> 'a t (** [set v n c] returns a copy of the [v] vect where the (n+1)th element (see also [get]) has been set to [c]. Operates in worst-case [O(log size)] time. *) val modify : 'a t -> int -> ('a -> 'a) -> 'a t (** [modify v n f] is equivalent to [set v n (f (get v n))], but more efficient. Operates in worst-case [O(log size)] time. *) val destructive_set : 'a t -> int -> 'a -> unit (** [destructive_set v n c] sets the element of index [n] in the [v] vect to [c]. {b This operation is destructive}, and will also affect vects sharing the modified leaf with [v]. Use with caution. *) val sub : 'a t -> int -> int -> 'a t (** [sub m n r] returns a sub-vect of [r] containing all the elements whose indexes range from [m] to [m + n - 1] (included). @raise Out_of_bounds in the same cases as Array.sub. Operates in worst-case [O(log size)] time. *) val insert : int -> 'a t -> 'a t -> 'a t (** [insert n r u] returns a copy of the [u] vect where [r] has been inserted between the elements with index [n - 1] and [n] in the original vect; after insertion, the first element of [r] (if any) is at index [n]. The length of the new vect is [length u + length r]. Operates in amortized [O(log(size r) + log(size u))] time. *) val remove : int -> int -> 'a t -> 'a t (** [remove m n r] returns the vect resulting from deleting the elements with indexes ranging from [m] to [m + n - 1] (included) from the original vect [r]. The length of the new vect is [length r - n]. Operates in amortized [O(log(size r))] time. *) (** {6 Conversion}*) val enum : 'a t -> 'a BatEnum.t (** Returns an enumeration of the elements of the vector. Behavior of the enumeration is undefined if the contents of the vector changes afterwards.*) val of_enum : 'a BatEnum.t -> 'a t (** Build a vector from an enumeration.*) val backwards : 'a t -> 'a BatEnum.t (** Returns an enumeration of the elements of a vector, from last to first. Behavior of the enumeration is undefined if the contents of the vector changes afterwards.*) val of_backwards : 'a BatEnum.t -> 'a t (** Build a vector from an enumeration, from last to first.*) (** {6 Iteration and higher-order functions } *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f r] applies [f] to all the elements in the [r] vect, in order. *) val iteri : (int -> 'a -> unit) -> 'a t -> unit (** Operates like iter, but also passes the index of the character to the given function. *) val rangeiter : ('a -> unit) -> int -> int -> 'a t -> unit (** [rangeiter f m n r] applies [f] to all the elements whose indices [k] satisfy [m] <= [k] < [m + n]. It is thus equivalent to [iter f (sub m n r)], but does not create an intermediary vect. [rangeiter] operates in worst-case [O(n + log m)] time, which improves on the [O(n log m)] bound from an explicit loop using [get]. @raise Out_of_bounds in the same cases as [sub]. *) val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b (** [fold_left f a r] computes [ f (... (f (f a r0) r1)...) rN-1 ] where [rn = Vect.get n r ] and [N = length r]. *) val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b (** An alias for {!fold_left} *) val reduce : ('a -> 'a -> 'a) -> 'a t -> 'a (** as {!fold_left}, but no initial value - just applies reducing function to elements from left to right. *) val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** [fold_right f r a] computes [ f (r0 ... (f rN-2 (f rN-1 a)) ...)) ] where [rn = Vect.get n r ] and [N = length r]. *) val foldi : (int -> 'b -> 'a -> 'b) -> 'b -> 'a t -> 'b (** As {!fold}, but with the position of each value passed to the folding function *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f v] returns a vect isomorphic to [v] where each element of index [i] equals [f (get v i)]. Therefore, the height of the returned vect is the same as that of the original one. Operates in [O(n)] time. *) val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t (** Same as {!map}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) (* NOT PROVIDED? val id_map : ('a -> 'a) -> 'a t -> 'a t (** [id_map f v] returns a vect isomorphic to [v] where each element of index [i] equals [f (get v i)]. It is very similar to [map], but tries to share as much data as possible with the original vect; for example, [id_map (fun x -> x) v == v]. This can lead to significative space savings if [f] leaves many values unmodified. For each element, the new value [f x] and the old one [x] are compared with [<>]. Operates in [O(n)] time. *) *) (**{6 Predicates}*) val for_all : ('a -> bool) -> 'a t -> bool (** [for_all p [a0; a1; ...; an]] checks if all elements of the vect satisfy the predicate [p]. That is, it returns [ (p a0) && (p a1) && ... && (p an)]. *) val exists : ('a -> bool) -> 'a t -> bool (** [exists p [a0; a1; ...; an]] checks if at least one element of the vect satisfies the predicate [p]. That is, it returns [ (p a0) || (p a1) || ... || (p an)]. *) val find : ('a -> bool) -> 'a t -> 'a (** [find p v] returns the first element of vect [v] that satisfies the predicate [p]. @raise Not_found if there is no value that satisfies [p] in the vect [v]. *) val find_opt : ('a -> bool) -> 'a t -> 'a option (** [find_opt p v] returns [Some a], where [a] is the first element of vect [v] that satisfies the predicate [p], or [None] if no such element exists. @since 2.7.0 *) val mem : 'a -> 'a t -> bool (** [mem a v] is true if and only if [a] is equal to an element of [v]. *) val memq : 'a -> 'a t -> bool (** Same as {!Vect.mem} but uses physical equality instead of structural equality to compare vect elements. *) val findi : ('a -> bool) -> 'a t -> int (** [findi p v] returns the index of the first element of vect [v] that satisfies the predicate [p]. @raise Not_found if there is no value that satisfies [p] in the vect [v]. *) val filter : ('a -> bool) -> 'a t -> 'a t (** [filter f v] returns a vect with the elements [a] from [v] such that [f a] returns [true]. Operates in [O(n)] time. *) val filter_map : ('a -> 'b option) -> 'a t -> 'b t (** [filter_map f v] returns a vect consisting of all elements [b] such that [f a] returns [Some b] , where [a] is an element of [v]. *) val find_all : ('a -> bool) -> 'a t -> 'a t (** [find_all] is another name for {!Vect.filter}. *) val partition : ('a -> bool) -> 'a t -> 'a t * 'a t (** [partition p v] returns a pair of vects [(v1, v2)], where [v1] is the vect of all the elements of [v] that satisfy the predicate [p], and [v2] is the vect of all the elements of [v] that do not satisfy [p]. The order of the elements in the input vect is preserved. *) (** {6 Convenience Functions} *) val first : 'a t -> 'a val last : 'a t -> 'a (** These return the first and last values in the vector *) val shift : 'a t -> 'a * 'a t (** Return the first element of a vector and its last [n-1] elements. *) val pop : 'a t -> 'a * 'a t (** Return the last element of a vector and its first [n-1] elements. *) (** {6 Boilerplate code}*) val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> 'b t -> unit val compare : 'a BatOrd.comp -> 'a t BatOrd.comp val equal : 'a BatOrd.eq -> 'a t BatOrd.eq val ord : 'a BatOrd.ord -> 'a t BatOrd.ord (**/**) val invariants : _ t -> unit (**/**) (** {6 Override modules}*) (** Operations on {!BatVect} with labels. This module overrides a number of functions of {!BatVect} by functions in which some arguments require labels. These labels are there to improve readability and safety and to let you change the order of arguments to functions. In every case, the behavior of the function is identical to that of the corresponding function of {!BatVect}. *) module Labels : sig val init : int -> f:(int -> 'a) -> 'a t val get : 'a t -> n:int -> 'a val at : 'a t -> n:int -> 'a val set : 'a t -> n:int -> elem:'a -> 'a t val modify : 'a t -> n:int -> f:('a -> 'a) -> 'a t val destructive_set : 'a t -> n:int -> elem:'a -> unit val sub : 'a t -> m:int -> n:int -> 'a t val insert : n:int -> sub:'a t -> 'a t -> 'a t val remove : m:int -> n:int -> 'a t -> 'a t val iter : f:('a -> unit) -> 'a t -> unit val iteri : f:(int -> 'a -> unit) -> 'a t -> unit val rangeiter : f:('a -> unit) -> m:int -> n:int -> 'a t -> unit val fold_left : f:('b -> 'a -> 'b) -> init:'b -> 'a t -> 'b val fold : f:('b -> 'a -> 'b) -> init:'b -> 'a t -> 'b val reduce : f:('a -> 'a -> 'a) -> 'a t -> 'a val fold_right : f:('a -> 'b -> 'b) -> 'a t -> init:'b -> 'b val foldi : f:(int -> 'b -> 'a -> 'b) -> init:'b -> 'a t -> 'b val map : f:('a -> 'b) -> 'a t -> 'b t val mapi : f:(int -> 'a -> 'b) -> 'a t -> 'b t val for_all : f:('a -> bool) -> 'a t -> bool val exists : f:('a -> bool) -> 'a t -> bool val find : f:('a -> bool) -> 'a t -> 'a val mem : elem:'a -> 'a t -> bool val memq : elem:'a -> 'a t -> bool val findi : f:('a -> bool) -> 'a t -> int val filter : f:('a -> bool) -> 'a t -> 'a t val filter_map : f:('a -> 'b option) -> 'a t -> 'b t val find_all : f:('a -> bool) -> 'a t -> 'a t val partition : f:('a -> bool) -> 'a t -> 'a t * 'a t end (** {6 Functorial interface} *) module type RANDOMACCESS = sig type 'a t val empty : 'a t 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 append : 'a t -> 'a t -> 'a t val concat : 'a t list -> 'a t val length : 'a t -> int val copy : 'a t -> 'a t val sub : 'a t -> int -> int -> 'a t val make : int -> 'a -> 'a t val iter : ('a -> unit) -> 'a t -> unit val map : ('a -> 'b) -> 'a t -> 'b t val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b val enum : 'a t -> 'a BatEnum.t val backwards : 'a t -> 'a BatEnum.t val of_enum : 'a BatEnum.t -> 'a t val of_backwards : 'a BatEnum.t -> 'a t end module Make : functor (R : RANDOMACCESS) -> functor (PARAM : sig val max_height : int val leaf_size : int end) -> sig type 'a t (** The type of a polymorphic vect. *) exception Out_of_bounds (** Raised when an operation violates the bounds of the vect. *) val max_length : int (** Maximum length of the vect. No function detect when one tries to add more elements than the container can hold. They create broken structures which may cause other functions of this module to raise exceptions when operating on them. *) (** {6 Creation and conversions} *) val empty : 'a t (** The empty vect. *) val singleton : 'a -> 'a t (** Returns a vect of length 1 holding only the given element.*) val of_container : 'a R.t -> 'a t (** [of_container s] returns a vect corresponding to the container [s]. Operates in [O(n)] time. *) val to_container : 'a t -> 'a R.t (** [to_container r] returns a container corresponding to the vect [r]. *) val of_array : 'a array -> 'a t (** [of_array s] returns a vect corresponding to the array [s]. Operates in [O(n)] time. *) val to_array : 'a t -> 'a array (** [to_array r] returns an array corresponding to the vect [r]. *) val to_list : 'a t -> 'a list (** Returns a list with the elements contained in the vect. *) val of_list : 'a list -> 'a t val make : int -> 'a -> 'a t (** [make i c] returns a vect of length [i] whose elements are all equal to [c]; it is similar to Array.make *) val init : int -> (int -> 'a) -> 'a t (** [init n f] returns a fresh vect of length [n], with element number [i] initialized to the result of [f i]. In other terms, [init n f] tabulates the results of [f] applied to the integers [0] to [n-1]. @raise Invalid_argument if [n < 0] or [n > max_length].*) (** {6 Properties } *) val is_empty : 'a t -> bool (** Returns whether the vect is empty or not. *) val height : 'a t -> int (** Returns the height (depth) of the vect. *) val length : 'a t -> int (** Returns the length of the vect ([O(1)]). *) (** {6 Operations } *) val balance : 'a t -> 'a t (** [balance r] returns a balanced copy of the [r] vect. Note that vects are automatically rebalanced when their height exceeds a given threshold, but [balance] allows to invoke that operation explicitly. *) val concat : 'a t -> 'a t -> 'a t (** [concat r u] concatenates the [r] and [u] vects. In general, it operates in [O(log(min n1 n2))] amortized time. Small vects are treated specially and can be appended/prepended in amortized [O(1)] time. *) val append : 'a -> 'a t -> 'a t (** [append c r] returns a new vect with the [c] element at the end in amortized [O(1)] time. *) val prepend : 'a -> 'a t -> 'a t (** [prepend c r] returns a new vect with the [c] character at the beginning in amortized [O(1)] time. *) val get : 'a t -> int -> 'a (** [get v n] returns the (n+1)th element from the vect [v]; i.e. [get v 0] returns the first element. Operates in worst-case [O(log size)] time. @raise Out_of_bounds if a character out of bounds is requested. *) val at : 'a t -> int -> 'a (** as [get] *) val set : 'a t -> int -> 'a -> 'a t (** [set v n c] returns a copy of the [v] vect where the (n+1)th element (see also [get]) has been set to [c]. Operates in worst-case [O(log size)] time. *) val modify : 'a t -> int -> ('a -> 'a) -> 'a t (** [modify v n f] is equivalent to [set v n (f (get v n))], but more efficient. Operates in worst-case [O(log size)] time. *) val destructive_set : 'a t -> int -> 'a -> unit (** [destructive_set v n c] sets the element of index [n] in the [v] vect to [c]. {b This operation is destructive}, and will also affect vects sharing the modified leaf with [v]. Use with caution. *) val sub : 'a t -> int -> int -> 'a t (** [sub r m n] returns a sub-vect of [r] containing all the elements whose indexes range from [m] to [m + n - 1] (included). @raise Out_of_bounds in the same cases as Array.sub. Operates in worst-case [O(log size)] time. *) val insert : int -> 'a t -> 'a t -> 'a t (** [insert n r u] returns a copy of the [u] vect where [r] has been inserted between the elements with index [n] and [n + 1] in the original vect. The length of the new vect is [length u + length r]. Operates in amortized [O(log(size r) + log(size u))] time. *) val remove : int -> int -> 'a t -> 'a t (** [remove m n r] returns the vect resulting from deleting the elements with indexes ranging from [m] to [m + n - 1] (included) from the original vect [r]. The length of the new vect is [length r - n]. Operates in amortized [O(log(size r))] time. *) (** {6 Conversion}*) val enum : 'a t -> 'a BatEnum.t (** Returns an enumeration of the elements of the vector. Behavior of the enumeration is undefined if the contents of the vector changes afterwards.*) val of_enum : 'a BatEnum.t -> 'a t (** Build a vector from an enumeration.*) val backwards : 'a t -> 'a BatEnum.t (** Returns an enumeration of the elements of a vector, from last to first. Behavior of the enumeration is undefined if the contents of the vector changes afterwards.*) val of_backwards : 'a BatEnum.t -> 'a t (** Build a vector from an enumeration, from last to first.*) (** {6 Iteration and higher-order functions } *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f r] applies [f] to all the elements in the [r] vect, in order. *) val iteri : (int -> 'a -> unit) -> 'a t -> unit (** Operates like iter, but also passes the index of the character to the given function. *) val rangeiter : ('a -> unit) -> int -> int -> 'a t -> unit (** [rangeiter f m n r] applies [f] to all the elements whose indices [k] satisfy [m] <= [k] < [m + n]. It is thus equivalent to [iter f (sub m n r)], but does not create an intermediary vect. [rangeiter] operates in worst-case [O(n + log m)] time, which improves on the [O(n log m)] bound from an explicit loop using [get]. @raise Out_of_bounds in the same cases as [sub]. *) val fold_left : ('b -> 'a -> 'b ) -> 'b -> 'a t -> 'b (** [fold_left f a r] computes [ f (... (f (f a r0) r1)...) rN-1 ] where [rn = Vect.get n r ] and [N = length r]. *) val fold : ('b -> 'a -> 'b ) -> 'b -> 'a t -> 'b (** An alias for {!fold_left} *) val reduce : ('a -> 'a -> 'a) -> 'a t -> 'a (** as {!fold_left}, but no initial value - just applies reducing function to elements from left to right. *) val fold_right : ('a -> 'b -> 'b ) -> 'a t -> 'b -> 'b (** [fold_right f r a] computes [ f (r0 ... (f rN-2 (f rN-1 a)) ...)) ] where [rn = Vect.get n r ] and [N = length r]. *) val foldi : (int -> 'b -> 'a -> 'b) -> 'b -> 'a t -> 'b (** As {!fold}, but with the position of each value passed to the folding function *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f v] returns a vect isomorphic to [v] where each element of index [i] equals [f (get v i)]. Therefore, the height of the returned vect is the same as that of the original one. Operates in [O(n)] time. *) val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t (** Same as {!map}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) (* NOT PROVIDED? val id_map : ('a -> 'a) -> 'a t -> 'a t (** [id_map f v] returns a vect isomorphic to [v] where each element of index [i] equals [f (get v i)]. It is very similar to [map], but tries to share as much data as possible with the original vect; for example, [id_map (fun x -> x) v == v]. This can lead to significative space savings if [f] leaves many values unmodified. For each element, the new value [f x] and the old one [x] are compared with [<>]. Operates in [O(n)] time. *) *) (**{6 Predicates}*) val for_all : ('a -> bool) -> 'a t -> bool (** [for_all p [a0; a1; ...; an]] checks if all elements of the vect satisfy the predicate [p]. That is, it returns [ (p a0) && (p a1) && ... && (p an)]. *) val exists : ('a -> bool) -> 'a t -> bool (** [exists p [a0; a1; ...; an]] checks if at least one element of the vect satisfies the predicate [p]. That is, it returns [ (p a0) || (p a1) || ... || (p an)]. *) val find : ('a -> bool) -> 'a t -> 'a (** [find p a] returns the first element of vect [a] that satisfies the predicate [p]. @raise Not_found if there is no value that satisfies [p] in the vect [a]. *) val find_opt : ('a -> bool) -> 'a t -> 'a option (** [find_opt p a] returns [Some x], where [x] is the first element of vect [a] that satisfies the predicate [p], or [None] if no such element exists. @since 2.7.0 *) val mem : 'a -> 'a t -> bool (** [mem m a] is true if and only if [m] is equal to an element of [a]. *) val memq : 'a -> 'a t -> bool (** Same as {!Vect.mem} but uses physical equality instead of structural equality to compare vect elements. *) val findi : ('a -> bool) -> 'a t -> int (** [findi p a] returns the index of the first element of vect [a] that satisfies the predicate [p]. @raise Not_found if there is no value that satisfies [p] in the vect [a]. *) val filter : ('a -> bool) -> 'a t -> 'a t (** [filter f v] returns a vect with the elements [x] from [v] such that [f x] returns [true]. Operates in [O(n)] time. *) val filter_map : ('a -> 'b option) -> 'a t -> 'b t (** [filter_map f e] returns a vect consisting of all elements [x] such that [f y] returns [Some x] , where [y] is an element of [e]. *) val find_all : ('a -> bool) -> 'a t -> 'a t (** [find_all] is another name for {!Vect.filter}. *) val partition : ('a -> bool) -> 'a t -> 'a t * 'a t (** [partition p v] returns a pair of vects [(v1, v2)], where [v1] is the vect of all the elements of [v] that satisfy the predicate [p], and [v2] is the vect of all the elements of [v] that do not satisfy [p]. The order of the elements in the input vect is preserved. *) (** {6 Convenience Functions} *) val first : 'a t -> 'a val last : 'a t -> 'a (** These return the first and last values in the vector *) val shift : 'a t -> 'a * 'a t (** Return the first element of a vector and its last [n-1] elements. *) val pop : 'a t -> 'a * 'a t (** Return the last element of a vector and its first [n-1] elements. *) (** {6 Boilerplate code}*) (** {6 Override modules}*) (** Operations on {!BatVect} with labels. This module overrides a number of functions of {!BatVect} by functions in which some arguments require labels. These labels are there to improve readability and safety and to let you change the order of arguments to functions. In every case, the behavior of the function is identical to that of the corresponding function of {!BatVect}. *) module Labels : sig val init : int -> f:(int -> 'a) -> 'a t val get : 'a t -> n:int -> 'a val at : 'a t -> n:int -> 'a val set : 'a t -> n:int -> elem:'a -> 'a t val modify : 'a t -> n:int -> f:('a -> 'a) -> 'a t val destructive_set : 'a t -> n:int -> elem:'a -> unit val sub : 'a t -> m:int -> n:int -> 'a t val insert : n:int -> sub:'a t -> 'a t -> 'a t val remove : m:int -> n:int -> 'a t -> 'a t val iter : f:('a -> unit) -> 'a t -> unit val iteri : f:(int -> 'a -> unit) -> 'a t -> unit val rangeiter : f:('a -> unit) -> m:int -> n:int -> 'a t -> unit val fold_left : f:('b -> 'a -> 'b) -> init:'b -> 'a t -> 'b val fold : f:('b -> 'a -> 'b) -> init:'b -> 'a t -> 'b val reduce : f:('a -> 'a -> 'a) -> 'a t -> 'a val fold_right : f:('a -> 'b -> 'b) -> 'a t -> init:'b -> 'b val foldi : f:(int -> 'b -> 'a -> 'b) -> init:'b -> 'a t -> 'b val map : f:('a -> 'b) -> 'a t -> 'b t val mapi : f:(int -> 'a -> 'b) -> 'a t -> 'b t val for_all : f:('a -> bool) -> 'a t -> bool val exists : f:('a -> bool) -> 'a t -> bool val find : f:('a -> bool) -> 'a t -> 'a val mem : elem:'a -> 'a t -> bool val memq : elem:'a -> 'a t -> bool val findi : f:('a -> bool) -> 'a t -> int val filter : f:('a -> bool) -> 'a t -> 'a t val filter_map : f:('a -> 'b option) -> 'a t -> 'b t val find_all : f:('a -> bool) -> 'a t -> 'a t val partition : f:('a -> bool) -> 'a t -> 'a t * 'a t end (** {7 Printing}*) val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> 'b t -> unit (**/**) val invariants : _ t -> unit (**/**) end batteries-included-3.4.0/src/batteries.mllib000066400000000000000000000022201415601150500210510ustar00rootroot00000000000000BatInnerPervasives BatInnerShuffle BatArray BatBigarray BatBig_int BatBool BatBounded BatBuffer BatBytesCompat BatBytes BatChar BatComplex BatDeque BatDigest BatEnum BatEither BatFilename BatFingerTree BatFloat BatFormat BatGc BatGenlex BatHashcons BatHashtbl BatHeap BatIO BatInnerIO BatInt32 BatInt64 BatInt BatLexing BatList BatMap BatMarshal BatNativeint BatNum BatPervasives BatPrintexc BatPrintf BatConcreteQueue BatQueue BatRandom BatScanf BatSet BatSplay BatStack BatStream BatString BatOpaqueInnerSys BatSys BatUnit BatUnix BatBase64 BatBitSet BatCharParser BatConcurrent BatDllist BatDynArray BatFile BatGlobal BatInnerWeaktbl BatInterfaces BatLazyList BatLogger BatMultiPMap BatMultiMap BatNumber BatOption BatOptParse BatOrd BatParserCo BatPathGen BatRefList BatRef BatResult BatReturn BatSeq BatSubstring BatTuple BatUref BatVect BatAvlTree BatISet BatIMap BatCache BatLog BatUChar BatUTF8 BatText BatteriesConfig BatteriesPrint Batteries BatteriesExceptionless Extlib batteries-included-3.4.0/src/batteries.mlv000066400000000000000000000120031415601150500205500ustar00rootroot00000000000000(* open this to extend all Foo with BatFoo *) module Legacy = struct include Pervasives module Arg = Arg module Array = Array module ArrayLabels = ArrayLabels module Buffer = Buffer module Bytes = Bytes module Callback = Callback module Char = Char module Complex = Complex module Digest = Digest ##V>=4.12## module Either = Either module Filename = Filename module Format = Format module Gc = Gc module Genlex = Genlex module Hashtbl = Hashtbl module Int32 = Int32 module Int64 = Int64 module Lazy = Lazy module Lexing = Lexing module List = List module ListLabels = ListLabels module Map = Map module Marshal = Marshal module MoreLabels = MoreLabels module Nativeint = Nativeint module Oo = Oo module Parsing = Parsing module Printexc = Printexc module Printf = Printf module Queue = Queue module Random = Random module Scanf = Scanf module Set = Set ##V>=4.7## module Seq = Seq ##V<4.8## module Sort = Sort module Stack = Stack module StdLabels = StdLabels module Stream = Stream module String = String module StringLabels = StringLabels module Sys = Sys module Weak = Weak module Unix = Unix module Num = Num module Big_int = Big_int module Bigarray = Bigarray module Str = Str ##V>=4.8## module Result = Result end (* stdlib modules *) (* Arg *) module Array = BatArray (* ArrayLabels *) module Buffer = BatBuffer module Bytes = BatBytes (* this type is a compiler builtin in OCaml V>=4.2, and declared by BatBytes as equal to 'string' below; this alias declaration makes the unqualified 'bytes' usable by users V<=4.2, otherwise they can only use (Bat)Bytes.t *) type bytes = Bytes.t (* Callback *) module Char = BatChar module Complex = BatComplex module Digest = BatDigest module Either = BatEither (* Filename *) module Format = BatFormat module Gc = BatGc module Genlex = BatGenlex module Hashtbl = BatHashtbl module Int32 = BatInt32 module Int64 = BatInt64 (* Lazy *) module Lexing = BatLexing module List = BatList (* ListLabels *) module Map = BatMap module Marshal = BatMarshal (* MoreLabels *) module Nativeint = BatNativeint (* Parsing *) module Printexc = BatPrintexc module Printf = BatPrintf (* UNTESTED FOR BACKWARDS COMPATIBILITY *) module Queue = BatQueue module Random = BatRandom module Scanf = BatScanf module Set = BatSet (* Sort - Deprecated *) module Stack = BatStack module Stream = BatStream module String = BatString (* StringLabels *) module Sys = BatSys (* Weak *) module Unix = BatUnix (*module Str = struct include Str include BatStr end*) module Big_int = BatBig_int module Num = BatNum module Bigarray = BatBigarray (* Extlib modules not replacing stdlib *) module Base64 = BatBase64 module BitSet = BatBitSet module Bit_set = BatBitSet module Dllist = BatDllist module DynArray = BatDynArray module Enum = BatEnum module File = BatFile module Global = BatGlobal module IO = BatIO module LazyList = BatLazyList module MultiPMap = BatMultiPMap module Option = BatOption (* REMOVED, Extlib only module OptParse = BatOptParse *) module RefList = BatRefList module Ref = BatRef (*module Std = REMOVED - use BatPervasives *) (* Batteries specific modules *) module Cache = BatCache module CharParser = BatCharParser module Deque = BatDeque module Hashcons = BatHashcons module Heap = BatHeap module FingerTree = BatFingerTree module Logger = BatLogger module MultiMap = BatMultiMap module ParserCo = BatParserCo module Result = BatResult module Return = BatReturn module Seq = BatSeq module Substring = BatSubstring module Tuple = BatTuple module Tuple2 = BatTuple.Tuple2 module Tuple3 = BatTuple.Tuple3 module Tuple4 = BatTuple.Tuple4 module Tuple5 = BatTuple.Tuple5 module Vect = BatVect module ISet = BatISet module IMap = BatIMap module Splay = BatSplay module Uref = BatUref module UChar = BatUChar module UTF8 = BatUTF8 module Text = BatText module Concurrent = BatConcurrent (* Batteries Specific *) module Interfaces = BatInterfaces module Number = BatNumber module Float = BatFloat module Int = BatInt module Bool = BatBool module Unit = BatUnit (*module Int63 = BatInt63*) module Filename = BatFilename (* Modules in-progress, API stability not guaranteed *) module Incubator = struct module Log = BatLog module Bounded = BatBounded module PathGen = BatPathGen end (* Pervasives last *) ##V<4.3##include Pervasives ##V>=4.3##include (Pervasives : ##V>=4.3## module type of Pervasives ##V>=4.3## with type ('a, 'b) result := ('a, 'b) Pervasives.result ##V>=4.3## and type 'a ref = 'a Pervasives.ref ##V>=4.3## and type fpclass = Pervasives.fpclass ##V>=4.3## and type in_channel = Pervasives.in_channel ##V>=4.3## and type out_channel = Pervasives.out_channel ##V>=4.3## and type open_flag = Pervasives.open_flag ##V>=4.3## and type ('a, 'b, 'c, 'd, 'e, 'f) format6 = ##V>=4.3## ('a, 'b, 'c, 'd, 'e, 'f) Pervasives.format6 ##V>=4.3## and type ('a, 'b, 'c, 'd) format4 = ##V>=4.3## ('a, 'b, 'c, 'd) Pervasives.format4 ##V>=4.3## and type ('a, 'b, 'c) format = ##V>=4.3## ('a, 'b, 'c) Pervasives.format ##V>=4.3##) include BatPervasives batteries-included-3.4.0/src/batteriesConfig.mlp000066400000000000000000000026511415601150500217000ustar00rootroot00000000000000(* * config - Configuration module for OCaml Batteries Included * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) let version = "@VERSION@";; let documentation_root = "@DOCROOT@";; let (browser: (_, _, _) format) = "@BROWSER_COMMAND@ %s";; (**The default function to open a www browser.*) let default_browse s = let command = Printf.sprintf browser s in Sys.command command let current_browse = ref default_browse let browse s = !current_browse s let set_browser f = current_browse := f let max_array_length = Sys.max_array_length let word_size = Sys.word_size let max_string_length= Sys.max_string_length batteries-included-3.4.0/src/batteriesExceptionless.ml000066400000000000000000000062151415601150500231400ustar00rootroot00000000000000(* open this to extend all Foo with BatFoo and BatFoo.Exceptionless if available *) include (Batteries : module type of Batteries with module Array := Batteries.Array and module Hashtbl := Batteries.Hashtbl and module List := Batteries.List and module Map := Batteries.Map and module Queue := Batteries.Queue and module Stack := Batteries.Stack and module String := Batteries.String and module Enum := Batteries.Enum and module LazyList := Batteries.LazyList and module Seq := Batteries.Seq and module Splay := Batteries.Splay ) module Array = struct include (BatArray : module type of BatArray with module Labels := BatArray.Labels and module Cap := BatArray.Cap ) include BatArray.Exceptionless module Labels = struct include BatArray.Labels include BatArray.Labels.LExceptionless end module Cap = struct include BatArray.Cap include BatArray.Cap.Exceptionless end end module Hashtbl = struct include BatHashtbl include BatHashtbl.Exceptionless (* TODO *) end module List = struct include (BatList : module type of BatList with module Labels := BatList.Labels ) include BatList.Exceptionless module Labels = struct include BatList.Labels include BatList.Labels.LExceptionless end end module Map = struct include (BatMap : module type of BatMap with module PMap := BatMap.PMap ) include Exceptionless module PMap = struct include BatMap.PMap include BatMap.PMap.Exceptionless end (* TODO *) end module Queue = struct include BatQueue include BatQueue.Exceptionless end (* module Set = BatSet (* TODO *) *) module Stack = struct include BatStack include BatStack.Exceptionless end module String = struct include (BatString : module type of BatString (* with module Cap := BatString.Cap *) ) include BatString.Exceptionless (* module Cap = struct *) (* include BatString.Cap *) (* include BatString.Cap.Exceptionless *) (* end *) end (* Extlib modules not replacing stdlib *) module Enum = struct include (BatEnum : module type of Batteries.Enum with module Labels := Batteries.Enum.Labels ) include BatEnum.Exceptionless module Labels = struct include BatEnum.Labels include BatEnum.Labels.LExceptionless end end module LazyList = struct include (BatLazyList : module type of Batteries.LazyList with module Labels := Batteries.LazyList.Labels ) include BatLazyList.Exceptionless module Labels = struct include BatLazyList.Labels include BatLazyList.Labels.Exceptionless end end (* Batteries specific modules *) module Seq = struct include BatSeq include BatSeq.Exceptionless end module Splay = struct include (BatSplay : module type of BatSplay with module Map := BatSplay.Map ) module Map (Ord : BatInterfaces.OrderedType) = struct include BatSplay.Map(Ord) include Exceptionless end end batteries-included-3.4.0/src/batteriesPrint.ml000066400000000000000000000065621415601150500214140ustar00rootroot00000000000000(* * Batteries_print - Pretty-printers for the toplevel * Copyright (C) 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) let print_uchar fmt t = Format.fprintf fmt "UChar.of_char '%s'" (BatUTF8.init 1 (fun _ -> t)) let print_rope fmt t = Format.fprintf fmt "r%S" (BatText.to_string t) let print_ustring fmt t = Format.fprintf fmt "u%S" t (* let string_of_cap t = BatString.Cap.to_string (BatString.Cap.copy t) let print_string_cap_rw fmt t = Format.fprintf fmt "rw%S" (string_of_cap t) let print_string_cap_ro fmt t = Format.fprintf fmt "ro%S" (string_of_cap t) *) let string_dynarray = BatIO.to_f_printer (BatDynArray.print BatString.print) let int_dynarray = BatIO.to_f_printer (BatDynArray.print BatInt.print) let char_dynarray = BatIO.to_f_printer (BatDynArray.print BatChar.print) let float_dynarray = BatIO.to_f_printer (BatDynArray.print BatFloat.print) let int_set = BatIO.to_f_printer (BatSet.Int.print BatInt.print) let int32_set = BatIO.to_f_printer (BatSet.Int32.print BatInt32.print) let int64_set = BatIO.to_f_printer (BatSet.Int64.print BatInt64.print) let natint_set = BatIO.to_f_printer (BatSet.Nativeint.print BatNativeint.print) let float_set = BatIO.to_f_printer (BatSet.Float.print BatFloat.print) let char_set = BatIO.to_f_printer (BatSet.Char.print BatChar.print) let string_set = BatIO.to_f_printer (BatSet.String.print BatString.print) let int_pset = BatIO.to_f_printer (BatSet.print BatInt.print) let string_pset = BatIO.to_f_printer (BatSet.print BatString.print) let rope_pset = BatIO.to_f_printer (BatSet.print BatText.print) let char_pset = BatIO.to_f_printer (BatSet.print BatChar.print) let (|>) x f = f x let enum_print_limit = ref 20 let enum_print p oc e = let e = BatEnum.clone e in for _i = 1 to !enum_print_limit-1 do match BatEnum.get e with | None -> () | Some x -> p oc x; BatIO.write oc ' ' done; if not (BatEnum.is_empty e) then BatIO.nwrite oc "..." let int_enum = BatIO.to_f_printer (enum_print BatInt.print) let string_enum = BatIO.to_f_printer (enum_print BatString.print) let rope_enum = BatIO.to_f_printer (enum_print BatText.print) let char_enum = BatIO.to_f_printer (enum_print BatChar.print) (*let iset = BatIO.to_f_printer BatISet.print *) let int_int_pmap = BatIO.to_f_printer (BatMap.print BatInt.print BatInt.print) let int_str_pmap = BatIO.to_f_printer (BatMap.print BatInt.print BatString.print) let str_int_pmap = BatIO.to_f_printer (BatMap.print BatString.print BatInt.print) let str_str_pmap = BatIO.to_f_printer (BatMap.print BatString.print BatString.print) (*let bitset = BatIO.to_f_printer BatBitSet.print*) batteries-included-3.4.0/src/batteriesThread.ml000066400000000000000000000003201415601150500215110ustar00rootroot00000000000000module Mutex = BatMutex module RMutex = BatRMutex let () = BatUnix.lock := RMutex.make (); BatIO.lock := RMutex.make (); BatIO.lock_factory := RMutex.make; BatPervasives.lock := RMutex.make (); () batteries-included-3.4.0/src/batteriesThread.mllib000066400000000000000000000000471415601150500222060ustar00rootroot00000000000000BatMutex BatRMutex BatteriesThread batteries-included-3.4.0/src/batteries_compattest.mlv000066400000000000000000000130301415601150500230140ustar00rootroot00000000000000open Batteries module Stdlib_verifications = struct (* This module asserts that all the BatFoo modules are actually extensions of stdlib modules, and that no functionality is lost. *) module Array_t = (Array : module type of Legacy.Array) module Buffer_t = (Buffer: sig include module type of Legacy.Buffer val add_channel : t -> BatInnerIO.input -> int -> unit val output_buffer : t -> string BatInnerIO.output end) module Bytes = (Bytes : module type of Legacy.Bytes) module Char_t = (Char: module type of Legacy.Char) module Complex_t = (Complex : module type of Legacy.Complex) module Digest = (Digest: sig include module type of Legacy.Digest val channel : BatIO.input -> int -> Digest.t val output : 'a BatIO.output -> t -> unit val input : BatIO.input -> Digest.t end) (* module Format = (Format: module type of Legacy.Format)*) module Gc = (Gc: sig include module type of Legacy.Gc val print_stat : 'a BatInnerIO.output -> unit end) module Genlex = (Genlex : module type of Legacy.Genlex) (* module Hashtbl = (Hashtbl: module type of Legacy.Hashtbl)*) module Int32 = (Int32: module type of Legacy.Int32) module Int64 = (Int64: module type of Legacy.Int64) module Lexing = (Lexing: sig include module type of Legacy.Lexing val from_channel : BatIO.input -> Lexing.lexbuf end) module List = (List: sig include module type of Legacy.List val find_map : ('a -> 'b option) -> 'a list -> 'b end) ##V>=4.7## module Seq = (Seq : module type of Legacy.Seq) module Marshal = (Marshal: sig include module type of Legacy.Marshal val to_channel : _ BatIO.output -> 'b -> extern_flags list -> unit val from_channel : BatIO.input -> 'a end) module Nativeint = (Nativeint: module type of Legacy.Nativeint) module Oo = (Oo : module type of Legacy.Oo) module Printexc = (Printexc: sig include module type of Legacy.Printexc val print : 'a BatInnerIO.output -> exn -> unit val print_backtrace : 'a BatInnerIO.output -> unit end) (* module Printf = (Printf: module type of Legacy.Printf)*) module Queue = (Queue: module type of Legacy.Queue) ##V>=4.8## module Result = (Result: module type of Legacy.Result) (* module Scanf = (Scanf : module type of Legacy.Scanf)*) (* FAILS BECAUSE OF Stack.Empty not being present because module Stack = (Stack : module type of Legacy.Stack) *) module Random = (Random: module type of Legacy.Random) module Stream = (Stream : module type of Legacy.Stream) module String : sig include module type of Legacy.String end = struct include BatString let starts_with = starts_with_stdlib let ends_with = ends_with_stdlib let exists = exists_stdlib end module Sys = (Sys : module type of Legacy.Sys) module Unix = (Unix: sig include module type of Legacy.Unix val in_channel_of_descr : Unix.file_descr -> BatInnerIO.input val out_channel_of_descr : Unix.file_descr -> unit BatInnerIO.output val descr_of_in_channel : BatInnerIO.input -> Unix.file_descr val descr_of_out_channel : unit BatInnerIO.output -> Unix.file_descr val open_process_in : ?autoclose:bool -> ?cleanup:bool -> string -> BatInnerIO.input val open_process_out : ?cleanup:bool -> string -> unit BatInnerIO.output val open_process : ?autoclose:bool -> ?cleanup:bool -> string -> BatInnerIO.input * unit BatInnerIO.output val open_process_full : ?autoclose:bool -> ?cleanup:bool -> string -> string array -> BatInnerIO.input * unit BatInnerIO.output * BatInnerIO.input val close_process_in : BatInnerIO.input -> Unix.process_status val close_process_out : unit BatInnerIO.output -> Unix.process_status val close_process : BatInnerIO.input * unit BatInnerIO.output -> Unix.process_status val close_process_full : BatInnerIO.input * unit BatInnerIO.output * BatInnerIO.input -> Unix.process_status val open_connection : ?autoclose:bool -> Unix.sockaddr -> BatInnerIO.input * unit BatInnerIO.output val shutdown_connection : BatInnerIO.input -> unit val establish_server : ?autoclose:bool -> ?cleanup:bool -> (BatInnerIO.input -> unit BatInnerIO.output -> unit) -> Unix.sockaddr -> unit end) module Big_int = (Big_int : module type of Legacy.Big_int) (* FIXME: This does not pass for some reason: module Bigarray = (Bigarray : module type of Legacy.Bigarray)*) (* test compatibility of BatMap.S with Legacy.Map.S *) let sort_map (type s) (module Map : Legacy.Map.S with type key = s) l = Map.bindings (List.fold_right (fun x m -> Map.add x x m) l Map.empty) module IntMap = struct include BatMap.Int let update = update_stdlib end let _ = assert ([1,1;2,2;3,3;] = (sort_map (module IntMap) [3; 1; 2;])) (* test compat of BatSplay.S with Legacy.Map.S *) module IntSplayMap = struct include BatSplay.Map (BatInt) let update = update_stdlib end let _ = assert ([1,1;2,2;3,3;] = (sort_map (module IntSplayMap) [3; 1; 2;])) (* test compatibility of BatSet.S with Legacy.Set.S *) let sort (type s) (module Set : Legacy.Set.S with type elt = s) l = Set.elements (List.fold_right Set.add l Set.empty) module IntSet = struct include BatSet.Int end let _ = assert ([1;2;3] = (sort (module IntSet) [3; 1; 2;])) end batteries-included-3.4.0/src/dune000066400000000000000000000066521415601150500167410ustar00rootroot00000000000000(library (name batteries) (public_name batteries) (synopsis "A community-maintained standard library extension") (preprocess (action (run build/prefilter.exe %{input-file}))) (flags (:standard -w -3-32-52)) (libraries num threads) (inline_tests (backend qtest_batteries) (deps %{project_root}/qtest/qtest_preamble.ml) ) (wrapped false) ) (rule (action (copy# batConcreteQueue_402.ml batConcreteQueue.ml)) (enabled_if (< %{ocaml_version} 4.03)) ) (rule (action (copy# batConcreteQueue_403.ml batConcreteQueue.ml)) (enabled_if (>= %{ocaml_version} 4.03)) ) (library (name qtest_batteries) (modules) (inline_tests.backend (generate_runner (run qtest extract --preamble-file %{project_root}/qtest/qtest_preamble.ml --quiet %{impl-files} %{intf-files})) (runner_libraries qcheck ounit2) )) (rule (target batteriesConfig.ml) (deps %{project_root}/build/mkconf.exe %{project_root}/_oasis batteriesConfig.mlp) (action (run %{project_root}/build/mkconf.exe %{project_root}/_oasis batteriesConfig.mlp %{target}))) ; documentation works! ; dune build @doc ; xdg-open _build/default/_doc/_html/index.html (documentation (mld_files index)) ; note: temporary, intro.text should be renamed (rule (copy ../build/intro.text index.mld)) ; note: these copy rules will go away once we have completely ; transitioned to Dune, but for now they are necessary to preserve ; ocamlbuild-friendly source filenames. (rule (copy batArray.mlv batArray.ml)) (rule (copy batArray.mliv batArray.mli)) (rule (copy batBig_int.mlv batBig_int.ml)) (rule (copy batBig_int.mliv batBig_int.mli)) (rule (copy batBigarray.mlv batBigarray.ml)) (rule (copy batBigarray.mliv batBigarray.mli)) (rule (copy batBuffer.mlv batBuffer.ml)) (rule (copy batBuffer.mliv batBuffer.mli)) (rule (copy batBytes.mlv batBytes.ml)) (rule (copy batBytes.mliv batBytes.mli)) (rule (copy batBytesCompat.mlv batBytesCompat.ml)) (rule (copy batChar.mlv batChar.ml)) (rule (copy batDigest.mlv batDigest.ml)) (rule (copy batFilename.mlv batFilename.ml)) (rule (copy batFilename.mliv batFilename.mli)) (rule (copy batFormat.mlv batFormat.ml)) (rule (copy batFormat.mliv batFormat.mli)) (rule (copy batGc.mliv batGc.mli)) (rule (copy batHashtbl.mlv batHashtbl.ml)) (rule (copy batInnerPervasives.mlv batInnerPervasives.ml)) (rule (copy batInnerWeaktbl.mlv batInnerWeaktbl.ml)) (rule (copy batInnerWeaktbl.mliv batInnerWeaktbl.mli)) (rule (copy batInt32.mlv batInt32.ml)) (rule (copy batInt32.mliv batInt32.mli)) (rule (copy batInt64.mlv batInt64.ml)) (rule (copy batInt64.mliv batInt64.mli)) (rule (copy batLexing.mlv batLexing.ml)) (rule (copy batLexing.mliv batLexing.mli)) (rule (copy batList.mlv batList.ml)) (rule (copy batList.mliv batList.mli)) (rule (copy batMarshal.mlv batMarshal.ml)) (rule (copy batMarshal.mliv batMarshal.mli)) (rule (copy batNativeint.mlv batNativeint.ml)) (rule (copy batNativeint.mliv batNativeint.mli)) (rule (copy batPervasives.mliv batPervasives.mli)) (rule (copy batPrintexc.mliv batPrintexc.mli)) (rule (copy batPrintf.mlv batPrintf.ml)) (rule (copy batPrintf.mliv batPrintf.mli)) (rule (copy batQueue.mliv batQueue.mli)) (rule (copy batSeq.mlv batSeq.ml)) (rule (copy batSeq.mliv batSeq.mli)) (rule (copy batStream.mlv batStream.ml)) (rule (copy batString.mlv batString.ml)) (rule (copy batString.mliv batString.mli)) (rule (copy batSys.mlv batSys.ml)) (rule (copy batSys.mliv batSys.mli)) (rule (copy batUnix.mlv batUnix.ml)) (rule (copy batteries.mlv batteries.ml)) batteries-included-3.4.0/src/extlib.ml000066400000000000000000000011451415601150500176740ustar00rootroot00000000000000module Base64 = BatBase64 module BitSet = BatBitSet module Dllist = BatDllist module DynArray = BatDynArray module Enum = BatEnum module ExtArray = struct module Array = BatArray end module ExtHashtbl = struct module Hashtbl = BatHashtbl end module ExtList = struct module List = BatList end module ExtString = struct module String = BatString end module Global = BatGlobal module IO = BatIO module OptParse = BatOptParse module Option = BatOption module PMap = BatMap module RefList = BatRefList module Std = BatPervasives module UChar = BatUChar module UTF8 = BatUTF8 (* module Unzip = NOT AVAILABLE *) batteries-included-3.4.0/test-build/000077500000000000000000000000001415601150500173375ustar00rootroot00000000000000batteries-included-3.4.0/test-build/Makefile000066400000000000000000000006531415601150500210030ustar00rootroot00000000000000# This test is designed to catch build issues that affect installed # versions of the library, such as the ones that plagued v2.5.0 and # v2.5.1 -- forgetting to include a new module in src/batteries.mllib, # which results in a link-time error when building from an installed # version. all: ocamlfind ocamlopt -package batteries -o test -linkpkg test.ml ./test | grep --quiet "0123456789" || exit 2 rm test.cm* test.o test batteries-included-3.4.0/test-build/test.ml000066400000000000000000000002401415601150500206440ustar00rootroot00000000000000open Batteries let digits = List.unfold 0 (fun n -> if n >= 10 then None else Some (n, n + 1)) let () = List.iter (Int.print stdout) digits; print_newline () batteries-included-3.4.0/testsuite/000077500000000000000000000000001415601150500173145ustar00rootroot00000000000000batteries-included-3.4.0/testsuite/_tags000066400000000000000000000000401415601150500203260ustar00rootroot00000000000000true: pkg_oUnit, threads, debug batteries-included-3.4.0/testsuite/dune000066400000000000000000000002201415601150500201640ustar00rootroot00000000000000(executable (name main) (flags (:standard -w -3)) (libraries batteries oUnit threads)) (rule (alias runtest) (action (run ./main.exe))) batteries-included-3.4.0/testsuite/main.ml000066400000000000000000000017541415601150500206010ustar00rootroot00000000000000open OUnit let all_tests = [ Test_pervasives.tests; (* Test_base64.tests; Replaced by simple quickcheck rules inline *) (* Test_unix.tests; Moved to inline tests in BatUnix *) (* Test_print.tests; Test_toplevel.tests; *) Test_map.tests; (* pmap is actually tested in test_map.ml, as they share their implementation *) Test_multipmap.tests; (* Test_vect.tests; Moved inline to BatVect *) Test_file.tests; (* Test_string.tests; Moved inline to BatString *) Test_substring.tests; Test_digest.tests; Test_enum.tests; Test_set.tests; Test_dynarray.tests; Test_stack.tests; Test_mappable.tests; Test_num.tests; Test_hashcons.tests; Test_mapfunctors.tests; Test_optparse.tests; Test_uref.tests; Test_bitset.tests; Test_container.tests; Test_random.tests; Test_bounded.tests; Test_modifiable.tests; Test_hashtbl.tests; ] let () = ignore(OUnit.run_test_tt_main ("All" >::: all_tests)); batteries-included-3.4.0/testsuite/myocamlbuild.ml000077700000000000000000000000001415601150500266472../build/myocamlbuild.mlustar00rootroot00000000000000batteries-included-3.4.0/testsuite/test_base64.ml000066400000000000000000000023251415601150500217730ustar00rootroot00000000000000open OUnit open BatBase64 let string = "hello world" let assert_equal_strings s1 s2 = assert_equal ~printer:(fun s -> "“"^s^"”") s1 s2 let hexa s = (* really not perf critical *) let r = ref "" in for i = 0 to String.length s - 1 do r := !r ^ (Printf.sprintf "%x" (Char.code s.[i])) done; !r let assert_equal_bytes s1 s2 = assert_equal ~printer:(fun s -> "“"^s^"” (0x"^(hexa s)^")") s1 s2 let test_encdec_aux str = assert_equal_bytes str (str_decode (str_encode str)) let test_decenc_aux str = let enc = str_encode str in assert_equal_strings enc (str_encode (str_decode enc)) let random_string len = let r = String.create len in for i = 0 to len - 1 do r.[i] <- BatRandom.char () done; r let map_generated_data f iters max_len = for len = 0 to max_len do for i = 1 to iters do f (random_string len) done done let test_encdec () = map_generated_data test_encdec_aux 4 50 let test_decenc () = map_generated_data test_decenc_aux 4 50 let tests = "Base64" >::: [ "Decode undoes encode" >:: test_encdec; "Encode undoes decode" >:: test_decenc; (*"Encode works as expected" >:: test_enc; "Decode works as expected" >:: test_dec;*) ] batteries-included-3.4.0/testsuite/test_bitset.ml000066400000000000000000000115061415601150500222020ustar00rootroot00000000000000open OUnit module BS = BatBitSet let test_of_array arr = let t = BS.create (Array.length arr) in let () = (* Create the table *) Array.iteri (fun idx vl -> try if vl then BS.set t idx with e -> assert_failure (Printf.sprintf "while setting bitset.(%d) got this exception: %s" idx (Printexc.to_string e))) arr in let () = (* Check the table *) Array.iteri (fun idx vl -> let res = try BS.mem t idx with e -> assert_failure (Printf.sprintf "while getting bitset.(%d) got this exception: %s" idx (Printexc.to_string e)) in assert_equal ~msg:(Printf.sprintf "at idx %d" idx) ~printer:string_of_bool vl res) arr in () let assert_mem t lst = List.iter (fun (i, b) -> assert_equal ~msg:(Printf.sprintf "at idx %d" i) ~printer:string_of_bool b (BS.mem t i)) lst let lst1 = [1; 4; 25; 27] let lst2 = [1; 5; 26; 250] let biop op ?(rev=false) lst () = let t1 = BS.of_list lst1 in let t2 = BS.of_list lst2 in let t1, t2 = if rev then t2, t1 else t1, t2 in let tr = op t1 t2 in assert_mem tr (List.map (fun i -> i, true) lst); assert_equal ~msg:"number of element" ~printer:string_of_int (List.length lst) (BS.count tr) module EInt = struct type t = int let compare = ( - ) let pp_printer = Format.pp_print_int let pp_print_sep = OUnitDiff.pp_comma_separator end module ListInt = struct include OUnitDiff.SetMake(EInt) let assert_equal ?msg lst1 lst2 = assert_equal ?msg (of_list lst1) (of_list lst2) end let tests = "BitSet" >::: [ "Check small array" >:: (fun () -> test_of_array [|true; false; false; true; false; true; true; false; false; false; true|]); "Check intermediate array" >:: (fun () -> test_of_array (Array.init 100 (fun _ -> Random.bool ()))); "Check huge array" >:: (fun () -> test_of_array (Array.init 1000 (fun _ -> Random.bool ()))); "empty" >:: (fun () -> let t = BS.empty () in assert_mem t [1, false; 2, false; 100, false]); "create" >:: (fun () -> let t = BS.create 10 in assert_mem t [1, false; 2, false; 9, false; 10, false; 100, false]); "create 0" >:: (fun () -> let t = BS.create 0 in BS.set t 0; assert_mem t [0, true; 1, false; 2, false; 9, false; 10, false; 100, false]); "full" >:: (fun () -> let t = BS.create_full 10 in assert_mem t [0, true; 1, true; 2, true; 9, true; 10, false; 100, false]; assert_equal ~msg:"count" ~printer:string_of_int 10 (BS.count t)); "copy" >:: (fun () -> let t = BS.of_list lst1 in let t' = BS.copy t in assert_bool "Copy should be equals" (BS.equal t t')); "union" >:: (biop BS.union [1; 4; 5; 25; 26; 27; 250]); "union2" >:: (biop BS.union ~rev:true [1; 4; 5; 25; 26; 27; 250]); "diff1" >:: (biop BS.diff [4; 25; 27]); "diff2" >:: (biop BS.diff ~rev:true [5; 26; 250]); "sym_diff" >:: (biop BS.sym_diff [4; 25; 27; 5; 26; 250]); "sym_diff2" >:: (biop BS.sym_diff ~rev:true [4; 25; 27; 5; 26; 250]); "inter" >:: (biop BS.inter [1]); "next_set_bit" >:: (fun () -> let bs = BS.of_list lst1 in let string_of_int_opt = function | Some i -> string_of_int i | None -> "" in let last = List.fold_left (fun prv cur -> assert_equal ~printer:string_of_int_opt (Some cur) (BS.next_set_bit bs (prv + 1)); cur) (-1) lst1 in assert_equal ~printer:string_of_int_opt None (BS.next_set_bit bs (last + 1))); "enum" >:: (fun () -> let t1 = BS.of_list lst1 in let t2 = BS.of_list lst2 in ListInt.assert_equal lst1 (BatList.of_enum (BS.enum t1)); ListInt.assert_equal lst2 (BatList.of_enum (BS.enum t2))); "toggle" >:: (fun () -> let t = BS.empty () in BS.toggle t 10; assert_bool "idx 10 is set" (BS.mem t 10); BS.toggle t 10; assert_bool "idx 10 is not set" (not (BS.mem t 10))); "compare" >:: (fun () -> let t1 = BS.of_list lst1 in let t2 = BS.of_list lst2 in assert_bool "lst1 < lst2" (BS.compare t1 t2 < 0); assert_bool "lst2 > lst1" (BS.compare t2 t1 > 0); assert_bool "lst1 = lst1" (BS.compare t1 t1 = 0); assert_bool "lst2 = lst2" (BS.compare t2 t2 = 0)) ] batteries-included-3.4.0/testsuite/test_bounded.ml000066400000000000000000000037171415601150500223350ustar00rootroot00000000000000open BatPervasives module R = BatRandom module U = OUnit module Int10_base = struct type base_t = int type t = int option let bounds = `c 1, `c 10 let bounded = BatBounded.opt_of_ord BatInt.ord let base_of_t x = x let base_of_t_exn x = BatOption.get x module Infix = BatInt.Infix end (** Only accept integers between 1 and 10, inclusive *) module Int10 = BatBounded.MakeNumeric(Int10_base) module Float10_base = struct type base_t = float type t = float option let bounds = `o 1.0, `o 10.0 let bounded = BatBounded.opt_of_ord BatFloat.ord let base_of_t x = x let base_of_t_exn x = BatOption.get x module Infix = BatFloat.Infix end (** Only accept floating point values between 1 and 10, exclusive *) module Float10 = BatBounded.MakeNumeric(Float10_base) let assert_make (type s) m to_string (xs : s list) = let module B = ( val m : BatBounded.NumericSig with type base_u = s and type u = s option ) in let min_bound, max_bound = B.bounds in let min_check = match min_bound with | `o a -> (fun x -> x > a) | `c a -> (fun x -> x >= a) | `u -> (const true) in let max_check = match max_bound with | `o a -> (fun x -> x < a) | `c a -> (fun x -> x <= a) | `u -> (const true) in List.iter ( fun x -> let printer b = Printf.sprintf "%s (%b)" (to_string x) b in U.assert_equal ~printer (max_check x && min_check x) (BatOption.is_some ((B.make %> B.extract) x)) ) xs; () let test_make () = let xs = BatList.init 100 identity in let m = (module Int10 : BatBounded.NumericSig with type base_u = int and type u = int option) in assert_make m string_of_int xs; let xs = BatList.init 110 (fun x -> float_of_int x /. 10.0) in let m = (module Float10 : BatBounded.NumericSig with type base_u = float and type u = float option) in assert_make m string_of_float xs let (>::), (>:::) = U.(>::), U.(>:::) let tests = "Bounded" >::: [ "value creation" >:: test_make ] batteries-included-3.4.0/testsuite/test_container.ml000066400000000000000000001126751415601150500227030ustar00rootroot00000000000000open OUnit module type Container = sig type 'a t val iter : ('a -> unit) -> 'a t -> unit val iter_right : ('a -> unit) -> 'a t -> unit val map : ('a -> 'b) -> 'a t -> 'b t val map_right : ('a -> 'b) -> 'a t -> 'b t val fold_left : ('acc -> 'a -> 'acc) -> 'acc -> 'a t -> 'acc val fold_lefti : (int -> 'acc -> 'a -> 'acc) -> 'acc -> 'a t -> 'acc val fold_right : ('acc -> 'a -> 'acc) -> 'acc -> 'a t -> 'acc val enum : 'a t -> 'a BatEnum.t val backwards : 'a t -> 'a BatEnum.t val of_enum : 'a BatEnum.t -> 'a t val of_backwards : 'a BatEnum.t -> 'a t val length : 'a t -> int val iteri : (int -> 'a -> unit) -> 'a t -> unit val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t val exists : ('a -> bool) -> 'a t -> bool val for_all : ('a -> bool) -> 'a t -> bool val filter : ('a -> bool) -> 'a t -> 'a t val filter_map : ('a -> 'b option) -> 'a t -> 'b t val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> 'a t val update : 'a t -> int -> ('a -> 'a) -> 'a t val append : 'a t -> 'a t -> 'a t val last : 'a t -> 'a val of_list : 'a list -> 'a t val to_list : 'a t -> 'a list val of_array : 'a array -> 'a t val to_array : 'a t -> 'a array val of_list_backwards : 'a list -> 'a t val to_list_backwards : 'a t -> 'a list val cons : 'a t -> 'a -> 'a t val snoc : 'a t -> 'a -> 'a t val tail : 'a t -> 'a t val init : 'a t -> 'a t val hd : 'a t -> 'a val find : ('a -> bool) -> 'a t -> 'a val find_right : ('a -> bool) -> 'a t -> 'a val is_empty : _ t -> bool val printer_delim : string * string val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> 'b -> unit) -> 'a BatInnerIO.output -> 'b t -> unit val invariants : _ t -> unit val insert : 'a t -> int -> 'a -> 'a t val delete : 'a t -> int -> 'a t val delete_range : 'a t -> int -> int -> 'a t val build : int -> (int -> 'a) -> 'a t val mem : 'a t -> 'a -> bool val memq : 'a t -> 'a -> bool val partition : ('a -> bool) -> 'a t -> 'a t * 'a t val find_index : ('a -> bool) -> 'a t -> int val reduce_left : ('a -> 'a -> 'a) -> 'a t -> 'a val make : int -> 'a -> 'a t (* sort, stable_sort, split_at, iter2, for_all2, take, drop, find_map, reduce, max, min, reverse *) end exception NotImplemented let ni1 = fun _ -> raise NotImplemented let ni2 = fun _ _ -> raise NotImplemented let ni3 = fun _ _ _ -> raise NotImplemented let ni4 = fun _ _ _ _ -> raise NotImplemented let ni_print ?first:_ ?last:_ ?sep:_ = ni3 module DllistContainer : Container = struct include BatDllist let fold_right f acc t = fold_right (fun acc elt -> f elt acc) t acc and hd = get and get l i = if i < 0 || i >= length l then raise Exit else get (skip l i) and snoc l x = let l = copy l in ignore (append (prev l) x); l and cons l x = let l = copy l in prepend l x and append l1 l2 = let l1 = copy l1 in let l2 = copy l2 in splice (prev l1) l2; l1 and init = ni1 and tail = ni1 and to_list_backwards = ni1 and of_list_backwards = ni1 and last = ni1 and mapi = ni2 and iteri = ni2 and of_backwards = ni1 and map_right = ni2 and iter_right = ni2 and find f t = get (find f t) and find_right = ni2 and is_empty = ni1 and printer_delim = ("","") and set = ni3 and insert = ni3 and delete = ni2 and delete_range = ni3 and of_array = ni1 and to_array = ni1 and update = ni3 and fold_lefti = ni3 and build = ni2 and mem = ni2 and memq = ni2 and partition = ni2 and find_index = ni2 and reduce_left = ni2 and make = ni2 end module ArrayContainer : Container = struct include BatArray let map_right = ni2 let iter_right = ni2 let fold_right f acc t = fold_right (fun acc elt -> f elt acc) t acc let last = ni1 let of_list_backwards = ni1 let to_list_backwards = ni1 let hd = ni1 let snoc = ni1 let cons = ni1 let tail = ni1 let init = ni1 and find_right = ni2 and is_empty = ni1 and printer_delim = ("[|", "|]") and invariants = ignore and set t i v = let t = Array.copy t in set t i v; t and insert = ni3 and delete = ni2 and delete_range = ni3 and of_array = ni1 and to_array = ni1 and update = ni3 and fold_lefti = ni3 and build = init and mem t x = mem x t and memq t x = memq x t and partition = ni2 and find_index = findi and reduce_left = ni2 end module LazyListContainer : Container = struct include BatLazyList let map_right = ni2 let iter_right = ni2 let fold_right f acc t = fold_right (fun acc elt -> f elt acc) acc t let of_backwards = ni1 let backwards = ni1 let get = at let to_list_backwards = ni1 let of_list_backwards = ni1 let tail = ni1 let snoc = ni1 let cons t x = cons x t let init = ni1 and find_right = ni2 and printer_delim = ("","") and invariants = ignore and set = ni3 and insert = ni3 and delete = ni2 and delete_range = ni3 and of_array = ni1 and to_array = ni1 and update = ni3 and fold_lefti = ni3 and build = init and mem t x = mem x t and memq t x = memq x t and partition = ni2 and find_index = ni2 and reduce_left = ni2 end module DynArrayContainer = struct include BatDynArray let of_backwards = ni1 let backwards = ni1 let iter_right = ni2 let map_right = ni2 let fold_right f acc t = fold_right (fun acc elt -> f elt acc) t acc let exists = ni2 let for_all = ni2 let append t1 t2 = let t1 = copy t1 in append t2 t1; t1 let to_list_backwards = ni1 let of_list_backwards = ni1 let hd = ni1 let tail = ni1 let snoc t x = let t = copy t in add t x; t let cons = ni2 let init = ni1 let find f t = get t (index_of f t) and find_right = ni2 and is_empty = empty and printer_delim = ("[|", "|]") and set t i v = let t = copy t in set t i v; t and insert t i v = let t = copy t in insert t i v; t and delete t i = let t = copy t in delete t i; t and delete_range t i len = let t = copy t in delete_range t i len; t and update = ni3 and fold_lefti = ni3 and build = init and mem = ni2 and memq = ni2 and partition = ni2 and find_index = ni2 and reduce_left = ni2 and make = ni2 end module DynArrayContainerStepResizer : Container = struct include DynArrayContainer let of_enum e = (* much simpler to see what happens when resizing code with this and what happens when not resizing with the previous module *) let a = of_enum e in set_resizer a (step_resizer 1); a end module DynArrayContainerCrapResizer : Container = struct include DynArrayContainer let crap_resizer ~currslots:_ ~oldlength:_ ~newlength:_ = -1 let of_enum e = let a = of_enum e in set_resizer a crap_resizer; a end module DequeContainer : Container = struct include BatDeque let length = size and of_backwards = ni1 and backwards = ni1 and iter_right = ni2 and map_right = ni2 and fold_right f acc t = fold_right (fun acc elt -> f elt acc) t acc and exists = ni2 and for_all = ni2 and filter = ni2 and filter_map = ni2 and get t n = let elt1 = at ~backwards:false t n in let elt2 = at ~backwards:true t (size t - 1 - n) in assert (elt1 = elt2); BatOption.get elt1 and last q = match rear q with None -> raise Exit | Some (_, e) -> e and to_list_backwards = ni1 and of_list_backwards = ni1 and hd t = match front t with Some (hd, _) -> hd | None -> raise Exit and tail t = match front t with Some (_, tl) -> tl | None -> raise Exit and init t = match rear t with Some (tl, _) -> tl | None -> raise Exit and cons t x = cons x t and find f t = match find ~backwards:false f t with | None -> raise Not_found | Some (_, x) -> x and find_right f t = match find ~backwards:true f t with | None -> raise Not_found | Some (_, x) -> x and append t1 t2 = let res1 = append t1 t2 in let res2 = append_list t1 (to_list t2) in let res3 = prepend_list (to_list t1) t2 in assert_equal (to_list res1) (to_list res2); assert_equal (to_list res1) (to_list res3); res1 and of_enum e = let orig = of_enum (BatEnum.clone e) in let n = BatEnum.count e in let l = BatList.of_enum e in let l1, l2 = BatList.split_at (n / 2) l in let q = prepend_list l1 (append_list empty l2) in assert_equal (to_list orig) (to_list q); q and printer_delim = ("[", "]") and set = ni3 and insert = ni3 and delete = ni2 and delete_range = ni3 and of_array = ni1 and to_array = ni1 and update = ni3 and fold_lefti = ni3 and build = ni2 and mem = ni2 and memq = ni2 and partition = ni2 and find_index = ni2 and reduce_left = ni2 and make = ni2 end module ListContainer : Container = struct include BatList let map_right = ni2 let iter_right = ni2 let fold_right f acc t = fold_right (fun acc elt -> f elt acc) t acc let get = at let to_list_backwards = ni1 let of_list_backwards = ni1 let of_list = ni1 let to_list = ni1 let tail = tl let snoc = ni2 let cons t x = cons x t let init = ni1 and find_right = ni2 and printer_delim = ("[", "]") and invariants = ignore and set = ni3 and insert = ni3 and delete = ni2 and delete_range = ni3 and of_array = ni1 and to_array = ni1 and update = ni3 and fold_lefti = ni3 and build = init and mem t x = mem x t and memq t x = memq x t and find_index p l = fst (findi (fun _ v -> p v) l) and reduce_left = reduce end module RefListContainer : Container = struct include BatRefList let map_right = ni2 let iter_right = ni2 let fold_right f acc t = fold_right (fun acc elt -> f elt acc) t acc let mapi = ni2 let iteri = ni2 let filter f l = let t = of_list (to_list l) in filter f t; t let filter_map = ni2 let get = Index.at_index let append = ni2 let to_list_backwards = ni1 let of_list_backwards = ni1 let cons t x = let t = of_list (to_list t) in push t x; t let snoc t x = let t = of_list (to_list t) in add t x; t let init = ni1 let tail = tl and find_right = ni2 and printer_delim = ("","") and print = ni_print and invariants = ignore and set = ni3 and insert = ni3 and delete = ni2 and delete_range = ni3 and of_array = ni1 and to_array = ni1 and update = ni3 and fold_lefti = ni3 and build = ni2 and mem = ni2 and memq = ni2 and partition = ni2 and find_index = ni2 and reduce_left = ni2 and make = ni2 end module VectContainer : Container = struct include BatVect let map_right = ni2 and iter_right = ni2 and fold_right f acc t = fold_right (fun acc elt -> f elt acc) t acc and append = concat and to_list_backwards = ni1 and of_list_backwards = ni1 and cons t x = prepend x t and snoc t x = append x t and hd = first and tail t = snd (shift t) and init t = snd (pop t) and find_right = ni2 and printer_delim = ("","") and insert t i v = insert i (singleton v) t and delete = ni2 and delete_range t i len = remove i len t and invariants t = invariants t; invariants (balance t) (* so that balance is called without having to test it specifically *) and update = modify and fold_lefti = foldi and set t i v = try let t' = set t i v in let old_v = get t i in try destructive_set t i v; assert (BatEnum.equal (=) (enum t) (enum t')); destructive_set t i old_v; t' with Out_of_bounds -> assert false with Out_of_bounds -> ignore (destructive_set t i v); assert false and build = init and mem t x = mem x t and memq t x = memq x t and find_index = findi and reduce_left = reduce end module FunctorVectContainer : Container = struct include BatVect.Make(struct include BatDynArray let empty = Obj.magic (create ()) let rev a = let module Array = BatDynArray in let n = length a in for i = 0 to (n / 2) - 1 do let tmp = a.(i) in a.(i) <- a.(n - 1 - i); a.(n - 1 - i) <- tmp; done let of_backwards e = let a = of_enum e in rev a; a let backwards a = rev a; let e = enum a in BatEnum.force e; rev a; e let concat = function | [] -> empty | h :: t -> let h = copy h in List.iter (fun elt -> append elt h) t; h let append a1 a2 = concat [a1;a2] let make i x = init i (fun _ -> x) end)(struct let max_height = 18 let leaf_size = 12 end) let map_right = ni2 and iter_right = ni2 and fold_right f acc t = fold_right (fun acc elt -> f elt acc) t acc and append = concat and to_list_backwards = ni1 and of_list_backwards = ni1 and cons t x = prepend x t and snoc t x = append x t and hd = first and tail t = snd (shift t) and init t = snd (pop t) and find_right = ni2 and printer_delim = ("","") and insert t i v = insert i (singleton v) t and delete = ni2 and delete_range t i len = remove i len t and invariants t = invariants t; invariants (balance t) and update = modify and fold_lefti = foldi and set t i v = try let t' = set t i v in let old_v = get t i in try destructive_set t i v; assert (BatEnum.equal (=) (enum t) (enum t')); destructive_set t i old_v; t' with Out_of_bounds -> assert false with Out_of_bounds -> ignore (destructive_set t i v); assert false and build = init and mem t x = mem x t and memq t x = memq x t and find_index = findi and reduce_left = reduce end module FingerTreeContainer : Container = struct include BatFingerTree let length = size let mapi = ni2 let iteri = ni2 let exists = ni2 let for_all = ni2 let filter = ni2 let filter_map = ni2 let last = last_exn let hd = head_exn let init = init_exn let tail = tail_exn let find = ni2 and find_right = ni2 and printer_delim = ("[", "]") and insert = ni3 and delete = ni2 and delete_range = ni3 and of_array = ni1 and to_array = ni1 and fold_lefti = ni3 and build = ni2 and mem = ni2 and memq = ni2 and partition = ni2 and find_index = ni2 and reduce_left = ni2 and make = ni2 end module SeqContainer : Container = struct include BatSeq let iter_right = ni2 let map_right = ni2 let fold_right f acc t = fold_right (fun acc elt -> f elt acc) t acc let backwards = ni1 let rec of_enum e = fun () -> let e = BatEnum.clone e in match BatEnum.get e with | None -> nil () | Some v -> Cons (v, of_enum e) let of_backwards = ni1 let mapi = ni2 let iteri = ni2 let get = at let to_list_backwards = ni1 let of_list_backwards = ni1 let of_list = ni1 let to_list = ni1 let tail = tl let init = ni1 let snoc = ni1 let cons t x = cons x t let hd e = let x = try Some (hd e) with Assert_failure _ as e -> raise e | _ -> None in let y = try Some (first e) with Assert_failure _ as e -> raise e | _ -> None in assert (x = y); match x with None -> raise Exit | Some e -> e let find f t = BatOption.get (find f t) and find_right = ni2 and printer_delim = ("[", "]") and invariants = ignore and set = ni3 and insert = ni3 and delete = ni2 and delete_range = ni3 and of_array = ni1 and to_array = ni1 and update = ni3 and fold_lefti = ni3 and build = init and memq = ni2 and partition = ni2 and find_index = ni2 and reduce_left = reduce and mem t x = mem x t end module BatArray = struct include BatArray let not_countable_enum a = let e = enum a in BatEnum.from (fun () -> BatEnum.get_exn e) end module TestContainer(C : Container) : sig end = struct let n = 100 let a = Array.init n (fun i -> i) let rev_a = Array.init n (fun i -> n - 1 - i) let c = C.of_enum (BatArray.enum a) let rev_c = C.of_enum (BatArray.enum rev_a) let inv = C.invariants let () = inv c; inv rev_c let empty : 'a C.t Lazy.t = try let s = C.of_enum (BatArray.enum [||]) in inv s; (* working around a caml bug: lazy [||] segfaults *) Obj.magic s with BatDllist.Empty -> lazy (raise BatDllist.Empty) let repeat_twice f = try (* repeating twice in case the structure mutates itself when doing operations on it *) f (); f () with NotImplemented -> () let () = repeat_twice (fun () -> assert (C.length c = n); try assert_equal 0 (C.length (Lazy.force empty)) with BatDllist.Empty -> () ) let () = repeat_twice (fun () -> let i = ref (-1) in C.iter (fun elt -> incr i; assert (!i = elt)) c; assert (!i = n - 1); try C.iter (fun _ -> assert false) (Lazy.force empty) with BatDllist.Empty -> () ) let () = repeat_twice (fun () -> let i = ref (-1) in C.iteri (fun idx elt -> incr i; assert (!i = idx); assert (!i = elt)) c; assert (!i = n - 1); try C.iteri (fun _ -> assert false) (Lazy.force empty); with BatDllist.Empty -> () ) let () = repeat_twice (fun () -> let i = ref n in C.iter_right (fun elt -> decr i; assert (!i = elt)) c; assert (!i = 0); try C.iter_right (fun _ -> assert false) (Lazy.force empty) with BatDllist.Empty -> () ) let () = repeat_twice (fun () -> let c = C.build n (fun i -> i + 1) in inv c; let i = ref (-1) in (try C.iter (fun elt -> incr i; assert (!i + 1 = elt)) c; with NotImplemented -> failwith "build and not iter??"); assert (!i = n - 1); assert_equal 0 (C.length (C.build 0 (fun _ -> assert false))); assert ( try ignore (C.build (-1) (fun _ -> ())); false with Assert_failure _ as e -> raise e | _ -> true ) ) let () = repeat_twice (fun () -> let c = C.make n (-42) in inv c; let i = ref (-1) in (try C.iter (fun elt -> incr i; assert (elt = -42)) c; with NotImplemented -> failwith "make and not iter??"); assert (!i = n - 1); assert_equal 0 (C.length (C.make 0 (-42))); assert ( try ignore (C.make (-1) (-42)); false with Assert_failure _ as e -> raise e | _ -> true ) ) let () = repeat_twice (fun () -> let i = ref (-1) in let c = C.map (fun elt -> incr i; assert (!i = elt); elt + 1) c in inv c; let i = ref (-1) in (try C.iter (fun elt -> incr i; assert (!i + 1 = elt)) c; with NotImplemented -> failwith "map and not iter??"); assert (!i = n - 1); try assert_equal 0 (C.length (C.map (fun _ -> assert false) (Lazy.force empty))) with BatDllist.Empty -> () ) let () = repeat_twice (fun () -> let i = ref (-1) in let c = C.mapi (fun idx elt -> incr i; assert (!i = idx); assert (!i = elt); elt + 1) c in inv c; let i = ref (-1) in (try C.iteri (fun idx elt -> incr i; assert (!i = idx); assert (!i + 1 = elt)) c; with NotImplemented -> failwith "mapi and not iteri??"); assert (!i = n - 1); try assert_equal 0 (C.length (C.mapi (fun _ -> assert false) (Lazy.force empty))) with BatDllist.Empty -> () ) let () = repeat_twice (fun () -> let i = ref n in let c = C.map_right (fun elt -> decr i; assert (!i = elt); elt + 1) c in inv c; let i = ref n in (try C.iter_right (fun elt -> decr i; assert (!i + 1 = elt)) c; with NotImplemented -> failwith "map_right and not iter_right??"); assert (!i = 0); try assert_equal 0 (C.length (C.map_right (fun _ -> assert false) (Lazy.force empty))) with BatDllist.Empty -> () ) let () = repeat_twice (fun () -> let i = ref (-1) in let acc = 0 in let acc = C.fold_left (fun acc elt -> incr i; assert (!i = elt); acc + 1) acc c in assert (!i = n - 1); assert (acc = n); try ignore (C.fold_left (fun _ -> assert false) 0 (Lazy.force empty)) with BatDllist.Empty -> () ) let () = repeat_twice (fun () -> let i = ref 0 in let acc = C.reduce_left (fun acc elt -> incr i; assert (acc = !i - 1); assert (!i = elt); acc + 1) c in assert (!i = n - 1); assert (acc = n - 1); try ignore (C.reduce_left (fun _ -> assert false) (Lazy.force empty)); assert false with | Assert_failure _ as e -> raise e | _ -> () ) let () = repeat_twice (fun () -> let i = ref (-1) in let acc = 0 in let acc = C.fold_lefti (fun index acc elt -> incr i; assert (!i = elt); assert (!i = index); acc + 1) acc c in assert (!i = n - 1); assert (acc = n); try ignore (C.fold_lefti (fun _ -> assert false) 0 (Lazy.force empty)) with BatDllist.Empty -> () ) let () = repeat_twice (fun () -> let i = ref n in let acc = 0 in let acc = C.fold_right (fun acc elt -> decr i; assert (!i = elt); acc + 1) acc c in assert (!i = 0); assert (acc = n); try ignore (C.fold_right (fun _ -> assert false) 0 (Lazy.force empty)) with BatDllist.Empty -> () ) let () = repeat_twice (fun () -> let e = C.enum c in for i = 0 to n / 2 - 1 do assert (i = BatEnum.get_exn e) done; let e' = BatEnum.clone e in assert_equal (BatEnum.count e) (BatEnum.count e'); for i = n / 2 to n - 1 do assert (i = BatEnum.get_exn e && i = BatEnum.get_exn e') done; assert (BatEnum.is_empty e && BatEnum.is_empty e'); assert (BatEnum.get e = None); assert (BatEnum.get e' = None) ) let () = repeat_twice (fun () -> let e = C.backwards c in for i = 0 to n / 2 - 1 do assert (n - 1 - i = BatEnum.get_exn e) done; let e' = BatEnum.clone e in assert (BatEnum.count e = BatEnum.count e'); for i = n / 2 to n - 1 do assert (n - 1 - i = BatEnum.get_exn e && n - 1 - i = BatEnum.get_exn e') done; assert (BatEnum.is_empty e && BatEnum.is_empty e'); assert (BatEnum.get e = None); assert (BatEnum.get e' = None) ) let () = repeat_twice (fun () -> let c = C.of_enum (BatArray.not_countable_enum a) in inv c; repeat_twice (fun () -> assert (C.length c = n)); repeat_twice (fun () -> let i = ref (-1) in C.iter (fun elt -> incr i; assert (!i = elt)) c; assert (!i = n - 1) ) ) let () = repeat_twice (fun () -> let c = C.of_backwards (BatArray.enum rev_a) in inv c; repeat_twice (fun () -> assert (C.length c = n)); repeat_twice (fun () -> let i = ref (-1) in C.iter (fun elt -> incr i; assert (!i = elt)) c; assert (!i = n - 1) ) ) let () = repeat_twice (fun () -> let c = C.of_backwards (BatArray.not_countable_enum rev_a) in inv c; repeat_twice (fun () -> assert (C.length c = n)); repeat_twice (fun () -> let i = ref (-1) in C.iter (fun elt -> incr i; assert (!i = elt)) c; assert (!i = n - 1) ) ) let () = repeat_twice (fun () -> assert (C.for_all (fun elt -> elt < n) c); let i = ref (-1) in assert (not (C.for_all (fun elt -> incr i; elt < n/2) c)); assert (!i = n/2); try ignore (C.for_all (fun _ -> assert false) (Lazy.force empty)) with BatDllist.Empty -> () ) let () = repeat_twice (fun () -> assert (not (C.exists (fun elt -> not (elt < n)) c)); let i = ref (-1) in assert (C.exists (fun elt -> incr i; not (elt < n/2)) c); assert (!i = n/2); try ignore (C.exists (fun _ -> assert false) (Lazy.force empty)) with BatDllist.Empty -> () ) let () = repeat_twice (fun () -> let i = ref (-1) in let c2 = C.filter (fun elt -> incr i; if not (elt = !i) then assert false; elt mod 2 = 0) c in inv c2; let j = ref (-1) in C.iter (fun elt -> incr j; assert (!j * 2 = elt)) c2; assert (!i = n - 1); assert (!j = n / 2 - 1); (* iterating first to force the sequence of lazy sequence before checking the number of elements traversed *) try ignore (C.filter (fun _ -> assert false) (Lazy.force empty)) with BatDllist.Empty -> () ) let () = repeat_twice (fun () -> let i = ref (-1) in let c2 = C.filter_map (fun elt -> incr i; assert (elt = !i); if elt mod 2 = 0 then Some (-(elt / 2)) else None) c in inv c2; let j = ref (-1) in C.iter (fun elt -> incr j; assert (!j = -elt)) c2; assert (!i = n - 1); assert (!j = n / 2 - 1); try ignore (C.filter_map (fun _ -> assert false) (Lazy.force empty)) with BatDllist.Empty -> () ) let () = repeat_twice (fun () -> let i = ref (-1) in let c2, c3 = C.partition (fun elt -> incr i; if not (elt = !i) then assert false; elt mod 3 = 0) c in inv c2; inv c3; let j = ref (-1) in C.iter (fun elt -> incr j; assert (!j * 3 = elt)) c2; let k = ref (-1) in C.iter (fun elt -> incr k; assert (3 * (!k / 2) + (!k mod 2) + 1 = elt)) c3; assert_equal ~printer:string_of_int (n - 1) !i; assert_equal ~printer:string_of_int ((n + 2) / 3 - 1) !j; assert_equal ~printer:string_of_int n ((!j + 1) + (!k + 1)); (* iterating first to force the sequence of lazy sequence before checking the number of elements traversed *) try ignore (C.partition (fun _ -> assert false) (Lazy.force empty)) with BatDllist.Empty -> () ) let () = repeat_twice (fun () -> assert (C.last c = n - 1); assert (try ignore (C.last (C.of_enum (BatEnum.empty ()))); false with Assert_failure _ as e -> raise e | _ -> true) ) let () = repeat_twice (fun () -> assert (C.hd c = 0); assert (try ignore (C.hd (C.of_enum (BatEnum.empty ()))); false with Assert_failure _ as e -> raise e | _ -> true) ) let () = repeat_twice (fun () -> let c2 = C.append c rev_c in inv c2; assert (C.length c2 = n * 2); let i = ref (-1) in C.iter (fun elt -> incr i; assert (elt = min !i (2 * n - 1 - !i))) c2; assert (!i = 2 * n - 1); let c2 = C.append c (C.append c c) in inv c2; assert (C.length c2 = n * 3); let i = ref (-1) in C.iter (fun elt -> incr i; assert (elt = !i mod n)) c2; assert (!i = 3 * n - 1); let c2 = C.append (C.append c c) c in inv c2; assert (C.length c2 = n * 3); let i = ref (-1) in C.iter (fun elt -> incr i; assert (elt = !i mod n)) c2; assert (!i = 3 * n - 1); let c2 = C.append c (C.of_enum (BatList.enum [n; n+1])) in inv c2; let i = ref (-1) in C.iter (fun elt -> incr i; assert (elt = !i)) c2; assert (!i = n + 1); let c2 = C.append (C.of_enum (BatList.enum [-2; -1])) c in inv c2; let i = ref (-3) in C.iter (fun elt -> incr i; assert (elt = !i)) c2; assert (!i = n - 1); ) let () = repeat_twice (fun () -> for i = 0 to n - 1 do assert_equal ~printer:string_of_int i (C.get c i) done; assert (try ignore (C.get c (-1)); false with Assert_failure _ as e -> raise e | _ -> true); assert (try ignore (C.get c n); false with Assert_failure _ as e -> raise e | _ -> true); ) let () = repeat_twice (fun () -> for i = 0 to n - 1 do let c2 = C.set c i (-1) in inv c2; let idx = ref (-1) in C.iteri (fun j v -> incr idx; assert_equal j !idx; assert_equal ~printer:string_of_int (if i = j then (-1) else j) v ) c2; assert_equal ~printer:string_of_int (n - 1) !idx; done; assert (try ignore (C.set c (-1) (-1)); false with Assert_failure _ as e -> raise e | _ -> true); assert (try ignore (C.set c n (-1)); false with Assert_failure _ as e -> raise e | _ -> true); (try assert ( try ignore (C.set (Lazy.force empty) (-1) (-1)); false with Assert_failure _ as e -> raise e | _ -> true ) with BatDllist.Empty -> ()); (try assert ( try ignore (C.set (Lazy.force empty) 0 (-1)); false with Assert_failure _ as e -> raise e | _ -> true ) with BatDllist.Empty -> ()); ) let () = repeat_twice (fun () -> for i = 0 to n - 1 do let c2 = C.update c i (fun i -> -i) in inv c2; let idx = ref (-1) in C.iteri (fun j v -> incr idx; assert_equal j !idx; assert_equal ~printer:string_of_int (if i = j then (-i) else j) v ) c2; assert_equal ~printer:string_of_int (n - 1) !idx; done; assert (try ignore (C.update c (-1) (fun _ -> -1)); false with Assert_failure _ as e -> raise e | _ -> true); assert (try ignore (C.update c n (fun _ -> -1)); false with Assert_failure _ as e -> raise e | _ -> true); (try assert ( try ignore (C.update (Lazy.force empty) (-1) (fun _ -> -1)); false with Assert_failure _ as e -> raise e | _ -> true ) with BatDllist.Empty -> ()); (try assert ( try ignore (C.update (Lazy.force empty) 0 (fun _ -> -1)); false with Assert_failure _ as e -> raise e | _ -> true ) with BatDllist.Empty -> ()); ) let () = repeat_twice (fun () -> for i = 0 to n do let c2 = C.insert c i (-1) in inv c2; let idx = ref (-1) in C.iteri (fun j v -> incr idx; assert_equal j !idx; assert_equal ~printer:string_of_int (if i = j then (-1) else if i > j then j else j - 1) v ) c2; assert_equal ~printer:string_of_int n !idx; let c3 = C.insert c2 (i / 2) (-2) in inv c3; let idx = ref (-1) in C.iteri (fun j v -> incr idx; assert_equal j !idx; assert_equal ~printer:string_of_int (if j < i / 2 then j else if j = i / 2 then (-2) else if j - 1 < i then j - 1 else if j - 1 = i then (-1) else j - 2 ) v ) c3; assert_equal ~printer:string_of_int (n + 1) !idx; done; assert (try ignore (C.insert c (-1) (-1)); false with Assert_failure _ as e -> raise e | _ -> true); assert (try ignore (C.insert c (n + 1) (-1)); false with Assert_failure _ as e -> raise e | _ -> true); ) let () = repeat_twice (fun () -> for i = 0 to n - 1 do let c2 = C.delete c i in inv c2; let idx = ref (-1) in C.iteri (fun j v -> incr idx; assert_equal j !idx; assert_equal ~printer:string_of_int (if i > j then j else j + 1) v ) c2; assert_equal ~printer:string_of_int (n - 2) !idx; let c3 = C.delete c2 (i / 2) in inv c3; let idx = ref (-1) in C.iteri (fun j v -> incr idx; assert_equal j !idx; assert_equal ~printer:string_of_int (if j < i / 2 then j else if j + 1 < i then j + 1 else j + 2) v ) c3; assert_equal ~printer:string_of_int (n - 3) !idx; done; assert (try ignore (C.delete c (-1)); false with Assert_failure _ as e -> raise e | _ -> true); assert (try ignore (C.delete c n); false with Assert_failure _ as e -> raise e | _ -> true); ) let () = repeat_twice (fun () -> assert (try ignore (C.delete_range c (-1) 1); false with Assert_failure _ as e -> raise e | _ -> true); assert (try ignore (C.delete_range c n 1); false with Assert_failure _ as e -> raise e | _ -> true); assert (try ignore (C.delete_range c 0 (-1)); false with Assert_failure _ as e -> raise e | _ -> true); assert (try ignore (C.delete_range c 1 n); false with Assert_failure _ as e -> raise e | _ -> true); assert (C.is_empty (C.delete_range c 0 n)); (* could check what happens with an empty range *) for i = 0 to n / 2 - 1 do let start = i in let len = min (1 + i * 2) (n - start) in let c2 = C.delete_range c start len in inv c2; let idx = ref (-1) in C.iteri (fun j v -> incr idx; assert_equal j !idx; assert_equal ~printer:string_of_int (if start > j then j else j + len) v ) c2; assert_equal ~printer:string_of_int (n - 1 - len) !idx; done; ) let () = repeat_twice (fun () -> assert (C.to_list c = Array.to_list a); (try assert (C.to_list (Lazy.force empty) = []) with BatDllist.Empty -> ()); ) let () = repeat_twice (fun () -> let c = C.of_list (Array.to_list a) in inv c; assert (Array.of_list (C.to_list c) = a) ) let () = repeat_twice (fun () -> let c = C.of_array a in inv c; assert (C.to_array c = a) ) let () = repeat_twice (fun () -> assert (C.to_list_backwards c = List.rev (Array.to_list a)) ) let () = repeat_twice (fun () -> let c = C.of_list_backwards (Array.to_list a) in inv c; assert (Array.of_list (List.rev (C.to_list c)) = a) ) let () = repeat_twice (fun () -> let c = C.snoc c n in inv c; assert (C.length c = n + 1); let i = ref (-1) in C.iter (fun elt -> incr i; assert (!i = elt)) c; assert (!i = n) ) let () = repeat_twice (fun () -> let c = C.cons c (-1) in inv c; assert (C.length c = n + 1); let i = ref (-2) in C.iter (fun elt -> incr i; assert (!i = elt)) c; assert (!i = n - 1) ) let () = repeat_twice (fun () -> let c = C.tail c in inv c; assert (C.length c = n - 1); let i = ref 0 in C.iter (fun elt -> incr i; assert (!i = elt)) c; assert (!i = n - 1); assert ( try ignore (C.tail (C.of_enum (BatEnum.empty ()))); false with Assert_failure _ as e -> raise e | _ -> true ) ) let () = repeat_twice (fun () -> let c = C.init c in inv c; assert (C.length c = n - 1); let i = ref (-1) in C.iter (fun elt -> incr i; assert (!i = elt)) c; assert (!i = n - 2); assert ( try ignore (C.init (C.of_enum (BatEnum.empty ()))); false with Assert_failure _ as e -> raise e | _ -> true ) ) let () = repeat_twice (fun () -> let a = Array.init n (fun i -> (i, i)) in let c = C.of_enum (BatArray.enum a) in assert (C.mem c (n/2, n/2)); assert (not (C.mem c (0,1))); (try assert (not (C.mem (Lazy.force empty) 0)) with BatDllist.Empty -> ()); ) let () = repeat_twice (fun () -> let a = Array.init n (fun i -> ref i) in let c = C.of_enum (BatArray.enum a) in assert (C.memq c a.(n/2)); assert (not (C.memq c (ref (n/2)))); (try assert (not (C.memq (Lazy.force empty) 0)) with BatDllist.Empty -> ()); ) let () = repeat_twice (fun () -> let i = ref (-1) in let elt = C.find (fun elt -> incr i; assert (!i = elt); elt = n/2) c in assert (elt = n/2); assert (!i = n/2); assert (try ignore (C.find (fun _ -> false) c); false with Assert_failure _ as e -> raise e | _ -> true); assert (try ignore (C.find (fun _ -> assert false) (Lazy.force empty)); false with Assert_failure _ as e -> raise e | _ -> true); ) let () = repeat_twice (fun () -> let i = ref (-1) in let index = C.find_index (fun elt -> incr i; assert (!i = elt); elt = n/2) c in assert (index = n/2); assert (!i = n/2); assert (try ignore (C.find_index (fun _ -> false) c); false with Assert_failure _ as e -> raise e | _ -> true); assert (try ignore (C.find_index (fun _ -> assert false) (Lazy.force empty)); false with Assert_failure _ as e -> raise e | _ -> true); ) let () = repeat_twice (fun () -> let i = ref n in let elt = C.find_right (fun elt -> decr i; assert (!i = elt); elt = n/2) c in assert (elt = n/2); assert (!i = n/2); assert (try ignore (C.find_right (fun _ -> false) c); false with Assert_failure _ as e -> raise e | _ -> true); assert (try ignore (C.find_right (fun _ -> assert false) (Lazy.force empty)); false with Assert_failure _ as e -> raise e | _ -> true); ) let () = try repeat_twice (fun () -> assert_equal true (C.is_empty (C.of_enum (BatList.enum []))); assert_equal false (C.is_empty (C.of_enum (BatList.enum [1]))); assert_equal false (C.is_empty (C.of_enum (BatList.enum [1;2]))); assert_equal false (C.is_empty (C.of_enum (BatList.enum [1;2;3]))); assert_equal false (C.is_empty c); ) with BatDllist.Empty -> () let () = repeat_twice (fun () -> let stringify l = try let c = C.of_enum (BatList.enum l) in inv c; BatIO.to_string (C.print ~sep:"," ~first:"<" ~last:">" BatInt.print) c with BatDllist.Empty -> "<>" in assert_equal "<2,4,66>" (stringify [2;4;66]); assert_equal "<2>" (stringify [2]); assert_equal "<>" (stringify []); ) end let tests = "Container" >::: [ "List" >:: (fun () -> let module M = TestContainer(ListContainer) in ()); "RefList" >:: (fun () -> let module M = TestContainer(RefListContainer) in ()); "Seq" >:: (fun () -> let module M = TestContainer(SeqContainer) in ()); "Vect" >:: (fun () -> let module M = TestContainer(VectContainer) in ()); "FunctorVect" >:: (fun () -> let module M = TestContainer(FunctorVectContainer) in ()); "FingerTree" >:: (fun () -> let module M = TestContainer(FingerTreeContainer) in ()); "Array" >:: (fun () -> let module M = TestContainer(ArrayContainer) in ()); "DynArray" >:: (fun () -> let module M = TestContainer(DynArrayContainer) in ()); "DynArrayStepResizer" >:: (fun () -> let module M = TestContainer(DynArrayContainerStepResizer) in ()); "DynArrayCrapResizer" >:: (fun () -> let module M = TestContainer(DynArrayContainerCrapResizer) in ()); "Deque" >:: (fun () -> let module M = TestContainer(DequeContainer) in ()); "Lazylist" >:: (fun () -> let module M = TestContainer(LazyListContainer) in ()); "Dllist" >:: (fun () -> let module M = TestContainer(DllistContainer) in ()); ] batteries-included-3.4.0/testsuite/test_digest.ml000066400000000000000000000012721415601150500221660ustar00rootroot00000000000000open OUnit (*1. Compute the digest of this file using Legacy.Digest*) let legacy_result () = let inp = Pervasives.open_in_bin Sys.argv.(0) in let result = Digest.channel inp (-1) in Pervasives.close_in inp; result (*2. Compute the digest of this file using Batteries.Digest*) let batteries_result () = let inp = BatFile.open_in Sys.argv.(0) in let result = BatDigest.channel inp (-1) in BatIO.close_in inp; result (*3. Compare*) let test_legacy_against_batteries () = assert_equal ~printer:(Printf.sprintf "%S") (legacy_result ()) (batteries_result ()) let tests = "Digest" >::: [ "Comparing Legacy.Digest and MD5" >:: test_legacy_against_batteries; ] batteries-included-3.4.0/testsuite/test_dynarray.ml000066400000000000000000000007471415601150500225460ustar00rootroot00000000000000open Batteries open OUnit module DA = DynArray let s1 = DA.of_list [1;2;3] let s2 = DA.of_list [1;2] let asseq_int = assert_equal ~printer:(DA.print Int.print |> IO.to_string) let asseq_str = assert_equal ~printer:identity let test_dynarray_filter () = let e = BatDynArray.create () in BatDynArray.add e "a"; BatDynArray.add e "b"; BatDynArray.keep ((=) "a") e; asseq_str (BatDynArray.get e 0) "a" let tests = "Set" >::: [ "Dynarray_filter" >:: test_dynarray_filter; ] batteries-included-3.4.0/testsuite/test_enum.ml000066400000000000000000000137771415601150500216700ustar00rootroot00000000000000open OUnit open BatBigarray open BatPervasives let array = [|'1';'2';'3';'4';'5'|] let array2 = [|[|'1';'2';'3';'4';'5'|]; [|'6';'7';'8';'9';'A'|]; [|'B';'C';'D';'E';'F'|]|] let array3 = [|[|[|'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'|]|]|] let list = ['1';'2';'3';'4';'5'] let string = "12345" let bigarray1 = Array1.of_array char c_layout array let bigarray2 = Array2.of_array char c_layout array2 let bigarray3 = Array3.of_array char c_layout array3 let text = BatText.of_string string module C = struct type t = char let compare x y = Char.code x - Char.code y end module S = BatSet.Make(C) module M = BatMap.Make(C) let theset = List.fold_right S.add list S.empty let themap = List.fold_left (fun m c -> M.add c () m) M.empty list open BatArray let test_array_enums () = let source = array in let printer x = BatPrintf.sprintf2 "%a" (print BatChar.print) x in let aeq = assert_equal ~printer in aeq (of_backwards (enum source)) (of_enum (backwards source)); aeq source (of_backwards (backwards source)); open BatList let test_list_enums () = let source = list in let printer x = BatPrintf.sprintf2 "%a" (print BatChar.print) x in let aeq = assert_equal ~printer in aeq (of_backwards (enum source)) (of_enum (backwards source)); aeq source (of_backwards (backwards source)); open BatString let test_string_enums () = let source = string in let aeq = assert_equal ~printer:(Printf.sprintf "%S") in aeq (of_backwards (enum source)) (of_enum (backwards source)); aeq source (of_backwards (backwards source)); open S let test_set_enums () = let source = theset in let printer x = BatPrintf.sprintf2 "%a" (print BatChar.print) x in let aeq = assert_equal ~cmp:(fun s1 s2 -> S.compare s1 s2 = 0) ~printer in aeq (of_enum (enum source)) (of_enum (backwards source)); aeq source (of_enum (backwards source)); open M let test_map_enums () = let source = themap in let printer x = BatPrintf.sprintf2 "%a" (print BatChar.print (fun _io _v -> ())) x in let aeq = assert_equal ~cmp:(fun m1 m2 -> M.compare (fun _ _ -> 0) m1 m2 = 0) ~printer in aeq (of_enum (enum source)) (of_enum (backwards source)); aeq source (of_enum (backwards source)) (* open Ulib.Text let test_rope_enums () = let source = text in let aeq = assert_equal ~printer:(BatPrintf.sprintf2 "%a" print) in aeq (of_backwards (enum source)) (of_enum (backwards source)); aeq source (of_backwards (backwards source)); open BatUTF8 let test_UTF8_enums () = let source = utf8 in let aeq = assert_equal ~printer:(BatPrintf.sprintf2 "%a" print) in aeq (of_backwards (enum source)) (of_enum (backwards source)); aeq source (of_backwards (backwards source)); *) open BatArray let test_bigarray_enums () = let printer x = BatPrintf.sprintf2 "%a" (print BatChar.print) x in let aeq = assert_equal ~printer in let enum_flatten x = BatEnum.flatten (BatEnum.map enum x) in aeq (of_enum (enum array)) (of_enum (Array1.enum bigarray1)); aeq (enum array2 |> enum_flatten |> of_enum) (of_enum (Array2.enum bigarray2)); aeq (enum array3 |> enum_flatten |> enum_flatten |> of_enum) (of_enum (Array3.enum bigarray3)) let test_uncombine () = let pair_list = [1,2;3,4;5,6;7,8;9,0] in let a,b = BatEnum.uncombine (BatList.enum pair_list) in let a = BatArray.of_enum a in let b = BatArray.of_enum b in let c,d = BatEnum.uncombine (BatList.enum pair_list) in let d = BatArray.of_enum d in let c = BatArray.of_enum c in let aeq = assert_equal ~printer:(BatIO.to_string (BatArray.print BatInt.print)) in aeq a [|1;3;5;7;9|]; aeq b [|2;4;6;8;0|]; aeq a c; aeq b d (* BatEnum.from should not call the user function after No_more_elements was raised. *) let test_from () = let nb_calls = ref 0 in let next () = incr nb_calls ; if !nb_calls <= 5 then !nb_calls else raise BatEnum.No_more_elements in let e = BatEnum.merge (fun _ _ -> true) (BatEnum.from next) (1 -- 5) in let nb_res = BatEnum.hard_count e in assert_equal ~printer:string_of_int 10 nb_res ; assert_equal ~printer:string_of_int 6 !nb_calls (* Same as above for BatEnum.from_while *) let test_from_while () = let nb_calls = ref 0 in let next () = incr nb_calls ; if !nb_calls <= 5 then Some !nb_calls else None in let e = BatEnum.merge (fun _ _ -> true) (BatEnum.from_while next) (1 -- 5) in let nb_res = BatEnum.hard_count e in assert_equal ~printer:string_of_int 10 nb_res ; assert_equal ~printer:string_of_int 6 !nb_calls (* Same as above for BatEnum.from_loop *) let test_from_loop () = let nb_calls = ref 0 in let next prev = incr nb_calls ; if !nb_calls <= 5 then prev+1, !nb_calls else raise BatEnum.No_more_elements in let e = BatEnum.merge (fun _ _ -> true) (BatEnum.from_loop 0 next) (1 -- 5) in let nb_res = BatEnum.hard_count e in assert_equal ~printer:string_of_int 10 nb_res ; assert_equal ~printer:string_of_int 6 !nb_calls let test_cycle () = let open BatEnum in let expected = [1;2;3;1;2;3] in let result = [1;2;3] |> BatList.enum |> cycle ~times:2 |> BatList.of_enum in assert_equal expected result; let result = [1;2] |> BatList.enum |> cycle ~times:0 in assert_equal ~printer:string_of_int 0 (count result) let tests = "BatEnum" >::: [ "Array" >:: test_array_enums; "List" >:: test_list_enums; "String" >:: test_string_enums; (* "Rope" >:: test_rope_enums; "UTF8" >:: test_UTF8_enums; *) "bigarray" >:: test_bigarray_enums; "Set" >:: test_set_enums; "Map" >:: test_map_enums; "uncombine" >:: test_uncombine; "from" >:: test_from; "from_while" >:: test_from_while; "from_loop" >:: test_from_loop; "test_cycle" >:: test_cycle ] batteries-included-3.4.0/testsuite/test_file.ml000066400000000000000000000117401415601150500216270ustar00rootroot00000000000000open OUnit open BatFile open BatIO open BatPervasives (**Initialize data sample*) let state = BatRandom.State.make [|0|];; let buffer = BatArray.of_enum (BatEnum.take 60 (BatRandom.State.enum_int state 255));; (**Write sample to temporary file*) let write buf = let (out, name) = open_temporary_out ~mode:[`delete_on_exit] () in BatEnum.iter (write_byte out) (BatArray.enum buf); close_out out; name (**Read from temporary file*) let read_regular name = with_file_in name (fun inp -> BatArray.of_enum (bytes_of inp)) let read_mmap name = with_file_in ~mode:[`mmap] name (fun inp -> BatArray.of_enum (bytes_of inp)) let temp_file ?(autoclean = true) pref suff = let tf = Filename.temp_file pref suff in if autoclean then Pervasives.at_exit (fun () -> try Unix.unlink tf with _ -> ()) ; tf (**Actual tests*) let print_array out = BatPrintf.sprintf2 "%a" (BatArray.print ~sep:"; " BatInt.print) out let test_read_back_tmp () = let name = write buffer in let aeq msg result = assert_equal ~printer:print_array ~msg buffer result in aeq "regular" (read_regular name); aeq "mmap" (read_mmap name) let test_open_files_not_autoclosed () = let name = write buffer in let f = open_in name in try let _ = BatIO.read_all f in let c = BatIO.read f in assert_failure (BatPrintf.sprintf "Expecting: BatIO.No_more_input, got char %C" c) with | BatIO.No_more_input -> () (* pass *) | BatIO.Input_closed -> assert_failure "Expected: BatIO.No_more_input, got BatIO.Input_closed." | e -> let _ = BatIO.close_in f in assert_failure (BatPrintf.sprintf "Expected: BatIO.No_more_input, got %s" (Printexc.to_string e)) let test_open_close_many () = try for _i = 0 to 10000 do Unix.unlink (write buffer) done; (* pass *) with Sys_error e -> assert_failure (BatPrintf.sprintf "Got Sys_error %S" e) let test_open_close_many_pervasives () = try for _i = 0 to 10000 do let temp = temp_file "batteries" "test" in let oc = open_out temp in output_string oc "test"; close_out oc; (try Unix.unlink temp with _ -> ()) done; (* pass *) with Sys_error e -> assert_failure (BatPrintf.sprintf "Got Sys_error %S" e) let test_no_append () = try let temp = temp_file "ocaml_batteries" "noappend_test" in let out = open_out temp in let _ = BatEnum.iter (write_byte out) (BatArray.enum buffer) in let _ = close_out out in let size_1 = size_of temp in let out = open_out temp in let _ = BatEnum.iter (write_byte out) (BatArray.enum buffer) in let _ = close_out out in let size_2 = size_of temp in if size_1 <> size_2 then assert_failure (BatPrintf.sprintf "Expected two files with size %d, got one with size %d and one with size %d" size_1 size_1 size_2) with Sys_error e -> assert_failure (BatPrintf.sprintf "Got Sys_error %S" e) let test_append () = try let temp = temp_file "ocaml_batteries" "append_test" in let out = open_out ~mode:[`append] temp in let _ = BatEnum.iter (write_byte out) (BatArray.enum buffer) in let _ = close_out out in let size_1 = size_of temp in let out = open_out ~mode:[`append] temp in let _ = BatEnum.iter (write_byte out) (BatArray.enum buffer) in let _ = close_out out in let size_2 = size_of temp in if size_2 <> 2*size_1 then assert_failure (BatPrintf.sprintf "Expected a files with size %d, got a first chunk with size %d and a second chunk with size %d" (2*size_1) size_1 size_2) with Sys_error e -> assert_failure (BatPrintf.sprintf "Got Sys_error %S" e) let test_lines_of () = let file_lines_of fn = let ic = Pervasives.open_in fn in BatEnum.suffix_action (fun () -> Pervasives.close_in ic) (BatEnum.from (fun () -> try Pervasives.input_line ic with End_of_file -> raise BatEnum.No_more_elements)) in try let open Batteries in let tf = temp_file "batteries" "test" in BatFile.write_lines tf (BatList.enum [ "First" ; "Second" ]) ; (file_lines_of tf /@ (fun x -> String.length x, 42) |> Enum.group Tuple2.first) |> List.of_enum |> ignore with Sys_error e -> assert_failure (BatPrintf.sprintf "Got Sys_error %S" e) let tests = "File" >::: [ "Reading back output to temporary file" >:: test_read_back_tmp; "open_in'd files should not autoclose" >:: test_open_files_not_autoclosed; "opening and closing many files" >:: test_open_close_many; "opening and closing many files (Pervasives)" >:: test_open_close_many_pervasives; "default truncation of files" >:: test_no_append; "appending to a file" >:: test_append; "reading lines of a file" >:: test_lines_of ] batteries-included-3.4.0/testsuite/test_hashcons.ml000066400000000000000000000023631415601150500225170ustar00rootroot00000000000000open OUnit open BatHashcons type lterm = lterm_ hobj and lterm_ = | Var of string | App of lterm * lterm | Lam of string * lterm module LtermFuncs = struct type t = lterm_ let equal lt1 lt2 = match lt1, lt2 with | Var j, Var k -> j = k | App (lt11, lt12), App (lt21, lt22) -> lt11 == lt21 && lt12 == lt22 | Lam (x, lt1), Lam (y, lt2) -> x = y && lt1 == lt2 | _ -> false let hash = function | Var x -> H.hc1_ 0 (Hashtbl.hash x) | App (lt1, lt2) -> H.hc1_ 1 (H.hc1 lt1 (H.hc0 lt2)) | Lam (x, lt) -> H.hc1_ 2 (H.hc1_ (Hashtbl.hash x) (H.hc0 lt)) end module LtermHC = MakeTable (LtermFuncs) let _tab = LtermHC.create 1 let var x : lterm = LtermHC.hashcons _tab (Var x) let app lt1 lt2 : lterm = LtermHC.hashcons _tab (App (lt1, lt2)) let lam x lt : lterm = LtermHC.hashcons _tab (Lam (x, lt)) let test_identity () = let mk_s x y z = lam x begin lam y begin lam z begin let xz = app (var x) (var z) in let yz = app (var y) (var z) in app xz yz end end end in assert_bool "mk_s produces different objects" (mk_s "x" "y" "z" == mk_s "x" "y" "z") let tests = "Hashcons" >::: [ "Pointer identity" >:: test_identity ] batteries-included-3.4.0/testsuite/test_hashtbl.ml000066400000000000000000000020511415601150500223300ustar00rootroot00000000000000open Batteries open OUnit (* regression tests for https://github.com/ocaml-batteries-team/batteries-included/issues/609 *) module IntIdHash = struct type t = int let hash t = t let equal = (=) end let test_issue_609_1 () = let module H = BatHashtbl.Make(IntIdHash) in let h = H.create 7 in H.replace h min_int []; let v = H.find_default h (-max_int) [] in assert_equal v [] let test_issue_609_2 () = let module H = BatHashtbl.Make(IntIdHash) in let h = H.create 7 in H.add h 0 []; H.remove_all h 0; assert_bool "0 was removed" (not (H.mem h 0)) let test_issue_1038 () = let module M = struct type t = int * string let equal ((i, _) : t) ((i', _) : t) = Int.equal i i' let hash ((_, s) : t) = Hashtbl.hash s end in let module H = BatHashtbl.Make(M) in let elem = (1, "Hello") in let h = H.of_list [(elem, ())] in assert_bool "the element is found" (H.mem h elem) let tests = "Hashtbl" >::: [ "PR#609 (1)" >:: test_issue_609_1; "PR#609 (2)" >:: test_issue_609_2; "PR#1038" >:: test_issue_1038; ] batteries-included-3.4.0/testsuite/test_map.ml000066400000000000000000001022141415601150500214620ustar00rootroot00000000000000open BatPervasives module R = BatRandom module U = OUnit let print_enum out enum = BatEnum.print (fun out (c, _) -> BatPrintf.fprintf out "%d" c) out enum let assert_equal_enums enum_1 enum_2 = match BatEnum.compare compare (enum_1 ()) (enum_2 ()) with | 0 -> (* pass *) () | _ -> U.assert_failure (BatPrintf.sprintf2 "Expected %a, got %a" print_enum (enum_1 ()) print_enum (enum_2 ())) let assert_equal_maps map_1 map_2 = let enum_1 () = BatMap.enum map_1 in let enum_2 () = BatMap.enum map_2 in assert_equal_enums enum_1 enum_2 let test_traversal_order () = let init = R.State.make [|0|] in let keys = BatEnum.take 50 (R.State.enum_int init 10) in let map = BatMap.of_enum (BatEnum.map (fun x -> (x,x)) keys) in let enum_1 () = BatMap.enum map and enum_2 () = let list = BatRefList.empty () in BatMap.iter (fun k v -> BatRefList.push list (k, v)) map; BatRefList.backwards list in match BatEnum.compare compare (enum_1 ()) (enum_2 ()) with | 0 -> (* pass *) () | _ -> U.assert_failure (BatPrintf.sprintf2 "Expected %a, got %a" print_enum (enum_1 ()) print_enum (enum_2 ())) let gen_map state bound count = let keys = BatEnum.take count (R.State.enum_int state bound) in BatMap.of_enum (BatEnum.map (fun x -> (x,x)) keys) let test_split () = let do_test map v = let m1, vo, m2 = BatMap.split v map in assert_equal_maps m1 (BatMap.filter (fun k _ -> k < v) map); assert_equal_maps m2 (BatMap.filter (fun k _ -> k > v) map); U.assert_equal vo (if BatMap.mem v map then Some v else None) in let init = R.State.make [|0|] in for i = 0 to 50 do let bound = 40 in let count = i * 5 in do_test (gen_map init bound count) (R.State.int init bound) done let (>:), (>::), (>:::) = U.(>:), U.(>::), U.(>:::) let (@?) = U.(@?) let (@!) msg (exn, f) = U.assert_raises ~msg exn f (* This functor is intended the features that are common in both the functorized Map and the polymorphic PMap data structures. Currently, those two modules have a different interfaces : there are functions in one that aren't present in another. The tests are therefore not exhaustive : only common features are tested (but all such functions are tested), and PMap-specific functions should be tested separately. As we hope, however, to make the feature set of both module converge in the long term, more features of one will be added to the other, and eventually all the features of both will be present here. Functions that are currently Map-specific : compare, equal, keys, values *) module TestMap (M: sig type 'a m type key = int val equal : ('a -> 'a -> bool) -> 'a m -> 'a m -> bool (* true if add, remove, update_stdlib and filter support physical equality *) val supports_phys_equality : bool (* tested functions *) val empty : 'a m val is_empty : _ m -> bool val singleton : key -> 'a -> 'a m val find : key -> 'a m -> 'a val add : key -> 'a -> 'a m -> 'a m val remove : key -> 'a m -> 'a m val mem : key -> _ m -> bool val cardinal : _ m -> int val update: key -> key -> 'a -> 'a m -> 'a m val update_stdlib: key -> ('a option -> 'a option) -> 'a m -> 'a m val min_binding : 'a m -> (key * 'a) val max_binding : 'a m -> (key * 'a) val pop_min_binding : 'a m -> (key * 'a) * 'a m val pop_max_binding : 'a m -> (key * 'a) * 'a m val min_binding_opt : 'a m -> (key * 'a) option val max_binding_opt : 'a m -> (key * 'a) option val modify : key -> ('a -> 'a) -> 'a m -> 'a m val modify_def : 'a -> key -> ('a -> 'a) -> 'a m -> 'a m val modify_opt : key -> ('a option -> 'a option) -> 'a m -> 'a m val extract : key -> 'a m -> 'a * 'a m val pop : 'a m -> (key * 'a) * 'a m val fold : ('a -> 'b -> 'b) -> 'a m -> 'b -> 'b val foldi : (key -> 'a -> 'b -> 'b) -> 'a m -> 'b -> 'b val iter : ('a -> unit) -> 'a m -> unit val iteri : (key -> 'a -> unit) -> 'a m -> unit val map : ('a -> 'b) -> 'a m -> 'b m val mapi : (key -> 'a -> 'b) -> 'a m -> 'b m val filterv : ('a -> bool) -> 'a m -> 'a m val filter : (key -> 'a -> bool) -> 'a m -> 'a m val filterv_map : ('a -> 'b option) -> 'a m -> 'b m val filter_map : (key -> 'a -> 'b option) -> 'a m -> 'b m val bindings : 'a m -> (key * 'a) list val enum : 'a m -> (key * 'a) BatEnum.t val backwards : 'a m -> (key * 'a) BatEnum.t val of_enum : (key * 'a) BatEnum.t -> 'a m val for_all : (key -> 'a -> bool) -> 'a m -> bool val exists : (key -> 'a -> bool) -> 'a m -> bool val partition : (key -> 'a -> bool) -> 'a m -> 'a m * 'a m val choose : 'a m -> (key * 'a) val split : key -> 'a m -> ('a m * 'a option * 'a m) val add_seq : (key * 'a) BatSeq.t -> 'a m -> 'a m val of_seq : (key * 'a) BatSeq.t -> 'a m val to_seq : 'a m -> (key * 'a) BatSeq.t val to_rev_seq : 'a m -> (key * 'a) BatSeq.t val to_seq_from : key -> 'a m -> (key * 'a) BatSeq.t val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a m -> 'b m -> 'c m val union_stdlib : (key -> 'a -> 'a -> 'a option) -> 'a m -> 'a m -> 'a m val print : ?first:string -> ?last:string -> ?sep:string -> ?kvsep:string -> ('a BatInnerIO.output -> key -> unit) -> ('a BatInnerIO.output -> 'c -> unit) -> 'a BatInnerIO.output -> 'c m -> unit end) = struct let li t = BatList.of_enum (M.enum t) let il li = M.of_enum (BatList.enum li) let eq_li ?msg cmp_elt print_elt l1 l2 = let cmp t1 t2 = let cmp = BatTuple.Tuple2.compare ~cmp1:BatInt.compare ~cmp2:cmp_elt in 0 = BatList.compare cmp t1 t2 in let printer = BatIO.to_string @@ BatList.print @@ BatTuple.Tuple2.print BatInt.print print_elt in U.assert_equal ?msg ~cmp ~printer l1 l2 let eq ?msg cmp_elt print_elt t1 t2 = eq_li ?msg cmp_elt print_elt (li t1) (li t2) let (@=) msg (t1, t2) = eq ~msg BatInt.compare BatInt.print t1 t2 let test_is_empty () = "empty is empty" @? M.is_empty M.empty; "singleton is not empty" @? not (M.is_empty @@ M.singleton 1 ()); () let test_singleton () = let k, v = 1, 'a' in "remove k (singleton k v) is empty" @? M.is_empty (M.remove k (M.singleton k v)); "find k (singleton k v) is v" @? (M.find k (M.singleton k v) = v); "to_list (singleton k v) = [(k, v)]" @? (li (M.singleton k v) = [(k, v)]); () let test_add () = let k, v, v', t = 1, 4, 7, il [(3,4); (5, 6)] in "add k v (add k v' t) = add k v t" @= (M.add k v (M.add k v' t), M.add k v t); "add 4 8 [3,4; 5,6] = [3,4; 4,8; 5,6]" @= (M.add 4 8 t, il [(3,4); (4,8); (5,6)]); if M.supports_phys_equality then begin "add 3,4 [3,4; 5,6] == [3,4; 5,6]" @? (t == M.add 3 4 t); end; () let test_cardinal () = let k, k', v = 1, 2, 3 in "cardinal empty = 0" @? (M.cardinal M.empty = 0); "cardinal (singleton k v) = 1" @? (M.cardinal (M.singleton k v) = 1); "k <> k' => cardinal (add k' v (singleton k v)) = 2" @? (k <> k' && M.cardinal (M.add k' v (M.singleton k v)) = 2); "mem k t => cardinal (remove k t) = cardinal t - 1" @? (let t = il [k,v; k',v] in M.cardinal (M.remove k t) = M.cardinal t - 1); () let test_find () = let t = il [(3,4); (5, 6)] in "find 3 t = 4" @? (M.find 3 t = 4); "find 4 t -> Not_found" @! (Not_found, fun () -> M.find 6 t); let test_cardinal k v t = "cardinal (add k v t) = cardinal t + (mem k t ? 0 : 1)" @? (M.cardinal (M.add k v t) = M.cardinal t + if M.mem k t then 0 else 1) in test_cardinal 3 0 t; test_cardinal 57 0 t; () let test_remove () = let t = il [(3,4); (5, 6)] in "find k (remove k (add k v (add k v' t))) -> Not_found" @! (Not_found, fun () -> let k, v, v', t = 1, 4, 5, t in M.find k (M.remove k (M.add k v (M.add k v' t)))); let test_cardinal k t = "cardinal (remove k t) = cardinal t - (mem k t ? 1 : 0)" @? (M.cardinal (M.remove k t) = M.cardinal t - if M.mem k t then 1 else 0) in test_cardinal 3 t; test_cardinal 57 t; if M.supports_phys_equality then begin "remove 12 [3,4; 5,6] == [3,4; 5,6]" @? (t == M.remove 12 t); "remove 12 [] == []" @? (M.empty == M.remove 12 M.empty); end; () let test_update_stdlib () = let s = (il [1,1; 2,2]) in "update_stdlib change [1,1;2,2] to [1,3;2,2]" @= (M.update_stdlib 1 (fun x -> assert(x = Some 1); Some 3) s, il [1,3;2,2]); "update_stdlib change [1,1;2,2] to [1,1;2,2;3,3]" @= (M.update_stdlib 3 (fun x -> assert(x = None); Some 3) s, il [1,1;2,2;3,3]); "update_stdlib change [1,1;2,2] to [2,2]" @= (M.update_stdlib 1 (fun x -> assert(x = Some 1); None) s, il [2,2]); "update_stdlib change [1,1;2,2] to [1,1;2,2] by not changing binding of 3 (phys eq)" @= (M.update_stdlib 3 (fun x -> assert(x = None); None ) s, s); "update_stdlib change [1,1;2,2] to [1,1;2,2] by not changing binding of 1 (phys eq)" @= (M.update_stdlib 1 (fun x -> assert(x = Some 1); Some 1) s, s); "update_stdlib change [] to [] by not changing binding of 1 (phys eq)" @= (M.update_stdlib 1 (fun x -> assert(x = None); None) M.empty, M.empty); if M.supports_phys_equality then begin "update_stdlib change [1,1;2,2] to [1,1;2,2] by not changing binding of 3 (phys eq)" @? (M.update_stdlib 3 (fun x -> assert(x = None); None ) s == s); "update_stdlib change [1,1;2,2] to [1,1;2,2] by not changing binding of 1 (phys eq)" @? (M.update_stdlib 1 (fun x -> assert(x = Some 1); Some 1) s == s); "update_stdlib change [] to [] by not changing binding of 1 (phys eq)" @? (M.update_stdlib 1 (fun x -> assert(x = None); None) M.empty == M.empty); end; () let test_update () = let s = (il [1,1; 2,2]) in "update 1 1 3 [1,1;2,2]" @= (M.update 1 1 3 s, il [1,3;2,2]); "update 1 3 3 [1,1;2,2]" @= (M.update 1 3 3 s, il [2,2;3,3]); "update 1 2 3 [1,1;2,2]" @= (M.update 1 2 3 s, il [2,3]); "update 1 1 1 [1,1;2,2]" @= (M.update 1 1 1 s, s); if M.supports_phys_equality then begin "update 1 1 1 [1,1;2,2] (phys eq)" @? (M.update 1 1 1 s == s); end; () let test_filter () = let t = il [(3,4); (6, 5); (7,8); (10, 9)] in "filter (_ -> false) t" @= (M.filter (fun _ _ -> false) t, M.empty); "filter (fun a b -> a > b) t" @= (M.filter (fun a b -> a > b) t, il [6,5;10,9]); "filter (_ -> true) t" @= (M.filter (fun _ _ -> true) t, t); "filter (_ -> true) empty" @= (M.filter (fun _ _ -> true) M.empty, M.empty); if M.supports_phys_equality then begin "filter (_ -> true) t (phys eq)" @? (M.filter (fun _ _ -> true) t == t); "filter (_ -> true) empty (phys eq)" @? (M.filter (fun _ _ -> true) M.empty == M.empty); end; () let test_union_stdlib () = "union_stdlib empty empty" @= (M.union_stdlib (fun _ -> failwith "must not be called") M.empty M.empty, M.empty); "union_stdlib [1,1;2,2] empty" @= (M.union_stdlib (fun _ -> failwith "must not be called") (il [1,1;2,2]) M.empty, il [1,1;2,2]); "union_stdlib empty [1,1;2,2]" @= (M.union_stdlib (fun _ -> failwith "must not be called") M.empty (il [1,1;2,2]), il [1,1;2,2]); "union_stdlib [1,1;2,2] [3,3;4,4]" @= (M.union_stdlib (fun _ -> failwith "must not be called") (il [3,3;4,4]) (il [1,1;2,2]), il [1,1;2,2;3,3;4,4]); "union_stdlib [1,1;2,2;3,10] [3,6;4,4] keep sum on conflict" @= (M.union_stdlib (fun _k a b -> Some (a+b)) (il [3,6;4,4]) (il [1,1;2,2;3,10]), il [1,1;2,2;3,16;4,4]); "union_stdlib [1,1;2,2;3,10] [3,6;4,4] drop on conflict" @= (M.union_stdlib (fun _k _a _b -> None) (il [3,6;4,4]) (il [1,1;2,2;3,10]), il [1,1;2,2;4,4]); "union_stdlib [1,1;4,2;3,10] [3,6;4,4] keep 3 w sum, drop 4" @= (M.union_stdlib (fun k a b -> if k = 3 then Some (a+b) else None) (il [2,2;3,6;4,4]) (il [1,1;4,2;3,10]), il [1,1;2,2;3,16]); () let list_of_seq s = BatSeq.fold_right (fun x l -> x :: l) s [] let test_add_seq () = "add_seq [1,1;2,2;3,3] [3,3;4,4]" @= (il [1,1;2,2;3,3;4,4], M.add_seq (BatSeq.of_list [1,1;2,2;3,3]) (il [3,3;4,4])); "add_seq [1,1;2,2] [3,3;4,4]" @= (il [1,1;2,2;3,3;4,4], M.add_seq (BatSeq.of_list [1,1;2,2]) (il [3,3;4,4])); "add_seq [] [3,3;4,4]" @= (il [3,3;4,4], M.add_seq (BatSeq.of_list []) (il [3,3;4,4])); "add_seq [1,1;2,2] [] " @= (il [1,1;2,2], M.add_seq (BatSeq.of_list [1,1;2,2]) (il [])); "add_seq [] [] " @= (il [], M.add_seq (BatSeq.of_list []) (il [])); () let test_of_seq () = "of_seq [1,1;2,2;3,3;4,4]" @= (il [1,1;2,2;3,3;4,4], M.of_seq (BatSeq.of_list [1,1;2,2;4,4;3,3])); "of_seq []" @= (il [ ], M.of_seq (BatSeq.of_list [ ])); () let test_to_seq () = "to_seq [1,1;2,2;3,3;4,4]" @? (BatSeq.equal (BatSeq.of_list [1,1;2,2;3,3;4,4]) (M.to_seq (il [4,4;1,1;3,3;2,2]))); "to_seq []" @? (BatSeq.equal (BatSeq.of_list [ ]) (M.to_seq (il [ ]))); () let test_to_rev_seq () = "to_rev_seq [1,1;2,2;3,3;4,4]" @? (BatSeq.equal (BatSeq.of_list [4,4;3,3;2,2;1,1]) (M.to_rev_seq (il [4,4;1,1;3,3;2,2]))); "to_rev_seq []" @? (BatSeq.equal (BatSeq.of_list [ ]) (M.to_rev_seq (il [ ]))); () let test_to_seq_from () = "to_seq_from 5 []" @? (BatSeq.equal (BatSeq.of_list [ ]) (M.to_seq_from 5 (il [ ]))); "to_seq_from 5 [1,1;2,2;3,3;4,4]" @? (BatSeq.equal (BatSeq.of_list [ ]) (M.to_seq_from 5 (il [4,4;1,1;3,3;2,2]))); "to_seq_from 3 [1,1;2,2;3,3;4,4]" @? (BatSeq.equal (BatSeq.of_list [3,3;4,4 ]) (M.to_seq_from 3 (il [4,4;1,1;3,3;2,2]))); "to_seq_from 5 [1,1;2,2;3,3;4,4]" @? (BatSeq.equal (BatSeq.of_list [1,1;2,2;3,3;4,4]) (M.to_seq_from 0 (il [4,4;1,1;3,3;2,2]))); let l = [0,0;1,1;2,2;3,3;4,4;5,5;6,6;7,7;8,8;9,9] and l2 = [5,5;6,6;7,7;8,8;9,9] in "to_seq_from 5 [1,1 -- 9,9]" @? (BatSeq.equal (BatSeq.of_list l2) (M.to_seq_from 5 (il l))); "to_seq_from 0 [1,1 -- 9,9]" @? (BatSeq.equal (BatSeq.of_list l) (M.to_seq_from 0 (il l))); let max = 40 in let l = BatList.init max (fun i -> (i, i)) in for i = 0 to max do let subl = BatList.filter (fun (x, _) -> x >= i) l in "to_seq_from N [1,1 -- M,M]" @? (BatSeq.equal (BatSeq.of_list subl) (M.to_seq_from i (il l))); done; () let test_mem () = let k, k', v = 1, 2, () in "mem k (singleton k v)" @? M.mem k (M.singleton k v); "not (mem k (singleton k' v))" @? not (M.mem k (M.singleton k' v)); () let test_min_binding () = let t = il [(2, 0); (1,2); (3, 4); (2, 0)] in "min_binding [(2, 0); (1,2); (3, 4); (2, 0)] = (1, 2)" @? (M.min_binding t = (1, 2)); "min_binding [] -> Not_found" @? (try ignore(M.min_binding M.empty); false with Not_found -> true); () let test_max_binding () = let t = il [(2, 0); (1,2); (3, 4); (2, 0)] in "max_binding [(2, 0); (1,2); (3, 4); (2, 0)] = (3, 4)" @? (M.max_binding t = (3, 4)); "max_binding [] -> Not_found" @? (try ignore(M.max_binding M.empty); false with Not_found -> true); () let test_min_binding_opt () = let t = il [(2, 0); (1,2); (3, 4); (2, 0)] in "min_binding_opt [(2, 0); (1,2); (3, 4); (2, 0)] = (1, 2)" @? (M.min_binding_opt t = Some (1, 2)); "min_binding_opt [] = None" @? (M.min_binding_opt M.empty = None); () let test_max_binding_opt () = let t = il [(2, 0); (1,2); (3, 4); (2, 0)] in "max_binding_opt [(2, 0); (1,2); (3, 4); (2, 0)] = (3, 4)" @? (M.max_binding_opt t = Some (3, 4)); "max_binding_opt [] = None" @? (M.max_binding_opt M.empty = None); () let test_pop_min_binding () = let t = il [(2, 0); (1,2); (3, 4); (2, 0)] in let t2 = il [(2, 0); (3, 4); (2, 0)] in let mb, rest = M.pop_min_binding t in "pop_min_binding [(2, 0); (1,2); (3, 4); (2, 0)] = (1, 2), ..." @? (mb = (1, 2)); "pop_min_binding [(2, 0); (1,2); (3, 4); (2, 0)] = (1, 2), ..." @= (rest, t2); "pop_min_binding [] -> Not_found" @? (try ignore(M.pop_min_binding M.empty); false with Not_found -> true); () let test_pop_max_binding () = let t = il [(2, 6); (1,2); (3, 4); (2, 6)] in let t2 = il [(1, 2); (2, 6)] in let mb, rest = M.pop_max_binding t in "pop_max_binding [(2, 0); (1,2); (3, 4); (2, 0)] = (1, 2), ..." @? (mb = (3, 4)); "pop_max_binding [(2, 0); (1,2); (3, 4); (2, 0)] = (1, 2), ..." @= (rest, t2); "pop_max_binding [] -> Not_found" @? (try ignore(M.pop_max_binding M.empty); false with Not_found -> true); () let test_modify () = let k, k', f, t = 1, 2, ((+) 1), il [(1,2); (3, 4)] in "mem k t => find k (modify k f t) = f (find k t)" @? (M.find k (M.modify k f t) = f (M.find k t)); "not (mem k' t) => modify k' f t -> Not_found" @! (Not_found, fun () -> M.modify k' f t); () let test_modify_def () = let sum t = M.fold (+) t 0 in let t = il [(1, 2); (3, 4)] in let test k t = "sum (modify_def 1 k (+1) t) = sum t + (mem k t ? 1 : 2)" @? (sum (M.modify_def 1 k ((+)1) t) = sum t + if M.mem k t then 1 else 2) in test 1 t; test 57 t; "modify_def 0 1 (+1) empty -> singleton 1,0" @? (let t = M.modify_def 0 1 succ M.empty in M.find 1 t = 1 && M.cardinal t = 1); () let test_modify_opt () = let sum t = M.fold (+) t 0 in let t = il [(1, 2); (3, 4)] in (* usage to modify values *) let test1 k t = "sum (modify_opt k (+1 or 2) t) = sum t + (mem k t ? 1 : 2)" @? (sum (M.modify_opt k (function None -> Some 2 | Some x -> Some (x+1)) t) = sum t + if M.mem k t then 1 else 2) in test1 1 t; test1 57 t; (* usage to delete values *) "modify_opt k (fun _ -> None) t -> remove k" @? (M.modify_opt 3 (function Some _ -> None | None -> None) t |> M.mem 3 |> not); "modify_opt k (fun _ -> None) (singleton k) -> empty" @? (M.singleton 1 0 |> M.modify_opt 1 (fun _ -> None) |> M.is_empty); (* usage to add values *) "modify_opt k (fun None -> Some x) t -> add k" @? (M.modify_opt 2 (function None -> Some 1 | _ -> assert false) t |> M.mem 2); () let test_choose () = "choose empty -> Not_found" @! (Not_found, fun () -> M.choose M.empty); let t = il [(1,2); (3,4)] in "mem (fst (choose t)) t" @? (M.mem (M.choose t |> fst) t); () let test_extract () = "extract 1 empty -> Not_found" @! (Not_found, fun () -> M.extract 1 M.empty); let t = il [(1,2); (3,4)] in "not @@ mem k @@ snd @@ extract k t" @? (M.extract 1 t |> snd |> M.mem 1 |> not); "extract k (add k v t) = (v, t)" @? (let (k, v) = (5, 6) in let (v', t') = M.extract k (M.add k v t) in v = v' && M.equal (=) t t'); () let test_pop () = "pop empty -> Not_found" @! (Not_found, fun () -> M.pop M.empty); let t = il [(1,2); (3,4)] in "not (mem (fst (fst (pop t))) (snd (pop t)))" @? (not @@ M.mem (M.pop t |> fst |> fst) (snd @@ M.pop t)); "let ((k,v),t') = pop t in add k v t' = t" @? (let (k,v), t' = M.pop t in M.equal (=) (M.add k v t') t); () let test_split () = let k, v, t = 1, 2, il [0,1; 2,3; 4,5] in "split k empty = (empty, None, empty)" @? (let (l, m, r) = M.split k M.empty in M.is_empty l && m = None && M.is_empty r); "split k (singleton k v) = (empty, Some v, empty)" @? (let (l, m, r) = M.split k (M.singleton k v) in M.is_empty l && m = Some v && M.is_empty r); "split 2 [0,1; 2,3; 4,5] = [0,1], Some 3, [4,5]" @? (let (l, m, r) = M.split 2 t in li l = [0,1] && m = Some 3 && li r = [4,5]); "split 1 [0,1; 2,3; 4,5] = [0,1], None, [2,3; 4,5]" @? (let (l, m, r) = M.split 1 t in li l = [0,1] && m = None && li r = [2,3; 4,5]); "split (fst (min_binding t)) t = (empty, Some (snd (min_binding t)), remove_min_binding t)" @? (let mk, mv = M.min_binding t in let (l, m, r) = M.split mk t in M.is_empty l && m = Some mv && li r = li (M.remove mk r)); "split (fst (max_binding t)) t = (remove_max_binding t, Some (snd (max_binding t)), empty)" @? (let mk, mv = M.max_binding t in let (l, m, r) = M.split mk t in li l = li (M.remove mk l) && m = Some mv && M.is_empty r); () let test_partition () = let t = il [0,0; 1,1; 2,2; 3,3; 4,4] in let p k _ = k mod 2 = 0 in "partition (fun k _ -> k mod 2 = 0) [0,0; 1,1; 2,2; 3,3; 4,4] = [0,0; 2,2; 4,4], [1,1; 3,3]" @? (let l, r = M.partition p t in li l = [0,0; 2,2; 4,4] && li r = [1,1; 3,3]); "partition (fun _ _ -> true) t = t, empty" @? (let l, r = M.partition (fun _ _ -> true) t in M.equal (=) l t && M.is_empty r); "partition (fun _ _ -> false) t = empty, t" @? (let l, r = M.partition (fun _ _ -> false) t in M.is_empty l && M.equal (=) r t); () let test_merge () = let t, t' = il [0,0; 1,1; 3,3], il [1,-1; 2,-2; 3,-3; 4,-4] in "is_empty (merge (fun k a b -> None) t t')" @? M.is_empty (M.merge (fun _ _ _ -> None) t t'); "t = merge (fun k a b -> a) t t'" @= (t, M.merge (fun _ a _ -> a) t t'); "t' = merge (fun k a b -> b) t t'" @= (t', M.merge (fun _ _ b -> b) t t'); let option_compare cmp a b = match a, b with | None, None -> 0 | None, Some _ -> -1 | Some _, None -> 1 | Some a, Some b -> cmp a b in let pair_compare2 cmp = BatTuple.Tuple2.compare ~cmp1:cmp ~cmp2:cmp in eq ~msg: "merge (fun k a b -> Some (a, b)) [0,0; 1,1; 3,3] [1,-1; 2,-2; 3,-3; 4,-4 = [0, (Some 0, None); 1, (Some 1, Some -1); 2, (None, Some -2); 3, (Some 3, Some -3); 4, (None, Some -4)]" (pair_compare2 (option_compare BatInt.compare)) (BatTuple.Tuple2.printn (BatOption.print BatInt.print)) (M.merge (fun _k a b -> Some (a, b)) t t') (il [0, (Some 0, None); 1, (Some 1, Some ~-1); 2, (None, Some ~-2); 3, (Some 3, Some ~-3); 4, (None, Some ~-4)]); () let test_for_all_exists () = let test (msg, for_all) = let (@?) str = (@?) (Printf.sprintf "[%s] %s" msg str) in "for_all (fun _ _ -> false) empty" @? for_all (fun _ _ -> false) M.empty; "for_all (fun _ _ -> true) empty" @? for_all (fun _ _ -> true) M.empty; let k, v = 1, 2 in "for_all (fun _ _ -> true) (singleton k v)" @? for_all (fun _ _ -> true) (M.singleton k v); "not (for_all (fun _ _ -> false) (singleton k v))" @? not (for_all (fun _ _ -> false) (M.singleton k v)); "for_all (fun k' _ -> k = k') (singleton k v)" @? for_all (fun k' _ -> k = k') (M.singleton k v); "for_all (=) [0,0; 1,1]" @? for_all (=) (il [0,0; 1,1]); "not (for_all (=) [0,0; 1,2])" @? not (for_all (=) (il [0,0; 1,2])); () in let not_not_exists f li = let not_f k v = not (f k v) in not (M.exists not_f li) in List.iter test [ "for_all", M.for_all; "not not exists", not_not_exists ] let test_print () = let test str li = let str' = BatIO.to_string (M.print ~first:"{" ~last:"}" ~sep:", " BatInt.print BatInt.print) (il li) in U.assert_equal ~msg:"printing test" ~cmp:(fun x y -> 0 = String.compare x y) ~printer:(fun x -> x) str' str in test "{}" []; test "{0: 1}" [(0, 1)]; test "{0: 1, 2: 3}" [(0, 1); (2, 3)]; () let test_enums () = (* test enum, of_enum, backwards *) let test_of_enum f name_f t = eq ~msg:(Printf.sprintf "of_enum (%s t) = t" name_f) BatInt.compare BatInt.print (M.of_enum (f t)) t in List.iter (fun (f, name_f) -> test_of_enum f name_f (il []); test_of_enum f name_f (il [(0,1); (4,5); (2, 3)])) [ M.enum, "enum"; M.backwards, "backwards"; M.bindings %> BatList.enum, "enum bindings"; ] let reindex (f : M.key -> 'a -> 'b) : 'a -> 'b = let count = ref (-1) in fun x -> incr count; f !count x let test_iterators () = (* we test all iter(i)/fold(i)/map(i)/filter(i)_map in one go, by building a common filteri_map implementation, by using side-effects for iter/map, and a referenced counter for non-i variants (assumes consecutive keys from 0 to N-1). In particular, the side-effects assume that all iterators process the elements in increasing key order. This was not true of PMap iterator functions, and I have changed them to respect that invariant (be it exposed in the documented or unspecified). I don't pretend this test is strong enough, but it's the less cumbersome that I could find, and it should still catch a wide range of regressions (obvious breakage, application order change...), and has already spotted instances of such issues. *) let from_filter_map f t = li (M.filter_map f t) in let from_filterv_map f t = li (M.filterv_map (reindex f) t) in let of_foldi f k v acc = match f k v with | None -> acc | Some v' -> (k,v')::acc in let from_foldi f t = List.rev @@ M.foldi (of_foldi f) t [] in let from_fold f t = List.rev @@ M.fold (reindex (of_foldi f)) t [] in let of_iteri acc f k v = match f k v with | None -> () | Some v' -> acc := (k, v') :: !acc in let from_iteri f t = let acc = ref [] in M.iteri (of_iteri acc f) t; List.rev !acc in let from_iter f t = let acc = ref [] in M.iter (reindex (of_iteri acc f)) t; List.rev !acc in let of_mapi acc f k v = of_iteri acc f k v; v in let from_mapi f t = let acc = ref [] in let res = M.mapi (of_mapi acc f) t in eq ~msg:"iterators test : mapi result test" BatInt.compare BatInt.print t res; List.rev !acc in let from_map f t = let acc = ref [] in let res = M.map (reindex (of_mapi acc f)) t in eq ~msg:"iterators test : map result test" BatInt.compare BatInt.print t res; List.rev !acc in let from_filter f t = t |> M.filter (fun k v -> f k v <> None) |> M.mapi (fun k v -> match f k v with | None -> assert false | Some v' -> v') |> li in let from_filterv f t = t |> M.filterv (reindex (fun k v -> f k v <> None)) |> M.mapi (fun k v -> match f k v with | None -> assert false | Some v' -> v') |> li in (* I took care to write the input unsorted, to observe potential sorting bugs *) let t = il [(4, 4); (5, 5); (3, 3); (0, 0); (6, 6); (2, 2); (1, 1)] in (* the function which all filter_map implementations will use *) let f k v = if k mod 2 = 0 then Some (v + 1) else None in (* result (in sorted order) *) let result = [(0, 1); (2, 3); (4, 5); (6, 7)] in List.iter (fun (name, filter_map_n) -> let msg = Printf.sprintf "iterators test : %s" name in eq_li ~msg BatInt.compare BatInt.print result (filter_map_n f t)) [ "filter_map", from_filter_map; "filterv_map", from_filterv_map; "foldi", from_foldi; "fold", from_fold; "iteri", from_iteri; "iter", from_iter; "mapi", from_mapi; "map", from_map; "filter", from_filter; "filterv", from_filterv; ] let tests = [ "test_is_empty" >:: test_is_empty; "test_singleton" >:: test_singleton; "test_cardinal" >:: test_cardinal; "test_add" >:: test_add; "test_find" >:: test_find; "test_remove" >:: test_remove; "test_mem" >:: test_mem; "test_min_binding" >:: test_min_binding; "test_max_binding" >:: test_max_binding; "test_modify" >:: test_modify; "test_modify_def" >:: test_modify_def; "test_modify_opt" >:: test_modify_opt; "test_choose" >:: test_choose; "test_split" >:: test_split; "test_partition" >:: test_partition; "test_merge" >:: test_merge; "test_for_all_exists" >:: test_for_all_exists; "test_print" >:: test_print; "test_enums" >:: test_enums; "test_iterators" >:: test_iterators; "test_pop" >:: test_pop; "test_extract" >:: test_extract; "test_update" >:: test_update; "test_update_stdlib" >:: test_update_stdlib; "test_filter" >:: test_filter; "test_add_seq" >:: test_add_seq; "test_of_seq" >:: test_of_seq; "test_to_seq" >:: test_to_seq; "test_to_rev_seq" >:: test_to_rev_seq; "test_to_seq_from" >:: test_to_seq_from; "test_min_binding_opt" >:: test_min_binding_opt; "test_max_binding_opt" >:: test_max_binding_opt; "test_pop_min_binding" >:: test_pop_min_binding; "test_pop_max_binding" >:: test_pop_max_binding; "test_union_stdlib" >:: test_union_stdlib; ] end module M = struct module M = BatMap.Make(BatInt) include M type 'a m = 'a M.t let fold f = M.fold (fun _ -> f) let foldi = M.fold let iter f = M.iter (fun _ -> f) let iteri = M.iter let filterv_map f = M.filter_map (fun _ -> f) let union_stdlib = M.union let supports_phys_equality = true end module P = struct module M = BatMap include M type key = int type 'a m = (key, 'a) M.t let iter f = M.iter (fun _ -> f) let iteri = M.iter let filterv_map f = M.filter_map (fun _ -> f) let supports_phys_equality = true end module S = struct module M = BatSplay.Map(BatInt) include M type 'a m = 'a M.t let filterv_map f = M.filter_map (fun _ -> f) let iter f = M.iter (fun _ -> f) let iteri = M.iter let fold f = M.fold (fun _ -> f) let foldi = M.fold let union_stdlib = M.union let supports_phys_equality = false end module TM = TestMap(M) module TP = TestMap(P) module TS = TestMap(S) (* what we want to test is the behaviour of PMap binary operators (union, diff, intersect, merge) in presence of different and funky comparison functions. We will check : - that the bindings of the result are correct - that the comparison function of the result map is as specified *) let heterogeneous_tests = let module P = BatMap.PMap in let li m = BatList.of_enum (P.enum m) in let (@=) msg (act, exp) = let cmp t1 t2 = let cmp = BatTuple.Tuple2.compare ~cmp1:BatInt.compare ~cmp2:BatInt.compare in 0 = BatList.compare cmp t1 t2 in let printer = BatIO.to_string @@ BatList.print @@ BatTuple.Tuple2.printn BatInt.print in U.assert_equal ~msg ~cmp ~printer exp act in let compare_modulo p x y = BatInt.compare (x mod p) (y mod p) in let il p m = P.of_enum ~cmp:(compare_modulo p) (BatList.enum m) in let m13 = il 13 [4,-4; 8,-8; 12,-5] in let m7 = il 7 [9,0; 3,3; 2,2; 5,5] in let test_modulo () = (* we check that we really have a modulo 7 comparison function : the 9.0 binding should be rewritten by the later 2,2 binding; when a binding is rewritten, the key is also changed, so the result is 2,2 rather than the also meaningful 9,2. *) "[9,0; 2,2]/7 = [2,2]" @= (li (il 7 [9,0; 2,2]), [2,2]) in let test_union () = (* We check that the result and all 'add' have been done modulo 7 : - the 8,-8 binding of m13 is now placed in first (smallest) position - the 5,5 binding has been rewritten by the 12,-5 binding*) "union [2,2; 3,3; 5,5]/7 [4,-4; 8,-8; 12,-5]/13 = [8,-8; 2,2; 3,3; 4,-4; 12,-5]/7" @= (li (P.union m7 m13), [8,-8; 2,2; 3,3; 4,-4; 12,-5]) in let test_diff () = (* We check that difference is made modulo 7 : 12,-5 remove 5,5 from the map *) "diff [2,2; 3,3; 5,5]/7 [4,-4; 8,-8; 12,-5]/13 = [2,2; 3,3]" @= (li (P.diff m7 m13), [2,2; 3,3]) in let test_intersect () = (* as intersect is currently underspecified, this test is rather fragile *) "intersect (+) [5,5; 8,8]/7 [4,-4; 5,-5; 8,-8]/13 = [8,0; 5,0]/7" @= (li (P.intersect (+) (il 7 [5,5; 8,8]) (il 13 [4,-4; 5,-5; 8,-8])), [8,0; 5,0]) in [ "modulo" >:: test_modulo; "union" >:: test_union; "diff" >:: test_diff; "intersect" >:: test_intersect; ] (* as specific test for the BatSplay.print_as_list function *) let test_splay_print_as_list () = let module M = BatSplay.Map(BatInt) in let test list = let splay = M.of_enum (BatList.enum list) in let print_pair out (a, b) = BatPrintf.fprintf out "%d, %d" a b in U.assert_equal ~printer:identity (BatIO.to_string (M.print_as_list BatInt.print BatInt.print) splay) (BatIO.to_string (BatList.print print_pair) list) in test []; test [0,1; 2,3]; () let tests = "(P)Map" >::: [ "traversal order iter vs. enum" >:: test_traversal_order; "split" >:: test_split; "usual tests on Map.Make" >::: TM.tests; "usual tests on PMap" >::: TP.tests; "usual tests on Splay" >::: TS.tests; "test BatSPlay.print_as_list" >:: test_splay_print_as_list; (* "PMap's heterogeneous operators" >::: heterogeneous_tests; *) ] batteries-included-3.4.0/testsuite/test_mapfunctors.ml000066400000000000000000000031711415601150500232500ustar00rootroot00000000000000open OUnit open BatRandom module MkTest (MkMap : functor (Ord : BatInterfaces.OrderedType) -> BatMap.S with type key = Ord.t) = struct (* This is basically Test_pmap, but specialized for MkMap(Int) *) module Map = MkMap (BatInt) let print_enum out enum = BatEnum.print begin fun out (c, _) -> BatPrintf.fprintf out "%d" c end out enum let assert_equal_enums enum_1 enum_2 = match BatEnum.compare compare (enum_1 ()) (enum_2 ()) with | 0 -> (* pass *) () | _ -> assert_failure (BatPrintf.sprintf2 "Expected %a, got %a" print_enum (enum_1 ()) print_enum (enum_2 ())) let assert_equal_maps map_1 map_2 = let enum_1 () = Map.enum map_1 in let enum_2 () = Map.enum map_2 in assert_equal_enums enum_1 enum_2 let gen_map state bound count = let keys = BatEnum.take count (State.enum_int state bound) in Map.of_enum (BatEnum.map (fun x -> (x, x)) keys) let test_traversal_order () = let init = State.make [|0|] in let map = gen_map init 10 50 in let enum_1 () = Map.enum map and enum_2 () = let list = BatRefList.empty () in Map.iter (fun k v -> BatRefList.push list (k, v)) map; BatRefList.backwards list in assert_equal_enums enum_1 enum_2 let tests = [ "traversal order iter vs. enum" >:: test_traversal_order ; ] end let tests = let module MT1 = MkTest (BatMap.Make) in let mt1_tests = "Map.Make" >::: MT1.tests in let module MT2 = MkTest (BatSplay.Map) in let mt2_tests = "Splay.Make" >::: MT2.tests in "Generic Map tests" >::: [ mt1_tests ; mt2_tests ; ] batteries-included-3.4.0/testsuite/test_mappable.ml000066400000000000000000000033471415601150500224750ustar00rootroot00000000000000open OUnit (* The purpose of this test file is to test properties that should be verified by all instances of a given interface, here BatInterfaces.Mappable. It is very minimal for now : it only check for one property, and only a few of the Mappable modules (it is actually a regression test for a very specific bug). New properties will be added, and hopefully they will be verified against all Mappable modules. *) module TestMappable (M : sig include BatEnum.Enumerable include BatInterfaces.Mappable with type 'a mappable = 'a enumerable end) = struct (* The property we test is that the order in which the [map] function traverse the structure (applying a given function on each element) is the same as the order of the [enum] function of the module (the order in which the elements are produced in the enumeration). *) let test_map_evaluation_order printer t = let elems_in_enum_order = BatList.of_enum (M.enum t) in let elems_in_map_order = let li = ref [] in ignore (M.map (fun x -> li := x :: !li) t); List.rev !li in assert_equal ~printer:(BatIO.to_string (BatList.print printer)) elems_in_enum_order elems_in_map_order end let test_list_mappable () = let module T = TestMappable(BatList) in T.test_map_evaluation_order BatInt.print [1; 2; 3] let test_array_mappable () = let module T = TestMappable(BatArray) in T.test_map_evaluation_order BatInt.print [|1; 2; 3|] (* let test_pair_mappable () = let module T = TestMappable(BatTuple.Tuple2) in T.test_map_evaluation_order BatInt.print (1, 2) *) let tests = "Mappable" >::: [ "Array" >:: test_array_mappable; "List" >:: test_list_mappable; (* "Pair" >:: test_pair_mappable;*) ] batteries-included-3.4.0/testsuite/test_modifiable.ml000066400000000000000000000176421415601150500230120ustar00rootroot00000000000000open OUnit open Batteries (* Here we check the various modify_* functions. We start by creating some Modifiable signatures with which all concerned modules should comply. *) (* Polymorphic, mutable containers *) module type MODIFIABLE_MUTABLE = sig type ('a, 'b) t val modify : 'a -> ('b -> 'b) -> ('a, 'b) t -> unit val modify_def : 'b -> 'a -> ('b -> 'b) -> ('a, 'b) t -> unit val modify_opt : 'a -> ('b option -> 'b option) -> ('a, 'b) t -> unit (* for testing we need to be able to inspect the container: *) val of_enum : ('a * 'b) Enum.t -> ('a, 'b) t val enum : ('a, 'b) t -> ('a * 'b) Enum.t end let none _ = None module TestModifiable_mutable (M : MODIFIABLE_MUTABLE) = struct let test () = let m = M.of_enum (Enum.combine (1 -- 5) (1 -- 5)) in M.modify 2 succ m ; let e = M.enum m /@ snd |> List.of_enum |> List.sort Int.compare in assert_equal ~printer:(BatIO.to_string (List.print Int.print)) e [1;3;3;4;5] ; (* Add an entry using modify_def *) M.modify_def 0 0 identity m ; (* Empty everything using modify_opt *) for i = 0 to 5 do M.modify_opt i none m done ; assert_bool "couldn't empty the map" (Enum.is_empty (M.enum m)) end let test_hashtbl_modifiable () = let module T = TestModifiable_mutable(Hashtbl) in T.test () (* Immutable containers *) module type MODIFIABLE_IMMUTABLE = sig type key = int type 'a t val modify : key -> ('a -> 'a) -> 'a t -> 'a t val modify_def : 'a -> key -> ('a -> 'a) -> 'a t -> 'a t val modify_opt : key -> ('a option -> 'a option) -> 'a t -> 'a t (* for testing we need to be able to inspect the container: *) val of_enum : (key * 'a) Enum.t -> 'a t val enum : 'a t -> (key * 'a) Enum.t end let rec reapply_i mi ma f m = if mi > ma then m else reapply_i (mi+1) ma f (f mi m) module TestModifiable_immutable (M : MODIFIABLE_IMMUTABLE) = struct let test () = let m = M.of_enum (Enum.combine (1 -- 5) (1 -- 5)) in let m = M.modify 2 succ m in let e = M.enum m /@ snd |> List.of_enum |> List.sort Int.compare in assert_equal ~printer:(BatIO.to_string (List.print Int.print)) e [1;3;3;4;5] ; (* Add an entry using modify_def *) let m = M.modify_def 0 0 identity m in (* Empty everything using modify_opt *) let m = reapply_i 0 5 (fun i m -> M.modify_opt i none m) m in assert_bool "couldn't empty the map" (Enum.is_empty (M.enum m)) end let test_map_modifiable () = let module T = TestModifiable_immutable(Map.Make (Int)) in T.test () let test_splay_modifiable () = let module T = TestModifiable_immutable(Splay.Map (Int)) in T.test () let test_imap_modifiable () = let module MyIMap = struct include IMap let of_enum e = let e' = e /@ fun (k, v) -> (k, k, v) in of_enum ~eq:(=) e' let enum t = enum t /@ (fun (n1, n2, v) -> ((n1 -- n2) /@ fun n -> n, v)) |> Enum.flatten end in let module T = TestModifiable_immutable(MyIMap) in T.test () (* And polymorphic, immutable containers *) module type MODIFIABLE_POLY_IMMUTABLE = sig type ('a, 'b) t val modify : 'a -> ('b -> 'b) -> ('a, 'b) t -> ('a, 'b) t val modify_def : 'b -> 'a -> ('b -> 'b) -> ('a, 'b) t -> ('a, 'b) t val modify_opt : 'a -> ('b option -> 'b option) -> ('a, 'b) t -> ('a, 'b) t (* for testing we need to be able to inspect the container: *) val of_enum : ('a * 'b) Enum.t -> ('a, 'b) t val enum : ('a, 'b) t -> ('a * 'b) Enum.t end module TestModifiable_poly_immutable (M : MODIFIABLE_POLY_IMMUTABLE) = struct let test () = let m = M.of_enum (Enum.combine (1 -- 5) (1 -- 5)) in let m = M.modify 2 succ m in let e = M.enum m /@ snd |> List.of_enum |> List.sort Int.compare in assert_equal ~printer:(BatIO.to_string (List.print Int.print)) e [1;3;3;4;5] ; (* Add an entry using modify_def *) let m = M.modify_def 0 0 identity m in (* Empty everything using modify_opt *) let m = reapply_i 0 5 (fun i m -> M.modify_opt i none m) m in assert_bool "couldn't empty the map" (Enum.is_empty (M.enum m)) end let test_list_modifiable () = let module AssocList = struct type ('a, 'b) t = ('a * 'b) list let modify = List.modify let modify_def = List.modify_def let modify_opt = List.modify_opt let of_enum = List.of_enum let enum = List.enum end in let module T = TestModifiable_poly_immutable(AssocList) in T.test () let test_pmap_modifiable () = let module T = TestModifiable_poly_immutable(Map) in T.test () (* And...? Polymorphic, immutable Multi containers! *) module type MODIFIABLE_POLY_MULTI_IMMUTABLE = sig type ('a, 'b) t val modify : 'a -> ('b BatSet.PSet.t -> 'b BatSet.PSet.t) -> ('a, 'b) t -> ('a, 'b) t val modify_def : 'b BatSet.PSet.t -> 'a -> ('b BatSet.PSet.t -> 'b BatSet.PSet.t) -> ('a, 'b) t -> ('a, 'b) t val modify_opt : 'a -> ('b BatSet.PSet.t option -> 'b BatSet.PSet.t option) -> ('a, 'b) t -> ('a, 'b) t (* for testing we need to be able to inspect the container: *) val of_enum : ('a * 'b) Enum.t -> ('a, 'b) t val enum : ('a, 'b) t -> ('a * 'b) Enum.t end module TestModifiable_poly_multi_immutable (M : MODIFIABLE_POLY_MULTI_IMMUTABLE) = struct let test () = let m = M.of_enum (Enum.combine (1 -- 5) (1 -- 5)) in let m = M.modify 2 (BatSet.PSet.map succ) m in let e = M.enum m /@ snd |> List.of_enum |> List.sort Int.compare in assert_equal ~printer:(BatIO.to_string (List.print Int.print)) e [1;3;3;4;5] ; (* Add an entry using modify_def *) let m = M.modify_def (BatSet.PSet.singleton 0) 0 identity m in (* Empty everything using modify_opt *) let m = reapply_i 0 5 (fun i m -> M.modify_opt i none m) m in assert_bool "couldn't empty the map" (Enum.is_empty (M.enum m)) end let test_multipmap_modifiable () = let module MyMultiPMap = struct include MultiPMap let of_enum e = of_enum ~keys:compare ~data:compare e end in let module T = TestModifiable_poly_multi_immutable(MyMultiPMap) in T.test () (* Wait! Non-polymorphic, immutable Multi containers *) module type MODIFIABLE_MULTI_IMMUTABLE = sig type ('a, 'b) t val modify : 'a -> ('b BatSet.t -> 'b BatSet.t) -> ('a, 'b) t -> ('a, 'b) t val modify_def : 'b BatSet.t -> 'a -> ('b BatSet.t -> 'b BatSet.t) -> ('a, 'b) t -> ('a, 'b) t val modify_opt : 'a -> ('b BatSet.t option -> 'b BatSet.t option) -> ('a, 'b) t -> ('a, 'b) t (* for testing we need to be able to inspect the container: *) val of_enum : ('a * 'b) Enum.t -> ('a, 'b) t val enum : ('a, 'b) t -> ('a * 'b) Enum.t end module TestModifiable_multi_immutable (M : MODIFIABLE_MULTI_IMMUTABLE) = struct let test () = let m = M.of_enum (Enum.combine (1 -- 5) (1 -- 5)) in let m = M.modify 2 (BatSet.map succ) m in let e = M.enum m /@ snd |> List.of_enum |> List.sort Int.compare in assert_equal ~printer:(BatIO.to_string (List.print Int.print)) e [1;3;3;4;5] ; (* Add an entry using modify_def *) let m = M.modify_def (BatSet.singleton 0) 0 identity m in (* Empty everything using modify_opt *) let m = reapply_i 0 5 (fun i m -> M.modify_opt i none m) m in assert_bool "couldn't empty the map" (Enum.is_empty (M.enum m)) end let test_multimap_modifiable () = let module T = TestModifiable_multi_immutable(MultiMap) in T.test () (* -- *) let tests = "Modifiable" >::: [ "Hashtbl" >:: test_hashtbl_modifiable; "List" >:: test_list_modifiable; "Map" >:: test_map_modifiable; "PMap" >:: test_pmap_modifiable; "Splay" >:: test_splay_modifiable; "IMap" >:: test_imap_modifiable; "MultiPMap" >:: test_multipmap_modifiable; "MultiMap" >:: test_multimap_modifiable; ] batteries-included-3.4.0/testsuite/test_multipmap.ml000066400000000000000000000007671415601150500227270ustar00rootroot00000000000000open OUnit open BatPervasives open BatMultiPMap let test_multimap_empty_assoc_lists () = let map = add 0 "foo" empty |> add 0 "bar" |> add 0 "sna" |> remove 0 "foo" |> remove 0 "bar" |> remove 0 "sna" in if mem 0 map then assert_failure (Printf.sprintf "map[0] should be empty but contains %d bindings\n" (BatSet.PSet.cardinal (find 0 map))) let tests = "MultiPMap" >::: [ "MultiPMap: removing empty association lists" >:: test_multimap_empty_assoc_lists; ] batteries-included-3.4.0/testsuite/test_num.ml000066400000000000000000000035051415601150500215070ustar00rootroot00000000000000open OUnit open BatNum let tests = "Num" >::: [ "of_float" >::: [ "zero" >:: begin function () -> assert_equal ~cmp:(=) ~printer:to_string zero (of_float 0.) end; "numbers" >:: begin function () -> Array.iter begin function f -> assert_equal ~printer:BatFloat.to_string f (to_float (of_float f)) end [|2.5; 1.0; 0.5; -0.5; -1.0; -2.5|] end; "infinity/nan" >::: (* set/reset pair for (re)setting the error_when_null_denominator state. * A stack is used instead of simple ref to make calls nestable. *) let (set, reset) = let saved_state = Stack.create () in begin fun state () -> Stack.push (Arith_status.get_error_when_null_denominator ()) saved_state; Arith_status.set_error_when_null_denominator state; end, begin fun () -> Arith_status.set_error_when_null_denominator (Stack.pop saved_state) end in let test () = Array.iter (* f is float, n/d are expected nominator and denominator *) begin fun (f, (n,d)) -> if Arith_status.get_error_when_null_denominator () then (* expect error *) assert_raises (Failure "create_ratio infinite or undefined rational number") (fun () -> ignore (of_float f)) else (* expect result *) assert_equal ~cmp:equal ~printer:to_string (div n d) (of_float f) end (* values to test *) [| infinity, (one,zero); neg_infinity, (neg one,zero); nan, (zero,zero) |] in [ (* allow null denominator *) "allow_null_denom" >:: bracket (set false) test reset; (* disallow null denominator *) "forbid_null_denom" >:: bracket (set true) test reset; ] ] ] batteries-included-3.4.0/testsuite/test_optparse.ml000066400000000000000000000013621415601150500225440ustar00rootroot00000000000000open OUnit open BatPervasives open BatOptParse let printer = dump let tests = "OptParse tests" >::: [ "parse empty" >:: begin function () -> let p = OptParser.make () in assert_equal ~printer [] (OptParser.parse p [||]) end; "parse no options" >:: begin function () -> let p = OptParser.make () in assert_equal ~printer ["foo"] (OptParser.parse p [|"foo"|]) end; "parse empty (only leading)" >:: begin function () -> let p = OptParser.make ~only_leading_opts:true () in assert_equal ~printer [] (OptParser.parse p [||]) end; "parse no options (only leading)" >:: begin function () -> let p = OptParser.make ~only_leading_opts:true () in assert_equal ~printer ["foo"] (OptParser.parse p [|"foo"|]) end; ] batteries-included-3.4.0/testsuite/test_pervasives.ml000066400000000000000000000044231415601150500230770ustar00rootroot00000000000000open OUnit open Batteries let test_using () = let obj = (ref 0), (ref 0) in let dispose (_,closed) = closed := 5 in let f (run,_) = run := 7; 42 in let r = with_dispose ~dispose f obj in let printer = string_of_int in let run, closed = obj in assert_equal ~printer 42 r; assert_equal ~printer 7 (!run); assert_equal ~printer 5 (!closed) type test1 = | A of int | B of float * float | C of string * test1 type test2 = { a : int; b : float * float; c : string * test2 option; } type test3 = { f1 : float; f2 : float; f3 : float; } let test_dump () = let test str value = assert_equal ~msg:str ~printer:(fun x -> x) str (BatPervasives.dump value) in (* integers *) test "0" None; test "0" false; test "1" true; test "17" 17; (* lists *) (* despite the specialized list-spotting routine, [] is printed as 0 as they have the same representation *) test "0" []; test "[1; 2]" [1; 2]; (* algebraic datatypes *) test "(1)" (A 1); test "Tag1 (2., 3.)" (B (2.,3.)); test "Tag2 (\"foo\", (1))" (C ("foo", A 1)); test "(1, (2., 3.), [\"foo\"])" {a = 1; b = (2., 3.); c = "foo", None}; (* tuples *) test "(1, 2)" (1,2); test "[0]" (0,0); (* lazy *) (* lazy immediate values are not lazyfied! test "0" (lazy 0); *) test "" (lazy (ignore ())); (* closures *) test "" (fun x -> x); (* objects *) let obj = object val x = 2 val z = 3. method foo = "bar" end in test (Printf.sprintf "Object #%d (2, 3.)" (Oo.id obj)) obj; (* infix, forward? *) (* string *) let str = "foo \"bar\"\n" in test (Printf.sprintf "%S" str) str; (* double *) let test_float x = test (string_of_float x) x in List.iter test_float [0.; 1.; -2.; max_float; min_float; epsilon_float; nan]; for _i = 0 to 1000 do test_float (Random.float max_float); test_float (Random.float min_float); done; (* abstract? *) (* custom? *) (* final? *) (* double array or struct *) let test_arr arr v = test (BatIO.to_string (BatArray.print BatFloat.print) arr) v in test "()" ([| |] : float array); test_arr [| 0.; 1.; 2. |] [| 0.; 1.; 2. |]; test_arr [| 0.; 1.; 2. |] { f1 = 0.; f2 = 1.; f3 = 2. }; () let tests = "Std" >::: [ "using" >:: test_using; "dump" >:: test_dump; ];; batteries-included-3.4.0/testsuite/test_pmap.ml000066400000000000000000000040531415601150500216440ustar00rootroot00000000000000open OUnit open BatRandom open BatPervasives let print_enum out enum = BatEnum.print (fun out (c, _) -> BatPrintf.fprintf out "%d" c) out enum let assert_equal_enums enum_1 enum_2 = match BatEnum.compare compare (enum_1 ()) (enum_2 ()) with | 0 -> (* pass *) () | _ -> assert_failure (BatPrintf.sprintf2 "Expected %a, got %a" print_enum (enum_1 ()) print_enum (enum_2 ())) let assert_equal_maps map_1 map_2 = let enum_1 () = BatPMap.enum map_1 in let enum_2 () = BatPMap.enum map_2 in assert_equal_enums enum_1 enum_2 let gen_map state bound count = let keys = BatEnum.take count (State.enum_int state bound) in BatPMap.of_enum (BatEnum.map (fun x -> (x,x)) keys) let test_traversal_order () = let init = State.make [|0|] in let map = gen_map init 10 50 in let enum_1 () = BatPMap.enum map and enum_2 () = let list = BatRefList.empty () in BatPMap.iter (fun k v -> BatRefList.push list (k, v)) map; BatRefList.backwards list in assert_equal_enums enum_1 enum_2 let test_split () = let do_test map v = let m1, vo, m2 = BatPMap.split v map in assert_equal_maps m1 (BatPMap.filteri (fun k _ -> k < v) map); assert_equal_maps m2 (BatPMap.filteri (fun k _ -> k > v) map); assert_equal vo (if BatPMap.mem v map then Some v else None) in let init = State.make [|0|] in for i = 0 to 50 do let bound = 40 in let count = i * 5 in do_test (gen_map init bound count) (State.int init bound) done let test_multimap_empty_assoc_lists () = let module M = BatMultiPMap in let map = M.add 0 "foo" M.empty |> M.add 0 "bar" |> M.add 0 "sna" |> M.remove 0 "foo" |> M.remove 0 "bar" |> M.remove 0 "sna" in if M.mem 0 map then assert_failure (Printf.sprintf "map[0] should be empty but contains %d bindings\n" (BatPSet.cardinal (M.find 0 map))) let tests = "PMap" >::: [ "traversal order iter vs. enum" >:: test_traversal_order; "split" >:: test_split; "MultiPMap: removing empty association lists" >:: test_multimap_empty_assoc_lists; ] batteries-included-3.4.0/testsuite/test_print.ml000066400000000000000000000035121415601150500220420ustar00rootroot00000000000000open OUnit open Gc let few_tests = 10 let many_tests= 100000 (* (*For comparison, not part of Batteries.*) let run_legacy number_of_runs = begin Gc.full_major (); let devnull = Legacy.Pervasives.open_out "/dev/null" in foreach (1 -- number_of_runs) (fun _ -> Legacy.Printf.fprintf devnull "%a%!" (fun ch () -> Legacy.Printf.fprintf ch "Hello, world!") () ); Legacy.Pervasives.close_out devnull; Gc.full_major (); (Gc.stat()).live_words end let test_leak_legacy () = let words_few = run_legacy few_tests in let words_many= run_legacy many_tests in if words_few < words_many then assert_failure (Printf.sprintf "Memory use grew by %d" (words_many - words_few)) *) open Printf let run_oldstyle number_of_runs = Gc.full_major (); foreach (1 -- number_of_runs) (fun _ -> fprintf stdnull "%a%!" (fun ch () -> fprintf ch "Hello, world!") () ); Gc.full_major (); (Gc.stat()).live_words let test_leak_oldstyle () = let words_few = run_oldstyle few_tests in let words_many= run_oldstyle many_tests in if words_few < words_many then assert_failure (Printf.sprintf "Memory use grew by %d" (words_many - words_few)) open Print let run_newstyle number_of_runs = Gc.full_major (); let printer_hello k () = k (fun ch -> fprintf ch p"Hello, world!") in foreach (1 -- number_of_runs) (fun _ -> fprintf stdnull p"{%hello}%!" () ); Gc.full_major (); (Gc.stat()).live_words let test_leak_newstyle () = let words_few = run_newstyle few_tests in let words_many= run_newstyle many_tests in if words_few < words_many then assert_failure (Printf.sprintf "Memory use grew by %d" (words_many - words_few)) let tests = "Print" >::: [ (* "Legacy printing memory leak" >:: test_leak_legacy ;*) "Old-style printing memory leak" >:: test_leak_oldstyle ; "New-style printing memory leak" >:: test_leak_newstyle ] batteries-included-3.4.0/testsuite/test_random.ml000066400000000000000000000047371415601150500222000ustar00rootroot00000000000000open OUnit let assert_equal_arrays = assert_equal ~printer:(BatIO.to_string (BatArray.print BatInt.print)) let take_array n e = BatArray.of_enum (BatEnum.take n e) let test_enum_helper reset create modify = let make n = take_array n (create ()) in (* Enumerations constructed for the same state should be equal. *) let () = reset () in let a = make 10 in let () = reset () in let b = make 10 in let () = assert_equal_arrays a b in (* The states should be shared: if the state is modified then the second stream should be different. *) let () = reset () in let a = make 1000 in let () = reset () in let () = modify () in let b = make 1000 in let () = assert_bool "Different states but equal arrays" (a <> b) in (* Cloning should work even if the RNG state is changing. *) let e = create () in let e_clone = BatEnum.clone e in let () = modify () in assert_equal_arrays (take_array 10 e) (take_array 10 e_clone) (* Wrapper that assures that [cmd] does not modify the default state. *) let with_saved_state cmd = let state = BatRandom.get_state () in let () = cmd () in BatRandom.set_state state let test_enum_default () = let reset () = BatRandom.init 0 in let create () = BatRandom.enum_int 100 in let modify () = let _ = BatRandom.int 100 in () in with_saved_state (fun () -> test_enum_helper reset create modify) let test_enum_state () = let make_seed () = BatRandom.State.make [| 0 |] in let state = ref (make_seed ()) in let reset () = state := make_seed () in let create () = BatRandom.State.enum_int !state 100 in let modify () = let _ = BatRandom.State.int !state 100 in () in test_enum_helper reset create modify module PSE = BatRandom.Incubator.Private_state_enums let test_enum_default_priv () = let reset () = BatRandom.init 0 in let create () = PSE.enum_int 100 in let modify () = let _ = BatRandom.int 100 in () in with_saved_state (fun () -> test_enum_helper reset create modify) let test_enum_state_priv () = let make_seed () = BatRandom.State.make [| 0 |] in let state = ref (make_seed ()) in let reset () = state := make_seed () in let create () = PSE.State.enum_int !state 100 in let modify () = let _ = PSE.State.int !state 100 in () in test_enum_helper reset create modify let tests = "BatRandom" >::: [ "enum_default" >:: test_enum_default; "enum_state" >:: test_enum_state; "enum_default_priv" >:: test_enum_default_priv; "enum_state_priv" >:: test_enum_state_priv; ] batteries-included-3.4.0/testsuite/test_set.ml000066400000000000000000000542501415601150500215060ustar00rootroot00000000000000open Batteries module U = OUnit module IS = Set.Make(Int) let of_list l = List.fold_left (fun a i -> IS.add i a) IS.empty l let s1 = of_list [1;2;3] let s2 = of_list [1;2] let asseq_int = U.assert_equal ~printer:string_of_int let test_subset_compare () = asseq_int 1 (IS.compare_subset s1 s2); asseq_int (-1) (IS.compare_subset s2 s1) let (>:), (>::), (>:::) = U.(>:), U.(>::), U.(>:::) let (@?) = U.(@?) let (@!) msg (exn, f) = U.assert_raises ~msg exn f (* This functor is intended the features that are common in both the functorized Set and the polymorphic Set data structures. Currently, those two modules have a different interfaces : there are functions in one that aren't present in another. The tests are therefore not exhaustive : only common features are tested (but all such functions are tested), and Set-specific functions should be tested separately. As we hope, however, to make the feature set of both module converge in the long term, more features of one will be added to the other, and eventually all the features of both will be present here. *) module TestSet (S: sig type s type elt = int val equal : s -> s -> bool (* tested functions *) val empty : s val is_empty : s -> bool val singleton : elt -> s val add : elt -> s -> s val remove : elt -> s -> s val mem : elt -> s -> bool val cardinal : s -> int val min_elt : s -> elt val max_elt : s -> elt val pop : s -> elt * s val fold : (elt -> 'b -> 'b) -> s -> 'b -> 'b val iter : (elt -> unit) -> s -> unit val filter : (elt -> bool) -> s -> s val enum : s -> elt BatEnum.t val backwards : s -> elt BatEnum.t val of_enum : elt BatEnum.t -> s val for_all : (elt -> bool) -> s -> bool val exists : (elt -> bool) -> s -> bool val partition : (elt -> bool) -> s -> s * s val choose : s -> elt val split : elt -> s -> s * bool * s val union : s -> s -> s val inter : s -> s -> s val diff : s -> s -> s val sym_diff : s -> s -> s val disjoint : s -> s -> bool val min_elt_opt : s -> elt option val max_elt_opt : s -> elt option val update : elt -> elt -> s -> s val find_opt : elt -> s -> elt option val find_first : (elt -> bool) -> s -> elt val find_first_opt : (elt -> bool) -> s -> elt option val find_last : (elt -> bool) -> s -> elt val find_last_opt : (elt -> bool) -> s -> elt option val choose_opt : s -> elt option val map : (elt -> elt) -> s -> s val map_endo : (elt -> elt) -> s -> s val filter_map : (elt -> elt option) -> s -> s val filter_map_endo : (elt -> elt option) -> s -> s val add_seq : elt BatSeq.t -> s -> s val of_seq : elt BatSeq.t -> s val to_seq : s -> elt BatSeq.t val to_rev_seq : s -> elt BatSeq.t val to_seq_from : elt -> s -> elt BatSeq.t val elements : s -> elt list val print : ?first:string -> ?last:string -> ?sep:string -> ('a BatInnerIO.output -> elt -> unit) -> 'a BatInnerIO.output -> s -> unit end) = struct let li t = BatList.of_enum (S.enum t) let il li = S.of_enum (BatList.enum li) let s1 = il [1;2;3] let eq_li ?msg cmp_elt print_elt l1 l2 = let cmp t1 t2 = 0 = BatList.compare cmp_elt t1 t2 in let printer = BatIO.to_string @@ BatList.print print_elt in U.assert_equal ?msg ~cmp ~printer l1 l2 let eq ?msg cmp_elt print_elt t1 t2 = eq_li ?msg cmp_elt print_elt (li t1) (li t2) let (@=) msg (t1, t2) = eq ~msg BatInt.compare BatInt.print t1 t2 let test_is_empty () = "empty is empty" @? S.is_empty S.empty; "singleton is not empty" @? not (S.is_empty @@ S.singleton 1); () let test_singleton () = let k = 1 in "remove k (singleton k) is empty" @? S.is_empty (S.remove k (S.singleton k)); "mem k (singleton k)" @? (S.mem k (S.singleton k)); "to_list (singleton k) = [k]" @? (li (S.singleton k) = [k]); () let test_add () = let k, t = 1, il [3; 5] in "add k (add k t) = add k t" @= (S.add k (S.add k t), S.add k t); "add 4 [3; 5] = [3; 4; 5]" @= (S.add 4 t, il [3; 4; 5]); "add returns phys eq. set" @= (s1, (S.add 2 s1)); () let test_cardinal () = let k, k' = 1, 2 in "cardinal empty = 0" @? (S.cardinal S.empty = 0); "cardinal (singleton k) = 1" @? (S.cardinal (S.singleton k) = 1); "k <> k' => cardinal (add k' (singleton k)) = 2" @? (k <> k' && S.cardinal (S.add k' (S.singleton k)) = 2); "mem k t => cardinal (remove k t) = cardinal t - 1" @? (let t = il [k; k'] in S.cardinal (S.remove k t) = S.cardinal t - 1); () let test_remove () = let t = il [3; 5] in "not (mem k (remove k (add k (add k t))))" @? (let k, t = 1, t in not (S.mem k (S.remove k (S.add k (S.add k t))))); let test_cardinal k t = "cardinal (remove k t) = cardinal t - (mem k t ? 1 : 0)" @? (S.cardinal (S.remove k t) = S.cardinal t - if S.mem k t then 1 else 0) in test_cardinal 3 t; test_cardinal 57 t; "remove 4 s1 == s1" @? (s1 == (S.remove 4 s1)); "remove 4 empty == empty" @? (S.empty == (S.remove 4 S.empty)); () let test_update () = "update 2 2 s1 == s1" @? (s1 == S.update 2 2 s1); "update 2 5 s1 == of_list[1;3;5]" @= (il [1;3;5], S.update 2 5 s1); () let test_mem () = let k, k' = 1, 2 in "mem k (singleton k)" @? S.mem k (S.singleton k); "not (mem k (singleton k'))" @? not (S.mem k (S.singleton k')); () let test_min_elt () = let t = il [2; 1; 3; 2] in "min_elt [2; 1; 3; 2] = 1" @? (S.min_elt t = 1); "min_elt empty -> Not_found" @! (Not_found, fun () -> S.min_elt S.empty); () let test_max_elt () = let t = il [2; 1; 3; 2] in "max_elt [2; 1; 3; 2] = 3" @? (S.max_elt t = 3); "max_elt empty -> Not_found" @! (Not_found, fun () -> S.max_elt S.empty); () let test_min_elt_opt () = let t = il [2; 1; 3; 2] in "min_elt_opt [2; 1; 3; 2] = Some 1" @? (S.min_elt_opt t = Some 1); "min_elt_opt [] = None" @? (S.min_elt_opt S.empty = None); () let test_max_elt_opt () = let t = il [2; 1; 3; 2] in "max_elt_opt [2; 1; 3; 2] = Some 3" @? (S.max_elt_opt t = Some 3); "max_elt_opt [] = None" @? (S.max_elt_opt S.empty = None); () let test_choose () = "choose empty -> Not_found" @! (Not_found, fun () -> S.choose S.empty); let t = il [1; 3] in "mem (choose t) t" @? (S.mem (S.choose t) t); () let test_choose_opt () = "choose_opt empty = None" @? (S.choose_opt S.empty = None); let t = il [1; 3] in "mem (Option.get (choose t)) t" @? (S.mem (Option.get (S.choose_opt t)) t); () let test_pop () = "pop empty -> Not_found" @! (Not_found, fun () -> S.pop S.empty); let t = il [1; 2; 3; 4] in "not (mem (fst (pop t)) (snd (pop t)))" @? (not @@ S.mem (fst @@ S.pop t) (snd @@ S.pop t)); "let (k,t') = pop t in add k t' = t" @? (let k, t' = S.pop t in S.equal (S.add k t') t); () let test_split () = let k, _v, t = 1, 2, il [0; 1; 2; 4; 5] in "split k empty = (empty, false, empty)" @? (let (l, p, r) = S.split k S.empty in S.is_empty l && p = false && S.is_empty r); "split k (singleton k) = (empty, true, empty)" @? (let (l, p, r) = S.split k (S.singleton k) in S.is_empty l && p = true && S.is_empty r); "split 2 [0; 1; 2; 4; 5] = [0; 1], true, [4; 5]" @? (let (l, p, r) = S.split 2 t in li l = [0;1] && p = true && li r = [4;5]); "split 3 [0; 1; 2; 4; 5] = [0; 1; 2], false, [4; 5]" @? (let (l, p, r) = S.split 3 t in li l = [0;1;2] && p = false && li r = [4;5]); "split (min_elt t) t = (empty, true, remove_min_elt t)" @? (let mk = S.min_elt t in let (l, p, r) = S.split mk t in S.is_empty l && p = true && li r = li (S.remove mk r)); "split (max_elt t) t = (remove_max_elt t, true, empty)" @? (let mk = S.max_elt t in let (l, p, r) = S.split mk t in li l = li (S.remove mk l) && p = true && S.is_empty r); () let test_partition () = let t = il [0; 1; 2; 3; 4] in let p k = k mod 2 = 0 in "partition (fun k -> k mod 2 = 0) [0; 1; 2; 3; 4] = [0; 2; 4], [1; 3]" @? (let l, r = S.partition p t in li l = [0; 2; 4] && li r = [1; 3]); "partition (fun _ -> true) t = t, empty" @? (let l, r = S.partition (fun _ -> true) t in S.equal l t && S.is_empty r); "partition (fun _ -> false) t = empty, t" @? (let l, r = S.partition (fun _ -> false) t in S.is_empty l && S.equal r t); () let test_union () = "union [1; 2; 3] [2; 3; 4] = [1; 2; 3; 4]" @= (il [1; 2; 3; 4], S.union (il [1; 2; 3]) (il [2; 3; 4])); "union [1; 2; 3] [2; 3] = [1; 2; 3]" @= (il [1; 2; 3], S.union (il [1; 2; 3]) (il [2; 3])); "union [2; 3] [2; 3; 4] = [2; 3; 4]" @= (il [2; 3; 4], S.union (il [2; 3]) (il [2; 3; 4])); "union [2; 3] [2; 3] = [2; 3]" @= (il [2; 3], S.union (il [2; 3]) (il [2; 3])); "union [2] [] = [2]" @= (il [2], S.union (il [2]) (il [])); "union [] [3] = [3]" @= (il [3], S.union (il []) (il [3])); () let test_inter () = "inter [1; 2; 3] [2; 3; 4] = [2; 3]" @= (il [2; 3], S.inter (il [1; 2; 3]) (il [2; 3; 4])); "inter [1; 2; 3] [2; 3] = [2; 3]" @= (il [2; 3], S.inter (il [1; 2; 3]) (il [2; 3])); "inter [2; 3] [2; 3; 4] = [2; 3]" @= (il [2; 3], S.inter (il [2; 3]) (il [2; 3; 4])); "inter [2; 3] [2; 3] = [2; 3]" @= (il [2; 3], S.inter (il [2; 3]) (il [2; 3])); "inter [2] [] = []" @= (il [], S.inter (il [2]) (il [])); "inter [] [3] = []" @= (il [], S.inter (il []) (il [3])); () let test_diff () = "diff [1; 2; 3] [2; 3; 4] = [1]" @= (il [1], S.diff (il [1; 2; 3]) (il [2; 3; 4])); "diff [1; 2; 3] [2; 3] = [1]" @= (il [1], S.diff (il [1; 2; 3]) (il [2; 3])); "diff [2; 3] [2; 3; 4] = []" @= (il [], S.diff (il [2; 3]) (il [2; 3; 4])); "diff [2; 3] [2; 3] = []" @= (il [], S.diff (il [2; 3]) (il [2; 3])); "diff [2] [] = [2]" @= (il [2], S.diff (il [2]) (il [])); "diff [] [3] = []" @= (il [], S.diff (il []) (il [3])); () let test_sym_diff () = "sym_diff [1; 2; 3] [2; 3; 4] = [1; 4]" @= (il [1; 4], S.sym_diff (il [1; 2; 3]) (il [2; 3; 4])); "sym_diff [1; 2; 3] [2; 3] = [1]" @= (il [1], S.sym_diff (il [1; 2; 3]) (il [2; 3])); "sym_diff [2; 3] [2; 3; 4] = [4]" @= (il [4], S.sym_diff (il [2; 3]) (il [2; 3; 4])); "sym_diff [2; 3] [2; 3] = []" @= (il [], S.sym_diff (il [2; 3]) (il [2; 3])); "sym_diff [2] [] = [2]" @= (il [2], S.sym_diff (il [2]) (il [])); "sym_diff [] [3] = [3]" @= (il [3], S.sym_diff (il []) (il [3])); () let test_disjoint () = "disjoint [1] [1] = false" @? (neg2 S.disjoint (il [1]) (il [1])); "disjoint [1] [2] = true" @? (S.disjoint (il [1]) (il [2])); "disjoint [] [2] = true" @? (S.disjoint (il []) (il [2])); "disjoint [1] [] = true" @? (S.disjoint (il [1]) (il [])); "disjoint [1; 2] [3; 4] = true" @? (S.disjoint (il [1; 2]) (il [3; 4])); "disjoint [1; 2; 3] [1; 4; 5] = false" @? (neg2 S.disjoint (il [1; 2; 3]) (il [1; 4; 5])); () let test_find_opt () = "find_opt 1 (of_list [1;2;3;4;5;6;7;8])" @? ((S.find_opt 1 (il [1;2;3;4;5;6;7;8])) = Some 1); "find_opt 1 (of_list [1;2;3;4;5;6;7;8])" @? ((S.find_opt 8 (il [1;2;3;4;5;6;7;8])) = Some 8); "find_opt 2 (of_list [1])" @? ((S.find_opt (2) (il [1])) = None); () let test_find_first () = "find_first (fun x -> x >= 0) s1" @? (S.find_first (fun x -> x >= 0) s1 = 1); "find_first (fun x -> x >= 1) s1" @? (S.find_first (fun x -> x >= 1) s1 = 1); "find_first (fun x -> x >= 2) s1" @? (S.find_first (fun x -> x >= 2) s1 = 2); "find_first (fun x -> x >= 3) s1" @? (S.find_first (fun x -> x >= 3) s1 = 3); "find_first (fun x -> x >= 4) s1" @? (try ignore(S.find_first (fun x -> x >= 4) s1); false with Not_found -> true); "find_first (fun x -> x >= 3) S.empty" @? (try ignore(S.find_first (fun x -> x >= 3) S.empty); false with Not_found -> true); () let test_find_first_opt () = "find_first_opt (fun x -> x >= 0) s1" @? (S.find_first_opt (fun x -> x >= 0) s1 = Some 1); "find_first_opt (fun x -> x >= 1) s1" @? (S.find_first_opt (fun x -> x >= 1) s1 = Some 1); "find_first_opt (fun x -> x >= 2) s1" @? (S.find_first_opt (fun x -> x >= 2) s1 = Some 2); "find_first_opt (fun x -> x >= 3) s1" @? (S.find_first_opt (fun x -> x >= 3) s1 = Some 3); "find_first_opt (fun x -> x >= 4) s1" @? (S.find_first_opt (fun x -> x >= 4) s1 = None ); "find_first_opt (fun x -> x >= 3) S.empty" @? (S.find_first_opt (fun x -> x >= 3) S.empty = None ); () let test_find_last () = "find_last_opt (fun x -> x <= 1) s1" @? ( (S.find_last (fun x -> x <= 1) s1) = 1); "find_last_opt (fun x -> x <= 2) s1" @? ( (S.find_last (fun x -> x <= 2) s1) = 2); "find_last_opt (fun x -> x <= 3) s1" @? ( (S.find_last (fun x -> x <= 3) s1) = 3); "find_last_opt (fun x -> x <= 4) s1" @? ( (S.find_last (fun x -> x <= 4) s1) = 3); "find_last_opt (fun x -> x <= 0) s1" @? (try ignore(S.find_last (fun x -> x <= 0) s1); false with Not_found -> true); "find_last_opt (fun x -> x <= 3) S.empty" @? (try ignore(S.find_last (fun x -> x <= 3) S.empty); false with Not_found -> true); () let test_find_last_opt () = "find_last_opt s1 " @? ((S.find_last_opt (fun x -> x <= 0) s1) = None ); "find_last_opt s1 " @? ((S.find_last_opt (fun x -> x <= 1) s1) = Some 1); "find_last_opt s1 " @? ((S.find_last_opt (fun x -> x <= 2) s1) = Some 2); "find_last_opt s1 " @? ((S.find_last_opt (fun x -> x <= 3) s1) = Some 3); "find_last_opt s1 " @? ((S.find_last_opt (fun x -> x <= 4) s1) = Some 3); "find_last_opt S.empty " @? ((S.find_last_opt (fun x -> x <= 3) S.empty) = None ); () let test_add_seq () = "add_seq [1;2;3] [3;4]" @= (il [1;2;3;4], S.add_seq (BatSeq.of_list [1;2;3]) (il [3;4])); "add_seq [1;2] [3;4]" @= (il [1;2;3;4], S.add_seq (BatSeq.of_list [1;2]) (il [3;4])); "add_seq [] [3;4]" @= (il [3;4], S.add_seq (BatSeq.of_list []) (il [3;4])); "add_seq [1;2] [] " @= (il [1;2], S.add_seq (BatSeq.of_list [1;2]) (il [])); "add_seq [] [] " @= (il [], S.add_seq (BatSeq.of_list []) (il [])); () let test_of_seq () = "of_seq [1;2;3;4]" @= (il [1;2;3;4], S.of_seq (BatSeq.of_list [1;2;4;3])); "of_seq []" @= (il [] , S.of_seq (BatSeq.of_list [])); () let test_to_seq () = "to_seq [1;2;3;4]" @? (BatSeq.equal (BatSeq.of_list [1;2;3;4]) (S.to_seq (il [4;1;3;2]))); "to_seq []" @? (BatSeq.equal (BatSeq.of_list []) (S.to_seq (il []))); () let test_to_rev_seq () = "to_rev_seq [1;2;3;4]" @? (BatSeq.equal (BatSeq.of_list [4;3;2;1]) (S.to_rev_seq (il [4;1;3;2]))); "to_rev_seq []" @? (BatSeq.equal (BatSeq.of_list []) (S.to_rev_seq (il []))); () let test_to_seq_from () = "to_seq_from 0 [1;2;3;4]" @? (BatSeq.equal (BatSeq.of_list [1;2;3;4]) (S.to_seq_from 0 (il [4;1;3;2]))); "to_seq_from 3 [1;2;3;4]" @? (BatSeq.equal (BatSeq.of_list [3;4 ]) (S.to_seq_from 3 (il [4;1;3;2]))); "to_seq_from 5 [1;2;3;4]" @? (BatSeq.equal (BatSeq.of_list [ ]) (S.to_seq_from 5 (il [4;1;3;2]))); "to_seq_from 5 []" @? (BatSeq.equal (BatSeq.of_list [ ]) (S.to_seq_from 5 (il [] ))); () let test_for_all_exists () = let test (msg, for_all) = let (@?) str = (@?) (Printf.sprintf "[%s] %s" msg str) in "for_all (fun _ -> false) empty" @? for_all (fun _ -> false) S.empty; "for_all (fun _ -> true) empty" @? for_all (fun _ -> true) S.empty; let k = 1 in "for_all (fun _ -> true) (singleton k)" @? for_all (fun _ -> true) (S.singleton k); "not (for_all (fun _ -> false) (singleton k))" @? not (for_all (fun _ -> false) (S.singleton k)); "for_all (fun k' -> k = k') (singleton k)" @? for_all (fun k' -> k = k') (S.singleton k); () in let not_not_exists f li = not (S.exists (neg f) li) in List.iter test [ "for_all", S.for_all; "not not exists", not_not_exists ] let test_print () = let test str li = let str' = BatIO.to_string (S.print ~first:"{" ~last:"}" ~sep:", " BatInt.print) (il li) in U.assert_equal ~msg:"printing test" ~cmp:(fun x y -> 0 = String.compare x y) ~printer:(fun x -> x) str' str in test "{}" []; test "{0}" [0]; test "{0, 2}" [0; 2]; () let test_enums () = (* test enum, of_enum, backwards *) let test_of_enum f name_f t = eq ~msg:(Printf.sprintf "of_enum (%s t) = t" name_f) BatInt.compare BatInt.print (S.of_enum (f t)) t in List.iter (fun (f, name_f) -> test_of_enum f name_f (il []); test_of_enum f name_f (il [0; 4; 2])) [ S.enum, "enum"; S.backwards, "backwards"; (fun s -> BatList.enum (S.elements s)), "enum bindings"; ] let test_map () = "map (x -> 1) [1;2;3] == [1]" @= (S.map (fun _x -> 1) (il [1;2;3]), il [1]); "map (x -> x+5) [1;2;3] == [6;7;8]" @= (S.map (fun x -> x+5) (il [1;2;3]), il [6;7;8]); "map (x->x) [1;2;3] == [1;2;3]" @= (S.map (fun x -> x) (il [1;2;3]), il [1;2;3]); "map (x->x) [] == []" @= (S.map (fun x -> x+1) S.empty, S.empty); () let test_map_endo () = "map_endo (x -> 1) [1;2;3] == [1]" @= (S.map_endo (fun _x -> 1) (il [1;2;3]), il [1]); "map_endo (x -> x+5) [1;2;3] == [6;7;8]" @= (S.map_endo (fun x -> x+5) (il [1;2;3]), il [6;7;8]); "map_endo (x->x) [1;2;3] == [1;2;3] (test phys eq)" @? (let s = il [1;2;3] in s == (S.map_endo (fun x -> x) s)); "map_endo (x->x) [1;2;3] == [1;2;3] (test phys eq)" @? (let s = S.empty in s == (S.map_endo (fun x -> x+1) s)); () let test_filter () = "filter (fun x -> x < 10) [1;2;3] (phys eq)" @? (let s = il [1;2;3] in s == (S.filter (fun x -> x < 10) s)); "filter (fun x -> x > 10) [] (phys eq)" @? (let s = S.empty in s == (S.filter (fun x -> x > 10) s)); "filter (fun x -> x > 10) [] (phys eq)" @= (S.filter (fun x -> x > 10) (il [0;10;20;30]), il [20;30]); () let test_filter_map () = "filter_map (fun x -> Some x) [1;2;3]" @= (il [1;2;3], S.filter_map (fun x -> Some x) (il [1;2;3])); "filter_map (fun x -> Some x) [] (phys eq)" @= (S.empty, S.filter_map (fun x -> Some x) S.empty); "filter_map (fun x -> if x < 3 then Some (-x) else None) [1;2;3;4] = [-1;-2]" @= (S.filter_map (fun x -> if x < 3 then Some (-x) else None) (il [1;2;3;4]), il [-1;-2]); () let test_filter_map_endo () = "filter_map_endo (fun x -> Some x) [1;2;3] (phys eq)" @? (let s = il [1;2;3] in s == (S.filter_map_endo (fun x -> Some x) s)); "filter_map_endo (fun x -> Some x) [] (phys eq)" @? (let s = S.empty in s == (S.filter_map_endo (fun x -> Some x) s)); "filter_map_endo (fun x -> if x < 3 then Some (-x) else None) [1;2;3;4] = [-1;-2]" @= (S.filter_map_endo (fun x -> if x < 3 then Some (-x) else None) (il [1;2;3;4]), il [-1;-2]); () let test_iterators () = (* we test all iter/fold/filter in one go, by building a common filter implementation (using side-effects for iter). *) let from_filter p t = li (S.filter p t) in let from_fold p t = let acc e li = (if p e then [e] else []) @ li in List.rev @@ S.fold acc t [] in let from_iter p t = let acc = ref [] in S.iter (fun e -> if p e then acc := e :: !acc) t; List.rev !acc in (* I took care to write the input unsorted, to observe potential sorting bugs *) let t = il [4; 5; 3; 0; 6; 2; 1] in (* the predicate which all filteri implementations will use *) let p e = (e mod 2 = 0) in (* result (in sorted order) *) let result = [0; 2; 4; 6] in List.iter (fun (name, filter_n) -> let msg = Printf.sprintf "iterators test : %s" name in eq_li ~msg BatInt.compare BatInt.print result (filter_n p t)) [ "fold", from_fold; "iter", from_iter; "filter", from_filter; ] let tests = [ "test_is_empty" >:: test_is_empty; "test_singleton" >:: test_singleton; "test_cardinal" >:: test_cardinal; "test_add" >:: test_add; "test_remove" >:: test_remove; "test_mem" >:: test_mem; "test_min_elt" >:: test_min_elt; "test_max_elt" >:: test_max_elt; "test_choose" >:: test_choose; "test_split" >:: test_split; "test_partition" >:: test_partition; "test_union" >:: test_union; "test_inter" >:: test_inter; "test_diff" >:: test_diff; "test_sym_diff" >:: test_sym_diff; "test_disjoint" >:: test_disjoint; "test_for_all_exists" >:: test_for_all_exists; "test_print" >:: test_print; "test_enums" >:: test_enums; "test_iterators" >:: test_iterators; "test_pop" >:: test_pop; "test_find_opt" >:: test_find_opt; "test_find_first" >:: test_find_first; "test_find_first_opt" >:: test_find_first_opt; "test_find_last" >:: test_find_last; "test_find_last_opt" >:: test_find_last_opt; "test_update" >:: test_update; "test_min_elt_opt" >:: test_min_elt_opt; "test_max_elt_opt" >:: test_max_elt_opt; "test_choose_opt" >:: test_choose_opt; "test_add_seq" >:: test_add_seq; "test_of_seq" >:: test_of_seq; "test_to_seq" >:: test_to_seq; "test_to_rev_seq" >:: test_to_rev_seq; "test_to_seq_from" >:: test_to_seq_from; "test_map" >:: test_map; "test_map_endo" >:: test_map_endo; "test_filter_map_endo" >:: test_filter_map_endo; "test_filter" >:: test_filter; ] end module S = struct include BatSet.Make(BatInt) type s = t let map_endo = map let filter_map_endo = filter_map end module P = struct module S = BatSet type elt = int include S type s = elt t let inter = intersect end module TS = TestSet(S) module TP = TestSet(P) let tests = "Set" >::: [ "Subset_compare" >:: test_subset_compare; "usual tests on Set.Make" >::: TS.tests; "usual tests on PSet" >::: TP.tests; ] batteries-included-3.4.0/testsuite/test_stack.ml000066400000000000000000000021341415601150500220120ustar00rootroot00000000000000open OUnit module Enum = BatEnum module Stack = BatStack module List = BatList let tests = "Stack" >::: [ "of_enum empty" >:: begin function () -> let e = Enum.empty () in let s = Stack.of_enum e in assert_bool "stack is not empty" (Stack.is_empty s); assert_equal ~printer:string_of_int 0 (Stack.length s); end; "of_enum simple" >:: begin function () -> let e = List.enum [1;2;3] in let s = Stack.of_enum e in assert_bool "stack is empty" (not (Stack.is_empty s)); assert_equal ~printer:string_of_int 3 (Stack.length s); assert_equal ~printer:string_of_int 3 (Stack.pop s); assert_equal ~printer:string_of_int 2 (Stack.pop s); assert_equal ~printer:string_of_int 1 (Stack.pop s); assert_raises Stack.Empty (fun () -> Stack.pop s); end; "enum empty" >:: begin function () -> let e = Stack.enum (Stack.create ()) in assert_bool "enum is not empty" (Enum.is_empty e); end; "enum nonempty" >:: begin function () -> let s = Stack.create () in Stack.push 5 s; Stack.push 7 s; assert_equal [7;5] (List.of_enum (Stack.enum s)); end ] batteries-included-3.4.0/testsuite/test_string.ml000066400000000000000000000045771415601150500222300ustar00rootroot00000000000000open OUnit open BatString let string = "Jon \"Maddog\" Orwant" open BatEnum (* let test_take_and_skip () = let foo s : string list = let e = enum s in [? List : of_enum (f e) | f <- List : [take 5; skip 3 %> take 5; take 5 ; identity] ?] in assert_equal ~printer:(Printf.sprintf2 "%a" (List.print String.print_quoted)) ["Jon \""; "dog\" "; "Orwan"; "t"] (foo string) *) let test_starts_with () = let check expected prefix = let s = match expected with true -> "" | false -> "not " in if starts_with string prefix <> expected then assert_failure (Printf.sprintf "String %S should %sstart with %S" string s prefix) in check true "Jon"; check false "Jon \"Maddog\" Orwants"; check false "Orwants" let test_ends_with () = let check expected suffix = let s = match expected with true -> "" | false -> "not " in if ends_with string suffix <> expected then assert_failure (Printf.sprintf "String %S should %send with %S" string s suffix) in check true "want"; check false "I'm Jon \"Maddog\" Orwant"; check false "Jon" let test_nsplit () = let printer = BatPrintf.sprintf2 "%a" (BatList.print BatString.print) in let check exp s sep = assert_equal ~printer exp (nsplit s sep) in check ["a"; "b"; "c"] "a/b/c" "/"; check [""; "a"; "b"; "c"; ""; ""] "/a/b/c//" "/"; check [""; "a"; "b"; "c"; ""; ""] "FOOaFOObFOOcFOOFOO" "FOO" let assert_no_raises : ?msg:string -> (unit -> 'a) -> 'a = fun ?(msg="Function raised an exception when none was expected.") f -> try f () with exn -> assert_failure (msg ^ " " ^ Printexc.to_string exn) let test_exists () = let check haystack needle expected = let msg = Printf.sprintf "exists \"%s\" \"%s\" = %b" (String.escaped haystack) (String.escaped needle) expected in assert_equal ~msg (assert_no_raises ~msg:(msg ^ " raised exception ") (fun () -> BatString.exists haystack needle)) expected in check "" "" true; check "a" "" true; check "" "a" false; check "ab" "a" true; check "ab" "b" true; check "ab" "c" false let tests = "String" >::: [ (* "Taking and skipping" >:: test_take_and_skip; *) "Start with" >:: test_starts_with; "Ends with" >:: test_ends_with; "Splitting with nsplit" >:: test_nsplit; "Exists" >:: test_exists; ] batteries-included-3.4.0/testsuite/test_substring.ml000066400000000000000000000146551415601150500227400ustar00rootroot00000000000000open OUnit open BatSubstring open BatPervasives let test_dropr = let aeq = assert_equal ~printer:identity in [ begin "dropr empty" >:: fun () -> aeq "" (to_string (dropr (const true) (of_string ""))); aeq "" (to_string (dropr (const false) (of_string ""))) end; begin "dropr none" >:: fun () -> aeq "foo" (to_string (dropr (const false) (of_string "foo"))) end; begin "dropr all" >:: fun () -> aeq "" (to_string (dropr (const true) (of_string "foo"))) end; begin "dropr some" >:: fun () -> aeq "f" (to_string (dropr ((=) 'o') (of_string "foo"))) end; ];; let test_dropl = let aeq = assert_equal ~printer:identity in [ begin "dropl empty" >:: fun () -> aeq "" (to_string (dropl (const true) (of_string ""))); aeq "" (to_string (dropl (const false) (of_string ""))) end; begin "dropl none" >:: fun () -> aeq "foo" (to_string (dropl (const false) (of_string "foo"))) end; begin "dropl all" >:: fun () -> aeq "" (to_string (dropl (const true) (of_string "foo"))) end; begin "dropl some" >:: fun () -> aeq "oo" (to_string (dropl ((=) 'f') (of_string "foo"))) end; ];; let test_taker = let aeq = assert_equal ~printer:identity in [ begin "taker empty" >:: fun () -> aeq "" (to_string (taker (const true) (of_string ""))); aeq "" (to_string (taker (const false) (of_string ""))) end; begin "taker none" >:: fun () -> aeq "" (to_string (taker (const false) (of_string "foo"))) end; begin "taker all" >:: fun () -> aeq "foo" (to_string (taker (const true) (of_string "foo"))) end; begin "taker some" >:: fun () -> aeq "oo" (to_string (taker ((=) 'o') (of_string "foo"))) end; ];; let test_takel = let aeq = assert_equal ~printer:identity in [ begin "takel empty" >:: fun () -> aeq "" (to_string (takel (const true) (of_string ""))); aeq "" (to_string (takel (const false) (of_string ""))) end; begin "takel none" >:: fun () -> aeq "" (to_string (takel (const false) (of_string "foo"))) end; begin "takel all" >:: fun () -> aeq "foo" (to_string (takel (const true) (of_string "foo"))) end; begin "takel some" >:: fun () -> aeq "f" (to_string (takel ((=) 'f') (of_string "foo"))) end; ];; let to_strings (x,y) = to_string x, to_string y let test_splitr = let printer (s1,s2) = Printf.sprintf "(%S,%S)" s1 s2 in let aeq = assert_equal ~printer in [ begin "splitr empty" >:: fun () -> aeq ("","") (to_strings (splitr (const true) (of_string ""))); aeq ("","") (to_strings (splitr (const false) (of_string ""))) end; begin "splitr none" >:: fun () -> aeq ("foo","") (to_strings (splitr (const false) (of_string "foo"))) end; begin "splitr all" >:: fun () -> aeq ("","foo") (to_strings (splitr (const true) (of_string "foo"))) end; begin "splitr some" >:: fun () -> aeq ("f","oo") (to_strings (splitr ((=) 'o') (of_string "foo"))) end; ];; let test_splitl = let printer (s1,s2) = Printf.sprintf "(%S,%S)" s1 s2 in let aeq = assert_equal ~printer in [ begin "splitl empty" >:: fun () -> aeq ("","") (to_strings (splitl (const true) (of_string ""))); aeq ("","") (to_strings (splitl (const false) (of_string ""))) end; begin "splitl none" >:: fun () -> aeq ("","foo") (to_strings (splitl (const false) (of_string "foo"))) end; begin "splitl all" >:: fun () -> aeq ("foo","") (to_strings (splitl (const true) (of_string "foo"))) end; begin "splitl some" >:: fun () -> aeq ("f","oo") (to_strings (splitl ((=) 'f') (of_string "foo"))) end; ];; let test_slice = let printer sus = let (s,i,n) = base sus in Printf.sprintf "(%S,%d,%d)" s i n in let cmp sus1 sus2 = to_string sus1 = to_string sus2 in let aeq = assert_equal ~printer ~cmp in [ begin "slice empty" >:: fun () -> aeq (empty ()) (slice (empty ()) 0 None) end; begin "slice all" >:: fun () -> aeq (of_string "foo") (slice (of_string "foo") 0 None); aeq (of_string "foo") (slice (of_string "foo") 0 (Some 3)); end; begin "slice none" >:: fun () -> aeq (of_string "") (slice (of_string "foo") 3 None); aeq (of_string "") (slice (of_string "foo") 3 (Some 0)); end; begin "slice some" >:: fun () -> aeq (of_string "oo") (slice (of_string "foo") 1 None); aeq (of_string "oo") (slice (of_string "foo") 1 (Some 2)); end; begin "slice pick" >:: fun () -> aeq (of_string "i") (slice (of_string "jim") 1 (Some 1)); end; ];; let test_index_from = let aeq = assert_equal ~printer:string_of_int in [ begin "index from" >:: fun () -> aeq (index_from (of_string "foobar") 2 'b') (2+index (triml 2 (of_string "foobar")) 'b') end; ];; let test_rindex_from = let aeq = assert_equal ~printer:string_of_int in [ begin "rindex from" >:: fun () -> aeq (rindex_from (of_string "foobar") 2 'b') (rindex (trimr 2 (of_string "foobar")) 'b') end; ];; let test_is_prefix = let aeq = assert_equal ~printer:string_of_bool in [ begin "is_prefix" >:: fun () -> aeq (is_prefix "foo" (of_string "foobar")) true; aeq (is_prefix "foj" (of_string "foobar")) false; aeq (is_prefix "foobarz" (of_string "foobar")) false; aeq (is_prefix "foobar" (of_string "foobar")) true; end; ];; let test_enum = let test_enum ss = ss |> to_string |> BatString.enum in let ss = of_string "testing" in [ begin "enum" >:: fun () -> assert_equal (ss |> enum |> BatString.of_enum) "testing"; assert_equal (size ss) (ss |> enum |> BatEnum.count) ~printer:string_of_int; assert_equal (ss |> enum |> BatString.of_enum) (ss |> test_enum |> BatString.of_enum) end ] let test_iteri = let ss = of_string "test" in let mark = ref false in let r = ref [] in ss |> iteri (fun i _ -> mark := true; r := i::(!r) ); [ begin "iteri" >:: fun () -> assert_equal !mark true ~printer:string_of_bool; assert_equal (List.rev !r) [0;1;2;3] end ] let tests = "Substring" >::: [ "dropr" >::: test_dropr; "dropl" >::: test_dropl; "taker" >::: test_taker; "takel" >::: test_takel; "splitr" >::: test_splitr; "splitl" >::: test_splitl; "slice" >::: test_slice; "index_from" >::: test_index_from; "is_prefix" >::: test_is_prefix; "enum" >::: test_enum; "test_iteri" >::: test_iteri; ];; batteries-included-3.4.0/testsuite/test_toplevel.ml000066400000000000000000000050741415601150500225450ustar00rootroot00000000000000open OUnit (*Source code which needs to be executed*) let make_temporary_file content = File.with_temporary_out ~suffix:".ml" begin fun out name -> String.print out content; name end let expected = "read-only string";; open Compilers open IO let test_from_source_file () = let source = "Print.printf p\"%sc\" ro\"read-only string\";;" in let generated_file = make_temporary_file source in let temp_name = Filename.temp_file "ocaml" "test" in ignore (Sys.command (string_of_command (ocaml [generated_file]) ^ " > " ^ temp_name)); let obtained = File.with_file_in temp_name read_all in assert_equal ~printer:(Printf.sprintf "%S") expected obtained let test_from_simulated_cmdline () = let temp_name = Filename.temp_file "ocaml" "test" in let source = Print.sprintf p"File.with_file_out %S (fun out -> Print.fprintf out p\"%%sc\" ro\"read-only string\");;\n" temp_name in let generated_file = make_temporary_file source in let command = string_of_command (ocaml []) ^ " < " ^ generated_file ^ " > /dev/null " in (* Printf.eprintf "Running %S\nWriting to file %S\n%!" command temp_name;*) ignore (Sys.command command); flush_all (); let obtained = File.with_file_in temp_name read_all in assert_equal ~printer:(Printf.sprintf "%S") expected obtained (* let test_1 = ("OCaml: Testing from source file", fun () -> try let generated_file = File.with_temporary_out ~suffix:".ml" begin fun out name -> String.print out source; name end in let temp_name = Filename.temp_file "ocaml" "test" in ignore (Sys.command (string_of_command (ocaml [generated_file]) ^ "> temp_name")); let obtained = File.with_file_in temp_name read_all in if obtained = expected then Testing.Pass else Testing.Fail (Printf.sprintf "Expected: %S\n\tObtained: %S\n" expected obtained) with e -> Testing.Err (Printexc.to_string e)) let test_2 = ("OCaml: Testing from simulated command-line", fun () -> try let command = string_of_command (ocaml []) in let (pin, pout)=Unix.open_process ~cleanup:true command in String.print pout source; close_out pout; let obtained = read_all pin in if obtained = expected then Testing.Pass else Testing.Fail (Printf.sprintf "Expected: %S\n\tObtained: %S\n" expected obtained) with e -> Testing.Err (Printexc.to_string e)) *) let tests = "Toplevel" >::: [ "From source file" >:: test_from_source_file; "From simulated command-line" >:: test_from_simulated_cmdline; ] batteries-included-3.4.0/testsuite/test_unix.ml000066400000000000000000000027331415601150500216750ustar00rootroot00000000000000open OUnit open BatPrintf open BatIO let string = "hello world" let test_open_process_readline () = try let r,w = BatUnix.open_process "cat" in fprintf w "%s\n" string; close_out w; match BatIO.read_line r with | s when s = string -> () | s -> assert_failure (BatPrintf.sprintf "Expected %S, got %S" string s) with e -> assert_failure (BatPrintf.sprintf "Expected %S, got exception %s" string (Printexc.to_string e)) let test_open_process_cleanup () = try let r,w = BatUnix.open_process "cat" in BatPrintf.fprintf w "%s\n" string; close_out w; while true do ignore (BatPervasives.input_char r) (*This is a way of checking that the process is closed.*) done with End_of_file | No_more_input -> () | e -> assert_failure (BatPrintf.sprintf "Expected %S, got exception %s" string (Printexc.to_string e)) (*let test_open_process_close_process () = (*Actually, this test shouldn't work*) try let r,w = Unix.open_process "cat" in fprintf w p"%s\n" string; ignore (Unix.close_process (r, w)); while true do ignore (input_char r); (*This is a way of checking that the process is closed.*) done with End_of_file | No_more_input -> () | e -> assert_failure (sprintf p"Expected %S, got exception %exn" string e)*) let tests = "Unix" >::: [ "Open process, then read_line" >:: test_open_process_readline; "Open process, then clean up" >:: test_open_process_cleanup ] batteries-included-3.4.0/testsuite/test_uref.ml000066400000000000000000000100561415601150500216500ustar00rootroot00000000000000module M = BatUref module U = OUnit let (>:), (>::), (>:::) = U.(>:), U.(>::), U.(>:::) let (@?) = U.(@?) let (@!) msg (exn, f) = U.assert_raises ~msg exn f let test_uref_uget_uset () = let v, v' = 1, 2 in "uget (uref v) = v" @? (M.uget (M.uref v) = v); "let r = uref v in uset r v'; uget r = v'" @? (let r = M.uref v in M.uset r v'; M.uget r = v'); () let test_unite () = let v, v' = 1, 2 in "let r = unref v in unite r r; uget r = v" @? (let r = M.uref v in M.unite r r; M.uget r = v); "let r, r' = unref v, unref v' in unite r r'; uget r = v' && uget r' = v'" @? (let r, r' = M.uref v, M.uref v' in M.unite r r'; M.uget r = v && M.uget r' = v); "let r, r' = unref v, unref v' in unite ~sel:(fun _x y -> y) r r'; uget r = v && uget r' = v" @? (let r, r' = M.uref v, M.uref v' in M.unite ~sel:(fun _x y -> y) r r'; M.uget r = v' && M.uget r' = v'); "let r = uref v in unite ~sel:(fun _ _ -> v') r r; uget r = v'" @? (let r = M.uref v in M.unite ~sel:(fun _ _ -> v') r r; M.uget r = v'); "let r, r' = uref v, uref v in unite ~sel:(fun _ _ -> v') r r'; uget r = v'" @? (let r, r' = M.uref v, M.uref v' in M.unite ~sel:(fun _ _ -> v') r r'; M.uget r = v'); "let r, r' = uref (ref v), uref (ref v) in uget r != uget r' && (unite r r'; uget r == uget r')" @? (let r, r' = M.uref (ref v), M.uref (ref v) in M.uget r != M.uget r' && (M.unite r r'; M.uget r == M.uget r')); "let r, r' = uref v, uref v in unite r r'; unite r' r; unite r' r; equal r r'" @? (let r, r' = M.uref v, M.uref v' in List.iter (fun (x, y) -> M.unite x y) [r,r'; r',r; r',r]; M.equal r r'); () let test_equal () = let v, v' = 1, 2 in "let r = uref v in equal r r" @? (let r = M.uref v in M.equal r r); "let r, r' = uref v, uref v in not (equal r r')" @? (let r, r' = M.uref v, M.uref v in not (M.equal r r')); let inequal_then_equal r r' = not (M.equal r r') && (M.unite r r'; M.equal r r') in "let r, r' = uref v, uref v' in not (equal r r') && (unite r r'; equal r r')" @? (inequal_then_equal (M.uref v) (M.uref v')); "let ra, ra' = uref v, uref v in let rb, rb' = uref v, uref v in unite ra ra'; unite rb rb'; not (equal ra' rb') && (unite ra rb; equal ra' rb')" @? (let ra, ra' = M.uref v, M.uref v in let rb, rb' = M.uref v, M.uref v in M.unite ra ra'; M.unite rb rb'; inequal_then_equal ra' rb'); () let test_unite_shuffle () = (* testing the unification in all possible orders of n urefs unfornatunaly, since this is an imperative structure where you can't undo operations, this is slightly complicated *) let pick_one n l f = assert (n <> 0); for i = 0 to n - 1 do let elt_l () = let l, rest = l () in let elt = BatList.nth l i in let l = let l1, l2 = BatList.split_at i l in l1 @ BatList.tl l2 in elt, l, rest in f elt_l done in let rec pick_two n l check = pick_one n l (fun elt_l -> if n = 1 then let elt, l, orig = elt_l () in assert (l = []); check elt orig else pick_one (n - 1) (fun () -> let elt, l, orig = elt_l () in l, (elt, orig)) (fun elt2_l_elt -> pick_two (n - 1) (fun () -> let elt, l, (elt2, orig) = elt2_l_elt () in M.unite ~sel:(+) elt elt2; elt :: l, orig ) check; pick_two (n - 1) (fun () -> let elt, l, (elt2, orig) = elt2_l_elt () in M.unite ~sel:(+) elt elt2; elt2 :: l, orig ) check; ) ) in let n = 4 in let urefs () = let l = BatList.init n (fun i -> M.uref i) in l, l in pick_two n urefs (fun elt urefs -> U.assert_equal ~printer:string_of_int (n * (n - 1) / 2) (M.uget elt); BatList.iter (fun uref -> U.assert_equal true (M.equal elt uref)) urefs ) let tests = "Uref" >::: [ "uref, uget, uset" >:: test_uref_uget_uset; "unite" >:: test_unite; "equal" >:: test_equal; "unite_shuffle" >:: test_unite_shuffle; ] batteries-included-3.4.0/testsuite/test_vect.ml000066400000000000000000000027361415601150500216560ustar00rootroot00000000000000open OUnit open BatVect open BatPervasives (**Initialize data sample*) let state = BatRandom.State.make [|0|] let buffer = BatArray.of_enum (BatEnum.take 1000 (BatRandom.State.enum_int state 255)) let vect = of_array buffer let print_array out = BatArray.print ~sep:"; " BatInt.print out let print_vect out = BatVect.print ~sep:"; " BatInt.print out let sprint_vect v = BatPrintf.sprintf2 "%a" print_vect v let test_array_conversion () = assert_equal ~printer:sprint_vect vect (to_array vect |> of_array |> to_array |> of_array) let test_init () = let f i = i * i in let vect = init 1000 f and array = Array.init 1000 f in if BatEnum.compare ( BatInt.compare ) (enum vect) (BatArray.enum array) = 0 then () (* pass *) else assert_failure (BatPrintf.sprintf2 "Hoping: %a\n\tGot: %a" print_array array print_vect vect) let test_fold_left () = let f i = i * i and g i j = i * i + j in let vect = fold_left g 0 (init 1000 f) and array = Array.fold_left g 0 (Array.init 1000 f) in assert_equal ~printer:string_of_int array vect let test_fold_right () = let f i = i * i and g i j = i * i + j in let vect = fold_right g (init 1000 f) 0 and array = Array.fold_right g (Array.init 1000 f) 0 in assert_equal ~printer:string_of_int array vect let tests = "Vect" >::: [ "Converting to/from array" >:: test_array_conversion; "Init" >:: test_init; "Fold_left" >:: test_fold_left; "Fold_right" >:: test_fold_right; ] batteries-included-3.4.0/toplevel/000077500000000000000000000000001415601150500171155ustar00rootroot00000000000000batteries-included-3.4.0/toplevel/_tags000066400000000000000000000000411415601150500201300ustar00rootroot00000000000000: compiler-libs batteries-included-3.4.0/toplevel/batteriesHelp.ml000066400000000000000000000352071415601150500222510ustar00rootroot00000000000000(* * Batteries_help - Calling the help system from the toplevel * Copyright (C) 2009 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open BatIO (*let debug fmt = Printf.eprintf fmt*) let debug fmt = BatPrintf.fprintf BatIO.stdnull fmt (** {6 Kinds} *) type kinds = | Values | Types | Topics | Modules | Exns | Modtypes | Classes | Methods | Attributes | Objtypes (** Parse a category name into a topic.*) let kind_of_name = function | "topic" | "language" -> Some Topics | "values" -> Some Values | "types" -> Some Types | "modules" -> Some Modules | "exceptions"| "exns" -> Some Exns | "modtypes" | "module_types" -> Some Modtypes | "classes" -> Some Classes | "methods" -> Some Methods | "attributes" -> Some Attributes | "class_types" -> Some Objtypes | _ -> None (** {6 Tables} *) type url = string(**A kind of string used to represent URLs. Distinguished for documentation purposes.*) type qualified = string(**A kind of string used to represent fully-qualified names.*) type unqualif = string(**A kind of string used to represent unqualified names, i.e. names without their module.*) type package = string(**A kind pf string used to represent help providers.*) type suggestion = { url : url(**The url to open in the browser to visit help on this suggestion.*); spackage : package(**The package which provides the url.*); } type completion = { qualified: qualified (**A possible qualified name matching the request*); cpackage : package (**The package which provides the completion.*) } type table = { suggestions: (qualified, suggestion) Hashtbl.t(**A map from fully qualified name to suggestions.*); completions: (unqualif, completion list) Hashtbl.t(**A map from unqualified name to a list of completions.*) } (** Convert a table of reflists to a table of lists. *) let table_of_tableref t = let result = Hashtbl.create (Hashtbl.length t) in Hashtbl.iter (fun k d -> Hashtbl.add result k (BatRefList.to_list d)) t; result let append_to_table table k v = let found = try Hashtbl.find table k with Not_found -> let l = BatRefList.empty () in Hashtbl.add table k l; l in BatRefList.push found v (** {6 Browsing} *) let browse pages = try List.iter (fun page -> debug "Showing %s\n" page.url; if BatteriesConfig.browse page.url <> 0 then raise Exit) pages with Exit -> Printf.eprintf "Sorry, I had a problem communicating with your browser and I couldn't open the manual.\n%!" (** {6 Loading} *) (**Extract the unqualified name of a possibly qualified name. [local_name "a.b.c.d"] produces ["d"]*) let local_name s = try snd (BatString.rsplit s ~by:".") with Not_found -> s (** Load the contents of an index file into hash tables. *) let load_index ~name ~index ~prefix ~suggestions ~completions = try BatEnum.iter (fun line -> Scanf.sscanf line " %S : %S " (fun item url -> let full_url = try ignore (BatString.find url "://"); url with Not_found -> prefix^url in Hashtbl.add suggestions item {spackage = name; url = full_url}; (*Add fully qualified name -> url*) let basename = Filename.basename item in let leafname = local_name basename in let completion={cpackage = name; qualified = item} in append_to_table completions basename completion; if leafname <> basename then append_to_table completions leafname completion; debug "Adding manual %S => %S (%S)\n" item full_url name; debug "Adding completion %S => %S (%S)\n" basename item name; debug "Adding completion %S => %S (%S)\n" leafname item name )) (BatFile.lines_of index) with e -> Printf.eprintf "While initializing the on-line help, error reading index file %S\n%s\n%!" index (Printexc.to_string e) (** Acquire a table, loading it if it hasn't been loaded yet. {b Note} This function is thread-unsafe. Don't call it from any thread other than the main thread. *) let get_table = let tables : (kinds, table) Hashtbl.t = Hashtbl.create 16 in fun kind -> try Hashtbl.find tables kind with Not_found -> let root_dir = BatteriesConfig.documentation_root in let root_file = Filename.concat root_dir "documentation.idex" in try let suggestions = Hashtbl.create 256 and completions = Hashtbl.create 256 in BatEnum.iter (fun line -> try Scanf.sscanf line "%s %s " (fun category index -> match kind_of_name category with | Some k when k = kind -> let index = Filename.concat root_dir index in let html_directory = Filename.dirname index in if Sys.file_exists index then load_index ~name:"OCaml Batteries Included" ~index ~prefix:("file://"^html_directory^"/") ~suggestions ~completions | _ -> () ) with _ -> () (*At this point, ignore syntax errors, they're probably comments.*) ) (BatFile.lines_of root_file); let result = {suggestions = suggestions; completions = table_of_tableref completions} in Hashtbl.add tables kind result; result with e -> Printf.eprintf "While initializing the on-line help, error in root doc file %S\n%s\n%!" root_file (Printexc.to_string e); let result = {suggestions = Hashtbl.create 0; completions = Hashtbl.create 0} in Hashtbl.add tables kind result; result (** {6 Searching} *) (**Print a warning regarding inconsistencies.*) let inconsistency topic subject = Printf.eprintf "Configuration issue: the help system promises something about a %s called %S but does not contain anything such. There may be an error with your installation of the documentation.\n" topic subject (** Find all the URL of each qualified name from a list of completions. Qualified names which can't be found in the table are dropped and a warning is printed. *) let result_of_completions table singular subject (l:completion list) = BatList.filter_map (fun {qualified = q; _} -> try Some (Hashtbl.find table.suggestions q) with Not_found -> inconsistency singular subject; (*Report internal inconsistency*) None) l (** Look for a given subject inside one of the manuals @param singular The singular noun corresponding to this manual. This string is used to display information regarding where the information may be found. @param plural The plural noun corresponding to this manual. This string is used to display information regarding where the information may be found. @param kind The key corresponding to the manual. @param subject The subject to search inside a manual. *) let man_aux ~kind ~singular ~plural subject = try let table = get_table kind in try match Hashtbl.find table.completions subject with | [] -> `No_result (*No completion on the subject, report subject not found*) | [{qualified = q; _}] as l -> (*Check for inconsistency*) (try ignore (Hashtbl.find table.suggestions q); `Suggestions (l, table) with Not_found -> inconsistency singular subject; `No_result) | l -> `Suggestions (l, table) with Not_found -> `No_result with Sys_error e -> Printf.printf "Sorry, I had a problem loading the help on %s. Deactivating help on that subject.\n Detailed error message is %s\n" plural e; `No_result (** Look for a given subject inside one of the manuals and display the results. @param cmd The command used to invoke this manual. This string is used to suggest further searches. @param singular The singular noun corresponding to this manual. This string is used to display information regarding where the information may be found. @param plural The plural noun corresponding to this manual. This string is used to display information regarding where the information may be found. @param kind The key corresponding to the manual. @param tabs If [true], all matching subjects will be opened, each one in its tab. Otherwise, a message will allow selecting one subject. @param subject The subject to search inside a manual. *) let man ~cmd ~kind ~singular ~plural ~tabs subject = match man_aux ~kind ~singular ~plural subject with `No_result -> Printf.printf "Sorry, I don't know any %s named %S.\n%!" singular subject | `Suggestions (l,table) when tabs -> browse (result_of_completions table singular subject l) | `Suggestions ([h],table) -> browse (result_of_completions table singular subject [h]) | `Suggestions (l,_) -> BatPrintf.printf "Several %s exist with name %S. To obtain help on one of them, please use one of\n %a%!" plural subject (BatList.print ~first:"" ~sep:"\n " ~last:"\n" (fun out {qualified = q; _} -> BatPrintf.fprintf out " %s %S\n" cmd q)) l (** Look for a given subject across all manuals and display the results. *) let man_all sources ~tabs subject = let found_something = if tabs then List.fold_left (fun was_found (*Browse help directly*) (_cmd, kind, singular, plural, _undefined) -> match man_aux ~kind ~singular ~plural subject with | `No_result -> was_found | `Suggestions (l, table) -> match result_of_completions table singular subject l with | [] -> false (*Inconsistency*) | l' -> let _ = browse l' in true) false sources else match List.fold_left (fun (((result_as_strings : string list)(*The text to display, as a list of strings, one string per kind.*), _one_suggestion (*The latest suggestion -- used only in case there's only one suggestion.*)) as acc) (cmd, kind, singular, plural, _undefined) -> match man_aux ~kind ~singular ~plural subject with | `No_result -> acc | `Suggestions ([h], table) -> let display : string = Printf.sprintf "There's information on %S in %s. To read this information, please use\n %s %S%!" subject plural cmd h.qualified in (display :: result_as_strings, `Browse (h, table, singular)) | `Suggestions (l,_) -> let display : string = BatPrintf.sprintf2 "There's information on %S in %s. To read this information, please use one of\n%a%!" subject plural (BatList.print ~first:"" ~sep:"" ~last:"" (fun out {qualified = q; _} -> BatPrintf.fprintf out " %s %S\n" cmd q)) l in (display::result_as_strings, `No_browsing)) ([], `No_result) sources with | ([], _) -> false (*No result*) | ([_],`Browse (l,table, singular) ) -> (match result_of_completions table singular subject [l] with | [] -> false (*Inconsistency*) | l' -> let _ = browse l' in true) | (texts, _) -> BatPrintf.printf "Several definitions exist for %S.\n%a%!" subject (BatList.print ~first:"" ~sep:"\n" ~last:"\n" BatString.print) texts; true in if not found_something then Printf.printf "Sorry, I don't know anything about %S.\n%!" subject (** {6 Registration} *) (** The various functions which may be used to access the manual.*) let helpers = let sources = [("#man_value", Values , "value", "values", "a value"); ("#man_type", Types , "type", "types", "a type" ); ("#man_topic", Topics , "topic", "topics", "a topic"); ("#man_module", Modules , "module", "modules", "a module" ); ("#man_exception", Exns , "exception", "exceptions", "an exception"); ("#man_signature", Modtypes , "signature", "signatures", "a signature" ); ("#man_class", Classes , "class", "classes", "a class" ); ("#man_method", Methods, "method", "methods", "a method" ); ("#man_attribute", Attributes,"attribute", "attributes", "an attribute" ); ("#man_objtype", Objtypes , "object type", "object types", "an object type")] in ("man", man_all sources ~tabs:false):: (List.map (fun (cmd, kind, singular, plural, _undefined) -> (String.sub cmd 1 (String.length cmd - 1), man ~cmd ~kind ~singular ~plural ~tabs:false)) sources) (**Launch the introductory help text.*) let help () = BatFile.with_file_in (BatteriesConfig.documentation_root ^ "/toplevel.help") (fun file -> copy file stdout); flush stdout;; (**Print the signature of a module.*) let print_module name = try let flattened = Str.global_replace (Str.regexp "[^_0-9a-zA-Z]") "__" name in let phrase = !Toploop.parse_toplevel_phrase (Lexing.from_string (Printf.sprintf "module %s = %s;;" flattened name)) in ignore (Toploop.execute_phrase true Format.std_formatter phrase) with _ -> ();; let man = List.assoc "man" helpers (** Initialize the help system (lazily)*) let init () = try (*The manual*) List.iter (fun (key, search) -> Hashtbl.add Toploop.directive_table key (Toploop.Directive_string search)) helpers; (*Directive #help*) Hashtbl.add Toploop.directive_table "help" (Toploop.Directive_none help); (*Directive #browse*) Hashtbl.add Toploop.directive_table "browse" (Toploop.Directive_string print_module) with e -> Printf.printf "Error while initializing help system:\n%s\n%!" (Printexc.to_string e) batteries-included-3.4.0/toplevel/batteriesHelp.mli000066400000000000000000000034001415601150500224100ustar00rootroot00000000000000(* * Batteries_help - Calling the help system from the toplevel * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Tools for reading the documentation from the toplevel All these tools are invoked automatically by the Batteries Toplevel. They are provided here if you wish to integrate them into your own toplevel. @author David Teller *) type kinds = | Values | Types | Topics | Modules | Exns | Modtypes | Classes | Methods | Attributes | Objtypes val init : unit -> unit (** Proceed to initialization. This function loads the primary help files and registers the toplevel directives. If you integrate the on-line help system into your toplevel, you must call this function before any of the other functions of this module. *) val help : unit -> unit (** [help ()] opens the tutorial.*) val man : string -> unit (** [man "something"] opens the help about subject ["something"]. *) batteries-included-3.4.0/toplevel/battop.ml000066400000000000000000000062421415601150500207440ustar00rootroot00000000000000(* * Top - An interpreted preamble for the toplevel * Copyright (C) 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** This file is meant to be invoked by a toplevel and performs initialization of OCaml Batteries Included and its libraries. Initialization consists of - loading Findlib - loading dependencies - loading the contents of the on-line help system - printing a welcome message This file is loaded by the magic line in the ocamlinit file. *) (* END CONFIGURATION *) (* MUST BE ALREADY HANDLED BY .ocamlinit #use "topfind";; *) #thread;; #require "batteries";; if !Sys.interactive then (*Only initialize help and display welcome if we're in interactive mode.*) begin BatteriesHelp.init (); let ver = BatteriesConfig.version in let vlen = String.length ver in let pad = String.make vlen '_' in let pad2 = String.make vlen ' ' in print_endline (" ___________________"^ pad ^"_______"); print_endline (" [| + | | Batteries " ^ ver ^ " - |"); print_endline (" |_____|_|___________"^ pad ^"______|"); print_endline (" ___________________"^ pad ^"_______"); print_endline (" | - Type '#help;;' "^ pad2 ^"| | + |]"); print_endline (" |___________________"^ pad ^"|_|___|"); print_newline (); print_newline (); flush_all () end;; open Batteries;; #install_printer BatteriesPrint.print_uchar;; #install_printer BatteriesPrint.print_ustring;; #install_printer BatteriesPrint.print_rope;; (* #install_printer BatteriesPrint.print_string_cap_rw;; #install_printer BatteriesPrint.print_string_cap_ro;; *) #install_printer BatteriesPrint.string_dynarray;; #install_printer BatteriesPrint.int_dynarray;; #install_printer BatteriesPrint.char_dynarray;; #install_printer BatteriesPrint.float_dynarray;; #install_printer BatteriesPrint.int_set;; #install_printer BatteriesPrint.int32_set;; #install_printer BatteriesPrint.int64_set;; #install_printer BatteriesPrint.natint_set;; #install_printer BatteriesPrint.float_set;; #install_printer BatteriesPrint.string_set;; #install_printer BatteriesPrint.int_pset;; #install_printer BatteriesPrint.string_pset;; #install_printer BatteriesPrint.rope_pset;; #install_printer BatteriesPrint.char_pset;; #install_printer BatteriesPrint.int_enum;; #install_printer BatteriesPrint.string_enum;; #install_printer BatteriesPrint.rope_enum;; #install_printer BatteriesPrint.char_enum;; batteries-included-3.4.0/toplevel/dune000066400000000000000000000003111415601150500177660ustar00rootroot00000000000000(library (name batteries_toplevel) (synopsis "Bytecode toplevel support for Batteries") (libraries num threads str compiler-libs batteries) (modules batteriesHelp) (modes byte) (wrapped false) ) batteries-included-3.4.0/toplevel/ocamlinit000066400000000000000000000026701415601150500210240ustar00rootroot00000000000000(* * Copyright (C) 2011 Batteries Included Team * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (* This script starts loading batteries into the ocaml toplevel. * * To install, copy to your ~/.ocamlinit. If you already have an * ocamlinit file that initializes findlib, just add the last * phrase to your ocamlinit. *) (* Pretend to be in non-interactive mode to hide topfind initialization message *) let interactive = !Sys.interactive;; Sys.interactive := false;; #use "topfind";; Sys.interactive := interactive;; (* run battop.ml in toplevel *) Toploop.use_silently Format.err_formatter (Filename.concat (Findlib.package_directory "batteries") "battop.ml");;