pax_global_header00006660000000000000000000000064142027330520014510gustar00rootroot0000000000000052 comment=f3bd097d69890794789ff8d104ccce80c5476e66 core-0.15.0/000077500000000000000000000000001420273305200125235ustar00rootroot00000000000000core-0.15.0/.gitignore000066400000000000000000000000411420273305200145060ustar00rootroot00000000000000_build *.install *.merlin _opam core-0.15.0/CONTRIBUTING.md000066400000000000000000000044101420273305200147530ustar00rootroot00000000000000This repository contains open source software that is developed and maintained by [Jane Street][js]. Contributions to this project are welcome and should be submitted via GitHub pull requests. Signing contributions --------------------- We require that you sign your contributions. Your signature certifies that you wrote the patch or otherwise have the right to pass it on as an open-source patch. The rules are pretty simple: if you can certify the below (from [developercertificate.org][dco]): ``` Developer Certificate of Origin Version 1.1 Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 1 Letterman Drive Suite D4700 San Francisco, CA, 94129 Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Developer's Certificate of Origin 1.1 By making a contribution to this project, I certify that: (a) The contribution was created in whole or in part by me and I have the right to submit it under the open source license indicated in the file; or (b) The contribution is based upon previous work that, to the best of my knowledge, is covered under an appropriate open source license and I have the right under that license to submit that work with modifications, whether created in whole or in part by me, under the same open source license (unless I am permitted to submit under a different license), as indicated in the file; or (c) The contribution was provided directly to me by some other person who certified (a), (b) or (c) and I have not modified it. (d) I understand and agree that this project and the contribution are public and that a record of the contribution (including all personal information I submit with it, including my sign-off) is maintained indefinitely and may be redistributed consistent with this project or the open source license(s) involved. ``` Then you just add a line to every git commit message: ``` Signed-off-by: Joe Smith ``` Use your real name (sorry, no pseudonyms or anonymous contributions.) If you set your `user.name` and `user.email` git configs, you can sign your commit automatically with git commit -s. [dco]: http://developercertificate.org/ [js]: https://opensource.janestreet.com/ core-0.15.0/LICENSE.md000066400000000000000000000021351420273305200141300ustar00rootroot00000000000000The MIT License Copyright (c) 2008--2022 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. core-0.15.0/Makefile000066400000000000000000000004031420273305200141600ustar00rootroot00000000000000INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) default: dune build install: dune install $(INSTALL_ARGS) uninstall: dune uninstall $(INSTALL_ARGS) reinstall: uninstall install clean: dune clean .PHONY: default install uninstall reinstall clean core-0.15.0/base_for_tests/000077500000000000000000000000001420273305200155255ustar00rootroot00000000000000core-0.15.0/base_for_tests/README.org000066400000000000000000000002771420273305200172010ustar00rootroot00000000000000* Base library for tests Base_for_tests provides helpers for generating tests for libraries using Base, especially for some functors in Base such as =Blit.Make= or =Binary_searchable.Make=. core-0.15.0/base_for_tests/src/000077500000000000000000000000001420273305200163145ustar00rootroot00000000000000core-0.15.0/base_for_tests/src/dune000066400000000000000000000002371420273305200171740ustar00rootroot00000000000000(library (name base_for_tests) (public_name core.base_for_tests) (libraries base) (preprocess (pps ppx_base ppx_inline_test ppx_sexp_conv ppx_sexp_message)))core-0.15.0/base_for_tests/src/test_binary_searchable.ml000066400000000000000000000267751420273305200233630ustar00rootroot00000000000000open! Base open! Binary_searchable include Test_binary_searchable_intf module type S_gen = sig open Binary_searchable type 'a t type 'a elt val binary_search : ('a t, 'a elt, 'a elt) binary_search val binary_search_segmented : ('a t, 'a elt) binary_search_segmented end module type Indexable_gen_and_for_test = sig include S_gen module For_test : sig val compare : bool elt -> bool elt -> int val small : bool elt val big : bool elt val of_array : bool elt array -> bool t end end module Test_gen (M : Indexable_gen_and_for_test) = struct open M let%test_module "test_binary_searchable" = (module struct let compare = For_test.compare let elt_compare = For_test.compare let s = For_test.small let b = For_test.big let binary_search ?pos ?len ~compare t how v = binary_search ?pos ?len ~compare (For_test.of_array t) how v ;; let ( = ) = Poly.equal let%test _ = binary_search ~compare [||] `First_equal_to s = None let%test _ = binary_search ~compare [| s |] `First_equal_to s = Some 0 let%test _ = binary_search ~compare [| s |] `First_equal_to b = None let%test _ = binary_search ~compare [| s; b |] `First_equal_to s = Some 0 let%test _ = binary_search ~compare [| s; b |] `First_equal_to b = Some 1 let%test _ = binary_search ~compare [| b; b |] `First_equal_to s = None let%test _ = binary_search ~compare [| s; s |] `First_equal_to b = None let%test _ = binary_search ~compare [| s; b; b |] `First_equal_to b = Some 1 let%test _ = binary_search ~compare [| s; s; b |] `First_equal_to s = Some 0 let%test _ = binary_search ~compare [| b; b; b |] `First_equal_to s = None let%test _ = binary_search ~compare [||] `Last_equal_to s = None let%test _ = binary_search ~compare [| s |] `Last_equal_to s = Some 0 let%test _ = binary_search ~compare [| s |] `Last_equal_to b = None let%test _ = binary_search ~compare [| s; b |] `Last_equal_to b = Some 1 let%test _ = binary_search ~compare [| s; b |] `Last_equal_to s = Some 0 let%test _ = binary_search ~compare [| b; b |] `Last_equal_to s = None let%test _ = binary_search ~compare [| s; s |] `Last_equal_to b = None let%test _ = binary_search ~compare [| s; b; b |] `Last_equal_to b = Some 2 let%test _ = binary_search ~compare [| s; s; b |] `Last_equal_to s = Some 1 let%test _ = binary_search ~compare [| b; b; b |] `Last_equal_to s = None let%test _ = binary_search ~compare [||] `First_greater_than_or_equal_to s = None let%test _ = binary_search ~compare [| b |] `First_greater_than_or_equal_to s = Some 0 ;; let%test _ = binary_search ~compare [| s |] `First_greater_than_or_equal_to s = Some 0 ;; let%test _ = binary_search ~compare [| s |] `First_strictly_greater_than s = None let%test _ = binary_search ~compare [||] `Last_less_than_or_equal_to s = None let%test _ = binary_search ~compare [| b |] `Last_less_than_or_equal_to s = None let%test _ = binary_search ~compare [| s |] `Last_less_than_or_equal_to s = Some 0 let%test _ = binary_search ~compare [| s |] `Last_strictly_less_than s = None let create_test_case (num_s, num_b) = let arr = Array.create b ~len:(num_s + num_b) in for i = 0 to num_s - 1 do arr.(i) <- s done; arr ;; let only_small = 10_000, 0 let only_big = 0, 10_000 let both = 2531, 4717 let%test _ = match binary_search (create_test_case only_small) ~compare `First_equal_to s with | None -> false | Some _ -> true ;; let%test _ = let arr = create_test_case both in match binary_search arr ~compare `First_equal_to b with | None -> false | Some v -> v = 2531 ;; let%test _ = let arr = create_test_case only_small in binary_search arr ~compare `First_equal_to b = None ;; let create_deterministic_test () = Array.init 100_000 ~f:(fun i -> if i > 50_000 then b else s) ;; let%test _ = let arr = create_deterministic_test () in binary_search arr ~compare `First_equal_to s = Some 0 ;; let%test _ = let arr = create_deterministic_test () in binary_search arr ~compare `Last_equal_to s = Some 50_000 ;; let%test _ = let arr = create_deterministic_test () in binary_search arr ~compare `First_greater_than_or_equal_to s = Some 0 ;; let%test _ = let arr = create_deterministic_test () in binary_search arr ~compare `Last_less_than_or_equal_to s = Some 50_000 ;; let%test _ = let arr = create_deterministic_test () in binary_search arr ~compare `First_strictly_greater_than s = Some 50_001 ;; let%test _ = let arr = create_deterministic_test () in binary_search arr ~compare `Last_strictly_less_than b = Some 50_000 ;; (* tests around a gap*) let%test _ = let arr = create_deterministic_test () in binary_search arr ~compare `First_equal_to b = Some 50_001 ;; let%test _ = let arr = create_deterministic_test () in binary_search arr ~compare `Last_equal_to b = Some 99_999 ;; let%test _ = let arr = create_deterministic_test () in binary_search arr ~compare `First_greater_than_or_equal_to b = Some 50_001 ;; let%test _ = let arr = create_deterministic_test () in binary_search arr ~compare `Last_less_than_or_equal_to b = Some 99_999 ;; let%test _ = let arr = create_deterministic_test () in binary_search arr ~compare `First_strictly_greater_than b = None ;; let%test _ = let arr = create_deterministic_test () in binary_search arr ~compare `Last_strictly_less_than b = Some 50_000 ;; (* test beginning of array *) let%test _ = let arr = create_test_case only_big in binary_search arr ~compare `First_equal_to s = None ;; let%test _ = let arr = create_test_case only_big in binary_search arr ~compare `Last_equal_to s = None ;; let%test _ = let arr = create_test_case only_big in binary_search arr ~compare `First_greater_than_or_equal_to s = Some 0 ;; let%test _ = let arr = create_test_case only_big in binary_search arr ~compare `Last_less_than_or_equal_to s = None ;; let%test _ = let arr = create_test_case only_big in binary_search arr ~compare `First_strictly_greater_than s = Some 0 ;; let%test _ = let arr = create_test_case only_big in binary_search arr ~compare `Last_strictly_less_than b = None ;; (* test end of array *) let%test _ = let arr = create_test_case only_small in binary_search arr ~compare `First_equal_to b = None ;; let%test _ = let arr = create_test_case only_small in binary_search arr ~compare `Last_equal_to b = None ;; let%test _ = let arr = create_test_case only_small in binary_search arr ~compare `First_greater_than_or_equal_to b = None ;; let%test _ = let arr = create_test_case only_small in binary_search arr ~compare `Last_less_than_or_equal_to b = Some 9_999 ;; let%test _ = let arr = create_test_case only_small in binary_search arr ~compare `First_strictly_greater_than s = None ;; let%test _ = let arr = create_test_case only_small in binary_search arr ~compare `Last_strictly_less_than b = Some 9_999 ;; let%test_unit _ = for length = 0 to 5 do for num_s = 0 to length do let arr = Array.init length ~f:(fun i -> if i < num_s then s else b) in for pos = -1 to length do for len = -1 to length + 1 do (*try*) let should_raise = Exn.does_raise (fun () -> Ordered_collection_common.check_pos_len_exn ~pos ~len ~total_length:length) in let result = Result.try_with (fun () -> binary_search arr ~pos ~len ~compare:elt_compare `Last_equal_to s) in match should_raise, result with | true, Error _ -> () | true, Ok _ -> failwith "expected it to raise but it didn't" | false, Error _ -> failwith "expected it to not raise, but it raised" | false, Ok result -> let searched = num_s - 1 in let correct_result = if searched < pos then None else if len = 0 then None else if searched >= pos + len then Some (pos + len - 1) else Some searched in if not (correct_result = result) then failwith "Wrong result" (*with exn -> failwiths "binary_search bug" (exn, `length length, `search_key search_key, `pos pos, `len len) <:sexp_of< exn * [ `length of int ] * [ `search_key of int ] * [ `pos of int ] * [ `len of int ] >>*) done done done done ;; let binary_search_segmented a = binary_search_segmented (For_test.of_array a) (*test for binary_search_segmented*) let%test _ = let arr = create_deterministic_test () in let segment_of x = if x = b then `Right else `Left in binary_search_segmented arr ~segment_of `Last_on_left = Some 50_000 && binary_search_segmented arr ~segment_of `First_on_right = Some 50_001 ;; let%test _ = let arr = create_deterministic_test () in let segment_of _ = `Right in binary_search_segmented arr ~segment_of `Last_on_left = None && binary_search_segmented arr ~segment_of `First_on_right = Some 0 ;; let%test _ = let arr = create_deterministic_test () in let segment_of _ = `Left in binary_search_segmented arr ~segment_of `Last_on_left = Some 99_999 && binary_search_segmented arr ~segment_of `First_on_right = None ;; end) ;; end module Test (M : Binary_searchable_and_for_test) = Test_gen (struct type 'a t = M.t type 'a elt = M.elt let binary_search = M.binary_search let binary_search_segmented = M.binary_search_segmented module For_test = M.For_test end) module Test1 (M : Binary_searchable1_and_for_test) = Test_gen (struct type 'a t = 'a M.t type 'a elt = 'a let binary_search = M.binary_search let binary_search_segmented = M.binary_search_segmented module For_test = struct let of_array = M.For_test.of_array let compare = Bool.compare let small = false let big = true end end) module Make_and_test (M : Indexable_and_for_test) = struct module B = Binary_searchable.Make (M) include B include Test (struct type t = M.t type elt = M.elt include B module For_test = M.For_test end) end module Make1_and_test (M : Indexable1_and_for_test) = struct module B = Binary_searchable.Make1 (M) include B include Test1 (struct type 'a t = 'a M.t include B module For_test = M.For_test end) end core-0.15.0/base_for_tests/src/test_binary_searchable.mli000066400000000000000000000000731420273305200235130ustar00rootroot00000000000000include Test_binary_searchable_intf.Test_binary_searchable core-0.15.0/base_for_tests/src/test_binary_searchable_intf.ml000066400000000000000000000030331420273305200243610ustar00rootroot00000000000000(** Produce unit tests for binary searchable containers *) open! Base open! Binary_searchable module type For_test = sig (** To implement the tests, we need two different [elt] values [small < big], to be able to compare those values, and to be able to construct a [t] containing those values. *) type t type elt val compare : elt -> elt -> int val small : elt val big : elt val of_array : elt array -> t end module type For_test1 = sig type 'a t val of_array : bool array -> bool t end module type Indexable_and_for_test = sig include Indexable module For_test : For_test with type elt := elt with type t := t end module type Indexable1_and_for_test = sig include Indexable1 module For_test : For_test1 with type 'a t := 'a t end module type Binary_searchable_and_for_test = sig include Binary_searchable.S module For_test : For_test with type elt := elt with type t := t end module type Binary_searchable1_and_for_test = sig include Binary_searchable.S1 module For_test : For_test1 with type 'a t := 'a t end module type Test_binary_searchable = sig module type For_test = For_test module type For_test1 = For_test1 module Test (M : Binary_searchable_and_for_test) : sig end module Test1 (M : Binary_searchable1_and_for_test) : sig end (** [Make_and_test] does [Binary_searchable.Make] and [Test]. *) module Make_and_test (T : Indexable_and_for_test) : S with type t := T.t with type elt := T.elt module Make1_and_test (T : Indexable1_and_for_test) : S1 with type 'a t := 'a T.t end core-0.15.0/base_for_tests/src/test_blit.ml000066400000000000000000000206411420273305200206420ustar00rootroot00000000000000open! Base open! Blit include Test_blit_intf module type S_gen = sig open Blit type 'a src type 'a dst (* val blit : ('a src, 'a dst) blit*) val blito : ('a src, 'a dst) blito (* val unsafe_blit : ('a src, 'a dst) blit*) val sub : ('a src, 'a dst) sub (*val subo : ('a src, 'a dst) subo*) end module type For_tests_gen = sig module Elt : sig type 'a t val equal : bool t -> bool t -> bool val of_bool : bool -> bool t end type 'a z module Src : sig type 'a t val length : _ t -> int val create_bool : len:int -> bool z t val get : 'a z t -> int -> 'a Elt.t val set : 'a z t -> int -> 'a Elt.t -> unit end module Dst : sig type 'a t val length : _ t -> int val create_bool : len:int -> bool z t val get : 'a z t -> int -> 'a Elt.t val set : 'a z t -> int -> 'a Elt.t -> unit val overlapping_src_dst : [ `Do_not_check | `Check of 'a Src.t -> 'a t ] end end module Test_gen (For_tests : For_tests_gen) (Tested : S_gen with type 'a src := 'a For_tests.Src.t with type 'a dst := 'a For_tests.Dst.t) = struct open Tested open For_tests let init ~len ~create ~set ~f = let t = create ~len in for i = 0 to len - 1 do set t i (f i) done; t ;; let elt1 = Elt.of_bool true let elt2 = Elt.of_bool false let () = assert (not (Elt.equal elt1 elt2)) let src_bit i = if i land 0x1 = 0 then elt1 else elt2 let dst_bit i = if i land 0x1 = 0 then elt2 else elt1 (* Test [blit]. *) let%test_unit _ = let n = 4 in for src_length = 0 to n do for dst_length = 0 to n do for src_pos = 0 to src_length do for dst_pos = 0 to dst_length do for src_len = 0 to min (src_length - src_pos) (dst_length - dst_pos) do try let is_in_range i = i >= dst_pos && i < dst_pos + src_len in let check length get name sequence ~expect = for i = 0 to length sequence - 1 do if not (Elt.equal (get sequence i) (expect i)) then raise_s [%message "bug" (name : string) (i : int)] done in let check_src = check Src.length Src.get in let check_dst = check Dst.length Dst.get in let src = init ~len:src_length ~create:Src.create_bool ~set:Src.set ~f:src_bit in assert (Src.length src = src_length); let dst = init ~len:dst_length ~create:Dst.create_bool ~set:Dst.set ~f:dst_bit in assert (Dst.length dst = dst_length); let init_src () = for i = 0 to src_length - 1 do Src.set src i (src_bit i) done in blito ~src ~src_pos ~src_len ~dst ~dst_pos (); check_src "blit src" src ~expect:src_bit; check_dst "blit dst" dst ~expect:(fun i -> if is_in_range i then src_bit (src_pos + i - dst_pos) else dst_bit i); (match Dst.overlapping_src_dst with | `Do_not_check -> () | `Check src_to_dst -> if dst_pos + src_len <= src_length then ( init_src (); let dst = src_to_dst src in if false then ( blito ~src ~src_pos ~src_len ~dst ~dst_pos (); check_dst "blit dst overlapping" dst ~expect:(fun i -> src_bit (if is_in_range i then src_pos + i - dst_pos else i))))); (* Check [sub]. *) init_src (); let dst = sub src ~pos:src_pos ~len:src_len in check_src "sub src" src ~expect:src_bit; check_dst "sub dst" dst ~expect:(fun i -> src_bit (src_pos + i)) with | exn -> raise_s [%message "bug" (exn : exn) (src_length : int) (src_pos : int) (dst_length : int) (dst_pos : int)] done done done done done ;; let%test_unit _ = let src = init ~len:4 ~create:Src.create_bool ~set:Src.set ~f:src_bit in let dst = init ~len:8 ~create:Dst.create_bool ~set:Dst.set ~f:dst_bit in let assert_raises f = assert (Exn.does_raise f) in assert_raises (fun () -> blito ~src ~src_pos:(-1) ~src_len:4 ~dst ~dst_pos:0 ()); assert_raises (fun () -> blito ~src ~src_pos:0 ~src_len:4 ~dst ~dst_pos:(-1) ()); assert_raises (fun () -> blito ~src ~src_pos:5 ~src_len:1 ~dst ~dst_pos:0 ()); assert_raises (fun () -> blito ~src ~src_pos:0 ~src_len:8 ~dst ~dst_pos:0 ()); assert_raises (fun () -> blito ~src ~src_pos:0 ~src_len:4 ~dst ~dst_pos:5 ()); assert_raises (fun () -> blito ~src ~src_pos:0 ~src_len:4 ~dst ~dst_pos:8 ()) ;; end module Test1 (Sequence : Sequence1 with type 'a elt := 'a poly) (Tested : S1 with type 'a t := 'a Sequence.t) = Test_gen (struct module Elt = struct type 'a t = 'a let equal = Poly.equal let of_bool = Fn.id end type 'a z = 'a Sequence.z module Src = Sequence module Dst = struct include Sequence let overlapping_src_dst = `Check Fn.id end end) (Tested) module Test1_generic (Elt : Elt1) (Sequence : Sequence1 with type 'a elt := 'a Elt.t) (Tested : S1 with type 'a t := 'a Sequence.t) = Test_gen (struct module Elt = Elt type 'a z = 'a Sequence.z module Src = Sequence module Dst = struct include Sequence let overlapping_src_dst = `Check Fn.id end end) (Tested) module Elt_to_elt1 (Elt : Elt) = struct type 'a t = Elt.t let equal = Elt.equal let of_bool = Elt.of_bool end module Test (Elt : Elt) (Sequence : Sequence with type elt := Elt.t) (Tested : S with type t := Sequence.t) = Test_gen (struct module Elt = Elt_to_elt1 (Elt) type 'a z = unit module Src = struct open Sequence type nonrec 'a t = t let length = length let get = get let set = set let create_bool = create end module Dst = struct include Src let overlapping_src_dst = `Check Fn.id end end) (Tested) module Test_distinct (Elt : Elt) (Src : Sequence with type elt := Elt.t) (Dst : Sequence with type elt := Elt.t) (Tested : S_distinct with type src := Src.t with type dst := Dst.t) = Test_gen (struct module Elt = Elt_to_elt1 (Elt) type 'a z = unit module Src = struct open Src type nonrec 'a t = t let length = length let get = get let set = set let create_bool = create end module Dst = struct open Dst type nonrec 'a t = t let length = length let get = get let set = set let create_bool = create let overlapping_src_dst = `Do_not_check end end) (Tested) module Make_and_test (Elt : Elt) (Sequence : sig include Sequence with type elt := Elt.t val unsafe_blit : (t, t) blit end) = struct module B = Make (Sequence) include Test (Elt) (Sequence) (B) include B end module Make_distinct_and_test (Elt : Elt) (Src : Sequence with type elt := Elt.t) (Dst : sig include Sequence with type elt := Elt.t val unsafe_blit : (Src.t, t) blit end) = struct module B = Make_distinct (Src) (Dst) include Test_distinct (Elt) (Src) (Dst) (B) include B end module Make1_and_test (Sequence : sig include Blit.Sequence1 include Sequence1 with type 'a t := 'a t with type 'a elt := 'a poly end) = struct module B = Make1 (Sequence) include Test1 (Sequence) (B) include B end module Make1_generic_and_test (Elt : Elt1) (Sequence : sig include Blit.Sequence1 include Sequence1 with type 'a t := 'a t with type 'a elt := 'a Elt.t end) = struct module B = Make1_generic (Sequence) include Test1_generic (Elt) (Sequence) (B) include B end core-0.15.0/base_for_tests/src/test_blit.mli000066400000000000000000000000411420273305200210030ustar00rootroot00000000000000include Test_blit_intf.Test_blit core-0.15.0/base_for_tests/src/test_blit_intf.ml000066400000000000000000000057541420273305200216720ustar00rootroot00000000000000(** Produce unit tests for blittable values. *) open! Base open! Blit module type Elt = sig type t val equal : t -> t -> bool (** [of_bool] is used to generate two distinct values of type [t], used in unit tests. It is required that [of_bool false <> of_bool true]. *) val of_bool : bool -> t end module type Elt1 = sig type 'a t val equal : bool t -> bool t -> bool val of_bool : bool -> bool t end module type Sequence = sig type t type elt val create : len:int -> t val length : t -> int val get : t -> int -> elt val set : t -> int -> elt -> unit end type 'a poly = 'a module type Sequence1 = sig type 'a t (** [Make1*] guarantees to only call [create_like ~len t] with [len > 0] if [length t > 0]. *) val length : _ t -> int (** [create_bool], [get], and [set] are just used for unit tests. [z] is needed for [Flat_tuple_array], [elt] is needed for [Option_array]. *) type 'a z type 'a elt val create_bool : len:int -> bool z t val get : 'a z t -> int -> 'a elt val set : 'a z t -> int -> 'a elt -> unit end module type Test_blit = sig module type Elt = Elt module type Elt1 = Elt1 module type Sequence = Sequence module type Sequence1 = Sequence1 module Test (Elt : Elt) (Sequence : Sequence with type elt := Elt.t) (Tested : S with type t := Sequence.t) : sig end module Test_distinct (Elt : Elt) (Src : Sequence with type elt := Elt.t) (Dst : Sequence with type elt := Elt.t) (Tested : S_distinct with type src := Src.t with type dst := Dst.t) : sig end module Test1 (Sequence : Sequence1 with type 'a elt := 'a poly) (Tested : S1 with type 'a t := 'a Sequence.t) : sig end module Test1_generic (Elt : Elt1) (Sequence : Sequence1 with type 'a elt := 'a Elt.t) (Tested : S1 with type 'a t := 'a Sequence.t) : sig end (** [Make_and_test] uses the [Blit.Make] functor and the [Test] functor. *) module Make_and_test (Elt : Elt) (Sequence : sig include Sequence with type elt := Elt.t val unsafe_blit : (t, t) blit end) : S with type t := Sequence.t module Make_distinct_and_test (Elt : Elt) (Src : Sequence with type elt := Elt.t) (Dst : sig include Sequence with type elt := Elt.t val unsafe_blit : (Src.t, t) blit end) : S_distinct with type src := Src.t with type dst := Dst.t module Make1_and_test (Sequence : sig include Blit.Sequence1 include Sequence1 with type 'a t := 'a t with type 'a elt := 'a poly end) : S1 with type 'a t := 'a Sequence.t module Make1_generic_and_test (Elt : Elt1) (Sequence : sig include Blit.Sequence1 include Sequence1 with type 'a t := 'a t with type 'a elt := 'a Elt.t end) : S1 with type 'a t := 'a Sequence.t end core-0.15.0/core.opam000066400000000000000000000034431420273305200143350ustar00rootroot00000000000000opam-version: "2.0" version: "v0.15.0" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/core" bug-reports: "https://github.com/janestreet/core/issues" dev-repo: "git+https://github.com/janestreet/core.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/core/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "4.11.0"} "base" {>= "v0.15" & < "v0.16"} "base_bigstring" {>= "v0.15" & < "v0.16"} "base_quickcheck" {>= "v0.15" & < "v0.16"} "bin_prot" {>= "v0.15" & < "v0.16"} "fieldslib" {>= "v0.15" & < "v0.16"} "jane-street-headers" {>= "v0.15" & < "v0.16"} "jst-config" {>= "v0.15" & < "v0.16"} "ppx_assert" {>= "v0.15" & < "v0.16"} "ppx_base" {>= "v0.15" & < "v0.16"} "ppx_hash" {>= "v0.15" & < "v0.16"} "ppx_inline_test" {>= "v0.15" & < "v0.16"} "ppx_jane" {>= "v0.15" & < "v0.16"} "ppx_sexp_conv" {>= "v0.15" & < "v0.16"} "ppx_sexp_message" {>= "v0.15" & < "v0.16"} "sexplib" {>= "v0.15" & < "v0.16"} "splittable_random" {>= "v0.15" & < "v0.16"} "stdio" {>= "v0.15" & < "v0.16"} "time_now" {>= "v0.15" & < "v0.16"} "typerep" {>= "v0.15" & < "v0.16"} "variantslib" {>= "v0.15" & < "v0.16"} "dune" {>= "2.0.0"} ] synopsis: "Industrial strength alternative to OCaml's standard library" description: " The Core suite of libraries is an industrial strength alternative to OCaml's standard library that was developed by Jane Street, the largest industrial user of OCaml. This is the system-independent part of Core. Unix-specific parts were moved to [core-unix]. " core-0.15.0/core/000077500000000000000000000000001420273305200134535ustar00rootroot00000000000000core-0.15.0/core/COPYRIGHT.txt000066400000000000000000000005121420273305200155620ustar00rootroot00000000000000Copyright (C) 2008- Jane Street Holding, LLC 1 New York Plaza, 33rd Floor New York, NY 10004 USA email: opensource@janestreet.com The contents of some files in this distribution was derived from external sources with compatible licenses. The original copyright and license notice was preserved in the affected files. core-0.15.0/core/INRIA-DISCLAIMER.txt000066400000000000000000000013321420273305200164670ustar00rootroot00000000000000THIS SOFTWARE IS PROVIDED BY INRIA AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL INRIA OR ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. core-0.15.0/core/MLton-license.txt000066400000000000000000000025041420273305200166660ustar00rootroot00000000000000This is the license for MLton, a whole-program optimizing compiler for the Standard ML programming language. Send comments and questions to MLton@mlton.org. MLton COPYRIGHT NOTICE, LICENSE AND DISCLAIMER. Copyright (C) 1999-2009 Henry Cejtin, Matthew Fluet, Suresh Jagannathan, and Stephen Weeks. Copyright (C) 1997-2000 by the NEC Research Institute Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the name of the above copyright holders, or their entities, not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. The above copyright holders disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall the above copyright holders be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. core-0.15.0/core/README.md000066400000000000000000000024451420273305200147370ustar00rootroot00000000000000Portable standard library for OCaml =================================== Core is an industrial-strength alternative to the OCaml standard library. It was developed by Jane Street, which is the largest industrial user of OCaml. Core works with Javascript. It provides an overlay on the usual namespace, so the best way to use it is to start your file with: ```ocaml open! Core ``` ## Relationship to Core and Base In sum: - **Base**: Minimal stdlib replacement. Portable and lightweight and intended to be highly stable. - **Core**: Extension of Base. More fully featured, with more code and dependencies, and APIs that evolve more quickly. Portable, and works on Javascript. Many of Core's modules are extensions of modules in Base, where the Core version adds `bin_io` support or locks in an API with `Stable`. Some modules, like `Core.Map`, extend their Base equivalents to follow Core conventions for the use of comparators. ------ Please report bugs and feature requests on [GitHub](https://github.com/janestreet/core). For everything else you can contact us at . You can find all of Jane Street's open-source libraries on [GitHub](https://github.com/janestreet). Documentation can be found [here](https://ocaml.janestreet.com/ocaml-core/latest/doc/core/index.html). core-0.15.0/core/THIRD-PARTY.txt000066400000000000000000000013031420273305200157600ustar00rootroot00000000000000The repository contains 3rd-party code in the following locations and under the following licenses: - src/union_find.ml and src/union_find.mli: based on an implementation by Henry Matthew Fluet, Suresh Jagannathan, and Stephen Weeks. License can be found in MLton-license.txt - various files in src/ are based on INRIA's OCaml distribution. Relicensed under MIT, as permitted under the Caml License for Consortium members: http://caml.inria.fr/consortium/license.en.html See also the disclaimer INRIA-DISCLAIMER.txt. - strftime.js in src/ is based on https://github.com/samsonjs/strftime License can be found at: http://sjs.mit-license.org See copy strftime.js-license.txt core-0.15.0/core/bench-bin/000077500000000000000000000000001420273305200153005ustar00rootroot00000000000000core-0.15.0/core/bench-bin/array_iter.ml000066400000000000000000000007471420273305200200030ustar00rootroot00000000000000open Core module Bench = Core_bench.Bench let () = let a = Array.init 1000 ~f:Fn.id in let test_array_iter = Bench.Test.create ~name:"array_iter" (fun () -> Array.iter a ~f:(fun i -> if i > 2000 then assert false)) in let test_array_for = Bench.Test.create ~name:"array_for" (fun () -> let length = Array.length a - 1 in for i = 0 to length do if i > 2000 then assert false done) in Bench.bench [ test_array_iter; test_array_for ] ;; core-0.15.0/core/bench-bin/array_queue.ml000066400000000000000000000060121420273305200201530ustar00rootroot00000000000000open Core_bench open Core let enqueue_tests = List.map [ 10; 1_000_000 ] ~f:(fun n -> Bench.Test.create ~name:("enqueue " ^ Int.to_string n) (fun () -> let q = Queue.create () in for i = 1 to n do Queue.enqueue q i done)) ;; (* top unit argument is a cheap guard *) let enqueue_dequeue_mixed () = let test_size = 1_000_000 in let seed = Random.State.make [| 1; 2; 3; 4 |] in let choices = Array.init test_size ~f:(fun (_ : int) -> Random.State.bool seed) in fun () -> let q = Queue.create () in for i = 1 to test_size do Queue.enqueue q i done; Array.iteri choices ~f:(fun i should_dequeue -> if should_dequeue then ignore (Queue.dequeue q : int option) else Queue.enqueue q i) ;; let queue_pipeline () = let q1 = Queue.create () in let q2 = Queue.create () in let q3 = Queue.create () in let q4 = Queue.create () in let q5 = Queue.create () in fun () -> Queue.enqueue q1 1; Queue.blit_transfer ~src:q1 ~dst:q2 (); Queue.blit_transfer ~src:q2 ~dst:q3 (); Queue.blit_transfer ~src:q3 ~dst:q4 (); Queue.blit_transfer ~src:q4 ~dst:q5 (); ignore (Queue.dequeue_exn q5 : int) ;; let blit_transfer_tests = List.bind [ 0; 1; 2; 4; 8; 16; 32; 64; 128 ] ~f:(fun len -> let half_len = len / 2 in let src = Queue.create () in let dst = Queue.create () in for _ = 1 to len do Queue.enqueue src 0 done; for _ = 1 to half_len do ignore (Queue.dequeue_exn src : int) done; for _ = 1 to half_len do Queue.enqueue src 0 done; [ Bench.Test.create ~name:(String.concat [ "blit_transfer "; Int.to_string len ]) (fun () -> Queue.blit_transfer ~src ~dst (); Queue.blit_transfer ~src:dst ~dst:src ()) ]) ;; let tests = [ Bench.Test.create ~name:"enqueue_dequeue_mixed" (enqueue_dequeue_mixed ()) ; Bench.Test.create ~name:"pipeline" (queue_pipeline ()) ] @ blit_transfer_tests @ enqueue_tests @ let args = List.init 10 ~f:(fun i -> Float.iround_nearest_exn (2. ** Float.of_int i)) in [ Bench.Test.create_indexed ~name:"Queue.enqueue + dequeue" ~args (fun num_elts -> let t = Queue.create () in for _ = 1 to num_elts do Queue.enqueue t () done; stage (fun () -> Queue.enqueue t (); Queue.dequeue_exn t)) ; Bench.Test.create_indexed ~name:"Linked_queue.enqueue + dequeue" ~args (fun num_elts -> let t = Linked_queue.create () in for _ = 1 to num_elts do Linked_queue.enqueue t () done; stage (fun () -> Linked_queue.enqueue t (); Linked_queue.dequeue_exn t)) ; Bench.Test.create_indexed ~name:"Deque.enqueue + dequeue" ~args (fun num_elts -> let t = Deque.create () in for _ = 1 to num_elts do Deque.enqueue_front t () done; stage (fun () -> Deque.enqueue_front t (); Deque.dequeue_front_exn t)) ] ;; let () = Command_unix.run (Bench.make_command tests) core-0.15.0/core/bench-bin/bench_hashtbl.ml000066400000000000000000000040451420273305200204210ustar00rootroot00000000000000open Core module Bench = Core_bench.Bench module Test = Bench.Test module My_hashtbl = struct type ('k, 'v) t = { hash : 'k -> int ; array : 'v option Array.t } let create ~size ~hash = let hash k = hash k mod size in { hash; array = Array.create ~len:size None } ;; let replace t ~key ~data = t.array.(t.hash key) <- Some data let find t key = t.array.(t.hash key) end module My_hashable = struct module Make (M : Hashtbl.Key) = struct module Table = struct include My_hashtbl let create ?(size = 0) () = create ~size ~hash:M.hash end end end module Hashtbl_ = My_hashtbl module Hashable_ = My_hashable let gen_test_int_replace_and_find n tbl = let replace () = for i = 0 to n - 1 do Hashtbl.set tbl ~key:i ~data:i done in let find () = for i = 0 to n - 1 do let (_ : int option) = Hashtbl.find tbl i in () done in replace, find ;; let () = let n = 1_000_000 in let int_tbl_replace1, int_tbl_find1 = let module I = Hashable.Make (struct include Int let hash x = Caml.Hashtbl.hash x end) in gen_test_int_replace_and_find n (I.Table.create ~size:(2 * n) ()) in let int_tbl_replace2, int_tbl_find2 = let module I = Hashable.Make (struct include Int let hash x = Core.Hashtbl_intf.Hashable.hash x end) in gen_test_int_replace_and_find n (I.Table.create ~size:(2 * n) ()) in let caml_hashtbl_hash () = for i = 0 to n - 1 do let (_ : int) = Caml.Hashtbl.hash i in () done in let jst_hashtbl_hash () = for i = 0 to n - 1 do let (_ : int) = Core.Hashtbl_intf.Hashable.hash i in () done in Bench.bench [ Test.create ~name:"Int-replace1" int_tbl_replace1 ; Test.create ~name:"Int-replace2" int_tbl_replace2 ; Test.create ~name:"Int-find1" int_tbl_find1 ; Test.create ~name:"Int-find2" int_tbl_find2 ; Test.create ~name:"Caml-hashtbl-hash" caml_hashtbl_hash ; Test.create ~name:"Jst-hashtbl-hash" jst_hashtbl_hash ] ;; core-0.15.0/core/bench-bin/bench_map.ml000066400000000000000000000106351420273305200175530ustar00rootroot00000000000000open Core module Bench = Core_bench.Bench module Test = Bench.Test let size = 10_000 let alist = List.init size ~f:(fun i -> i, i) let of_alist_exn () = ignore (Int.Map.of_alist_exn alist : int Int.Map.t) let of_sorted_array () = let sorted_array = Array.init size ~f:(fun i -> i, i) in ignore (Int.Map.of_sorted_array sorted_array : _ Int.Map.t Or_error.t) ;; let map = Int.Map.of_alist_exn alist let iter () = Map.iteri map ~f:(fun ~key:_ ~data:_ -> ()) let iter2 () = Map.iter2 map map ~f:(fun ~key:_ ~data:_ -> ()) let iter2_naive () = let iter2 a b ~f = Map.iteri a ~f:(fun ~key ~data:_ -> match Map.find b key with | None -> f `Left | Some _ -> f `Both) in iter2 map map ~f:ignore ;; let add_with_set = assert (not (Int.Map.mem map size)); fun () -> ignore (Map.set map ~key:size ~data:size : _ Map.t) ;; let add_with_add = assert (not (Int.Map.mem map size)); fun () -> ignore (Map.add map ~key:size ~data:size : _ Base.Map.Or_duplicate.t) ;; let add_duplicate = let map = Map.set map ~key:size ~data:size in assert (Int.Map.mem map size); fun () -> ignore (Map.add map ~key:size ~data:size : _ Base.Map.Or_duplicate.t) ;; let remove = let deep_key = fst (Map.min_elt_exn map) in fun () -> ignore (Map.remove map deep_key : _ Map.t) ;; let old_map_merge t1 t2 ~f = let all_keys = List.dedup_and_sort ~compare (List.append (Map.keys t1) (Map.keys t2)) in List.fold ~init:Map.Poly.empty all_keys ~f:(fun t key -> let z = match Map.find t1 key, Map.find t2 key with | None, None -> assert false | None, Some v2 -> `Right v2 | Some v1, None -> `Left v1 | Some v1, Some v2 -> `Both (v1, v2) in match f ~key z with | None -> t | Some data -> Map.set t ~key ~data) ;; let merge_test do_merge = let map2 = Int.Map.of_alist_exn (List.init size ~f:(fun i -> 2 * i, 2 * i)) in fun () -> ignore (do_merge map map2 ~f:(fun ~key:_ x -> match x with | `Left a -> Some a | `Right a -> Some a | `Both (a, b) -> Some (a + b)) : _ Map.t) ;; let gen_diff_test m ~number_of_diff ~diff = let gen_pair i = sprintf "%6d" i, sprintf "%6d" (i + 1) in let map1 = String.Map.of_alist_exn (List.init m ~f:gen_pair) in let map2 = let gen_pair i = gen_pair (i * 16856431 mod m) in List.fold (List.init number_of_diff ~f:gen_pair) ~init:map1 ~f:(fun acc (key, data) -> Map.set acc ~key ~data) in fun () -> let (_ : _ list) = diff map1 map2 ~data_equal:String.equal in () ;; let diff_by_iter2 map1 map2 ~data_equal = let results = ref [] in Map.iter2 map1 map2 ~f:(fun ~key ~data -> match data with | `Left _ -> results := (key, None) :: !results | `Right v -> results := (key, Some v) :: !results | `Both (v1, v2) -> if not (data_equal v1 v2) then results := (key, Some v2) :: !results); !results ;; let command = let symmetric_diff t1 t2 ~data_equal = Map.symmetric_diff t1 t2 ~data_equal |> Sequence.to_list in Bench.make_command [ Test.create ~name:"Map.of_alist_exn" of_alist_exn ; Test.create ~name:"Map.of_sorted_array" of_sorted_array ; Test.create ~name:"Map.add reporting duplicate" add_duplicate ; Test.create ~name:"Map.set adding a new element" add_with_set ; Test.create ~name:"Map.add" add_with_add ; Test.create ~name:"Map.iteri" iter ; Test.create ~name:"Map.iter2" iter2 ; Test.create ~name:"Map.iter2_naive" iter2 ; Test.create ~name:"Map.remove" remove ; Test.create ~name:"Map.merge (new)" (merge_test Map.merge) ; Test.create ~name:"Map.merge (old)" (merge_test old_map_merge) ; Test.create ~name:"Map.symmetric_diff-10" (gen_diff_test 100_000 ~number_of_diff:10 ~diff:symmetric_diff) ; Test.create ~name:"Map.symmetric_diff-100" (gen_diff_test 100_000 ~number_of_diff:100 ~diff:symmetric_diff) ; Test.create ~name:"Map.symmetric_diff-1000" (gen_diff_test 100_000 ~number_of_diff:1000 ~diff:symmetric_diff) ; Test.create ~name:"Map.symmetric_diff_by_iter2-10" (gen_diff_test 100_000 ~number_of_diff:10 ~diff:diff_by_iter2) ; Test.create ~name:"Map.symmetric_diff_by_iter2-100" (gen_diff_test 100_000 ~number_of_diff:100 ~diff:diff_by_iter2) ; Test.create ~name:"Map.symmetric_diff_by_iter2-1000" (gen_diff_test 100_000 ~number_of_diff:1000 ~diff:diff_by_iter2) ] ;; let () = Command_unix.run command core-0.15.0/core/bench-bin/core_stack.ml000066400000000000000000000010071420273305200177450ustar00rootroot00000000000000open! Core module Stack = Core.Stack module Bench = Core_bench.Bench let () = Bench.bench [ Bench.Test.create ~name:"Stack.fold" (let s = Stack.of_list (List.init 100 ~f:Fn.id) in fun () -> ignore (Stack.fold s ~init:0 ~f:( + ) : int)) ; Bench.Test.create ~name:"stack_push_pop" (let s = Stack.create () in Stack.push s (); fun () -> for _ = 1 to 10 do Stack.push s (); Stack.pop_exn s done) ] ;; core-0.15.0/core/bench-bin/core_string_search_pattern.ml000066400000000000000000000050671420273305200232420ustar00rootroot00000000000000open Core open Core_bench let rec make_needle k = if k < 0 then "" else ( let b = make_needle (k - 1) in String.concat ~sep:(String.of_char (Char.of_int_exn (65 + k))) [ b; b ]) ;; let make_haystack k j = let c = make_needle (k - 1) in String.concat ~sep:"$" (List.init j ~f:(fun _ -> c) @ [ make_needle k ]) ;; let compile_kmp p () = ignore (String.Search_pattern.create p : String.Search_pattern.t) let compile_re2 p () = ignore (Re2.create_exn p : Re2.t) let compile_pcre p () = ignore (Pcre.regexp ~study:true p : Pcre.regexp) let _ = compile_pcre let search_kmp haystack needle = let expected = Some (String.length haystack - String.length needle) in let needle = String.Search_pattern.create needle in stage (fun () -> assert ( [%equal: int option] (String.Search_pattern.index needle ~in_:haystack) expected)) ;; let search_re2 haystack needle = let needle = Re2.create_exn needle in stage (fun () -> assert (Re2.matches needle haystack)) ;; let search_pcre haystack needle = let needle = Pcre.regexp ~study:true needle in stage (fun () -> assert (Pcre.pmatch ~rex:needle haystack)) ;; let () = Command_unix.run (Bench.make_command (List.concat (List.map [ 3; 9; 12; 16 ] ~f:(fun k -> let needle = make_needle k in let needle_length = Int.to_string (String.length needle) in [ Bench.Test.create ~name:("kmp_create__" ^ needle_length) (compile_kmp needle) ; Bench.Test.create ~name:("re2_compile_" ^ needle_length) (compile_re2 needle) (* ; Bench.Test.create ~name:("pcre_compile_" ^ needle_length) (compile_pcre x) *) ])) @ List.concat (List.map [ 3; 9 (* 12 *) ] ~f:(fun k -> let needle = make_needle k in let needle_length = Int.to_string (String.length needle) in List.concat (List.map [ 10; 100 (*300 *) ] ~f:(fun j -> let haystack = make_haystack k j in let haystack_length = Int.to_string (String.length haystack) in List.map [ search_kmp, "kmp_search_______" ; search_re2, "re2_search_______" ; search_pcre, "pcre_search_" ] ~f:(fun (f, n) -> Bench.Test.create ~name:(n ^ needle_length ^ "_" ^ haystack_length) (unstage (f haystack needle))))))))) ;; core-0.15.0/core/bench-bin/core_string_search_pattern.mli000066400000000000000000000000551420273305200234030ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/bench-bin/dequeue.ml000066400000000000000000000004621420273305200172710ustar00rootroot00000000000000open! Core module Bench = Core_bench.Bench let () = let d = Deque.create () in Deque.enqueue_front d (); Bench.bench [ Bench.Test.create ~name:"dequeue_push_pop" (fun () -> for _ = 1 to 10 do Deque.enqueue_front d (); Deque.dequeue_front_exn d done) ] ;; core-0.15.0/core/bench-bin/dune000066400000000000000000000006041420273305200161560ustar00rootroot00000000000000(executables (names array_iter array_queue bench_hashtbl bench_map core_stack core_string_search_pattern dequeue hashtbl_bench immediate_bench ordering_container string_escaping time_to_string) (libraries core_unix.command_unix core core_bench core_kernel.pairing_heap core_kernel.pooled_hashtbl ppx_hash.runtime-lib pcre re2 shell.string_extended) (preprocess (pps ppx_jane)))core-0.15.0/core/bench-bin/hashtbl_bench.ml000066400000000000000000001054141420273305200204230ustar00rootroot00000000000000(* This program benchmarks all functions exported by [Hashtbl.Make (...)]. For functions that look up / add / remove a single key, we attempt to construct a benchmark that uses one hash table, and touches a random key each time. For operations that behave differently when the key is present vs absent, we try to maintain a 50/50 chance on average that the operation hits a key each time. For operations that do not modify the key set, we just pick keys out of twice the hash table's initial set. For operations that add or remove keys, we arrange to have a ~50% chance to add or remove on each try. For monotonic operations, we either pair them with another operation, or we construct a fresh hash table and benchmark repeated application of the operation. It's worth noting that the functorization in these tests (which is an artifact of trying to test the same things with different implementations, load, etc.) does not influence the output of the tests too much. Here is comparison of the int table constructed in these tests vs direct use of [Int.Table]: ┌──────────────────────────────────────────────────────────────────┬──────────┠│ Name │ Time/Run │ ├──────────────────────────────────────────────────────────────────┼──────────┤ │ Hashtbl.Make(Int): find_exn + :1 │ 36.30ns │ │ Hashtbl.Make(Int): find_exn + :100 │ 36.76ns │ │ Hashtbl.Make(Int): find_exn + :10000 │ 41.14ns │ │ Hashtbl.Make(Int): find_exn + [using Int.Table]:1 │ 34.05ns │ │ Hashtbl.Make(Int): find_exn + [using Int.Table]:100 │ 35.02ns │ │ Hashtbl.Make(Int): find_exn + [using Int.Table]:10000 │ 36.43ns │ └──────────────────────────────────────────────────────────────────┴──────────┘ Similarly testing with hastable data that are immediate vs non-immediate had no appreciable effect on the test results. *) open Core open Core_bench module type Config = sig val sizes : int list val regex : Re2.t option end module type Impl = sig include Hashtbl_intf.Hashtbl val module_name : string end module type Key = sig include Hashtbl.Key val module_name : string val of_int_exn : int -> t end module Benchmarks (Config : Config) (Impl : Impl) (Key : Key) : sig val benchmarks : Bench.Test.t list end = struct module Table = Impl.Make (Key) module Example = struct let data size = List.init size ~f:Fn.id let keys size = List.init size ~f:Key.of_int_exn let key_array size = keys size |> Array.of_list let alist size = List.zip_exn (keys size) (data size) let t size = Table.of_alist_exn (alist size) let t_multi size = Table.of_alist_multi (alist size) let sexp size = Table.sexp_of_t sexp_of_int (t size) type random = { state : Random.State.t ; size : int ; keys : Key.t array } let random size = let state = Random.State.make [||] in let keys = key_array (size * 2) in { state; size; keys } ;; let random_index { state; size; _ } mode = match mode with | `present -> Random.State.int state size | `absent -> Random.State.int state size + size | `either -> Random.State.int state (size * 2) ;; let random_data r mode = random_index r mode let random_key r mode = random_index r mode |> Array.get r.keys end module For_bench = struct let queue = Queue.create () let all () = Queue.to_list queue let name str = sprintf "%s.Make(%s): %s" Impl.module_name Key.module_name str (* we require functions to return [unit] so benchmarks aren't accidentally only partially applying some function *) let enqueue str (f : int -> (unit -> unit) Staged.t) = let name = name str in let args = Config.sizes in match Config.regex with | Some regex when not (Re2.matches regex name) -> () | _ -> Queue.enqueue queue (Bench.Test.create_indexed ~name ~args f) ;; end let ( !! ) = For_bench.enqueue (* helpful for users to subtract these times from other benchmarks that use them *) let () = ( !! ) "" (fun size -> let r = Example.random size in stage (fun () -> ignore (Example.random_key r `either : Key.t))) ;; let () = ( !! ) "" (fun size -> let r = Example.random size in stage (fun () -> ignore (Example.random_data r `either : int))) ;; module _ : Hashtbl_intf.S = struct type key = Table.key type ('k, 'v) hashtbl = ('k, 'v) Table.hashtbl type 'v t = 'v Table.t type ('k, 'v) t_ = ('k, 'v) Table.t_ type 'k key_ = 'k Table.key_ module Provide_of_sexp = Table.Provide_of_sexp module Provide_bin_io = Table.Provide_bin_io (* benchmarks begin here *) let sexp_of_t = Table.sexp_of_t let () = ( !! ) "sexp_of_t" (fun size -> let t = Example.t size in stage (fun () -> ignore (sexp_of_t sexp_of_int t : Sexp.t))) ;; let t_of_sexp = Table.t_of_sexp let () = ( !! ) "t_of_sexp" (fun size -> let sexp = Example.sexp size in stage (fun () -> ignore (t_of_sexp int_of_sexp sexp : int t))) ;; let invariant = Table.invariant let () = ( !! ) "invariant" (fun size -> let t = Example.t size in stage (fun () -> invariant ignore t)) ;; let create = Table.create let () = ( !! ) "create" (fun size -> let size = Some size in stage (fun () -> ignore (create ?size () : int t))) ;; let of_alist = Table.of_alist let () = ( !! ) "of_alist [no dups]" (fun size -> let alist = Example.alist size in stage (fun () -> ignore (of_alist alist : [ `Ok of int t | `Duplicate_key of key ]))) ;; let of_alist_exn = Table.of_alist_exn let () = ( !! ) "of_alist_exn [no dups]" (fun size -> let alist = Example.alist size in stage (fun () -> ignore (of_alist_exn alist : int t))) ;; let of_alist_or_error = Table.of_alist_or_error let () = ( !! ) "of_alist_or_error [no dups]" (fun size -> let alist = Example.alist size in stage (fun () -> ignore (of_alist_or_error alist : int t Or_error.t))) ;; let of_alist_report_all_dups = Table.of_alist_report_all_dups let () = ( !! ) "of_alist_report_all_dups [no dups]" (fun size -> let alist = Example.alist size in stage (fun () -> ignore (of_alist_report_all_dups alist : [ `Ok of int t | `Duplicate_keys of key list ]))) ;; let of_alist_multi = Table.of_alist_multi let () = ( !! ) "of_alist_multi [no dups]" (fun size -> let alist = Example.alist size in stage (fun () -> ignore (of_alist_multi alist : int list t))) ;; let create_mapped = Table.create_mapped let () = ( !! ) "create_mapped [no dups]" (fun size -> let alist = Example.alist size in stage (fun () -> ignore (create_mapped alist ~get_key:fst ~get_data:snd : [ `Ok of int t | `Duplicate_keys of key list ]))) ;; let create_with_key = Table.create_with_key let () = ( !! ) "create_with_key [no dups]" (fun size -> let data = Example.data size in let key_array = Example.key_array size in stage (fun () -> ignore (create_with_key data ~get_key:(Array.get key_array) : [ `Ok of int t | `Duplicate_keys of key list ]))) ;; let create_with_key_exn = Table.create_with_key_exn let () = ( !! ) "create_with_key_exn [no dups]" (fun size -> let data = Example.data size in let key_array = Example.key_array size in stage (fun () -> ignore (create_with_key_exn data ~get_key:(Array.get key_array) : int t))) ;; let create_with_key_or_error = Table.create_with_key_or_error let () = ( !! ) "create_with_key_or_error [no dups]" (fun size -> let data = Example.data size in let key_array = Example.key_array size in stage (fun () -> ignore (create_with_key_or_error data ~get_key:(Array.get key_array) : int t Or_error.t))) ;; let group = Table.group let () = ( !! ) "group [no dups]" (fun size -> let alist = Example.alist size in stage (fun () -> ignore (group alist ~get_key:fst ~get_data:snd ~combine:( + ) : int t))) ;; let sexp_of_key = Table.sexp_of_key let () = ( !! ) "sexp_of_key + " (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> ignore (sexp_of_key t (Example.random_key r `present) : Sexp.t))) ;; let choose = Table.choose let choose_exn = Table.choose_exn let copy = Table.copy let () = ( !! ) "copy" (fun size -> let t = Example.t size in stage (fun () -> ignore (copy t : int t))) ;; let clear = Table.clear let () = ( !! ) "clear + copy" (fun size -> let t = Example.t size in stage (fun () -> clear (copy t))) ;; let fold = Table.fold let () = ( !! ) "fold" (fun size -> let f ~key:_ ~data:_ _ = () in let t = Example.t size in stage (fun () -> fold t ~init:() ~f)) ;; let iter = Table.iter let () = ( !! ) "iter" (fun size -> let t = Example.t size in stage (fun () -> iter t ~f:ignore)) ;; let iter_keys = Table.iter_keys let () = ( !! ) "iter_keys" (fun size -> let t = Example.t size in stage (fun () -> iter_keys t ~f:ignore)) ;; let iteri = Table.iteri let () = ( !! ) "iteri" (fun size -> let f ~key:_ ~data:_ = () in let t = Example.t size in stage (fun () -> iteri t ~f)) ;; let exists = Table.exists let () = ( !! ) "exists [true]" (fun size -> let f _ = true in let t = Example.t size in stage (fun () -> ignore (exists t ~f : bool))) ;; let () = ( !! ) "exists [false]" (fun size -> let f _ = false in let t = Example.t size in stage (fun () -> ignore (exists t ~f : bool))) ;; let () = ( !! ) "exists + " (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> let v = Example.random_data r `present in ignore (exists t ~f:(fun data -> data = v) : bool))) ;; let existsi = Table.existsi let () = ( !! ) "existsi [true]" (fun size -> let f ~key:_ ~data:_ = true in let t = Example.t size in stage (fun () -> ignore (existsi t ~f : bool))) ;; let () = ( !! ) "existsi [false]" (fun size -> let f ~key:_ ~data:_ = false in let t = Example.t size in stage (fun () -> ignore (existsi t ~f : bool))) ;; let () = ( !! ) "existsi + " (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> let k = Example.random_key r `present in ignore (existsi t ~f:(fun ~key ~data:_ -> Key.compare key k = 0) : bool))) ;; let for_all = Table.for_all let () = ( !! ) "for_all [true]" (fun size -> let f _ = true in let t = Example.t size in stage (fun () -> ignore (for_all t ~f : bool))) ;; let () = ( !! ) "for_all [false]" (fun size -> let f _ = false in let t = Example.t size in stage (fun () -> ignore (for_all t ~f : bool))) ;; let () = ( !! ) "for_all + " (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> let v = Example.random_data r `present in ignore (for_all t ~f:(fun data -> data <> v) : bool))) ;; let for_alli = Table.for_alli let () = ( !! ) "for_alli [true]" (fun size -> let f ~key:_ ~data:_ = true in let t = Example.t size in stage (fun () -> ignore (for_alli t ~f : bool))) ;; let () = ( !! ) "for_alli [false]" (fun size -> let f ~key:_ ~data:_ = false in let t = Example.t size in stage (fun () -> ignore (for_alli t ~f : bool))) ;; let () = ( !! ) "for_alli + " (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> let k = Example.random_key r `present in ignore (for_alli t ~f:(fun ~key ~data:_ -> Key.compare key k <> 0) : bool))) ;; let count = Table.count let () = ( !! ) "count [true]" (fun size -> let f _ = true in let t = Example.t size in stage (fun () -> ignore (count t ~f : int))) ;; let () = ( !! ) "count [false]" (fun size -> let f _ = false in let t = Example.t size in stage (fun () -> ignore (count t ~f : int))) ;; let counti = Table.counti let () = ( !! ) "counti [true]" (fun size -> let f ~key:_ ~data:_ = true in let t = Example.t size in stage (fun () -> ignore (counti t ~f : int))) ;; let () = ( !! ) "counti [false]" (fun size -> let f ~key:_ ~data:_ = false in let t = Example.t size in stage (fun () -> ignore (counti t ~f : int))) ;; let is_empty = Table.is_empty let () = ( !! ) "is_empty" (fun size -> let t = Example.t size in stage (fun () -> ignore (is_empty t : bool))) ;; let length = Table.length let () = ( !! ) "length" (fun size -> let t = Example.t size in stage (fun () -> ignore (length t : int))) ;; let keys = Table.keys let () = ( !! ) "keys" (fun size -> let t = Example.t size in stage (fun () -> ignore (keys t : Key.t list))) ;; let data = Table.data let () = ( !! ) "data" (fun size -> let t = Example.t size in stage (fun () -> ignore (data t : int list))) ;; let mem = Table.mem let () = ( !! ) "mem + [true]" (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> ignore (Table.mem t (Example.random_key r `present) : bool))) ;; let () = ( !! ) "mem + [false]" (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> ignore (Table.mem t (Example.random_key r `absent) : bool))) ;; let remove = Table.remove let () = ( !! ) "copy + remove [all]" (fun size -> let t = Example.t size in let keys = keys t in stage (fun () -> let t = copy t in List.iter keys ~f:(fun key -> remove t key))) ;; let add_exn = Table.add_exn let () = let ( !!! ) ~capacity ~resize = let name = sprintf "create [%s capacity, %s resize] + add_exn [N+1]" (if capacity then "w/" else "no") (if resize then "w/" else "no") in ( !! ) name (fun size -> let alist = Example.alist (size + 1) in let growth_allowed = if resize then None else Some true in let size = if capacity then None else Some size in stage (fun () -> let t = create ?size ?growth_allowed () in List.iter alist ~f:(fun (key, data) -> add_exn t ~key ~data))) in ( !!! ) ~capacity:true ~resize:true; ( !!! ) ~capacity:true ~resize:false; ( !!! ) ~capacity:false ~resize:true; ( !!! ) ~capacity:false ~resize:false ;; let () = ( !! ) "add_exn or remove + mem + " (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> let key = Example.random_key r `either in if mem t key then remove t key else add_exn t ~key ~data:0)) ;; let set = Table.set let () = ( !! ) "set or remove + mem + " (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> let key = Example.random_key r `either in if mem t key then remove t key else set t ~key ~data:0)) ;; let () = ( !! ) "set + + remove + " (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> set t ~key:(Example.random_key r `either) ~data:0; remove t (Example.random_key r `either))) ;; let add = Table.add let () = ( !! ) "add or remove + mem + " (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> let key = Example.random_key r `either in if mem t key then remove t key else ignore (add t ~key ~data:0 : [ `Ok | `Duplicate ]))) ;; let () = ( !! ) "add + + remove + " (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> ignore (add t ~key:(Example.random_key r `either) ~data:0 : [ `Ok | `Duplicate ]); remove t (Example.random_key r `either))) ;; let add_multi = Table.add_multi let remove_multi = Table.remove_multi let () = ( !! ) "add_multi + + remove_multi + " (fun size -> let r = Example.random size in let t = Example.t_multi size in stage (fun () -> add_multi t ~key:(Example.random_key r `either) ~data:0; remove_multi t (Example.random_key r `either))) ;; let change = Table.change let () = ( !! ) "change + + " (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> let key = Example.random_key r `either in let data = Example.random_data r `either in change t key ~f:(fun _ -> if data < size then Some data else None))) ;; let update = Table.update let update_and_return = Table.update_and_return (* [update] is in terms of [update_and_return] so there's no need for a separate benchmark *) let () = ( !! ) "update + + remove + " (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> update t (Example.random_key r `either) ~f:(function | None -> 0 | Some n -> n + 1); remove t (Example.random_key r `either))) ;; let map = Table.map let () = ( !! ) "map" (fun size -> let f data = data + 1 in let t = Example.t size in stage (fun () -> ignore (map t ~f : int t))) ;; let mapi = Table.mapi let () = ( !! ) "mapi" (fun size -> let f ~key:_ ~data = data + 1 in let t = Example.t size in stage (fun () -> ignore (mapi t ~f : int t))) ;; let filter = Table.filter let () = ( !! ) "filter [halve]" (fun size -> let f data = data % 2 = 0 in let t = Example.t size in stage (fun () -> ignore (filter t ~f : int t))) ;; let filteri = Table.filteri let () = ( !! ) "filteri [halve]" (fun size -> let f ~key:_ ~data = data % 2 = 0 in let t = Example.t size in stage (fun () -> ignore (filteri t ~f : int t))) ;; let filter_keys = Table.filter_keys let () = ( !! ) "filter_keys [halve]" (fun size -> let r = Example.random size in let f _ = Random.State.bool r.state in let t = Example.t size in stage (fun () -> ignore (filter_keys t ~f : int t))) ;; let filter_map = Table.filter_map let () = ( !! ) "filter_map [halve]" (fun size -> let f data = if data % 2 = 0 then Some (data + 1) else None in let t = Example.t size in stage (fun () -> ignore (filter_map t ~f : int t))) ;; let filter_mapi = Table.filter_mapi let () = ( !! ) "filter_mapi [halve]" (fun size -> let f ~key:_ ~data = if data % 2 = 0 then Some (data + 1) else None in let t = Example.t size in stage (fun () -> ignore (filter_mapi t ~f : int t))) ;; let partition_tf = Table.partition_tf let () = ( !! ) "partition_tf [halve]" (fun size -> let f data = data % 2 = 0 in let t = Example.t size in stage (fun () -> ignore (partition_tf t ~f : int t * int t))) ;; let partitioni_tf = Table.partitioni_tf let () = ( !! ) "partitioni_tf [halve]" (fun size -> let f ~key:_ ~data = data % 2 = 0 in let t = Example.t size in stage (fun () -> ignore (partitioni_tf t ~f : int t * int t))) ;; let partition_map = Table.partition_map let () = ( !! ) "partition_map [halve]" (fun size -> let f data = if data % 2 = 0 then First (data + 1) else Second (data - 1) in let t = Example.t size in stage (fun () -> ignore (partition_map t ~f : int t * int t))) ;; let partition_mapi = Table.partition_mapi let () = ( !! ) "partition_mapi [halve]" (fun size -> let f ~key:_ ~data = if data % 2 = 0 then First (data + 1) else Second (data - 1) in let t = Example.t size in stage (fun () -> ignore (partition_mapi t ~f : int t * int t))) ;; let find_or_add = Table.find_or_add let find_and_remove = Table.find_and_remove let () = ( !! ) "find_or_add + + find_and_remove + " (fun size -> let default () = 0 in let r = Example.random size in let t = Example.t size in stage (fun () -> ignore (find_or_add t (Example.random_key r `either) ~default : int); ignore (find_and_remove t (Example.random_key r `either) : int option))) ;; let findi_or_add = Table.findi_or_add let () = ( !! ) "findi_or_add + + find_and_remove + " (fun size -> let default _key = 0 in let r = Example.random size in let t = Example.t size in stage (fun () -> ignore (findi_or_add t (Example.random_key r `either) ~default : int); ignore (find_and_remove t (Example.random_key r `either) : int option))) ;; let find_exn = Table.find_exn let () = ( !! ) "find_exn + " (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> ignore (find_exn t (Example.random_key r `present) : int))) ;; let find = Table.find let () = ( !! ) "find + " (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> ignore (find t (Example.random_key r `either) : int option))) ;; let find_multi = Table.find_multi let () = ( !! ) "find_multi + " (fun size -> let r = Example.random size in let t = Example.t_multi size in stage (fun () -> ignore (find_multi t (Example.random_key r `either) : int list))) ;; let find_and_call = Table.find_and_call let () = ( !! ) "find_and_call + " (fun size -> let if_not_found _ = 0 in let if_found data = data in let r = Example.random size in let t = Example.t size in stage (fun () -> let key = Example.random_key r `either in ignore (find_and_call t key ~if_found ~if_not_found : int))) ;; let findi_and_call = Table.findi_and_call let () = ( !! ) "findi_and_call + " (fun size -> let if_not_found _ = 0 in let if_found ~key:_ ~data = data in let r = Example.random size in let t = Example.t size in stage (fun () -> let key = Example.random_key r `either in ignore (findi_and_call t key ~if_found ~if_not_found : int))) ;; let find_and_call1 = Table.find_and_call1 let () = ( !! ) "find_and_call1 + " (fun size -> let if_not_found _ () = 0 in let if_found data () = data in let r = Example.random size in let t = Example.t size in stage (fun () -> let key = Example.random_key r `either in ignore (find_and_call1 t key ~a:() ~if_found ~if_not_found : int))) ;; let findi_and_call1 = Table.findi_and_call1 let () = ( !! ) "findi_and_call1 + " (fun size -> let if_not_found _ () = 0 in let if_found ~key:_ ~data () = data in let r = Example.random size in let t = Example.t size in stage (fun () -> let key = Example.random_key r `either in ignore (findi_and_call1 t key ~a:() ~if_found ~if_not_found : int))) ;; let find_and_call2 = Table.find_and_call2 let () = ( !! ) "find_and_call2 + " (fun size -> let if_not_found _ () () = 0 in let if_found data () () = data in let r = Example.random size in let t = Example.t size in stage (fun () -> let key = Example.random_key r `either in ignore (find_and_call2 t key ~a:() ~b:() ~if_found ~if_not_found : int))) ;; let findi_and_call2 = Table.findi_and_call2 let () = ( !! ) "findi_and_call2 + " (fun size -> let if_not_found _ () () = 0 in let if_found ~key:_ ~data () () = data in let r = Example.random size in let t = Example.t size in stage (fun () -> let key = Example.random_key r `either in ignore (findi_and_call2 t key ~a:() ~b:() ~if_found ~if_not_found : int))) ;; let merge = Table.merge let () = let bench desc merge_fun = ( !! ) (sprintf "merge [%s]" desc) (fun size -> let t = Example.t (size * 2) in (* [t1] and [t2] both have [size] keys, and half of their keys overlap. *) let t1 = filter t ~f:(fun data -> data % 2 = 0) in let t2 = filter t ~f:(fun data -> data < size) in stage (fun () -> ignore (merge t1 t2 ~f:merge_fun : int t))) in bench "drop" (fun ~key:_ _ -> None); bench "keep" (fun ~key:_ -> function | `Left data | `Right data -> Some data | `Both (left, right) -> Some (left + right)) ;; let merge_into = Table.merge_into let () = let bench desc merge_fun = ( !! ) (sprintf "copy + merge_into [%s]" desc) (fun size -> let t = Example.t (size * 2) in (* [t1] and [t2] both have [size] keys, and half of their keys overlap. *) let t1 = filter t ~f:(fun data -> data % 2 = 0) in let t2 = filter t ~f:(fun data -> data < size) in stage (fun () -> merge_into ~dst:(copy t1) ~src:t2 ~f:merge_fun)) in bench "drop" (fun ~key:_ _ _ -> Remove); bench "keep" (fun ~key:_ x _ -> Set_to x) ;; let filter_inplace = Table.filter_inplace let () = ( !! ) "copy + filter_inplace [halve]" (fun size -> let f data = data % 2 = 0 in let t = Example.t size in stage (fun () -> filter_inplace (copy t) ~f)) ;; let filteri_inplace = Table.filteri_inplace let () = ( !! ) "copy + filteri_inplace [halve]" (fun size -> let f ~key:_ ~data = data % 2 = 0 in let t = Example.t size in stage (fun () -> filteri_inplace (copy t) ~f)) ;; let filter_keys_inplace = Table.filter_keys_inplace let () = ( !! ) "copy + filter_keys_inplace [true]" (fun size -> let f _ = true in let t = Example.t size in stage (fun () -> filter_keys_inplace (copy t) ~f)) ;; let () = ( !! ) "copy + filter_keys_inplace [false]" (fun size -> let f _ = false in let t = Example.t size in stage (fun () -> filter_keys_inplace (copy t) ~f)) ;; let map_inplace = Table.map_inplace let () = ( !! ) "copy + map_inplace" (fun size -> let f data = data + 1 in let t = Example.t size in stage (fun () -> map_inplace (copy t) ~f)) ;; let mapi_inplace = Table.mapi_inplace let () = ( !! ) "copy + mapi_inplace" (fun size -> let f ~key:_ ~data = data + 1 in let t = Example.t size in stage (fun () -> mapi_inplace (copy t) ~f)) ;; let filter_map_inplace = Table.filter_map_inplace let () = ( !! ) "copy + filter_map_inplace [halve]" (fun size -> let f data = if data % 2 = 0 then Some (data + 1) else None in let t = Example.t size in stage (fun () -> filter_map_inplace (copy t) ~f)) ;; let filter_mapi_inplace = Table.filter_mapi_inplace let () = ( !! ) "copy + filter_mapi_inplace [halve]" (fun size -> let f ~key:_ ~data = if data % 2 = 0 then Some (data + 1) else None in let t = Example.t size in stage (fun () -> filter_mapi_inplace (copy t) ~f)) ;; let equal = Table.equal let () = ( !! ) "equal [same]" (fun size -> let t1 = Example.t size in let t2 = copy t1 in stage (fun () -> ignore (equal Int.equal t1 t2 : bool))) ;; let similar = Table.similar let () = ( !! ) "similar [same]" (fun size -> let t1 = Example.t size in let t2 = copy t1 in stage (fun () -> ignore (similar Int.equal t1 t2 : bool))) ;; let to_alist = Table.to_alist let () = ( !! ) "to_alist" (fun size -> let t = Example.t size in stage (fun () -> ignore (to_alist t : (Key.t * int) list))) ;; let validate = Table.validate let () = ( !! ) "validate [pass]" (fun size -> let check _ = Validate.pass in let name _ = "name" in let t = Example.t size in stage (fun () -> ignore (validate check t ~name : Validate.t))) ;; let incr = Table.incr let () = ( !! ) "incr + [existing]" (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> incr t (Example.random_key r `present))) ;; let decr = Table.decr let () = ( !! ) "decr + [existing]" (fun size -> let r = Example.random size in let t = Example.t size in stage (fun () -> decr t (Example.random_key r `present))) ;; (* no benchmarks for non-functions *) let hashable = Table.hashable end let benchmarks = For_bench.all () end module Int_key = struct include Int let hash s = [%hash: int] s let module_name = "Int" end module Int_key_with_collisions = struct include Int let module_name = "Int_sqr" (* This hash function causes irregular numbers of collisions because squaring does not map uniformly onto modulo space, which I think is more like what a "bad" hash function would cause. *) let hash x = x * x end module String_key = struct include String let hash = [%hash: string] let module_name = "String" let of_int_exn i = sprintf "%016x" i end (* There is no specific reason why we chose this record structure. It would be good to test a mix of immediate components, non-immediate components, and recursive components. So we threw a few such things into this record structure. *) module Compound_key = struct type t = { int : int ; string : string ; tuple : bool option * char } [@@deriving sexp, compare, hash] let of_int_exn int = let option = match int % 3 with | 0 -> None | 1 -> Some true | 2 -> Some false | _ -> assert false in let char = Char.of_int_exn (int % 256) in { int; string = String_key.of_int_exn int; tuple = option, char } ;; let module_name = "Compound" end module Bench_impl (Config : Config) (Impl : Impl) = struct module M1 = Benchmarks (Config) (Impl) (Int_key) module M2 = Benchmarks (Config) (Impl) (Int_key_with_collisions) module M3 = Benchmarks (Config) (Impl) (String_key) module M4 = Benchmarks (Config) (Impl) (Compound_key) let benchmarks = M1.benchmarks @ M2.benchmarks @ M3.benchmarks @ M4.benchmarks end module Hash_impl : Impl = struct include Core.Hashtbl let module_name = "Hashtbl" end module Pool_impl : Impl = struct include Pooled_hashtbl let module_name = "Pooled_hashtbl" end module Bench_hashtbl (Config : Config) = Bench_impl (Config) (Hash_impl) module Bench_pooled (Config : Config) = Bench_impl (Config) (Pool_impl) let benchmarks ~regex ~sizes = let module Config = struct let regex = regex let sizes = sizes end in let module H = Bench_hashtbl (Config) in let module P = Bench_pooled (Config) in H.benchmarks @ P.benchmarks |> List.sort ~compare:(fun test1 test2 -> String.compare (Bench.Test.name test1) (Bench.Test.name test2)) ;; module Top_level = struct let command = let open Command.Let_syntax in let open Command.Spec in let regex = Arg_type.create Re2.create_exn in Bench.make_command_ext ~summary:"Benchmarks for hash tables." [%map_open let regex = flag "-matching" (optional regex) ~doc:"REGEX Select tests matching given regex." and sizes = flag "-sizes" (optional_with_default [ 1; 32; 1024 ] (Arg_type.comma_separated int ~allow_empty:true)) ~doc:"INT,... Use hash tables of specified sizes." and list = flag "-list" no_arg ~doc:" List benchmark names; do not run benchmarks." in fun (analysis_configs, display_config, mode) -> let tests = benchmarks ~regex ~sizes in if list then ( printf "There are %s benchmarks:\n" (Int.to_string_hum (List.length tests * List.length sizes)); List.iter tests ~f:(fun test -> List.iter sizes ~f:(fun size -> printf "%s:%d\n" (Bench.Test.name test) size))) else ( match mode with | `From_file _ -> failwith "This executable is for running benchmarks, not analyzing saved \ measurements." | `Run (save_to_file, run_config) -> Bench.bench ~run_config ~analysis_configs ~display_config ?save_to_file tests)] ;; end let () = Command_unix.run Top_level.command core-0.15.0/core/bench-bin/hashtbl_bench.mli000066400000000000000000000000321420273305200205620ustar00rootroot00000000000000(* intentionally blank *) core-0.15.0/core/bench-bin/immediate_bench.ml000066400000000000000000000006131420273305200207270ustar00rootroot00000000000000open! Core open Core_bench module Always = Type_immediacy.Always module M = struct type t = | A | B | C [@@deriving typerep] let always = Always.of_typerep_exn [%here] typerep_of_t end let tests = [ Bench.Test.create ~name:"Always.value_as_int" (fun () -> ignore (Always.value_as_int M.always M.A : int)) ] ;; let () = Command_unix.run (Bench.make_command tests) core-0.15.0/core/bench-bin/ordering_container.ml000066400000000000000000000072041420273305200215100ustar00rootroot00000000000000open Core open Core_bench module Heap = Pairing_heap module Int = struct let name = "int" include Int let random () = Random.int 1_000_000 end module String_list = struct let name = "string-list" module T = struct type t = string list [@@deriving sexp, bin_io, compare, hash] end include T include Comparable.Make (T) include Hashable.Make (T) let random_char () = Random.int 127 |> Char.of_int_exn let random () = List.init 5 ~f:(fun _ -> String.init 5 ~f:(fun _ -> random_char ())) end module type Key = sig type t include Hashable.S with type t := t include Comparable.S with type t := t val name : string val random : unit -> t end module Mock_heap = struct let create ~cmp:_ () = () let add_removable _ _ = () let update _ _ _ = () end let gen_test_add_and_update ~create ~random ~add ~update n = let sample = Array.init n ~f:(fun _ -> random ()) in let sample2 = Array.init n ~f:(fun _ -> random ()) in fun () -> let container = create () in Array.iter sample ~f:(fun x -> add container x); Array.iteri sample2 ~f:(fun i x -> update container sample.(i) x) ;; let gen_test_update ~create ~random ~add ~update n = let sample = Array.init n ~f:(fun _ -> random ()) in let container = create () in Array.iter sample ~f:(fun x -> add container x); fun () -> for _ = 0 to n / 10 do let i = Random.int n in let a = random () in update container sample.(i) a; sample.(i) <- a done ;; let gen_tests m n = let module Key = (val m : Key) in let test_set = let random = Key.random in let create () = ref Key.Set.empty in let add c x = c := Set.add !c x in let update c x y = c := Set.add (Set.remove !c x) y in [ Bench.Test.create ~name:(Key.name ^ "-set-add&update") (gen_test_add_and_update ~create ~random ~add ~update n) ; Bench.Test.create ~name:(Key.name ^ "-set-update") (gen_test_update ~create ~random ~add ~update n) ] in let test_mock_heap = let module Heap = Mock_heap in let random = Key.random in let create () = Heap.create ~cmp:Key.compare (), Key.Table.create () in let add (heap, elts) x = let elt = Heap.add_removable heap x in Hashtbl.set elts ~key:x ~data:elt in let update (heap, elts) x y = match Hashtbl.find elts x with | None -> () | Some elt -> let elt = Heap.update heap elt y in Hashtbl.set elts ~key:y ~data:elt in [ Bench.Test.create ~name:(Key.name ^ "-mockheap-add&update") (gen_test_add_and_update ~create ~random ~add ~update n) ; Bench.Test.create ~name:(Key.name ^ "-mockheap-update") (gen_test_update ~create ~random ~add ~update n) ] in let test_heap = let random = Key.random in let create () = Heap.create ~cmp:Key.compare (), Key.Table.create () in let add (heap, elts) x = let elt = Heap.add_removable heap x in Hashtbl.set elts ~key:x ~data:elt in let update (heap, elts) x y = match Hashtbl.find elts x with | None -> () | Some elt -> let elt = Heap.update heap elt y in Hashtbl.set elts ~key:y ~data:elt in [ Bench.Test.create ~name:(Key.name ^ "-heap-add&update") (gen_test_add_and_update ~create ~random ~add ~update n) ; Bench.Test.create ~name:(Key.name ^ "-heap-update") (gen_test_update ~create ~random ~add ~update n) ] in List.concat [ test_set; test_heap; test_mock_heap ] ;; let () = Random.self_init (); let n = 100_000 in [ gen_tests (module Int : Key) n; gen_tests (module String_list : Key) n ] |> List.concat |> Bench.bench ;; core-0.15.0/core/bench-bin/string_escaping.ml000066400000000000000000000021431420273305200210110ustar00rootroot00000000000000open Core open Poly module Bench = Core_bench.Bench let () = let module E = String.Escaping in let escape = Staged.unstage (E.escape ~escapeworthy:[ 'x'; 'y'; 'z' ] ~escape_char:'\\') in let unescape = Staged.unstage (E.unescape ~escape_char:'\\') in let rex = Pcre.regexp "[xyz\\\\]" in let unrex = Pcre.regexp "\\\\." in let escape_pcre s = Pcre.substitute ~rex ~subst:(fun s -> "\\" ^ s) s in let unescape_pcre s = Pcre.substitute ~rex:unrex ~subst:(fun s -> Char.to_string s.[1]) s in let strings = [ "aaa" ; "xyz" ; "aaaaaaaaa" ; "aaxaaxaax" ; "abcde\\abcde\\abcde\\abcde\\abcde\\abcde\\" ; "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ; "aaaaaaaaaaaaaaaaaa\\aaaaaaaaaaaaaaaaaaaaaaa" ; "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" ] in Bench.bench (List.concat_map strings ~f:(fun str -> let go name escape unescape = Bench.Test.create ~name:(sprintf "%s-%s" name str) (fun () -> assert (unescape (escape str) = str)) in [ go "String.Escaping" escape unescape; go "Pcre" escape_pcre unescape_pcre ])) ;; core-0.15.0/core/bench-bin/time_to_string.ml000066400000000000000000000004021420273305200206540ustar00rootroot00000000000000open Core open Core_bench let date = Date.create_exn ~d:14 ~m:Month.Jul ~y:1789 let () = Command_unix.run (Bench.make_command [ Bench.Test.create ~name:"Date.to_string" (fun () -> ignore (Date.to_string date : string)) ]) ;; core-0.15.0/core/replace_caml_modify_for_testing/000077500000000000000000000000001420273305200220345ustar00rootroot00000000000000core-0.15.0/core/replace_caml_modify_for_testing/dune000066400000000000000000000003301420273305200227060ustar00rootroot00000000000000(library (name replace_caml_modify_for_testing) (library_flags -cclib -Xlinker -cclib --wrap -cclib -Xlinker -cclib caml_modify) (c_names replace_caml_modify_for_testing_stub) (preprocess (pps ppx_inline_test)))core-0.15.0/core/replace_caml_modify_for_testing/replace_caml_modify_for_testing.ml000066400000000000000000000006651420273305200307560ustar00rootroot00000000000000external count : unit -> int = "replace_caml_modify_for_testing_count" [@@noalloc] external reset : unit -> unit = "replace_caml_modify_for_testing_reset" [@@noalloc] let%test_unit _ = let x = Array.make (32 * 1024) [ Random.int 10 ] in let v = [ Random.int 10 ] in let n = count () in x.(0) <- v; assert (count () = n + 1); let x = Array.make (32 * 1024) 0 in let n = count () in x.(0) <- 2; assert (count () = n) ;; core-0.15.0/core/replace_caml_modify_for_testing/replace_caml_modify_for_testing.mli000066400000000000000000000007441420273305200311250ustar00rootroot00000000000000(** Increment a counter whenever [caml_modify] is called. This library wraps caml_modify at the C level, and should only be used in testing code. *) (** [count ()] returns the number of times [caml_modify] has been called since the last call to {!reset}. *) external count : unit -> int = "replace_caml_modify_for_testing_count" [@@noalloc] (** [reset ()] reset the counter to [0]. *) external reset : unit -> unit = "replace_caml_modify_for_testing_reset" [@@noalloc] core-0.15.0/core/replace_caml_modify_for_testing/replace_caml_modify_for_testing_stub.c000066400000000000000000000007661420273305200316270ustar00rootroot00000000000000#include CAMLextern void __real_caml_modify(value *fp, value v); static long count = 0; void (*replace_caml_modify_hook)(void) = NULL; CAMLprim void __wrap_caml_modify(value *fp, value v) { count++; __real_caml_modify(fp, v); if (replace_caml_modify_hook != NULL) replace_caml_modify_hook (); } CAMLprim value replace_caml_modify_for_testing_count() { return Val_long(count); } CAMLprim value replace_caml_modify_for_testing_reset() { count = 0; return Val_unit; } core-0.15.0/core/src/000077500000000000000000000000001420273305200142425ustar00rootroot00000000000000core-0.15.0/core/src/arg.ml000066400000000000000000000002541420273305200153460ustar00rootroot00000000000000open! Import include Caml.Arg type t = key * spec * doc let sort_and_align lst = align (Base.List.sort lst ~compare:(fun (a, _, _) (b, _, _) -> String.compare a b)) ;; core-0.15.0/core/src/arg.mli000066400000000000000000000005721420273305200155220ustar00rootroot00000000000000(** INRIA's original command-line parsing library. The [Command] module is generally recommended over direct use of this library. *) open! Import include module type of Caml.Arg (** @inline *) type t = key * spec * doc (** Like [align], except that the specification list is also sorted by key *) val sort_and_align : (key * spec * doc) list -> (key * spec * doc) list core-0.15.0/core/src/array.ml000066400000000000000000000377501420273305200157260ustar00rootroot00000000000000open! Import open Base_quickcheck.Export open Perms.Export module Array = Base.Array module Core_sequence = Sequence include ( Base.Array : sig type 'a t = 'a array [@@deriving sexp, compare, sexp_grammar] end) type 'a t = 'a array [@@deriving bin_io, quickcheck, typerep] module Private = Base.Array.Private module T = struct include Base.Array let normalize t i = Ordered_collection_common.normalize ~length_fun:length t i let slice t start stop = Ordered_collection_common.slice ~length_fun:length ~sub_fun:sub t start stop ;; let nget t i = t.(normalize t i) let nset t i v = t.(normalize t i) <- v module Sequence = struct open Base.Array let length = length let get = get let set = set end (* See OCaml perf notes for why these array blits are special cased -- in particular, the section entitled "Fast, Slow and Incorrect Array blits" of https://web.archive.org/web/20130220000229/http://janestreet.github.com/ocaml-perf-notes.html *) module Int = struct type t_ = int array [@@deriving bin_io, compare, sexp] module Unsafe_blit = struct external unsafe_blit : src:t_ -> src_pos:int -> dst:t_ -> dst_pos:int -> len:int -> unit = "core_array_unsafe_int_blit" [@@noalloc] end include Test_blit.Make_and_test (struct type t = int let equal = ( = ) let of_bool b = if b then 1 else 0 end) (struct type t = t_ [@@deriving sexp_of] include Sequence let create ~len = create ~len 0 include Unsafe_blit end) include Unsafe_blit end module Float = struct type t_ = float array [@@deriving bin_io, compare, sexp] module Unsafe_blit = struct external unsafe_blit : src:t_ -> src_pos:int -> dst:t_ -> dst_pos:int -> len:int -> unit = "core_array_unsafe_float_blit" [@@noalloc] end include Test_blit.Make_and_test (struct type t = float let equal = Base.Float.equal let of_bool b = if b then 1. else 0. end) (struct type t = t_ [@@deriving sexp_of] include Sequence let create ~len = create ~len 0. include Unsafe_blit end) include Unsafe_blit end end module type Permissioned = sig type ('a, -'perms) t include Container.S1_permissions with type ('a, 'perms) t := ('a, 'perms) t include Blit.S1_permissions with type ('a, 'perms) t := ('a, 'perms) t include Binary_searchable.S1_permissions with type ('a, 'perms) t := ('a, 'perms) t external length : ('a, _) t -> int = "%array_length" val is_empty : (_, _) t -> bool external get : ('a, [> read ]) t -> int -> 'a = "%array_safe_get" external set : ('a, [> write ]) t -> int -> 'a -> unit = "%array_safe_set" external unsafe_get : ('a, [> read ]) t -> int -> 'a = "%array_unsafe_get" external unsafe_set : ('a, [> write ]) t -> int -> 'a -> unit = "%array_unsafe_set" val create_float_uninitialized : len:int -> (float, [< _ perms ]) t val create : len:int -> 'a -> ('a, [< _ perms ]) t val init : int -> f:(int -> 'a) -> ('a, [< _ perms ]) t val make_matrix : dimx:int -> dimy:int -> 'a -> (('a, [< _ perms ]) t, [< _ perms ]) t val copy_matrix : (('a, [> read ]) t, [> read ]) t -> (('a, [< _ perms ]) t, [< _ perms ]) t val append : ('a, [> read ]) t -> ('a, [> read ]) t -> ('a, [< _ perms ]) t val concat : ('a, [> read ]) t list -> ('a, [< _ perms ]) t val copy : ('a, [> read ]) t -> ('a, [< _ perms ]) t val fill : ('a, [> write ]) t -> pos:int -> len:int -> 'a -> unit val of_list : 'a list -> ('a, [< _ perms ]) t val map : ('a, [> read ]) t -> f:('a -> 'b) -> ('b, [< _ perms ]) t val folding_map : ('a, [> read ]) t -> init:'b -> f:('b -> 'a -> 'b * 'c) -> ('c, [< _ perms ]) t val fold_map : ('a, [> read ]) t -> init:'b -> f:('b -> 'a -> 'b * 'c) -> 'b * ('c, [< _ perms ]) t val mapi : ('a, [> read ]) t -> f:(int -> 'a -> 'b) -> ('b, [< _ perms ]) t val iteri : ('a, [> read ]) t -> f:(int -> 'a -> unit) -> unit val foldi : ('a, [> read ]) t -> init:'b -> f:(int -> 'b -> 'a -> 'b) -> 'b val folding_mapi : ('a, [> read ]) t -> init:'b -> f:(int -> 'b -> 'a -> 'b * 'c) -> ('c, [< _ perms ]) t val fold_mapi : ('a, [> read ]) t -> init:'b -> f:(int -> 'b -> 'a -> 'b * 'c) -> 'b * ('c, [< _ perms ]) t val fold_right : ('a, [> read ]) t -> f:('a -> 'b -> 'b) -> init:'b -> 'b val sort : ?pos:int -> ?len:int -> ('a, [> read_write ]) t -> compare:('a -> 'a -> int) -> unit val stable_sort : ('a, [> read_write ]) t -> compare:('a -> 'a -> int) -> unit val is_sorted : ('a, [> read ]) t -> compare:('a -> 'a -> int) -> bool val is_sorted_strictly : ('a, [> read ]) t -> compare:('a -> 'a -> int) -> bool val merge : ('a, [> read ]) t -> ('a, [> read ]) t -> compare:('a -> 'a -> int) -> ('a, [< _ perms ]) t val concat_map : ('a, [> read ]) t -> f:('a -> ('b, [> read ]) t) -> ('b, [< _ perms ]) t val concat_mapi : ('a, [> read ]) t -> f:(int -> 'a -> ('b, [> read ]) t) -> ('b, [< _ perms ]) t val partition_tf : ('a, [> read ]) t -> f:('a -> bool) -> ('a, [< _ perms ]) t * ('a, [< _ perms ]) t val partitioni_tf : ('a, [> read ]) t -> f:(int -> 'a -> bool) -> ('a, [< _ perms ]) t * ('a, [< _ perms ]) t val cartesian_product : ('a, [> read ]) t -> ('b, [> read ]) t -> ('a * 'b, [< _ perms ]) t val transpose : (('a, [> read ]) t, [> read ]) t -> (('a, [< _ perms ]) t, [< _ perms ]) t option val transpose_exn : (('a, [> read ]) t, [> read ]) t -> (('a, [< _ perms ]) t, [< _ perms ]) t val normalize : ('a, _) t -> int -> int val slice : ('a, [> read ]) t -> int -> int -> ('a, [< _ perms ]) t val nget : ('a, [> read ]) t -> int -> 'a val nset : ('a, [> write ]) t -> int -> 'a -> unit val filter_opt : ('a option, [> read ]) t -> ('a, [< _ perms ]) t val filter_map : ('a, [> read ]) t -> f:('a -> 'b option) -> ('b, [< _ perms ]) t val filter_mapi : ('a, [> read ]) t -> f:(int -> 'a -> 'b option) -> ('b, [< _ perms ]) t val for_alli : ('a, [> read ]) t -> f:(int -> 'a -> bool) -> bool val existsi : ('a, [> read ]) t -> f:(int -> 'a -> bool) -> bool val counti : ('a, [> read ]) t -> f:(int -> 'a -> bool) -> int val iter2_exn : ('a, [> read ]) t -> ('b, [> read ]) t -> f:('a -> 'b -> unit) -> unit val map2_exn : ('a, [> read ]) t -> ('b, [> read ]) t -> f:('a -> 'b -> 'c) -> ('c, [< _ perms ]) t val fold2_exn : ('a, [> read ]) t -> ('b, [> read ]) t -> init:'c -> f:('c -> 'a -> 'b -> 'c) -> 'c val for_all2_exn : ('a, [> read ]) t -> ('b, [> read ]) t -> f:('a -> 'b -> bool) -> bool val exists2_exn : ('a, [> read ]) t -> ('b, [> read ]) t -> f:('a -> 'b -> bool) -> bool val filter : ('a, [> read ]) t -> f:('a -> bool) -> ('a, [< _ perms ]) t val filteri : ('a, [> read ]) t -> f:(int -> 'a -> bool) -> ('a, [< _ perms ]) t val swap : ('a, [> read_write ]) t -> int -> int -> unit val rev_inplace : ('a, [> read_write ]) t -> unit val rev : ('a, [> read ]) t -> ('a, [< _ perms ]) t val of_list_rev : 'a list -> ('a, [< _ perms ]) t val of_list_map : 'a list -> f:('a -> 'b) -> ('b, [< _ perms ]) t val of_list_mapi : 'a list -> f:(int -> 'a -> 'b) -> ('b, [< _ perms ]) t val of_list_rev_map : 'a list -> f:('a -> 'b) -> ('b, [< _ perms ]) t val of_list_rev_mapi : 'a list -> f:(int -> 'a -> 'b) -> ('b, [< _ perms ]) t val map_inplace : ('a, [> read_write ]) t -> f:('a -> 'a) -> unit val find_exn : ('a, [> read ]) t -> f:('a -> bool) -> 'a val find_map_exn : ('a, [> read ]) t -> f:('a -> 'b option) -> 'b val findi : ('a, [> read ]) t -> f:(int -> 'a -> bool) -> (int * 'a) option val findi_exn : ('a, [> read ]) t -> f:(int -> 'a -> bool) -> int * 'a val find_mapi : ('a, [> read ]) t -> f:(int -> 'a -> 'b option) -> 'b option val find_mapi_exn : ('a, [> read ]) t -> f:(int -> 'a -> 'b option) -> 'b val find_consecutive_duplicate : ('a, [> read ]) t -> equal:('a -> 'a -> bool) -> ('a * 'a) option val reduce : ('a, [> read ]) t -> f:('a -> 'a -> 'a) -> 'a option val reduce_exn : ('a, [> read ]) t -> f:('a -> 'a -> 'a) -> 'a val permute : ?random_state:Random.State.t -> ?pos:int -> ?len:int -> ('a, [> read_write ]) t -> unit val random_element : ?random_state:Random.State.t -> ('a, [> read ]) t -> 'a option val random_element_exn : ?random_state:Random.State.t -> ('a, [> read ]) t -> 'a val zip : ('a, [> read ]) t -> ('b, [> read ]) t -> ('a * 'b, [< _ perms ]) t option val zip_exn : ('a, [> read ]) t -> ('b, [> read ]) t -> ('a * 'b, [< _ perms ]) t val unzip : ('a * 'b, [> read ]) t -> ('a, [< _ perms ]) t * ('b, [< _ perms ]) t val sorted_copy : ('a, [> read ]) t -> compare:('a -> 'a -> int) -> ('a, [< _ perms ]) t val last : ('a, [> read ]) t -> 'a val equal : ('a -> 'a -> bool) -> ('a, [> read ]) t -> ('a, [> read ]) t -> bool val to_sequence : ('a, [> read ]) t -> 'a Sequence.t val to_sequence_mutable : ('a, [> read ]) t -> 'a Sequence.t end module Permissioned : sig type ('a, -'perms) t [@@deriving bin_io, compare, sexp] module Int : sig type nonrec -'perms t = (int, 'perms) t [@@deriving bin_io, compare, sexp] include Blit.S_permissions with type 'perms t := 'perms t external unsafe_blit : src:[> read ] t -> src_pos:int -> dst:[> write ] t -> dst_pos:int -> len:int -> unit = "core_array_unsafe_int_blit" [@@noalloc] end module Float : sig type nonrec -'perms t = (float, 'perms) t [@@deriving bin_io, compare, sexp] include Blit.S_permissions with type 'perms t := 'perms t external unsafe_blit : src:[> read ] t -> src_pos:int -> dst:[> write ] t -> dst_pos:int -> len:int -> unit = "core_array_unsafe_float_blit" [@@noalloc] end val of_array_id : 'a array -> ('a, [< read_write ]) t val to_array_id : ('a, [> read_write ]) t -> 'a array val to_sequence_immutable : ('a, [> immutable ]) t -> 'a Sequence.t include Permissioned with type ('a, 'perms) t := ('a, 'perms) t end = struct type ('a, -'perms) t = 'a array [@@deriving bin_io, compare, sexp, typerep] module Int = struct include T.Int type -'perms t = t_ [@@deriving bin_io, compare, sexp] end module Float = struct include T.Float type -'perms t = t_ [@@deriving bin_io, compare, sexp] end let to_array_id = Fn.id let of_array_id = Fn.id include (T : Permissioned with type ('a, 'b) t := ('a, 'b) t) [@ocaml.warning "-3"] let to_array = copy let to_sequence_immutable = to_sequence_mutable end module type S = sig type 'a t include Binary_searchable.S1 with type 'a t := 'a t include Container.S1 with type 'a t := 'a t external length : 'a t -> int = "%array_length" external get : 'a t -> int -> 'a = "%array_safe_get" external set : 'a t -> int -> 'a -> unit = "%array_safe_set" external unsafe_get : 'a t -> int -> 'a = "%array_unsafe_get" external unsafe_set : 'a t -> int -> 'a -> unit = "%array_unsafe_set" val create : len:int -> 'a -> 'a t val create_float_uninitialized : len:int -> float t val init : int -> f:(int -> 'a) -> 'a t val make_matrix : dimx:int -> dimy:int -> 'a -> 'a t t val copy_matrix : 'a t t -> 'a t t val append : 'a t -> 'a t -> 'a t val concat : 'a t list -> 'a t val copy : 'a t -> 'a t val fill : 'a t -> pos:int -> len:int -> 'a -> unit include Blit.S1 with type 'a t := 'a t val of_list : 'a list -> 'a t val map : 'a t -> f:('a -> 'b) -> 'b t val folding_map : 'a t -> init:'b -> f:('b -> 'a -> 'b * 'c) -> 'c t val fold_map : 'a t -> init:'b -> f:('b -> 'a -> 'b * 'c) -> 'b * 'c t val mapi : 'a t -> f:(int -> 'a -> 'b) -> 'b t val iteri : 'a t -> f:(int -> 'a -> unit) -> unit val foldi : 'a t -> init:'b -> f:(int -> 'b -> 'a -> 'b) -> 'b val folding_mapi : 'a t -> init:'b -> f:(int -> 'b -> 'a -> 'b * 'c) -> 'c t val fold_mapi : 'a t -> init:'b -> f:(int -> 'b -> 'a -> 'b * 'c) -> 'b * 'c t val fold_right : 'a t -> f:('a -> 'b -> 'b) -> init:'b -> 'b val sort : ?pos:int -> ?len:int -> 'a t -> compare:('a -> 'a -> int) -> unit val stable_sort : 'a t -> compare:('a -> 'a -> int) -> unit val is_sorted : 'a t -> compare:('a -> 'a -> int) -> bool val is_sorted_strictly : 'a t -> compare:('a -> 'a -> int) -> bool val merge : 'a t -> 'a t -> compare:('a -> 'a -> int) -> 'a t val concat_map : 'a t -> f:('a -> 'b t) -> 'b t val concat_mapi : 'a t -> f:(int -> 'a -> 'b t) -> 'b t val partition_tf : 'a t -> f:('a -> bool) -> 'a t * 'a t val partitioni_tf : 'a t -> f:(int -> 'a -> bool) -> 'a t * 'a t val cartesian_product : 'a t -> 'b t -> ('a * 'b) t val transpose : 'a t t -> 'a t t option val transpose_exn : 'a t t -> 'a t t val normalize : 'a t -> int -> int val slice : 'a t -> int -> int -> 'a t val nget : 'a t -> int -> 'a val nset : 'a t -> int -> 'a -> unit val filter_opt : 'a option t -> 'a t val filter_map : 'a t -> f:('a -> 'b option) -> 'b t val filter_mapi : 'a t -> f:(int -> 'a -> 'b option) -> 'b t val for_alli : 'a t -> f:(int -> 'a -> bool) -> bool val existsi : 'a t -> f:(int -> 'a -> bool) -> bool val counti : 'a t -> f:(int -> 'a -> bool) -> int val iter2_exn : 'a t -> 'b t -> f:('a -> 'b -> unit) -> unit val map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t val fold2_exn : 'a t -> 'b t -> init:'c -> f:('c -> 'a -> 'b -> 'c) -> 'c val for_all2_exn : 'a t -> 'b t -> f:('a -> 'b -> bool) -> bool val exists2_exn : 'a t -> 'b t -> f:('a -> 'b -> bool) -> bool val filter : 'a t -> f:('a -> bool) -> 'a t val filteri : 'a t -> f:(int -> 'a -> bool) -> 'a t val swap : 'a t -> int -> int -> unit val rev_inplace : 'a t -> unit val rev : 'a t -> 'a t val of_list_rev : 'a list -> 'a t val of_list_map : 'a list -> f:('a -> 'b) -> 'b t val of_list_mapi : 'a list -> f:(int -> 'a -> 'b) -> 'b t val of_list_rev_map : 'a list -> f:('a -> 'b) -> 'b t val of_list_rev_mapi : 'a list -> f:(int -> 'a -> 'b) -> 'b t val map_inplace : 'a t -> f:('a -> 'a) -> unit val find_exn : 'a t -> f:('a -> bool) -> 'a val find_map_exn : 'a t -> f:('a -> 'b option) -> 'b val findi : 'a t -> f:(int -> 'a -> bool) -> (int * 'a) option val findi_exn : 'a t -> f:(int -> 'a -> bool) -> int * 'a val find_mapi : 'a t -> f:(int -> 'a -> 'b option) -> 'b option val find_mapi_exn : 'a t -> f:(int -> 'a -> 'b option) -> 'b val find_consecutive_duplicate : 'a t -> equal:('a -> 'a -> bool) -> ('a * 'a) option val reduce : 'a t -> f:('a -> 'a -> 'a) -> 'a option val reduce_exn : 'a t -> f:('a -> 'a -> 'a) -> 'a val permute : ?random_state:Random.State.t -> ?pos:int -> ?len:int -> 'a t -> unit val random_element : ?random_state:Random.State.t -> 'a t -> 'a option val random_element_exn : ?random_state:Random.State.t -> 'a t -> 'a val zip : 'a t -> 'b t -> ('a * 'b) t option val zip_exn : 'a t -> 'b t -> ('a * 'b) t val unzip : ('a * 'b) t -> 'a t * 'b t val sorted_copy : 'a t -> compare:('a -> 'a -> int) -> 'a t val last : 'a t -> 'a val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val to_sequence : 'a t -> 'a Core_sequence.t val to_sequence_mutable : 'a t -> 'a Core_sequence.t end include (T : S with type 'a t := 'a array) [@ocaml.warning "-3"] let invariant invariant_a t = iter t ~f:invariant_a let max_length = Sys.max_array_length module Int = struct include T.Int type t = t_ [@@deriving bin_io, compare, sexp] end module Float = struct include T.Float type t = t_ [@@deriving bin_io, compare, sexp] end module _ (M : S) : sig type ('a, -'perm) t_ include Permissioned with type ('a, 'perm) t := ('a, 'perm) t_ end = struct include M type ('a, -'perm) t_ = 'a t end module _ (M : Permissioned) : sig type 'a t_ include S with type 'a t := 'a t_ end = struct include M type 'a t_ = ('a, read_write) t end core-0.15.0/core/src/array.mli000066400000000000000000000264361420273305200160760ustar00rootroot00000000000000(** Fixed-length, mutable vector of elements with O(1) [get] and [set] operations. This module extends {{!Base.Array}[Base.Array]}. *) open Import open Perms.Export (** {2 The [Array] type} *) type 'a t = 'a Base.Array.t [@@deriving bin_io, quickcheck, typerep] (** {2 The signature included from [Base.Array]} *) (** @inline *) include module type of struct include Base.Array end with type 'a t := 'a t (** {2 Extensions} We add extensions for [Int] and [Float] arrays to make them bin-able, comparable, sexpable, and blit-able (via [Blit.S]). [Permissioned] provides fine-grained access control for arrays. Operations supporting "normalized" indexes are also available. *) module Int : sig type nonrec t = int t [@@deriving bin_io, compare, sexp] include Blit.S with type t := t external unsafe_blit : src:t -> src_pos:int -> dst:t -> dst_pos:int -> len:int -> unit = "core_array_unsafe_int_blit" [@@noalloc] end module Float : sig type nonrec t = float t [@@deriving bin_io, compare, sexp] include Blit.S with type t := t external unsafe_blit : src:t -> src_pos:int -> dst:t -> dst_pos:int -> len:int -> unit = "core_array_unsafe_float_blit" [@@noalloc] end (** [normalize array index] returns a new index into the array such that if the index is less than zero, the returned index will "wrap around" -- i.e., [array.(normalize array (-1))] returns the last element of the array. *) val normalize : 'a t -> int -> int (** [slice t start stop] returns a new array including elements [t.(start)] through [t.(stop-1)], normalized Python-style with the exception that [stop = 0] is treated as [stop = length t]. *) val slice : 'a t -> int -> int -> 'a t (** Array access with [normalize]d index. *) val nget : 'a t -> int -> 'a (** Array modification with [normalize]d index. *) val nset : 'a t -> int -> 'a -> unit (** The [Permissioned] module gives the ability to restrict permissions on an array, so you can give a function read-only access to an array, create an immutable array, etc. *) module Permissioned : sig (** The meaning of the ['perms] parameter is as usual (see the [Perms] module for more details) with the non-obvious difference that you don't need any permissions to extract the length of an array. This was done for simplicity because some information about the length of an array can leak out even if you only have write permissions since you can catch out-of-bounds errors. *) type ('a, -'perms) t [@@deriving bin_io, compare, sexp] module Int : sig type nonrec -'perms t = (int, 'perms) t [@@deriving bin_io, compare, sexp] include Blit.S_permissions with type 'perms t := 'perms t external unsafe_blit : src:[> read ] t -> src_pos:int -> dst:[> write ] t -> dst_pos:int -> len:int -> unit = "core_array_unsafe_int_blit" [@@noalloc] end module Float : sig type nonrec -'perms t = (float, 'perms) t [@@deriving bin_io, compare, sexp] include Blit.S_permissions with type 'perms t := 'perms t external unsafe_blit : src:[> read ] t -> src_pos:int -> dst:[> write ] t -> dst_pos:int -> len:int -> unit = "core_array_unsafe_float_blit" [@@noalloc] end (** [of_array_id] and [to_array_id] return the same underlying array. On the other hand, [to_array] (inherited from [Container.S1_permissions] below) makes a copy. To create a new (possibly immutable) copy of an array [a], use [copy (of_array_id a)]. More generally, any function that takes a (possibly mutable) [t] can be called on an array by calling [of_array_id] on it first. There is a conceptual type equality between ['a Array.t] and [('a, read_write) Array.Permissioned.t]. The reason for not exposing this as an actual type equality is that we also want: {ul {- The type equality ['a Array.t = 'a array] for interoperability with code which does not use Core.} {- The type [('a, 'perms) Array.Permissioned.t] to be abstract, so that the permission phantom type will have an effect.} } Since we don't control the definition of ['a array], this would require a type [('a, 'perms) Array.Permissioned.t] which is abstract, except that [('a, read_write) Array.Permissioned.t] is concrete, which is not possible. *) val of_array_id : 'a array -> ('a, [< read_write ]) t val to_array_id : ('a, [> read_write ]) t -> 'a array (** [to_sequence_immutable t] converts [t] to a sequence. Unlike [to_sequence], [to_sequence_immutable] does not need to copy [t] since it is immutable. *) val to_sequence_immutable : ('a, [> immutable ]) t -> 'a Sequence.t include Container.S1_permissions with type ('a, 'perms) t := ('a, 'perms) t include Blit.S1_permissions with type ('a, 'perms) t := ('a, 'perms) t include Binary_searchable.S1_permissions with type ('a, 'perms) t := ('a, 'perms) t (** These functions are in [Container.S1_permissions], but they are re-exposed here so that their types can be changed to make them more permissive (see comment above). *) val length : (_, _) t -> int val is_empty : (_, _) t -> bool (** counterparts of regular array functions above *) external get : ('a, [> read ]) t -> int -> 'a = "%array_safe_get" external set : ('a, [> write ]) t -> int -> 'a -> unit = "%array_safe_set" external unsafe_get : ('a, [> read ]) t -> int -> 'a = "%array_unsafe_get" external unsafe_set : ('a, [> write ]) t -> int -> 'a -> unit = "%array_unsafe_set" val create : len:int -> 'a -> ('a, [< _ perms ]) t val create_float_uninitialized : len:int -> (float, [< _ perms ]) t val init : int -> f:(int -> 'a) -> ('a, [< _ perms ]) t val make_matrix : dimx:int -> dimy:int -> 'a -> (('a, [< _ perms ]) t, [< _ perms ]) t val copy_matrix : (('a, [> read ]) t, [> read ]) t -> (('a, [< _ perms ]) t, [< _ perms ]) t val append : ('a, [> read ]) t -> ('a, [> read ]) t -> ('a, [< _ perms ]) t val concat : ('a, [> read ]) t list -> ('a, [< _ perms ]) t val copy : ('a, [> read ]) t -> ('a, [< _ perms ]) t val fill : ('a, [> write ]) t -> pos:int -> len:int -> 'a -> unit val of_list : 'a list -> ('a, [< _ perms ]) t val map : ('a, [> read ]) t -> f:('a -> 'b) -> ('b, [< _ perms ]) t val mapi : ('a, [> read ]) t -> f:(int -> 'a -> 'b) -> ('b, [< _ perms ]) t val folding_map : ('a, [> read ]) t -> init:'b -> f:('b -> 'a -> 'b * 'c) -> ('c, [< _ perms ]) t val iteri : ('a, [> read ]) t -> f:(int -> 'a -> unit) -> unit val foldi : ('a, [> read ]) t -> init:'b -> f:(int -> 'b -> 'a -> 'b) -> 'b val folding_mapi : ('a, [> read ]) t -> init:'b -> f:(int -> 'b -> 'a -> 'b * 'c) -> ('c, [< _ perms ]) t val fold_right : ('a, [> read ]) t -> f:('a -> 'b -> 'b) -> init:'b -> 'b val sort : ?pos:int -> ?len:int -> ('a, [> read_write ]) t -> compare:('a -> 'a -> int) -> unit val stable_sort : ('a, [> read_write ]) t -> compare:('a -> 'a -> int) -> unit val is_sorted : ('a, [> read ]) t -> compare:('a -> 'a -> int) -> bool val is_sorted_strictly : ('a, [> read ]) t -> compare:('a -> 'a -> int) -> bool val merge : ('a, [> read ]) t -> ('a, [> read ]) t -> compare:('a -> 'a -> int) -> ('a, [< _ perms ]) t val concat_map : ('a, [> read ]) t -> f:('a -> ('b, [> read ]) t) -> ('b, [< _ perms ]) t val concat_mapi : ('a, [> read ]) t -> f:(int -> 'a -> ('b, [> read ]) t) -> ('b, [< _ perms ]) t val partition_tf : ('a, [> read ]) t -> f:('a -> bool) -> ('a, [< _ perms ]) t * ('a, [< _ perms ]) t val partitioni_tf : ('a, [> read ]) t -> f:(int -> 'a -> bool) -> ('a, [< _ perms ]) t * ('a, [< _ perms ]) t val cartesian_product : ('a, [> read ]) t -> ('b, [> read ]) t -> ('a * 'b, [< _ perms ]) t val transpose : (('a, [> read ]) t, [> read ]) t -> (('a, [< _ perms ]) t, [< _ perms ]) t option val transpose_exn : (('a, [> read ]) t, [> read ]) t -> (('a, [< _ perms ]) t, [< _ perms ]) t val normalize : (_, _) t -> int -> int val slice : ('a, [> read ]) t -> int -> int -> ('a, [< _ perms ]) t val nget : ('a, [> read ]) t -> int -> 'a val nset : ('a, [> write ]) t -> int -> 'a -> unit val filter_opt : ('a option, [> read ]) t -> ('a, [< _ perms ]) t val filter_map : ('a, [> read ]) t -> f:('a -> 'b option) -> ('b, [< _ perms ]) t val filter_mapi : ('a, [> read ]) t -> f:(int -> 'a -> 'b option) -> ('b, [< _ perms ]) t val for_alli : ('a, [> read ]) t -> f:(int -> 'a -> bool) -> bool val existsi : ('a, [> read ]) t -> f:(int -> 'a -> bool) -> bool val counti : ('a, [> read ]) t -> f:(int -> 'a -> bool) -> int val iter2_exn : ('a, [> read ]) t -> ('b, [> read ]) t -> f:('a -> 'b -> unit) -> unit val map2_exn : ('a, [> read ]) t -> ('b, [> read ]) t -> f:('a -> 'b -> 'c) -> ('c, [< _ perms ]) t val fold2_exn : ('a, [> read ]) t -> ('b, [> read ]) t -> init:'c -> f:('c -> 'a -> 'b -> 'c) -> 'c val for_all2_exn : ('a, [> read ]) t -> ('b, [> read ]) t -> f:('a -> 'b -> bool) -> bool val exists2_exn : ('a, [> read ]) t -> ('b, [> read ]) t -> f:('a -> 'b -> bool) -> bool val filter : ('a, [> read ]) t -> f:('a -> bool) -> ('a, [< _ perms ]) t val filteri : ('a, [> read ]) t -> f:(int -> 'a -> bool) -> ('a, [< _ perms ]) t val swap : ('a, [> read_write ]) t -> int -> int -> unit val rev_inplace : ('a, [> read_write ]) t -> unit val of_list_rev : 'a list -> ('a, [< _ perms ]) t val of_list_map : 'a list -> f:('a -> 'b) -> ('b, [< _ perms ]) t val of_list_mapi : 'a list -> f:(int -> 'a -> 'b) -> ('b, [< _ perms ]) t val of_list_rev_map : 'a list -> f:('a -> 'b) -> ('b, [< _ perms ]) t val of_list_rev_mapi : 'a list -> f:(int -> 'a -> 'b) -> ('b, [< _ perms ]) t val map_inplace : ('a, [> read_write ]) t -> f:('a -> 'a) -> unit val find_exn : ('a, [> read ]) t -> f:('a -> bool) -> 'a val find_map_exn : ('a, [> read ]) t -> f:('a -> 'b option) -> 'b val findi : ('a, [> read ]) t -> f:(int -> 'a -> bool) -> (int * 'a) option val findi_exn : ('a, [> read ]) t -> f:(int -> 'a -> bool) -> int * 'a val find_mapi : ('a, [> read ]) t -> f:(int -> 'a -> 'b option) -> 'b option val find_mapi_exn : ('a, [> read ]) t -> f:(int -> 'a -> 'b option) -> 'b val find_consecutive_duplicate : ('a, [> read ]) t -> equal:('a -> 'a -> bool) -> ('a * 'a) option val reduce : ('a, [> read ]) t -> f:('a -> 'a -> 'a) -> 'a option val reduce_exn : ('a, [> read ]) t -> f:('a -> 'a -> 'a) -> 'a val permute : ?random_state:Random.State.t -> ?pos:int -> ?len:int -> ('a, [> read_write ]) t -> unit val zip : ('a, [> read ]) t -> ('b, [> read ]) t -> ('a * 'b, [< _ perms ]) t option val zip_exn : ('a, [> read ]) t -> ('b, [> read ]) t -> ('a * 'b, [< _ perms ]) t val unzip : ('a * 'b, [> read ]) t -> ('a, [< _ perms ]) t * ('b, [< _ perms ]) t val sorted_copy : ('a, [> read ]) t -> compare:('a -> 'a -> int) -> ('a, [< _ perms ]) t val last : ('a, [> read ]) t -> 'a val equal : ('a -> 'a -> bool) -> ('a, [> read ]) t -> ('a, [> read ]) t -> bool val to_sequence : ('a, [> read ]) t -> 'a Sequence.t val to_sequence_mutable : ('a, [> read ]) t -> 'a Sequence.t end core-0.15.0/core/src/array_stubs.c000066400000000000000000000020151420273305200167420ustar00rootroot00000000000000#include #include #include #include #include CAMLprim value core_array_unsafe_int_blit(value src, value src_pos, value dst, value dst_pos, value len) { /* On 32bit boxes ocaml values are 32bits long. On 64bit boxes OCaml values are 64bits long. The value type will change its size accordingly and hence the following macro works. */ memmove(&Field(dst, Long_val(dst_pos)), &Field(src, Long_val(src_pos)), Long_val(len) * sizeof(value)); return Val_unit; } CAMLprim value core_array_unsafe_float_blit(value src, value src_pos, value dst, value dst_pos, value len) { /* On both 32bit and 64bit boxes, floats are 64bits long and type casting the pointer to double achieves this. */ memmove((double *)dst + Long_val(dst_pos), (double *)src + Long_val(src_pos), Long_val(len) * sizeof(double)); return Val_unit; } core-0.15.0/core/src/bag.ml000066400000000000000000000006211420273305200153240ustar00rootroot00000000000000open! Import include Bag_intf include (Doubly_linked : Doubly_linked.S) let add = insert_first let add_unit t v = add t v |> (ignore : _ Elt.t -> unit) let elts t = fold_elt t ~init:[] ~f:(fun acc elt -> elt :: acc) let remove_one = remove_first let choose = first_elt let until_empty t f = let rec loop () = Option.iter (remove_one t) ~f:(fun v -> f v; loop ()) in loop () ;; core-0.15.0/core/src/bag.mli000066400000000000000000000000441420273305200154740ustar00rootroot00000000000000include Bag_intf.Bag (** @inline *) core-0.15.0/core/src/bag_intf.ml000066400000000000000000000064461420273305200163570ustar00rootroot00000000000000(** Imperative set-like data structure. There are a few differences from simple sets: - Duplicates are allowed. - It doesn't require anything (hashable, comparable) of elements in the bag. - Addition and removal are constant time operations. It is an error to modify a bag ([add], [remove], [remove_one], ...) during iteration ([fold], [iter], ...). *) open! Import module type S = sig module Elt : sig type 'a t val equal : 'a t -> 'a t -> bool val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t val value : 'a t -> 'a end type 'a t [@@deriving sexp] (** Much of a bag's interface comes from the generic {!Base.Container} module. *) include Container.S1 with type 'a t := 'a t include Invariant.S1 with type 'a t := 'a t (** [create ()] returns an empty bag. *) val create : unit -> 'a t (** [add t v] adds [v] to the bag [t], returning an element that can later be removed from the bag. [add] runs in constant time. *) val add : 'a t -> 'a -> 'a Elt.t val add_unit : 'a t -> 'a -> unit (** [mem_elt t elt] returns whether or not [elt] is in [t]. It is like [mem] (included from [Container]), but it takes an ['a Elt.t] instead of an ['a] and runs in constant time instead of linear time. *) val mem_elt : 'a t -> 'a Elt.t -> bool (** [remove t elt] removes [elt] from the bag [t], raising an exception if [elt] is not in the bag. [remove] runs in constant time. *) val remove : 'a t -> 'a Elt.t -> unit (** [choose t] returns some element in the bag. *) val choose : 'a t -> 'a Elt.t option (** [remove_one t] removes some element from the bag, and returns its value. [remove_one] runs in constant time. *) val remove_one : 'a t -> 'a option (** [clear t] removes all elements from the bag. [clear] runs in constant time. *) val clear : 'a t -> unit (** [filter_inplace t ~f] removes all the elements from [t] that don't satisfy [f]. *) val filter_inplace : 'a t -> f:('a -> bool) -> unit (** [iter_elt t ~f] calls [f] on each element of the bag. *) val iter_elt : 'a t -> f:('a Elt.t -> unit) -> unit (** [find_elt t ~f] returns the first element in the bag satisfying [f], returning [None] if none is found. *) val find_elt : 'a t -> f:('a -> bool) -> 'a Elt.t option (** [until_empty t f] repeatedly removes values [v] from [t], running [f v] on each one, until [t] is empty. Running [f] may add elements to [t] if it wants. *) val until_empty : 'a t -> ('a -> unit) -> unit (** [transfer ~src ~dst] moves all of the elements from [src] to [dst] in constant time. *) val transfer : src:'a t -> dst:'a t -> unit val of_list : 'a list -> 'a t val elts : 'a t -> 'a Elt.t list (** [unchecked_iter t ~f] behaves like [iter t ~f] except that [f] is allowed to modify [t]. Elements added by [f] may or may not be visited; elements removed by [f] that have not been visited will not be visited. It is an (undetected) error to delete the current element. *) val unchecked_iter : 'a t -> f:('a -> unit) -> unit end module type Bag = sig (** The module type of the Bag module. Example usage: {[ module My_bag : Bag.S = Bag ]} Now [My_bag.Elt.t] can't be used with any other [Bag.t] type. *) module type S = S include S end core-0.15.0/core/src/bigbuffer.ml000066400000000000000000000157331420273305200165400ustar00rootroot00000000000000(* Some code taken from INRIA's buffer module. *) open! Import open Bigstring include Bigbuffer_internal let __internal (t : t) = t let length t = t.pos (* {[ let invariant t = assert (t.len == Bigstring.length t.bstr) ]} *) let create n = let n = max 1 n in let bstr = Bigstring.create n in { bstr; pos = 0; len = n; init = bstr } ;; let contents buf = Bigstring.to_string buf.bstr ~len:buf.pos let contents_bytes buf = Bigstring.to_bytes buf.bstr ~len:buf.pos let big_contents buf = subo ~len:buf.pos buf.bstr let volatile_contents buf = buf.bstr let add_char buf c = let pos = buf.pos in if pos >= buf.len then resize buf 1; buf.bstr.{pos} <- c; buf.pos <- pos + 1 ;; module To_bytes = Test_blit.Make_distinct_and_test (struct type t = char let equal = Char.equal let of_bool b = if b then 'a' else 'b' end) (struct type nonrec t = t [@@deriving sexp_of] let create ~len = let t = create len in for _ = 1 to len do add_char t 'a' done; t ;; let length = length let set t i c = Bigstring.set t.bstr i c let get t i = Bigstring.get t.bstr i end) (struct include Bytes let create ~len = create len let unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len = Bigstring.To_bytes.unsafe_blit ~src:src.bstr ~src_pos ~dst ~dst_pos ~len ;; end) include To_bytes module To_string = Blit.Make_to_string (Bigbuffer_internal) (To_bytes) let nth buf pos = if pos < 0 || pos >= buf.pos then invalid_arg "Bigbuffer.nth" else buf.bstr.{pos} ;; let clear buf = buf.pos <- 0 let reset buf = buf.pos <- 0; buf.bstr <- buf.init; buf.len <- Bigstring.length buf.bstr ;; let add_substring buf src ~pos:src_pos ~len = if src_pos < 0 || len < 0 || src_pos > String.length src - len then invalid_arg "Bigbuffer.add_substring"; let new_pos = buf.pos + len in if new_pos > buf.len then resize buf len; Bigstring.From_string.blit ~src ~src_pos ~len ~dst:buf.bstr ~dst_pos:buf.pos; buf.pos <- new_pos ;; let add_subbytes buf src ~pos:src_pos ~len = if src_pos < 0 || len < 0 || src_pos > Bytes.length src - len then invalid_arg "Bigbuffer.add_subbytes"; let new_pos = buf.pos + len in if new_pos > buf.len then resize buf len; Bigstring.From_bytes.blit ~src ~src_pos ~len ~dst:buf.bstr ~dst_pos:buf.pos; buf.pos <- new_pos ;; let add_bigstring buf src = let len = Bigstring.length src in let new_pos = buf.pos + len in if new_pos > buf.len then resize buf len; Bigstring.blito ~src ~src_len:len ~dst:buf.bstr ~dst_pos:buf.pos (); buf.pos <- new_pos ;; let add_string buf src = let len = String.length src in let new_pos = buf.pos + len in if new_pos > buf.len then resize buf len; Bigstring.From_string.blito ~src ~src_len:len ~dst:buf.bstr ~dst_pos:buf.pos (); buf.pos <- new_pos ;; let add_bytes buf src = let len = Bytes.length src in let new_pos = buf.pos + len in if new_pos > buf.len then resize buf len; Bigstring.From_bytes.blito ~src ~src_len:len ~dst:buf.bstr ~dst_pos:buf.pos (); buf.pos <- new_pos ;; let add_buffer buf_dst buf_src = let len = buf_src.pos in let dst_pos = buf_dst.pos in let new_pos = dst_pos + len in if new_pos > buf_dst.len then resize buf_dst len; Bigstring.blito ~src:buf_src.bstr ~src_len:len ~dst:buf_dst.bstr ~dst_pos (); buf_dst.pos <- new_pos ;; let add_bin_prot t (writer : _ Bin_prot.Type_class.writer) x = let new_pos = match writer.write t.bstr ~pos:t.pos x with | pos -> pos | exception _ -> (* It's likeky that the exception is due to a buffer overflow, so resize the internal buffer and try again. Technically we could match on [Bin_prot.Common.Buffer_short] only, however we can't easily enforce that custom bin_write_xxx functions do raise this particular exception and not [Invalid_argument] or [Failure] for instance. *) let size = writer.size x in if t.pos + size > t.len then resize t size; writer.write t.bstr ~pos:t.pos x in t.pos <- new_pos ;; let closing = function | '(' -> ')' | '{' -> '}' | _ -> assert false ;; (* opening and closing: open and close characters, typically ( and ) k: balance of opening and closing chars s: the string where we are searching start: the index where we start the search. *) let advance_to_closing opening closing k s start = let rec advance k i lim = if i >= lim then raise (Not_found_s [%message "Bigbuffer.add_substitute: cannot find closing delimiter" (opening : char) (closing : char) (start : int) s]) else if Char.equal s.[i] opening then advance (k + 1) (i + 1) lim else if Char.equal s.[i] closing then if k = 0 then i else advance (k - 1) (i + 1) lim else advance k (i + 1) lim in advance k start (String.length s) ;; let advance_to_non_alpha s start = let rec advance i lim = if i >= lim then lim else ( match s.[i] with | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | 'é' | 'à' | 'á' | 'è' | 'ù' | 'â' | 'ê' | 'î' | 'ô' | 'û' | 'ë' | 'ï' | 'ü' | 'ç' | 'É' | 'À' | 'Á' | 'È' | 'Ù' | 'Â' | 'Ê' | 'Î' | 'Ô' | 'Û' | 'Ë' | 'Ï' | 'Ü' | 'Ç' -> advance (i + 1) lim | _ -> i) in advance start (String.length s) ;; (* We are just at the beginning of an ident in s, starting at start. *) let find_ident s start = match s.[start] with (* Parenthesized ident ? *) | ('(' | '{') as c -> let new_start = start + 1 in let stop = advance_to_closing c (closing c) 0 s new_start in String.sub s ~pos:new_start ~len:(stop - start - 1), stop + 1 (* Regular ident *) | _ -> let stop = advance_to_non_alpha s (start + 1) in String.sub s ~pos:start ~len:(stop - start), stop ;; (* Substitute $ident, $(ident), or ${ident} in s, according to the function mapping f. *) let add_substitute buf f s = let lim = String.length s in let rec subst previous i = if i < lim then ( match s.[i] with | '$' as current when Char.equal previous '\\' -> add_char buf current; subst current (i + 1) | '$' -> let ident, next_i = find_ident s (i + 1) in add_string buf (f ident); subst ' ' next_i | current when Char.equal previous '\\' -> add_char buf '\\'; add_char buf current; subst current (i + 1) | '\\' as current -> subst current (i + 1) | current -> add_char buf current; subst current (i + 1)) in subst ' ' 0 ;; module Format = struct let formatter_of_buffer buf = Format.make_formatter (fun s pos len -> add_substring buf s ~pos ~len) ignore ;; let bprintf buf = Format.kfprintf ignore (formatter_of_buffer buf) end module Printf = struct let bprintf buf = Printf.ksprintf (add_string buf) end core-0.15.0/core/src/bigbuffer.mli000066400000000000000000000046651420273305200167130ustar00rootroot00000000000000(** Extensible string buffers based on Bigstrings. 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). This implementation uses Bigstrings instead of strings. This removes the 16MB limit on buffer size (on 32-bit machines), and improves I/O-performance when reading/writing from/to channels. *) open! Import include Base.Buffer.S (** Return a copy of the current contents of the buffer as a bigstring. The buffer itself is unchanged. *) val big_contents : t -> Bigstring.t (** Return the actual underlying bigstring used by this bigbuffer. No copying is involved. To be safe, use and finish with the returned value before calling any other function in this module on the same [Bigbuffer.t]. *) val volatile_contents : t -> Bigstring.t (** [add_bigstring b s] appends the bigstring [s] at the end of the buffer [b]. *) val add_bigstring : t -> Bigstring.t -> unit (** [add_bin_prot b writer x] appends the bin-protted representation of [x] at the end of the buffer [b]. *) val add_bin_prot : t -> 'a Bin_prot.Type_class.writer -> 'a -> 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 [Caml.Not_found] or [Not_found_s] if the closing character of a parenthesized variable cannot be found. *) val add_substitute : t -> (string -> string) -> string -> unit (** *) module Format : sig open Format val formatter_of_buffer : t -> formatter val bprintf : t -> ('a, formatter, unit) format -> 'a end module Printf : sig val bprintf : t -> ('a, unit, string, unit) format4 -> 'a end (**/**) (** For Core.Bigbuffer, not for users! *) val __internal : t -> Bigbuffer_internal.t core-0.15.0/core/src/bigbuffer_internal.ml000066400000000000000000000006151420273305200204250ustar00rootroot00000000000000open! Import type t = { mutable bstr : Bigstring.t ; mutable pos : int ; mutable len : int ; init : Bigstring.t } [@@deriving sexp_of] let resize buf more = let min_len = buf.len + more in let new_len = min_len + min_len in let new_buf = Bigstring.create new_len in Bigstring.blito ~src:buf.bstr ~src_len:buf.pos ~dst:new_buf (); buf.bstr <- new_buf; buf.len <- new_len ;; core-0.15.0/core/src/bigbuffer_internal.mli000066400000000000000000000002611420273305200205730ustar00rootroot00000000000000open! Import type t = { mutable bstr : Bigstring.t ; mutable pos : int ; mutable len : int ; init : Bigstring.t } [@@deriving sexp_of] val resize : t -> int -> unit core-0.15.0/core/src/bigstring.ml000066400000000000000000000127151420273305200165720ustar00rootroot00000000000000open! Import open Std_internal open Bigarray module Stable = struct module V1 = struct include Base_bigstring module Z : sig type t = (char, int8_unsigned_elt, c_layout) Array1.t [@@deriving bin_io] end = struct type t = bigstring [@@deriving bin_io] end include Z type t_frozen = t [@@deriving bin_io] end end module T = Stable.V1 include T module Unstable = T let create ?max_mem_waiting_gc size = let max_mem_waiting_gc_in_bytes = Option.map max_mem_waiting_gc ~f:Byte_units0.bytes_int_exn in create ?max_mem_waiting_gc_in_bytes size ;; let sub_shared ?(pos = 0) ?len (bstr : t) = let len = get_opt_len bstr ~pos len in Array1.sub bstr pos len ;; (* Destruction *) external unsafe_destroy : t -> unit = "bigstring_destroy_stub" external unsafe_destroy_and_resize : t -> len:int -> t = "bigstring_realloc" (* Reading / writing bin-prot *) let read_bin_prot_verbose_errors t ?(pos = 0) ?len reader = let len = get_opt_len t len ~pos in let limit = pos + len in check_args ~loc:"read_bin_prot_verbose_errors" t ~pos ~len; let invalid_data message a sexp_of_a = `Invalid_data (Error.create message a sexp_of_a) in let read bin_reader ~pos ~len = if len > limit - pos then `Not_enough_data else ( let pos_ref = ref pos in match try `Ok (bin_reader t ~pos_ref) with | exn -> `Invalid_data (Error.of_exn exn) with | `Invalid_data _ as x -> x | `Ok result -> let expected_pos = pos + len in if !pos_ref = expected_pos then `Ok (result, expected_pos) else invalid_data "pos_ref <> expected_pos" (!pos_ref, expected_pos) [%sexp_of: int * int]) in match read Bin_prot.Utils.bin_read_size_header ~pos ~len:Bin_prot.Utils.size_header_length with | (`Not_enough_data | `Invalid_data _) as x -> x | `Ok (element_length, pos) -> if element_length < 0 then invalid_data "negative element length %d" element_length [%sexp_of: int] else read reader.Bin_prot.Type_class.read ~pos ~len:element_length ;; let read_bin_prot t ?pos ?len reader = match read_bin_prot_verbose_errors t ?pos ?len reader with | `Ok x -> Ok x | `Invalid_data e -> Error (Error.tag e ~tag:"Invalid data") | `Not_enough_data -> Or_error.error_string "not enough data" ;; let write_bin_prot t ?(pos = 0) writer v = let data_len = writer.Bin_prot.Type_class.size v in let total_len = data_len + Bin_prot.Utils.size_header_length in if pos < 0 then failwiths ~here:[%here] "Bigstring.write_bin_prot: negative pos" pos [%sexp_of: int]; if pos + total_len > length t then failwiths ~here:[%here] "Bigstring.write_bin_prot: not enough room" (`pos pos, `pos_after_writing (pos + total_len), `bigstring_length (length t)) [%sexp_of: [ `pos of int ] * [ `pos_after_writing of int ] * [ `bigstring_length of int ]]; let pos_after_size_header = Bin_prot.Utils.bin_write_size_header t ~pos data_len in let pos_after_data = writer.Bin_prot.Type_class.write t ~pos:pos_after_size_header v in if pos_after_data - pos <> total_len then failwiths ~here:[%here] "Bigstring.write_bin_prot bug!" ( `pos_after_data pos_after_data , `start_pos pos , `bin_prot_size_header_length Bin_prot.Utils.size_header_length , `data_len data_len , `total_len total_len ) [%sexp_of: [ `pos_after_data of int ] * [ `start_pos of int ] * [ `bin_prot_size_header_length of int ] * [ `data_len of int ] * [ `total_len of int ]]; pos_after_data ;; (* Hex dump *) include Hexdump.Of_indexable (struct type nonrec t = t let length = length let get = get end) let rec last_nonmatch_plus_one ~buf ~min_pos ~pos ~char = let pos' = pos - 1 in if pos' >= min_pos && Char.( = ) (get buf pos') char then last_nonmatch_plus_one ~buf ~min_pos ~pos:pos' ~char else pos ;; let get_tail_padded_fixed_string ~padding t ~pos ~len () = let data_end = last_nonmatch_plus_one ~buf:t ~min_pos:pos ~pos:(pos + len) ~char:padding in to_string t ~pos ~len:(data_end - pos) ;; let set_tail_padded_fixed_string ~padding t ~pos ~len value = let slen = String.length value in if slen > len then Printf.failwithf "Bigstring.set_tail_padded_fixed_string: %S is longer than %d" value len (); From_string.blit ~src:value ~dst:t ~src_pos:0 ~dst_pos:pos ~len:slen; for i = pos + slen to pos + len - 1 do set t i padding done ;; let rec first_nonmatch ~buf ~pos ~max_pos ~char = if pos <= max_pos && Char.( = ) (get buf pos) char then first_nonmatch ~buf ~pos:(Int.succ pos) ~max_pos ~char else pos ;; let set_head_padded_fixed_string ~padding t ~pos ~len value = let slen = String.length value in if slen > len then Printf.failwithf "Bigstring.set_head_padded_fixed_string: %S is longer than %d" value len (); From_string.blit ~src:value ~dst:t ~src_pos:0 ~dst_pos:(pos + len - slen) ~len:slen; for i = pos to pos + len - slen - 1 do set t i padding done ;; let get_head_padded_fixed_string ~padding t ~pos ~len () = let data_begin = first_nonmatch ~buf:t ~pos ~max_pos:(pos + len - 1) ~char:padding in to_string t ~pos:data_begin ~len:(len - (data_begin - pos)) ;; let quickcheck_generator = Base_quickcheck.Generator.bigstring let quickcheck_observer = Base_quickcheck.Observer.bigstring let quickcheck_shrinker = Base_quickcheck.Shrinker.bigstring core-0.15.0/core/src/bigstring.mli000066400000000000000000000121021420273305200167310ustar00rootroot00000000000000(** String type based on [Bigarray], for use in I/O and C-bindings. *) open! Import open Bigarray (** {2 Types and exceptions} *) (** Type of bigstrings *) type t = (char, int8_unsigned_elt, c_layout) Array1.t [@@deriving compare, quickcheck, sexp_of] (** Type of bigstrings which support hashing. Note that mutation invalidates previous hashes. *) type t_frozen = t [@@deriving compare, hash, sexp_of] include module type of Base_bigstring with type t := t and type t_frozen := t_frozen include Hexdump.S with type t := t (** {2 Creation and string conversion} *) (** [create length] @param max_mem_waiting_gc default = 256 M in OCaml <= 3.12, 1 G otherwise. As the total allocation of calls to [create] approach [max_mem_waiting_gc], the pressure in the garbage collector to be more agressive will increase. @return a new bigstring having [length]. Content is undefined. *) val create : ?max_mem_waiting_gc:Byte_units0.t -> int -> t (** [sub_shared ?pos ?len bstr] @return the sub-bigstring in [bstr] that starts at position [pos] and has length [len]. The sub-bigstring shares the same memory region, i.e. modifying it will modify the original bigstring. Holding on to the sub-bigstring will also keep the (usually bigger) original one around. @param pos default = 0 @param len default = [Bigstring.length bstr - pos] *) val sub_shared : ?pos:int -> ?len:int -> t -> t (** {2 Reading/writing bin-prot} *) (** These functions write the "size-prefixed" bin-prot format that is used by, e.g., async's [Writer.write_bin_prot], [Reader.read_bin_prot] and [Unpack_buffer.Unpack_one.create_bin_prot]. *) (** [write_bin_prot t writer a] writes [a] to [t] starting at [pos], and returns the index in [t] immediately after the last byte written. It raises if [pos < 0] or if [a] doesn't fit in [t]. *) val write_bin_prot : t -> ?pos:int (** default is 0 *) -> 'a Bin_prot.Type_class.writer -> 'a -> int (** The [read_bin_prot*] functions read from the region of [t] starting at [pos] of length [len]. They return the index in [t] immediately after the last byte read. They raise if [pos] and [len] don't describe a region of [t]. *) val read_bin_prot : t -> ?pos:int -> ?len:int -> 'a Bin_prot.Type_class.reader -> ('a * int) Or_error.t val read_bin_prot_verbose_errors : t -> ?pos:int -> ?len:int -> 'a Bin_prot.Type_class.reader -> [ `Invalid_data of Error.t | `Not_enough_data | `Ok of 'a * int ] (** {2 Destruction} *) (** [unsafe_destroy bstr] destroys the bigstring by deallocating its associated data or, if memory-mapped, unmapping the corresponding file, and setting all dimensions to zero. This effectively frees the associated memory or address-space resources instantaneously. This feature helps working around a bug in the current OCaml runtime, which does not correctly estimate how aggressively to reclaim such resources. This operation is safe unless you have passed the bigstring to another thread that is performing operations on it at the same time. Access to the bigstring after this operation will yield array bounds exceptions. @raise Failure if the bigstring has already been deallocated (or deemed "external", which is treated equivalently), or if it has proxies, i.e. other bigstrings referring to the same data. *) external unsafe_destroy : t -> unit = "bigstring_destroy_stub" (** [unsafe_destroy_and_resize bstr ~len] reallocates the memory backing [bstr] and returns a new bigstring that starts at position 0 and has length [len]. If [len] is greater than [length bstr] then the newly allocated memory will not be initialized. Similar to [unsafe_destroy], this operation is safe unless you have passed the bigstring to another thread that is performing operations on it at the same time. Access to [bstr] after this operation will yield array bounds exceptions. @raise Failure if the bigstring has already been deallocated (or deemed "external", which is treated equivalently), if it is backed by a memory map, or if it has proxies, i.e. other bigstrings referring to the same data. *) external unsafe_destroy_and_resize : t -> len:int -> t = "bigstring_realloc" (** Similar to [Binary_packing.unpack_tail_padded_fixed_string] and [.pack_tail_padded_fixed_string]. *) val get_tail_padded_fixed_string : padding:char -> t -> pos:int -> len:int -> unit -> string val set_tail_padded_fixed_string : padding:char -> t -> pos:int -> len:int -> string -> unit val get_head_padded_fixed_string : padding:char -> t -> pos:int -> len:int -> unit -> string val set_head_padded_fixed_string : padding:char -> t -> pos:int -> len:int -> string -> unit module Unstable : sig type nonrec t = t [@@deriving bin_io, compare, sexp_of] type nonrec t_frozen = t_frozen [@@deriving bin_io, compare, hash, sexp_of] end module Stable : sig module V1 : sig type nonrec t = t [@@deriving bin_io, compare, sexp] type nonrec t_frozen = t_frozen [@@deriving bin_io, compare, hash, sexp] end end core-0.15.0/core/src/bigstring_stubs.c000066400000000000000000000076751420273305200176350ustar00rootroot00000000000000#define _FILE_OFFSET_BITS 64 #define _GNU_SOURCE /* recvmmsg */ /* For pread/pwrite */ #define _XOPEN_SOURCE 500 /* For OpenBSD `swap` functions */ #ifdef __OpenBSD__ #define _BSD_SOURCE #endif #include #include #include #include #include #ifdef __APPLE__ #include #define bswap_16 OSSwapInt16 #define bswap_32 OSSwapInt32 #define bswap_64 OSSwapInt64 #elif __GLIBC__ #include #include #elif __OpenBSD__ #include #define bswap_16 swap16 #define bswap_32 swap32 #define bswap_64 swap64 #elif __CYGWIN__ #include #else #include #if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__) #include #else #include #endif #define __BYTE_ORDER _BYTE_ORDER #define __LITTLE_ENDIAN _LITTLE_ENDIAN #define __BIG_ENDIAN _BIG_ENDIAN #define bswap_16 bswap16 #define bswap_32 bswap32 #define bswap_64 bswap64 #endif #include #include #include #include #include #include #include #include "core_bigstring.h" #include "internalhash.h" /* Bytes_val is only available from 4.06 */ #ifndef Bytes_val #define Bytes_val String_val #endif CAMLprim value bigstring_realloc (value v_bstr, value v_size) { CAMLparam2(v_bstr, v_size); CAMLlocal1(v_bstr2); struct caml_ba_array *ba = Caml_ba_array_val(v_bstr); intnat size = Long_val(v_size); int i; struct caml_ba_array *ba2; void *data; switch (ba->flags & CAML_BA_MANAGED_MASK) { case CAML_BA_EXTERNAL : caml_failwith("bigstring_realloc: bigstring is external or deallocated"); break; case CAML_BA_MANAGED : if (ba->proxy != NULL) caml_failwith("bigstring_realloc: bigstring has proxy"); break; case CAML_BA_MAPPED_FILE : caml_failwith("bigstring_realloc: bigstring is backed by memory map"); break; } data = realloc(ba->data, sizeof(char) * size); /* realloc is equivalent to free when size is equal to zero, and may return NULL. */ if (NULL == data && size != 0) caml_raise_out_of_memory (); v_bstr2 = caml_ba_alloc(ba->flags, ba->num_dims, data, ba->dim); ba2 = Caml_ba_array_val(v_bstr2); ba2->dim[0] = size; /* ba is a pointer into the OCaml heap, hence may have been invalidated by the * call to [caml_ba_alloc]. */ ba = Caml_ba_array_val(v_bstr); ba->data = NULL; ba->flags = CAML_BA_EXTERNAL; for (i = 0; i < ba->num_dims; ++i) ba->dim[i] = 0; CAMLreturn(v_bstr2); } /* Destruction */ static void check_bigstring_proxy(struct caml_ba_array *b) { if (b->proxy != NULL) caml_failwith("bigstring_destroy: bigstring has proxy"); } void core_bigstring_destroy(value v, int flags) { int i; struct caml_ba_array *b = Caml_ba_array_val(v); struct custom_operations* ops = Custom_ops_val(v); switch (b->flags & CAML_BA_MANAGED_MASK) { case CAML_BA_EXTERNAL : if ((flags & CORE_BIGSTRING_DESTROY_ALLOW_EXTERNAL) != CORE_BIGSTRING_DESTROY_ALLOW_EXTERNAL) caml_failwith("bigstring_destroy: bigstring is external or already deallocated"); break; case CAML_BA_MANAGED : check_bigstring_proxy(b); free(b->data); break; case CAML_BA_MAPPED_FILE : check_bigstring_proxy(b); /* This call to finalize is actually a call to caml_ba_mapped_finalize (the finalize function for *mapped* bigarrays), which will unmap the array. (note: this is compatible with OCaml 4.06+) */ if ((flags & CORE_BIGSTRING_DESTROY_DO_NOT_UNMAP) != CORE_BIGSTRING_DESTROY_DO_NOT_UNMAP) { if (ops->finalize != NULL) { ops->finalize(v); } } break; } b->data = NULL; b->flags = CAML_BA_EXTERNAL; for (i = 0; i < b->num_dims; ++i) b->dim[i] = 0; } CAMLprim value bigstring_destroy_stub(value v_bstr) { core_bigstring_destroy(v_bstr, 0); return Val_unit; } core-0.15.0/core/src/bigsubstring.ml000066400000000000000000000010511420273305200172730ustar00rootroot00000000000000open! Import include Make_substring.F (struct type t = Bigstring.t [@@deriving quickcheck] let create = Bigstring.create ?max_mem_waiting_gc:None let length = Bigstring.length let get = Bigstring.get module Blit = Make_substring.Blit let blit = Blit.bigstring_bigstring let blit_to_string = Blit.bigstring_bytes let blit_to_bytes = Blit.bigstring_bytes let blit_to_bigstring = Blit.bigstring_bigstring let blit_from_string = Blit.string_bigstring let blit_from_bigstring = Blit.bigstring_bigstring end) core-0.15.0/core/src/bigsubstring.mli000066400000000000000000000002351420273305200174470ustar00rootroot00000000000000(** Substring type based on [Bigarray], for use in I/O and C-bindings *) open! Import include Make_substring.S with type base = Bigstring.t (** @inline *) core-0.15.0/core/src/binable.ml000066400000000000000000000012311420273305200161650ustar00rootroot00000000000000open! Import include Binable_intf include Binable0 (* [of_string] and [to_string] can't go in binable0.ml due to a cyclic dependency. *) let of_string m string = of_bigstring m (Bigstring.of_string string) let to_string m t = Bigstring.to_string (to_bigstring m t) module Of_binable = Of_binable_without_uuid [@@alert "-legacy"] module Of_binable1 = Of_binable1_without_uuid [@@alert "-legacy"] module Of_binable2 = Of_binable2_without_uuid [@@alert "-legacy"] module Of_binable3 = Of_binable3_without_uuid [@@alert "-legacy"] module Of_sexpable = Of_sexpable_without_uuid [@@alert "-legacy"] module Of_stringable = Of_stringable_without_uuid [@@alert "-legacy"] core-0.15.0/core/src/binable.mli000066400000000000000000000000351420273305200163370ustar00rootroot00000000000000include Binable_intf.Binable core-0.15.0/core/src/binable0.ml000066400000000000000000000150211420273305200162470ustar00rootroot00000000000000open! Import include Binable_intf include Bin_prot.Binable module Shape = Bin_prot.Shape module Stable = struct module Of_binable = struct module V1 (Binable : Minimal.S) (M : Conv_without_uuid with type binable := Binable.t) : S with type t := M.t = Bin_prot.Utils.Make_binable_without_uuid (struct module Binable = Binable include M end) [@@alert "-legacy"] module V2 (Binable : Minimal.S) (M : Conv with type binable := Binable.t) : S with type t := M.t = Bin_prot.Utils.Make_binable_with_uuid (struct module Binable = Binable include M end) end module Of_binable1 = struct module V1 (Binable : Minimal.S1) (M : Conv1_without_uuid with type 'a binable := 'a Binable.t) : S1 with type 'a t := 'a M.t = Bin_prot.Utils.Make_binable1_without_uuid (struct module Binable = Binable include M end) [@@alert "-legacy"] module V2 (Binable : Minimal.S1) (M : Conv1 with type 'a binable := 'a Binable.t) : S1 with type 'a t := 'a M.t = Bin_prot.Utils.Make_binable1_with_uuid (struct module Binable = Binable include M end) end module Of_binable2 = struct module V1 (Binable : Minimal.S2) (M : Conv2_without_uuid with type ('a, 'b) binable := ('a, 'b) Binable.t) : S2 with type ('a, 'b) t := ('a, 'b) M.t = Bin_prot.Utils.Make_binable2_without_uuid (struct module Binable = Binable include M end) [@@alert "-legacy"] module V2 (Binable : Minimal.S2) (M : Conv2 with type ('a, 'b) binable := ('a, 'b) Binable.t) : S2 with type ('a, 'b) t := ('a, 'b) M.t = Bin_prot.Utils.Make_binable2_with_uuid (struct module Binable = Binable include M end) end module Of_binable3 = struct module V1 (Binable : Minimal.S3) (M : Conv3_without_uuid with type ('a, 'b, 'c) binable := ('a, 'b, 'c) Binable.t) : S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) M.t = Bin_prot.Utils.Make_binable3_without_uuid (struct module Binable = Binable include M end) [@@alert "-legacy"] module V2 (Binable : Minimal.S3) (M : Conv3 with type ('a, 'b, 'c) binable := ('a, 'b, 'c) Binable.t) : S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) M.t = Bin_prot.Utils.Make_binable3_with_uuid (struct module Binable = Binable include M end) end module Of_sexpable = struct module V1 (M : Sexpable.S) = Of_binable.V1 (struct type t = Base.Sexp.t = | Atom of string | List of t list [@@deriving bin_io] end) (struct type t = M.t let to_binable = M.sexp_of_t let of_binable = M.t_of_sexp end) module V2 (M : Conv_sexpable) = Of_binable.V2 (struct type t = Base.Sexp.t = | Atom of string | List of t list [@@deriving bin_io] end) (struct type t = M.t let to_binable = M.sexp_of_t let of_binable = M.t_of_sexp let caller_identity = M.caller_identity end) end module Of_stringable = struct module V1 (M : Stringable.S) = Bin_prot.Utils.Make_binable_without_uuid (struct module Binable = struct type t = string [@@deriving bin_io] end type t = M.t let to_binable = M.to_string (* Wrap exception for improved diagnostics. *) exception Of_binable of string * exn [@@deriving sexp] let of_binable s = try M.of_string s with | x -> raise (Of_binable (s, x)) ;; end) [@@alert "-legacy"] module V2 (M : Conv_stringable) = Bin_prot.Utils.Make_binable_with_uuid (struct module Binable = struct type t = string [@@deriving bin_io] end type t = M.t let to_binable = M.to_string (* Wrap exception for improved diagnostics. *) exception Of_binable of string * exn [@@deriving sexp] let of_binable s = try M.of_string s with | x -> raise (Of_binable (s, x)) ;; let caller_identity = M.caller_identity end) end end open Bigarray type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t type 'a m = (module S with type t = 'a) let of_bigstring (type a) m bigstring = let module M = (val m : S with type t = a) in let pos_ref = ref 0 in let t = M.bin_read_t bigstring ~pos_ref in let bigstring_length = Array1.dim bigstring in (match !pos_ref = bigstring_length with | true -> () | false -> raise_s [%message "bin_read_t did not consume the entire buffer" ~consumed:(!pos_ref : int) (bigstring_length : int)]); t ;; (* Using the [Bigstring] module would introduce a cyclic dependency. *) let create_bigstring size = Array1.create Bigarray.char Bigarray.c_layout size let to_bigstring ?(prefix_with_length = false) (type a) m t = let module M = (val m : S with type t = a) in let t_length = M.bin_size_t t in let bigstring_length = if prefix_with_length then t_length + 8 (* the size of a 64-bit int *) else t_length in let bigstring = create_bigstring bigstring_length in let pos = if prefix_with_length then Bin_prot.Write.bin_write_int_64bit bigstring ~pos:0 t_length else 0 in let pos = M.bin_write_t bigstring ~pos t in assert (pos = bigstring_length); bigstring ;; module Of_binable_with_uuid = Stable.Of_binable.V2 module Of_binable1_with_uuid = Stable.Of_binable1.V2 module Of_binable2_with_uuid = Stable.Of_binable2.V2 module Of_binable3_with_uuid = Stable.Of_binable3.V2 module Of_sexpable_with_uuid = Stable.Of_sexpable.V2 module Of_stringable_with_uuid = Stable.Of_stringable.V2 module Of_binable_without_uuid = Stable.Of_binable.V1 module Of_binable1_without_uuid = Stable.Of_binable1.V1 module Of_binable2_without_uuid = Stable.Of_binable2.V1 module Of_binable3_without_uuid = Stable.Of_binable3.V1 module Of_sexpable_without_uuid = Stable.Of_sexpable.V1 module Of_stringable_without_uuid = Stable.Of_stringable.V1 let%test_module _ = (module struct module type S_only_functions_and_shape = sig include S_only_functions val bin_shape_t : Shape.t end (* Check that only the functions & shape are sufficient for [@@deriving bin_io]. The fact that this functor typechecks is, itself, the test. *) module _ (X : S_only_functions_and_shape) : S = struct type t = X.t [@@deriving bin_io] end end) ;; core-0.15.0/core/src/binable0.mli000066400000000000000000000000361420273305200164200ustar00rootroot00000000000000include Binable_intf.Binable0 core-0.15.0/core/src/binable_intf.ml000066400000000000000000000204711420273305200172140ustar00rootroot00000000000000open! Import open Bin_prot.Binable open Bigarray module type Conv_without_uuid = sig type binable type t val to_binable : t -> binable val of_binable : binable -> t end module type Conv1_without_uuid = sig type 'a binable type 'a t val to_binable : 'a t -> 'a binable val of_binable : 'a binable -> 'a t end module type Conv2_without_uuid = sig type ('a, 'b) binable type ('a, 'b) t val to_binable : ('a, 'b) t -> ('a, 'b) binable val of_binable : ('a, 'b) binable -> ('a, 'b) t end module type Conv3_without_uuid = sig type ('a, 'b, 'c) binable type ('a, 'b, 'c) t val to_binable : ('a, 'b, 'c) t -> ('a, 'b, 'c) binable val of_binable : ('a, 'b, 'c) binable -> ('a, 'b, 'c) t end module type Conv = sig include Conv_without_uuid val caller_identity : Bin_prot.Shape.Uuid.t end module type Conv1 = sig include Conv1_without_uuid val caller_identity : Bin_prot.Shape.Uuid.t end module type Conv2 = sig include Conv2_without_uuid val caller_identity : Bin_prot.Shape.Uuid.t end module type Conv3 = sig include Conv3_without_uuid val caller_identity : Bin_prot.Shape.Uuid.t end module type Conv_sexpable = sig include Sexpable.S val caller_identity : Bin_prot.Shape.Uuid.t end module type Conv_stringable = sig include Stringable.S val caller_identity : Bin_prot.Shape.Uuid.t end (** Module types and utilities for dealing with types that support the bin-io binary encoding. *) module type Binable0 = sig (** We copy the definition of the bigstring type here, because we cannot depend on bigstring.ml *) type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t (** New code should use [@@deriving bin_io]. These module types ([S], [S1], and [S2]) are exported only for backwards compatibility. *) module type S = S module type S_only_functions = S_only_functions module type S1 = S1 module type S2 = S2 module type S3 = S3 module Minimal : sig module type S = Minimal.S module type S1 = Minimal.S1 module type S2 = Minimal.S2 module type S3 = Minimal.S3 end module type Conv = Conv module type Conv1 = Conv1 module type Conv2 = Conv2 module type Conv3 = Conv3 module type Conv_sexpable = Conv_sexpable module type Conv_stringable = Conv_stringable module type Conv_without_uuid = Conv_without_uuid module type Conv1_without_uuid = Conv1_without_uuid module type Conv2_without_uuid = Conv2_without_uuid module type Conv3_without_uuid = Conv3_without_uuid (** [Of_binable*] functors are for when you want the binary representation of one type to be the same as that for some other isomorphic type. *) module Of_binable_with_uuid (Binable : Minimal.S) (M : Conv with type binable := Binable.t) : S with type t := M.t module Of_binable1_with_uuid (Binable : Minimal.S1) (M : Conv1 with type 'a binable := 'a Binable.t) : S1 with type 'a t := 'a M.t module Of_binable2_with_uuid (Binable : Minimal.S2) (M : Conv2 with type ('a, 'b) binable := ('a, 'b) Binable.t) : S2 with type ('a, 'b) t := ('a, 'b) M.t module Of_binable3_with_uuid (Binable : Minimal.S3) (M : Conv3 with type ('a, 'b, 'c) binable := ('a, 'b, 'c) Binable.t) : S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) M.t module Of_binable_without_uuid (Binable : Minimal.S) (M : Conv_without_uuid with type binable := Binable.t) : S with type t := M.t [@@alert legacy "Use [Of_binable_with_uuid] if possible."] module Of_binable1_without_uuid (Binable : Minimal.S1) (M : Conv1_without_uuid with type 'a binable := 'a Binable.t) : S1 with type 'a t := 'a M.t [@@alert legacy "Use [Of_binable1_with_uuid] if possible."] module Of_binable2_without_uuid (Binable : Minimal.S2) (M : Conv2_without_uuid with type ('a, 'b) binable := ('a, 'b) Binable.t) : S2 with type ('a, 'b) t := ('a, 'b) M.t [@@alert legacy "Use [Of_binable2_with_uuid] if possible."] module Of_binable3_without_uuid (Binable : Minimal.S3) (M : Conv3_without_uuid with type ('a, 'b, 'c) binable := ('a, 'b, 'c) Binable.t) : S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) M.t [@@alert legacy "Use [Of_binable3_with_uuid] if possible."] (** [Of_sexpable_with_uuid] serializes a value using the bin-io of the sexp serialization of the value. This is not as efficient as using [@@deriving bin_io]. However, it is useful when performance isn't important and there are obstacles to using [@@deriving bin_io], e.g., some type missing [@@deriving bin_io]. [Of_sexpable_with_uuid] is also useful when one wants to be forgiving about format changes, due to the sexp serialization being more robust to changes like adding or removing a constructor. *) module Of_sexpable_with_uuid (M : Conv_sexpable) : S with type t := M.t module Of_stringable_with_uuid (M : Conv_stringable) : S with type t := M.t module Of_sexpable_without_uuid (M : Sexpable.S) : S with type t := M.t [@@alert legacy "Use [Of_sexpable_with_uuid] if possible."] module Of_stringable_without_uuid (M : Stringable.S) : S with type t := M.t [@@alert legacy "Use [Of_stringable_with_uuid] if possible."] type 'a m = (module S with type t = 'a) val of_bigstring : 'a m -> bigstring -> 'a val to_bigstring : ?prefix_with_length:bool (** defaults to false *) -> 'a m -> 'a -> bigstring (** The following functors preserve stability: if applied to stable types with stable (de)serializations, they will produce stable types with stable (de)serializations. Note: In all cases, stability of the input (and therefore the output) depends on the semantics of all conversion functions (e.g. [to_string], [to_sexpable]) not changing in the future. *) module Stable : sig module Of_binable : sig module V1 : (module type of Of_binable_without_uuid) [@alert "-legacy"] [@@alert legacy "Use [V2] instead."] module V2 : module type of Of_binable_with_uuid end module Of_binable1 : sig module V1 : (module type of Of_binable1_without_uuid) [@alert "-legacy"] [@@alert legacy "Use [V2] instead."] module V2 : module type of Of_binable1_with_uuid end module Of_binable2 : sig module V1 : (module type of Of_binable2_without_uuid) [@alert "-legacy"] [@@alert legacy "Use [V2] instead."] module V2 : module type of Of_binable2_with_uuid end module Of_binable3 : sig module V1 : (module type of Of_binable3_without_uuid) [@alert "-legacy"] [@@alert legacy "Use [V2] instead."] module V2 : module type of Of_binable3_with_uuid end module Of_sexpable : sig module V1 : (module type of Of_sexpable_without_uuid) [@alert "-legacy"] [@@alert legacy "Use [V2] instead."] module V2 : module type of Of_sexpable_with_uuid end module Of_stringable : sig module V1 : (module type of Of_stringable_without_uuid) [@alert "-legacy"] [@@alert legacy "Use [V2] instead."] module V2 : module type of Of_stringable_with_uuid end end end module type Binable = sig include Binable0 val of_string : 'a m -> string -> 'a val to_string : 'a m -> 'a -> string module Of_binable = Of_binable_without_uuid [@@alert "-legacy"] [@@deprecated "[since 2019-11] Use [Of_binable_with_uuid] if possible, otherwise use \ [Of_binable_without_uuid]."] module Of_binable1 = Of_binable1_without_uuid [@@alert "-legacy"] [@@deprecated "[since 2019-11] Use [Of_binable1_with_uuid] if possible, otherwise use \ [Of_binable1_without_uuid]."] module Of_binable2 = Of_binable2_without_uuid [@@alert "-legacy"] [@@deprecated "[since 2019-11] Use [Of_binable2_with_uuid] if possible, otherwise use \ [Of_binable2_without_uuid]."] module Of_binable3 = Of_binable3_without_uuid [@@alert "-legacy"] [@@deprecated "[since 2019-11] Use [Of_binable3_with_uuid] if possible, otherwise use \ [Of_binable3_without_uuid]."] module Of_sexpable = Of_sexpable_without_uuid [@@alert "-legacy"] [@@deprecated "[since 2019-11] Use [Of_sexpable_with_uuid] if possible, otherwise use \ [Of_sexpable_without_uuid]."] module Of_stringable = Of_stringable_without_uuid [@@alert "-legacy"] [@@deprecated "[since 2019-11] Use [Of_stringable_with_uuid] if possible, otherwise use \ [Of_stringable_without_uuid]."] end core-0.15.0/core/src/binary_searchable.ml000066400000000000000000000000761420273305200202340ustar00rootroot00000000000000include Base.Binary_searchable include Binary_searchable_intf core-0.15.0/core/src/binary_searchable.mli000066400000000000000000000002401420273305200203760ustar00rootroot00000000000000(** This module extends the {{!Base.Binary_searchable}[Base.Binary_searchable]} module. *) include Binary_searchable_intf.Binary_searchable (** @inline *) core-0.15.0/core/src/binary_searchable_intf.ml000066400000000000000000000007311420273305200212520ustar00rootroot00000000000000(** This module extends {!Base.Binary_searchable}. *) open Base.Binary_searchable module type S1_permissions = sig open Perms.Export type ('a, -'perms) t val binary_search : (('a, [> read ]) t, 'a, 'key) binary_search val binary_search_segmented : (('a, [> read ]) t, 'a) binary_search_segmented end module type Binary_searchable = sig include module type of struct include Base.Binary_searchable end module type S1_permissions = S1_permissions end core-0.15.0/core/src/blang.ml000066400000000000000000000400541420273305200156620ustar00rootroot00000000000000open! Import open Std_internal (* The module [T] serves to enforce the invariant that all Blang.t values are in a normal form whereby boolean constants True and False only appear as the topmost constructor -- in any other position they are simplified away using laws of boolean algebra. We also enforce that nested [And]s and [Or]s each lean to the right so that [eval] doesn't need so much stack space as it would if they leaned to the left. Thought experiment: compare how [eval] works on right-leaning [And (a, And (b, And (c, d)))] versus left-leaning [And (And (And (a, b), c), d)]. The former is the best case and is enforced. Note: this file deviates from the usual pattern of modules with Stable interfaces in that the Stable sub-module is not the first thing to be defined in the module. The reason for this deviation is so that one can convince oneself of the aforementioned invariant after reading only this small amount of code. After defining T we then immediately define its Stable interface. *) module T : sig type +'a t = private | True | False | And of 'a t * 'a t | Or of 'a t * 'a t | Not of 'a t | If of 'a t * 'a t * 'a t | Base of 'a [@@deriving bin_io, compare, equal, hash, typerep] val invariant : 'a t -> unit val true_ : 'a t val false_ : 'a t val not_ : 'a t -> 'a t val andalso : 'a t -> 'a t -> 'a t val orelse : 'a t -> 'a t -> 'a t val if_ : 'a t -> 'a t -> 'a t -> 'a t val base : 'a -> 'a t end = struct type +'a t = | True | False | And of 'a t * 'a t | Or of 'a t * 'a t | Not of 'a t | If of 'a t * 'a t * 'a t | Base of 'a [@@deriving bin_io, compare, equal, hash, typerep] let invariant = let subterms = function | True | False | Base _ -> [] | Not t1 -> [ t1 ] | And (t1, t2) | Or (t1, t2) -> [ t1; t2 ] | If (t1, t2, t3) -> [ t1; t2; t3 ] in let rec contains_no_constants = function | True | False -> assert false | t -> List.iter ~f:contains_no_constants (subterms t) in fun t -> List.iter ~f:contains_no_constants (subterms t) ;; let true_ = True let false_ = False let base v = Base v let not_ = function | True -> False | False -> True | Not t -> t | t -> Not t ;; let rec andalso t1 t2 = match t1, t2 with | _, False | False, _ -> False | other, True | True, other -> other | And (t1a, t1b), _ -> (* nested [And]s lean right -- see comment above *) And (t1a, andalso t1b t2) | _ -> And (t1, t2) ;; let rec orelse t1 t2 = match t1, t2 with | _, True | True, _ -> True | other, False | False, other -> other | Or (t1a, t1b), _ -> (* nested [Or]s lean right -- see comment above *) Or (t1a, orelse t1b t2) | _ -> Or (t1, t2) ;; let if_ a b c = match a with | True -> b | False -> c | _ -> (match b, c with | True, _ -> orelse a c | _, False -> andalso a b | _, True -> orelse (not_ a) b | False, _ -> andalso (not_ a) c | _ -> If (a, b, c)) ;; end module Raw = struct type 'a t = 'a T.t = private | True | False | And of 'a t * 'a t | Or of 'a t * 'a t | Not of 'a t | If of 'a t * 'a t * 'a t | Base of 'a [@@deriving sexp_of] end include T module Stable = struct module V1 : sig (* THIS TYPE AND ITS SERIALIZATIONS SHOULD NEVER BE CHANGED - PLEASE SPEAK WITH ANOTHER DEVELOPER IF YOU NEED MORE DETAIL *) type 'a t = 'a T.t = private | True | False | And of 'a t * 'a t | Or of 'a t * 'a t | Not of 'a t | If of 'a t * 'a t * 'a t | Base of 'a [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar] (* the remainder of this signature consists of functions used in the definitions of sexp conversions that are also useful more generally *) val and_ : 'a t list -> 'a t val or_ : 'a t list -> 'a t val gather_conjuncts : 'a t -> 'a t list val gather_disjuncts : 'a t -> 'a t list end = struct type 'a t = 'a T.t = private | True | False | And of 'a t * 'a t | Or of 'a t * 'a t | Not of 'a t | If of 'a t * 'a t * 'a t | Base of 'a include ( T : sig type 'a t [@@deriving bin_io, compare, equal, hash] end with type 'a t := 'a t) type sexp = Sexp.t = | Atom of string | List of sexp list (* cheap import *) (* flatten out nested and's *) let gather_conjuncts t = let rec loop acc = function | True :: ts -> loop acc ts | And (t1, t2) :: ts -> loop acc (t1 :: t2 :: ts) | t :: ts -> loop (t :: acc) ts | [] -> List.rev acc in loop [] [ t ] ;; (* flatten out nested or's *) let gather_disjuncts t = let rec loop acc = function | False :: ts -> loop acc ts | Or (t1, t2) :: ts -> loop acc (t1 :: t2 :: ts) | t :: ts -> loop (t :: acc) ts | [] -> List.rev acc in loop [] [ t ] ;; (* [and_] and [or_] use [fold_right] instead of [fold_left] to avoid quadratic behavior with [andalso] or [orelse], respectively. *) let and_ ts = List.fold_right ts ~init:true_ ~f:andalso let or_ ts = List.fold_right ts ~init:false_ ~f:orelse let unary name args sexp = match args with | [ x ] -> x | _ -> let n = List.length args in of_sexp_error (sprintf "%s expects one argument, %d found" name n) sexp ;; let ternary name args sexp = match args with | [ x; y; z ] -> x, y, z | _ -> let n = List.length args in of_sexp_error (sprintf "%s expects three arguments, %d found" name n) sexp ;; let sexp_of_t sexp_of_value t = let rec aux t = match t with | Base x -> sexp_of_value x | True -> Atom "true" | False -> Atom "false" | Not t -> List [ Atom "not"; aux t ] | If (t1, t2, t3) -> List [ Atom "if"; aux t1; aux t2; aux t3 ] | And _ as t -> let ts = gather_conjuncts t in List (Atom "and" :: List.map ~f:aux ts) | Or _ as t -> let ts = gather_disjuncts t in List (Atom "or" :: List.map ~f:aux ts) in aux t ;; let t_of_sexp base_of_sexp sexp = let base sexp = base (base_of_sexp sexp) in let rec aux sexp = match sexp with | Atom kw -> (match String.lowercase kw with | "true" -> true_ | "false" -> false_ | _ -> base sexp) | List (Atom kw :: args) -> (match String.lowercase kw with | "and" -> and_ (List.map ~f:aux args) | "or" -> or_ (List.map ~f:aux args) | "not" -> not_ (aux (unary "not" args sexp)) | "if" -> let x, y, z = ternary "if" args sexp in if_ (aux x) (aux y) (aux z) | _ -> base sexp) | _ -> base sexp in aux sexp ;; let t_sexp_grammar : 'a. 'a Sexplib.Sexp_grammar.t -> 'a t Sexplib.Sexp_grammar.t = let defns : Sexplib.Sexp_grammar.defn list = let blang : Sexplib.Sexp_grammar.grammar = Tycon ("blang", [ Tyvar "a" ]) in [ { tycon = "blang" ; tyvars = [ "a" ] ; grammar = Union [ Tyvar "a" ; Variant { case_sensitivity = Case_insensitive ; clauses = [ No_tag { name = "true"; clause_kind = Atom_clause } ; No_tag { name = "false"; clause_kind = Atom_clause } ; No_tag { name = "if" ; clause_kind = List_clause { args = Cons (blang, Cons (blang, Cons (blang, Empty))) } } ; No_tag { name = "and" ; clause_kind = List_clause { args = Many blang } } ; No_tag { name = "or" ; clause_kind = List_clause { args = Many blang } } ; No_tag { name = "not" ; clause_kind = List_clause { args = Cons (blang, Empty) } } ] } ] } ] in fun base_grammar -> { untyped = Recursive (Tycon ("blang", [ base_grammar.untyped ]), defns) } ;; end end include (Stable.V1 : module type of Stable.V1 with type 'a t := 'a t) let constant b = if b then true_ else false_ module type Constructors = sig val base : 'a -> 'a t val true_ : _ t val false_ : _ t val constant : bool -> _ t val not_ : 'a t -> 'a t val and_ : 'a t list -> 'a t val or_ : 'a t list -> 'a t val if_ : 'a t -> 'a t -> 'a t -> 'a t end module O = struct include T let not = not_ let and_ = and_ let or_ = or_ let constant = constant let ( && ) = andalso let ( || ) = orelse let ( ==> ) a b = (not a) || b end let constant_value = function | True -> Some true | False -> Some false | _ -> None ;; (* [values t] lists the base predicates in [t] from left to right *) let values t = let rec loop acc = function | Base v :: ts -> loop (v :: acc) ts | True :: ts -> loop acc ts | False :: ts -> loop acc ts | Not t1 :: ts -> loop acc (t1 :: ts) | And (t1, t2) :: ts -> loop acc (t1 :: t2 :: ts) | Or (t1, t2) :: ts -> loop acc (t1 :: t2 :: ts) | If (t1, t2, t3) :: ts -> loop acc (t1 :: t2 :: t3 :: ts) | [] -> List.rev acc in loop [] [ t ] ;; module C = Container.Make (struct type 'a t = 'a T.t let fold t ~init ~f = let rec loop acc t pending = match t with | Base a -> next (f acc a) pending | True | False -> next acc pending | Not t -> loop acc t pending | And (t1, t2) | Or (t1, t2) -> loop acc t1 (t2 :: pending) | If (t1, t2, t3) -> loop acc t1 (t2 :: t3 :: pending) and next acc = function | [] -> acc | t :: ts -> loop acc t ts in loop init t [] ;; let iter = `Define_using_fold let length = `Define_using_fold end) let count = C.count let sum = C.sum let exists = C.exists let find = C.find let find_map = C.find_map let fold = C.fold let for_all = C.for_all let is_empty = C.is_empty let iter = C.iter let length = C.length let mem = C.mem let to_array = C.to_array let to_list = C.to_list let min_elt = C.min_elt let max_elt = C.max_elt let fold_result = C.fold_result let fold_until = C.fold_until include Monad.Make (struct type 'a t = 'a T.t let return = base let rec bind t ~f:k = match t with | Base v -> k v | True -> true_ | False -> false_ | Not t1 -> not_ (bind t1 ~f:k) (* Unfortunately we need to duplicate some of the short-circuiting from [andalso] and friends here. In principle we could do something involving [Lazy.t] but the overhead probably wouldn't be worth it. *) | And (t1, t2) -> (match bind t1 ~f:k with | False -> false_ | other -> andalso other (bind t2 ~f:k)) | Or (t1, t2) -> (match bind t1 ~f:k with | True -> true_ | other -> orelse other (bind t2 ~f:k)) | If (t1, t2, t3) -> (match bind t1 ~f:k with | True -> bind t2 ~f:k | False -> bind t3 ~f:k | other -> if_ other (bind t2 ~f:k) (bind t3 ~f:k)) ;; let map = `Define_using_bind end) (* semantics *) let rec eval t base_eval = match t with | True -> true | False -> false | And (t1, t2) -> eval t1 base_eval && eval t2 base_eval | Or (t1, t2) -> eval t1 base_eval || eval t2 base_eval | Not t -> not (eval t base_eval) | If (t1, t2, t3) -> if eval t1 base_eval then eval t2 base_eval else eval t3 base_eval | Base x -> base_eval x ;; let specialize t f = bind t ~f:(fun v -> match f v with | `Known c -> constant c | `Unknown -> base v) ;; let eval_set ~universe:all set_of_base = let rec aux (b : _ t) = match b with | True -> force all | False -> Set.Using_comparator.empty ~comparator:(Set.comparator (force all)) | And (a, b) -> Set.inter (aux a) (aux b) | Or (a, b) -> Set.union (aux a) (aux b) | Not a -> Set.diff (force all) (aux a) | Base a -> set_of_base a | If (cond, a, b) -> let cond = aux cond in Set.union (Set.inter cond (aux a)) (Set.inter (Set.diff (force all) cond) (aux b)) in aux ;; module type Monadic = sig module M : Monad.S val map : 'a t -> f:('a -> 'b M.t) -> 'b t M.t val bind : 'a t -> f:('a -> 'b t M.t) -> 'b t M.t val eval : 'a t -> f:('a -> bool M.t) -> bool M.t end module For_monad (M : Monad.S) : Monadic with module M := M = struct open M.Monad_infix let rec bind t ~f = match t with | Base x -> f x | True -> M.return true_ | False -> M.return false_ | And (a, b) -> bind a ~f >>= (function | False -> M.return false_ | True -> bind b ~f | a -> bind b ~f >>| fun b -> andalso a b) | Or (a, b) -> bind a ~f >>= (function | True -> M.return true_ | False -> bind b ~f | a -> bind b ~f >>| fun b -> orelse a b) | Not a -> bind a ~f >>| not_ | If (a, b, c) -> bind a ~f >>= (function | True -> bind b ~f | False -> bind c ~f | a -> bind b ~f >>= fun b -> bind c ~f >>| fun c -> if_ a b c) ;; let map t ~f = bind t ~f:(fun x -> f x >>| base) let eval t ~f = bind t ~f:(fun x -> f x >>| function | true -> true_ | false -> false_) >>| fun t -> eval t Nothing.unreachable_code ;; end (** We avoid deriving quickcheck to ensure that the invariants described in [T]'s comments above are preserved. *) let quickcheck_generator a_generator = Quickcheck.Generator.recursive_union [ Quickcheck.Generator.map ~f:base a_generator ; Quickcheck.Generator.singleton true_ ; Quickcheck.Generator.singleton false_ ] ~f:(fun self -> [ Quickcheck.Generator.map self ~f:not_ ; Quickcheck.Generator.map2 self self ~f:O.( || ) ; Quickcheck.Generator.map2 self self ~f:O.( && ) ; Quickcheck.Generator.map3 self self self ~f:if_ ]) ;; let quickcheck_shrinker (type a) (a_shrinker : a Quickcheck.Shrinker.t) = Quickcheck.Shrinker.fixed_point (fun self -> let binop operator left right = Sequence.round_robin [ Sequence.singleton left ; Sequence.singleton right ; Sequence.map (Quickcheck.Shrinker.shrink self left) ~f:(fun left -> operator left right) ; Sequence.map (Quickcheck.Shrinker.shrink self right) ~f:(fun right -> operator left right) ] in Quickcheck.Shrinker.create (fun t -> match t with | True | False -> Sequence.empty | Base a -> Sequence.map ~f:base (Quickcheck.Shrinker.shrink a_shrinker a) | Or (left, right) -> binop O.( || ) left right | And (left, right) -> binop O.( && ) left right | Not t -> Sequence.append (Sequence.singleton t) (Sequence.map ~f:not_ (Quickcheck.Shrinker.shrink self t)) | If (if_, then_, else_) -> Sequence.round_robin [ Sequence.singleton if_ ; Sequence.singleton then_ ; Sequence.singleton else_ ; Sequence.map (Quickcheck.Shrinker.shrink self if_) ~f:(fun if_ -> O.if_ if_ then_ else_) ; Sequence.map (Quickcheck.Shrinker.shrink self then_) ~f:(fun then_ -> O.if_ if_ then_ else_) ; Sequence.map (Quickcheck.Shrinker.shrink self else_) ~f:(fun else_ -> O.if_ if_ then_ else_) ])) ;; let quickcheck_observer (type a) (a_observer : a Quickcheck.Observer.t) = Base_quickcheck.Observer.create (fun t ~size ~hash -> hash_fold_t (fun hash a -> Quickcheck.Observer.observe a_observer a ~size ~hash) hash t) ;; core-0.15.0/core/src/blang.mli000066400000000000000000000175241420273305200160410ustar00rootroot00000000000000(** Boolean expressions. *) open! Import (** A blang is a boolean expression built up by applying the usual boolean operations to properties that evaluate to true or false in some context. {2 Usage} For example, imagine writing a config file for an application that filters a stream of integers. Your goal is to keep only those integers that are multiples of either -3 or 5. Using [Blang] for this task, the code might look like: {[ module Property = struct type t = | Multiple_of of int | Positive | Negative [@@deriving sexp] let eval t num = match t with | Multiple_of n -> num % n = 0 | Positive -> num > 0 | Negative -> num < 0 end type config = { keep : Property.t Blang.t; } [@@deriving sexp] let config = { keep = Blang.t_of_sexp Property.t_of_sexp (Sexp.of_string "(or (and negative (multiple_of 3)) (and positive (multiple_of 5)))"; } let keep config num : bool = Blang.eval config.keep (fun p -> Property.eval p num) ]} Note how [positive] and [negative] and [multiple_of] become operators in a small, newly-defined boolean expression language that allows you to write statements like [(and negative (multiple_of 3))]. {2 Blang sexp syntax} The blang sexp syntax is almost exactly the derived one, except that: 1. Base properties are not marked explicitly. Thus, if your base property type has elements FOO, BAR, etc., then you could write the following Blang s-expressions: {v FOO (and FOO BAR) (if FOO BAR BAZ) v} and so on. Note that this gets in the way of using the blang "keywords" in your value language. 2. [And] and [Or] take a variable number of arguments, so that one can (and probably should) write {v (and FOO BAR BAZ QUX) v} instead of {v (and FOO (and BAR (and BAZ QUX))) v} If you want to see the derived sexp, use [Raw.sexp_of_t]. *) open Std_internal (** Note that the sexps are not directly inferred from the type below -- there are lots of fancy shortcuts. Also, the sexps for ['a] must not look anything like blang sexps. Otherwise [t_of_sexp] will fail. The directly inferred sexps are available via [Raw.sexp_of_t]. *) type +'a t = private | True | False | And of 'a t * 'a t | Or of 'a t * 'a t | Not of 'a t | If of 'a t * 'a t * 'a t | Base of 'a [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar, typerep] (** [Raw] provides the automatically derived [sexp_of_t], useful in debugging the actual structure of the blang. *) module Raw : sig type nonrec 'a t = 'a t [@@deriving sexp_of] end (** {2 Smart constructors that simplify away constants whenever possible} *) module type Constructors = sig val base : 'a -> 'a t val true_ : _ t val false_ : _ t (** [function true -> true_ | false -> false_] *) val constant : bool -> _ t val not_ : 'a t -> 'a t (** n-ary [And] *) val and_ : 'a t list -> 'a t (** n-ary [Or] *) val or_ : 'a t list -> 'a t (** [if_ if then else] *) val if_ : 'a t -> 'a t -> 'a t -> 'a t end include Constructors module O : sig include Constructors val ( && ) : 'a t -> 'a t -> 'a t val ( || ) : 'a t -> 'a t -> 'a t (** [a ==> b] is "a implies b". This is not [=>] to avoid making it look like a comparison operator. *) val ( ==> ) : 'a t -> 'a t -> 'a t val not : 'a t -> 'a t end (** [constant_value t = Some b] iff [t = constant b] *) val constant_value : 'a t -> bool option (** The following two functions are useful when one wants to pretend that ['a t] has constructors [And] and [Or] of type ['a t list -> 'a t]. The pattern of use is {[ match t with | And (_, _) as t -> let ts = gather_conjuncts t in ... | Or (_, _) as t -> let ts = gather_disjuncts t in ... | ... ]} or, in case you also want to handle [True] (resp. [False]) as a special case of conjunction (disjunction) {[ match t with | True | And (_, _) as t -> let ts = gather_conjuncts t in ... | False | Or (_, _) as t -> let ts = gather_disjuncts t in ... | ... ]} *) (** [gather_conjuncts t] gathers up all toplevel conjuncts in [t]. For example, {ul {- [gather_conjuncts (and_ ts) = ts] } {- [gather_conjuncts (And (t1, t2)) = gather_conjuncts t1 @ gather_conjuncts t2] } {- [gather_conjuncts True = [] ] } {- [gather_conjuncts t = [t]] when [t] matches neither [And (_, _)] nor [True] } } *) val gather_conjuncts : 'a t -> 'a t list (** [gather_disjuncts t] gathers up all toplevel disjuncts in [t]. For example, {ul {- [gather_disjuncts (or_ ts) = ts] } {- [gather_disjuncts (Or (t1, t2)) = gather_disjuncts t1 @ gather_disjuncts t2] } {- [gather_disjuncts False = [] ] } {- [gather_disjuncts t = [t]] when [t] matches neither [Or (_, _)] nor [False] } } *) val gather_disjuncts : 'a t -> 'a t list include Container.S1 with type 'a t := 'a t include Quickcheckable.S1 with type 'a t := 'a t (** [Blang.t] sports a substitution monad: {ul {- [return v] is [Base v] (think of [v] as a variable) } {- [bind t f] replaces every [Base v] in [t] with [f v] (think of [v] as a variable and [f] as specifying the term to substitute for each variable) } } Note: [bind t f] does short-circuiting, so [f] may not be called on every variable in [t]. *) include Monad with type 'a t := 'a t (** [values t] forms the list containing every [v] for which [Base v] is a subexpression of [t] *) val values : 'a t -> 'a list (** [eval t f] evaluates the proposition [t] relative to an environment [f] that assigns truth values to base propositions. *) val eval : 'a t -> ('a -> bool) -> bool (** [eval_set ~universe set_of_base expression] returns the subset of elements [e] in [universe] that satisfy [eval expression (fun base -> Set.mem (set_of_base base) e)]. [eval_set] assumes, but does not verify, that [set_of_base] always returns a subset of [universe]. If this doesn't hold, then [eval_set]'s result may contain elements not in [universe]. [And set1 set2] represents the elements that are both in [set1] and [set2], thus in the intersection of the two sets. Symmetrically, [Or set1 set2] represents the union of [set1] and [set2]. *) val eval_set : universe:('elt, 'comparator) Set.t Lazy.t -> ('a -> ('elt, 'comparator) Set.t) -> 'a t -> ('elt, 'comparator) Set.t (** [specialize t f] partially evaluates [t] according to a perhaps-incomplete assignment [f] of the values of base propositions. The following laws (at least partially) characterize its behavior. - [specialize t (fun _ -> `Unknown) = t] - [specialize t (fun x -> `Known (f x)) = constant (eval t f)] - [List.for_all (values (specialize t g)) ~f:(fun x -> g x = `Unknown)] - {[ if List.for_all (values t) ~f:(fun x -> match g x with | `Known b -> b = f x | `Unknown -> true) then eval t f = eval (specialize t g) f ]} *) val specialize : 'a t -> ('a -> [ `Known of bool | `Unknown ]) -> 'a t module type Monadic = sig module M : Monad.S val map : 'a t -> f:('a -> 'b M.t) -> 'b t M.t val bind : 'a t -> f:('a -> 'b t M.t) -> 'b t M.t val eval : 'a t -> f:('a -> bool M.t) -> bool M.t end (** Generalizes some of the blang operations above to work in a monad. *) module For_monad (M : Monad.S) : Monadic with module M := M val invariant : 'a t -> unit module Stable : sig module V1 : sig type nonrec 'a t = 'a t = private | True | False | And of 'a t * 'a t | Or of 'a t * 'a t | Not of 'a t | If of 'a t * 'a t * 'a t | Base of 'a [@@deriving sexp, sexp_grammar, bin_io, compare, equal, hash] end end core-0.15.0/core/src/blit.ml000066400000000000000000000000441420273305200155240ustar00rootroot00000000000000include Base.Blit include Blit_intf core-0.15.0/core/src/blit.mli000066400000000000000000000001351420273305200156760ustar00rootroot00000000000000(** This module extends {{!Base.Blit}[Base.Blit]}. *) include Blit_intf.Blit (** @inline *) core-0.15.0/core/src/blit_intf.ml000066400000000000000000000021611420273305200165460ustar00rootroot00000000000000(** This module extends the Base [Blit] module *) open Base.Blit (*_ These are not implemented less-general-in-terms-of-more-general because odoc produces unreadable documentation in that case, with or without [inline] on [include]. *) module type S_permissions = sig open Perms.Export type -'perms t val blit : ([> read ] t, [> write ] t) blit val blito : ([> read ] t, [> write ] t) blito val unsafe_blit : ([> read ] t, [> write ] t) blit val sub : ([> read ] t, [< _ perms ] t) sub val subo : ([> read ] t, [< _ perms ] t) subo end module type S1_permissions = sig open Perms.Export type ('a, -'perms) t val blit : (('a, [> read ]) t, ('a, [> write ]) t) blit val blito : (('a, [> read ]) t, ('a, [> write ]) t) blito val unsafe_blit : (('a, [> read ]) t, ('a, [> write ]) t) blit val sub : (('a, [> read ]) t, ('a, [< _ perms ]) t) sub val subo : (('a, [> read ]) t, ('a, [< _ perms ]) t) subo end module type Blit = sig (** @inline *) include module type of struct include Base.Blit end module type S_permissions = S_permissions module type S1_permissions = S1_permissions end core-0.15.0/core/src/bool.ml000066400000000000000000000026251420273305200155340ustar00rootroot00000000000000open! Import type t = bool [@@deriving bin_io, typerep] include Identifiable.Extend (Base.Bool) (struct type nonrec t = t [@@deriving bin_io] end) module Replace_polymorphic_compare = Base.Bool include ( Base.Bool : module type of struct include Base.Bool end with type t := t) include Comparable.Validate (Base.Bool) let of_string_hum = let table = lazy (let table = String.Caseless.Table.create () in [ false, [ "false"; "no"; "0" ]; true, [ "true"; "yes"; "1" ] ] |> List.iter ~f:(fun (bool, strings) -> List.iter strings ~f:(fun string -> Hashtbl.set table ~key:string ~data:bool; Hashtbl.set table ~key:(String.prefix string 1) ~data:bool)); table) in let raise_invalid input = let expected_case_insensitive = String.Set.of_list (Hashtbl.keys (force table)) in raise_s [%message "Bool.of_string_hum: invalid input" (input : string) (expected_case_insensitive : String.Set.t)] in fun string -> Hashtbl.find_and_call (force table) string ~if_found:Fn.id ~if_not_found:raise_invalid ;; let quickcheck_generator = Base_quickcheck.Generator.bool let quickcheck_observer = Base_quickcheck.Observer.bool let quickcheck_shrinker = Base_quickcheck.Shrinker.bool module Stable = struct module V1 = struct type nonrec t = t [@@deriving compare, sexp, bin_io] end end core-0.15.0/core/src/bool.mli000066400000000000000000000010701420273305200156760ustar00rootroot00000000000000(** This module extends {{!Base.Bool}[Base.Bool]}. *) type t = bool [@@deriving bin_io, typerep] include module type of Base.Bool with type t := t include Identifiable.S with type t := t and type comparator_witness := Base.Bool.comparator_witness (** Human readable parsing. Accepted inputs are (case insensitive): - true/false - yes/no - 1/0 - t/f - y/n *) val of_string_hum : string -> t include Quickcheckable.S with type t := t module Stable : sig module V1 : sig type nonrec t = t [@@deriving compare, sexp, bin_io] end end core-0.15.0/core/src/bounded_index.ml000066400000000000000000000052261420273305200174100ustar00rootroot00000000000000open! Import open! Stable_internal module Stable = struct module V1 = struct module Make (M : sig val label : string end) = struct type t = { index : int ; min_index : int ; max_index : int } [@@deriving bin_io, compare, hash] let create index ~min ~max = if index < min || index > max then Error.raise_s [%message "index out of bounds" (index : int) (min : int) (max : int)] else { index; min_index = min; max_index = max } ;; module For_sexpable = struct type t = string * int * string * int * string * int [@@deriving sexp] end include Sexpable.Stable.Of_sexpable.V1 (For_sexpable) (struct type nonrec t = t let to_sexpable t = M.label, t.index, "of", t.min_index, "to", t.max_index let of_sexpable (label, index, of_, min, to_, max) = if String.equal label M.label && String.equal of_ "of" && String.equal to_ "to" then create index ~min ~max else Error.raise_s [%message "invalid sexp for index" ~label:M.label] ;; end) include Comparator.Stable.V1.Make (struct type nonrec t = t [@@deriving sexp_of, compare] end) include Comparable.Stable.V1.Make (struct type nonrec t = t [@@deriving sexp, compare, bin_io] type nonrec comparator_witness = comparator_witness let comparator = comparator end) end end end open! Std_internal module type S = Bounded_index_intf.S module Make (M : sig val label : string val module_name : string end) = struct module Stable = struct module V1 = Stable.V1.Make (M) end open Stable.V1 type t = Stable.V1.t [@@deriving bin_io, compare, hash, sexp] type comparator_witness = Stable.V1.comparator_witness let create = Stable.V1.create let create_all ~min ~max = Sequence.unfold ~init:min ~f:(fun index -> if index < min || index > max then None else Some (create index ~min ~max, index + 1)) |> Sequence.to_list ;; let index t = t.index let max_index t = t.max_index let min_index t = t.min_index include Sexpable.To_stringable (struct type nonrec t = t [@@deriving sexp] end) include Identifiable.Make_using_comparator (struct type nonrec t = t [@@deriving bin_io, compare, hash, sexp] type nonrec comparator_witness = comparator_witness let comparator = comparator let of_string = of_string let to_string = to_string let module_name = M.module_name end) end core-0.15.0/core/src/bounded_index.mli000066400000000000000000000000701420273305200175510ustar00rootroot00000000000000include Bounded_index_intf.Bounded_index (** @inline *) core-0.15.0/core/src/bounded_index_intf.ml000066400000000000000000000027631420273305200204330ustar00rootroot00000000000000open! Import open! Std_internal module type S = sig type t [@@deriving hash] include Identifiable with type t := t (** [create index ~min ~max] raises if [index < min || index > max]. The resulting [t] is only equal to other [t] if all three fields are the same. *) val create : int -> min:int -> max:int -> t (** all indices in ascending order *) val create_all : min:int -> max:int -> t list (** Accessors. *) val index : t -> int val min_index : t -> int val max_index : t -> int module Stable : sig module V1 : Stable_comparable.V1 with type t = t with type comparator_witness = comparator_witness end end module type Bounded_index = sig (** [Bounded_index] creates unique index types with explicit bounds and human-readable labels. "(thing 2 of 0 to 4)" refers to a 0-based index for the third element of five with the label "thing", whereas a 1-based index for the second element of twelve with the label "item" renders as "(item 2 of 1 to 12)", even though both represent the index 2. Use [Bounded_index] to help distinguish between different index types when reading rendered values, deserializing sexps, and typechecking. Consider using [Bounded_index] to label fixed pools of resources such as cores in a cpu, worker processes in a parallel application, or machines in a cluster. *) module type S = S module Make (M : sig val label : string val module_name : string end) : S end core-0.15.0/core/src/byte_units.ml000066400000000000000000000234421420273305200167660ustar00rootroot00000000000000(* Conversions between units of measure based on bytes. *) open! Import open Std_internal module Repr = Int63 module T = Byte_units0 include (T : module type of T with module Repr := Repr) include Comparable.Make_plain (T) include Hashable.Make_plain (T) module Infix = struct let ( - ) a b = of_repr (Repr.( - ) (to_repr a) (to_repr b)) let ( + ) a b = of_repr (Repr.( + ) (to_repr a) (to_repr b)) let ( // ) a b = Repr.( // ) (to_repr a) (to_repr b) let ( / ) t s = of_repr (Repr.of_float (Repr.to_float (to_repr t) /. s)) let ( * ) t s = of_repr (Repr.of_float (Repr.to_float (to_repr t) *. s)) end include Infix let zero = of_repr Repr.zero let min_value = of_repr Repr.min_value let max_value = of_repr Repr.max_value let scale = Infix.( * ) let iscale t s = of_repr (Repr.( * ) (to_repr t) (Repr.of_int s)) let bytes_int_exn = T.bytes_int_exn let bytes_int63 = to_repr let bytes_int64 t = Repr.to_int64 (to_repr t) let bytes_float t = Repr.to_float (to_repr t) let of_bytes_int b = of_repr (Repr.of_int b) let of_bytes_int63 = of_repr let of_bytes_int64_exn b = of_repr (Repr.of_int64_exn b) let of_bytes_float_exn b = of_repr (Repr.of_float b) let[@deprecated "[since 2019-01] Use [bytes_int_exn], [bytes_int63], [bytes_int64] or [bytes_float] \ as appropriate."] bytes = bytes_float ;; let[@deprecated "[since 2019-01] Use [of_bytes_int], [of_bytes_int63], [of_bytes_int64_exn] or \ [of_bytes_float_exn] as appropriate."] of_bytes = of_bytes_float_exn ;; let kilobyte : t = of_bytes_int 1024 let megabyte = iscale kilobyte 1024 let gigabyte = iscale megabyte 1024 let terabyte = iscale gigabyte 1024 let petabyte = iscale terabyte 1024 let exabyte = iscale petabyte 1024 let word = let module W = Word_size in match W.word_size with | W.W32 -> of_bytes_int 4 | W.W64 -> of_bytes_int 8 ;; let kilobytes t : float = Infix.( // ) t kilobyte let megabytes t = Infix.( // ) t megabyte let gigabytes t = Infix.( // ) t gigabyte let terabytes t = Infix.( // ) t terabyte let petabytes t = Infix.( // ) t petabyte let exabytes t = Infix.( // ) t exabyte let words_int_exn t = Repr.to_int_exn (Repr.( / ) (to_repr t) (to_repr word)) let words_float t = Infix.( // ) t word let of_kilobytes t : t = Infix.( * ) kilobyte t let of_megabytes t = Infix.( * ) megabyte t let of_gigabytes t = Infix.( * ) gigabyte t let of_terabytes t = Infix.( * ) terabyte t let of_petabytes t = Infix.( * ) petabyte t let of_exabytes t = Infix.( * ) exabyte t let of_words_int t = iscale word t let of_words_float_exn t = Infix.( * ) word t let[@deprecated "[since 2019-01] Use [words_int_exn] or [words_float]"] words = words_float ;; let[@deprecated "[since 2019-01] Use [of_words_int] or [of_words_float_exn]"] of_words = of_words_float_exn ;; let of_string s = let length = String.length s in if Int.( < ) length 2 then invalid_argf "'%s' passed to Byte_units.of_string - too short" s (); let base_str = String.sub s ~pos:0 ~len:(Int.( - ) length 1) in let ext_char = Char.lowercase s.[Int.( - ) length 1] in let base = try Float.of_string base_str with | _ -> invalid_argf "'%s' passed to Byte_units.of_string - %s cannot be converted to float " s base_str () in match ext_char with | 'b' -> of_bytes_float_exn base | 'k' -> of_kilobytes base | 'm' -> of_megabytes base | 'g' -> of_gigabytes base | 't' -> of_terabytes base | 'p' -> of_petabytes base | 'e' -> of_exabytes base | 'w' -> of_words base | ext -> invalid_argf "'%s' passed to Byte_units.of_string - illegal extension %c" s ext () ;; let arg_type = Command.Arg_type.create of_string let largest_measure t = let t_abs = of_repr (Repr.abs (to_repr t)) in if t_abs >= exabyte then `Exabytes else if t_abs >= petabyte then `Petabytes else if t_abs >= terabyte then `Terabytes else if t_abs >= gigabyte then `Gigabytes else if t_abs >= megabyte then `Megabytes else if t_abs >= kilobyte then `Kilobytes else `Bytes ;; module Stable = struct (* Share the common [of_sexp] code for [V1] and [V2]. *) module Of_sexp_v1_v2 : sig val t_of_sexp : Sexp.t -> t end = struct let no_match () = failwith "Not a recognized [Byte_units.t] representation" let of_value_sexp_and_unit_name val_sexp = function | "Bytes" -> (try of_bytes_int63 (Int63.t_of_sexp val_sexp) with | _ -> of_bytes_float_exn (Float.t_of_sexp val_sexp)) | "Kilobytes" -> of_kilobytes (float_of_sexp val_sexp) | "Megabytes" -> of_megabytes (float_of_sexp val_sexp) | "Gigabytes" -> of_gigabytes (float_of_sexp val_sexp) | "Terabytes" -> of_terabytes (float_of_sexp val_sexp) | "Petabytes" -> of_petabytes (float_of_sexp val_sexp) | "Exabytes" -> of_exabytes (float_of_sexp val_sexp) | "Words" -> of_words_float_exn (float_of_sexp val_sexp) | _ -> no_match () ;; let t_of_sexp = function | Sexp.Atom str -> of_string str | Sexp.List [ Sexp.Atom unit_name; value ] -> of_value_sexp_and_unit_name value unit_name | _ -> no_match () ;; let t_of_sexp sexp = try t_of_sexp sexp with | exn -> raise (Sexp.Of_sexp_error (exn, sexp)) ;; end module V1 = struct type nonrec t = t [@@deriving compare, hash] include Binable0.Of_binable_without_uuid [@alert "-legacy"] (Float) (struct type nonrec t = t let to_binable = bytes_float let of_binable = of_bytes_float_exn end) include Of_sexp_v1_v2 let sexp_of_t t = (* V1 only goes up to gigabytes *) match largest_measure t with | `Bytes -> [%sexp `Bytes (bytes_float t : float)] | `Kilobytes -> [%sexp `Kilobytes (kilobytes t : float)] | `Megabytes -> [%sexp `Megabytes (megabytes t : float)] | `Gigabytes | `Terabytes | `Petabytes | `Exabytes -> [%sexp `Gigabytes (gigabytes t : float)] ;; let to_string t = String.lowercase (to_string t) let of_string = of_string (* This test documents the original to-string representation and fails under javascript due to differences in the rounding. *) let%expect_test (_ [@tags "no-js"]) = printf !"%{}" (of_bytes_int 1000); [%expect {| 1000b |}]; printf !"%{}" (of_bytes_int 1023); [%expect {| 1023b |}]; printf !"%{}" (of_bytes_int 1024); [%expect {| 1k |}]; printf !"%{}" (of_bytes_int 1025); [%expect {| 1.00098k |}]; printf !"%{}" (of_bytes_int 1500); [%expect {| 1.46484k |}]; printf !"%{}" (of_bytes_int 10000); [%expect {| 9.76562k |}]; printf !"%{}" (of_bytes_int 100000); [%expect {| 97.6562k |}]; printf !"%{}" (of_bytes_int 1000000); [%expect {| 976.562k |}]; printf !"%{}" (of_bytes_int 10000000); [%expect {| 9.53674m |}] ;; let t_of_sexp sexp = match sexp with | Sexp.Atom s -> (try of_string s with | Invalid_argument msg -> of_sexp_error msg sexp) | Sexp.List _ -> t_of_sexp sexp ;; end module V2 = struct type nonrec t = t [@@deriving compare, hash] include Binable0.Of_binable_without_uuid [@alert "-legacy"] (Int63) (struct type nonrec t = t let to_binable = bytes_int63 let of_binable = of_bytes_int63 end) include Of_sexp_v1_v2 let sexp_of_t t = [%sexp `Bytes (bytes_int63 t : Int63.t)] end end let to_string_hum = T.to_string module Short = struct type nonrec t = t let to_string t = let to_units_str to_unit ext = let f = to_unit t in let f_abs = Float.abs f in if Float.Robustly_comparable.( >=. ) f_abs 100. then sprintf "%.0f%c" f ext else if Float.Robustly_comparable.( >=. ) f_abs 10. then sprintf "%.1f%c" f ext else sprintf "%.2f%c" f ext in match largest_measure t with | `Bytes -> sprintf "%dB" (bytes_int_exn t) | `Kilobytes -> to_units_str kilobytes 'K' | `Megabytes -> to_units_str megabytes 'M' | `Gigabytes -> to_units_str gigabytes 'G' | `Terabytes -> to_units_str terabytes 'T' | `Petabytes -> to_units_str petabytes 'P' | `Exabytes -> to_units_str exabytes 'E' ;; let sexp_of_t t = Sexp.Atom (to_string t) let%expect_test _ = printf !"%{}" (of_bytes_int 1000); [%expect {| 1000B |}]; printf !"%{}" (of_bytes_int 1023); [%expect {| 1023B |}]; printf !"%{}" (of_bytes_int 1024); [%expect {| 1.00K |}]; printf !"%{}" (of_bytes_int 1025); [%expect {| 1.00K |}]; printf !"%{}" (of_bytes_int 10000); [%expect {| 9.77K |}]; printf !"%{}" (of_bytes_int 100000); [%expect {| 97.7K |}]; printf !"%{}" (of_bytes_int 1000000); [%expect {| 977K |}]; printf !"%{}" (of_bytes_int 10000000); [%expect {| 9.54M |}]; printf !"%{}" (of_bytes 10000000000.); [%expect {| 9.31G |}]; printf !"%{}" (of_bytes 1000000000000.); [%expect {| 931G |}]; printf !"%{}" (of_bytes 100000000000000.); [%expect {| 90.9T |}]; printf !"%{}" (of_bytes 100000000000000000.); [%expect {| 88.8P |}]; printf !"%{}" (of_bytes 3000000000000000000.); [%expect {| 2.60E |}]; () ;; end let to_string_short = Short.to_string let[@deprecated "[since 2019-01] Use [of_bytes], [of_kilobytes], [of_megabytes], etc as appropriate."] create units value = match units with | `Bytes -> of_bytes_float_exn value | `Kilobytes -> of_kilobytes value | `Megabytes -> of_megabytes value | `Gigabytes -> of_gigabytes value | `Words -> of_words_float_exn value ;; include Quickcheckable.Of_quickcheckable (Repr) (struct type nonrec t = t let of_quickcheckable = of_repr let to_quickcheckable = to_repr end) core-0.15.0/core/src/byte_units.mli000066400000000000000000000136371420273305200171440ustar00rootroot00000000000000(** Conversions between units of measure that are based on bytes (like kilobytes, megabytes, gigabytes, and words). [t]'s are created with [of_bytes_float_exn], [of_words_float_exn], [of_kilobytes], [of_megabytes], etc. Note: in this module, kilobytes, Megabytes, etc. are defined as powers of 1024: - 1 kilobyte: 2^10 = 1024 bytes - 1 Megabyte: 2^20 = 1024^2 bytes - 1 Gigabyte: 2^30 = 1024^3 bytes - 1 Terabyte: 2^40 = 1024^4 bytes - 1 Petabyte: 2^50 = 1024^5 bytes - 1 Exabyte: 2^60 = 1024^6 bytes *) open! Import type t [@@deriving sexp_of] [@@immediate64] val create : [ `Bytes | `Kilobytes | `Megabytes | `Gigabytes | `Words ] -> float -> t [@@deprecated "[since 2019-01] Use [of_bytes], [of_kilobytes], [of_megabytes], etc as appropriate."] include Comparable.S_plain with type t := t include Hashable.S_plain with type t := t include Stringable.S with type t := t (** This is a deprecated alias for [of_bytes_float_exn]. *) val of_bytes : float -> t [@@deprecated "[since 2019-01] Use [of_bytes_int], [of_bytes_int63], [of_bytes_int64_exn] or \ [of_bytes_float_exn] as appropriate."] val of_bytes_int : int -> t val of_bytes_int63 : Int63.t -> t (** This will raise if and only if the argument can not be represented as a [Byte_units.t]. Specifically this is if the argument is outside of \[-2^62,2^62). *) val of_bytes_int64_exn : Int64.t -> t (** This will raise if and only if the argument can not be represented as a [Byte_units.t]. Specifically this is if the argument is outside of \[-2^62,2^62), *) val of_bytes_float_exn : float -> t (** create of [Byte_units] based on the number of kilobytes. N.B. This will raise if the value is outside of \[-2^52,2^52). *) val of_kilobytes : float -> t (** create of [Byte_units] based on the number of Megabytes. N.B. This will raise if the value is outside of \[-2^42,2^42). *) val of_megabytes : float -> t (** create of [Byte_units] based on the number of Gigabytes. N.B. This will raise if the value is outside of \[-2^32,2^32). *) val of_gigabytes : float -> t (** create of [Byte_units] based on the number of Terabytes. N.B. This will raise if the value is outside of \[-2^22,2^22). *) val of_terabytes : float -> t (** create of [Byte_units] based on the number of Petabytes. N.B. This will raise if the value is outside of \[-2^12,2^12). *) val of_petabytes : float -> t (** create of [Byte_units] based on the number of Exabytes. N.B. This will raise if the value is outside of \[-4,4). *) val of_exabytes : float -> t (** Do not use, consider using [of_words_int] instead. Alias for [of_words_float_exn]. *) val of_words : float -> t [@@deprecated "[since 2019-01] Use [of_words_int] or [of_words_float_exn] instead."] (** create of [Byte_units] based on the number of machine words. *) val of_words_int : int -> t (** Create of [Byte_units] based on the number of machine words. On 64-bit platforms this will raise if the value is outside of \[-2^59,2^59). On 32-bit platforms (including JS) this will raise if the value is outside of \[-2^60,2^60). *) val of_words_float_exn : float -> t (** [to_string_hum t] returns a string representation of [t]. This will use the largest unit that will not make the translated value be below 1. For example [Byte_units.to_string_hum (Byte_units.of_bytes_int 1000)] gives [1000B], but [Byte_units.to_string_hum (Byte_units.of_bytes_int 1500)] gives [1.46484K]. *) val to_string_hum : t -> string val to_string_short : t -> string [@@deprecated "[since 2020-06] Use [Short.to_string] instead."] module Short : sig type nonrec t = t [@@deriving sexp_of] (** [Short.to_string] is like [to_string_hum] but will attempt to only show 4 significant digits. For example [Byte_units.to_string_hum (Byte_units.of_bytes_int 1000)] gives [1000B], but [Byte_units.to_string_hum (Byte_units.of_bytes_int 1500)] gives [1.46K]. [Short.sexp_of_t] does the same. *) val to_string : t -> string end (** This is a deprecated alias for [bytes_float]. *) val bytes : t -> float [@@deprecated "[since 2019-01] Use [bytes_int_exn], [bytes_int63], [bytes_int64] or [bytes_float] \ as appropriate."] (** This will raise if and only if the value of this [Byte_units.t] can not be represented as an int. This can only happen on platforms where [int] is less than 63 bits, specifically JS and 32-bit OCaml where this will raise if the number of bytes is outside of \[-2^30,2^30). *) val bytes_int_exn : t -> int val bytes_int63 : t -> Int63.t val bytes_int64 : t -> Int64.t val bytes_float : t -> float val kilobytes : t -> float val megabytes : t -> float val gigabytes : t -> float val terabytes : t -> float val petabytes : t -> float val exabytes : t -> float (** Do not use, consider using [words_int_exn] instead. Alias for [words_float] *) val words : t -> float [@@deprecated "[since 2019-01] Use [words_int_exn] or [words_float] instead."] (** In JS and on 32-bit OCaml this will raise if and only if the number of bytes is outside of \[-2^32,2^32). *) val words_int_exn : t -> int val words_float : t -> float val zero : t val min_value : t val max_value : t (** [scale t mul] scale the measure [t] by [mul] *) val scale : t -> float -> t val arg_type : t Command.Arg_type.t module Infix : sig val ( - ) : t -> t -> t val ( + ) : t -> t -> t (** [( / ) t mul] scales [t] by [1/mul] *) val ( / ) : t -> float -> t (** [( // ) t1 t2] returns the ratio of t1 to t2 *) val ( // ) : t -> t -> float end include module type of Infix include Quickcheckable.S with type t := t module Stable : sig (*_ old float based [bin_io] repr. *) module V1 : sig type nonrec t = t [@@deriving hash] include Stable_module_types.S0_without_comparator with type t := t end (*_ new [Int63] based [bin_io] repr. *) module V2 : sig type nonrec t = t [@@deriving hash] include Stable_module_types.S0_without_comparator with type t := t end end core-0.15.0/core/src/byte_units0.ml000066400000000000000000000015151420273305200170430ustar00rootroot00000000000000open! Import open Std_internal module Repr = Int63 module T : sig type t [@@deriving compare, hash, sexp_of] [@@immediate64] val to_string : t -> string val of_repr : Repr.t -> t val to_repr : t -> Repr.t end = struct type t = Repr.t [@@deriving compare, hash] let of_repr = Fn.id let to_repr = Fn.id let to_string n = let open Repr in let kib = of_int 1024 in let mib = kib * kib in let gib = kib * mib in let n_abs = abs n in if n_abs < kib then sprintf "%dB" (to_int_exn n) else if n_abs < mib then sprintf "%gK" (to_float n /. to_float kib) else if n_abs < gib then sprintf "%gM" (to_float n /. to_float mib) else sprintf "%gG" (to_float n /. to_float gib) ;; let sexp_of_t n = Sexp.Atom (to_string n) end include T let bytes_int_exn t = Repr.to_int_exn (to_repr t) core-0.15.0/core/src/byte_units0.mli000066400000000000000000000003131420273305200172070ustar00rootroot00000000000000open! Import module Repr = Int63 type t [@@deriving compare, hash, sexp_of] [@@immediate64] val to_string : t -> string val of_repr : Repr.t -> t val to_repr : t -> Repr.t val bytes_int_exn : t -> int core-0.15.0/core/src/bytes.ml000066400000000000000000000010441420273305200157210ustar00rootroot00000000000000open! Import open Base_quickcheck.Export module Stable = struct module V1 = struct include Base.Bytes type t = bytes [@@deriving bin_io, quickcheck, typerep] end end include Stable.V1 include Comparable.Validate (Base.Bytes) include Hexdump.Of_indexable (struct type t = bytes let length = length let get = get end) let gen' char_gen = String.gen' char_gen |> Quickcheck.Generator.map ~f:of_string let gen_with_length len char_gen = String.gen_with_length len char_gen |> Quickcheck.Generator.map ~f:of_string ;; core-0.15.0/core/src/bytes.mli000066400000000000000000000020361420273305200160740ustar00rootroot00000000000000(** This module extends {{!Base.Bytes}[Base.Bytes]}. *) open! Import type t = bytes [@@deriving bin_io, typerep] (** @inline *) include module type of struct include Base.Bytes end with type t := t include Hexdump.S with type t := t include Quickcheckable.S with type t := t (** Like [gen], but generate bytes with the given distribution of characters. *) val gen' : char Quickcheck.Generator.t -> t Quickcheck.Generator.t (** Like [gen'], but generate bytes with the given length. *) val gen_with_length : int -> char Quickcheck.Generator.t -> t Quickcheck.Generator.t (** Note that [bytes] is already stable by itself, since as a primitive type it is an integral part of the sexp / bin_io protocol. [Bytes.Stable] exists only to provide interface uniformity with other stable types. *) module Stable : sig module V1 : sig type nonrec t = t type nonrec comparator_witness = comparator_witness include Stable_module_types.S0 with type t := t with type comparator_witness := comparator_witness end end core-0.15.0/core/src/char.ml000066400000000000000000000024451420273305200155160ustar00rootroot00000000000000open! Import type t = char [@@deriving typerep] include Identifiable.Extend (Base.Char) (struct type t = char [@@deriving bin_io] end) (* include [Base.Char] after the application of [Identifiable.Extend] to replace the [Comparable] functions with the pervasive versions *) include ( Base.Char : module type of struct include Base.Char end with type t := t) module Caseless = struct module T = struct include Caseless type t = char [@@deriving bin_io] end include T include Comparable.Make_binable_using_comparator (T) include Hashable.Make_binable (T) end module Replace_polymorphic_compare = Base.Char let quickcheck_generator = Base_quickcheck.Generator.char let quickcheck_observer = Base_quickcheck.Observer.char let quickcheck_shrinker = Base_quickcheck.Shrinker.char let gen_digit = Base_quickcheck.Generator.char_digit let gen_lowercase = Base_quickcheck.Generator.char_lowercase let gen_uppercase = Base_quickcheck.Generator.char_uppercase let gen_alpha = Base_quickcheck.Generator.char_alpha let gen_alphanum = Base_quickcheck.Generator.char_alphanum let gen_print = Base_quickcheck.Generator.char_print let gen_whitespace = Base_quickcheck.Generator.char_whitespace let gen_uniform_inclusive = Base_quickcheck.Generator.char_uniform_inclusive core-0.15.0/core/src/char.mli000066400000000000000000000027021420273305200156630ustar00rootroot00000000000000(** This module extends {{!Base.Char}[Base.Char]}, adding [Identifiable] for making char identifiers and [Quickcheckable] to facilitate automated testing with pseudorandom data. *) type t = char [@@deriving typerep] (** {2 The signature included from [Base.Char]} *) (** @inline *) include module type of struct include Base.Char end with type t := t (** {2 Extensions} *) (** [Caseless] compares and hashes characters ignoring case, so that for example [Caseless.equal 'A' 'a'] and [Caseless.('a' < 'B')] are [true], and [Caseless.Map], [Caseless.Table] lookup and [Caseless.Set] membership is case-insensitive. *) module Caseless : sig type nonrec t = t [@@deriving bin_io, hash, sexp] include Comparable.S_binable with type t := t include Hashable.S_binable with type t := t end include Identifiable.S with type t := t and type comparator_witness := comparator_witness (** {3 Quickcheck Support} *) include Quickcheckable.S with type t := t val gen_digit : t Quickcheck.Generator.t val gen_lowercase : t Quickcheck.Generator.t val gen_uppercase : t Quickcheck.Generator.t val gen_alpha : t Quickcheck.Generator.t val gen_alphanum : t Quickcheck.Generator.t val gen_print : t Quickcheck.Generator.t val gen_whitespace : t Quickcheck.Generator.t (** Generates characters between the given inclusive bounds in ASCII order. Raises if bounds are in decreasing order. *) val gen_uniform_inclusive : t -> t -> t Quickcheck.Generator.t core-0.15.0/core/src/command.ml000066400000000000000000002707061420273305200162260ustar00rootroot00000000000000module Stable = struct module Shape = Command_shape.Stable end open! Import open! Std_internal include Command_intf module Shape = Command_shape (* in order to define expect tests, we want to raise rather than exit if the code is running in the test runner process *) let raise_instead_of_exit = match Ppx_inline_test_lib.Runtime.testing with | `Testing `Am_test_runner -> true | `Testing `Am_child_of_test_runner | `Not_testing -> false ;; exception Exit_called of { status : int } [@@deriving sexp_of] (* [raise_instead_of_exit]-respecting wrappers for [exit] and functions that call it *) include struct let exit status = if raise_instead_of_exit then raise (Exit_called { status }) else exit status ;; module Exn = struct let to_string = Exn.to_string let handle_uncaught_and_exit f = if raise_instead_of_exit then ( try f () with | Exit_called { status = 0 } as exn -> print_s [%sexp (exn : exn)]) else Exn.handle_uncaught_and_exit f ;; end end let unwords xs = String.concat ~sep:" " xs let unparagraphs xs = String.concat ~sep:"\n\n" xs exception Failed_to_parse_command_line of string let die fmt = Printf.ksprintf (fun msg () -> raise (Failed_to_parse_command_line msg)) fmt let help_screen_compare = Shape.Private.help_screen_compare (* universal maps are used to pass around values between different bits of command line parsing code without having a huge impact on the types involved 1. passing values from parsed args to command-line autocomplete functions 2. passing special values to a base commands that request them in their spec * expanded subcommand path * args passed to the base command * help text for the base command *) module Env = struct include Univ_map let key_create name = Univ_map.Key.create ~name sexp_of_opaque let multi_add = Univ_map.Multi.add let set_with_default = Univ_map.With_default.set end module Auto_complete = struct type t = Env.t -> part:string -> string list end module Completer = struct type t = Auto_complete.t option let run_and_exit t env ~part : never_returns = Option.iter t ~f:(fun completions -> List.iter ~f:print_endline (completions env ~part)); exit 0 ;; end module Arg_type : sig type 'a t val extra_doc : 'a t -> string option lazy_t val key : 'a t -> 'a Env.Multi.Key.t option val complete : 'a t -> Completer.t val parse : 'a t -> string -> ('a, exn) result val create : ?complete:Auto_complete.t -> ?key:'a Env.Multi.Key.t -> (string -> 'a) -> 'a t val map : ?key:'a Env.Multi.Key.t -> 'b t -> f:('b -> 'a) -> 'a t val of_lazy : ?key:'a Env.Multi.Key.t -> 'a t lazy_t -> 'a t val of_map : ?accept_unique_prefixes:bool -> ?case_sensitive:bool -> ?list_values_in_help:bool -> ?auto_complete:Auto_complete.t -> ?key:'a Env.Multi.Key.t -> 'a String.Map.t -> 'a t val of_alist_exn : ?accept_unique_prefixes:bool -> ?case_sensitive:bool -> ?list_values_in_help:bool -> ?auto_complete:Auto_complete.t -> ?key:'a Env.Multi.Key.t -> (string * 'a) list -> 'a t val enumerated : ?accept_unique_prefixes:bool -> ?case_sensitive:bool -> ?list_values_in_help:bool -> ?auto_complete:Auto_complete.t -> ?key:'a Env.Multi.Key.t -> (module Enumerable_stringable with type t = 'a) -> 'a t val enumerated_sexpable : ?accept_unique_prefixes:bool -> ?case_sensitive:bool -> ?list_values_in_help:bool -> ?auto_complete:Auto_complete.t -> ?key:'a Env.Multi.Key.t -> (module Enumerable_sexpable with type t = 'a) -> 'a t val comma_separated : ?allow_empty:bool -> ?key:'a list Env.Multi.Key.t -> ?strip_whitespace:bool -> ?unique_values:bool -> 'a t -> 'a list t module Export : sig val string : string t val int : int t val char : char t val float : float t val bool : bool t val date : Date.t t val percent : Percent.t t val host_and_port : Host_and_port.t t val sexp : Sexp.t t val sexp_conv : ?complete:Auto_complete.t -> (Sexp.t -> 'a) -> 'a t end module For_testing : sig val complete : _ t -> Auto_complete.t val parse : 'a t -> string -> 'a Or_error.t end end = struct type 'a t = { parse : string -> 'a ; complete : Completer.t ; key : 'a Univ_map.Multi.Key.t option ; extra_doc : string option Lazy.t } [@@deriving fields] let parse t s = Result.try_with (fun () -> t.parse s) let create' ?complete ?key parse ~extra_doc = { parse; key; complete; extra_doc } let create ?complete ?key of_string = create' ?complete ?key of_string ~extra_doc:(Lazy.from_val None) ;; let map ?key t ~f = { t with key; parse = (fun s -> f (t.parse s)) } let of_lazy ?key t = let parse str = (force t).parse str in let complete env ~part = match (force t).complete with | None -> (* See [run_and_exit] - no completions is equivalent to not having a [Complete]. *) [] | Some complete -> complete env ~part in let extra_doc = Lazy.bind t ~f:extra_doc in { parse; complete = Some complete; key; extra_doc } ;; let string = create Fn.id let int = create Int.of_string let char = create Char.of_string let float = create Float.of_string let date = create Date.of_string let percent = create Percent.of_string let host_and_port = create Host_and_port.of_string let sexp = create Sexp.of_string let sexp_conv ?complete of_sexp = create ?complete (fun s -> of_sexp (Sexp.of_string s)) let associative ?(accept_unique_prefixes = true) ?(list_values_in_help = true) ?auto_complete ?key ~case_sensitive alist = let open struct module type S = sig include Comparator.S with type t = string val is_prefix : string -> prefix:string -> bool end type 'a t = | T : { cmp : (module S with type comparator_witness = 'cmp) ; map : (string, 'a, 'cmp) Map.t } -> 'a t end in let (T { cmp = (module S); map }) = let make_map_raise_duplicate_key (type cmp) (module S : S with type comparator_witness = cmp) alist = match Map.of_alist (module S) alist with | `Ok map -> map | `Duplicate_key (_ : S.t) -> let duplicate_keys = List.map alist ~f:(fun (k, (_ : 'a)) -> k, k) |> Map.of_alist_multi (module S) |> Map.filter ~f:(function | [] | [ _ ] -> false | _ :: _ :: _ -> true) |> Map.data in raise_s [%message "Command.Spec.Arg_type.of_alist_exn" (duplicate_keys : string list list)] in let make cmp = T { cmp; map = make_map_raise_duplicate_key cmp alist } in if case_sensitive then make (module String) else make (module String.Caseless) in let complete univ_map ~part:prefix = match auto_complete with | Some complete -> complete univ_map ~part:prefix | None -> List.filter_map (Map.to_alist map) ~f:(fun (name, _) -> match S.is_prefix name ~prefix with | false -> None | true -> (* Bash completion will not accept [Foo] as a completion for [f]. So we need to match the capitalization given. *) let suffix = String.subo name ~pos:(String.length prefix) in let name = prefix ^ suffix in Some name) in let find arg = match Map.find map arg with | Some _ as s -> s | None -> (match accept_unique_prefixes with | false -> None | true -> (match Map.to_alist map |> List.filter ~f:(fun (name, _) -> S.is_prefix name ~prefix:arg) with | [ (_singleton_key, v) ] -> Some v | [] | _ :: _ :: _ -> (* In the two-or-more case we could provide filtered help text, but it's more generally useful to list all the options, which we do below. *) None)) in create' ~extra_doc: (lazy (if list_values_in_help then ( let values = String.concat ~sep:", " (Map.keys map) in Some [%string "(can be: %{values})"]) else None)) ?key ~complete (fun arg -> match find arg with | Some v -> v | None -> let valid_arguments_extra = if case_sensitive then "" else " (case insensitive)" in failwithf "valid arguments%s: {%s}" valid_arguments_extra (String.concat ~sep:"," (Map.keys map)) ()) ;; let of_alist_exn ?accept_unique_prefixes ?(case_sensitive = true) ?list_values_in_help ?auto_complete ?key alist = associative ?accept_unique_prefixes ?list_values_in_help ?auto_complete ?key ~case_sensitive alist ;; let of_map ?accept_unique_prefixes ?case_sensitive ?list_values_in_help ?auto_complete ?key map = of_alist_exn ?accept_unique_prefixes ?case_sensitive ?list_values_in_help ?auto_complete ?key (Map.to_alist map) ;; let enumerated (type t) ?accept_unique_prefixes ?case_sensitive ?list_values_in_help ?auto_complete ?key (module E : Enumerable_stringable with type t = t) = of_alist_exn ?accept_unique_prefixes ?case_sensitive ?list_values_in_help ?auto_complete ?key (let%map.List t = E.all in E.to_string t, t) ;; let enumerated_sexpable (type t) ?accept_unique_prefixes ?case_sensitive ?list_values_in_help ?auto_complete ?key (module E : Enumerable_sexpable with type t = t) = enumerated ?accept_unique_prefixes ?case_sensitive ?list_values_in_help ?auto_complete ?key (module struct include E let to_string t = Sexp.to_string [%sexp (t : E.t)] end) ;; let bool = enumerated ~list_values_in_help:false (module Bool) let comma_separated ?(allow_empty = false) ?key ?(strip_whitespace = false) ?(unique_values = false) t = let strip = if strip_whitespace then fun str -> String.strip str else Fn.id in let complete = Option.map t.complete ~f:(fun complete_elt env ~part -> let prefixes, suffix = match String.split part ~on:',' |> List.rev with | [] -> [], part | hd :: tl -> List.rev tl, hd in let is_allowed = if not unique_values then fun (_ : string) -> true else ( let seen_already = prefixes |> List.map ~f:strip |> String.Set.of_list in fun choice -> not (Set.mem seen_already (strip choice))) in let choices = match List.filter (complete_elt env ~part:suffix) ~f:(fun choice -> (not (String.mem choice ',')) && is_allowed choice) with (* If there is exactly one choice to auto-complete, add a second choice with a trailing comma so that auto-completion will go to the end but bash won't add a space. If there are multiple choices, or a single choice that must be final, there is no need to add a dummy option. *) | [ choice ] -> [ choice; choice ^ "," ] | choices -> choices in List.map choices ~f:(fun choice -> String.concat ~sep:"," (prefixes @ [ choice ]))) in let of_string string = let string = strip string in if String.is_empty string then if allow_empty then [] else failwith "Command.Spec.Arg_type.comma_separated: empty list not allowed" else List.map (String.split string ~on:',') ~f:(fun str -> t.parse (strip str)) in create ?key ?complete of_string ;; module Export = struct let string = string let int = int let char = char let float = float let bool = bool let date = date let percent = percent let host_and_port = host_and_port let sexp = sexp let sexp_conv = sexp_conv end module For_testing = struct let complete t = match t.complete with | Some f -> f | None -> fun _ ~part:_ -> [] ;; let parse t str = parse t str |> Or_error.of_exn_result end end module Flag = struct module Num_occurrences = struct type t = Shape.Num_occurrences.t = { at_least_once : bool ; at_most_once : bool } [@@deriving compare, enumerate, fields, sexp_of] let to_help_string = Shape.Num_occurrences.to_help_string let to_help_string_deprecated { at_least_once; at_most_once = _ } flag_name = to_help_string { at_least_once; at_most_once = true } ~flag_name ;; let any = { at_least_once = false; at_most_once = false } let at_least_once = { at_least_once = true; at_most_once = false } let at_most_once = { at_least_once = false; at_most_once = true } let exactly_once = { at_least_once = true; at_most_once = true } end type action = | No_arg of (Env.t -> Env.t) | Print_info_and_quit of (Env.t -> string) | Arg of (Env.t -> string -> Env.t) * Completer.t | Rest of (Env.t -> string list -> Env.t) module Internal = struct type t = { name : string ; aliases : string list ; aliases_excluded_from_help : string list (* [aliases_excluded_from_help] are aliases that don't show up in -help output. Currently they're only used for double-dash built-in flags like --help and --version. *) ; action : action ; doc : string ; num_occurrences : Num_occurrences.t ; check_available : Env.t -> unit ; name_matching : [ `Prefix | `Full_match_required ] } let wrap_if_optional t flag_name = Num_occurrences.to_help_string t.num_occurrences ~flag_name ;; module Doc = struct type t = { arg_doc : string option ; doc : string } let parse ~action ~doc = let arg_doc, doc = match (action : action), String.lsplit2 doc ~on:' ' with | (No_arg _ | Print_info_and_quit _), _ -> None, doc | Arg _, (None | Some ("", _)) -> Some "_", doc | Rest _, (None | Some ("", _)) -> None, doc | (Arg _ | Rest _), Some (arg, doc) -> Some arg, doc in { doc = String.strip doc; arg_doc } ;; let concat ~name ~arg_doc = match arg_doc with | None -> name | Some arg_doc -> name ^ " " ^ arg_doc ;; end module Deprecated = struct let wrap_if_optional t x = Num_occurrences.to_help_string_deprecated t.num_occurrences x ;; (* flag help in the format of the old command. used for injection *) let help ({ name ; doc ; aliases ; action ; num_occurrences = _ ; check_available = _ ; name_matching = _ ; aliases_excluded_from_help = _ } as t) = if String.is_prefix doc ~prefix:" " then (name, String.lstrip doc) :: List.map aliases ~f:(fun x -> x, sprintf "same as \"%s\"" name) else ( let { Doc.arg_doc; doc } = Doc.parse ~action ~doc in (wrap_if_optional t (Doc.concat ~name ~arg_doc), doc) :: List.map aliases ~f:(fun x -> ( wrap_if_optional t (Doc.concat ~name:x ~arg_doc) , sprintf "same as \"%s\"" name ))) ;; end let align ({ name ; doc ; aliases ; action ; num_occurrences = _ ; check_available = _ ; name_matching = _ ; aliases_excluded_from_help = _ } as t) : Shape.Flag_info.t = let { Doc.arg_doc; doc } = Doc.parse ~action ~doc in let name = wrap_if_optional t (Doc.concat ~name ~arg_doc) in { name; doc; aliases } ;; let create flags = match String.Map.of_alist (List.map flags ~f:(fun flag -> flag.name, flag)) with | `Duplicate_key flag -> failwithf "multiple flags named %s" flag () | `Ok map -> List.concat_map flags ~f:(fun flag -> flag.name :: flag.aliases) |> List.find_a_dup ~compare:[%compare: string] |> Option.iter ~f:(fun x -> failwithf "multiple flags or aliases named %s" x ()); map ;; end type 'a state = { action : action ; read : Env.t -> 'a ; num_occurrences : Num_occurrences.t ; extra_doc : string option Lazy.t } type 'a t = string -> 'a state let arg_flag name arg_type read write num_occurrences = { read ; num_occurrences ; action = (let update env arg = match Arg_type.parse arg_type arg with | Error exn -> die "failed to parse %s value %S.\n%s" name arg (Exn.to_string exn) () | Ok arg -> let env = write env arg in (match Arg_type.key arg_type with | None -> env | Some key -> Env.multi_add env ~key ~data:arg) in Arg (update, Arg_type.complete arg_type)) ; extra_doc = Arg_type.extra_doc arg_type } ;; let map_flag t ~f input = let { action; read; num_occurrences; extra_doc } = t input in { action; read = (fun env -> f (read env)); num_occurrences; extra_doc } ;; let write_option name key env arg = Env.update env key ~f:(function | None -> arg | Some _ -> die "flag %s passed more than once" name ()) ;; let required_value ?default arg_type name num_occurrences = let key = Env.Key.create ~name [%sexp_of: _] in let read env = match Env.find env key with | Some v -> v | None -> (match default with | Some v -> v | None -> die "missing required flag: %s" name ()) in let write env arg = write_option name key env arg in arg_flag name arg_type read write num_occurrences ;; let required arg_type name = required_value arg_type name Num_occurrences.exactly_once let optional_with_default default arg_type name = required_value ~default arg_type name Num_occurrences.at_most_once ;; let optional arg_type name = let key = Env.Key.create ~name [%sexp_of: _] in let read env = Env.find env key in let write env arg = write_option name key env arg in arg_flag name arg_type read write Num_occurrences.at_most_once ;; let no_arg_general ~key_value ~deprecated_hook name = let key = Env.Key.create ~name [%sexp_of: unit] in let read env = Env.mem env key in let write env = if Env.mem env key then die "flag %s passed more than once" name () else Env.set env ~key ~data:() in let action env = let env = Option.fold key_value ~init:env ~f:(fun env (key, value) -> Env.set_with_default env ~key ~data:value) in write env in let action = match deprecated_hook with | None -> action | Some f -> fun env -> let env = action env in f (); env in { read ; action = No_arg action ; num_occurrences = Num_occurrences.at_most_once ; extra_doc = Lazy.from_val None } ;; let no_arg name = no_arg_general name ~key_value:None ~deprecated_hook:None let no_arg_register ~key ~value name = no_arg_general name ~key_value:(Some (key, value)) ~deprecated_hook:None ;; let no_arg_some value = map_flag no_arg ~f:(function | true -> Some value | false -> None) ;; let listed arg_type name = let key = Env.With_default.Key.create ~default:[] ~name [%sexp_of: _ list] in let read env = List.rev (Env.With_default.find env key) in let write env arg = Env.With_default.change env key ~f:(fun list -> arg :: list) in arg_flag name arg_type read write Num_occurrences.any ;; let one_or_more_as_pair arg_type name = let key = Env.With_default.Key.create ~default:Fqueue.empty ~name [%sexp_of: _ Fqueue.t] in let read env = match Fqueue.to_list (Env.With_default.find env key) with | first :: rest -> first, rest | [] -> die "missing required flag: %s" name () in let write env arg = Env.With_default.change env key ~f:(fun q -> Fqueue.enqueue q arg) in arg_flag name arg_type read write Num_occurrences.at_least_once ;; let[@deprecated "[since 2021-07] Use [one_or_more_as_pair] or [one_or_more_as_list]"] one_or_more = one_or_more_as_pair ;; let one_or_more_as_list arg_type = one_or_more_as_pair arg_type |> map_flag ~f:(fun (x, xs) -> x :: xs) ;; let escape_general ~deprecated_hook name = let key = Env.Key.create ~name [%sexp_of: string list] in let action env cmd_line = Env.set env ~key ~data:cmd_line in let read env = Env.find env key in let action = match deprecated_hook with | None -> action | Some f -> fun env x -> f x; action env x in { action = Rest action ; read ; num_occurrences = Num_occurrences.at_most_once ; extra_doc = Lazy.from_val None } ;; let no_arg_abort ~exit _name = { action = No_arg (fun _ -> never_returns (exit ())) ; num_occurrences = Num_occurrences.at_most_once ; read = (fun _ -> ()) ; extra_doc = Lazy.from_val None } ;; let escape name = escape_general ~deprecated_hook:None name module Deprecated = struct let no_arg ~hook name = no_arg_general ~deprecated_hook:(Some hook) ~key_value:None name ;; let escape ~hook = escape_general ~deprecated_hook:(Some hook) end end module Path : sig type t val empty : t val create : path_to_exe:string -> t val of_parts : string list -> t val append : t -> subcommand:string -> t val replace_first : t -> from:string -> to_:string -> t val parts : t -> string list val parts_exe_basename : t -> string list val to_string : t -> string val to_string_dots : t -> string val pop_help : t -> t val length : t -> int val is_empty : t -> bool end = struct type t = string list let empty = [] let create ~path_to_exe = [ path_to_exe ] let of_parts parts = List.rev parts let append t ~subcommand = subcommand :: t let parts = List.rev let parts_exe_basename t = match List.rev t with | [] -> [] | hd :: tl -> Filename.basename hd :: tl ;; let to_string t = unwords (parts_exe_basename t) let length = List.length let replace_first t ~from ~to_ = let rec aux parts ~acc ~from ~to_ = match parts with | [] -> acc | hd :: tl -> if String.( = ) hd from then List.rev_append tl (to_ :: acc) else aux tl ~acc:(hd :: acc) ~from ~to_ in aux (parts t) ~acc:[] ~from ~to_ ;; let pop_help = function | "help" :: t -> t | _ -> assert false ;; let to_string_dots t = (match t with | [] -> [] | last :: init -> last :: List.map init ~f:(Fn.const ".")) |> to_string ;; let is_empty = List.is_empty end module Anons = struct module Grammar : sig type t = Shape.Anons.Grammar.t val zero : t val one : string -> t val many : t -> t val maybe : t -> t val concat : t list -> t val ad_hoc : usage:string -> t include Invariant.S with type t := t val names : t -> string list end = struct type t = Shape.Anons.Grammar.t = | Zero | One of string | Many of t | Maybe of t | Concat of t list | Ad_hoc of string let invariant = Shape.Anons.Grammar.invariant let usage = Shape.Anons.Grammar.usage let rec is_fixed_arity = function | Zero -> true | One _ -> true | Many _ -> false | Maybe _ -> false | Ad_hoc _ -> false | Concat ts -> (match List.rev ts with | [] -> failwith "bug in command.ml" | last :: others -> assert (List.for_all others ~f:is_fixed_arity); is_fixed_arity last) ;; let rec names = function | Zero -> [] | One s -> [ s ] | Many t -> names t | Maybe t -> names t | Ad_hoc s -> [ s ] | Concat ts -> List.concat_map ts ~f:names ;; let zero = Zero let one name = One name let many = function | Zero -> Zero (* strange, but not non-sense *) | t -> if not (is_fixed_arity t) then failwithf "iteration of variable-length grammars such as %s is disallowed" (usage t) (); Many t ;; let maybe = function | Zero -> Zero (* strange, but not non-sense *) | t -> Maybe t ;; let concat = function | [] -> Zero | car :: cdr -> let car, cdr = List.fold cdr ~init:(car, []) ~f:(fun (t1, acc) t2 -> match t1, t2 with | Zero, t | t, Zero -> t, acc | _, _ -> if is_fixed_arity t1 then t2, t1 :: acc else failwithf "the grammar %s for anonymous arguments is not supported because \ there is the possibility for arguments (%s) following a variable \ number of arguments (%s). Supporting such grammars would \ complicate the implementation significantly." (usage (Concat (List.rev (t2 :: t1 :: acc)))) (usage t2) (usage t1) ()) in (match cdr with | [] -> car | _ :: _ -> Concat (List.rev (car :: cdr))) ;; let ad_hoc ~usage = Ad_hoc usage end module Parser : sig type +'a t val from_env : (Env.t -> 'a) -> 'a t val one : name:string -> 'a Arg_type.t -> 'a t val maybe : 'a t -> 'a option t val sequence : 'a t -> 'a list t val stop_parsing : 'a t -> 'a t val final_value : 'a t -> Env.t -> 'a module Consume_result : sig type nonrec 'a t = { (* If emacs highlights [parser] as if it were a keyword, that's only because [parser] was a keyword in camlp4. [parser] is a regular name in OCaml. *) parser : 'a t ; parse_flags : bool ; update_env : Env.t -> Env.t } end val consume : 'a t -> string -> for_completion:bool -> 'a Consume_result.t val complete : 'a t -> Env.t -> part:string -> never_returns module For_opening : sig val return : 'a -> 'a t val ( <*> ) : ('a -> 'b) t -> 'a t -> 'b t val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t end end = struct type 'a t = | Done of (Env.t -> 'a) | More of 'a more (* A [Test] will (generally) return a [Done _] value if there is no more input and a [More] parser to use if there is any more input. *) | Test of (more:bool -> 'a t) (* If we're only completing, we can't pull values out, but we can still step through [t]s (which may have completion set up). *) | Only_for_completion of packed list | Stop_parsing of 'a t and 'a more = { name : string ; parse : string -> for_completion:bool -> 'a parse_result ; complete : Completer.t } and packed = Packed : 'a t -> packed and 'a parse_result = { parser : 'a t ; update_env : Env.t -> Env.t } let return a = Done (fun _ -> a) let from_env f = Done f let stop_parsing t = Stop_parsing t let pack_for_completion = function | Done _ -> [] (* won't complete or consume anything *) | (More _ | Test _ | Stop_parsing _) as x -> [ Packed x ] | Only_for_completion ps -> ps ;; let parse_more { name; parse; complete } ~f = let parse arg ~for_completion = let { parser; update_env } = parse arg ~for_completion in { parser = f parser; update_env } in More { name; parse; complete } ;; let rec ( <*> ) t_left t_right = match t_left, t_right with (* [Done] *) | Done f, Done x -> Done (fun env -> f env (x env)) (* next step [More] *) | More more, _ -> parse_more more ~f:(fun tl -> tl <*> t_right) | Done _, More more -> parse_more more ~f:(fun tr -> t_left <*> tr) (* next step [Only_for_completion] *) | Only_for_completion _, _ | Done _, Only_for_completion _ -> Only_for_completion (pack_for_completion t_left @ pack_for_completion t_right) (* next step [Stop_parsing] *) | Stop_parsing tl, tr | (Done _ as tl), Stop_parsing tr -> Stop_parsing (tl <*> tr) (* next step [Test] *) | Test test, _ -> Test (fun ~more -> test ~more <*> t_right) | Done _, Test test -> Test (fun ~more -> t_left <*> test ~more) ;; let ( >>| ) t f = return f <*> t let one_more ~name arg_type = let parse anon ~for_completion = match Arg_type.parse arg_type anon with | Error exn -> if for_completion then (* we don't *really* care about this value, so just put in a dummy value so completion can continue *) { parser = Only_for_completion []; update_env = Fn.id } else die "failed to parse %s value %S\n%s" name anon (Exn.to_string exn) () | Ok v -> { parser = return v ; update_env = (fun env -> Option.fold (Arg_type.key arg_type) ~init:env ~f:(fun env key -> Env.multi_add env ~key ~data:v)) } in More { name; parse; complete = Arg_type.complete arg_type } ;; let one ~name arg_type = Test (fun ~more -> if more then one_more ~name arg_type else die "missing anonymous argument: %s" name ()) ;; let maybe t = Test (fun ~more -> if more then t >>| fun a -> Some a else return None) let sequence t = let rec loop = Test (fun ~more -> if more then return (fun v acc -> v :: acc) <*> t <*> loop else return []) in loop ;; let rec final_value t env = match t with | Done a -> a env | Stop_parsing t -> final_value t env | Test f -> final_value (f ~more:false) env | More { name; _ } -> die "missing anonymous argument: %s" name () | Only_for_completion _ -> failwith "BUG: asked for final value when doing completion" ;; module Consume_result = struct type nonrec 'a t = { parser : 'a t ; parse_flags : bool ; update_env : Env.t -> Env.t } end let rec consume : type a. a t -> string -> for_completion:bool -> a Consume_result.t = fun t arg ~for_completion -> match t with | Done _ -> die "too many anonymous arguments" () | Test f -> consume (f ~more:true) arg ~for_completion | More { parse; _ } -> let { parser; update_env } = parse arg ~for_completion in { parser; parse_flags = true; update_env } | Stop_parsing t -> { (consume t arg ~for_completion) with parse_flags = false } | Only_for_completion packed -> (match packed with | [] -> { parser = Only_for_completion []; parse_flags = true; update_env = Fn.id } | Packed t :: rest -> let ({ update_env; parse_flags; parser } : _ Consume_result.t) = consume t arg ~for_completion in { update_env ; parse_flags ; parser = Only_for_completion (pack_for_completion parser @ rest) }) ;; let rec complete : type a. a t -> Env.t -> part:string -> never_returns = fun t env ~part -> match t with | Done _ -> exit 0 | Test f -> complete (f ~more:true) env ~part | More { complete; _ } -> Completer.run_and_exit complete env ~part | Stop_parsing t -> complete t env ~part | Only_for_completion t -> (match t with | [] -> exit 0 | Packed t :: _ -> complete t env ~part) ;; module For_opening = struct let return = return let ( <*> ) = ( <*> ) let ( >>| ) = ( >>| ) end end open Parser.For_opening type 'a t = { p : 'a Parser.t ; grammar : Grammar.t } let t2 t1 t2 = { p = return (fun a1 a2 -> a1, a2) <*> t1.p <*> t2.p ; grammar = Grammar.concat [ t1.grammar; t2.grammar ] } ;; let t3 t1 t2 t3 = { p = return (fun a1 a2 a3 -> a1, a2, a3) <*> t1.p <*> t2.p <*> t3.p ; grammar = Grammar.concat [ t1.grammar; t2.grammar; t3.grammar ] } ;; let t4 t1 t2 t3 t4 = { p = return (fun a1 a2 a3 a4 -> a1, a2, a3, a4) <*> t1.p <*> t2.p <*> t3.p <*> t4.p ; grammar = Grammar.concat [ t1.grammar; t2.grammar; t3.grammar; t4.grammar ] } ;; let normalize str = (* Verify the string is not empty or surrounded by whitespace *) let strlen = String.length str in if strlen = 0 then failwith "Empty anonymous argument name provided"; if String.( <> ) (String.strip str) str then failwithf "argument name %S has surrounding whitespace" str (); (* If the string contains special surrounding characters, don't do anything *) let has_special_chars = let special_chars = Char.Set.of_list [ '<'; '>'; '['; ']'; '('; ')'; '{'; '}' ] in String.exists str ~f:(Set.mem special_chars) in if has_special_chars then str else String.uppercase str ;; let ( %: ) name arg_type = let name = normalize name in { p = Parser.one ~name arg_type; grammar = Grammar.one name } ;; let map_anons t ~f = { p = t.p >>| f; grammar = t.grammar } let maybe t = { p = Parser.maybe t.p; grammar = Grammar.maybe t.grammar } let maybe_with_default default t = let t = maybe t in { t with p = (t.p >>| fun v -> Option.value ~default v) } ;; let sequence t = { p = Parser.sequence t.p; grammar = Grammar.many t.grammar } let non_empty_sequence_as_pair t = t2 t (sequence t) let non_empty_sequence_as_list t = let t = non_empty_sequence_as_pair t in { t with p = (t.p >>| fun (x, xs) -> x :: xs) } ;; let escape t = { p = Parser.stop_parsing t.p; grammar = t.grammar } module Deprecated = struct let ad_hoc ~usage_arg = { p = Parser.sequence (Parser.one ~name:"WILL NEVER BE PRINTED" Arg_type.Export.string) ; grammar = Grammar.ad_hoc ~usage:usage_arg } ;; end end module Cmdline = struct type t = | Nil | Cons of string * t | Complete of string [@@deriving compare] let of_list args = List.fold_right args ~init:Nil ~f:(fun arg args -> Cons (arg, args)) let rec to_list = function | Nil -> [] | Cons (x, xs) -> x :: to_list xs | Complete x -> [ x ] ;; let rec ends_in_complete = function | Complete _ -> true | Nil -> false | Cons (_, args) -> ends_in_complete args ;; let extend t ~extend ~path = if ends_in_complete t then t else ( let path_list = Option.value ~default:[] (List.tl (Path.parts path)) in of_list (to_list t @ extend path_list)) ;; end module Key_type = Shape.Private.Key_type let assert_no_underscores key_type flag_or_subcommand = if String.exists flag_or_subcommand ~f:(fun c -> Char.( = ) c '_') then failwithf "%s %s contains an underscore. Use a dash instead." (Key_type.to_string key_type) flag_or_subcommand () ;; let normalize key_type key = assert_no_underscores key_type key; match key_type with | Key_type.Flag -> if String.equal key "-" then failwithf !"invalid %{Key_type} name: %S" key_type key (); if String.exists key ~f:Char.is_whitespace then failwithf !"invalid %{Key_type} name (contains whitespace): %S" key_type key (); if String.is_prefix ~prefix:"-" key then key else "-" ^ key | Key_type.Subcommand -> String.lowercase key ;; let lookup_expand = Shape.Private.lookup_expand let lookup_expand_with_aliases map prefix key_type = let alist = List.concat_map (String.Map.data map) ~f:(fun flag -> let { Flag.Internal.name ; aliases ; aliases_excluded_from_help ; action = _ ; doc = _ ; num_occurrences = _ ; check_available = _ ; name_matching } = flag in let data = flag, name_matching in let aliases = aliases_excluded_from_help @ aliases in (name, data) :: List.map aliases ~f:(fun alias -> alias, data)) in match List.find_a_dup alist ~compare:(fun (s1, _) (s2, _) -> String.compare s1 s2) with | None -> lookup_expand alist prefix key_type | Some (flag, _) -> failwithf "multiple flags named %s" flag () ;; module Base = struct type t = { summary : string ; readme : (unit -> string) option ; flags : Flag.Internal.t String.Map.t ; anons : unit -> ([ `Parse_args ] -> [ `Run_main ] -> unit) Anons.Parser.t ; usage : Anons.Grammar.t } module Deprecated = struct let subcommand_cmp_fst (a, _) (c, _) = help_screen_compare a c let flags_help ?(display_help_flags = true) t = let flags = String.Map.data t.flags in let flags = if display_help_flags then flags else List.filter flags ~f:(fun f -> String.( <> ) f.name "-help") in List.concat_map ~f:Flag.Internal.Deprecated.help flags ;; end let formatted_flags t = String.Map.data t.flags |> List.map ~f:Flag.Internal.align (* this sort puts optional flags after required ones *) |> List.sort ~compare:(fun a b -> String.compare a.name b.name) |> Shape.Flag_help_display.sort ;; let shape t : Shape.Base_info.t = { summary = t.summary ; readme = Option.map t.readme ~f:(fun readme -> readme ()) ; anons = Grammar t.usage ; flags = formatted_flags t } ;; let path_key = Env.key_create "path" let args_key = Env.key_create "args" let help_key = Env.key_create "help" let indent_by_2 str = String.split ~on:'\n' str |> List.map ~f:(fun line -> " " ^ line) |> String.concat ~sep:"\n" ;; let get_flag_and_action t arg = match lookup_expand_with_aliases t.flags arg Flag with | Error msg -> die "%s" msg () | Ok (flag_name, flag) -> flag_name, flag.action ;; let run_flag t env arg (args : Cmdline.t) = let flag, action = get_flag_and_action t arg in match action with | Print_info_and_quit info -> let completing = Cmdline.ends_in_complete args in (* If we're doing completion, version/help info aren't useful completion responses. *) if completing then env, args else ( print_endline (info env); exit 0) | No_arg f -> f env, args | Arg (f, comp) -> (match args with | Nil -> die "missing argument for flag %s" flag () | Cons (arg, rest) -> let env = try f env arg with | Failed_to_parse_command_line _ as e -> if Cmdline.ends_in_complete rest then env else raise e in env, rest | Complete part -> never_returns (Completer.run_and_exit comp env ~part)) | Rest f -> if Cmdline.ends_in_complete args then exit 0; f env (Cmdline.to_list args), Nil ;; let rec run_cmdline t env parser (cmdline : Cmdline.t) ~for_completion ~parse_flags = match cmdline with | Nil -> List.iter (String.Map.data t.flags) ~f:(fun flag -> flag.check_available env); Anons.Parser.final_value parser env | Complete part -> if parse_flags && String.is_prefix part ~prefix:"-" then ( List.iter (String.Map.keys t.flags) ~f:(fun name -> if String.is_prefix name ~prefix:part then print_endline name); exit 0) else never_returns (Anons.Parser.complete parser env ~part) | Cons (arg, args) -> let arg, args, arg_is_flag = match parse_flags with | false -> arg, args, false | true -> (match arg, args with (* the '-anon' flag is here as an escape hatch in case you have an anonymous argument that starts with a hyphen. *) | "-anon", Cons (arg, args) -> arg, args, false (* support the common Unix convention where "-" means stdin *) | "-", _ -> arg, args, false | _, _ -> arg, args, String.is_prefix arg ~prefix:"-") in (match arg_is_flag with | true -> let env, args = run_flag t env arg args in run_cmdline t env parser args ~parse_flags ~for_completion | false -> let parse_flags1 = parse_flags in let ({ parser; parse_flags = parse_flags2; update_env } : _ Anons.Parser.Consume_result.t) = Anons.Parser.consume parser arg ~for_completion in let env = update_env env in let parse_flags = parse_flags1 && parse_flags2 in run_cmdline t env parser ~parse_flags args ~for_completion) ;; let run_exn exn ~for_completion ~path ~verbose_on_parse_error = match exn with | Failed_to_parse_command_line _ when for_completion -> exit 0 | Exit_called { status } -> exit status | _ -> let exn_str = match exn with | Failed_to_parse_command_line msg -> msg | _ -> Sexp.to_string_hum [%sexp (exn : exn)] in let verbose = Option.value verbose_on_parse_error ~default:true in let error_msg = if verbose then String.concat ~sep:"\n\n" [ "Error parsing command line:" ; indent_by_2 exn_str ; "For usage information, run" ; " " ^ Path.to_string path ^ " -help\n" ] else exn_str in prerr_endline error_msg; exit 1 ;; let run t env ~when_parsing_succeeds ~path ~args ~verbose_on_parse_error ~help_text = let for_completion = Cmdline.ends_in_complete args in let env = env |> Env.set ~key:path_key ~data:path |> Env.set ~key:args_key ~data:(Cmdline.to_list args) |> Env.set ~key:help_key ~data:help_text in match Result.try_with (fun () -> run_cmdline t env (t.anons ()) ~for_completion ~parse_flags:true args `Parse_args) with | Ok thunk -> when_parsing_succeeds (); thunk `Run_main | Error exn -> run_exn exn ~for_completion ~path ~verbose_on_parse_error ;; module Spec = struct type ('a, 'b) t = { f : unit -> ('a -> 'b) Anons.Parser.t ; usage : unit -> Anons.Grammar.t ; flags : unit -> Flag.Internal.t list } (* the (historical) reason that [param] is defined in terms of [t] rather than the other way round is that the delayed evaluation mattered for sequencing of read/write operations on ref cells in the old representation of flags *) type 'a param = { param : 'm. ('a -> 'm, 'm) t } open Anons.Parser.For_opening let app t1 t2 ~f = { f = (fun () -> return f <*> t1.f () <*> t2.f ()) ; flags = (fun () -> t2.flags () @ t1.flags ()) ; usage = (fun () -> Anons.Grammar.concat [ t1.usage (); t2.usage () ]) } ;; (* So sad. We can't define [apply] in terms of [app] because of the value restriction. *) let apply pf px = { param = { f = (fun () -> return (fun mf mx k -> mf (fun f -> mx (fun x -> k (f x)))) <*> pf.param.f () <*> px.param.f ()) ; flags = (fun () -> px.param.flags () @ pf.param.flags ()) ; usage = (fun () -> Anons.Grammar.concat [ pf.param.usage (); px.param.usage () ]) } } ;; let ( ++ ) t1 t2 = app t1 t2 ~f:(fun f1 f2 x -> f2 (f1 x)) let ( +> ) t1 p2 = app t1 p2.param ~f:(fun f1 f2 x -> f2 (f1 x)) let ( +< ) t1 p2 = app p2.param t1 ~f:(fun f2 f1 x -> f1 (f2 x)) let step f = { f = (fun () -> return f) ; flags = (fun () -> []) ; usage = (fun () -> Anons.Grammar.zero) } ;; let empty : 'm. ('m, 'm) t = { f = (fun () -> return Fn.id) ; flags = (fun () -> []) ; usage = (fun () -> Anons.Grammar.zero) } ;; let const v = { param = { f = (fun () -> return (fun k -> k v)) ; flags = (fun () -> []) ; usage = (fun () -> Anons.Grammar.zero) } } ;; let map p ~f = { param = { f = (fun () -> p.param.f () >>| fun c k -> c (fun v -> k (f v))) ; flags = p.param.flags ; usage = p.param.usage } } ;; let wrap f t = { f = (fun () -> t.f () >>| fun run main -> f ~run ~main) ; flags = t.flags ; usage = t.usage } ;; let of_params params = let t = params.param in { f = (fun () -> t.f () >>| fun run main -> run Fn.id main) ; flags = t.flags ; usage = t.usage } ;; let to_params (t : ('a, 'b) t) : ('a -> 'b) param = { param = { f = (fun () -> t.f () >>| fun f k -> k f); flags = t.flags; usage = t.usage } } ;; let of_param p = p.param let to_param t main = map (to_params t) ~f:(fun k -> k main) let lookup key = { param = { f = (fun () -> Anons.Parser.from_env (fun env m -> m (Env.find_exn env key))) ; flags = (fun () -> []) ; usage = (fun () -> Anons.Grammar.zero) } } ;; let path : Path.t param = lookup path_key let args : string list param = lookup args_key let help : string Lazy.t param = lookup help_key (* This is only used internally, for the help command. *) let env = { param = { f = (fun () -> Anons.Parser.from_env (fun env m -> m env)) ; flags = (fun () -> []) ; usage = (fun () -> Anons.Grammar.zero) } } ;; include struct module Arg_type = Arg_type include Arg_type.Export end include struct open Anons type 'a anons = 'a t let ( %: ) = ( %: ) let map_anons = map_anons let maybe = maybe let maybe_with_default = maybe_with_default let sequence = sequence let non_empty_sequence_as_pair = non_empty_sequence_as_pair let non_empty_sequence_as_list = non_empty_sequence_as_list let t2 = t2 let t3 = t3 let t4 = t4 let anon spec = Anons.Grammar.invariant spec.grammar; { param = { f = (fun () -> spec.p >>| fun v k -> k v) ; flags = (fun () -> []) ; usage = (fun () -> spec.grammar) } } ;; end let escape_anon ~final_anon = Anons.escape (t2 final_anon (sequence ("ARG" %: string))) |> anon ;; include struct open Flag type 'a flag = 'a t let map_flag = map_flag let escape = escape let listed = listed let one_or_more = one_or_more let one_or_more_as_pair = one_or_more_as_pair let one_or_more_as_list = one_or_more_as_list let no_arg = no_arg let no_arg_register = no_arg_register let no_arg_abort = no_arg_abort let no_arg_some = no_arg_some let optional = optional let optional_with_default = optional_with_default let required = required let flag_internal ?(aliases = []) ?full_flag_required name mode ~doc ~aliases_excluded_from_help = let normalize flag = normalize Key_type.Flag flag in let name = normalize name in let aliases = List.map ~f:normalize aliases in let { read; action; num_occurrences; extra_doc } = mode name in let check_available = match num_occurrences.at_least_once with | false -> (ignore : Univ_map.t -> unit) | true -> fun env -> ignore (read env : _) in let name_matching = if Option.is_some full_flag_required then `Full_match_required else `Prefix in { param = { f = (fun () -> Anons.Parser.from_env (fun env m -> m (read env))) ; flags = (fun () -> [ { name ; aliases ; aliases_excluded_from_help ; doc = (match force extra_doc with | Some extra_doc -> [%string "%{doc} %{extra_doc}"] | None -> doc) ; action ; num_occurrences ; check_available ; name_matching } ]) ; usage = (fun () -> Anons.Grammar.zero) } } ;; let flag = flag_internal ~aliases_excluded_from_help:[] let flag_optional_with_default_doc ?aliases ?full_flag_required name arg_type sexp_of_default ~default ~doc = let doc = match sexp_of_default default with | Sexp.Atom "_" -> doc | default_sexp -> sprintf !"%s (default: %{Sexp})" doc default_sexp in flag ?aliases ?full_flag_required name (optional_with_default default arg_type) ~doc ;; include Applicative.Make (struct type nonrec 'a t = 'a param let return = const let apply = apply let map = `Custom map end) let pair = both end let flags_of_args_exn args = List.fold args ~init:empty ~f:(fun acc (name, spec, doc) -> let gen f flag_type = step (fun m x -> f x; m) +> flag name flag_type ~doc in let call f arg_type = gen (fun x -> Option.iter x ~f) (optional arg_type) in let set r arg_type = call (fun x -> r := x) arg_type in let set_bool r b = gen (fun passed -> if passed then r := b) no_arg in acc ++ match spec with | Arg.Unit f -> gen (fun passed -> if passed then f ()) no_arg | Arg.Set r -> set_bool r true | Arg.Clear r -> set_bool r false | Arg.String f -> call f string | Arg.Set_string r -> set r string | Arg.Int f -> call f int | Arg.Set_int r -> set r int | Arg.Float f -> call f float | Arg.Set_float r -> set r float | Arg.Bool f -> call f bool | Arg.Symbol (syms, f) -> let arg_type = Arg_type.of_alist_exn ~list_values_in_help:false (List.map syms ~f:(fun sym -> sym, sym)) in call f arg_type | Arg.Rest f -> gen (fun x -> Option.iter x ~f:(List.iter ~f)) escape | Arg.Tuple _ -> failwith "Arg.Tuple is not supported by Command.Spec.flags_of_args_exn" | ((Arg.Expand _) [@if ocaml_version >= (4, 05, 0)]) -> failwith "Arg.Expand is not supported by Command.Spec.flags_of_args_exn" | ((Arg.Rest_all _) [@if ocaml_version >= (4, 12, 0)]) -> failwith "Arg.Rest_all is not supported by Command.Spec.flags_of_args_exn") ;; module Deprecated = struct include Flag.Deprecated include Anons.Deprecated end let arg_names param = let t = param.param in let flag_names = Map.keys (Flag.Internal.create (t.flags ())) in let anon_names = Anons.Grammar.names (t.usage ()) in List.concat [ flag_names; anon_names ] ;; module Choose_one = struct module Choice_name : sig type t [@@deriving compare, sexp_of] include Comparator.S with type t := t val to_string : t -> string val list_to_string : t list -> string val create_exn : 'a param -> t end = struct module T = struct type t = string list [@@deriving compare, sexp_of] end include T include Comparator.Make (T) let create_exn param = let names = arg_names param in let names_with_commas = List.filter names ~f:(fun s -> String.contains s ',') in if not (List.is_empty names_with_commas) then failwiths ~here:[%here] "For simplicity, [Command.Spec.choose_one] does not support names with \ commas." names_with_commas [%sexp_of: string list]; match names with | [] -> raise_s [%message "[choose_one] expects choices to read command-line arguments."] | _ :: _ -> names ;; let to_string = String.concat ~sep:"," let list_to_string ts = List.map ts ~f:to_string |> String.concat ~sep:"\n " end module If_nothing_chosen = struct type (_, _) t = | Default_to : 'a -> ('a, 'a) t | Raise : ('a, 'a) t | Return_none : ('a, 'a option) t end let choose_one (type a b) (ts : a option param list) ~(if_nothing_chosen : (a, b) If_nothing_chosen.t) = match List.map ts ~f:(fun t -> Choice_name.create_exn t, t) |> Map.of_alist (module Choice_name) with | `Duplicate_key name -> failwiths ~here:[%here] "[Command.Spec.choose_one] called with duplicate name" name [%sexp_of: Choice_name.t] | `Ok ts -> Map.fold ts ~init:(return []) ~f:(fun ~key:name ~data:t init -> map2 init t ~f:(fun init value -> Option.fold value ~init ~f:(fun init value -> (name, value) :: init))) |> map ~f:(function | _ :: _ :: _ as passed -> die !"Cannot pass more than one of these: \n\ \ %{Choice_name.list_to_string}" (List.map passed ~f:fst) () | [ (_, value) ] -> (match if_nothing_chosen with | Default_to (_ : a) -> (value : b) | Raise -> (value : b) | Return_none -> (Some value : b)) | [] -> (match if_nothing_chosen with | Default_to value -> value | Return_none -> None | Raise -> die !"Must pass one of these:\n %{Choice_name.list_to_string}" (Map.keys ts) ())) ;; end module If_nothing_chosen = Choose_one.If_nothing_chosen let choose_one = Choose_one.choose_one let and_arg_names t = map t ~f:(fun value -> value, arg_names t) let and_arg_name t = match arg_names t with | [ name ] -> map t ~f:(fun value -> value, name) | names -> raise_s [%message "[and_arg_name] expects exactly one name, got" ~_:(names : string list)] ;; end end module Group = struct type 'a t = { summary : string ; readme : (unit -> string) option ; subcommands : (string * 'a) list Lazy.t ; body : (path:string list -> unit) option } let shape ~subcommand_to_shape t : _ Shape.Group_info.t = { summary = t.summary ; readme = Option.map ~f:(fun readme -> readme ()) t.readme ; subcommands = Lazy.map t.subcommands ~f:(List.Assoc.map ~f:subcommand_to_shape) } ;; end let abs_path = Shape.Private.abs_path let comp_cword = Command_env_var.COMP_CWORD module Exec = struct type t = { summary : string ; readme : (unit -> string) option ; (* If [path_to_exe] is relative, interpret w.r.t. [working_dir] *) working_dir : string ; path_to_exe : string ; child_subcommand : string list ; env : env option } let shape t : Shape.Exec_info.t = { summary = t.summary ; readme = Option.map ~f:(fun readme -> readme ()) t.readme ; working_dir = t.working_dir ; path_to_exe = t.path_to_exe ; child_subcommand = t.child_subcommand } ;; end (* A proxy command is the structure of an Exec command obtained by running it in a special way *) module Proxy = struct module Kind = struct type 'a t = | Base of Shape.Base_info.t | Group of 'a Shape.Group_info.t | Exec of Shape.Exec_info.t | Lazy of 'a t Lazy.t end type t = { working_dir : string ; path_to_exe : string ; path_to_subcommand : string list ; child_subcommand : string list ; kind : t Kind.t } end type t = | Base of Base.t | Group of t Group.t | Exec of Exec.t | Lazy of t Lazy.t let rec sexpable_shape : t -> Shape.Sexpable.t = function | Base base -> Base (Base.shape base) | Exec exec -> Exec (Exec.shape exec) | Group group -> Group (Group.shape ~subcommand_to_shape:sexpable_shape group) | Lazy thunk -> Lazy (Lazy.map ~f:sexpable_shape thunk) ;; type ('main, 'result) basic_spec_command = summary:string -> ?readme:(unit -> string) -> ('main, unit -> 'result) Base.Spec.t -> 'main -> t let extend_exn ~mem ~add map key_type ~key data = if mem map key then failwithf "there is already a %s named %s" (Key_type.to_string key_type) key (); add map ~key ~data ;; let extend_map_exn map key_type ~key data = extend_exn map key_type ~key data ~mem:Map.mem ~add:Map.set ;; let extend_alist_exn alist key_type ~key data = extend_exn alist key_type ~key data ~mem:(fun alist key -> List.Assoc.mem alist key ~equal:String.equal) ~add:(fun alist ~key ~data -> List.Assoc.add alist key data ~equal:String.equal) ;; module Bailout_dump_flag = struct let add base ~name ~aliases ~aliases_excluded_from_help ~text ~text_summary = let flags = base.Base.flags in let flags = extend_map_exn flags Key_type.Flag ~key:name { name ; aliases_excluded_from_help ; aliases ; num_occurrences = Flag.Num_occurrences.at_most_once ; check_available = ignore ; action = Print_info_and_quit (fun env -> text env) ; doc = sprintf " print %s and exit" text_summary ; name_matching = `Prefix } in { base with Base.flags } ;; end let basic_spec ~summary ?readme { Base.Spec.usage; flags; f } main = let flags = flags () in let usage = usage () in let anons () = let open Anons.Parser.For_opening in f () >>| fun k `Parse_args -> let thunk = k main in fun `Run_main -> thunk () in let flags = Flag.Internal.create flags in let base = { Base.summary; readme; usage; flags; anons } in let base = Bailout_dump_flag.add base ~name:"-help" ~aliases:[ "-?" ] ~aliases_excluded_from_help:[ "--help" ] ~text_summary:"this help text" ~text:(fun env -> Lazy.force (Env.find_exn env Base.help_key)) in Base base ;; let basic = basic_spec let subs_key : (string * t) list Env.Key.t = Env.key_create "subcommands" let lazy_group ~summary ?readme ?preserve_subcommand_order ?body alist = let subcommands = Lazy.map alist ~f:(fun alist -> let alist = List.map alist ~f:(fun (name, t) -> normalize Key_type.Subcommand name, t) in match String.Map.of_alist alist with | `Duplicate_key name -> failwithf "multiple subcommands named %s" name () | `Ok map -> (match preserve_subcommand_order with | Some () -> alist | None -> Map.to_alist map)) in Group { summary; readme; subcommands; body } ;; let group ~summary ?readme ?preserve_subcommand_order ?body alist = let readme = Option.map readme ~f:(fun f () -> String.strip (f ())) in lazy_group ~summary ?readme ?preserve_subcommand_order ?body (Lazy.from_val alist) ;; let exec ~summary ?readme ?(child_subcommand = []) ?env ~path_to_exe () = let working_dir = Filename.dirname @@ match path_to_exe with | `Absolute _ | `Relative_to_me _ -> Caml.Sys.executable_name | `Relative_to_argv0 _ -> Caml.Sys.argv.(0) in let path_to_exe = match path_to_exe with | `Absolute p -> if not (Filename.is_absolute p) then failwith "Path passed to `Absolute must be absolute" else p | `Relative_to_me p | `Relative_to_argv0 p -> if not (Filename.is_relative p) then failwith "Path passed to `Relative_to_me must be relative" else p in Exec { summary; readme; working_dir; path_to_exe; child_subcommand; env } ;; let of_lazy thunk = Lazy thunk let rec proxy_of_sexpable sexpable ~working_dir ~path_to_exe ~child_subcommand ~path_to_subcommand : Proxy.t = let kind = kind_of_sexpable sexpable ~working_dir ~path_to_exe ~child_subcommand ~path_to_subcommand in { working_dir; path_to_exe; path_to_subcommand; child_subcommand; kind } and kind_of_sexpable sexpable ~working_dir ~path_to_exe ~child_subcommand ~path_to_subcommand = match (sexpable : Shape.Sexpable.t) with | Base b -> Proxy.Kind.Base b | Exec e -> Proxy.Kind.Exec e | Lazy l -> Proxy.Kind.Lazy (Lazy.map l ~f:(fun sexpable -> kind_of_sexpable sexpable ~working_dir ~path_to_exe ~child_subcommand ~path_to_subcommand)) | Group g -> Proxy.Kind.Group { g with subcommands = Lazy.map g.subcommands ~f: (List.map ~f:(fun (str, sexpable) -> let path_to_subcommand = path_to_subcommand @ [ str ] in let proxy = proxy_of_sexpable sexpable ~working_dir ~path_to_exe ~child_subcommand ~path_to_subcommand in str, proxy)) } ;; module type For_version_info = sig module Version_util : Version_util module Time : sig type t = Time_float.t [@@deriving sexp_of] end end module Version_info (M : For_version_info) = struct open M let print_version ~version = print_endline (force version) let print_build_info ~build_info = print_endline (force build_info) let command ~version ~build_info = basic ~summary:"print version information" Base.Spec.( empty +> flag "-version" no_arg ~doc:" print the version of this build" +> flag "-build-info" no_arg ~doc:" print build info for this build") (fun version_flag build_info_flag -> if build_info_flag then print_build_info ~build_info else if version_flag then print_version ~version else ( print_build_info ~build_info; print_version ~version); exit 0) ;; let rec add ~version ~build_info unversioned = match unversioned with | Base base -> let base = Bailout_dump_flag.add base ~name:"-version" ~aliases:[] ~aliases_excluded_from_help:[ "--version" ] ~text_summary:"the version of this build" ~text:(fun _ -> force version) in let base = Bailout_dump_flag.add base ~name:"-build-info" ~aliases:[] ~aliases_excluded_from_help:[ "--build-info" ] ~text_summary:"info about this build" ~text:(fun _ -> force build_info) in Base base | Group group -> let subcommands = Lazy.map group.Group.subcommands ~f:(fun subcommands -> extend_alist_exn subcommands Key_type.Subcommand ~key:"version" (command ~version ~build_info)) in Group { group with Group.subcommands } | Exec exec -> Exec exec | Lazy thunk -> Lazy (lazy (add ~version ~build_info (Lazy.force thunk))) ;; let normalize_version_lines lines = String.concat ~sep:"\n" (List.sort lines ~compare:String.compare) ;; let default_version = lazy (normalize_version_lines Version_util.version_list) let default_build_info = lazy (* lazy to avoid loading all the time zone stuff at toplevel *) (Version_util.reprint_build_info Time.sexp_of_t) ;; end let%test_module "Version_info" = (module struct module Version_info = Version_info (struct module Version_util = struct let version_list = [ "hg://some/path_0xdeadbeef"; "ssh://a/path_8badf00d" ] let reprint_build_info to_sexp = Sexp.to_string (to_sexp Time_float.epoch) end module Time = struct type t = Time_float.t let sexp_of_t t = Time_float.to_string_utc t |> Sexp.of_string end end) let%expect_test "print version where multiple repos are used" = Version_info.print_version ~version:Version_info.default_version; [%expect {| hg://some/path_0xdeadbeef ssh://a/path_8badf00d |}] ;; let%expect_test "print build info" = Version_info.print_build_info ~build_info:(lazy "some build info"); [%expect {| some build info |}] ;; end) ;; let rec summary = function | Base x -> x.summary | Group x -> x.summary | Exec x -> x.summary | Lazy thunk -> summary (Lazy.force thunk) ;; module Spec = struct include Base.Spec let path = map ~f:Path.parts_exe_basename path end module Deprecated = struct module Spec = Spec.Deprecated let summary = summary let rec get_flag_names = function | Base base -> base.Base.flags |> String.Map.keys | Lazy thunk -> get_flag_names (Lazy.force thunk) | Group _ | Exec _ -> assert false ;; let help_recursive ~cmd ~with_flags ~expand_dots t s = let rec help_recursive_rec ~cmd t s = let new_s = s ^ (if expand_dots then cmd else ".") ^ " " in match t with | Lazy thunk -> let t = Lazy.force thunk in help_recursive_rec ~cmd t s | Base base -> let base_help = s ^ cmd, summary (Base base) in if with_flags then base_help :: List.map ~f:(fun (flag, h) -> new_s ^ flag, h) (List.sort ~compare:Base.Deprecated.subcommand_cmp_fst (Base.Deprecated.flags_help ~display_help_flags:false base)) else [ base_help ] | Group { summary; subcommands; readme = _; body = _ } -> (s ^ cmd, summary) :: (Lazy.force subcommands |> List.sort ~compare:Base.Deprecated.subcommand_cmp_fst |> List.concat_map ~f:(fun (cmd', t) -> help_recursive_rec ~cmd:cmd' t new_s)) | Exec _ -> (* Command.exec does not support deprecated commands *) [] in help_recursive_rec ~cmd t s ;; end module For_unix (For_unix_with_string_env_var : For_unix with type env_var := string) = struct module Version_info = Version_info (For_unix_with_string_env_var) module For_unix_with_command_env_var : For_unix with type env_var := Command_env_var.t = struct (* We force access to env vars to go through [Command_env_var] so that we can keep an accurate enumeration of the variables we use. *) include For_unix_with_string_env_var module Unix = struct include Unix let putenv ~key ~data = putenv ~key:(Command_env_var.to_string key) ~data let unsetenv key = unsetenv (Command_env_var.to_string key) let unsafe_getenv key = unsafe_getenv (Command_env_var.to_string key) type env = [ `Replace of (Command_env_var.t * string) list | `Extend of (Command_env_var.t * string) list | `Override of (Command_env_var.t * string option) list | `Replace_raw of string list ] let convert_env env = let convert_command_env_var_to_string list = List.map list ~f:(fun (env_var, str) -> Command_env_var.to_string env_var, str) in match env with | `Replace list -> `Replace (convert_command_env_var_to_string list) | `Extend list -> `Extend (convert_command_env_var_to_string list) | `Override list -> `Override (convert_command_env_var_to_string list) | `Replace_raw _ as replace -> replace ;; let exec ~prog ~argv ?use_path ?env () = exec ~prog ~argv ?use_path ?env:(Option.map env ~f:convert_env) () ;; let create_process_env ?working_dir ?prog_search_path ?argv0 ~prog ~args ~env () = create_process_env ?working_dir ?prog_search_path ?argv0 ~prog ~args ~env:(convert_env env) () ;; end end open For_unix_with_command_env_var (* Clear the setting of environment variable associated with command-line completion and recursive help so that subprocesses don't see them. Use [unsafe_getenv] so setuid-root programs can still read environment variables. There is no security risk here because the values are only used as triggers to dump out command information. *) let getenv_and_clear var = let value = Unix.unsafe_getenv var in if Option.is_some value then Unix.unsetenv var; value ;; let maybe_comp_cword () = getenv_and_clear comp_cword |> Option.map ~f:Int.of_string let set_comp_cword new_value = let new_value = Int.to_string new_value in Unix.putenv ~key:comp_cword ~data:new_value ;; module Exec = struct include Exec let exec_with_args t ~args ~maybe_new_comp_cword = let prog = abs_path ~dir:t.working_dir t.path_to_exe in let args = t.child_subcommand @ args in let env = t.env in Option.iter maybe_new_comp_cword ~f:(fun n -> (* The logic for tracking [maybe_new_comp_cword] doesn't take into account whether this exec specifies a child subcommand. If it does, COMP_CWORD needs to be set higher to account for the arguments used to specify the child subcommand. *) set_comp_cword (n + List.length t.child_subcommand)); never_returns (For_unix_with_string_env_var.Unix.exec ?env ~prog ~argv:(prog :: args) ()) ;; end module Sexpable = struct include Shape.Sexpable let read_stdout_and_stderr (process_info : Unix.Process_info.t) = (* We need to read each of stdout and stderr in a separate thread to avoid deadlocks if the child process decides to wait for a read on one before closing the other. Buffering may hide this problem until output is "sufficiently large". *) let start_reading descr info = let output = Set_once.create () in let thread = Thread.create ~on_uncaught_exn:`Print_to_stderr (fun () -> Result.try_with (fun () -> descr |> Unix.in_channel_of_descr |> In_channel.input_all) |> Set_once.set_exn output [%here]) () in stage (fun () -> Thread.join thread; Unix.close descr; match Set_once.get output with | None -> raise_s [%message "BUG failed to read" (info : Info.t)] | Some (Ok output) -> output | Some (Error exn) -> raise exn) in (* We might hang forever trying to join the reading threads if the child process keeps the file descriptor open. Not handling this because I think we've never seen it in the wild despite running vulnerable code for years. *) (* We have to start both threads before joining any of them. *) let finish_stdout = start_reading process_info.stdout (Info.of_string "stdout") in let finish_stderr = start_reading process_info.stderr (Info.of_string "stderr") in unstage finish_stdout (), unstage finish_stderr () ;; let of_external ~working_dir ~path_to_exe ~child_subcommand = let process_info = Unix.create_process_env () ~prog:(abs_path ~dir:working_dir path_to_exe) ~args:child_subcommand ~env: (let help_sexp = supported_versions |> Int.Set.sexp_of_t |> Sexp.to_string in `Extend [ COMMAND_OUTPUT_HELP_SEXP, help_sexp ]) in Unix.close process_info.stdin; let stdout, stderr = read_stdout_and_stderr process_info in ignore (Unix.wait (`Pid process_info.pid) : Pid.t * Unix.Exit_or_signal.t); (* Now we've killed all the processes and threads we made. *) match stdout |> Sexp.of_string |> Versioned.t_of_sexp |> of_versioned with | exception exn -> raise_s [%message "cannot parse command shape" ~_:(exn : exn) (stdout : string) (stderr : string)] | t -> t ;; let rec find (t : t) ~path_to_subcommand = match path_to_subcommand with | [] -> t | sub :: subs -> (match t with | Base _ -> failwithf "unexpected subcommand %S" sub () | Lazy thunk -> find (Lazy.force thunk) ~path_to_subcommand | Exec { path_to_exe; working_dir; child_subcommand; _ } -> find (of_external ~working_dir ~path_to_exe ~child_subcommand) ~path_to_subcommand:(sub :: (subs @ child_subcommand)) | Group g -> (match List.Assoc.find (Lazy.force g.subcommands) ~equal:String.equal sub with | None -> failwithf "unknown subcommand %S" sub () | Some t -> find t ~path_to_subcommand:subs)) ;; end let proxy_of_exe ~working_dir path_to_exe child_subcommand = Sexpable.of_external ~working_dir ~path_to_exe ~child_subcommand |> proxy_of_sexpable ~working_dir ~path_to_exe ~child_subcommand ~path_to_subcommand:[] ;; let rec shape_of_proxy proxy : Shape.t = shape_of_proxy_kind proxy.Proxy.kind and shape_of_exe () ~child_subcommand ~path_to_exe ~working_dir = shape_of_proxy (proxy_of_exe ~working_dir path_to_exe child_subcommand) and shape_of_proxy_kind kind = match kind with | Base b -> Basic b | Lazy l -> Lazy (Lazy.map ~f:shape_of_proxy_kind l) | Group g -> Group { g with subcommands = Lazy.map g.subcommands ~f:(List.Assoc.map ~f:shape_of_proxy) } | Exec ({ child_subcommand; path_to_exe; working_dir; _ } as e) -> Exec (e, shape_of_exe ~child_subcommand ~path_to_exe ~working_dir) ;; let rec shape t : Shape.t = match t with | Base b -> Basic (Base.shape b) | Group g -> Group (Group.shape ~subcommand_to_shape:shape g) | Exec ({ Exec.child_subcommand; path_to_exe; working_dir; _ } as e) -> Exec (Exec.shape e, shape_of_exe ~child_subcommand ~path_to_exe ~working_dir) | Lazy thunk -> shape (Lazy.force thunk) ;; let gather_help ~recursive ~flags ~expand_dots shape = let rec loop path acc shape = let string_of_path = if expand_dots then Path.to_string else Path.to_string_dots in let gather_group path acc subcommands = let filtered_subcommands = (* Only show the [help] subcommand at top-level. *) if Path.is_empty path then subcommands else List.Assoc.remove ~equal:String.( = ) subcommands "help" in filtered_subcommands |> List.stable_sort ~compare:(fun a b -> help_screen_compare (fst a) (fst b)) |> List.fold ~init:acc ~f:(fun (acc : Shape.Flag_info.t Fqueue.t) (subcommand, shape) -> let path = Path.append path ~subcommand in let name = string_of_path path in let doc = Shape.get_summary shape in let acc = Fqueue.enqueue acc { name; doc; aliases = [] } in if recursive then loop path acc shape else acc) in match shape with | Exec (_, shape) -> (* If the executable being called doesn't use [Core.Command], then sexp extraction will fail. *) (try loop path acc (shape ()) with | _ -> acc) | Group g -> gather_group path acc (Lazy.force g.subcommands) | Basic b -> if flags then b.flags |> List.filter ~f:(fun fmt -> String.( <> ) fmt.name "[-help]") |> List.fold ~init:acc ~f:(fun acc fmt -> let path = Path.append path ~subcommand:fmt.name in let fmt = { fmt with name = string_of_path path } in Fqueue.enqueue acc fmt) else acc | Lazy thunk -> loop path acc (Lazy.force thunk) in loop Path.empty Fqueue.empty shape |> Fqueue.to_list ;; let group_or_exec_help_text ~flags ~path ~summary ~readme ~format_list = unparagraphs (List.filter_opt [ Some summary ; Some (String.concat [ " "; Path.to_string path; " SUBCOMMAND" ]) ; readme ; Some (if flags then "=== subcommands and flags ===" else "=== subcommands ===") ; Some (Shape.Flag_help_display.to_string format_list) ]) ;; let rec help_for_shape shape path ~expand_dots ~flags ~recursive = let format_list = gather_help ~expand_dots ~flags ~recursive shape in match shape with | Basic b -> let usage = Shape.Base_info.get_usage b in unparagraphs (List.filter_opt [ Some b.summary ; Some (" " ^ Path.to_string path ^ " " ^ usage) ; b.readme ; Some "=== flags ===" ; Some (Shape.Flag_help_display.to_string b.flags) ]) | Group g -> group_or_exec_help_text ~flags ~path ~readme:g.readme ~summary:g.summary ~format_list | Exec (e, _) -> group_or_exec_help_text ~flags ~path ~readme:e.readme ~summary:e.summary ~format_list | Lazy thunk -> help_for_shape (Lazy.force thunk) path ~expand_dots ~flags ~recursive ;; let help_subcommand ~summary ~readme = basic ~summary:"explain a given subcommand (perhaps recursively)" Base.Spec.( empty +> flag "-recursive" no_arg ~doc:" show subcommands of subcommands, etc." +> flag "-flags" no_arg ~doc:" show flags as well in recursive help" +> flag "-expand-dots" no_arg ~doc:" expand subcommands in recursive help" +> path +> env +> anon (maybe ("SUBCOMMAND" %: string))) (fun recursive flags expand_dots path (env : Env.t) cmd_opt () -> let subs = match Env.find env subs_key with | Some subs -> subs | None -> assert false (* maintained by [dispatch] *) in let path = let path = Path.pop_help path in Option.fold cmd_opt ~init:path ~f:(fun path subcommand -> Path.append path ~subcommand) in let path, shape = match cmd_opt with | None -> let subcommands = List.Assoc.map subs ~f:shape |> Lazy.from_val in let readme = Option.map readme ~f:(fun readme -> readme ()) in path, Shape.Group { readme; summary; subcommands } | Some cmd -> (match lookup_expand (List.Assoc.map subs ~f:(fun x -> x, `Prefix)) cmd Subcommand with | Error e -> die "unknown subcommand %s for command %s: %s" cmd (Path.to_string path) e () | Ok (possibly_expanded_name, t) -> (* Fix the unexpanded value *) let path = Path.replace_first ~from:cmd ~to_:possibly_expanded_name path in path, shape t) in print_endline (help_for_shape shape path ~recursive ~flags ~expand_dots)) ;; (* This script works in both bash (via readarray) and zsh (via read -A). If you change it, please test in both bash and zsh. It does not work tcsh (different function syntax). *) let dump_autocomplete_function () = let fname = sprintf "_jsautocom_%s" (Pid.to_string (Unix.getpid ())) in let argv_0 = Caml.Sys.argv.(0) in printf "function %s {\n\ \ export COMP_CWORD\n\ \ COMP_WORDS[0]=%s\n\ \ if type readarray > /dev/null\n\ \ then readarray -t COMPREPLY < <(\"${COMP_WORDS[@]}\")\n\ \ else IFS=\"\n\ \" read -d \"\" -A COMPREPLY < <(\"${COMP_WORDS[@]}\")\n\ \ fi\n\ }\n\ complete -F %s %s\n\ %!" fname argv_0 fname argv_0 ;; let dump_help_sexp ~supported_versions t ~path_to_subcommand = Int.Set.inter Sexpable.supported_versions supported_versions |> Int.Set.max_elt |> function | None -> failwiths ~here:[%here] "Couldn't choose a supported help output version for Command.exec from the given \ supported versions." Sexpable.supported_versions Int.Set.sexp_of_t | Some version_to_use -> sexpable_shape t |> Sexpable.find ~path_to_subcommand |> Sexpable.to_versioned ~version_to_use |> Sexpable.Versioned.sexp_of_t |> Sexp.to_string |> print_string ;; let handle_environment t ~argv = match argv with | [] -> failwith "missing executable name" | cmd :: args -> Option.iter (getenv_and_clear COMMAND_OUTPUT_HELP_SEXP) ~f:(fun version -> let supported_versions = Sexp.of_string version |> Int.Set.t_of_sexp in dump_help_sexp ~supported_versions t ~path_to_subcommand:args; exit 0); Option.iter (getenv_and_clear COMMAND_OUTPUT_INSTALLATION_BASH) ~f:(fun _ -> dump_autocomplete_function (); exit 0); cmd, args ;; let process_args ~cmd ~args = let maybe_comp_cword = maybe_comp_cword () in let args = match maybe_comp_cword with | None -> Cmdline.of_list args | Some comp_cword -> let args = List.take (args @ [ "" ]) comp_cword in List.fold_right args ~init:Cmdline.Nil ~f:(fun arg args -> match args with | Cmdline.Nil -> Cmdline.Complete arg | _ -> Cmdline.Cons (arg, args)) in Path.create ~path_to_exe:cmd, args, maybe_comp_cword ;; let rec add_help_subcommands = function | Base _ as t -> t | Exec _ as t -> t | Group { summary; readme; subcommands; body } -> let subcommands = Lazy.map subcommands ~f:(fun subcommands -> extend_alist_exn (List.Assoc.map subcommands ~f:add_help_subcommands) Key_type.Subcommand ~key:"help" (help_subcommand ~summary ~readme)) in Group { summary; readme; subcommands; body } | Lazy thunk -> Lazy (lazy (add_help_subcommands (Lazy.force thunk))) ;; let maybe_apply_extend args ~extend ~path = Option.value_map extend ~default:args ~f:(fun f -> Cmdline.extend args ~extend:f ~path) ;; let rec dispatch t env ~extend ~path ~args ~maybe_new_comp_cword ~version ~build_info ~verbose_on_parse_error ~when_parsing_succeeds ~complete_subcommands = match t with | Lazy thunk -> let t = Lazy.force thunk in dispatch t env ~extend ~path ~args ~maybe_new_comp_cword ~version ~build_info ~verbose_on_parse_error ~when_parsing_succeeds ~complete_subcommands | Base base -> let args = maybe_apply_extend args ~extend ~path in let help_text = lazy (help_for_shape (shape t) path ~recursive:false ~flags:true ~expand_dots:false) in Base.run base env ~path ~args ~verbose_on_parse_error ~help_text ~when_parsing_succeeds | Exec exec -> let args = Cmdline.to_list (maybe_apply_extend args ~extend ~path) in Exec.exec_with_args ~args exec ~maybe_new_comp_cword | Group ({ summary; readme; subcommands = subs; body } as group) -> let completing = Cmdline.ends_in_complete args in let env = Env.set env ~key:subs_key ~data:(Lazy.force subs) in let die_showing_help msg = if completing then exit 0 else ( eprintf "%s\n%!" (help_for_shape ~recursive:false ~flags:false ~expand_dots:false (shape (Group { summary; readme; subcommands = subs; body })) path); die "%s" msg ()) in let rec parse_group args ~maybe_new_comp_cword = let maybe_new_comp_cword = Option.map ~f:Int.pred maybe_new_comp_cword in let skip rest = parse_group rest ~maybe_new_comp_cword in let resolve sub rest = let subs = List.Assoc.map (Lazy.force subs) ~f:(fun x -> x, `Prefix) in match lookup_expand subs sub Subcommand with | Error msg -> die_showing_help msg | Ok (sub, t) -> dispatch t env ~when_parsing_succeeds ~extend ~path:(Path.append path ~subcommand:sub) ~args:rest ~maybe_new_comp_cword ~version ~build_info ~verbose_on_parse_error ~complete_subcommands in match (args : Cmdline.t) with | Nil -> (match body with | None -> die_showing_help (sprintf "missing subcommand for command %s" (Path.to_string path)) | Some body -> body ~path:(Path.parts_exe_basename path)) | Cons (sub, rest) -> (* Match for flags recognized when subcommands are expected next *) (match sub with (* Recognized at the top level command only *) | ("-version" | "--version") when Path.length path = 1 -> if completing then skip rest else ( Version_info.print_version ~version; exit 0) | ("-build-info" | "--build-info") when Path.length path = 1 -> if completing then skip rest else ( Version_info.print_build_info ~build_info; exit 0) (* Recognized everywhere *) | "-help" | "--help" -> if completing then skip rest else ( match rest with | Nil | Complete (_ : string) -> print_endline (help_for_shape ~recursive:false ~flags:false ~expand_dots:false (shape (Group { group with subcommands = subs })) path); exit 0 | Cmdline.Cons (first_of_rest, rest_of_rest) -> resolve first_of_rest (Cons (sub, rest_of_rest))) | (_ : string) -> resolve sub rest) | Complete part -> let subs = Lazy.force subs |> List.map ~f:fst |> List.filter ~f:(fun name -> String.is_prefix name ~prefix:part) |> List.sort ~compare:String.compare in (match complete_subcommands with | Some f -> let subcommands = shape t |> Shape.fully_forced |> Shape.Fully_forced.expanded_subcommands in (match f ~path:(Path.parts path) ~part subcommands with | None -> exit 1 | Some to_output -> print_endline (String.concat ~sep:" " to_output); exit 0) | None -> List.iter subs ~f:print_endline; exit 0) in parse_group args ~maybe_new_comp_cword ;; let run ?verbose_on_parse_error ?version ?build_info ?(argv = Array.to_list Caml.Sys.argv) ?extend ?(when_parsing_succeeds = Fn.id) ?complete_subcommands t = let build_info = match build_info with | Some v -> lazy v | None -> Version_info.default_build_info in let version = match version with | None -> Version_info.default_version | Some v -> (* [version] was space delimited at some point and newline delimited at another. We always print one (repo, revision) pair per line and ensure sorted order *) lazy (Version_info.normalize_version_lines (String.split v ~on:' ' |> List.concat_map ~f:(String.split ~on:'\n'))) in Exn.handle_uncaught_and_exit (fun () -> let t = Version_info.add t ~version ~build_info in let t = add_help_subcommands t in let cmd, args = handle_environment t ~argv in let path, args, maybe_new_comp_cword = process_args ~cmd ~args in try dispatch t Env.empty ~extend ~path ~args ~maybe_new_comp_cword ~version ~build_info ~verbose_on_parse_error ~when_parsing_succeeds ~complete_subcommands with | Failed_to_parse_command_line msg -> if Cmdline.ends_in_complete args then exit 0 else ( prerr_endline msg; exit 1)) ;; let deprecated_run t ~cmd ~args ~is_help ~is_help_rec ~is_help_rec_flags ~is_expand_dots = let path_strings = String.split cmd ~on:' ' in let path = Path.of_parts path_strings in let args = if is_expand_dots then "-expand-dots" :: args else args in let args = if is_help_rec_flags then "-flags" :: args else args in let args = if is_help_rec then "-r" :: args else args in let args = if is_help then "-help" :: args else args in let args = Cmdline.of_list args in let t = add_help_subcommands t in dispatch t Env.empty ~path ~args ~extend:None ~maybe_new_comp_cword:None ~version:Version_info.default_version ~build_info:Version_info.default_build_info ~verbose_on_parse_error:None ~when_parsing_succeeds:Fn.id ~complete_subcommands:None ;; end (* NOTE: all that follows is simply namespace management boilerplate. This will go away once we re-work the internals of Command to use Applicative from the ground up. *) module Param = struct module type S = sig type +'a t include Applicative.S with type 'a t := 'a t val help : string Lazy.t t val path : string list t val args : string list t val flag : ?aliases:string list -> ?full_flag_required:unit -> string -> 'a Flag.t -> doc:string -> 'a t val flag_optional_with_default_doc : ?aliases:string list -> ?full_flag_required:unit -> string -> 'a Arg_type.t -> ('a -> Sexp.t) -> default:'a -> doc:string -> 'a t val anon : 'a Anons.t -> 'a t val escape_anon : final_anon:'a Anons.t -> ('a * string list) t module If_nothing_chosen : sig type (_, _) t = | Default_to : 'a -> ('a, 'a) t | Raise : ('a, 'a) t | Return_none : ('a, 'a option) t end val choose_one : 'a option t list -> if_nothing_chosen:('a, 'b) If_nothing_chosen.t -> 'b t val and_arg_names : 'a t -> ('a * string list) t val and_arg_name : 'a t -> ('a * string) t val arg_names : 'a t -> string list end module A = struct type 'a t = 'a Spec.param include Applicative.Make (struct type nonrec 'a t = 'a t let return = Spec.const let apply = Spec.apply let map = `Custom Spec.map end) end include A let help = Spec.help let path = Spec.path let args = Spec.args let flag = Spec.flag let anon = Spec.anon let choose_one = Spec.choose_one let arg_names = Spec.arg_names let and_arg_names = Spec.and_arg_names let and_arg_name = Spec.and_arg_name let flag_optional_with_default_doc = Spec.flag_optional_with_default_doc module Arg_type = Arg_type module If_nothing_chosen = Spec.If_nothing_chosen include Arg_type.Export include struct open Flag let escape = escape let listed = listed let map_flag = map_flag let no_arg = no_arg let no_arg_abort = no_arg_abort let no_arg_register = no_arg_register let no_arg_some = no_arg_some let one_or_more = one_or_more let one_or_more_as_pair = one_or_more_as_pair let one_or_more_as_list = one_or_more_as_list let optional = optional let optional_with_default = optional_with_default let required = required end include struct open Anons let ( %: ) = ( %: ) let map_anons = map_anons let maybe = maybe let maybe_with_default = maybe_with_default let non_empty_sequence_as_list = non_empty_sequence_as_list let non_empty_sequence_as_pair = non_empty_sequence_as_pair let sequence = sequence let t2 = t2 let t3 = t3 let t4 = t4 end let escape_anon = Spec.escape_anon end module Let_syntax = struct include Param module Let_syntax = struct include Param module Open_on_rhs = Param end end type 'result basic_command = summary:string -> ?readme:(unit -> string) -> (unit -> 'result) Param.t -> t let basic ~summary ?readme param = let spec = Spec.of_params @@ Param.map param ~f:(fun run () () -> run ()) in let readme = Option.map readme ~f:(fun f () -> String.strip (f ())) in basic ~summary ?readme spec () ;; module Private = struct let abs_path = abs_path let word_wrap = Shape.Private.word_wrap module Anons = Anons module Cmdline = Cmdline module For_unix = For_unix module Path = Path module Spec = struct include Spec let to_string_for_choose_one param = Choose_one.Choice_name.(create_exn param |> to_string) ;; end end let run = `Use_Command_unix let shape = `Use_Command_unix core-0.15.0/core/src/command.mli000066400000000000000000000000541420273305200163620ustar00rootroot00000000000000include Command_intf.Command (** @inline *) core-0.15.0/core/src/command_env_var.ml000066400000000000000000000002631420273305200177330ustar00rootroot00000000000000type t = | COMMAND_OUTPUT_INSTALLATION_BASH | COMMAND_OUTPUT_HELP_SEXP | COMP_CWORD [@@deriving compare, enumerate, sexp_of] let to_string t = Sexp.to_string (sexp_of_t t) core-0.15.0/core/src/command_env_var.mli000066400000000000000000000006121420273305200201020ustar00rootroot00000000000000open! Import open! Std_internal (** [Command_env_var] collects all the environment variables used by [Command]. We define them centrally because some services that wrap [Command] calls need to know to special case them. *) type t = | COMMAND_OUTPUT_INSTALLATION_BASH | COMMAND_OUTPUT_HELP_SEXP | COMP_CWORD [@@deriving compare, enumerate, sexp_of] val to_string : t -> string core-0.15.0/core/src/command_intf.ml000066400000000000000000001122461420273305200172400ustar00rootroot00000000000000(** Purely functional command line parsing. Here is a simple example: {[ let () = let open Command.Let_syntax in Command.basic ~summary:"cook eggs" [%map_open let num_eggs = flag "num-eggs" (required int) ~doc:"COUNT cook this many eggs" and style = flag "style" (required (Arg_type.create Egg_style.of_string)) ~doc:"OVER-EASY|SUNNY-SIDE-UP style of eggs" and recipient = anon ("recipient" %: string) in fun () -> (* TODO: implement egg-cooking in ocaml *) failwith "no eggs today" ] |> Command.run ]} {b Note}: {{!Core.Command.Param}[Command.Param]} has replaced {{!Core.Command.Spec}[Command.Spec] (DEPRECATED)} and should be used in all new code. *) open! Import open! Std_internal type env = [ `Replace of (string * string) list | `Extend of (string * string) list | `Override of (string * string option) list | `Replace_raw of string list ] module type Version_util = sig val version_list : string list val reprint_build_info : (Time_float.t -> Sexp.t) -> string end (** [For_unix] is the subset of Core's interface that [Command] needs, in particular to implement the [shape] and [run] functions. [Core.Private.Command] is a functor taking a module matching [For_unix] and is applied in Core to construct [Core.Command]. We use a functor in this way so that [Command]'s internal data types can remain hidden. *) module type For_unix = sig type env_var module Version_util : Version_util module Signal : sig type t end module Thread : sig type t val create : on_uncaught_exn:[ `Kill_whole_process | `Print_to_stderr ] -> ('a -> unit) -> 'a -> t val join : t -> unit end module Time : sig type t = Time_float.t [@@deriving sexp_of] end module Unix : sig module File_descr : sig type t end module Exit : sig type error = [ `Exit_non_zero of int ] type t = (unit, error) Result.t end module Exit_or_signal : sig type error = [ Exit.error | `Signal of Signal.t ] type t = (unit, error) Result.t end val getpid : unit -> Pid.t val close : ?restart:bool -> File_descr.t -> unit val open_process_in : string -> In_channel.t val close_process_in : In_channel.t -> Exit_or_signal.t val in_channel_of_descr : File_descr.t -> In_channel.t val putenv : key:env_var -> data:string -> unit val unsetenv : env_var -> unit val unsafe_getenv : env_var -> string option type env = [ `Replace of (env_var * string) list | `Extend of (env_var * string) list | `Override of (env_var * string option) list | `Replace_raw of string list ] val exec : prog:string -> argv:string list -> ?use_path:bool -> ?env:env -> unit -> never_returns module Process_info : sig type t = { pid : Pid.t ; stdin : File_descr.t ; stdout : File_descr.t ; stderr : File_descr.t } end val create_process_env : ?working_dir:string -> ?prog_search_path:string list -> ?argv0:string -> prog:string -> args:string list -> env:env -> unit -> Process_info.t type wait_on = [ `Any | `Group of Pid.t | `My_group | `Pid of Pid.t ] val wait : ?restart:bool -> wait_on -> Pid.t * Exit_or_signal.t end end module type Enumerable_sexpable = sig type t [@@deriving enumerate, sexp_of] end module type Enumerable_stringable = sig type t [@@deriving enumerate] val to_string : t -> string end module type Command = sig module type Enumerable_sexpable = Enumerable_sexpable module type Enumerable_stringable = Enumerable_stringable (** Specifications for command-line auto-completion. *) module Auto_complete : sig (** In addition to the argument prefix, an auto-completion spec has access to any previously parsed arguments in the form of a heterogeneous map into which those arguments may register themselves by providing a [Univ_map.Key] using the [~key] argument to [Arg_type.create]. *) type t = Univ_map.t -> part:string -> string list end (** Argument types. *) module Arg_type : sig (** The type of a command line argument. *) type 'a t (** An argument type includes information about how to parse values of that type from the command line, and (optionally) how to autocomplete partial arguments of that type via bash's programmable tab-completion. If the [of_string] function raises an exception, command line parsing will be aborted and the exception propagated up to top-level and printed along with command-line help. *) val create : ?complete:Auto_complete.t -> ?key:'a Univ_map.Multi.Key.t -> (string -> 'a) -> 'a t (** Transforms the result of a [t] using [f]. *) val map : ?key:'b Univ_map.Multi.Key.t -> 'a t -> f:('a -> 'b) -> 'b t (** Defers construction of the arg type until it is needed. *) val of_lazy : ?key:'a Univ_map.Multi.Key.t -> 'a t Lazy.t -> 'a t (** An auto-completing [Arg_type] over a finite set of values. *) val of_map : ?accept_unique_prefixes:bool (** Defaults to [true]. Automatically parses a prefix of a valid key if it's unambiguous. *) -> ?case_sensitive:bool (** Defaults to [true]. If [false], map keys must all be distinct when lowercased.*) -> ?list_values_in_help:bool (** Defaults to [true]. If you set it to false the accepted values won't be listed in the command help. *) -> ?auto_complete:Auto_complete.t (** Defaults to bash completion on the string prefix. This allows users to specify arbitrary auto-completion for [t]. *) -> ?key:'a Univ_map.Multi.Key.t -> 'a String.Map.t -> 'a t (** Convenience wrapper for [of_map]. Raises on duplicate keys. *) val of_alist_exn : ?accept_unique_prefixes:bool -> ?case_sensitive:bool (** Defaults to [true]. If [false], map keys must all be distinct when lowercased.*) -> ?list_values_in_help:bool (** default: true *) -> ?auto_complete:Auto_complete.t -> ?key:'a Univ_map.Multi.Key.t -> (string * 'a) list -> 'a t (** Convenience wrapper for [of_alist_exn] to use with [ppx_enumerate] using [to_string]. Raises on duplicate [to_string]ed values. *) val enumerated : ?accept_unique_prefixes:bool -> ?case_sensitive:bool (** Defaults to [true]. If [false], map keys must all be distinct when lowercased.*) -> ?list_values_in_help:bool (** default: true *) -> ?auto_complete:Auto_complete.t -> ?key:'a Univ_map.Multi.Key.t -> (module Enumerable_stringable with type t = 'a) -> 'a t (** Convenience wrapper for [of_alist_exn] to use with [ppx_enumerate] using [sexp_of_t] to turn the value into a string. Raises on duplicate [to_string]ed values. *) val enumerated_sexpable : ?accept_unique_prefixes:bool -> ?case_sensitive:bool (** Defaults to [true]. If [false], map keys must all be distinct when lowercased.*) -> ?list_values_in_help:bool (** default: true *) -> ?auto_complete:Auto_complete.t -> ?key:'a Univ_map.Multi.Key.t -> (module Enumerable_sexpable with type t = 'a) -> 'a t (** [comma_separated t] accepts comma-separated lists of arguments parsed by [t]. If [strip_whitespace = true], whitespace is stripped from each comma-separated string before it is parsed by [t]. If [allow_empty = true] then the empty string (or just whitespace, if [strip_whitespace = true]) results in an empty list, and if [allow_empty = false] then the empty string will fail to parse. (Note that there is currently no way for [comma_separated] to produce a list whose only element is the empty string.) If [unique_values = true] no autocompletion will be offered for arguments already supplied in the fragment to complete. *) val comma_separated : ?allow_empty:bool (** default: [false] *) -> ?key:'a list Univ_map.Multi.Key.t -> ?strip_whitespace:bool (** default: [false] *) -> ?unique_values:bool (** default: [false] *) -> 'a t -> 'a list t (** Values to include in other namespaces. *) module Export : sig val string : string t (** Beware that an anonymous argument of type [int] cannot be specified as negative, as it is ambiguous whether -1 is a negative number or a flag. (The same applies to [float], [time_span], etc.) You can use the special built-in "-anon" flag to force a string starting with a hyphen to be interpreted as an anonymous argument rather than as a flag, or you can just make it a parameter to a flag to avoid the issue. *) val int : int t val char : char t val float : float t val bool : bool t val date : Date.t t val percent : Percent.t t val host_and_port : Host_and_port.t t val sexp : Sexp.t t val sexp_conv : ?complete:Auto_complete.t -> (Sexp.t -> 'a) -> 'a t end module For_testing : sig val complete : _ t -> Auto_complete.t val parse : 'a t -> string -> 'a Or_error.t end end (** Command-line flag specifications. *) module Flag : sig type 'a t (** Required flags must be passed exactly once. *) val required : 'a Arg_type.t -> 'a t (** Optional flags may be passed at most once. *) val optional : 'a Arg_type.t -> 'a option t (** [optional_with_default] flags may be passed at most once, and default to a given value. *) val optional_with_default : 'a -> 'a Arg_type.t -> 'a t (** [listed] flags may be passed zero or more times. *) val listed : 'a Arg_type.t -> 'a list t val one_or_more : 'a Arg_type.t -> ('a * 'a list) t [@@deprecated "[since 2021-07] Use [one_or_more_as_pair] or [one_or_more_as_list]"] (** [one_or_more_as_pair] flags must be passed one or more times. *) val one_or_more_as_pair : 'a Arg_type.t -> ('a * 'a list) t (** Like [one_or_more_as_pair], but returns the flag values as a list. *) val one_or_more_as_list : 'a Arg_type.t -> 'a list t (** [no_arg] flags may be passed at most once. The boolean returned is true iff the flag is passed on the command line. *) val no_arg : bool t (** [no_arg_register ~key ~value] is like [no_arg], but associates [value] with [key] in the autocomplete environment. *) val no_arg_register : key:'a Univ_map.With_default.Key.t -> value:'a -> bool t (** [no_arg_some value] is like [no_arg], but will return [Some value] if the flag is passed on the command line, and return [None] otherwise. *) val no_arg_some : 'a -> 'a option t (** [no_arg_abort ~exit] is like [no_arg], but aborts command-line parsing by calling [exit]. This flag type is useful for "help"-style flags that just print something and exit. *) val no_arg_abort : exit:(unit -> never_returns) -> unit t (** [escape] flags may be passed at most once. They cause the command line parser to abort and pass through all remaining command line arguments as the value of the flag. A standard choice of flag name to use with [escape] is ["--"]. *) val escape : string list option t (** [map_flag flag ~f] transforms the parsed result of [flag] by applying [f]. *) val map_flag : 'a t -> f:('a -> 'b) -> 'b t end (** Anonymous command-line argument specification. *) module Anons : sig (** A specification of some number of anonymous arguments. *) type +'a t (** [(name %: typ)] specifies a required anonymous argument of type [typ]. The [name] must not be surrounded by whitespace; if it is, an exn will be raised. If the [name] is surrounded by a special character pair (<>, \{\}, \[\] or (),) [name] will remain as-is, otherwise, [name] will be uppercased. In the situation where [name] is only prefixed or only suffixed by one of the special character pairs, or different pairs are used (e.g., " 'a Arg_type.t -> 'a t (** [sequence anons] specifies a sequence of anonymous arguments. An exception will be raised if [anons] matches anything other than a fixed number of anonymous arguments. *) val sequence : 'a t -> 'a list t (** [non_empty_sequence_as_pair anons] and [non_empty_sequence_as_list anons] are like [sequence anons] except that an exception will be raised if there is not at least one anonymous argument given. *) val non_empty_sequence_as_pair : 'a t -> ('a * 'a list) t val non_empty_sequence_as_list : 'a t -> 'a list t (** [(maybe anons)] indicates that some anonymous arguments are optional. *) val maybe : 'a t -> 'a option t (** [(maybe_with_default default anons)] indicates an optional anonymous argument with a default value. *) val maybe_with_default : 'a -> 'a t -> 'a t (** [t2], [t3], and [t4] each concatenate multiple anonymous argument specs into a single one. The purpose of these combinators is to allow for optional sequences of anonymous arguments. Consider a command with usage: {v main.exe FOO [BAR BAZ] v} where the second and third anonymous arguments must either both be there or both not be there. This can be expressed as: {[ t2 ("FOO" %: foo) (maybe (t2 ("BAR" %: bar) ("BAZ" %: baz)))] ]} Sequences of 5 or more anonymous arguments can be built up using nested tuples: {[ maybe (t3 a b (t3 c d e)) ]} *) val t2 : 'a t -> 'b t -> ('a * 'b) t val t3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t val t4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t (** [map_anons anons ~f] transforms the parsed result of [anons] by applying [f]. *) val map_anons : 'a t -> f:('a -> 'b) -> 'b t end (** Command-line parameter specification. This module replaces {{!Core.Command.Spec}[Command.Spec]}, and should be used in all new code. Its types and compositional rules are much easier to understand. *) module Param : sig module type S = sig type +'a t (** [Command.Param] is intended to be used with the [[%map_open]] syntax defined in [ppx_let], like so: {[ let command = Command.basic ~summary:"..." [%map_open let count = anon ("COUNT" %: int) and port = flag "port" (optional int) ~doc:"N listen on this port" and person = person_param in (* ... Command-line validation code, if any, goes here ... *) fun () -> (* The body of the command *) do_stuff count port person ] ]} One can also use [[%map_open]] to define composite command line parameters, like [person_param] in the previous snippet: {[ type person = { name : string; age : int } let person_param : person Command.Param.t = [%map_open let name = flag "name" (required string) ~doc:"X name of the person" and age = flag "age" (required int) ~doc:"N how many years old" in {name; age} ] ]} The right-hand sides of [[%map_open]] definitions have [Command.Param] in scope. Alternatively, you can say: {[ let open Foo.Let_syntax in [%map_open let x ... ] ]} if [Foo] follows the same conventions as [Command.Param]. See example/command/main.ml for more examples. *) include Applicative.S with type 'a t := 'a t (** {2 Various internal values} *) (** The help text for the command. *) val help : string Lazy.t t (** The subcommand path of the command. *) val path : string list t (** The arguments passed to the command. *) val args : string list t (** [flag name spec ~doc] specifies a command that, among other things, takes a flag named [name] on its command line. [doc] indicates the meaning of the flag. All flags must have a dash at the beginning of the name. If [name] is not prefixed by "-", it will be normalized to ["-" ^ name]. Unless [full_flag_required] is used, one doesn't have to pass [name] exactly on the command line, but only an unambiguous prefix of [name] (i.e., a prefix which is not a prefix of any other flag's name). NOTE: the [doc] for a flag which takes an argument should be of the form [arg_name ^ " " ^ description] where [arg_name] describes the argument and [description] describes the meaning of the flag. NOTE: flag names (including aliases) containing underscores will be rejected. Use dashes instead. NOTE: "-" by itself is an invalid flag name and will be rejected. *) val flag : ?aliases:string list -> ?full_flag_required:unit -> string -> 'a Flag.t -> doc:string -> 'a t (** [flag_optional_with_default_doc name arg_type sexp_of_default ~default ~doc] is a shortcut for [flag], where: + The [Flag.t] is [optional_with_default default arg_type] + The [doc] is passed through with an explanation of what the default value appended. *) val flag_optional_with_default_doc : ?aliases:string list -> ?full_flag_required:unit -> string -> 'a Arg_type.t -> ('a -> Sexp.t) -> default:'a -> doc:string -> 'a t (** [anon spec] specifies a command that, among other things, takes the anonymous arguments specified by [spec]. *) val anon : 'a Anons.t -> 'a t (** [escape_anon ~final_anon] parses [anon] and then stops parsing. Remaining command line arguments are collected in the [string list], even if they start with dashes. See [escape] for the flag version of this behavior. The final anon is required to indicate when to stop parsing. *) val escape_anon : final_anon:'a Anons.t -> ('a * string list) t module If_nothing_chosen : sig type (_, _) t = | Default_to : 'a -> ('a, 'a) t | Raise : ('a, 'a) t | Return_none : ('a, 'a option) t end (** [choose_one clauses ~if_nothing_chosen] expresses a sum type. It raises if more than one of [clauses] is [Some _]. When [if_nothing_chosen = Raise], it also raises if none of [clauses] is [Some _]. *) val choose_one : 'a option t list -> if_nothing_chosen:('a, 'b) If_nothing_chosen.t -> 'b t (** [and_arg_names t] returns both the value of [t] and the names of the arguments that went into [t]. Useful for errors that reference multiple params. *) val and_arg_names : 'a t -> ('a * string list) t (** Like [and_arg_names], but asserts that there is exactly one name. *) val and_arg_name : 'a t -> ('a * string) t val arg_names : 'a t -> string list end include S (** @inline *) (** Values included for convenience so you can specify all command line parameters inside a single local open of [Param]. *) module Arg_type : module type of Arg_type with type 'a t = 'a Arg_type.t include module type of Arg_type.Export include module type of Flag with type 'a t := 'a Flag.t include module type of Anons with type 'a t := 'a Anons.t end module Let_syntax : sig (** Substituted below. *) type 'a t val return : 'a -> 'a t include Applicative.Applicative_infix with type 'a t := 'a t module Let_syntax : sig (** Substituted below. *) type 'a t val return : 'a -> 'a t val map : 'a t -> f:('a -> 'b) -> 'b t val both : 'a t -> 'b t -> ('a * 'b) t module Open_on_rhs = Param end with type 'a t := 'a Param.t end with type 'a t := 'a Param.t (** The old interface for command-line specifications -- {b Do Not Use}. This interface should not be used. See the {{!Core.Command.Param}[Param]} module for the new way to do things. *) module Spec : sig (** {2 Command parameters} *) (** Specification of an individual parameter to the command's main function. *) type 'a param = 'a Param.t [@@deprecated "[since 2019-03] use [Command.Param.t] instead"] include Param.S with type 'a t := 'a Param.t (** Superceded by [return], preserved for backwards compatibility. *) val const : 'a -> 'a Param.t [@@deprecated "[since 2018-10] use [Command.Param.return] instead of [Command.Spec.const]"] (** Superceded by [both], preserved for backwards compatibility. *) val pair : 'a Param.t -> 'b Param.t -> ('a * 'b) Param.t [@@deprecated "[since 2018-10] use [Command.Param.both] instead of [Command.Spec.pair]"] (** {2 Command specifications} *) (** Composable command-line specifications. *) type (-'main_in, +'main_out) t (** Ultimately one forms a basic command by combining a spec of type [('main, unit -> unit) t] with a main function of type ['main]; see the [basic] function below. Combinators in this library incrementally build up the type of main according to what command-line parameters it expects, so the resulting type of [main] is something like: [arg1 -> ... -> argN -> unit -> unit] It may help to think of [('a, 'b) t] as a function space ['a -> 'b] embellished with information about: {ul {- how to parse the command line} {- what the command does and how to call it} {- how to autocomplete a partial command line}} One can view a value of type [('main_in, 'main_out) t] as a function that transforms a main function from type ['main_in] to ['main_out], typically by supplying some arguments. E.g., a value of type [Spec.t] might have type: {[ (arg1 -> ... -> argN -> 'r, 'r) Spec.t ]} Such a value can transform a main function of type [arg1 -> ... -> argN -> 'r] by supplying it argument values of type [arg1], ..., [argn], leaving a main function whose type is ['r]. In the end, [Command.basic] takes a completed spec where ['r = unit -> unit], and hence whose type looks like: {[ (arg1 -> ... -> argN -> unit -> unit, unit -> unit) Spec.t ]} A value of this type can fully apply a main function of type [arg1 -> ... -> argN -> unit -> unit] to all its arguments. The final unit argument allows the implementation to distinguish between the phases of (1) parsing the command line and (2) running the body of the command. Exceptions raised in phase (1) lead to a help message being displayed alongside the exception. Exceptions raised in phase (2) are displayed without any command line help. The view of [('main_in, main_out) Spec.t] as a function from ['main_in] to ['main_out] is directly reflected by the [step] function, whose type is: {[ val step : ('m1 -> 'm2) -> ('m1, 'm2) t ]} *) (** [spec1 ++ spec2 ++ ... ++ specN] composes [spec1] through [specN]. For example, if [spec_a] and [spec_b] have types: {[ spec_a: (a1 -> ... -> aN -> 'ra, 'ra) Spec.t; spec_b: (b1 -> ... -> bM -> 'rb, 'rb) Spec.t ]} then [spec_a ++ spec_b] has the following type: {[ (a1 -> ... -> aN -> b1 -> ... -> bM -> 'rb, 'rb) Spec.t ]} So, [spec_a ++ spec_b] transforms a main function by first supplying [spec_a]'s arguments of type [a1], ..., [aN], and then supplying [spec_b]'s arguments of type [b1], ..., [bm]. One can understand [++] as function composition by thinking of the type of specs as concrete function types, representing the transformation of a main function: {[ spec_a: \/ra. (a1 -> ... -> aN -> 'ra) -> 'ra; spec_b: \/rb. (b1 -> ... -> bM -> 'rb) -> 'rb ]} Under this interpretation, the composition of [spec_a] and [spec_b] has type: {[ spec_a ++ spec_b : \/rc. (a1 -> ... -> aN -> b1 -> ... -> bM -> 'rc) -> 'rc ]} And the implementation is just function composition: {[ sa ++ sb = fun main -> sb (sa main) ]} *) (** The empty command-line spec. *) val empty : ('m, 'm) t (** Command-line spec composition. *) val ( ++ ) : ('m1, 'm2) t -> ('m2, 'm3) t -> ('m1, 'm3) t (** Adds a rightmost parameter onto the type of main. *) val ( +> ) : ('m1, 'a -> 'm2) t -> 'a Param.t -> ('m1, 'm2) t (** Adds a leftmost parameter onto the type of main. This function should only be used as a workaround in situations where the order of composition is at odds with the order of anonymous arguments because you're factoring out some common spec. *) val ( +< ) : ('m1, 'm2) t -> 'a Param.t -> ('a -> 'm1, 'm2) t (** Combinator for patching up how parameters are obtained or presented. Here are a couple examples of some of its many uses: {ul {li {i introducing labeled arguments} {v step (fun m v -> m ~foo:v) +> flag "-foo" no_arg : (foo:bool -> 'm, 'm) t v}} {li {i prompting for missing values} {v step (fun m user -> match user with | Some user -> m user | None -> print_string "enter username: "; m (read_line ())) +> flag "-user" (optional string) ~doc:"USER to frobnicate" : (string -> 'm, 'm) t v}} } A use of [step] might look something like: {[ step (fun main -> let ... in main x1 ... xN) : (arg1 -> ... -> argN -> 'r, 'r) t ]} Thus, [step] allows one to write arbitrary code to decide how to transform a main function. As a simple example: {[ step (fun main -> main 13.) : (float -> 'r, 'r) t ]} This spec is identical to [const 13.]; it transforms a main function by supplying it with a single float argument, [13.]. As another example: {[ step (fun m v -> m ~foo:v) : (foo:'foo -> 'r, 'foo -> 'r) t ]} This spec transforms a main function that requires a labeled argument into a main function that requires the argument unlabeled, making it easily composable with other spec combinators. *) val step : ('m1 -> 'm2) -> ('m1, 'm2) t (** Combinator for defining a class of commands with common behavior. Here are two examples of command classes defined using [wrap]: {ul {li {i print top-level exceptions to stderr} {v wrap (fun ~run ~main -> Exn.handle_uncaught ~exit:true (fun () -> run main) ) : ('m, unit) t -> ('m, unit) t v}} {li {i iterate over lines from stdin} {v wrap (fun ~run ~main -> In_channel.iter_lines stdin ~f:(fun line -> run (main line)) ) : ('m, unit) t -> (string -> 'm, unit) t v}} } *) val wrap : (run:('m1 -> 'r1) -> main:'m2 -> 'r2) -> ('m1, 'r1) t -> ('m2, 'r2) t module Arg_type : module type of Arg_type with type 'a t = 'a Arg_type.t include module type of Arg_type.Export (** A flag specification. *) type 'a flag = 'a Flag.t include module type of Flag with type 'a t := 'a flag (** [flags_of_args_exn args] creates a spec from [Caml.Arg.t]s, for compatibility with OCaml's base libraries. Fails if it encounters an arg that cannot be converted. NOTE: There is a difference in side effect ordering between [Caml.Arg] and [Command]. In the [Arg] module, flag handling functions embedded in [Caml.Arg.t] values will be run in the order that flags are passed on the command line. In the [Command] module, using [flags_of_args_exn flags], they are evaluated in the order that the [Caml.Arg.t] values appear in [args]. *) val flags_of_args_exn : Arg.t list -> ('a, 'a) t [@@deprecated "[since 2018-10] switch to Command.Param"] (** A specification of some number of anonymous arguments. *) type 'a anons = 'a Anons.t include module type of Anons with type 'a t := 'a anons (** Conversions to and from new-style [Param] command line specifications. *) val to_param : ('a, 'r) t -> 'a -> 'r Param.t val of_param : 'r Param.t -> ('r -> 'm, 'm) t end (** Commands which can be combined into a hierarchy of subcommands. *) type t type ('main, 'result) basic_spec_command = summary:string -> ?readme:(unit -> string) -> ('main, unit -> 'result) Spec.t -> 'main -> t (** [basic_spec ~summary ?readme spec main] is a basic command that executes a function [main] which is passed parameters parsed from the command line according to [spec]. [summary] is to contain a short one-line description of its behavior. [readme] is to contain any longer description of its behavior that will go on that command's help screen. *) val basic_spec : ('main, unit) basic_spec_command type 'result basic_command = summary:string -> ?readme:(unit -> string) -> (unit -> 'result) Param.t -> t (** Same general behavior as [basic_spec], but takes a command line specification built up using [Params] instead of [Spec]. *) val basic : unit basic_command (** [group ~summary subcommand_alist] is a compound command with named subcommands, as found in [subcommand_alist]. [summary] is to contain a short one-line description of the command group. [readme] is to contain any longer description of its behavior that will go on that command's help screen. NOTE: subcommand names containing underscores will be rejected; use dashes instead. [body] is called when no additional arguments are passed -- in particular, when no subcommand is passed. Its [path] argument is the subcommand path by which the group command was reached. *) val group : summary:string -> ?readme:(unit -> string) -> ?preserve_subcommand_order:unit -> ?body:(path:string list -> unit) -> (string * t) list -> t (** [lazy_group] is the same as [group], except that the list of subcommands may be generated lazily. *) val lazy_group : summary:string -> ?readme:(unit -> string) -> ?preserve_subcommand_order:unit -> ?body:(path:string list -> unit) -> (string * t) list Lazy.t -> t (** [exec ~summary ~path_to_exe] runs [exec] on the executable at [path_to_exe]. If [path_to_exe] is [`Absolute path] then [path] is executed without any further qualification. If it is [`Relative_to_me path] then [Filename.dirname Sys.executable_name ^ "/" ^ path] is executed instead. All of the usual caveats about [Sys.executable_name] apply: specifically, it may only return an absolute path in Linux. On other operating systems it will return [Sys.argv.(0)]. If it is [`Relative_to_argv0 path] then [Sys.argv.(0) ^ "/" ^ path] is executed. The [child_subcommand] argument allows referencing a subcommand one or more levels below the top-level of the child executable. It should {e not} be used to pass flags or anonymous arguments to the child. Care has been taken to support nesting multiple executables built with Command. In particular, recursive help and autocompletion should work as expected. NOTE: Non-Command executables can be used with this function but will still be executed when [help -recursive] is called or autocompletion is attempted (despite the fact that neither will be particularly helpful in this case). This means that if you have a shell script called "reboot-everything.sh" that takes no arguments and reboots everything no matter how it is called, you shouldn't use it with [exec]. Additionally, no loop detection is attempted, so if you nest an executable within itself, [help -recursive] and autocompletion will hang forever (although actually running the subcommand will work). *) val exec : summary:string -> ?readme:(unit -> string) -> ?child_subcommand:string list -> ?env:env -> path_to_exe: [ `Absolute of string | `Relative_to_argv0 of string | `Relative_to_me of string ] -> unit -> t (** [of_lazy thunk] constructs a lazy command that is forced only when necessary to run it or extract its shape. *) val of_lazy : t Lazy.t -> t (** Extracts the summary string for a command. *) val summary : t -> string module Shape : module type of struct include Command_shape end with module Private := Command_shape.Private and module Stable := Command_shape.Stable (** call this instead of [Core.exit] if in command-related code that you want to run in tests. For example, in the body of [Command.Param.no_arg_abort] *) val exit : int -> _ (** [Deprecated] should be used only by [Deprecated_command]. At some point it will go away. *) module Deprecated : sig module Spec : sig val no_arg : hook:(unit -> unit) -> bool Spec.flag val escape : hook:(string list -> unit) -> string list option Spec.flag val ad_hoc : usage_arg:string -> string list Spec.anons end val summary : t -> string val help_recursive : cmd:string -> with_flags:bool -> expand_dots:bool -> t -> string -> (string * string) list val get_flag_names : t -> string list end (** Deprecated values that moved from [Core.Command] to [Command_unix]. *) val run : [ `Use_Command_unix ] [@@deprecated "[since 2021-03] Use [Command_unix]"] module Path : sig end [@@deprecated "[since 2021-03] Use [Command_unix]"] val shape : [ `Use_Command_unix ] [@@deprecated "[since 2021-03] Use [Command_unix]"] (**/**) (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig val abs_path : dir:string -> string -> string val word_wrap : string -> int -> string list module Anons : sig val normalize : string -> string end module Path : sig type t val empty : t val create : path_to_exe:string -> t val append : t -> subcommand:string -> t val parts : t -> string list val replace_first : t -> from:string -> to_:string -> t val to_string : t -> string val to_string_dots : t -> string end module Cmdline : sig type t [@@deriving compare] val of_list : string list -> t val extend : t -> extend:(string list -> string list) -> path:Path.t -> t end module Spec : sig val flags_of_args_exn : (string * Arg.spec * string) list -> ('a, 'a) Spec.t val to_string_for_choose_one : _ Param.t -> string end module For_unix (M : For_unix with type env_var := string) : sig val shape : t -> Shape.t val help_for_shape : Shape.t -> Path.t -> expand_dots:bool -> flags:bool -> recursive:bool -> string val run : ?verbose_on_parse_error:bool -> ?version:string -> ?build_info:string -> ?argv:string list -> ?extend:(string list -> string list) -> ?when_parsing_succeeds:(unit -> unit) -> ?complete_subcommands: (path:string list -> part:string -> string list list -> string list option) (** [complete_subcommands ~path ~part options] allows users to provide a custom tab completion handler to an invocation of [run]. By default, completion is performed via standard bash completion. One may use this to, e.g. use a fuzzy finder for completion. Imagine a command whose structure is "subcommand1 subcommand2", [path] represents the subcommand invocations interpreted thusfar in being matched. [part] is the portion of the auto-completion that is being matched upon. If a user attempts to complete "exe subcommand1 s", they will get ["subcommand1"] in [path] and "s" in [part]. [options] are the valid subcommand invocations to present to the user. [complete_subcommands] should return the selection made, if any. *) -> t -> unit val deprecated_run : t -> cmd:string -> args:string list -> is_help:bool -> is_help_rec:bool -> is_help_rec_flags:bool -> is_expand_dots:bool -> unit end end module Stable : sig module Shape = Command_shape.Stable end end core-0.15.0/core/src/command_shape.ml000066400000000000000000000545041420273305200174020ustar00rootroot00000000000000module Stable = struct open! Stable_internal open! Ppx_compare_lib.Builtin module Anons = struct module Grammar = struct module V1 = struct type t = | Zero | One of string | Many of t | Maybe of t | Concat of t list | Ad_hoc of string [@@deriving bin_io, compare, sexp] let%expect_test _ = print_endline [%bin_digest: t]; [%expect {| a17fd34ec213e508db450f6469f7fe99 |}] ;; let rec invariant t = Base.Invariant.invariant [%here] t [%sexp_of: t] (fun () -> match t with | Zero -> () | One _ -> () | Many Zero -> failwith "Many Zero should be just Zero" | Many t -> invariant t | Maybe Zero -> failwith "Maybe Zero should be just Zero" | Maybe t -> invariant t | Concat [] | Concat [ _ ] -> failwith "Flatten zero and one-element Concat" | Concat ts -> Base.List.iter ts ~f:invariant | Ad_hoc _ -> ()) ;; let t_of_sexp sexp = let t = [%of_sexp: t] sexp in invariant t; t ;; let rec usage = function | Zero -> "" | One usage -> usage | Many Zero -> failwith "bug in command.ml" | Many (One _ as t) -> Base.Printf.sprintf "[%s ...]" (usage t) | Many t -> Base.Printf.sprintf "[(%s) ...]" (usage t) | Maybe Zero -> failwith "bug in command.ml" | Maybe t -> Base.Printf.sprintf "[%s]" (usage t) | Concat ts -> Base.String.concat ~sep:" " (Base.List.map ts ~f:usage) | Ad_hoc usage -> usage ;; end module Model = V1 end module V2 = struct type t = | Usage of string | Grammar of Grammar.V1.t [@@deriving bin_io, compare, sexp] let%expect_test _ = print_endline [%bin_digest: t]; [%expect {| 081d9ec167903f8f8c49cbf8e3fb3a66 |}] ;; end module Model = V2 end module Flag_info = struct module V1 = struct type t = { name : string ; doc : string ; aliases : string list } [@@deriving bin_io, compare, sexp] let%expect_test _ = print_endline [%bin_digest: t]; [%expect {| bd8d6fb7a662d2c0b5e0d2026c6d2d21 |}] ;; end module Model = V1 end module Base_info = struct module V2 = struct type t = { summary : string ; readme : string option [@sexp.option] ; anons : Anons.V2.t ; flags : Flag_info.V1.t list } [@@deriving bin_io, compare, fields, sexp] let%expect_test _ = print_endline [%bin_digest: t]; [%expect {| 8faac1e8d9deb0baaa56ac8ebf85b498 |}] ;; end module V1 = struct type t = { summary : string ; readme : string option [@sexp.option] ; usage : string ; flags : Flag_info.V1.t list } [@@deriving bin_shape, sexp] let to_latest { summary; readme; usage; flags } = { V2.summary; readme; anons = Usage usage; flags } ;; let of_latest { V2.summary; readme; anons; flags } = { summary ; readme ; usage = (match anons with | Usage usage -> usage | Grammar grammar -> Anons.Grammar.V1.usage grammar) ; flags } ;; end module Model = V2 end module Group_info = struct type a = Dummy_type_because_we_cannot_digest_type_constructors_only_concrete_types [@@deriving bin_io] module V2 = struct type 'a t = { summary : string ; readme : string option [@sexp.option] ; subcommands : (string * 'a) List.Stable.V1.t Lazy.Stable.V1.t } [@@deriving bin_io, compare, sexp] let%expect_test _ = print_endline [%bin_digest: a t]; [%expect {| 2cc3eeb58d12d8fe4400009e592d7827 |}] ;; open! Base let map t ~f = { t with subcommands = Lazy.map t.subcommands ~f:(List.Assoc.map ~f) } ;; end module Model = V2 module V1 = struct type 'a t = { summary : string ; readme : string option [@sexp.option] ; subcommands : (string * 'a) List.Stable.V1.t } [@@deriving bin_io, compare, sexp] let%expect_test _ = print_endline [%bin_digest: a t]; [%expect {| 2cc3eeb58d12d8fe4400009e592d7827 |}] ;; open! Base let map t ~f = { t with subcommands = List.Assoc.map t.subcommands ~f } let to_latest { summary; readme; subcommands } : 'a Model.t = { summary; readme; subcommands = Lazy.from_val subcommands } ;; let of_latest ({ summary; readme; subcommands } : 'a Model.t) : 'a t = { summary; readme; subcommands = Lazy.force subcommands } ;; end end module Exec_info = struct let abs_path ~dir path = if Filename.is_absolute path then path else Filename.concat dir path ;; module V3 = struct type t = { summary : string ; readme : string option [@sexp.option] ; working_dir : string ; path_to_exe : string ; child_subcommand : string list } [@@deriving bin_io, compare, sexp] let%expect_test _ = print_endline [%bin_digest: t]; [%expect {| c0c8256e9238cdd8f2ec1f8785e02ae0 |}] ;; let to_latest = Fn.id let of_latest = Fn.id end module Model = V3 module V2 = struct type t = { summary : string ; readme : string option [@sexp.option] ; working_dir : string ; path_to_exe : string } [@@deriving bin_shape, sexp] let to_v3 t : V3.t = { summary = t.summary ; readme = t.readme ; working_dir = t.working_dir ; path_to_exe = t.path_to_exe ; child_subcommand = [] } ;; let of_v3 (t : V3.t) = { summary = t.summary ; readme = t.readme ; working_dir = t.working_dir ; path_to_exe = abs_path ~dir:t.working_dir t.path_to_exe } ;; let to_latest = Fn.compose V3.to_latest to_v3 let of_latest = Fn.compose of_v3 V3.of_latest end module V1 = struct type t = { summary : string ; readme : string option [@sexp.option] ; (* [path_to_exe] must be absolute. *) path_to_exe : string } [@@deriving bin_shape, sexp] let to_v2 t : V2.t = { summary = t.summary ; readme = t.readme ; working_dir = "/" ; path_to_exe = t.path_to_exe } ;; let of_v2 (t : V2.t) = { summary = t.summary ; readme = t.readme ; path_to_exe = abs_path ~dir:t.working_dir t.path_to_exe } ;; let to_latest = Fn.compose V2.to_latest to_v2 let of_latest = Fn.compose of_v2 V2.of_latest end end module Fully_forced = struct module V1 = struct type t = | Basic of Base_info.V2.t | Group of t Group_info.V2.t | Exec of Exec_info.V3.t * t [@@deriving bin_io, compare, sexp] let%expect_test _ = print_endline [%bin_digest: t]; [%expect {| 981154ef3919437c6c822619882841d4 |}] ;; end module Model = V1 end module Sexpable = struct module V3 = struct type t = | Base of Base_info.V2.t | Group of t Group_info.V2.t | Exec of Exec_info.V3.t | Lazy of t Lazy.Stable.V1.t [@@deriving bin_shape, sexp] let%expect_test _ = print_endline [%bin_digest: t]; [%expect {| d3c375548f1a43c58c71e814c04ba36a |}] ;; let to_latest = Fn.id let of_latest = Fn.id end module Model = V3 module V2 = struct type t = | Base of Base_info.V2.t | Group of t Group_info.V1.t | Exec of Exec_info.V2.t [@@deriving bin_shape, sexp] let%expect_test _ = print_endline [%bin_digest: t]; [%expect {| 598d4b41ef435bc69a4886bdba0f8689 |}] ;; let rec to_latest : t -> Model.t = function | Base b -> Base b | Exec e -> Exec (Exec_info.V2.to_latest e) | Group g -> Group (Group_info.V1.to_latest (Group_info.V1.map g ~f:to_latest)) ;; let rec of_latest : Model.t -> t = function | Base b -> Base b | Exec e -> Exec (Exec_info.V2.of_latest e) | Lazy thunk -> of_latest (Base.Lazy.force thunk) | Group g -> Group (Group_info.V1.map (Group_info.V1.of_latest g) ~f:of_latest) ;; end module V1 = struct type t = | Base of Base_info.V1.t | Group of t Group_info.V1.t | Exec of Exec_info.V1.t [@@deriving bin_shape, sexp] let%expect_test _ = print_endline [%bin_digest: t]; [%expect {| 70d20b5432ffab77a385b02b04031d2e |}] ;; let rec to_latest : t -> Model.t = function | Base b -> Base (Base_info.V1.to_latest b) | Exec e -> Exec (Exec_info.V1.to_latest e) | Group g -> Group (Group_info.V1.to_latest (Group_info.V1.map g ~f:to_latest)) ;; let rec of_latest : Model.t -> t = function | Base b -> Base (Base_info.V1.of_latest b) | Exec e -> Exec (Exec_info.V1.of_latest e) | Lazy thunk -> of_latest (Base.Lazy.force thunk) | Group g -> Group (Group_info.V1.map (Group_info.V1.of_latest g) ~f:of_latest) ;; end module Versioned = struct type t = | V1 of V1.t | V2 of V2.t | V3 of V3.t (* available at least since 2020-04 *) [@@deriving bin_shape, sexp, variants] (* It's okay to change this one in place, as long as we wait long enough before dropping support for old versions. *) let%expect_test _ = print_endline [%bin_digest: t]; [%expect {| 796fbf006deb25159171637c2a510bf4 |}] ;; let to_latest = function | V1 t -> V1.to_latest t | V2 t -> V2.to_latest t | V3 t -> V3.to_latest t ;; let of_latest ~version_to_use latest = match version_to_use with | 1 -> V1 (V1.of_latest latest) | 2 -> V2 (V2.of_latest latest) | 3 -> V3 (V3.of_latest latest) | other -> Std_internal.failwiths ~here:[%here] "unsupported version_to_use" other [%sexp_of: int] ;; end end end open! Import open! Std_internal module Anons = struct module Grammar = struct type t = Stable.Anons.Grammar.Model.t = | Zero | One of string | Many of t | Maybe of t | Concat of t list | Ad_hoc of string [@@deriving bin_io, compare, sexp] let invariant = Stable.Anons.Grammar.Model.invariant let usage = Stable.Anons.Grammar.Model.usage end type t = Stable.Anons.Model.t = | Usage of string | Grammar of Grammar.t [@@deriving bin_io, compare, sexp] end module Num_occurrences = struct type t = { at_least_once : bool ; at_most_once : bool } [@@deriving compare, enumerate, fields, sexp_of] let maybe_missing_prefix = "[" let maybe_missing_suffix = "]" let maybe_more_suffix = " ..." let to_help_string t ~flag_name = let { at_least_once; at_most_once } = t in let description = if at_least_once then flag_name else String.concat [ maybe_missing_prefix; flag_name; maybe_missing_suffix ] in if at_most_once then description else String.concat [ description; maybe_more_suffix ] ;; let of_help_string name = let at_most_once, name = match String.chop_suffix name ~suffix:maybe_more_suffix with | None -> true, name | Some name -> false, name in let at_least_once, name = match String.chop_prefix name ~prefix:maybe_missing_prefix |> Option.bind ~f:(String.chop_suffix ~suffix:maybe_missing_suffix) with | None -> true, name | Some name -> false, name in { at_least_once; at_most_once }, name ;; let%expect_test "to_help_string" = let flag_name = "name" in List.iter [%all: t] ~f:(fun t -> let s = to_help_string t ~flag_name in print_s [%message "" ~_:(t : t) s]; let t', flag_name' = of_help_string s in assert ([%compare.equal: t] t t'); assert ([%compare.equal: string] flag_name flag_name')); [%expect {| (((at_least_once false) (at_most_once false)) "[name] ...") (((at_least_once true) (at_most_once false)) "name ...") (((at_least_once false) (at_most_once true)) [name]) (((at_least_once true) (at_most_once true)) name) |}] ;; end module Flag_info = struct type t = Stable.Flag_info.Model.t = { name : string ; doc : string ; aliases : string list } [@@deriving bin_io, compare, fields, sexp] let parse_name t = let num_occurrences, flag_name = Num_occurrences.of_help_string t.name in match String.split flag_name ~on:' ' with | [ flag_name ] -> Ok (num_occurrences, false, flag_name) | [ flag_name; _arg_doc ] -> Ok (num_occurrences, true, flag_name) | _ -> error_s [%message "Unable to parse" flag_name] ;; (* Users are likely to call all three of these functions, in which case we will re-parse the [name] several times. We don't expect users of these functions to care about the inefficiency. *) let flag_name t = parse_name t |> Or_error.map ~f:trd3 let num_occurrences t = parse_name t |> Or_error.map ~f:fst3 let requires_arg t = parse_name t |> Or_error.map ~f:snd3 let help_screen_compare a b = match a, b with | _, "[-help]" -> -1 | "[-help]", _ -> 1 | _, "[-version]" -> -1 | "[-version]", _ -> 1 | _, "[-build-info]" -> -1 | "[-build-info]", _ -> 1 | _, "help" -> -1 | "help", _ -> 1 | _, "version" -> -1 | "version", _ -> 1 | _ -> 0 ;; end module Flag_help_display = struct type t = Flag_info.t list let sort t = List.stable_sort t ~compare:(fun a b -> Flag_info.help_screen_compare a.Flag_info.name b.Flag_info.name) ;; let word_wrap_and_strip text width = let chunks = String.split text ~on:'\n' in List.concat_map chunks ~f:(fun text -> let words = String.split text ~on:' ' |> List.filter ~f:(fun word -> not (String.is_empty word)) in match List.fold words ~init:None ~f:(fun acc word -> Some (match acc with | None -> [], word | Some (lines, line) -> (* efficiency is not a concern for the string lengths we expect *) let line_and_word = line ^ " " ^ word in if String.length line_and_word <= width then lines, line_and_word else line :: lines, word)) with | None -> [] | Some (lines, line) -> List.rev (line :: lines)) ;; module Display : sig val to_string : t -> string end = struct let num_cols = 80 let spaces_string width = String.make width ' ' let pad_spaces_to_suffix x ~width = let slack = width - String.length x in x ^ spaces_string slack ;; let indentation = " " let indent_and_newline x = List.concat [ [ indentation ]; x; [ "\n" ] ] let spacing_dot = ". " let dot_indentation_offset = 27 ;; let documentation_start_column = dot_indentation_offset + String.length indentation let lhs_width = documentation_start_column let lhs_pad_width = dot_indentation_offset + String.length indentation let lhs_pad = spaces_string lhs_pad_width let lhs_pad_and_newline_terminate = List.map ~f:(fun v -> indent_and_newline [ lhs_pad; v ]) ;; let rows flag_name_with_aliases documentation = let flag_on_its_own_line = let flag_width = String.length indentation + String.length flag_name_with_aliases in if flag_width >= dot_indentation_offset + String.length spacing_dot then indent_and_newline [ flag_name_with_aliases ] else indent_and_newline [ pad_spaces_to_suffix ~width:dot_indentation_offset flag_name_with_aliases ; spacing_dot ] in let wrapped_documentation = word_wrap_and_strip documentation (num_cols - lhs_width - String.length indentation) in match wrapped_documentation with | [] -> [ flag_on_its_own_line ] | doc_wrapped_first_line :: doc_wrapped_rest_lines -> let wrapped_doc_lines = lhs_pad_and_newline_terminate doc_wrapped_rest_lines in let prefix_doc_wrapped_first_line_with x = indent_and_newline [ pad_spaces_to_suffix ~width:dot_indentation_offset x ; spacing_dot ; doc_wrapped_first_line ] in if String.length flag_name_with_aliases >= dot_indentation_offset then flag_on_its_own_line :: prefix_doc_wrapped_first_line_with "" :: wrapped_doc_lines else prefix_doc_wrapped_first_line_with flag_name_with_aliases :: wrapped_doc_lines ;; let to_string t = List.concat_map t ~f:(fun t -> let flag_name_with_aliases = let flag = t.Flag_info.name in String.concat ~sep:", " (flag :: t.aliases) in rows flag_name_with_aliases t.doc |> List.concat) |> String.concat ;; end let to_string t = Display.to_string t end module Key_type = struct type t = | Subcommand | Flag let to_string = function | Subcommand -> "subcommand" | Flag -> "flag" ;; end let lookup_expand alist prefix key_type = let is_dash = Char.equal '-' in let alist = (* no partial matches unless some non-dash char is present *) if String.for_all prefix ~f:is_dash then List.map alist ~f:(fun (key, (data, _)) -> key, (data, `Full_match_required)) else alist in match List.filter alist ~f:(function | key, (_, `Full_match_required) -> String.( = ) key prefix | key, (_, `Prefix) -> String.is_prefix key ~prefix) with | [ (key, (data, _name_matching)) ] -> Ok (key, data) | [] -> Error (sprintf !"unknown %{Key_type} %s" key_type prefix) | matches -> (match List.find matches ~f:(fun (key, _) -> String.( = ) key prefix) with | Some (key, (data, _name_matching)) -> Ok (key, data) | None -> let matching_keys = List.map ~f:fst matches in Error (sprintf !"%{Key_type} %s is an ambiguous prefix: %s" key_type prefix (String.concat ~sep:", " matching_keys))) ;; module Base_info = struct type t = Stable.Base_info.Model.t = { summary : string ; readme : string option [@sexp.option] ; anons : Anons.t ; flags : Flag_info.t list } [@@deriving bin_io, compare, fields, sexp] let find_flag t prefix = match String.is_prefix prefix ~prefix:"-" with | false -> error_s [%message "Flags must begin with '-'" prefix] | true -> let%bind.Or_error choices = List.map t.flags ~f:(fun (flag_info : Flag_info.t) -> let%bind.Or_error flag_name = Flag_info.flag_name flag_info in Ok (List.map (flag_name :: flag_info.aliases) ~f:(fun key -> key, (flag_info, `Prefix)))) |> Or_error.combine_errors in lookup_expand (List.concat choices) prefix Flag |> Result.map_error ~f:Error.of_string |> Or_error.map ~f:snd ;; let get_usage t = match t.anons with | Usage usage -> usage | Grammar grammar -> Stable.Anons.Grammar.V1.usage grammar ;; end module Group_info = struct type 'a t = 'a Stable.Group_info.Model.t = { summary : string ; readme : string option [@sexp.option] ; subcommands : (string * 'a) List.t Lazy.t } [@@deriving bin_io, compare, fields, sexp] let find_subcommand t prefix = match String.is_prefix prefix ~prefix:"-" with | true -> error_s [%message "Subcommands must not begin with '-'" prefix] | false -> let choices = List.map (force t.subcommands) ~f:(fun (key, a) -> key, (a, `Prefix)) in lookup_expand choices prefix Subcommand |> Result.map_error ~f:Error.of_string |> Or_error.map ~f:snd ;; let map = Stable.Group_info.Model.map end module Exec_info = struct type t = Stable.Exec_info.Model.t = { summary : string ; readme : string option [@sexp.option] ; working_dir : string ; path_to_exe : string ; child_subcommand : string list } [@@deriving bin_io, compare, fields, sexp] end module Fully_forced = struct type t = Stable.Fully_forced.Model.t = | Basic of Base_info.t | Group of t Group_info.t | Exec of Exec_info.t * t [@@deriving bin_io, compare, sexp] let expanded_subcommands t = let rec expand = function | Exec (_, t) -> expand t | Basic _ -> [ [] ] | Group { subcommands; _ } -> List.concat_map (Lazy.force subcommands) ~f:(fun (name, t) -> List.map ~f:(fun path -> name :: path) (expand t)) in (* Reversing so that the commands show up in the same order as help is output *) List.rev (expand t) ;; end module Sexpable = struct type t = Stable.Sexpable.Model.t = | Base of Base_info.t | Group of t Group_info.t | Exec of Exec_info.t | Lazy of t Lazy.t [@@deriving sexp_of] let extraction_var = Command_env_var.to_string COMMAND_OUTPUT_HELP_SEXP module Versioned = Stable.Sexpable.Versioned let supported_versions = let f i supported _ = Set.add supported i in Versioned.Variants.fold ~init:(Set.empty (module Int)) ~v1:(f 1) ~v2:(f 2) ~v3:(f 3) ;; let of_versioned = Versioned.to_latest let to_versioned t ~version_to_use = Versioned.of_latest t ~version_to_use end type t = | Basic of Base_info.t | Group of t Group_info.t | Exec of Exec_info.t * (unit -> t) | Lazy of t Lazy.t let rec fully_forced : t -> Fully_forced.t = function | Basic b -> Basic b | Group g -> Group (Group_info.map g ~f:fully_forced) | Exec (e, f) -> Exec (e, fully_forced (f ())) | Lazy thunk -> fully_forced (Lazy.force thunk) ;; let rec get_summary = function | Basic b -> b.summary | Group g -> g.summary | Exec (e, _) -> e.summary | Lazy thunk -> get_summary (Lazy.force thunk) ;; let help_text = `Use_Command_unix module Private = struct module Key_type = Key_type let abs_path = Stable.Exec_info.abs_path let help_screen_compare = Flag_info.help_screen_compare let word_wrap = Flag_help_display.word_wrap_and_strip let lookup_expand = lookup_expand end core-0.15.0/core/src/command_shape.mli000066400000000000000000000000701420273305200175400ustar00rootroot00000000000000include Command_shape_intf.Command_shape (** @inline *) core-0.15.0/core/src/command_shape_intf.ml000066400000000000000000000145301420273305200204150ustar00rootroot00000000000000(** A [Command_shape] allows limited introspection of a [Command], including subcommands, arguments, and doc strings. Think of it as machine-readable help. *) open! Import open! Std_internal module type Command_shape = sig module Anons : sig module Grammar : sig type t = | Zero | One of string | Many of t | Maybe of t | Concat of t list | Ad_hoc of string [@@deriving bin_shape, compare, sexp_of] include Invariant.S with type t := t val usage : t -> string end type t = | Usage of string (** When exec'ing an older binary whose help sexp doesn't expose the grammar. *) | Grammar of Grammar.t [@@deriving bin_shape, compare, sexp_of] end module Num_occurrences : sig type t = { at_least_once : bool ; at_most_once : bool } [@@deriving compare, enumerate, fields, sexp_of] val to_help_string : t -> flag_name:string -> string end module Flag_info : sig type t = { name : string (** See [flag_name] below. *) ; doc : string ; aliases : string list } [@@deriving compare, fields, sexp_of] (** [flag_name] infers the string which one would pass on the command line. It is not the same as the raw [name] field, which additionally encodes [num_occurrences] and [requires_arg] (sort of). *) val flag_name : t -> string Or_error.t val num_occurrences : t -> Num_occurrences.t Or_error.t (** [requires_arg] gives undefined behavior on [escape] flags. This is a limitation of the underlying shape representation. *) val requires_arg : t -> bool Or_error.t include Binable.S with type t := t [@@deprecated "[since 2020-04] Use [Command.Stable.Shape.Flag_info]."] val t_of_sexp : Sexp.t -> t [@@deprecated "[since 2020-04] Use [Command.Stable.Shape.Flag_info]."] end module Flag_help_display : sig type t = Flag_info.t list val sort : t -> t val to_string : t -> string end module Base_info : sig type t = { summary : string ; readme : string option ; anons : Anons.t ; flags : Flag_info.t list } [@@deriving compare, fields, sexp_of] (** [find_flag t prefix] looks up the flag, if any, to which [prefix] refers. It raises if [prefix] does not begin with [-] as all flags should. [find_flag] does not consider [aliases_excluded_from_help], and it assumes that all flags can be passed by prefix. These are limitations in the underlying shape representation. *) val find_flag : t -> string -> Flag_info.t Or_error.t val get_usage : t -> string include Binable.S with type t := t [@@deprecated "[since 2020-04] Use [Command.Stable.Shape.Base_info]."] val t_of_sexp : Sexp.t -> t [@@deprecated "[since 2020-04] Use [Command.Stable.Shape.Base_info]."] end module Group_info : sig type 'a t = { summary : string ; readme : string option ; subcommands : (string, 'a) List.Assoc.t Lazy.t } [@@deriving compare, fields, sexp_of] val find_subcommand : 'a t -> string -> 'a Or_error.t val map : 'a t -> f:('a -> 'b) -> 'b t include Binable.S1 with type 'a t := 'a t [@@deprecated "[since 2020-04] Use [Command.Stable.Shape.Group_info]."] val t_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a t [@@deprecated "[since 2020-04] Use [Command.Stable.Shape.Group_info]."] end module Exec_info : sig type t = { summary : string ; readme : string option ; working_dir : string ; path_to_exe : string ; child_subcommand : string list } [@@deriving compare, fields, sexp_of] include Binable.S with type t := t [@@deprecated "[since 2020-04] Use [Command.Stable.Shape.Exec_info]."] val t_of_sexp : Sexp.t -> t [@@deprecated "[since 2020-04] Use [Command.Stable.Shape.Exec_info]."] end (** Fully forced shapes are comparable and serializable. *) module Fully_forced : sig type t = | Basic of Base_info.t | Group of t Group_info.t | Exec of Exec_info.t * t [@@deriving compare, sexp_of] val expanded_subcommands : t -> string list list include Binable.S with type t := t [@@deprecated "[since 2020-04] Use [Command.Stable.Shape.Fully_forced]."] val t_of_sexp : Sexp.t -> t [@@deprecated "[since 2020-04] Use [Command.Stable.Shape.Fully_forced]."] end type t = | Basic of Base_info.t | Group of t Group_info.t | Exec of Exec_info.t * (unit -> t) | Lazy of t Lazy.t val fully_forced : t -> Fully_forced.t val get_summary : t -> string module Sexpable : sig type t = | Base of Base_info.t | Group of t Group_info.t | Exec of Exec_info.t | Lazy of t Lazy.t [@@deriving sexp_of] val extraction_var : string val supported_versions : Set.M(Int).t module Versioned : sig type t [@@deriving sexp] end val of_versioned : Versioned.t -> t val to_versioned : t -> version_to_use:int -> Versioned.t end val help_text : [ `Use_Command_unix ] [@@deprecated "[since 2021-03] Use [Command_unix]"] module Stable : sig module Anons : sig module Grammar : sig module V1 : Stable_without_comparator with type t = Anons.Grammar.t end module V2 : Stable_without_comparator with type t = Anons.t end module Flag_info : sig module V1 : Stable_without_comparator with type t = Flag_info.t end module Base_info : sig module V2 : Stable_without_comparator with type t = Base_info.t end module Group_info : sig module V2 : Stable1 with type 'a t = 'a Group_info.t end module Exec_info : sig module V3 : Stable_without_comparator with type t = Exec_info.t end module Fully_forced : sig module V1 : Stable_without_comparator with type t = Fully_forced.t end end module Private : sig module Key_type : sig type t = | Subcommand | Flag val to_string : t -> string end val abs_path : dir:string -> string -> string val help_screen_compare : string -> string -> int val lookup_expand : (string * ('a * [ `Full_match_required | `Prefix ])) list -> string -> Key_type.t -> (string * 'a, string) result val word_wrap : string -> int -> string list end end core-0.15.0/core/src/comparable.ml000066400000000000000000000142251420273305200167050ustar00rootroot00000000000000open! Import include Comparable_intf module Infix = Base.Comparable.Infix module Polymorphic_compare = Base.Comparable.Polymorphic_compare module Validate (T : sig type t [@@deriving compare, sexp_of] end) : Validate with type t := T.t = struct module V = Validate open Maybe_bound let to_string t = Base.Sexp.to_string (T.sexp_of_t t) let validate_bound ~min ~max t = V.bounded ~name:to_string ~lower:min ~upper:max ~compare:T.compare t ;; let validate_lbound ~min t = validate_bound ~min ~max:Unbounded t let validate_ubound ~max t = validate_bound ~max ~min:Unbounded t end module Validate_with_zero (T : sig type t [@@deriving compare, sexp_of] val zero : t end) = struct module V = Validate (T) include V (* Preallocate the interesting bounds to minimize allocation in the implementations of [validate_*]. *) let excl_zero = Maybe_bound.Excl T.zero let incl_zero = Maybe_bound.Incl T.zero let validate_positive t = validate_lbound ~min:excl_zero t let validate_non_negative t = validate_lbound ~min:incl_zero t let validate_negative t = validate_ubound ~max:excl_zero t let validate_non_positive t = validate_ubound ~max:incl_zero t end module With_zero (T : sig type t [@@deriving compare, sexp_of] val zero : t end) = struct include Validate_with_zero (T) include Base.Comparable.With_zero (T) end module Map_and_set_binable_using_comparator (T : sig type t [@@deriving bin_io, compare, sexp] include Comparator.S with type t := t end) = struct include T module Map = Map.Make_binable_using_comparator (T) module Set = Set.Make_binable_using_comparator (T) end module Map_and_set_binable (T : sig type t [@@deriving bin_io, compare, sexp] end) = Map_and_set_binable_using_comparator (struct include T include Comparator.Make (T) end) module Poly (T : sig type t [@@deriving sexp] end) = struct module C = struct include T include Base.Comparable.Poly (T) end include C include Validate (C) module Replace_polymorphic_compare : Polymorphic_compare with type t := t = C module Map = Map.Make_using_comparator (C) module Set = Set.Make_using_comparator (C) end module Make_plain_using_comparator (T : sig type t [@@deriving sexp_of] include Comparator.S with type t := t end) : S_plain with type t := T.t and type comparator_witness = T.comparator_witness = struct include T module M = Base.Comparable.Make_using_comparator (T) include M include Validate (struct include T include M end) module Replace_polymorphic_compare : Polymorphic_compare with type t := t = M module Map = Map.Make_plain_using_comparator (T) module Set = Set.Make_plain_using_comparator (T) end module Make_plain (T : sig type t [@@deriving compare, sexp_of] end) = Make_plain_using_comparator (struct include T include Comparator.Make (T) end) module Make_using_comparator (T : sig type t [@@deriving sexp] include Comparator.S with type t := t end) : S with type t := T.t and type comparator_witness = T.comparator_witness = struct include T module M = Base.Comparable.Make_using_comparator (T) include M include Validate (struct include T include M end) module Replace_polymorphic_compare : Polymorphic_compare with type t := t = M module Map = Map.Make_using_comparator (T) module Set = Set.Make_using_comparator (T) end module Make (T : sig type t [@@deriving compare, sexp] end) : S with type t := T.t = Make_using_comparator (struct include T include Comparator.Make (T) end) module Make_binable_using_comparator (T : sig type t [@@deriving bin_io, sexp] include Comparator.S with type t := t end) = struct include T module M = Base.Comparable.Make_using_comparator (T) include Validate (struct include T let compare = T.comparator.compare end) include M module Replace_polymorphic_compare : Polymorphic_compare with type t := t = M module Map = Map.Make_binable_using_comparator (T) module Set = Set.Make_binable_using_comparator (T) end module Make_binable (T : sig type t [@@deriving bin_io, compare, sexp] end) = struct include Make_binable_using_comparator (struct include T include Comparator.Make (T) end) end module Extend (M : Base.Comparable.S) (X : sig type t = M.t [@@deriving sexp] end) = struct module T = struct include M include ( X : sig type t = M.t [@@deriving sexp] end with type t := t) end include T include Validate (T) module Replace_polymorphic_compare : Comparisons.S with type t := t = M module Map = Map.Make_using_comparator (T) module Set = Set.Make_using_comparator (T) end module Extend_binable (M : Base.Comparable.S) (X : sig type t = M.t [@@deriving bin_io, sexp] end) = struct module T = struct include M include ( X : sig type t = M.t [@@deriving bin_io, sexp] end with type t := t) end include T include Validate (T) module Replace_polymorphic_compare : Comparisons.S with type t := t = M module Map = Map.Make_binable_using_comparator (T) module Set = Set.Make_binable_using_comparator (T) end module Inherit (C : sig type t [@@deriving compare] end) (T : sig type t [@@deriving sexp] val component : t -> C.t end) = Make (struct type t = T.t [@@deriving sexp] let compare t t' = C.compare (T.component t) (T.component t') end) include (Base.Comparable : With_compare) module Stable = struct module V1 = struct module type S = sig type comparable type comparator_witness module Map : Map.Stable.V1.S with type key := comparable with type comparator_witness := comparator_witness module Set : Set.Stable.V1.S with type elt := comparable with type elt_comparator_witness := comparator_witness end module Make (X : Stable_module_types.S0) = struct module Map = Map.Stable.V1.Make (X) module Set = Set.Stable.V1.Make (X) end end end core-0.15.0/core/src/comparable.mli000066400000000000000000000000621420273305200170500ustar00rootroot00000000000000include Comparable_intf.Comparable (** @inline *) core-0.15.0/core/src/comparable_intf.ml000066400000000000000000000173071420273305200177310ustar00rootroot00000000000000open! Import module type Infix = Base.Comparable.Infix module type Polymorphic_compare = Base.Comparable.Polymorphic_compare module type With_compare = Base.Comparable.With_compare module type Validate = sig type t val validate_lbound : min:t Maybe_bound.t -> t Validate.check val validate_ubound : max:t Maybe_bound.t -> t Validate.check val validate_bound : min:t Maybe_bound.t -> max:t Maybe_bound.t -> t Validate.check end module type Validate_with_zero = sig type t include Validate with type t := t val validate_positive : t Validate.check val validate_non_negative : t Validate.check val validate_negative : t Validate.check val validate_non_positive : t Validate.check end module type With_zero = sig type t include Base.Comparable.With_zero with type t := t include Validate_with_zero with type t := t end module type S_common = sig include Base.Comparable.S include Validate with type t := t module Replace_polymorphic_compare : Polymorphic_compare with type t := t end (** Usage example: {[ module Foo : sig type t = ... include Comparable.S with type t := t end ]} Then use [Comparable.Make] in the struct (see comparable.mli for an example). *) module type S_plain = sig include S_common module Map : Map.S_plain with type Key.t = t with type Key.comparator_witness = comparator_witness module Set : Set.S_plain with type Elt.t = t with type Elt.comparator_witness = comparator_witness end module type S = sig include S_common module Map : Map.S with type Key.t = t with type Key.comparator_witness = comparator_witness module Set : Set.S with type Elt.t = t with type Elt.comparator_witness = comparator_witness end module type Map_and_set_binable = sig type t include Comparator.S with type t := t module Map : Map.S_binable with type Key.t = t with type Key.comparator_witness = comparator_witness module Set : Set.S_binable with type Elt.t = t with type Elt.comparator_witness = comparator_witness end module type S_binable = sig include S_common include Map_and_set_binable with type t := t with type comparator_witness := comparator_witness end module type Comparable = sig (** Comparable extends {{!Base.Comparable}[Base.Comparable]} and provides functions for comparing like types. Usage example: {[ module Foo = struct module T = struct type t = ... [@@deriving compare, sexp] end include T include Comparable.Make (T) end ]} Then include [Comparable.S] in the signature (see {!Comparable_intf} for an example). To add an [Infix] submodule: {[ module C = Comparable.Make (T) include C module Infix = (C : Comparable.Infix with type t := t) ]} Common pattern: Define a module [O] with a restricted signature. It aims to be (locally) opened to bring useful operators into scope without shadowing unexpected variable names. E.g. in the [Date] module: {[ module O = struct include (C : Comparable.Infix with type t := t) let to_string t = .. end ]} Opening [Date] would shadow [now], but opening [Date.O] doesn't: {[ let now = .. in let someday = .. in Date.O.(now > someday) ]} *) module type Infix = Infix module type Map_and_set_binable = Map_and_set_binable module type Polymorphic_compare = Polymorphic_compare module type S_plain = S_plain module type S = S module type S_binable = S_binable module type S_common = S_common module type Validate = Validate module type Validate_with_zero = Validate_with_zero module type With_compare = With_compare module type With_zero = With_zero include With_compare (** Inherit comparability from a component. *) module Inherit (C : sig type t [@@deriving compare] end) (T : sig type t [@@deriving sexp] val component : t -> C.t end) : S with type t := T.t (** {2 Comparison-only Functors} These functors require only [type t] and [val compare]. They do not require [val sexp_of_t], and do not generate container datatypes. *) module Infix (T : sig type t [@@deriving compare] end) : Infix with type t := T.t module Polymorphic_compare (T : sig type t [@@deriving compare] end) : Polymorphic_compare with type t := T.t (** {2 Make Functors} The Comparable Make functor family allows users to choose among the following attributes: - [*_using_comparator] or not - [*_binable] or not - [*_plain] or not Thus there are functors like [Make_plain] or [Make_binable_using_comparator], etc. *) module Make_plain (T : sig type t [@@deriving compare, sexp_of] end) : S_plain with type t := T.t module Make (T : sig type t [@@deriving compare, sexp] end) : S with type t := T.t module Make_plain_using_comparator (T : sig type t [@@deriving sexp_of] include Comparator.S with type t := t end) : S_plain with type t := T.t with type comparator_witness := T.comparator_witness module Make_using_comparator (T : sig type t [@@deriving sexp] include Comparator.S with type t := t end) : S with type t := T.t with type comparator_witness := T.comparator_witness module Make_binable (T : sig type t [@@deriving bin_io, compare, sexp] end) : S_binable with type t := T.t module Make_binable_using_comparator (T : sig type t [@@deriving bin_io, sexp] include Comparator.S with type t := t end) : S_binable with type t := T.t with type comparator_witness := T.comparator_witness module Extend (M : Base.Comparable.S) (X : sig type t = M.t [@@deriving sexp] end) : S with type t := M.t with type comparator_witness := M.comparator_witness module Extend_binable (M : Base.Comparable.S) (X : sig type t = M.t [@@deriving bin_io, sexp] end) : S_binable with type t := M.t with type comparator_witness := M.comparator_witness module Map_and_set_binable (T : sig type t [@@deriving bin_io, compare, sexp] end) : Map_and_set_binable with type t := T.t module Map_and_set_binable_using_comparator (T : sig type t [@@deriving bin_io, compare, sexp] include Comparator.S with type t := t end) : Map_and_set_binable with type t := T.t with type comparator_witness := T.comparator_witness module Poly (T : sig type t [@@deriving sexp] end) : S with type t := T.t module Validate (T : sig type t [@@deriving compare, sexp_of] end) : Validate with type t := T.t module Validate_with_zero (T : sig type t [@@deriving compare, sexp_of] val zero : t end) : Validate_with_zero with type t := T.t module With_zero (T : sig type t [@@deriving compare, sexp_of] val zero : t end) : With_zero with type t := T.t (** The following module types and functors may be used to define stable modules: *) module Stable : sig module V1 : sig module type S = sig type comparable type comparator_witness module Map : Map.Stable.V1.S with type key := comparable with type comparator_witness := comparator_witness module Set : Set.Stable.V1.S with type elt := comparable with type elt_comparator_witness := comparator_witness end module Make (X : Stable_module_types.S0) : S with type comparable := X.t with type comparator_witness := X.comparator_witness end end end core-0.15.0/core/src/comparator.ml000066400000000000000000000012211420273305200167370ustar00rootroot00000000000000open! Import module Comparator = Base.Comparator type ('a, 'witness) t = ('a, 'witness) Comparator.t = private { compare : 'a -> 'a -> int ; sexp_of_t : 'a -> Base.Sexp.t } module type Base_mask = module type of Comparator with type ('a, 'b) t := ('a, 'b) t include (Comparator : Base_mask) module Stable = struct module V1 = struct type nonrec ('a, 'witness) t = ('a, 'witness) t = private { compare : 'a -> 'a -> int ; sexp_of_t : 'a -> Base.Sexp.t } type ('a, 'b) comparator = ('a, 'b) t module type S = S module type S1 = S1 let make = make module Make = Make module Make1 = Make1 end end core-0.15.0/core/src/comparator.mli000066400000000000000000000022471420273305200171210ustar00rootroot00000000000000(** Extends {{!Base.Comparator}[Base.Comparator]}, providing a type-indexed value that allows you to compare values of that type. *) open! Import type ('a, 'witness) t = ('a, 'witness) Base.Comparator.t = private { compare : 'a -> 'a -> int ; sexp_of_t : 'a -> Base.Sexp.t } include module type of Base.Comparator with type ('a, 'witness) t := ('a, 'witness) t (** @inline *) (** The following module types and functors may be used to define stable modules *) module Stable : sig module V1 : sig type nonrec ('a, 'b) t = ('a, 'b) t = private { compare : 'a -> 'a -> int ; sexp_of_t : 'a -> Base.Sexp.t } type ('a, 'b) comparator = ('a, 'b) t module type S = sig type t type comparator_witness val comparator : (t, comparator_witness) comparator end module type S1 = sig type 'a t type comparator_witness val comparator : ('a t, comparator_witness) comparator end val make : compare:('a -> 'a -> int) -> sexp_of_t:('a -> Base.Sexp.t) -> (module S_fc with type comparable_t = 'a) module Make : module type of Make module Make1 : module type of Make1 end end core-0.15.0/core/src/container.ml000066400000000000000000000001231420273305200165520ustar00rootroot00000000000000include Base.Container module type S1_permissions = Container_intf.S1_permissions core-0.15.0/core/src/container.mli000066400000000000000000000007751420273305200167400ustar00rootroot00000000000000(** Provides generic signatures for container data structures. These signatures include functions ([iter], [fold], [exists], [for_all], ...) that you would expect to find in any container. Used by including [Container.S0] or [Container.S1] in the signature for every container-like data structure ([Array], [List], [String], ...) to ensure a consistent interface. These signatures extend signatures exported by {!Base.Container_intf}. *) include Container_intf.Container (** @inline *) core-0.15.0/core/src/container_intf.ml000066400000000000000000000065701420273305200176060ustar00rootroot00000000000000(** This module extends {!Base.Container}. *) open! Import open Perms.Export open Base.Container module Continue_or_stop = Continue_or_stop module type S1_permissions = sig type ('a, -'permissions) t (** Checks whether the provided element is there, using polymorphic compare if [equal] is not provided. *) val mem : ('a, [> read ]) t -> 'a -> equal:('a -> 'a -> bool) -> bool val length : (_, [> read ]) t -> int val is_empty : (_, [> read ]) t -> bool (** [iter t ~f] calls [f] on each element of [t]. *) val iter : ('a, [> read ]) t -> f:('a -> unit) -> unit (** [fold t ~init ~f] returns [f (... f (f (f init e1) e2) e3 ...) en], where [e1..en] are the elements of [t] *) val fold : ('a, [> read ]) t -> init:'accum -> f:('accum -> 'a -> 'accum) -> 'accum (** [fold_result t ~init ~f] is a short-circuiting version of [fold] that runs in the [Result] monad. If [f] returns an [Error _], that value is returned without any additional invocations of [f]. *) val fold_result : ('a, [> read ]) t -> init:'accum -> f:('accum -> 'a -> ('accum, 'e) Result.t) -> ('accum, 'e) Result.t (** [fold_until t ~init ~f ~finish] is a short-circuiting version of [fold]. If [f] returns [Stop _] the computation ceases and results in that value. If [f] returns [Continue _], the fold will proceed. If [f] never returns [Stop _], the final result is computed by [finish]. *) val fold_until : ('a, [> read ]) t -> init:'accum -> f:('accum -> 'a -> ('accum, 'final) Continue_or_stop.t) -> finish:('accum -> 'final) -> 'final (** Returns [true] if and only if there exists an element for which the provided function evaluates to [true]. This is a short-circuiting operation. *) val exists : ('a, [> read ]) t -> f:('a -> bool) -> bool (** Returns [true] if and only if the provided function evaluates to [true] for all elements. This is a short-circuiting operation. *) val for_all : ('a, [> read ]) t -> f:('a -> bool) -> bool (** Returns the number of elements for which the provided function evaluates to true. *) val count : ('a, [> read ]) t -> f:('a -> bool) -> int (** Returns the sum of [f i] for i in the container *) val sum : (module Summable with type t = 'sum) -> ('a, [> read ]) t -> f:('a -> 'sum) -> 'sum (** Returns as an [option] the first element for which [f] evaluates to true. *) val find : ('a, [> read ]) t -> f:('a -> bool) -> 'a option (** Returns the first evaluation of [f] that returns [Some], and returns [None] if there is no such element. *) val find_map : ('a, [> read ]) t -> f:('a -> 'b option) -> 'b option val to_list : ('a, [> read ]) t -> 'a list val to_array : ('a, [> read ]) t -> 'a array (** Returns a min (resp max) element from the collection using the provided [compare] function. In case of a tie, the first element encountered while traversing the collection is returned. The implementation uses [fold] so it has the same complexity as [fold]. Returns [None] iff the collection is empty. *) val min_elt : ('a, [> read ]) t -> compare:('a -> 'a -> int) -> 'a option val max_elt : ('a, [> read ]) t -> compare:('a -> 'a -> int) -> 'a option end module type Container = sig (** @open *) include module type of struct include Base.Container end module type S1_permissions = S1_permissions end core-0.15.0/core/src/core.ml000066400000000000000000000173731420273305200155370ustar00rootroot00000000000000(** Core greatly expands the functionality available in Base while still remaining platform-agnostic. Core changes more frequently (i.e., is less stable) than Base. Some modules are mere extensions of their counterparts in Base, usually adding generic functionality by including functors that make them binable, comparable, sexpable, blitable, etc. The bulk of Core, though, is modules providing entirely new functionality. *) open! Import module Applicative = Applicative module Arg = Arg module Array = Array module Avltree = Avltree module Backtrace = Backtrace module Bag = Bag module Bigbuffer = Bigbuffer module Bigstring = Bigstring module Bigsubstring = Bigsubstring module Bin_prot = Core_bin_prot module Binable = Binable module Binary_search = Binary_search module Binary_searchable = Binary_searchable module Blang = Blang module Blit = Blit module Bool = Bool module Bounded_index = Bounded_index module Buffer = Base.Buffer module Byte_units = Byte_units module Bytes = Bytes module Caml = struct include Caml (* When we removed [Core.Caml]'s extensions of [Core.Caml], we added the declarations below to force code to switch to the new names, and avoid silently incorrectly using something else in scope. *) module Condition = struct end [@@deprecated "[since 2021-02] Use [Caml_threads.Condition]"] module Mutex = struct end [@@deprecated "[since 2021-02] Use [Caml_threads.Mutex]"] module Thread = struct end [@@deprecated "[since 2021-02] Use [Caml_threads.Thread]"] module Unix = struct end [@@deprecated "[since 2021-02] Use [Caml_unix]"] module UnixLabels = struct end [@@deprecated "[since 2021-02] Use [UnixLabels]"] end module Char = Char module Command = Command module Comparable = Comparable module Comparator = Comparator module Comparisons = Comparisons module Container = Container module Container_intf = Container_intf module Continue_or_stop = Continue_or_stop module Core_kernel_stable = Stable [@@deprecated "[since 2021-05] Use [Core_stable] -- [Core_kernel] was renamed as [Core]"] module Core_stable = Stable module Date = Date module Day_of_week = Day_of_week module Debug = Debug module Deque = Deque module Deriving_hash = Deriving_hash module Digest = Md5 [@@ocaml.deprecated "[since 2017-05] Use Md5 instead."] module Doubly_linked = Doubly_linked module Either = Either module Ephemeron = Ephemeron module Equal = Equal module Error = Error module Exn = Base.Exn module Expect_test_config = Expect_test_config module Fdeque = Fdeque module Field = Field module Filename = Filename module Float = Float module Float_with_finite_only_serialization = Float_with_finite_only_serialization module Floatable = Floatable module Fn = Fn module Formatter = Formatter module Fqueue = Fqueue module Gc = Gc module Hash = Hash module Hash_queue = Hash_queue module Hash_set = Hash_set module Hashable = Hashable module Hashtbl = Hashtbl module Hashtbl_intf = Hashtbl_intf module Heap_block = Heap_block module Hexdump = Hexdump module Hexdump_intf = Hexdump_intf module Host_and_port = Host_and_port module Identifiable = Identifiable module Immediate_option = Immediate_option module Immediate_option_intf = Immediate_option_intf module In_channel = In_channel module Indexed_container = Indexed_container module Info = Info module Int = Int module Int32 = Int32 module Int63 = Int63 module Int64 = Int64 module Int_conversions = Int_conversions module Int_intf = Int_intf module Int_math = Int_math module Intable = Intable module Interfaces = Interfaces module Invariant = Invariant module Lazy = Lazy module Linked_queue = Linked_queue module List = List module Map = Map module Map_intf = Map_intf module Maybe_bound = Maybe_bound module Md5 = Md5 module Memo = Memo module Monad = Monad module Month = Month module Mutex = struct end [@@deprecated "[since 2019-02] Use [Error_checking_mutex] or [Caml_threads.Mutex]"] module Nativeint = Nativeint module No_polymorphic_compare = No_polymorphic_compare module Nothing = Nothing module Only_in_test = Only_in_test module Option = Option module Option_array = Option_array module Optional_syntax = Optional_syntax module Optional_syntax_intf = Optional_syntax_intf module Or_error = Or_error module Ordered_collection_common = Ordered_collection_common module Ordering = Ordering module Out_channel = Out_channel module Percent = Percent module Perms = Perms module Pid = Pid module Poly = Poly module Polymorphic_compare = Poly [@@deprecated "[since 2018-11] use [Poly] instead"] module Popcount = Base.Popcount [@@warning "-3"] [@@deprecated "[since 2018-10] use [popcount] functions in individual int modules"] module Pretty_printer = Pretty_printer module Printexc = Printexc module Printf = Printf module Queue = Queue module Quickcheck = Quickcheck module Quickcheck_intf = Quickcheck_intf module Quickcheckable = Quickcheckable module Random = Base.Random module Ref = Ref module Result = Result module Robustly_comparable = Robustly_comparable module Sequence = Sequence module Set = Set module Set_intf = Set_intf module Set_once = Set_once module Sexp_maybe = Sexp.Sexp_maybe module Sexp = Sexp module Sexpable = Sexpable module Sign = Sign module Signal = Signal module Sign_or_nan = Sign_or_nan module Source_code_position = Source_code_position module Splittable_random = Splittable_random module Stable_comparable = Stable_comparable module Stable_unit_test = Stable_unit_test module Stack = Stack module Staged = Base.Staged module String = String module String_id = String_id module Stringable = Stringable module Substring = Substring module Substring_intf = Substring_intf module Sys = Core_sys module Thread = struct end [@@deprecated "[since 2021-04] Use [Core_thread] or [Caml_threads.Thread]"] module Time = Time_float module Time_ns = Time_ns module Tuple = Tuple module Tuple2 = Tuple.T2 module Tuple3 = Tuple.T3 module Type_equal = Type_equal module Type_immediacy = Type_immediacy module Uchar = Uchar module Uniform_array = Uniform_array module Union_find = Union_find module Unique_id = Unique_id module Unit = Unit module Unit_of_time = Unit_of_time module Univ_map = Univ_map module Unix = struct end [@@deprecated "[since 2020-03] Core shadows Unix. Use Core_unix, which overrides some of Unix's \ behavior. If necessary, Unix is available and unshadowed as Caml_unix."] module Validate = Validate module Validated = Validated module Variant = Variant module Weak = Weak module With_return = With_return module Word_size = Word_size module type Unique_id = Unique_id.Id include T (** @open *) include Std_internal include Not_found (** {2 Top-level values} *) type 'a _maybe_bound = 'a Maybe_bound.t = | Incl of 'a | Excl of 'a | Unbounded let am_running_inline_test = am_running_inline_test let am_running_test = am_running_test let does_raise = Exn.does_raise let sec = Time_float.Span.of_sec let ( ^/ ) = Filename.concat (** We perform these side effects here because we want them to run for any code that uses [Core]. If this were in another module in [Core] that was not used in some program, then the side effects might not be run in that program. This will run as long as the program refers to at least one value directly in Core; referring to values in [Core.Bool], for example, is not sufficient. *) let () = Exn.initialize_module () (** To be used in implementing Core, but not by end users. *) module Core_private = struct module Digit_string_helpers = Digit_string_helpers module Time_zone = Zone module Ofday_helpers = Ofday_helpers module Span_float = Span_float module Bigbuffer_internal = Bigbuffer_internal module Stable_internal = Stable_internal module Std_internal = Std_internal module Time_ns_alternate_sexp = Time_ns_alternate_sexp end module Core_kernel_private = Core_private [@@deprecated "[since 2021-05] Use [Core_private] -- [Core_kernel] was renamed as [Core]"] core-0.15.0/core/src/core_bigstring.h000066400000000000000000000013031420273305200174100ustar00rootroot00000000000000#ifndef __CORE_BIGSTRING_H #define __CORE_BIGSTRING_H #include /* Bigarray flags for creating a [Bigstring.t] */ #define CORE_BIGSTRING_FLAGS (CAML_BA_CHAR | CAML_BA_C_LAYOUT) /* Do not call [unmap] for bigstrings with kind [CAML_BA_MAPPED_FILE] */ #define CORE_BIGSTRING_DESTROY_DO_NOT_UNMAP 1 /* Don't fail on bigstring with kind [CAML_BA_EXTERNAL] */ #define CORE_BIGSTRING_DESTROY_ALLOW_EXTERNAL 2 /* Destroy a bigstring: - free the memory with [free] if it is managed by ocaml - reset all its dimmensions to 0 - [unmap] if it is a memory-map - set its kind to [CAML_BA_EXTERNAL] */ void core_bigstring_destroy(value v, int flags); #endif /* __CORE_BIGSTRING_H */ core-0.15.0/core/src/core_bin_prot.ml000066400000000000000000000023651420273305200174260ustar00rootroot00000000000000open! Import include Bin_prot module Writer = struct type 'a t = 'a Bin_prot.Type_class.writer = { size : 'a Size.sizer ; write : 'a Write.writer } let to_string t v = let len = t.size v in let buf = Bigstring.create len in let pos = t.write buf ~pos:0 v in assert (pos = Bigstring.length buf); let str = Bigstring.to_string buf in Bigstring.unsafe_destroy buf; str ;; let to_bytes t v = let len = t.size v in let buf = Bigstring.create len in let pos = t.write buf ~pos:0 v in assert (pos = Bigstring.length buf); let str = Bigstring.to_bytes buf in Bigstring.unsafe_destroy buf; str ;; end module Reader = struct type 'a t = 'a Bin_prot.Type_class.reader = { read : 'a Read.reader ; vtag_read : (int -> 'a) Read.reader } let of_string t string = let buf = Bigstring.of_string string in let pos_ref = ref 0 in let v = t.read buf ~pos_ref in assert (!pos_ref = Bigstring.length buf); Bigstring.unsafe_destroy buf; v ;; let of_bytes t bytes = let buf = Bigstring.of_bytes bytes in let pos_ref = ref 0 in let v = t.read buf ~pos_ref in assert (!pos_ref = Bigstring.length buf); Bigstring.unsafe_destroy buf; v ;; end core-0.15.0/core/src/core_bin_prot.mli000066400000000000000000000007401420273305200175720ustar00rootroot00000000000000open! Import include module type of Bin_prot module Writer : sig type 'a t = 'a Bin_prot.Type_class.writer = { size : 'a Size.sizer ; write : 'a Write.writer } val to_string : 'a t -> 'a -> string val to_bytes : 'a t -> 'a -> bytes end module Reader : sig type 'a t = 'a Bin_prot.Type_class.reader = { read : 'a Read.reader ; vtag_read : (int -> 'a) Read.reader } val of_string : 'a t -> string -> 'a val of_bytes : 'a t -> bytes -> 'a end core-0.15.0/core/src/core_pervasives.ml000066400000000000000000000013111420273305200177670ustar00rootroot00000000000000include Caml (* At Jane Street, the OCaml stdlib is patched to define [Pervasives.raise] as the ["%reraise"] primitive. We do this as the compiler is currently not good enough at automatically detecting reraise [1]. We patch the stdlib so that everything is affected, including libraries defined before base such as sexplib or non Jane Street libraries. We need this definition so that this implementation can match its interface with the patched stdlib and with the original one. [[1] http://caml.inria.fr/mantis/view.php?id=6556 *) external raise : exn -> 'a = "%reraise" [%%if ocaml_version < (4, 12, 0)] let __FUNCTION__ = "<__FUNCTION__ not supported before OCaml 4.12>" [%%endif] core-0.15.0/core/src/core_pervasives.mli000066400000000000000000001366311420273305200201560ustar00rootroot00000000000000 (** This module has exactly the same interface and implementation as INRIA's Pervasives, except that some things are deprecated in favor of Core equivalents. Functions here are in one of four states: 1. Deprecated using [@@deprecated]. 2. Accepted as part of Core for the forseeable future. 3. We haven't yet decided whether to deprecate, as indicated by a CR. 4. We plan to deprecate eventually, but haven't yet, as indicated by a CR. Eventually, this module will be removed, and it will be recommended to compile with -nopervasives when using Core. *) (** {6 Exceptions} *) (** Raise the given exception value *) external raise : exn -> 'a = "%reraise" (** A faster version [raise] which does not record the backtrace. @since 4.02.0 *) external raise_notrace : exn -> 'a = "%raise_notrace" (** Raise exception [Invalid_argument] with the given string. *) val invalid_arg : string -> 'a (** Raise exception [Failure] with the given string. *) val failwith : string -> 'a (** The [Exit] exception is not raised by any library function. It is provided for use in your programs. *) exception Exit (** {6 Comparisons} *) (** [e1 = e2] tests for structural equality of [e1] and [e2]. Mutable structures (e.g. references and arrays) are equal if and only if their current contents are structurally equal, even if the two mutable objects are not the same physical object. Equality between functional values raises [Invalid_argument]. Equality between cyclic data structures may not terminate. *) external ( = ) : 'a -> 'a -> bool = "%equal" (** Negation of {!Poly.( = )}. *) external ( <> ) : 'a -> 'a -> bool = "%notequal" (** See {!Poly.( >= )}. *) external ( < ) : 'a -> 'a -> bool = "%lessthan" (** See {!Poly.( >= )}. *) external ( > ) : 'a -> 'a -> bool = "%greaterthan" (** See {!Poly.( >= )}. *) external ( <= ) : 'a -> 'a -> bool = "%lessequal" (** Structural ordering functions. These functions coincide with the usual orderings over integers, characters, strings, byte sequences and floating-point numbers, and extend them to a total ordering over all types. The ordering is compatible with [( = )]. As in the case of [( = )], mutable structures are compared by contents. Comparison between functional values raises [Invalid_argument]. Comparison between cyclic structures may not terminate. *) external ( >= ) : 'a -> 'a -> bool = "%greaterequal" (** [compare x y] returns [0] if [x] is equal to [y], a negative integer if [x] is less than [y], and a positive integer if [x] is greater than [y]. The ordering implemented by [compare] is compatible with the comparison predicates [=], [<] and [>] defined above, with one difference on the treatment of the float value {!Caml.nan}. Namely, the comparison predicates treat [nan] as different from any other float value, including itself; while [compare] treats [nan] as equal to itself and less than any other float value. This treatment of [nan] ensures that [compare] defines a total ordering relation. [compare] applied to functional values may raise [Invalid_argument]. [compare] applied to cyclic structures may not terminate. The [compare] function can be used as the comparison function required by the {!Set.Make} and {!Map.Make} functors, as well as the {!List.sort} and {!Array.sort} functions. *) external compare : 'a -> 'a -> int = "%compare" (** Return the smaller of the two arguments. The result is unspecified if one of the arguments contains the float value [nan]. *) val min : 'a -> 'a -> 'a (** Return the greater of the two arguments. The result is unspecified if one of the arguments contains the float value [nan]. *) val max : 'a -> 'a -> 'a (** [e1 == e2] tests for physical equality of [e1] and [e2]. On mutable types such as references, arrays, byte sequences, records with mutable fields and objects with mutable instance variables, [e1 == e2] is true if and only if physical modification of [e1] also affects [e2]. On non-mutable types, the behavior of [( == )] is implementation-dependent; however, it is guaranteed that [e1 == e2] implies [compare e1 e2 = 0]. *) external ( == ) : 'a -> 'a -> bool = "%eq" [@@deprecated "[since 2014-10] Use [phys_equal]"] (** Negation of {!( == )}. *) external ( != ) : 'a -> 'a -> bool = "%noteq" [@@deprecated "[since 2014-10] Use [phys_equal]"] (** {6 Boolean operations} *) (** The boolean negation. *) external not : bool -> bool = "%boolnot" (** 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 = "%sequand" external ( & ) : bool -> bool -> bool = "%sequand" [@@ocaml.deprecated "[since 2010-01] {!Caml.( && )} should be used instead."] (** 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. *) external ( || ) : bool -> bool -> bool = "%sequor" external ( or ) : bool -> bool -> bool = "%sequor" [@@ocaml.deprecated "[since 2010-01] {!Caml.( || )} should be used instead."] (** {6 Debugging} *) (** [__LOC__] returns the location at which this expression appears in the file currently being parsed by the compiler, with the standard error format of OCaml: "File %S, line %d, characters %d-%d" *) external __LOC__ : string = "%loc_LOC" (** [__FILE__] returns the name of the file currently being parsed by the compiler. *) external __FILE__ : string = "%loc_FILE" (** [__LINE__] returns the line number at which this expression appears in the file currently being parsed by the compiler. *) external __LINE__ : int = "%loc_LINE" (** [__MODULE__] returns the module name of the file being parsed by the compiler. *) external __MODULE__ : string = "%loc_MODULE" (** [__POS__] returns a tuple [(file,lnum,cnum,enum)], corresponding to the location at which this expression appears in the file currently being parsed by the compiler. [file] is the current filename, [lnum] the line number, [cnum] the character position in the line and [enum] the last character position in the line. *) external __POS__ : string * int * int * int = "%loc_POS" [%%if ocaml_version >= (4, 12, 0)] (** [__FUNCTION__] returns the name of the current function or method, including any enclosing modules or classes. *) external __FUNCTION__ : string = "%loc_FUNCTION" [%%else] val __FUNCTION__ : string [%%endif] (** [__LOC_OF__ expr] returns a pair [(loc, expr)] where [loc] is the location of [expr] in the file currently being parsed by the compiler, with the standard error format of OCaml: "File %S, line %d, characters %d-%d" *) external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC" (** [__LINE_OF__ expr] returns a pair [(line, expr)], where [line] is the line number at which the expression [expr] appears in the file currently being parsed by the compiler. *) external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE" (** [__POS_OF__ expr] returns a pair [(expr,loc)], where [loc] is a tuple [(file,lnum,cnum,enum)] corresponding to the location at which the expression [expr] appears in the file currently being parsed by the compiler. [file] is the current filename, [lnum] the line number, [cnum] the character position in the line and [enum] the last character position in the line. *) external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" (** {6 Composition operators} *) (** Reverse-application operator: [x |> f |> g] is exactly equivalent to [g (f (x))]. @since 4.01 *) external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" (** Application operator: [g @@ f @@ x] is exactly equivalent to [g (f (x))]. @since 4.01 *) external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" (** {6 Integer arithmetic} *) (** Integers are 31 bits wide (or 63 bits on 64-bit processors). All operations are taken modulo 2{^31} (or 2{^63}). They do not fail on overflow. *) (** Unary negation. You can also write [- e] instead of [~- e]. *) external ( ~- ) : int -> int = "%negint" (** Unary addition. You can also write [+ e] instead of [~+ e]. @since 3.12.0 *) external ( ~+ ) : int -> int = "%identity" (** [succ x] is [x + 1]. *) external succ : int -> int = "%succint" (** [pred x] is [x - 1]. *) external pred : int -> int = "%predint" (** Integer addition. *) external ( + ) : int -> int -> int = "%addint" (** Integer subtraction. *) external ( - ) : int -> int -> int = "%subint" (** Integer multiplication. *) external ( * ) : int -> int -> int = "%mulint" (** Integer division. Raise [Division_by_zero] if the second argument is 0. Integer division rounds the real quotient of its arguments towards zero. More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer less than or equal to the real quotient of [x] by [y]. Moreover, [(- x) / y = x / (- y) = - (x / y)]. *) external ( / ) : int -> int -> int = "%divint" (** Integer remainder. If [y] is not zero, the result of [x mod y] satisfies the following properties: [x = (x / y) * y + x mod y] and [abs(x mod y) <= abs(y) - 1]. If [y = 0], [x mod y] raises [Division_by_zero]. Note that [x mod y] is negative only if [x < 0]. Raise [Division_by_zero] if [y] is zero. *) external ( mod ) : int -> int -> int = "%modint" (** Return the absolute value of the argument. Note that this may be negative if the argument is [min_int]. *) val abs : int -> int (** The greatest representable integer. *) val max_int : int [@@deprecated "[since 2014-10] Use [Int.max_value]"] (** The smallest representable integer. *) val min_int : int [@@deprecated "[since 2014-10] Use [Int.min_value]"] (** {7 Bitwise operations} *) (** Bitwise logical and. *) external ( land ) : int -> int -> int = "%andint" (** Bitwise logical or. *) external ( lor ) : int -> int -> int = "%orint" (** Bitwise logical exclusive or. *) external ( lxor ) : int -> int -> int = "%xorint" (** Bitwise logical negation. *) val lnot : int -> int (** [n lsl m] shifts [n] to the left by [m] bits. The result is unspecified if [m < 0] or [m >= bitsize], where [bitsize] is [32] on a 32-bit platform and [64] on a 64-bit platform. *) external ( lsl ) : int -> int -> int = "%lslint" (** [n lsr m] shifts [n] to the right by [m] bits. This is a logical shift: zeroes are inserted regardless of the sign of [n]. The result is unspecified if [m < 0] or [m >= bitsize]. *) external ( lsr ) : int -> int -> int = "%lsrint" (** [n asr m] shifts [n] to the right by [m] bits. This is an arithmetic shift: the sign bit of [n] is replicated. The result is unspecified if [m < 0] or [m >= bitsize]. *) external ( asr ) : int -> int -> int = "%asrint" (** {6 Floating-point arithmetic} 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 arithmetic operation with [nan] as argument returns [nan] as result. *) (** Unary negation. You can also write [-. e] instead of [~-. e]. *) external ( ~-. ) : float -> float = "%negfloat" (** Unary addition. You can also write [+. e] instead of [~+. e]. @since 3.12.0 *) external ( ~+. ) : float -> float = "%identity" (** Floating-point addition *) external ( +. ) : float -> float -> float = "%addfloat" (** Floating-point subtraction *) external ( -. ) : float -> float -> float = "%subfloat" (** Floating-point multiplication *) external ( *. ) : float -> float -> float = "%mulfloat" (** Floating-point division. *) external ( /. ) : float -> float -> float = "%divfloat" (** Exponentiation. *) external ( ** ) : float -> float -> float = "caml_power_float" "pow" [@@unboxed] [@@noalloc] (** Square root. *) external sqrt : float -> float = "caml_sqrt_float" "sqrt" [@@unboxed] [@@noalloc] (** Exponential. *) external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc] (** Natural logarithm. *) external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc] (** Base 10 logarithm. *) external log10 : float -> float = "caml_log10_float" "log10" [@@unboxed] [@@noalloc] [@@deprecated "[since 2016-07] Use [Float.log10]"] (** [expm1 x] computes [exp x -. 1.0], giving numerically-accurate results even if [x] is close to [0.0]. @since 3.12.0 *) external expm1 : float -> float = "caml_expm1_float" "caml_expm1" [@@unboxed] [@@noalloc] [@@deprecated "[since 2016-07] Use [Float.expm1]"] (** [log1p x] computes [log(1.0 +. x)] (natural logarithm), giving numerically-accurate results even if [x] is close to [0.0]. @since 3.12.0 *) external log1p : float -> float = "caml_log1p_float" "caml_log1p" [@@unboxed] [@@noalloc] [@@deprecated "[since 2016-07] Use [Float.log1p]"] (** Cosine. Argument is in radians. *) external cos : float -> float = "caml_cos_float" "cos" [@@unboxed] [@@noalloc] [@@deprecated "[since 2016-07] Use [Float.cos]"] (** Sine. Argument is in radians. *) external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc] [@@deprecated "[since 2016-07] Use [Float.sin]"] (** Tangent. Argument is in radians. *) external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc] [@@deprecated "[since 2016-07] Use [Float.tan]"] (** Arc cosine. The argument must fall within the range [[-1.0, 1.0]]. Result is in radians and is between [0.0] and [pi]. *) external acos : float -> float = "caml_acos_float" "acos" [@@unboxed] [@@noalloc] [@@deprecated "[since 2016-07] Use [Float.acos]"] (** Arc sine. The argument must fall within the range [[-1.0, 1.0]]. Result is in radians and is between [-pi/2] and [pi/2]. *) external asin : float -> float = "caml_asin_float" "asin" [@@unboxed] [@@noalloc] [@@deprecated "[since 2016-07] Use [Float.asin]"] (** Arc tangent. Result is in radians and is between [-pi/2] and [pi/2]. *) external atan : float -> float = "caml_atan_float" "atan" [@@unboxed] [@@noalloc] [@@deprecated "[since 2016-07] Use [Float.atan]"] (** [atan2 y x] returns the arc tangent of [y /. x]. The signs of [x] and [y] are used to determine the quadrant of the result. Result is in radians and is between [-pi] and [pi]. *) external atan2 : float -> float -> float = "caml_atan2_float" "atan2" [@@unboxed] [@@noalloc] [@@deprecated "[since 2016-07] Use [Float.atan2]"] (** [hypot x y] returns [sqrt(x *. x + y *. y)], that is, the length of the hypotenuse of a right-angled triangle with sides of length [x] and [y], or, equivalently, the distance of the point [(x,y)] to origin. @since 4.00.0 *) external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot" [@@unboxed] [@@noalloc] [@@deprecated "[since 2016-07] Use [Float.hypot]"] (** Hyperbolic cosine. Argument is in radians. *) external cosh : float -> float = "caml_cosh_float" "cosh" [@@unboxed] [@@noalloc] [@@deprecated "[since 2016-07] Use [Float.cosh]"] (** Hyperbolic sine. Argument is in radians. *) external sinh : float -> float = "caml_sinh_float" "sinh" [@@unboxed] [@@noalloc] [@@deprecated "[since 2016-07] Use [Float.sinh]"] (** Hyperbolic tangent. Argument is in radians. *) external tanh : float -> float = "caml_tanh_float" "tanh" [@@unboxed] [@@noalloc] [@@deprecated "[since 2016-07] Use [Float.tanh]"] (** Round above to an integer value. [ceil f] returns the least integer value greater than or equal to [f]. The result is returned as a float. *) external ceil : float -> float = "caml_ceil_float" "ceil" [@@unboxed] [@@noalloc] [@@deprecated "[since 2014-10] Use [Float.round_up]"] (** Round below to an integer value. [floor f] returns the greatest integer value less than or equal to [f]. The result is returned as a float. *) external floor : float -> float = "caml_floor_float" "floor" [@@unboxed] [@@noalloc] [@@deprecated "[since 2014-10] Use [Float.round_down]"] (** [abs_float f] returns the absolute value of [f]. *) external abs_float : float -> float = "%absfloat" [@@deprecated "[since 2014-10] Use [Float.abs]"] (** [copysign x y] returns a float whose absolute value is that of [x] and whose sign is that of [y]. If [x] is [nan], returns [nan]. If [y] is [nan], returns either [x] or [-. x], but it is not specified which. @since 4.00.0 *) external copysign : float -> float -> float = "caml_copysign_float" "caml_copysign" [@@unboxed] [@@noalloc] [@@deprecated "[since 2016-07] Use [Float.copysign]"] (** [mod_float a b] returns the remainder of [a] with respect to [b]. The returned value is [a -. n *. b], where [n] is the quotient [a /. b] rounded towards zero to an integer. *) external mod_float : float -> float -> float = "caml_fmod_float" "fmod" [@@unboxed] [@@noalloc] [@@deprecated "[since 2014-10] Use [Float.mod_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 frexp : float -> float * int = "caml_frexp_float" [@@deprecated "[since 2014-10] Use [Float.frexp]"] (** [ldexp x n] returns [x *. 2 ** n]. *) external ldexp : (float[@unboxed]) -> (int[@untagged]) -> (float[@unboxed]) = "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc] [@@deprecated "[since 2014-10] Use [Float.ldexp]"] (** [modf f] returns the pair of the fractional and integral part of [f]. *) external modf : float -> float * float = "caml_modf_float" [@@deprecated "[since 2014-10] Use [Float.modf]"] (** Same as {!Caml.float_of_int}. *) external float : int -> float = "%floatofint" (** Convert an integer to floating-point. *) external float_of_int : int -> float = "%floatofint" (** Same as {!Caml.int_of_float}. *) external truncate : float -> int = "%intoffloat" [@@deprecated "[since 2014-10] Use [Float.iround_towards_zero_exn]"] (** Truncate the given floating-point number to an integer. The result is unspecified if the argument is [nan] or falls outside the range of representable integers. *) external int_of_float : float -> int = "%intoffloat" (** Positive infinity. *) val infinity : float [@@deprecated "[since 2014-10] Use [Float.infinity]"] (** Negative infinity. *) val neg_infinity : float [@@deprecated "[since 2014-10] Use [Float.neg_infinity]"] (** 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 nan : float [@@deprecated "[since 2014-10] Use [Float.nan]"] (** The largest positive finite value of type [float]. *) val max_float : float [@@deprecated "[since 2014-10] Use [Float.max_value]"] (** The smallest positive, non-zero, non-denormalized value of type [float]. *) val min_float : float [@@deprecated "[since 2014-10] Use [Float.min_value]"] (** The difference between [1.0] and the smallest exactly representable floating-point number greater than [1.0]. *) val epsilon_float : float [@@deprecated "[since 2014-10] Use [Float.epsilon_float]"] (** The five classes of floating-point numbers, as determined by the {!Caml.classify_float} function. *) type fpclass = Caml.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 *) (** Return the class of the given floating-point number: normal, subnormal, zero, infinite, or not a number. *) external classify_float : (float[@unboxed]) -> fpclass = "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc] [@@deprecated "[since 2014-10] Use [Float.classify]"] (** {6 String operations} More string operations are provided in module {!String}. *) (** String concatenation. *) val ( ^ ) : string -> string -> string (** {6 Character operations} More character operations are provided in module {!Char}. *) (** Return the ASCII code of the argument. *) external int_of_char : char -> int = "%identity" (** Return the character with the given ASCII code. Raise [Invalid_argument "char_of_int"] if the argument is outside the range 0--255. *) val char_of_int : int -> char (** {6 Unit operations} *) (** Discard the value of its argument and return [()]. For instance, [ignore(f x)] discards the result of the side-effecting function [f]. It is equivalent to [f x; ()], except that the latter may generate a compiler warning; writing [ignore(f x)] instead avoids the warning. *) external ignore : 'a -> unit = "%ignore" (** {6 String conversion functions} *) (** Return the string representation of a boolean. As the returned values may be shared, the user should not modify them directly. *) val string_of_bool : bool -> string (** Convert the given string to a boolean. Raise [Invalid_argument "bool_of_string"] if the string is not ["true"] or ["false"]. *) val bool_of_string : string -> bool (** Return the string representation of an integer, in decimal. *) val string_of_int : int -> string (** Convert the given string to an integer. The string is read in decimal (by default) or in hexadecimal (if it begins with [0x] or [0X]), octal (if it begins with [0o] or [0O]), or binary (if it begins with [0b] or [0B]). Raise [Failure "int_of_string"] 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]. *) external int_of_string : string -> int = "caml_int_of_string" (** Return the string representation of a floating-point number. *) val string_of_float : float -> string (** Convert the given string to a float. Raise [Failure "float_of_string"] if the given string is not a valid representation of a float. *) external float_of_string : string -> float = "caml_float_of_string" (** {6 Pair operations} *) [%%if flambda_backend] (** Return the first component of a pair. *) external fst : 'a * 'b -> 'a = "%field0_immut" (** Return the second component of a pair. *) external snd : 'a * 'b -> 'b = "%field1_immut" [%%else] (** Return the first component of a pair. *) external fst : 'a * 'b -> 'a = "%field0" (** Return the second component of a pair. *) external snd : 'a * 'b -> 'b = "%field1" [%%endif] (** {6 List operations} More list operations are provided in module {!List}. *) (** List concatenation. *) val ( @ ) : 'a list -> 'a list -> 'a list [@@deprecated "[since 2014-10] Use [List.Infix]"] (** {6 Input/output} Note: all input/output functions can raise [Sys_error] when the system calls they invoke fail. *) (** The type of input channel. *) type in_channel = Caml.in_channel [@@deprecated "[since 2016-04] Use [In_channel.t]"] (** The type of output channel. *) type out_channel = Caml.out_channel [@@deprecated "[since 2016-04] Use [Out_channel.t]"] (** The standard input for the process. *) val stdin : Caml.in_channel [@@deprecated "[since 2016-04] Use [In_channel.stdin]"] (** The standard output for the process. *) val stdout : Caml.out_channel (** The standard error output for the process. *) val stderr : Caml.out_channel (** {7 Output functions on standard output} *) (** Print a character on standard output. *) val print_char : char -> unit [@@deprecated "[since 2016-04] Use [Out_channel.output_char stdout]"] (** Print a string on standard output. *) val print_string : string -> unit (** Print a byte sequence on standard output. *) val print_bytes : bytes -> unit [@@deprecated "[since 2016-04] Core doesn't support [bytes] yet."] (** Print an integer, in decimal, on standard output. *) val print_int : int -> unit [@@deprecated "[since 2016-04] Use [Out_channel.output_string stdout]"] (** Print a floating-point number, in decimal, on standard output. *) val print_float : float -> unit [@@deprecated "[since 2016-04] Use [Out_channel.output_string stdout]"] (** Print a string, followed by a newline character, on standard output and flush standard output. *) val print_endline : string -> unit (** Print a newline character on standard output, and flush standard output. This can be used to simulate line buffering of standard output. *) val print_newline : unit -> unit [@@deprecated "[since 2016-04] Use [Out_channel.newline stdout]"] (** {7 Output functions on standard error} *) (** Print a character on standard error. *) val prerr_char : char -> unit [@@deprecated "[since 2016-04] Use [Out_channel.output_char stderr]"] (** Print a string on standard error. *) val prerr_string : string -> unit [@@deprecated "[since 2016-04] Use [Out_channel.output_string stderr]"] (** Print a byte sequence on standard error. *) val prerr_bytes : bytes -> unit [@@deprecated "[since 2016-04] Core doesn't support [bytes] yet"] (** Print an integer, in decimal, on standard error. *) val prerr_int : int -> unit [@@deprecated "[since 2016-04] Use [Out_channel.output_string stderr]"] (** Print a floating-point number, in decimal, on standard error. *) val prerr_float : float -> unit [@@deprecated "[since 2016-04] Use [Out_channel.output_string stderr]"] (** Print a string, followed by a newline character on standard error and flush standard error. *) val prerr_endline : string -> unit (** Print a newline character on standard error, and flush standard error. *) val prerr_newline : unit -> unit [@@deprecated "[since 2016-04] Use [Out_channel.newline stderr]"] (** {7 Input functions on standard input} *) (** Flush standard output, then read characters from standard input until a newline character is encountered. Return the string of all characters read, without the newline character at the end. *) val read_line : unit -> string [@@deprecated "[since 2016-04] Use\n[Out_channel.(flush stdout); In_channel.(input_line_exn stdin)]"] (** Flush standard output, then read one line from standard input and convert it to an integer. Raise [Failure "int_of_string"] if the line read is not a valid representation of an integer. *) val read_int : unit -> int [@@deprecated "[since 2016-04] Use\n\ [Out_channel.(flush stdout); Int.of_string In_channel.(input_line_exn stdin)]"] (** Flush standard output, then read one line from standard input and convert it to a floating-point number. The result is unspecified if the line read is not a valid representation of a floating-point number. *) val read_float : unit -> float [@@deprecated "[since 2016-04] Use\n\ [Out_channel.(flush stdout); Float.of_string In_channel.(input_line_exn stdin)]"] (** {7 General output functions} *) (** Opening modes for {!Caml.open_out_gen} and {!Caml.open_in_gen}. *) type open_flag = Caml.open_flag = | Open_rdonly (** open for reading. *) | Open_wronly (** open for writing. *) | Open_append (** open for appending: always write at end of file. *) | Open_creat (** create the file if it does not exist. *) | Open_trunc (** empty the file if it already exists. *) | Open_excl (** fail if Open_creat and the file already exists. *) | Open_binary (** open in binary mode (no conversion). *) | Open_text (** open in text mode (may perform conversions). *) | Open_nonblock (** open in non-blocking mode. *) [@@deprecated "[since 2016-04] Use [In_channel.create] and [Out_channel.create]"] (** Open the named file for writing, and return a new output channel on that file, positionned at the beginning of the file. The file is truncated to zero length if it already exists. It is created if it does not already exists. *) val open_out : string -> Caml.out_channel [@@deprecated "[since 2016-04] Use [Out_channel.create]"] (** Same as {!Caml.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 {!Caml.open_out}. *) val open_out_bin : string -> Caml.out_channel [@@deprecated "[since 2016-04] Use [Out_channel.create]"] (** [open_out_gen mode perm filename] opens the named file for writing, as described above. The extra argument [mode] specify the opening mode. The extra argument [perm] specifies the file permissions, in case the file must be created. {!Caml.open_out} and {!Caml.open_out_bin} are special cases of this function. *) val open_out_gen : Caml.open_flag list -> int -> string -> Caml.out_channel [@@deprecated "[since 2016-04] Use [Out_channel.create]"] (** Flush the buffer associated with the given output channel, performing all pending writes on that channel. Interactive programs must be careful about flushing standard output and standard error at the right time. *) val flush : Caml.out_channel -> unit [@@deprecated "[since 2016-04] Use [Out_channel.flush]"] (** Flush all open output channels; ignore errors. *) val flush_all : unit -> unit [@@deprecated "[since 2016-04]"] (** Write the character on the given output channel. *) val output_char : Caml.out_channel -> char -> unit [@@deprecated "[since 2016-04] Use [Out_channel.output_char]"] (** Write the string on the given output channel. *) val output_string : Caml.out_channel -> string -> unit [@@deprecated "[since 2016-04] Use [Out_channel.output_string]"] (** Write the byte sequence on the given output channel. *) val output_bytes : Caml.out_channel -> bytes -> unit [@@deprecated "[since 2016-04] Core doesn't yet support bytes."] (** [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 "output"] if [pos] and [len] do not designate a valid range of [buf]. *) val output : Caml.out_channel -> bytes -> int -> int -> unit [@@deprecated "[since 2016-04] Core doesn't yet support bytes."] (** Same as [output] but take a string as argument instead of a byte sequence. *) val output_substring : Caml.out_channel -> string -> int -> int -> unit [@@deprecated "[since 2016-04] Use [Out_channel.output]"] (** 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_byte : Caml.out_channel -> int -> unit [@@deprecated "[since 2016-04] Use [Out_channel.output_byte]"] (** 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 {!Caml.input_binary_int} function. The format is compatible across all machines for a given version of OCaml. *) val output_binary_int : Caml.out_channel -> int -> unit [@@deprecated "[since 2016-04] Use [Out_channel.output_binary_int]"] (** 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 {!Caml.input_value}. See the description of module {!Marshal} for more information. {!Caml.output_value} is equivalent to {!Marshal.to_channel} with an empty list of flags. *) val output_value : Caml.out_channel -> 'a -> unit [@@deprecated "[since 2016-04] Use [Out_channel.output_value]"] (** [seek_out chan pos] sets the current writing position to [pos] for channel [chan]. This works only for regular files. On files of other kinds (such as terminals, pipes and sockets), the behavior is unspecified. *) val seek_out : Caml.out_channel -> int -> unit [@@deprecated "[since 2014-10] Use [Out_channel.seek]"] (** Return the current writing position for the given channel. Does not work on channels opened with the [Open_append] flag (returns unspecified results). *) val pos_out : Caml.out_channel -> int [@@deprecated "[since 2014-10] Use [Out_channel.pos]"] (** Return the size (number of characters) of the regular file on which the given channel is opened. If the channel is opened on a file that is not a regular file, the result is meaningless. *) val out_channel_length : Caml.out_channel -> int [@@deprecated "[since 2014-10] Use [Out_channel.length]"] (** 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. Note that [close_out] may raise [Sys_error] if the operating system signals an error when flushing or closing. *) val close_out : Caml.out_channel -> unit [@@deprecated "[since 2014-10] Use [Out_channel.close]"] (** Same as [close_out], but ignore all errors. *) val close_out_noerr : Caml.out_channel -> unit [@@deprecated "[since 2016-04] Use [Out_channel.close] and catch exceptions"] (** [set_binary_mode_out oc true] sets the channel [oc] to binary mode: no translations take place during output. [set_binary_mode_out oc false] sets the channel [oc] to text mode: depending on the operating system, some translations may take place during output. For instance, under Windows, end-of-lines will be translated from [\n] to [\r\n]. This function has no effect under operating systems that do not distinguish between text mode and binary mode. *) val set_binary_mode_out : Caml.out_channel -> bool -> unit [@@deprecated "[since 2016-04] Use [Out_channel.set_binary_mode]"] (** {7 General input functions} *) (** Open the named file for reading, and return a new input channel on that file, positionned at the beginning of the file. *) val open_in : string -> Caml.in_channel [@@deprecated "[since 2016-04] Use [In_channel.create]"] (** Same as {!Caml.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 {!Caml.open_in}. *) val open_in_bin : string -> Caml.in_channel [@@deprecated "[since 2016-04] Use [In_channel.create]"] (** [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. {!Caml.open_in} and {!Caml.open_in_bin} are special cases of this function. *) val open_in_gen : Caml.open_flag list -> int -> string -> Caml.in_channel [@@deprecated "[since 2016-04] Use [In_channel.create]"] (** Read one character from the given input channel. Raise [End_of_file] if there are no more characters to read. *) val input_char : Caml.in_channel -> char [@@deprecated "[since 2016-04] Use [In_channel.input_char]"] (** 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_line : Caml.in_channel -> string [@@deprecated "[since 2016-04] Use [In_channel.input_line]"] (** [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 {!Caml.really_input} for reading exactly [len] characters.) Exception [Invalid_argument "input"] is raised if [pos] and [len] do not designate a valid range of [buf]. *) val input : Caml.in_channel -> bytes -> int -> int -> int [@@deprecated "[since 2016-04] Core doesn't yet support bytes."] (** [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 "really_input"] if [pos] and [len] do not designate a valid range of [buf]. *) val really_input : Caml.in_channel -> bytes -> int -> int -> unit [@@deprecated "[since 2016-04] Core doesn't yet support bytes."] (** [really_input_string ic len] reads [len] characters from channel [ic] and returns them in a new string. Raise [End_of_file] if the end of file is reached before [len] characters have been read. *) val really_input_string : Caml.in_channel -> int -> string [@@deprecated "[since 2016-04] Use [In_channel.really_input_exn ~pos:0]"] (** Same as {!Caml.input_char}, but return the 8-bit integer representing the character. Raise [End_of_file] if an end of file was reached. *) val input_byte : Caml.in_channel -> int [@@deprecated "[since 2016-04] Use [In_channel.input_byte]"] (** Read an integer encoded in binary format (4 bytes, big-endian) from the given input channel. See {!Caml.output_binary_int}. Raise [End_of_file] if an end of file was reached while reading the integer. *) val input_binary_int : Caml.in_channel -> int [@@deprecated "[since 2016-04] Use [In_channel.input_binary_int]"] (** Read the representation of a structured value, as produced by {!Caml.output_value}, and return the corresponding value. This function is identical to {!Marshal.from_channel}; see the description of module {!Marshal} for more information, in particular concerning the lack of type safety. *) val input_value : Caml.in_channel -> 'a [@@deprecated "[since 2016-04] Use [In_channel.unsafe_input_value]"] (** [seek_in chan pos] sets the current reading position to [pos] for channel [chan]. This works only for regular files. On files of other kinds, the behavior is unspecified. *) val seek_in : Caml.in_channel -> int -> unit [@@deprecated "[since 2014-10] Use [In_channel.seek]"] (** Return the current reading position for the given channel. *) val pos_in : Caml.in_channel -> int [@@deprecated "[since 2014-10] Use [In_channel.pos]"] (** Return the size (number of characters) of the regular file on which the given channel is opened. If the channel is opened on a file that is not a regular file, the result is meaningless. The returned size does not take into account the end-of-line translations that can be performed when reading from a channel opened in text mode. *) val in_channel_length : Caml.in_channel -> int [@@deprecated "[since 2014-10] Use [In_channel.length]"] (** 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. *) val close_in : Caml.in_channel -> unit [@@deprecated "[since 2014-10] Use [In_channel.close]"] (** Same as [close_in], but ignore all errors. *) val close_in_noerr : Caml.in_channel -> unit [@@deprecated "[since 2016-04] Use [In_channel.close] and catch exceptions"] (** [set_binary_mode_in ic true] sets the channel [ic] to binary mode: no translations take place during input. [set_binary_mode_out ic false] sets the channel [ic] to text mode: depending on the operating system, some translations may take place during input. For instance, under Windows, end-of-lines will be translated from [\r\n] to [\n]. This function has no effect under operating systems that do not distinguish between text mode and binary mode. *) val set_binary_mode_in : Caml.in_channel -> bool -> unit [@@deprecated "[since 2016-04] Use [In_channel.set_binary_mode]"] (** {7 Operations on large files} *) (** Operations on large files. This sub-module provides 64-bit variants of the channel functions that manipulate file positions and file sizes. By representing positions and sizes by 64-bit integers (type [int64]) instead of regular integers (type [int]), these alternate functions allow operating on files whose sizes are greater than [max_int]. *) module LargeFile : sig val seek_out : Caml.out_channel -> int64 -> unit val pos_out : Caml.out_channel -> int64 val out_channel_length : Caml.out_channel -> int64 val seek_in : Caml.in_channel -> int64 -> unit val pos_in : Caml.in_channel -> int64 val in_channel_length : Caml.in_channel -> int64 end [@@deprecated "[since 2016-04] Use [In_channel] and [Out_channel]"] (** {6 References} *) (** The type of references (mutable indirection cells) containing a value of type ['a]. *) type 'a ref = 'a Caml.ref = { mutable contents : 'a } (** Return a fresh reference containing the given value. *) external ref : 'a -> 'a ref = "%makemutable" (** [!r] returns the current contents of reference [r]. Equivalent to [fun r -> r.contents]. *) external ( ! ) : 'a ref -> 'a = "%field0" (** [r := a] stores the value of [a] in reference [r]. Equivalent to [fun r v -> r.contents <- v]. *) external ( := ) : 'a ref -> 'a -> unit = "%setfield0" (** Increment the integer contained in the given reference. Equivalent to [fun r -> r := succ !r]. *) external incr : int ref -> unit = "%incr" (** Decrement the integer contained in the given reference. Equivalent to [fun r -> r := pred !r]. *) external decr : int ref -> unit = "%decr" (** Result type *) type ('a, 'b) result = ('a, 'b) Caml.result = | Ok of 'a | Error of 'b (** {6 Operations on format strings} *) (** Format strings are character strings with special lexical conventions that defines the functionality of formatted input/output functions. Format strings are used to read data with formatted input functions from module {!Scanf} and to print data with formatted output functions from modules {!Printf} and {!Format}. Format strings are made of three kinds of entities: - {e conversions specifications}, introduced by the special character ['%'] followed by one or more characters specifying what kind of argument to read or print, - {e formatting indications}, introduced by the special character ['@'] followed by one or more characters specifying how to read or print the argument, - {e plain characters} that are regular characters with usual lexical conventions. Plain characters specify string literals to be read in the input or printed in the output. There is an additional lexical rule to escape the special characters ['%'] and ['@'] in format strings: if a special character follows a ['%'] character, it is treated as a plain character. In other words, ["%%"] is considered as a plain ['%'] and ["%@"] as a plain ['@']. For more information about conversion specifications and formatting indications available, read the documentation of modules {!Scanf}, {!Printf} and {!Format}. *) (** Format strings have a general and highly polymorphic type [('a, 'b, 'c, 'd, 'e, 'f) format6]. The two simplified types, [format] and [format4] below are included for backward compatibility with earlier releases of OCaml. The meaning of format string type parameters is as follows: - ['a] is the type of the parameters of the format for formatted output functions ([printf]-style functions); ['a] is the type of the values read by the format for formatted input functions ([scanf]-style functions). - ['b] is the type of input source for formatted input functions and the type of output target for formatted output functions. For [printf]-style functions from module [Printf], ['b] is typically [out_channel]; for [printf]-style functions from module [Format], ['b] is typically [Format.formatter]; for [scanf]-style functions from module [Scanf], ['b] is typically [Scanf.Scanning.in_channel]. Type argument ['b] is also the type of the first argument given to user's defined printing functions for [%a] and [%t] conversions, and user's defined reading functions for [%r] conversion. - ['c] is the type of the result of the [%a] and [%t] printing functions, and also the type of the argument transmitted to the first argument of [kprintf]-style functions or to the [kscanf]-style functions. - ['d] is the type of parameters for the [scanf]-style functions. - ['e] is the type of the receiver function for the [scanf]-style functions. - ['f] is the final result type of a formatted input/output function invocation: for the [printf]-style functions, it is typically [unit]; for the [scanf]-style functions, it is typically the result type of the receiver function. *) type ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6 type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 (** Converts a format string into a string. *) val string_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string (** [format_of_string s] returns a format string read from the string literal [s]. Note: [format_of_string] can not convert a string argument that is not a literal. If you need this functionality, use the more general {!Scanf.format_from_string} function. *) external format_of_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" (** [f1 ^^ f2] catenates format strings [f1] and [f2]. The result is a format string that behaves as the concatenation of format strings [f1] and [f2]: in case of formatted output, it accepts arguments from [f1], then arguments from [f2]; in case of formatted input, it returns results from [f1], then results from [f2]. *) val ( ^^ ) : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('f, 'b, 'c, 'e, 'g, 'h) format6 -> ('a, 'b, 'c, 'd, 'g, 'h) format6 (** {6 Program termination} *) (** Terminate the process, returning the given status code to the operating system: usually 0 to indicate no errors, and a small positive integer to indicate failure. All open output channels are flushed with [flush_all]. An implicit [exit 0] is performed each time a program terminates normally. An implicit [exit 2] is performed if the program terminates early because of an uncaught exception. *) val exit : int -> 'a (** Register the given function to be called at program termination time. The functions registered with [at_exit] will be called when the program executes {!Caml.exit}, or terminates, either normally or because of an uncaught exception. The functions are called in 'last in, first out' order: the function most recently added with [at_exit] is called first. *) val at_exit : (unit -> unit) -> unit (**/**) (** The following is for system use only. Do not call directly. *) val valid_float_lexem : string -> string [@@deprecated "[since 2015-11] Do not use."] val unsafe_really_input : Caml.in_channel -> bytes -> int -> int -> unit [@@deprecated "[since 2015-11] Do not use."] val do_at_exit : unit -> unit [@@deprecated "[since 2015-11] Do not use."] core-0.15.0/core/src/core_sys.ml000066400000000000000000000036331420273305200164270ustar00rootroot00000000000000open! Import include Base.Sys let unix_quote x = if (not (String.is_empty x)) && String.for_all x ~f:(function | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' | ':' | '.' | '/' | ',' | '+' | '=' | '%' | '@' -> true | _ -> false) then ( (* Shell keywords, as output by [compgen -k] for bash, [man dash] for dash, and [PATH= type -m '*' | grep reserved] for zsh, except for keywords that have special characters like [[. Note that builtins don't matter because 'alias' and alias behave the same, unlike 'if' and if. *) match x with | "if" | "then" | "else" | "elif" | "fi" | "case" | "esac" | "for" | "select" | "while" | "until" | "do" | "done" | "in" | "function" | "time" | "coproc" | "foreach" | "repeat" | "nocorrect" -> Filename.quote x | _ -> x) else Filename.quote x ;; let quote = match Caml.Sys.os_type with | "Unix" -> unix_quote | _ -> Filename.quote ;; let concat_quoted split_command = List.map ~f:quote split_command |> String.concat ~sep:" " ;; let c_int_size = `Use_Sys_unix let catch_break = `Use_Sys_unix let chdir = `Use_Sys_unix let command = `Use_Sys_unix let command_exn = `Use_Sys_unix let executable_name = `Use_Sys_unix let execution_mode = `Use_Sys_unix let file_exists = `Use_Sys_unix let file_exists_exn = `Use_Sys_unix let fold_dir = `Use_Sys_unix let getcwd = `Use_Sys_unix let home_directory = `Use_Sys_unix let is_directory = `Use_Sys_unix let is_directory_exn = `Use_Sys_unix let is_file = `Use_Sys_unix let is_file_exn = `Use_Sys_unix let ls_dir = `Use_Sys_unix let override_argv = `Use_Sys_unix let readdir = `Use_Sys_unix let remove = `Use_Sys_unix let rename = `Use_Sys_unix let unsafe_getenv = `Use_Sys_unix let unsafe_getenv_exn = `Use_Sys_unix exception Break = Caml.Sys.Break module Private = struct let unix_quote = unix_quote end core-0.15.0/core/src/core_sys.mli000066400000000000000000000054371420273305200166040ustar00rootroot00000000000000open! Import include module type of struct include Base.Sys end (** [quote s] quotes the string in a format suitable for the shell of the current system (e.g. suitable for [command]). On Unix, this function only quotes as necessary, which makes its output more legible than [Filename.quote]. WARNING: This may not work with some shells, but should work with sh, bash, and zsh. *) val quote : string -> string (** Converts a list of tokens to a command line fragment that can be passed to the shell of the current system. Each token is escaped as appropriate using [quote]. *) val concat_quoted : string list -> string val c_int_size : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val catch_break : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val chdir : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val command : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val command_exn : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val executable_name : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val execution_mode : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val file_exists : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val file_exists_exn : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val fold_dir : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val getcwd : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val home_directory : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val is_directory : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val is_directory_exn : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val is_file : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val is_file_exn : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val ls_dir : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val override_argv : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val readdir : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val remove : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val rename : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val unsafe_getenv : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] val unsafe_getenv_exn : [ `Use_Sys_unix ] [@@deprecated "[since 2021-04] Use [Sys_unix]"] exception Break [@deprecated "[since 2021-04] Use [Sys_unix]"] (**/**) (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig val unix_quote : string -> string end core-0.15.0/core/src/date.ml000066400000000000000000000003141420273305200155070ustar00rootroot00000000000000include Date0 let of_time time ~zone = Time_float.to_date ~zone time let today ~zone = of_time (Time_float.now ()) ~zone let format = `Use_Date_unix let of_tm = `Use_Date_unix let parse = `Use_Date_unix core-0.15.0/core/src/date.mli000066400000000000000000000000731420273305200156620ustar00rootroot00000000000000(** Date module. *) include Date_intf.Date (** @inline *) core-0.15.0/core/src/date0.ml000066400000000000000000000521421420273305200155750ustar00rootroot00000000000000open! Import open Std_internal open Digit_string_helpers let is_leap_year ~year = (year mod 4 = 0 && not (year mod 100 = 0)) || year mod 400 = 0 (* Create a local private date type to ensure that all dates are created via Date.create_exn. *) module Stable = struct module V1 = struct module Without_comparable = struct module T : sig type t [@@immediate] [@@deriving bin_io, equal, hash, typerep] val create_exn : y:int -> m:Month.Stable.V1.t -> d:int -> t val year : t -> int val month : t -> Month.Stable.V1.t val day : t -> int val days_in_month : year:int -> month:Month.t -> int val to_int : t -> int val of_int_exn : int -> t val invalid_value__for_internal_use_only : t end = struct (* We used to store dates like this: type t = { y: int; m: Month.Stable.V1.t; d: int; } In the below we make sure that the bin_io representation is identical (and the stable unit tests check this) In memory we use the following much more compact representation: 2 bytes year 1 byte month 1 byte day all packed into a single immediate int (so from 4 words down to 1). *) type t = int [@@deriving equal, hash, typerep, bin_shape ~basetype:"899ee3e0-490a-11e6-a10a-a3734f733566"] let create0 ~year ~month ~day = (* create_exn's validation make sure that each value fits *) (year lsl 16) lor (Month.to_int month lsl 8) lor day ;; let year t = t lsr 16 let month t = Month.of_int_exn ((t lsr 8) land 0xff) let day t = t land 0xff let days_in_month ~year ~month = match (month : Month.t) with | Jan | Mar | May | Jul | Aug | Oct | Dec -> 31 | Apr | Jun | Sep | Nov -> 30 | Feb -> if is_leap_year ~year then 29 else 28 ;; let create_exn ~y:year ~m:month ~d:day = (* year, month, and day need to be passed as parameters to avoid allocating a closure (see unit test below) *) let invalid ~year ~month ~day msg = invalid_argf !"Date.create_exn ~y:%d ~m:%{Month} ~d:%d error: %s" year month day msg () in if year < 0 || year > 9999 then invalid ~year ~month ~day "year outside of [0..9999]"; if day <= 0 then invalid ~year ~month ~day "day <= 0"; let days_in_month = days_in_month ~year ~month in if day > days_in_month then invalid ~year ~month ~day (sprintf "%d day month violation" days_in_month); create0 ~year ~month ~day ;; (* We don't use Make_binable here, because that would go via an immediate tuple or record. That is exactly the 32 bytes we worked so hard above to get rid of. We also don't want to just bin_io the integer directly because that would mean a new bin_io format. *) let bin_read_t buf ~pos_ref = let year = Int.bin_read_t buf ~pos_ref in let month = Month.Stable.V1.bin_read_t buf ~pos_ref in let day = Int.bin_read_t buf ~pos_ref in create0 ~year ~month ~day ;; let __bin_read_t__ _buf ~pos_ref = (* __bin_read_t is only needed for variants *) Bin_prot.Common.raise_variant_wrong_type "Date.t" !pos_ref ;; let bin_reader_t = { Bin_prot.Type_class.read = bin_read_t; vtag_read = __bin_read_t__ } ;; let bin_size_t t = Int.bin_size_t (year t) + Month.bin_size_t (month t) + Int.bin_size_t (day t) ;; let bin_write_t buf ~pos t = let pos = Int.bin_write_t buf ~pos (year t) in let pos = Month.bin_write_t buf ~pos (month t) in Int.bin_write_t buf ~pos (day t) ;; let bin_writer_t = { Bin_prot.Type_class.size = bin_size_t; write = bin_write_t } let bin_t = { Bin_prot.Type_class.reader = bin_reader_t ; writer = bin_writer_t ; shape = bin_shape_t } ;; let to_int t = t let of_int_exn n = create_exn ~y:(year n) ~m:(month n) ~d:(day n) let invalid_value__for_internal_use_only = 0 let%test "invalid value" = Exn.does_raise (fun () : t -> of_int_exn invalid_value__for_internal_use_only) ;; end include T (** YYYY-MM-DD *) let to_string_iso8601_extended t = let buf = Bytes.create 10 in write_4_digit_int buf ~pos:0 (year t); Bytes.set buf 4 '-'; write_2_digit_int buf ~pos:5 (Month.to_int (month t)); Bytes.set buf 7 '-'; write_2_digit_int buf ~pos:8 (day t); Bytes.unsafe_to_string ~no_mutation_while_string_reachable:buf ;; let to_string = to_string_iso8601_extended (** YYYYMMDD *) let to_string_iso8601_basic t = let buf = Bytes.create 8 in write_4_digit_int buf ~pos:0 (year t); write_2_digit_int buf ~pos:4 (Month.to_int (month t)); write_2_digit_int buf ~pos:6 (day t); Bytes.unsafe_to_string ~no_mutation_while_string_reachable:buf ;; (** MM/DD/YYYY *) let to_string_american t = let buf = Bytes.create 10 in write_2_digit_int buf ~pos:0 (Month.to_int (month t)); Bytes.set buf 2 '/'; write_2_digit_int buf ~pos:3 (day t); Bytes.set buf 5 '/'; write_4_digit_int buf ~pos:6 (year t); Bytes.unsafe_to_string ~no_mutation_while_string_reachable:buf ;; let parse_year4 str pos = read_4_digit_int str ~pos let parse_month str pos = Month.of_int_exn (read_2_digit_int str ~pos) let parse_day str pos = read_2_digit_int str ~pos (** YYYYMMDD *) let of_string_iso8601_basic str ~pos = if pos + 8 > String.length str then invalid_arg "Date.of_string_iso8601_basic: pos + 8 > string length"; create_exn ~y:(parse_year4 str pos) ~m:(parse_month str (pos + 4)) ~d:(parse_day str (pos + 6)) ;; (* WARNING: if you are going to change this function in a material way, be sure you understand the implications of working in Stable *) let of_string s = let invalid () = failwith ("invalid date: " ^ s) in let ensure b = if not b then invalid () in let month_num ~year ~month ~day = create_exn ~y:(parse_year4 s year) ~m:(parse_month s month) ~d:(parse_day s day) in let month_abrv ~year ~month ~day = create_exn ~y:(parse_year4 s year) ~m:(Month.of_string (String.sub s ~pos:month ~len:3)) ~d:(parse_day s day) in if String.contains s '/' then ( let y, m, d = match String.split s ~on:'/' with | [ a; b; c ] -> if String.length a = 4 then a, b, c (* y/m/d *) else c, a, b (* m/d/y *) | _ -> invalid () in let year = Int.of_string y in let year = if year >= 100 then year else if year < 75 then 2000 + year else 1900 + year in let month = Month.of_int_exn (Int.of_string m) in let day = Int.of_string d in create_exn ~y:year ~m:month ~d:day) else if String.contains s '-' then ( (* yyyy-mm-dd *) ensure (String.length s = 10 && Char.( = ) s.[4] '-' && Char.( = ) s.[7] '-'); month_num ~year:0 ~month:5 ~day:8) else if String.contains s ' ' then if String.length s = 11 && Char.( = ) s.[2] ' ' && Char.( = ) s.[6] ' ' then (* DD MMM YYYY *) month_abrv ~day:0 ~month:3 ~year:7 else ( (* YYYY MMM DD *) ensure (String.length s = 11 && Char.( = ) s.[4] ' ' && Char.( = ) s.[8] ' '); month_abrv ~day:9 ~month:5 ~year:0) else if String.length s = 9 then (* DDMMMYYYY *) month_abrv ~day:0 ~month:2 ~year:5 else if String.length s = 8 then (* assume YYYYMMDD *) month_num ~year:0 ~month:4 ~day:6 else invalid () ;; let of_string s = try of_string s with | exn -> invalid_argf "Date.of_string (%s): %s" s (Exn.to_string exn) () ;; module Sexpable = struct module Old_date = struct type t = { y : int ; m : int ; d : int } [@@deriving sexp] let to_date t = T.create_exn ~y:t.y ~m:(Month.of_int_exn t.m) ~d:t.d end let t_of_sexp = function | Sexp.Atom s -> of_string s | Sexp.List _ as sexp -> Old_date.to_date (Old_date.t_of_sexp sexp) ;; let t_of_sexp s = try t_of_sexp s with | Of_sexp_error _ as exn -> raise exn | Invalid_argument a -> of_sexp_error a s ;; let sexp_of_t t = Sexp.Atom (to_string t) let t_sexp_grammar = Sexplib.Sexp_grammar.coerce Sexplib.Sexp.t_sexp_grammar end include Sexpable let compare t1 t2 = let n = Int.compare (year t1) (year t2) in if n <> 0 then n else ( let n = Month.compare (month t1) (month t2) in if n <> 0 then n else Int.compare (day t1) (day t2)) ;; include (val Comparator.Stable.V1.make ~compare ~sexp_of_t) end include Without_comparable include Comparable.Stable.V1.Make (Without_comparable) include Hashable.Stable.V1.Make (Without_comparable) end module Option = struct module V1 = struct type t = int [@@deriving bin_io , bin_shape ~basetype:"826a3e79-3321-451a-9707-ed6c03b84e2f" , compare , hash , typerep] let none = V1.(to_int invalid_value__for_internal_use_only) let is_none t = t = none let is_some t = not (is_none t) let some_is_representable _ = true let some t = V1.to_int t let unchecked_value = V1.of_int_exn let to_option t = if is_some t then Some (unchecked_value t) else None let of_option opt = match opt with | None -> none | Some v -> some v ;; let value_exn t = if is_some t then unchecked_value t else raise_s [%message [%here] "Date.Option.value_exn none"] ;; let value t ~default = if is_some t then unchecked_value t else default let sexp_of_t t = to_option t |> Option.sexp_of_t V1.sexp_of_t let t_of_sexp sexp = (Option.t_of_sexp V1.t_of_sexp) sexp |> of_option let t_sexp_grammar = Sexplib.Sexp_grammar.coerce [%sexp_grammar: V1.t Option.t] end end end module Without_comparable = Stable.V1.Without_comparable include Without_comparable module C = Comparable.Make_binable_using_comparator (Without_comparable) include C module O = struct include (C : Comparable.Infix with type t := t) end include ( Hashable.Make_binable (struct include T include Sexpable include Binable let compare (a : t) (b : t) = compare a b end) : Hashable.S_binable with type t := t) include Pretty_printer.Register (struct type nonrec t = t let module_name = "Core.Date" let to_string = to_string end) let unix_epoch = create_exn ~y:1970 ~m:Jan ~d:1 (* The Days module is used for calculations that involve adding or removing a known number of days from a date. Internally the date is translated to a day number, the days are added, and the new date is returned. Those interested in the math can read: http://alcor.concordia.ca/~gpkatch/gdate-method.html note: unit tests are in lib_test/time_test.ml *) module Days : sig type date = t type t [@@immediate] val of_date : date -> t val to_date : t -> date val diff : t -> t -> int val add_days : t -> int -> t val unix_epoch : t end with type date := t = struct open Int type t = int let of_year y = (365 * y) + (y / 4) - (y / 100) + (y / 400) let of_date date = let m = (Month.to_int (month date) + 9) % 12 in let y = year date - (m / 10) in of_year y + (((m * 306) + 5) / 10) + (day date - 1) ;; let c_10_000 = Int63.of_int 10_000 let c_14_780 = Int63.of_int 14_780 let c_3_652_425 = Int63.of_int 3_652_425 let to_date days = let y = let open Int63 in to_int_exn (((c_10_000 * of_int days) + c_14_780) / c_3_652_425) in let ddd = days - of_year y in let y, ddd = if ddd < 0 then ( let y = y - 1 in y, days - of_year y) else y, ddd in let mi = ((100 * ddd) + 52) / 3_060 in let y = y + ((mi + 2) / 12) in let m = ((mi + 2) % 12) + 1 in let d = ddd - (((mi * 306) + 5) / 10) + 1 in create_exn ~y ~m:(Month.of_int_exn m) ~d ;; let unix_epoch = of_date unix_epoch let add_days t days = t + days let diff t1 t2 = t1 - t2 end let add_days t days = Days.to_date (Days.add_days (Days.of_date t) days) let diff t1 t2 = Days.diff (Days.of_date t1) (Days.of_date t2) let add_months t n = let total_months = Month.to_int (month t) + n in let y = year t + (total_months /% 12) in let m = total_months % 12 in (* correct for december *) let y, m = if Int.( = ) m 0 then y - 1, m + 12 else y, m in let m = Month.of_int_exn m in (* handle invalid dates for months with fewer number of days *) let rec try_create d = try create_exn ~y ~m ~d with | _exn -> assert (Int.( >= ) d 1); try_create (d - 1) in try_create (day t) ;; let add_years t n = add_months t (n * 12) (* http://en.wikipedia.org/wiki/Determination_of_the_day_of_the_week#Purely_mathematical_methods note: unit tests in lib_test/time_test.ml *) let day_of_week = let table = [| 0; 3; 2; 5; 0; 3; 5; 1; 4; 6; 2; 4 |] in fun t -> let m = Month.to_int (month t) in let y = if Int.( < ) m 3 then year t - 1 else year t in Day_of_week.of_int_exn ((y + (y / 4) - (y / 100) + (y / 400) + table.(m - 1) + day t) % 7) ;; (* http://en.wikipedia.org/wiki/Ordinal_date *) let non_leap_year_table = [| 0; 31; 59; 90; 120; 151; 181; 212; 243; 273; 304; 334 |] let leap_year_table = [| 0; 31; 60; 91; 121; 152; 182; 213; 244; 274; 305; 335 |] let ordinal_date t = let table = if is_leap_year ~year:(year t) then leap_year_table else non_leap_year_table in let offset = table.(Month.to_int (month t) - 1) in day t + offset ;; let last_week_of_year y = let first_of_year = create_exn ~y ~m:Jan ~d:1 in let is t day = Day_of_week.equal (day_of_week t) day in if is first_of_year Thu || (is_leap_year ~year:y && is first_of_year Wed) then 53 else 52 ;; (* See http://en.wikipedia.org/wiki/ISO_week_date or ISO 8601 for the details of this algorithm. Uses a [~f] argument to avoid allocating a tuple when called by [week_number]. *) let call_with_week_and_year t ~f = let ordinal = ordinal_date t in let weekday = Day_of_week.iso_8601_weekday_number (day_of_week t) in (* [ordinal - weekday + 4] is the ordinal of this week's Thursday, then (n + 6) / 7 is division by 7 rounding up *) let week = (ordinal - weekday + 10) / 7 in let year = year t in if Int.( < ) week 1 then f ~week:(last_week_of_year (year - 1)) ~year:(year - 1) else if Int.( > ) week (last_week_of_year year) then f ~week:1 ~year:(year + 1) else f ~week ~year ;; let week_number_and_year t = call_with_week_and_year t ~f:(fun ~week ~year -> week, year) let week_number t = call_with_week_and_year t ~f:(fun ~week ~year:_ -> week) let is_weekend t = Day_of_week.is_sun_or_sat (day_of_week t) let is_weekday t = not (is_weekend t) let is_business_day t ~is_holiday = is_weekday t && not (is_holiday t) let rec diff_weekend_days t1 t2 = if t1 < t2 then -diff_weekend_days t2 t1 else ( (* Basic date diff *) let diff = diff t1 t2 in (* Compute the number of Saturday -> Sunday crossings *) let d1 = day_of_week t1 in let d2 = day_of_week t2 in let num_satsun_crossings = if Int.( < ) (Day_of_week.to_int d1) (Day_of_week.to_int d2) then 1 + (diff / 7) else diff / 7 in (num_satsun_crossings * 2) + (if Day_of_week.( = ) d2 Day_of_week.Sun then 1 else 0) + if Day_of_week.( = ) d1 Day_of_week.Sun then -1 else 0) ;; let diff_weekdays t1 t2 = diff t1 t2 - diff_weekend_days t1 t2 let add_days_skipping t ~skip n = let step = if Int.( >= ) n 0 then 1 else -1 in let rec loop t k = let t_next = add_days t step in if skip t then loop t_next k else if Int.( = ) k 0 then t else loop t_next (k - 1) in loop t (abs n) ;; let rec first_day_satisfying t ~step ~condition = if condition t then t else first_day_satisfying (add_days t step) ~step ~condition ;; let next_day_satisfying t ~step ~condition = let next_day = add_days t step in first_day_satisfying next_day ~step ~condition ;; let following_weekday t = next_day_satisfying t ~step:1 ~condition:is_weekday let previous_weekday t = next_day_satisfying t ~step:(-1) ~condition:is_weekday let round_forward_to_weekday t = first_day_satisfying t ~step:1 ~condition:is_weekday let round_backward_to_weekday t = first_day_satisfying t ~step:(-1) ~condition:is_weekday let round_forward_to_business_day t ~is_holiday = first_day_satisfying t ~step:1 ~condition:(is_business_day ~is_holiday) ;; let round_backward_to_business_day t ~is_holiday = first_day_satisfying t ~step:(-1) ~condition:(is_business_day ~is_holiday) ;; let add_weekdays t n = add_days_skipping t ~skip:is_weekend n let add_weekdays_rounding_in_direction_of_step = add_weekdays let add_weekdays_rounding_forward t n = add_days_skipping (round_forward_to_weekday t) ~skip:is_weekend n ;; let add_weekdays_rounding_backward t n = add_days_skipping (round_backward_to_weekday t) ~skip:is_weekend n ;; let add_business_days t ~is_holiday n = add_days_skipping t n ~skip:(fun d -> is_weekend d || is_holiday d) ;; let add_business_days_rounding_in_direction_of_step = add_business_days let add_business_days_rounding_forward t ~is_holiday n = add_days_skipping (round_forward_to_business_day ~is_holiday t) n ~skip:(fun d -> not (is_business_day ~is_holiday d)) ;; let add_business_days_rounding_backward t ~is_holiday n = add_days_skipping (round_backward_to_business_day ~is_holiday t) n ~skip:(fun d -> not (is_business_day ~is_holiday d)) ;; let dates_between ~min:t1 ~max:t2 = let rec loop t l = if t < t1 then l else loop (add_days t (-1)) (t :: l) in loop t2 [] ;; let weekdays_between ~min ~max = let all_dates = dates_between ~min ~max in Option.value_map (List.hd all_dates) ~default:[] ~f:(fun first_date -> (* to avoid a system call on every date, we just get the weekday for the first date and use it to get all the other weekdays *) let first_weekday = day_of_week first_date in let date_and_weekdays = List.mapi all_dates ~f:(fun i date -> date, Day_of_week.shift first_weekday i) in List.filter_map date_and_weekdays ~f:(fun (date, weekday) -> if Day_of_week.is_sun_or_sat weekday then None else Some date)) ;; let business_dates_between ~min ~max ~is_holiday = weekdays_between ~min ~max |> List.filter ~f:(fun d -> not (is_holiday d)) ;; let first_strictly_after t ~on:dow = let dow = Day_of_week.to_int dow in let tplus1 = add_days t 1 in let cur = Day_of_week.to_int (day_of_week tplus1) in let diff = (dow + 7 - cur) mod 7 in add_days tplus1 diff ;; module For_quickcheck = struct open Quickcheck let gen_uniform_incl d1 d2 = if d1 > d2 then raise_s [%message "Date.gen_uniform_incl: bounds are crossed" ~lower_bound:(d1 : t) ~upper_bound:(d2 : t)]; Generator.map (Int.gen_uniform_incl 0 (diff d2 d1)) ~f:(fun days -> add_days d1 days) ;; let gen_incl d1 d2 = Generator.weighted_union [ 1., Generator.return d1; 1., Generator.return d2; 18., gen_uniform_incl d1 d2 ] ;; let quickcheck_generator = gen_incl (of_string "1900-01-01") (of_string "2100-01-01") let quickcheck_observer = Observer.create (fun t ~size:_ ~hash -> hash_fold_t hash t) let quickcheck_shrinker = Shrinker.empty () end let quickcheck_generator = For_quickcheck.quickcheck_generator let gen_incl = For_quickcheck.gen_incl let gen_uniform_incl = For_quickcheck.gen_uniform_incl let quickcheck_observer = For_quickcheck.quickcheck_observer let quickcheck_shrinker = For_quickcheck.quickcheck_shrinker module Private = struct let leap_year_table = leap_year_table let non_leap_year_table = non_leap_year_table let ordinal_date = ordinal_date end module Option = struct module Stable = Stable.Option include Stable.V1 module Optional_syntax = struct module Optional_syntax = struct let is_none = is_none let unsafe_value = unchecked_value end end let quickcheck_generator = Quickcheck.Generator.map (Option.quickcheck_generator quickcheck_generator) ~f:of_option ;; let quickcheck_shrinker = Quickcheck.Shrinker.map (Option.quickcheck_shrinker quickcheck_shrinker) ~f:of_option ~f_inverse:to_option ;; let quickcheck_observer = Quickcheck.Observer.of_hash (module struct type nonrec t = t [@@deriving hash] end) ;; include Comparable.Make_plain (struct type nonrec t = t [@@deriving compare, sexp_of] end) end core-0.15.0/core/src/date0.mli000066400000000000000000000000501420273305200157350ustar00rootroot00000000000000include Date0_intf.Date0 (** @inline *) core-0.15.0/core/src/date0_intf.ml000066400000000000000000000242471420273305200166220ustar00rootroot00000000000000open! Import open Std_internal module type Date0 = sig type t [@@immediate] [@@deriving bin_io, hash, sexp, sexp_grammar, typerep] include Hashable_binable with type t := t (** converts a string to a date in the following formats: - m/d/y - y-m-d (valid iso8601_extended) - DD MMM YYYY - DDMMMYYYY - YYYYMMDD *) include Stringable with type t := t include Comparable_binable with type t := t include Pretty_printer.S with type t := t (** [create_exn ~y ~m ~d] creates the date specified in the arguments. Arguments are validated, and are not normalized in any way. So, days must be within the limits for the month in question, numbers cannot be negative, years must be fully specified, etc. *) val create_exn : y:int -> m:Month.t -> d:int -> t (** For details on this ISO format, see: http://www.wikipedia.org/wiki/iso8601 *) val of_string_iso8601_basic : string -> pos:int -> t (** YYYYMMDD *) val to_string_iso8601_basic : t -> string (** MM/DD/YYYY *) val to_string_american : t -> string val day : t -> int val month : t -> Month.t val year : t -> int (** Only accurate after 1752-09 *) val day_of_week : t -> Day_of_week.t (** Week of the year, from 1 to 53, along with the week-numbering year to which the week belongs. The week-numbering year may not correspond to the calendar year in which the provided date occurs. According to ISO 8601, weeks start on Monday, and the first week of a year is the week that contains the first Thursday of the year. This means that dates near the end of the calendar year can have week number 1 and belong to the following week-numbering year, and dates near the beginning of the calendar year can have week number 52 or 53 and belong to the previous week-numbering year. The triple (week-numbering year, week number, week day) uniquely identifies a particular date, which is not true if the calendar year is used instead. *) val week_number_and_year : t -> int * int (** See {!week_number_and_year} for the meaning of week number. *) val week_number : t -> int val is_weekend : t -> bool val is_weekday : t -> bool (** Monday through Friday are business days, unless they're a holiday. *) val is_business_day : t -> is_holiday:(t -> bool) -> bool (** [add_days t n] adds n days to [t] and returns the resulting date. Inaccurate when crossing 1752-09. *) val add_days : t -> int -> t (** [add_months t n] returns date with max days for the month if the date would be invalid. e.g. adding 1 month to Jan 30 results in Feb 28 due to Feb 30 being an invalid date, Feb 29 is returned in cases of leap year. In particular, this means adding [x] months and then adding [y] months isn't the same as adding [x + y] months, and in particular adding [x] months and then [-x] months won't always get you back where you were. **) val add_months : t -> int -> t (** [add_years t n] has the same semantics as [add_months] for adding years to Feb 29 of a leap year, i.e., when the addition results in a date in a non-leap year, the result will be Feb 28 of that year. *) val add_years : t -> int -> t (** [diff t1 t2] returns date [t1] minus date [t2] in days. *) val diff : t -> t -> int (** [diff_weekdays t1 t2] returns the number of weekdays in the half-open interval \[t2,t1) if t1 >= t2, and [- diff_weekdays t2 t1] otherwise. *) val diff_weekdays : t -> t -> int (** [diff_weekend_days t1 t2] returns the number of days that are weekend days in the half-open interval \[t2,t1) if t1 >= t2, and [- diff_weekend_days t2 t1] otherwise. *) val diff_weekend_days : t -> t -> int (** First rounds the given date backward to the previous weekday, if it is not already a weekday. Then advances by the given number of weekdays, which may be negative. *) val add_weekdays_rounding_backward : t -> int -> t (** First rounds the given date forward to the next weekday, if it is not already a weekday. Then advances by the given number of weekdays, which may be negative. *) val add_weekdays_rounding_forward : t -> int -> t (** First rounds the given date backward to the previous business day, i.e. weekday not satisfying [is_holiday], if it is not already a business day. Then advances by the given number of business days, which may be negative. *) val add_business_days_rounding_backward : t -> is_holiday:(t -> bool) -> int -> t (** First rounds the given date forward to the next business day, i.e. weekday not satisfying [is_holiday], if it is not already a business day. Then advances by the given number of business days, which may be negative. *) val add_business_days_rounding_forward : t -> is_holiday:(t -> bool) -> int -> t (** [add_weekdays t 0] returns the next weekday if [t] is a weekend and [t] otherwise. Unlike [add_days] this is done by looping over the count of days to be added (forward or backwards based on the sign), and is O(n) in the number of days to add. Beware, [add_weekdays sat 1] or [add_weekdays sun 1] both return the next [tue], not the next [mon]. You may want to use [following_weekday] if you want the next following weekday, [following_weekday (fri|sat|sun)] would all return the next [mon]. *) val add_weekdays : t -> int -> t [@@deprecated "[since 2019-12] use [add_weekdays_rounding_backward] or \ [add_weekdays_rounding_forward] as appropriate"] val add_weekdays_rounding_in_direction_of_step : t -> int -> t [@@alert legacy "use [add_weekdays_rounding_backward] or [add_weekdays_rounding_forward] as \ appropriate"] (** [add_business_days t ~is_holiday n] returns a business day even when [n=0]. [add_business_days ~is_holiday:(fun _ -> false) ...] is the same as [add_weekdays]. If you don't want to skip Saturday or Sunday, use [add_days_skipping]. *) val add_business_days : t -> is_holiday:(t -> bool) -> int -> t [@@deprecated "[since 2019-12] use [add_business_days_rounding_backward] or \ [add_business_days_rounding_forward] as appropriate"] val add_business_days_rounding_in_direction_of_step : t -> is_holiday:(t -> bool) -> int -> t [@@alert legacy "use [add_business_days_rounding_backward] or \ [add_business_days_rounding_forward] as appropriate"] (** [add_days_skipping t ~skip n] adds [n] days to [t], ignoring any date satisfying [skip], starting at the first date at or after [t] that does not satisfy [skip]. For example, if [skip t = true], then [add_days_skipping t ~skip 0 > t]. [add_business_days] and [add_weekdays] are special cases of [add_days_skipping]. *) val add_days_skipping : t -> skip:(t -> bool) -> int -> t (** the following returns a closed interval (endpoints included) *) val dates_between : min:t -> max:t -> t list val business_dates_between : min:t -> max:t -> is_holiday:(t -> bool) -> t list val weekdays_between : min:t -> max:t -> t list val previous_weekday : t -> t val following_weekday : t -> t (** [first_strictly_after t ~on:day_of_week] returns the first occurrence of [day_of_week] strictly after [t]. *) val first_strictly_after : t -> on:Day_of_week.t -> t (** [days_in_month ~year ~month] returns the number of days in [month], using [year] only if [month = Month.Feb] to check if there is a leap year. Incorrect for September 1752. *) val days_in_month : year:int -> month:Month.t -> int (** [is_leap_year ~year] returns true if [year] is considered a leap year *) val is_leap_year : year:int -> bool (** The starting date of the UNIX epoch: 1970-01-01 *) val unix_epoch : t (** [gen] generates dates between 1900-01-01 and 2100-01-01. *) include Quickcheckable with type t := t (** [gen_incl d1 d2] generates dates in the range between [d1] and [d2], inclusive, with the endpoints having higher weight than the rest. Raises if [d1 > d2]. *) val gen_incl : t -> t -> t Quickcheck.Generator.t (** [gen_uniform_incl d1 d2] generates dates chosen uniformly in the range between [d1] and [d2], inclusive. Raises if [d1 > d2]. *) val gen_uniform_incl : t -> t -> t Quickcheck.Generator.t (** [Days] provides a linear representation of dates that is optimized for arithmetic on the number of days between dates, rather than for representing year/month/day components. This module is intended for use only in performance-sensitive contexts where dates are manipulated more often than they are constructed or deconstructed; most clients should use the ordinary [t]. *) module Days : sig type date = t type t [@@immediate] val of_date : date -> t val to_date : t -> date val diff : t -> t -> int val add_days : t -> int -> t (** The starting date of the UNIX epoch: 1970-01-01 *) val unix_epoch : t end with type date := t module Option : sig type value := t type t [@@immediate] [@@deriving sexp_grammar] include Immediate_option_intf.S with type value := value and type t := t include Comparable.S_plain with type t := t include Quickcheckable.S with type t := t end module Stable : sig module V1 : sig type nonrec t = t [@@immediate] [@@deriving equal, hash, sexp_grammar] (** [to_int] and [of_int_exn] convert to/from the underlying integer representation. *) val to_int : t -> int val of_int_exn : int -> t include Stable_comparable.V1 with type t := t with type comparator_witness = comparator_witness include Hashable.Stable.V1.S with type key := t end module Option : sig module V1 : sig type nonrec t = Option.t [@@immediate] [@@deriving bin_io, compare, sexp, sexp_grammar] end end end module O : sig include Comparable.Infix with type t := t end (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig val leap_year_table : int array val non_leap_year_table : int array val ordinal_date : t -> int end end core-0.15.0/core/src/date_intf.ml000066400000000000000000000007441420273305200165360ustar00rootroot00000000000000module type Date = sig type t = Date0.t include module type of Date0 with type t := t (** @inline *) val of_time : Time_float.t -> zone:Time_float.Zone.t -> t val today : zone:Time_float.Zone.t -> t (** Deprecations *) val format : [ `Use_Date_unix ] [@@deprecated "[since 2021-03] Use [Date_unix]"] val of_tm : [ `Use_Date_unix ] [@@deprecated "[since 2021-03] Use [Date_unix]"] val parse : [ `Use_Date_unix ] [@@deprecated "[since 2021-03] Use [Date_unix]"] end core-0.15.0/core/src/day_of_week.ml000066400000000000000000000063201420273305200170510ustar00rootroot00000000000000open! Import let failwithf = Printf.failwithf module Stable = struct module V1 = struct module T = struct type t = | Sun | Mon | Tue | Wed | Thu | Fri | Sat [@@deriving bin_io, compare, hash, quickcheck] let to_string t = match t with | Sun -> "SUN" | Mon -> "MON" | Tue -> "TUE" | Wed -> "WED" | Thu -> "THU" | Fri -> "FRI" | Sat -> "SAT" ;; let to_string_long t = match t with | Sun -> "Sunday" | Mon -> "Monday" | Tue -> "Tuesday" | Wed -> "Wednesday" | Thu -> "Thursday" | Fri -> "Friday" | Sat -> "Saturday" ;; let of_string_internal s = match String.uppercase s with | "SUN" | "SUNDAY" -> Sun | "MON" | "MONDAY" -> Mon | "TUE" | "TUESDAY" -> Tue | "WED" | "WEDNESDAY" -> Wed | "THU" | "THURSDAY" -> Thu | "FRI" | "FRIDAY" -> Fri | "SAT" | "SATURDAY" -> Sat | _ -> failwithf "Day_of_week.of_string: %S" s () ;; let of_int_exn i = match i with | 0 -> Sun | 1 -> Mon | 2 -> Tue | 3 -> Wed | 4 -> Thu | 5 -> Fri | 6 -> Sat | _ -> failwithf "Day_of_week.of_int_exn: %d" i () ;; (* Be very generous with of_string. We accept all possible capitalizations and the integer representations as well. *) let of_string s = try of_string_internal s with | _ -> (try of_int_exn (Int.of_string s) with | _ -> failwithf "Day_of_week.of_string: %S" s ()) ;; (* this is in T rather than outside so that the later functor application to build maps uses this sexp representation *) include Sexpable.Stable.Of_stringable.V1 (struct type nonrec t = t let of_string = of_string let to_string = to_string end) end include T module Unstable = struct include T include (Comparable.Make_binable (T) : Comparable.S_binable with type t := t) include Hashable.Make_binable (T) end include Comparable.Stable.V1.Make (Unstable) include Hashable.Stable.V1.Make (Unstable) end end include Stable.V1.Unstable let weekdays = [ Mon; Tue; Wed; Thu; Fri ] let weekends = [ Sat; Sun ] (* written out to save overhead when loading modules. The members of the set and the ordering should never change, so speed wins over something more complex that proves the order = the order in t at runtime *) let all = [ Sun; Mon; Tue; Wed; Thu; Fri; Sat ] let of_int i = try Some (of_int_exn i) with | _ -> None ;; let to_int t = match t with | Sun -> 0 | Mon -> 1 | Tue -> 2 | Wed -> 3 | Thu -> 4 | Fri -> 5 | Sat -> 6 ;; let iso_8601_weekday_number t = match t with | Mon -> 1 | Tue -> 2 | Wed -> 3 | Thu -> 4 | Fri -> 5 | Sat -> 6 | Sun -> 7 ;; let num_days_in_week = 7 let shift t i = of_int_exn (Int.( % ) (to_int t + i) num_days_in_week) let num_days ~from ~to_ = let d = to_int to_ - to_int from in if Int.(d < 0) then d + num_days_in_week else d ;; let is_sun_or_sat t = t = Sun || t = Sat core-0.15.0/core/src/day_of_week.mli000066400000000000000000000003761420273305200172270ustar00rootroot00000000000000(** Provides a variant type for days of the week ([Mon], [Tue], etc.) and convenience functions for converting these days into other formats, like sexp or string or ISO 8601 weekday number. *) include Day_of_week_intf.Day_of_week (** @inline *) core-0.15.0/core/src/day_of_week_intf.ml000066400000000000000000000032451420273305200200740ustar00rootroot00000000000000(** For representing a day of the week. *) open! Import module type Day_of_week = sig type t = | Sun | Mon | Tue | Wed | Thu | Fri | Sat [@@deriving bin_io, compare, hash, quickcheck, sexp] include Comparable.S_binable with type t := t include Hashable.S_binable with type t := t (** [of_string s] accepts three-character abbreviations and full day names with any capitalization, and strings of the integers 0-6. *) include Stringable.S with type t := t (** Capitalized full day names rather than all-caps 3-letter abbreviations. *) val to_string_long : t -> string (** These use the same mapping as [Unix.tm_wday]: 0 <-> Sun, ... 6 <-> Sat *) val of_int_exn : int -> t val of_int : int -> t option val to_int : t -> int (** As per ISO 8601, Mon->1, Tue->2, ... Sun->7 *) val iso_8601_weekday_number : t -> int (** [shift] goes forward (or backward) the specified number of days. *) val shift : t -> int -> t (** [num_days ~from ~to_] gives the number of days that must elapse from a [from] to get to a [to_], i.e., the smallest non-negative number [i] such that [shift from i = to_]. *) val num_days : from:t -> to_:t -> int val is_sun_or_sat : t -> bool val all : t list (** [ Mon; Tue; Wed; Thu; Fri ] *) val weekdays : t list (** [ Sat; Sun ] *) val weekends : t list module Stable : sig module V1 : sig type nonrec t = t [@@deriving bin_io, sexp, compare, hash] include Comparable.Stable.V1.S with type comparable := t with type comparator_witness := comparator_witness include Hashable.Stable.V1.S with type key := t end end end core-0.15.0/core/src/debug.ml000066400000000000000000000042311420273305200156620ustar00rootroot00000000000000open! Import module List = Base.List module String = Base.String let eprint message = Printf.eprintf "%s\n%!" message let eprint_s sexp = eprint (Sexp.to_string_hum sexp) let eprints message a sexp_of_a = eprint_s ([%sexp_of: string * a] (message, a)) let eprintf format = Printf.ksprintf eprint format let failwiths = Error.failwiths module Make () = struct let check_invariant = ref true let show_messages = ref true let debug invariant ~module_name name ts arg sexp_of_arg sexp_of_result f = if !show_messages then eprints (String.concat ~sep:"" [ module_name; "."; name ]) arg sexp_of_arg; if !check_invariant then ( try List.iter ts ~f:invariant with | exn -> failwiths ~here:[%here] "invariant pre-condition failed" (name, exn) [%sexp_of: string * exn]); let result_or_exn = Result.try_with f in if !check_invariant then ( try List.iter ts ~f:invariant with | exn -> failwiths ~here:[%here] "invariant post-condition failed" (name, exn) [%sexp_of: string * exn]); if !show_messages then eprints (String.concat ~sep:"" [ module_name; "."; name; "-result" ]) result_or_exn [%sexp_of: (result, exn) Result.t]; Result.ok_exn result_or_exn ;; end let should_print_backtrace = ref false let am_internal here message = (* In this function we use [Printf.eprintf] rather than [Debug.eprintf], because the former doesn't flush, while the latter does. We'd rather flush once at the end, rather than three times. *) Printf.eprintf "%s:\n" (Source_code_position.to_string here); if !should_print_backtrace then Printf.eprintf "%s\n" (Backtrace.get () |> [%sexp_of: Backtrace.t] |> Sexp.to_string_hum); (match message with | None -> () | Some message -> Printf.eprintf "%s\n" message); Printf.eprintf "%!" ;; let am here = am_internal here None let amf here fmt = Printf.ksprintf (fun string -> am_internal here (Some string)) fmt let ams here message a sexp_of_a = am_internal here (Some ((message, a) |> [%sexp_of: string * a] |> Sexp.to_string_hum)) ;; core-0.15.0/core/src/debug.mli000066400000000000000000000060741420273305200160420ustar00rootroot00000000000000(** Utilities for printing debug messages. *) open! Import (** [eprint message] prints to stderr [message], followed by a newline and flush. This is the same as [prerr_endline]. *) val eprint : string -> unit (** [eprints message a sexp_of_a] prints to stderr [message] and [a] as a sexp, followed by a newline and flush. *) val eprints : string -> 'a -> ('a -> Sexp.t) -> unit (** [eprint_s sexp] prints [sexp] to stderr, followed by a newline and a flush. *) val eprint_s : Sexp.t -> unit (** [eprintf message arg1 ... argn] prints to stderr [message], with sprintf-style format characters instantiated, followed by a newline and flush. *) val eprintf : ('r, unit, string, unit) format4 -> 'r (** [Debug.Make] produces a [debug] function used to wrap a function to display arguments before calling and display results after returning. Intended usage is: {[ module Foo = struct type t = ... let invariant = ... let bar t x y : Result.t = ... end module Foo_debug = struct open Foo include Debug.Make () let debug x = debug invariant ~module_name:"Foo" x let bar t x y = debug "bar" [t] (t, x, y) [%sexp_of: t * X.t * Y.t] [%sexp_of: Result.t] (fun () -> bar t x y) end ]} *) module Make () : sig (** Whether the invariants are called on each invocation. *) val check_invariant : bool ref (** If true, you get a message on stderr every time [debug] is called. *) val show_messages : bool ref (** We avoid labels so that the applications are more concise -- see example above. *) val debug : 't Invariant.t -> module_name:string (** module_name appears on messages *) -> string (** string name of function [f], also appears on messages *) -> 't list (** args of type [t], to have invariant checked iff [check_invariant] *) -> 'args (** arguments to the function we're debugging *) -> ('args -> Sexp.t) -> ('result -> Sexp.t) -> (unit -> 'result) (** should call [f] with ['args], exn's re-raised *) -> 'result end (** [am], [ams], and [amf] output a source code position and backtrace to stderr. [amf] accepts a printf-style format string. [ams] accepts a message, value, and sexp converter for that value. Typical usage looks like: {[ ...; Debug.am [%here]; ...; Debug.amf [%here] "hello (%s, %s)" (X.to_string x) (Y.to_string y); ...; Debug.ams [%here] "hello" (x, y) [%sexp_of: X.t * Y.t]; ...; ]} The [am*] functions output source code positions in the standard format "FILE:LINE:COL", which means that one can use a tool like emacs grep-mode on a buffer containing debug messages to step through one's code by stepping through the messages. *) val am : Source_code_position.t -> unit val ams : Source_code_position.t -> string -> 'a -> ('a -> Sexp.t) -> unit val amf : Source_code_position.t -> ('r, unit, string, unit) format4 -> 'r (** [should_print_backtrace] governs whether the [am*] functions print a backtrace. *) val should_print_backtrace : bool ref core-0.15.0/core/src/deprecate_pipe_bang.ml000066400000000000000000000000301420273305200205250ustar00rootroot00000000000000let ( |! ) x y = x |> y core-0.15.0/core/src/deprecate_pipe_bang.mli000066400000000000000000000001201420273305200206760ustar00rootroot00000000000000val ( |! ) : 'a -> ('a -> 'b) -> 'b [@@deprecated "[since 2016-07] Use [ |> ]"] core-0.15.0/core/src/deque.ml000066400000000000000000000367611420273305200157140ustar00rootroot00000000000000open! Import open Std_internal type 'a t = { (* [arr] is a cyclic buffer *) mutable arr : 'a Option_array.t ; (* [front_index] and [back_index] are the positions in which new elements may be enqueued. This makes the active part of [arr] the range from [front_index+1] to [back_index-1] (modulo the length of [arr] and wrapping around if necessary). Note that this means the active range is maximized when [front_index = back_index], which occurs when there are [Array.length arr - 1] active elements. *) mutable front_index : int ; mutable back_index : int ; (* apparent_front_index is what is exposed as the front index externally. It has no real relation to the array -- every enqueue to the front decrements it and every dequeue from the front increments it. *) mutable apparent_front_index : int ; mutable length : int ; (* We keep arr_length here as a speed hack. Calling Array.length on arr is actually meaningfully slower. *) mutable arr_length : int ; never_shrink : bool } let create ?initial_length ?never_shrink () = let never_shrink = match never_shrink with | None -> Option.is_some initial_length | Some b -> b in let initial_length = Option.value ~default:7 initial_length in if initial_length < 0 then invalid_argf "passed negative initial_length to Deque.create: %i" initial_length (); (* Make the initial array length be [initial_length + 1] so we can fit [initial_length] elements without growing. We never quite use the whole array. *) let arr_length = initial_length + 1 in { arr = Option_array.create ~len:arr_length ; front_index = 0 ; back_index = 1 ; apparent_front_index = 0 ; length = 0 ; arr_length ; never_shrink } ;; let length t = t.length let is_empty t = length t = 0 (* We keep track of the length in a mutable field for speed, but this calculation should be correct by construction, and can be used for testing. *) let _invariant_length t = let constructed_length = if t.front_index < t.back_index then t.back_index - t.front_index - 1 else t.back_index - t.front_index - 1 + t.arr_length in assert (length t = constructed_length) ;; (* The various "when_not_empty" functions return misleading numbers when the dequeue is empty. They are safe to call if it is known that the dequeue is non-empty. *) let apparent_front_index_when_not_empty t = t.apparent_front_index let apparent_back_index_when_not_empty t = t.apparent_front_index + length t - 1 let actual_front_index_when_not_empty t = if t.front_index = t.arr_length - 1 then 0 else t.front_index + 1 ;; let actual_back_index_when_not_empty t = if t.back_index = 0 then t.arr_length - 1 else t.back_index - 1 ;; let checked t f = if is_empty t then None else Some (f t) let apparent_front_index t = checked t apparent_front_index_when_not_empty let apparent_back_index t = checked t apparent_back_index_when_not_empty let foldi' t dir ~init ~f = if is_empty t then init else ( let apparent_front = apparent_front_index_when_not_empty t in let apparent_back = apparent_back_index_when_not_empty t in let actual_front = actual_front_index_when_not_empty t in let actual_back = actual_back_index_when_not_empty t in let rec loop acc ~apparent_i ~real_i ~stop_pos ~step = if real_i = stop_pos then acc, apparent_i else loop (f apparent_i acc (Option_array.get_some_exn t.arr real_i)) ~apparent_i:(apparent_i + step) ~real_i:(real_i + step) ~stop_pos ~step in (* We want to iterate from actual_front to actual_back (or vice versa), but we may need to wrap around the array to do so. Thus we do the following: 1. If the active range is contiguous (i.e. actual_front <= actual_back), then loop starting at the appropriate end of the active range until we reach the first element outside of it. 2. If it is not contiguous (actual_front > actual_back), then first loop from the appropriate end of the active range to the end of the array. Then, loop from the opposite end of the array to the opposite end of the active range. *) match dir with | `front_to_back -> if actual_front <= actual_back then ( let acc, _ = loop init ~apparent_i:apparent_front ~real_i:actual_front ~stop_pos:(actual_back + 1) ~step:1 in acc) else ( let acc, apparent_i = loop init ~apparent_i:apparent_front ~real_i:actual_front ~stop_pos:t.arr_length ~step:1 in let acc, _ = loop acc ~apparent_i ~real_i:0 ~stop_pos:(actual_back + 1) ~step:1 in acc) | `back_to_front -> if actual_front <= actual_back then ( let acc, _ = loop init ~apparent_i:apparent_back ~real_i:actual_back ~stop_pos:(actual_front - 1) ~step:(-1) in acc) else ( let acc, apparent_i = loop init ~apparent_i:apparent_back ~real_i:actual_back ~stop_pos:(-1) ~step:(-1) in let acc, _ = loop acc ~apparent_i ~real_i:(t.arr_length - 1) ~stop_pos:(actual_front - 1) ~step:(-1) in acc)) ;; let fold' t dir ~init ~f = foldi' t dir ~init ~f:(fun _ acc v -> f acc v) let iteri' t dir ~f = foldi' t dir ~init:() ~f:(fun i () v -> f i v) let iter' t dir ~f = foldi' t dir ~init:() ~f:(fun _ () v -> f v) let fold t ~init ~f = fold' t `front_to_back ~init ~f let foldi t ~init ~f = foldi' t `front_to_back ~init ~f let iteri t ~f = iteri' t `front_to_back ~f let iteri_internal t ~f = if not (is_empty t) then ( let actual_front = actual_front_index_when_not_empty t in let actual_back = actual_back_index_when_not_empty t in let rec loop ~real_i ~stop_pos = if real_i < stop_pos then ( f t.arr real_i; loop ~real_i:(real_i + 1) ~stop_pos) in if actual_front <= actual_back then loop ~real_i:actual_front ~stop_pos:(actual_back + 1) else ( loop ~real_i:actual_front ~stop_pos:t.arr_length; loop ~real_i:0 ~stop_pos:(actual_back + 1))) ;; let iter t ~f = iteri_internal t ~f:(fun arr i -> Option_array.get_some_exn arr i |> f) let clear t = if t.never_shrink then (* clear the array to allow elements to be garbage collected *) iteri_internal t ~f:Option_array.unsafe_set_none else t.arr <- Option_array.create ~len:8; t.front_index <- 0; t.back_index <- 1; t.length <- 0; t.arr_length <- Option_array.length t.arr ;; (* We have to be careful here, importing all of Container.Make would change the runtime of some functions ([length] minimally) silently without changing the semantics. We get around that by importing things explicitly. *) module C = Container.Make (struct type nonrec 'a t = 'a t let fold = fold let iter = `Custom iter let length = `Custom length end) let count = C.count let sum = C.sum let exists = C.exists let mem = C.mem let for_all = C.for_all let find_map = C.find_map let find = C.find let to_list = C.to_list let min_elt = C.min_elt let max_elt = C.max_elt let fold_result = C.fold_result let fold_until = C.fold_until let blit new_arr t = assert (not (is_empty t)); let actual_front = actual_front_index_when_not_empty t in let actual_back = actual_back_index_when_not_empty t in let old_arr = t.arr in if actual_front <= actual_back then Option_array.blit ~src:old_arr ~dst:new_arr ~src_pos:actual_front ~dst_pos:0 ~len:(length t) else ( let break_pos = Option_array.length old_arr - actual_front in Option_array.blit ~src:old_arr ~dst:new_arr ~src_pos:actual_front ~dst_pos:0 ~len:break_pos; Option_array.blit ~src:old_arr ~dst:new_arr ~src_pos:0 ~dst_pos:break_pos ~len:(actual_back + 1)); (* length depends on t.arr and t.front_index, so this needs to be first *) t.back_index <- length t; t.arr <- new_arr; t.arr_length <- Option_array.length new_arr; t.front_index <- Option_array.length new_arr - 1; (* Since t.front_index = Option_array.length new_arr - 1, this is asserting that t.back_index is a valid index in the array and that the array can support at least one more element -- recall, if t.front_index = t.back_index then the array is full. Note that this is true if and only if Option_array.length new_arr > length t + 1. *) assert (t.front_index > t.back_index) ;; let maybe_shrink_underlying t = if (not t.never_shrink) && t.arr_length > 10 && t.arr_length / 3 > length t then ( let new_arr = Option_array.create ~len:(t.arr_length / 2) in blit new_arr t) ;; let grow_underlying t = let new_arr = Option_array.create ~len:(t.arr_length * 2) in blit new_arr t ;; let enqueue_back t v = if t.front_index = t.back_index then grow_underlying t; Option_array.set_some t.arr t.back_index v; t.back_index <- (if t.back_index = t.arr_length - 1 then 0 else t.back_index + 1); t.length <- t.length + 1 ;; let enqueue_front t v = if t.front_index = t.back_index then grow_underlying t; Option_array.set_some t.arr t.front_index v; t.front_index <- (if t.front_index = 0 then t.arr_length - 1 else t.front_index - 1); t.apparent_front_index <- t.apparent_front_index - 1; t.length <- t.length + 1 ;; let enqueue t back_or_front v = match back_or_front with | `back -> enqueue_back t v | `front -> enqueue_front t v ;; let peek_front_nonempty t = Option_array.get_some_exn t.arr (actual_front_index_when_not_empty t) ;; let peek_front_exn t = if is_empty t then failwith "Deque.peek_front_exn passed an empty queue" else peek_front_nonempty t ;; let peek_front t = if is_empty t then None else Some (peek_front_nonempty t) let peek_back_nonempty t = Option_array.get_some_exn t.arr (actual_back_index_when_not_empty t) ;; let peek_back_exn t = if is_empty t then failwith "Deque.peek_back_exn passed an empty queue" else peek_back_nonempty t ;; let peek_back t = if is_empty t then None else Some (peek_back_nonempty t) let peek t back_or_front = match back_or_front with | `back -> peek_back t | `front -> peek_front t ;; let dequeue_front_nonempty t = let i = actual_front_index_when_not_empty t in let res = Option_array.get_some_exn t.arr i in Option_array.set_none t.arr i; t.front_index <- i; t.apparent_front_index <- t.apparent_front_index + 1; t.length <- t.length - 1; maybe_shrink_underlying t; res ;; let dequeue_front_exn t = if is_empty t then failwith "Deque.dequeue_front_exn passed an empty queue" else dequeue_front_nonempty t ;; let dequeue_front t = if is_empty t then None else Some (dequeue_front_nonempty t) let dequeue_back_nonempty t = let i = actual_back_index_when_not_empty t in let res = Option_array.get_some_exn t.arr i in Option_array.set_none t.arr i; t.back_index <- i; t.length <- t.length - 1; maybe_shrink_underlying t; res ;; let dequeue_back_exn t = if is_empty t then failwith "Deque.dequeue_back_exn passed an empty queue" else dequeue_back_nonempty t ;; let dequeue_back t = if is_empty t then None else Some (dequeue_back_nonempty t) let dequeue_exn t back_or_front = match back_or_front with | `front -> dequeue_front_exn t | `back -> dequeue_back_exn t ;; let dequeue t back_or_front = match back_or_front with | `front -> dequeue_front t | `back -> dequeue_back t ;; let drop_gen ?(n = 1) ~dequeue t = if n < 0 then invalid_argf "Deque.drop: negative input (%d)" n (); let rec loop n = if n > 0 then ( match dequeue t with | None -> () | Some _ -> loop (n - 1)) in loop n ;; let drop_front ?n t = drop_gen ?n ~dequeue:dequeue_front t let drop_back ?n t = drop_gen ?n ~dequeue:dequeue_back t let drop ?n t back_or_front = match back_or_front with | `back -> drop_back ?n t | `front -> drop_front ?n t ;; let assert_not_empty t name = if is_empty t then failwithf "%s: Deque.t is empty" name () let true_index_exn t i = let i_from_zero = i - t.apparent_front_index in if i_from_zero < 0 || length t <= i_from_zero then ( assert_not_empty t "Deque.true_index_exn"; let apparent_front = apparent_front_index_when_not_empty t in let apparent_back = apparent_back_index_when_not_empty t in invalid_argf "invalid index: %i for array with indices (%i,%i)" i apparent_front apparent_back ()); let true_i = t.front_index + 1 + i_from_zero in if true_i >= t.arr_length then true_i - t.arr_length else true_i ;; let get t i = Option_array.get_some_exn t.arr (true_index_exn t i) let get_opt t i = try Some (get t i) with | _ -> None ;; let set_exn t i v = Option_array.set_some t.arr (true_index_exn t i) v let to_array t = match peek_front t with | None -> [||] | Some front -> let arr = Array.create ~len:(length t) front in ignore (fold t ~init:0 ~f:(fun i v -> arr.(i) <- v; i + 1) : int); arr ;; let of_array arr = let t = create ~initial_length:(Array.length arr + 1) () in Array.iter arr ~f:(fun v -> enqueue_back t v); t ;; include Bin_prot.Utils.Make_iterable_binable1 (struct type nonrec 'a t = 'a t type 'a el = 'a [@@deriving bin_io] let caller_identity = Bin_prot.Shape.Uuid.of_string "34c1e9ca-4992-11e6-a686-8b4bd4f87796" ;; let module_name = Some "Core.Deque" let length = length let iter t ~f = iter t ~f let init ~len ~next = let t = create ~initial_length:len () in for _i = 0 to len - 1 do let x = next () in enqueue_back t x done; t ;; end) let t_of_sexp f sexp = of_array (Array.t_of_sexp f sexp) let sexp_of_t f t = Array.sexp_of_t f (to_array t) let t_sexp_grammar elt_grammar = Sexplib.Sexp_grammar.coerce (Array.t_sexp_grammar elt_grammar) ;; (* re-expose these here under a different name to avoid internal confusion *) let back_index = apparent_back_index let front_index = apparent_front_index let back_index_exn t = assert_not_empty t "Deque.back_index_exn"; apparent_back_index_when_not_empty t ;; let front_index_exn t = assert_not_empty t "Deque.front_index_exn"; apparent_front_index_when_not_empty t ;; module Binary_searchable = Test_binary_searchable.Make1_and_test (struct type nonrec 'a t = 'a t let get t i = get t (front_index_exn t + i) let length = length module For_test = struct let of_array = of_array end end) (* The "stable" indices used in this module make the application of the [Binary_searchable] functor awkward. We need to be sure to translate incoming positions from stable space to the expected 0 -> length - 1 space and then we need to translate them back on return. *) let binary_search ?pos ?len t ~compare how v = let pos = match pos with | None -> None | Some pos -> Some (pos - t.apparent_front_index) in match Binary_searchable.binary_search ?pos ?len t ~compare how v with | None -> None | Some untranslated_i -> Some (t.apparent_front_index + untranslated_i) ;; let binary_search_segmented ?pos ?len t ~segment_of how = let pos = match pos with | None -> None | Some pos -> Some (pos - t.apparent_front_index) in match Binary_searchable.binary_search_segmented ?pos ?len t ~segment_of how with | None -> None | Some untranslated_i -> Some (t.apparent_front_index + untranslated_i) ;; core-0.15.0/core/src/deque.mli000066400000000000000000000107731420273305200160600ustar00rootroot00000000000000 (** A double-ended queue that can shrink and expand on both ends. An index is assigned to an element when it enters the queue, and the index of an element is static (i.e., an index refers to a distinct element until that element is removed from the queue, no matter how many intervening push/pop operations occur). One consequence of this is that the minimum index may be less than zero. The "front" is the smallest valid index, while the "back" is the largest. All operations are amortized O(1) with a small constant. *) open! Import type 'a t [@@deriving bin_io, sexp, sexp_grammar] include Binary_searchable.S1 with type 'a t := 'a t include Container.S1 with type 'a t := 'a t (** [create ?initial_length ?never_shrink ()] creates a new [t]. [initial_length] is the initial length of the dequeue; it will be able to hold [initial_length] elements without resizing. It must be positive. If [never_shrink] is true, the physical array will never shrink, only expand. If [initial_length] is given without [never_shrink], then [never_shrink] is presumed to be [true], otherwise [never_shrink] defaults to [false]. @param initial_length defaults to 7 *) val create : ?initial_length:int (** defaults to [7]. *) -> ?never_shrink:bool -> unit -> _ t (** [of_array arr] creates a dequeue containing the elements of [arr]. The first element of the array will be at the front of the dequeue. *) val of_array : 'a array -> 'a t (** [front_index t] return the index of the front item in [t]. *) val front_index : _ t -> int option (** [front_index_exn t] throws an exception if [t] is empty, otherwise returns the index of the front item in [t]. *) val front_index_exn : _ t -> int (** [back_index t] return the index of the back item in [t]. *) val back_index : _ t -> int option (** [back_index_exn t] throws an exception if [t] is empty, otherwise returns the index of the back item in [t]. *) val back_index_exn : _ t -> int (** [get_opt t i] returns the element at index [i]. Return [None] if [i] is invalid. *) val get_opt : 'a t -> int -> 'a option (** [get t i] returns the element at index [i]. Raise an exception if [i] is invalid. *) val get : 'a t -> int -> 'a (** [peek t back_or_front] returns the value at the back or front of the dequeue without removing it. *) val peek : 'a t -> [ `back | `front ] -> 'a option val peek_front : 'a t -> 'a option val peek_front_exn : 'a t -> 'a val peek_back : 'a t -> 'a option val peek_back_exn : 'a t -> 'a (** [set_exn t i v] mutates the element at [i]. *) val set_exn : 'a t -> int -> 'a -> unit (** [iter' t ~f] iterates over the elements of [t]. *) val iter' : 'a t -> [ `front_to_back | `back_to_front ] -> f:('a -> unit) -> unit (** [iteri t ~f] iterates over the elements of [t] [`front_to_back] passing in the index. *) val iteri : 'a t -> f:(int -> 'a -> unit) -> unit (** [iteri' t ~f] is the same as [iter'], but also passes in the index of the current element. *) val iteri' : 'a t -> [ `front_to_back | `back_to_front ] -> f:(int -> 'a -> unit) -> unit (** [fold' t ~init ~f] folds over the elements of [t]. *) val fold' : 'a t -> [ `front_to_back | `back_to_front ] -> init:'b -> f:('b -> 'a -> 'b) -> 'b (** [foldi t ~init ~f] is the same as [fold], but also passes in the index of the current element to [f]. *) val foldi : 'a t -> init:'b -> f:(int -> 'b -> 'a -> 'b) -> 'b (** [foldi' t ~init ~f] is the same as [fold'], but also passes in the index of the current element to [f]. *) val foldi' : 'a t -> [ `front_to_back | `back_to_front ] -> init:'b -> f:(int -> 'b -> 'a -> 'b) -> 'b (** [enqueue t back_or_front v] pushes [v] onto the [back_or_front] of [t]. *) val enqueue : 'a t -> [ `back | `front ] -> 'a -> unit val enqueue_front : 'a t -> 'a -> unit val enqueue_back : 'a t -> 'a -> unit (** [clear t] removes all elements from [t]. *) val clear : _ t -> unit (** [drop ?n t back_or_front] drops [n] elements (default 1) from the [back_or_front] of [t]. If [t] has fewer than [n] elements then it is cleared. *) val drop : ?n:int -> _ t -> [ `back | `front ] -> unit val drop_front : ?n:int -> _ t -> unit val drop_back : ?n:int -> _ t -> unit (** [dequeue t back_or_front] removes and returns the [back_or_front] of [t]. *) val dequeue : 'a t -> [ `back | `front ] -> 'a option val dequeue_exn : 'a t -> [ `back | `front ] -> 'a val dequeue_front : 'a t -> 'a option val dequeue_front_exn : 'a t -> 'a val dequeue_back : 'a t -> 'a option val dequeue_back_exn : 'a t -> 'a core-0.15.0/core/src/deriving_hash.ml000066400000000000000000000004711420273305200174100ustar00rootroot00000000000000open! Import include Deriving_hash_intf module Of_deriving_hash (Repr : S) (M : sig type t val to_repr : t -> Repr.t end) = struct let hash_fold_t state t = Repr.hash_fold_t state (M.to_repr t) let hash = Ppx_hash_lib.Std.Hash.of_fold hash_fold_t end core-0.15.0/core/src/deriving_hash.mli000066400000000000000000000002001420273305200175470ustar00rootroot00000000000000(** Generates hash functions from type expressions and definitions. *) include Deriving_hash_intf.Deriving_hash (** @inline *) core-0.15.0/core/src/deriving_hash_intf.ml000066400000000000000000000004221420273305200204240ustar00rootroot00000000000000open! Import module type S = sig type t [@@deriving hash] end module type Deriving_hash = sig module Of_deriving_hash (Repr : S) (M : sig type t val to_repr : t -> Repr.t end) : S with type t := M.t end core-0.15.0/core/src/digit_string_helpers.ml000066400000000000000000000413221420273305200210060ustar00rootroot00000000000000open! Import open Std_internal open Int.Replace_polymorphic_compare module Round = struct type t = | Toward_positive_infinity | Toward_negative_infinity [@@deriving compare, sexp_of] end let module_name = "Digit_string_helpers" let int63_two = Int63.of_int 2 let int63_ten = Int63.of_int 10 let int63_twenty = Int63.of_int 20 let int63_billion = Int63.of_int 1_000_000_000 let max_billions = Int63.( / ) Int63.max_value int63_billion let rec digits_of_positive_int63 n = if Int63.( < ) n int63_ten then 1 else Int.succ (digits_of_positive_int63 (Int63.( / ) n int63_ten)) ;; let digits_of_int63_max_value = digits_of_positive_int63 Int63.max_value let rec max_int63_with ~digits = match digits with | 1 -> Int63.of_int 9 | 2 -> Int63.of_int 99 | 3 -> Int63.of_int 999 | 4 -> Int63.of_int 9_999 | 5 -> Int63.of_int 99_999 | 6 -> Int63.of_int 999_999 | 7 -> Int63.of_int 9_999_999 | 8 -> Int63.of_int 99_999_999 | 9 -> Int63.of_int 999_999_999 | _ -> if digits >= digits_of_int63_max_value then Int63.max_value else ( let billions = Int63.succ (max_int63_with ~digits:(digits - 9)) in Int63.pred (Int63.( * ) int63_billion billions)) ;; module Unsafe = struct let unsafe_char_of_digit n = Char.unsafe_of_int (Char.to_int '0' + n) let digit_of_char char = Char.get_digit_exn char let write_1_digit_int bytes ~pos int = Bytes.unsafe_set bytes pos (unsafe_char_of_digit int) ;; let return_tens_and_write_ones bytes ~pos int = let tens = int / 10 in let ones = int - (tens * 10) in write_1_digit_int bytes ~pos ones; tens ;; let write_2_digit_int bytes ~pos int = let tens = return_tens_and_write_ones bytes ~pos:(pos + 1) int in write_1_digit_int bytes ~pos tens ;; let write_3_digit_int bytes ~pos int = let tens = return_tens_and_write_ones bytes ~pos:(pos + 2) int in write_2_digit_int bytes ~pos tens ;; let write_4_digit_int bytes ~pos int = let tens = return_tens_and_write_ones bytes ~pos:(pos + 3) int in write_3_digit_int bytes ~pos tens ;; let write_5_digit_int bytes ~pos int = let tens = return_tens_and_write_ones bytes ~pos:(pos + 4) int in write_4_digit_int bytes ~pos tens ;; let write_6_digit_int bytes ~pos int = let tens = return_tens_and_write_ones bytes ~pos:(pos + 5) int in write_5_digit_int bytes ~pos tens ;; let write_7_digit_int bytes ~pos int = let tens = return_tens_and_write_ones bytes ~pos:(pos + 6) int in write_6_digit_int bytes ~pos tens ;; let write_8_digit_int bytes ~pos int = let tens = return_tens_and_write_ones bytes ~pos:(pos + 7) int in write_7_digit_int bytes ~pos tens ;; let write_9_digit_int bytes ~pos int = let tens = return_tens_and_write_ones bytes ~pos:(pos + 8) int in write_8_digit_int bytes ~pos tens ;; let return_billions_and_write_remainder bytes ~pos int63 = let billions = Int63.( / ) int63 int63_billion in let remainder = Int63.( - ) int63 (Int63.( * ) billions int63_billion) in write_9_digit_int bytes ~pos (Int63.to_int_exn remainder); billions ;; let rec write_int63 bytes ~pos ~digits int63 = match digits with | 1 -> write_1_digit_int bytes ~pos (Int63.to_int_exn int63) | 2 -> write_2_digit_int bytes ~pos (Int63.to_int_exn int63) | 3 -> write_3_digit_int bytes ~pos (Int63.to_int_exn int63) | 4 -> write_4_digit_int bytes ~pos (Int63.to_int_exn int63) | 5 -> write_5_digit_int bytes ~pos (Int63.to_int_exn int63) | 6 -> write_6_digit_int bytes ~pos (Int63.to_int_exn int63) | 7 -> write_7_digit_int bytes ~pos (Int63.to_int_exn int63) | 8 -> write_8_digit_int bytes ~pos (Int63.to_int_exn int63) | 9 -> write_9_digit_int bytes ~pos (Int63.to_int_exn int63) | _ -> let digits_of_billions = digits - 9 in let billions = return_billions_and_write_remainder bytes ~pos:(pos + digits_of_billions) int63 in write_int63 bytes ~pos ~digits:digits_of_billions billions ;; let read_1_digit_int string ~pos = digit_of_char (String.unsafe_get string pos) let read_2_digit_int string ~pos = (read_1_digit_int string ~pos * 10) + read_1_digit_int string ~pos:(pos + 1) ;; let read_3_digit_int string ~pos = (read_2_digit_int string ~pos * 10) + read_1_digit_int string ~pos:(pos + 2) ;; let read_4_digit_int string ~pos = (read_3_digit_int string ~pos * 10) + read_1_digit_int string ~pos:(pos + 3) ;; let read_5_digit_int string ~pos = (read_4_digit_int string ~pos * 10) + read_1_digit_int string ~pos:(pos + 4) ;; let read_6_digit_int string ~pos = (read_5_digit_int string ~pos * 10) + read_1_digit_int string ~pos:(pos + 5) ;; let read_7_digit_int string ~pos = (read_6_digit_int string ~pos * 10) + read_1_digit_int string ~pos:(pos + 6) ;; let read_8_digit_int string ~pos = (read_7_digit_int string ~pos * 10) + read_1_digit_int string ~pos:(pos + 7) ;; let read_9_digit_int string ~pos = (read_8_digit_int string ~pos * 10) + read_1_digit_int string ~pos:(pos + 8) ;; let raise_int63_overflow name = invalid_argf "%s.%s: overflow reading int63" module_name name () ;; let rec read_int63 string ~pos ~digits = match digits with | 1 -> Int63.of_int (read_1_digit_int string ~pos) | 2 -> Int63.of_int (read_2_digit_int string ~pos) | 3 -> Int63.of_int (read_3_digit_int string ~pos) | 4 -> Int63.of_int (read_4_digit_int string ~pos) | 5 -> Int63.of_int (read_5_digit_int string ~pos) | 6 -> Int63.of_int (read_6_digit_int string ~pos) | 7 -> Int63.of_int (read_7_digit_int string ~pos) | 8 -> Int63.of_int (read_8_digit_int string ~pos) | 9 -> Int63.of_int (read_9_digit_int string ~pos) | _ -> let digits_of_billions = digits - 9 in let billions = read_int63 string ~pos ~digits:digits_of_billions in let remainder = Int63.of_int (read_9_digit_int string ~pos:(pos + digits_of_billions)) in if Int63.( > ) billions max_billions then raise_int63_overflow "read_int63"; let sum = Int63.( + ) (Int63.( * ) billions int63_billion) remainder in if Int63.( < ) sum Int63.zero then raise_int63_overflow "read_int63"; sum ;; let divide_and_round_up ~numerator ~denominator = let open Int63.O in (numerator + denominator - Int63.one) /% denominator ;; let raise_invalid_decimal name = invalid_argf "%s.%s: invalid decimal character" module_name name () ;; (* Reads the portion of string between [pos] and [pos+decimals-1], inclusive, and interperets it as a positive decimal part of a number, which we call [x]. Let [i] and [r] be the integer part and remaining fractional part of [x * scale / divisor]. If [r < round_at/divisor], returns [i]. If [r = round_at/divisor], returns [i] or [i+1] based on [round_exact]. If [r > round_at/divisor], returns [i+1]. Assumes without checking that [scale] and [divisor] are both positive and less than [Int63.max_value / 10] (to avoid internal overflow during the algorithm when multiplying by 10), and that [round_at >= 0] and [round_at < divisor]. *) let read_int63_decimal_rounded string ~pos:start ~decimals ~scale ~divisor ~round_at ~round_exact ~allow_underscore = let open Int63.O in let until = Int.( + ) start decimals in (* The loop invariant is that each iteration, we strip off the next decimal digit and update [sum], [round_at], and [divisor] such that the desired result is: [ sum + round(remaining_digits_of_x_parsed_as_decimal * scale / divisor) ] where "round" rounds based on the new value of [round_at]. *) let divisor = ref divisor in let round_at = ref round_at in let sum = ref Int63.zero in let pos = ref start in (* Stop if we run out of characters, or if further digits cannot increase our sum. *) while Int.( <> ) !pos until && !round_at < scale do (match String.unsafe_get string !pos with | '0' .. '9' as char -> let digit = Int63.of_int (digit_of_char char) in (* Every new decimal place implicitly scales our numerator by a factor of ten, so must also effectively scale our denominator. 0.abcdef * scale/divisor [round at round_at] = a.bcdef * scale/(divisor*10) [round at round_at*10] Then redefine divisor := divisor*10 and round_at := round_at*10, so we have: a.bcdef * scale/divisor [round at round_at] *) divisor := !divisor * int63_ten; round_at := !round_at * int63_ten; (* Next we work out the part of the sum based on our current digit: a.bcdef * scale/divisor [round at round_at] = a.bcdef * scale/divisor - round_at / divisor [round at 0] = (a*scale-round_at) / divisor + 0.bcdef * scale/divisor [round at 0] Decompose the first term into integer and remainder parts. Since we have already subtracted [round_at], we decompose based on the ceiling rather than the floor of the division, e.g. 5/3 would decompose as 2 + (-1)/3, rather than 1 + (2/3). = increment + remainder/divisor + 0.bcdef * scale/divisor [round at 0] = increment + 0.bcdef * scale/divisor [round at -remainder] *) let numerator = (digit * scale) - !round_at in let denominator = !divisor in let increment = divide_and_round_up ~numerator ~denominator in let remainder = numerator - (increment * denominator) in (* Now just accumulate the new increment and iterate on the remaining part: 0.bcdef * scale/divisor [round at -remainder]. Since [remainder] is between [-(divisor-1)] and [0] inclusive, the new [round_at] will be within [0] and [divisor-1] inclusive. *) round_at := -remainder; sum := !sum + increment; (* This line prevents the divisor from growing without bound and overflowing. If this line actually changes the divisor, then the divisor is larger than the scale, so the sum will increase if and only if [parsed_remaining_digits * scale (> or >=) round_at], which doesn't depend on how much larger the divisor is. So this change is safe. *) divisor := Int63.min denominator scale | '_' when allow_underscore -> () | _ -> raise_invalid_decimal "read_int63_decimal"); pos := Int.succ !pos done; if !round_at = zero then ( match round_exact with | Round.Toward_negative_infinity -> () | Round.Toward_positive_infinity -> sum := !sum + Int63.one); !sum ;; let read_int63_decimal string ~pos ~decimals ~scale ~round_ties ~allow_underscore = read_int63_decimal_rounded string ~pos ~decimals ~scale:(Int63.( * ) scale int63_two) ~divisor:int63_two ~round_at:Int63.one ~round_exact:round_ties ~allow_underscore ;; end let min_scale = Int63.one let max_scale = Int63.( / ) Int63.max_value int63_twenty let raise_negative_decimals name ~decimals = invalid_argf "%s.%s: decimals=%d is negative" module_name name decimals () ;; let raise_non_positive_digits name ~digits = invalid_argf "%s.%s: digits=%d is not a positive number" module_name name digits () ;; let raise_scale_out_of_bounds name ~scale = invalid_argf "%s.%s: scale=%Ld out of range [%Ld, %Ld]" module_name name (Int63.to_int64 scale) (Int63.to_int64 min_scale) (Int63.to_int64 max_scale) () ;; let raise_pos_out_of_bounds name ~len ~pos ~digits = if pos < 0 || pos >= len then invalid_argf "%s.%s: pos=%d out of range for string of length %d" module_name name pos len () else invalid_argf "%s.%s: %d digits do not fit at pos %d in string of length %d" module_name name digits pos len () ;; let raise_int_out_of_bounds name ~max int = invalid_argf "%s.%s: %d out of range [0, %d]" module_name name int max () ;; let raise_int63_out_of_bounds name ~max int63 = invalid_argf !"%s.%s: %{Int63} out of range [0, %{Int63}]" module_name name int63 max () ;; let check_decimals name ~decimals = if decimals < 0 then raise_negative_decimals name ~decimals ;; let check_digits name ~digits = if digits < 1 then raise_non_positive_digits name ~digits let check_pos name ~len ~pos ~digits = if pos < 0 || pos + digits > len then raise_pos_out_of_bounds name ~len ~pos ~digits ;; let check_int name ~max int = if int < 0 || int > max then raise_int_out_of_bounds name ~max int ;; let check_int63 name ~max int63 = if Int63.( < ) int63 Int63.zero || Int63.( > ) int63 max then raise_int63_out_of_bounds name ~max int63 ;; let check_scale name ~scale = if Int63.( < ) scale min_scale || Int63.( > ) scale max_scale then raise_scale_out_of_bounds name ~scale ;; let check_write name ~bytes ~pos ~digits ~max int = let len = Bytes.length bytes in check_pos name ~digits ~len ~pos; check_int name ~max int ;; let check_write63 name ~bytes ~pos ~digits int63 = check_digits name ~digits; let max = max_int63_with ~digits in let len = Bytes.length bytes in check_pos name ~digits ~len ~pos; check_int63 name ~max int63 ;; let write_1_digit_int bytes ~pos int = check_write "write_1_digit_int" ~bytes ~pos ~digits:1 ~max:9 int; Unsafe.write_1_digit_int bytes ~pos int ;; let write_2_digit_int bytes ~pos int = check_write "write_2_digit_int" ~bytes ~pos ~digits:2 ~max:99 int; Unsafe.write_2_digit_int bytes ~pos int ;; let write_3_digit_int bytes ~pos int = check_write "write_3_digit_int" ~bytes ~pos ~digits:3 ~max:999 int; Unsafe.write_3_digit_int bytes ~pos int ;; let write_4_digit_int bytes ~pos int = check_write "write_4_digit_int" ~bytes ~pos ~digits:4 ~max:9_999 int; Unsafe.write_4_digit_int bytes ~pos int ;; let write_5_digit_int bytes ~pos int = check_write "write_5_digit_int" ~bytes ~pos ~digits:5 ~max:99_999 int; Unsafe.write_5_digit_int bytes ~pos int ;; let write_6_digit_int bytes ~pos int = check_write "write_6_digit_int" ~bytes ~pos ~digits:6 ~max:999_999 int; Unsafe.write_6_digit_int bytes ~pos int ;; let write_7_digit_int bytes ~pos int = check_write "write_7_digit_int" ~bytes ~pos ~digits:7 ~max:9_999_999 int; Unsafe.write_7_digit_int bytes ~pos int ;; let write_8_digit_int bytes ~pos int = check_write "write_8_digit_int" ~bytes ~pos ~digits:8 ~max:99_999_999 int; Unsafe.write_8_digit_int bytes ~pos int ;; let write_9_digit_int bytes ~pos int = check_write "write_9_digit_int" ~bytes ~pos ~digits:9 ~max:999_999_999 int; Unsafe.write_9_digit_int bytes ~pos int ;; let write_int63 bytes ~pos ~digits int63 = check_write63 "write_int63" ~bytes ~pos ~digits int63; Unsafe.write_int63 bytes ~pos ~digits int63 ;; let check_read name ~string ~pos ~digits = let len = String.length string in check_pos name ~digits ~len ~pos ;; let check_read63 name ~string ~pos ~digits = check_digits name ~digits; let len = String.length string in check_pos name ~digits ~len ~pos ;; let check_read63_decimal name ~string ~pos ~decimals ~scale = let len = String.length string in check_decimals name ~decimals; check_scale name ~scale; check_pos name ~digits:decimals ~len ~pos ;; let read_1_digit_int string ~pos = check_read "read_1_digit_int" ~string ~pos ~digits:1; Unsafe.read_1_digit_int string ~pos ;; let read_2_digit_int string ~pos = check_read "read_2_digit_int" ~string ~pos ~digits:2; Unsafe.read_2_digit_int string ~pos ;; let read_3_digit_int string ~pos = check_read "read_3_digit_int" ~string ~pos ~digits:3; Unsafe.read_3_digit_int string ~pos ;; let read_4_digit_int string ~pos = check_read "read_4_digit_int" ~string ~pos ~digits:4; Unsafe.read_4_digit_int string ~pos ;; let read_5_digit_int string ~pos = check_read "read_5_digit_int" ~string ~pos ~digits:5; Unsafe.read_5_digit_int string ~pos ;; let read_6_digit_int string ~pos = check_read "read_6_digit_int" ~string ~pos ~digits:6; Unsafe.read_6_digit_int string ~pos ;; let read_7_digit_int string ~pos = check_read "read_7_digit_int" ~string ~pos ~digits:7; Unsafe.read_7_digit_int string ~pos ;; let read_8_digit_int string ~pos = check_read "read_8_digit_int" ~string ~pos ~digits:8; Unsafe.read_8_digit_int string ~pos ;; let read_9_digit_int string ~pos = check_read "read_9_digit_int" ~string ~pos ~digits:9; Unsafe.read_9_digit_int string ~pos ;; let read_int63 string ~pos ~digits = check_read63 "read_int63" ~string ~pos ~digits; Unsafe.read_int63 string ~pos ~digits ;; let read_int63_decimal string ~pos ~decimals ~scale ~round_ties ~allow_underscore = check_read63_decimal "read_int63_decimal" ~string ~pos ~decimals ~scale; Unsafe.read_int63_decimal string ~pos ~decimals ~scale ~round_ties ~allow_underscore ;; core-0.15.0/core/src/digit_string_helpers.mli000066400000000000000000000067401420273305200211640ustar00rootroot00000000000000(** Utility functions for parsing and outputing strings containing known numbers of digits. Used primarily for building functions for reading in and writing out Time related values. *) open! Import (** {2 Write digit functions} [write_int63 bytes ~pos ~digits int63] writes the string representation of [int63], 0-padded to fill [digits] characters, into [bytes] starting at position [pos]. Raises if [int] is negative or is too long for [bytes], if [pos] is an invalid index in [bytes] for the number of digits, or if [digits < 1]. *) val write_int63 : bytes -> pos:int -> digits:int -> Int63.t -> unit (** [write_*_digit_int] is like [write_int63] for a hard-coded number of digits and for [int] rather than [Int63.t]. *) val write_1_digit_int : bytes -> pos:int -> int -> unit val write_2_digit_int : bytes -> pos:int -> int -> unit val write_3_digit_int : bytes -> pos:int -> int -> unit val write_4_digit_int : bytes -> pos:int -> int -> unit val write_5_digit_int : bytes -> pos:int -> int -> unit val write_6_digit_int : bytes -> pos:int -> int -> unit val write_7_digit_int : bytes -> pos:int -> int -> unit val write_8_digit_int : bytes -> pos:int -> int -> unit val write_9_digit_int : bytes -> pos:int -> int -> unit (** {2 Read digit functions} [read_int63 string ~pos ~digits] parses [digits] characters starting at [pos] in [string] and returns the corresponding [Int63.t]. It raises if [digits < 1] or [pos < 0] or [pos + digits > String.length string]. *) val read_int63 : string -> pos:int -> digits:int -> Int63.t (** [read_*_digit_int] is like [read_int63] for a hard-coded number of digits and for [int] rather than [Int63.t]. *) val read_1_digit_int : string -> pos:int -> int val read_2_digit_int : string -> pos:int -> int val read_3_digit_int : string -> pos:int -> int val read_4_digit_int : string -> pos:int -> int val read_5_digit_int : string -> pos:int -> int val read_6_digit_int : string -> pos:int -> int val read_7_digit_int : string -> pos:int -> int val read_8_digit_int : string -> pos:int -> int val read_9_digit_int : string -> pos:int -> int module Round : sig type t = | Toward_positive_infinity | Toward_negative_infinity [@@deriving compare, sexp_of] end (** [read_int63_decimal string ~pos ~decimals ~scale ~round_ties ~allow_underscore] reads [decimals] characters from [string] starting at [pos] as a decimal value as if starting immediately after a decimal point, and returns that fraction times [scale]. The result is rounded to the nearest value, with ties broken by [round_ties]. This function is useful for reading the decimal parts of numbers annotated with units that scale the result, such as when reading time units like "1.0ms" or "12.125s". If [allow_underscore = true], then '_' characters in [string] are allowed and ignored. Otherwise only digit characters are allowed. Raises if [pos] is out of range for [string] and [decimals], or if [scale < 1] or [scale > max_value / 20]. *) val read_int63_decimal : string -> pos:int -> decimals:int -> scale:Int63.t -> round_ties:Round.t -> allow_underscore:bool -> Int63.t (** [max_int63_with ~digits] returns the maximum [Int63.t] that fits in [digits] decimal digits. *) val max_int63_with : digits:int -> Int63.t module Unsafe : sig (** [divide_and_round_up ~numerator ~denominator] returns [ceil (numerator/denominator)]. *) val divide_and_round_up : numerator:Int63.t -> denominator:Int63.t -> Int63.t end core-0.15.0/core/src/doubly_linked.ml000066400000000000000000000661511420273305200174310ustar00rootroot00000000000000open! Import include Doubly_linked_intf (* INVARIANT: This exception is raised if a list is mutated during a pending iteration. This invariant is guaranteed by the Header and Elt modules in conjunction. All downstream code in this module need not be concerned with this invariant. *) exception Attempt_to_mutate_list_during_iteration let phys_equal = ( == ) module Header : sig type t val create : unit -> t val length : t -> int val equal : t -> t -> bool val incr_length : by:int -> t -> unit val check_no_pending_iterations : t -> unit (* Unfortunate, but by specializing [with_iteration] for different arities, a large amount of allocation during folds and iterations is avoided. The original type of [with_iteration] was [val with_iteration : t -> (unit -> 'a) -> 'a] The difference between {[ let x = e in let f () = g x in f () ]} and {[ let x = e in let f x = g x in f x ]} is that in the first case the closure for [f] contains a pointer to [x], and in the second case it doesn't. A closure without pointers to enclosing environment is implemented as a naked function pointer, so we don't allocate at all. For the same reason we make sure not to call [Result.try_with (fun () -> ...)] inside [with_iteration] and do an explicit match statement instead. *) val with_iteration_2 : t -> 'a -> 'b -> ('a -> 'b -> 'c) -> 'c val with_iteration_3 : t -> 'a -> 'b -> 'c -> ('a -> 'b -> 'c -> 'd) -> 'd val with_iteration_4 : t -> 'a -> 'b -> 'c -> 'd -> ('a -> 'b -> 'c -> 'd -> 'e) -> 'e val merge : t -> t -> [ `Same_already | `Merged ] end = struct type s = { mutable length : int ; mutable pending_iterations : int } type t = s Union_find.t let create () = Union_find.create { length = 1; pending_iterations = 0 } let equal (t1 : t) t2 = Union_find.same_class t1 t2 let length t = (Union_find.get t).length let union_find_get__check_no_pending_iterations t = let s = Union_find.get t in if s.pending_iterations > 0 then raise Attempt_to_mutate_list_during_iteration else s ;; let check_no_pending_iterations t = ignore (union_find_get__check_no_pending_iterations t : s) ;; let incr_length ~by:n t = let s = union_find_get__check_no_pending_iterations t in s.length <- s.length + n ;; (* Care is taken not to allocate in [with_iteration_*], since it is called every second by [every_second] in [writer0.ml] *) let incr_pending_iters s = s.pending_iterations <- s.pending_iterations + 1 let decr_pending_iters s = s.pending_iterations <- s.pending_iterations - 1 let with_iteration_2 t a b f = let s = Union_find.get t in incr_pending_iters s; match f a b with | exception exn -> decr_pending_iters s; raise exn | r -> decr_pending_iters s; r ;; let with_iteration_3 t a b c f = let s = Union_find.get t in incr_pending_iters s; match f a b c with | exception exn -> decr_pending_iters s; raise exn | r -> decr_pending_iters s; r ;; let with_iteration_4 t a b c d f = let s = Union_find.get t in incr_pending_iters s; match f a b c d with | exception exn -> decr_pending_iters s; raise exn | r -> decr_pending_iters s; r ;; let merge (t1 : t) t2 = if Union_find.same_class t1 t2 then `Same_already else ( let n1 = (union_find_get__check_no_pending_iterations t1).length in let n2 = (union_find_get__check_no_pending_iterations t2).length in with_iteration_4 t1 t1 t2 n1 n2 (fun t1 t2 n1 n2 -> with_iteration_4 t2 t1 t2 n1 n2 (fun t1 t2 n1 n2 -> Union_find.union t1 t2; Union_find.set t1 { length = n1 + n2; pending_iterations = 0 })); `Merged) ;; end module Elt : sig type 'a t [@@deriving sexp_of] val header : 'a t -> Header.t val equal : 'a t -> 'a t -> bool val create : 'a -> 'a t val value : 'a t -> 'a val set : 'a t -> 'a -> unit val unlink : 'a t -> unit val split_or_splice_before : 'a t -> 'a t -> unit val split_or_splice_after : 'a t -> 'a t -> unit val insert_after : 'a t -> 'a -> 'a t val insert_before : 'a t -> 'a -> 'a t val unlink_before : 'a t -> 'a t val next : 'a t -> 'a t val prev : 'a t -> 'a t end = struct type 'a t = { mutable value : 'a ; mutable prev : 'a t ; mutable next : 'a t ; mutable header : Header.t } let equal = phys_equal let next t = t.next let prev t = t.prev let header t = t.header let create_aux v header = let rec t = { value = v; prev = t; next = t; header } in t ;; let is_singleton t = equal t t.prev let sexp_of_t sexp_of_a t = sexp_of_a t.value let create v = create_aux v (Header.create ()) let value t = t.value let set t v = t.value <- v (* [split_or_splice] is sufficient as the lone primitive for accomplishing all pointer updates on cyclic loops of list nodes. It takes two "gaps" between adjacent linked list nodes. If the gaps point into the same list, the result is that it will be split into two lists afterwards. If the gaps point into different lists, the result is that they will be spliced together into one list afterwards. {v Before After -----+ +----- -----+ +----- A | <--> | B A | <--- ---> | B -----+ +----- -----+ \ / +----- X -----+ +----- -----+ / \ +----- C | <--> | D C | <--- ---> | D -----+ +----- -----+ +----- v} *) let unsafe_split_or_splice ~prev1:a ~next1:b ~prev2:c ~next2:d = a.next <- d; d.prev <- a; c.next <- b; b.prev <- c ;; let unsafe_split_or_splice_after t1 t2 = unsafe_split_or_splice ~next1:t1.next ~prev1:t1.next.prev ~next2:t2.next ~prev2:t2.next.prev ;; let unsafe_split_or_splice_before t1 t2 = unsafe_split_or_splice ~prev1:t1.prev ~next1:t1.prev.next ~prev2:t2.prev ~next2:t2.prev.next ;; let check_two_nodes_no_pending_iterations t1 t2 = Header.check_no_pending_iterations t1.header; if not (Header.equal t1.header t2.header) then Header.check_no_pending_iterations t2.header ;; (* We redefine safe versions for export *) let split_or_splice_after t1 t2 = check_two_nodes_no_pending_iterations t1 t2; unsafe_split_or_splice_after t1 t2 ;; let split_or_splice_before t1 t2 = check_two_nodes_no_pending_iterations t1 t2; unsafe_split_or_splice_before t1 t2 ;; let insert_before t v = Header.incr_length t.header ~by:1; let node = create_aux v t.header in unsafe_split_or_splice_before t node; node ;; let insert_after t v = Header.incr_length t.header ~by:1; let node = create_aux v t.header in unsafe_split_or_splice_after t node; node ;; let dummy_header = Header.create () let unlink_before t = let node = t.prev in if is_singleton node then node else ( Header.incr_length t.header ~by:(-1); unsafe_split_or_splice_before t node; node.header <- dummy_header; node) ;; let unlink_after t = let node = t.next in if is_singleton node then node else ( Header.incr_length t.header ~by:(-1); unsafe_split_or_splice_after t node; node.header <- dummy_header; node) ;; let unlink t = ignore (unlink_after t.prev : _ t) end type 'a t = 'a Elt.t option ref let invariant invariant_a t = match !t with | None -> () | Some head -> let header = Elt.header head in let rec loop n elt = let next_elt = Elt.next elt in let prev_elt = Elt.prev elt in assert (Elt.equal elt (Elt.prev next_elt)); assert (Elt.equal elt (Elt.next prev_elt)); assert (Header.equal (Elt.header elt) header); invariant_a (Elt.value elt); if Elt.equal next_elt head then n else loop (n + 1) next_elt in let len = loop 1 head in assert (len = Header.length header) ;; let create (type a) () : a t = ref None let equal (t : _ t) t' = phys_equal t t' let of_list = function | [] -> create () | x :: xs -> let first = Elt.create x in let _last = List.fold xs ~init:first ~f:Elt.insert_after in ref (Some first) ;; let of_array = function | [||] -> create () | arr -> let first = Elt.create arr.(0) in let rec loop arr elt i = if i < Array.length arr then loop arr (Elt.insert_after elt arr.(i)) (i + 1) in loop arr first 1; ref (Some first) ;; let map t ~f = match !t with | None -> create () | Some first -> let new_first = Elt.create (f (Elt.value first)) in Header.with_iteration_3 (Elt.header first) f new_first first (fun f new_first first -> let rec loop f acc first elt = let acc = Elt.insert_after acc (f (Elt.value elt)) in let next = Elt.next elt in if not (phys_equal next first) then loop f acc first next in (* unroll and skip first elt *) let next = Elt.next first in if not (phys_equal next first) then loop f new_first first next); ref (Some new_first) ;; let mapi t ~f = match !t with | None -> create () | Some first -> let new_first = Elt.create (f 0 (Elt.value first)) in Header.with_iteration_3 (Elt.header first) f new_first first (fun f new_first first -> let rec loop f i acc first elt = let acc = Elt.insert_after acc (f i (Elt.value elt)) in let next = Elt.next elt in if not (phys_equal next first) then loop f (i + 1) acc first next in (* unroll and skip first elt *) let next = Elt.next first in if not (phys_equal next first) then loop f 1 new_first first next); ref (Some new_first) ;; let fold_elt t ~init ~f = match !t with | None -> init | Some first -> Header.with_iteration_3 (Elt.header first) f init first (fun f init first -> let rec loop f acc first elt = let acc = f acc elt in let next = Elt.next elt in if phys_equal next first then acc else loop f acc first next in loop f init first first) ;; let foldi_elt t ~init ~f = match !t with | None -> init | Some first -> Header.with_iteration_3 (Elt.header first) f init first (fun f init first -> let rec loop f i acc first elt = let acc = f i acc elt in let next = Elt.next elt in if phys_equal next first then acc else loop f (i + 1) acc first next in loop f 0 init first first) ;; let fold_elt_1 t ~init ~f a = match !t with | None -> init | Some first -> Header.with_iteration_4 (Elt.header first) f a init first (fun f a init first -> let rec loop f a acc first elt = let acc = f a acc elt in let next = Elt.next elt in if phys_equal next first then acc else loop f a acc first next in loop f a init first first) ;; let foldi_elt_1 t ~init ~f a = match !t with | None -> init | Some first -> Header.with_iteration_4 (Elt.header first) f a init first (fun f a init first -> let rec loop f i a acc first elt = let acc = f i a acc elt in let next = Elt.next elt in if phys_equal next first then acc else loop f (i + 1) a acc first next in loop f 0 a init first first) ;; let iter_elt t ~f = fold_elt_1 t ~init:() ~f:(fun f () elt -> f elt) f let iteri_elt t ~f = foldi_elt t ~init:() ~f:(fun i () elt -> f i elt) open With_return let find_elt t ~f = with_return (fun r -> fold_elt_1 t f ~init:() ~f:(fun f () elt -> if f (Elt.value elt) then r.return (Some elt)); None) ;; let findi_elt t ~f = with_return (fun r -> foldi_elt_1 t f ~init:() ~f:(fun i f () elt -> if f i (Elt.value elt) then r.return (Some (i, elt))); None) ;; (* this function is lambda lifted for performance, to make direct recursive calls instead of calls through its closure. It also avoids the initial closure allocation. *) let rec iter_loop first f elt = f (Elt.value elt); let next = Elt.next elt in if not (phys_equal next first) then iter_loop first f next ;; let iter t ~f = match !t with | None -> () | Some first -> Header.with_iteration_2 (Elt.header first) first f (fun first f -> iter_loop first f first) ;; let length t = match !t with | None -> 0 | Some first -> Header.length (Elt.header first) ;; let rec iteri_loop first f i elt = f i (Elt.value elt); let next = Elt.next elt in if not (phys_equal next first) then iteri_loop first f (i + 1) next ;; let iteri t ~f = match !t with | None -> () | Some first -> Header.with_iteration_2 (Elt.header first) first f (fun first f -> iteri_loop first f 0 first) ;; let foldi t ~init ~f = foldi_elt_1 t ~init f ~f:(fun i f acc elt -> f i acc (Elt.value elt)) ;; module C = Container.Make (struct type nonrec 'a t = 'a t let fold t ~init ~f = fold_elt_1 t ~init f ~f:(fun f acc elt -> f acc (Elt.value elt)) let iter = `Custom iter let length = `Custom length end) let count = C.count let sum = C.sum let exists = C.exists let find = C.find let find_map = C.find_map let fold = C.fold let for_all = C.for_all let mem = C.mem let to_array = C.to_array let min_elt = C.min_elt let max_elt = C.max_elt let fold_result = C.fold_result let fold_until = C.fold_until let unchecked_iter t ~f = match !t with | None -> () | Some first -> let rec loop t f elt = f (Elt.value elt); let next = Elt.next elt in match !t with (* the first element of the bag may have been changed by [f] *) | None -> () | Some first -> if not (phys_equal first next) then loop t f next in loop t f first ;; let is_empty t = Option.is_none !t (* more efficient than what Container.Make returns *) let fold_right t ~init ~f = match !t with | None -> init | Some first -> Header.with_iteration_3 (Elt.header first) f init first (fun f init first -> let rec loop f acc elt = let prev = Elt.prev elt in let acc = f (Elt.value prev) acc in if phys_equal prev first then acc else loop f acc prev in loop f init first) ;; let fold_right_elt t ~init ~f = match !t with | None -> init | Some first -> Header.with_iteration_3 (Elt.header first) f init first (fun f init first -> let rec loop f acc elt = let prev = Elt.prev elt in let acc = f prev acc in if phys_equal prev first then acc else loop f acc prev in loop f init first) ;; let to_list t = fold_right t ~init:[] ~f:(fun x tl -> x :: tl) let sexp_of_t sexp_of_a t = List.sexp_of_t sexp_of_a (to_list t) let t_of_sexp a_of_sexp s = of_list (List.t_of_sexp a_of_sexp s) let t_sexp_grammar elt_grammar = Sexplib.Sexp_grammar.coerce (Base.List.t_sexp_grammar elt_grammar) ;; let copy t = of_list (to_list t) let clear t = t := None let compare compare_elt t1 t2 = match !t1, !t2 with | None, None -> 0 | None, _ -> -1 | _, None -> 1 | Some f1, Some f2 -> Header.with_iteration_3 (Elt.header f1) compare_elt f1 f2 (fun compare_elt f1 f2 -> Header.with_iteration_3 (Elt.header f2) compare_elt f1 f2 (fun compare_elt f1 f2 -> let rec loop compare_elt elt1 f1 elt2 f2 = let compare_result = compare_elt (Elt.value elt1) (Elt.value elt2) in if compare_result <> 0 then compare_result else ( let next1 = Elt.next elt1 in let next2 = Elt.next elt2 in match phys_equal next1 f1, phys_equal next2 f2 with | true, true -> 0 | true, false -> -1 | false, true -> 1 | false, false -> loop compare_elt next1 f1 next2 f2) in loop compare_elt f1 f1 f2 f2)) ;; exception Transfer_src_and_dst_are_same_list let transfer ~src ~dst = if phys_equal src dst then raise Transfer_src_and_dst_are_same_list; match !src with | None -> () | Some src_head -> (match !dst with | None -> dst := Some src_head; clear src | Some dst_head -> (match Header.merge (Elt.header src_head) (Elt.header dst_head) with | `Same_already -> raise Transfer_src_and_dst_are_same_list | `Merged -> Elt.split_or_splice_before dst_head src_head; clear src)) ;; let map_inplace t ~f = iter_elt t ~f:(fun elt -> Elt.set elt (f (Elt.value elt))) let mapi_inplace t ~f = iteri_elt t ~f:(fun i elt -> Elt.set elt (f i (Elt.value elt))) let remove_list t to_remove = List.iter to_remove ~f:(fun elt -> (match !t with | None -> () | Some head -> if Elt.equal head elt then ( let next_elt = Elt.next elt in t := if Elt.equal head next_elt then None else Some next_elt)); Elt.unlink elt) ;; let filter_inplace t ~f = let to_remove = List.rev (fold_elt t ~init:[] ~f:(fun elts elt -> if f (Elt.value elt) then elts else elt :: elts)) in remove_list t to_remove ;; let filteri_inplace t ~f = let to_remove = List.rev (foldi_elt t ~init:[] ~f:(fun i elts elt -> if f i (Elt.value elt) then elts else elt :: elts)) in remove_list t to_remove ;; let filter_map_inplace t ~f = let to_remove = List.rev (fold_elt t ~init:[] ~f:(fun elts elt -> match f (Elt.value elt) with | None -> elt :: elts | Some value -> Elt.set elt value; elts)) in remove_list t to_remove ;; let filter_mapi_inplace t ~f = let to_remove = List.rev (foldi_elt t ~init:[] ~f:(fun i elts elt -> match f i (Elt.value elt) with | None -> elt :: elts | Some value -> Elt.set elt value; elts)) in remove_list t to_remove ;; exception Elt_does_not_belong_to_list let first_elt t = !t let last_elt t = Option.map ~f:Elt.prev !t let first t = Option.map ~f:Elt.value (first_elt t) let last t = Option.map ~f:Elt.value (last_elt t) let is_first t elt = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if Header.equal (Elt.header first) (Elt.header elt) then Elt.equal elt first else raise Elt_does_not_belong_to_list ;; let is_last t elt = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if Header.equal (Elt.header first) (Elt.header elt) then ( let last = Elt.prev first in Elt.equal elt last) else raise Elt_does_not_belong_to_list ;; let mem_elt t elt = match !t with | None -> false | Some first -> Header.equal (Elt.header first) (Elt.header elt) ;; let prev t elt = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if Elt.equal elt first then None else if Header.equal (Elt.header first) (Elt.header elt) then Some (Elt.prev elt) else raise Elt_does_not_belong_to_list ;; let next t elt = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> let last = Elt.prev first in if Elt.equal elt last then None else if Header.equal (Elt.header first) (Elt.header elt) then Some (Elt.next elt) else raise Elt_does_not_belong_to_list ;; let insert_after t elt v = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if Header.equal (Elt.header first) (Elt.header elt) then Elt.insert_after elt v else raise Elt_does_not_belong_to_list ;; let insert_before t elt v = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if Elt.equal elt first then ( let new_elt = Elt.insert_before first v in t := Some new_elt; new_elt) else if Header.equal (Elt.header first) (Elt.header elt) then Elt.insert_before elt v else raise Elt_does_not_belong_to_list ;; let insert_empty t v = let new_elt = Elt.create v in t := Some new_elt; new_elt ;; let insert_last t v = match !t with | None -> insert_empty t v | Some first -> Elt.insert_before first v ;; let insert_first t v = match !t with | None -> insert_empty t v | Some first -> let new_elt = Elt.insert_before first v in t := Some new_elt; new_elt ;; let remove_last t = match !t with | None -> None | Some first -> let last = Elt.unlink_before first in if Elt.equal first last then t := None; Some (Elt.value last) ;; let remove_first t = match !t with | None -> None | Some first -> let second = Elt.next first in Elt.unlink first; t := if Elt.equal first second then None else Some second; Some (Elt.value first) ;; let remove t elt = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if Elt.equal elt first then ignore (remove_first t : _ option) else if Header.equal (Elt.header first) (Elt.header elt) then Elt.unlink elt else raise Elt_does_not_belong_to_list ;; let filter t ~f = let new_t = create () in (match !t with | None -> () | Some first -> Header.with_iteration_3 (Elt.header first) f new_t first (fun f new_t first -> let rec loop f new_t first elt = if f (Elt.value elt) then insert_last new_t (Elt.value elt) |> (ignore : _ Elt.t -> unit); let next = Elt.next elt in if not (phys_equal next first) then loop f new_t first next in loop f new_t first first)); new_t ;; let filteri t ~f = let new_t = create () in (match !t with | None -> () | Some first -> Header.with_iteration_3 (Elt.header first) f new_t first (fun f new_t first -> let rec loop f i new_t first elt = if f i (Elt.value elt) then insert_last new_t (Elt.value elt) |> (ignore : _ Elt.t -> unit); let next = Elt.next elt in if not (phys_equal next first) then loop f (i + 1) new_t first next in loop f 0 new_t first first)); new_t ;; let filter_map t ~f = let new_t = create () in (match !t with | None -> () | Some first -> Header.with_iteration_3 (Elt.header first) f new_t first (fun f new_t first -> let rec loop f new_t first elt = (match f (Elt.value elt) with | None -> () | Some value -> insert_last new_t value |> (ignore : _ Elt.t -> unit)); let next = Elt.next elt in if not (phys_equal next first) then loop f new_t first next in loop f new_t first first)); new_t ;; let filter_mapi t ~f = let new_t = create () in (match !t with | None -> () | Some first -> Header.with_iteration_3 (Elt.header first) f new_t first (fun f new_t first -> let rec loop f i new_t first elt = (match f i (Elt.value elt) with | None -> () | Some value -> insert_last new_t value |> (ignore : _ Elt.t -> unit)); let next = Elt.next elt in if not (phys_equal next first) then loop f (i + 1) new_t first next in loop f 0 new_t first first)); new_t ;; let partition_tf t ~f = let t1 = create () in let t2 = create () in (match !t with | None -> () | Some first -> Header.with_iteration_4 (Elt.header first) f t1 t2 first (fun f t1 t2 first -> let rec loop f t1 t2 first elt = insert_last (if f (Elt.value elt) then t1 else t2) (Elt.value elt) |> (ignore : _ Elt.t -> unit); let next = Elt.next elt in if not (phys_equal next first) then loop f t1 t2 first next in loop f t1 t2 first first)); t1, t2 ;; let partitioni_tf t ~f = let t1 = create () in let t2 = create () in (match !t with | None -> () | Some first -> Header.with_iteration_4 (Elt.header first) f t1 t2 first (fun f t1 t2 first -> let rec loop f i t1 t2 first elt = insert_last (if f i (Elt.value elt) then t1 else t2) (Elt.value elt) |> (ignore : _ Elt.t -> unit); let next = Elt.next elt in if not (phys_equal next first) then loop f (i + 1) t1 t2 first next in loop f 0 t1 t2 first first)); t1, t2 ;; let partition_map t ~f = let t1 = create () in let t2 = create () in (match !t with | None -> () | Some first -> Header.with_iteration_4 (Elt.header first) f t1 t2 first (fun f t1 t2 first -> let rec loop f t1 t2 first elt = (match (f (Elt.value elt) : (_, _) Either.t) with | First value -> insert_last t1 value |> (ignore : _ Elt.t -> unit) | Second value -> insert_last t2 value |> (ignore : _ Elt.t -> unit)); let next = Elt.next elt in if not (phys_equal next first) then loop f t1 t2 first next in loop f t1 t2 first first)); t1, t2 ;; let partition_mapi t ~f = let t1 = create () in let t2 = create () in (match !t with | None -> () | Some first -> Header.with_iteration_4 (Elt.header first) f t1 t2 first (fun f t1 t2 first -> let rec loop f i t1 t2 first elt = (match (f i (Elt.value elt) : (_, _) Either.t) with | First value -> insert_last t1 value |> (ignore : _ Elt.t -> unit) | Second value -> insert_last t2 value |> (ignore : _ Elt.t -> unit)); let next = Elt.next elt in if not (phys_equal next first) then loop f (i + 1) t1 t2 first next in loop f 0 t1 t2 first first)); t1, t2 ;; exception Invalid_move__elt_equals_anchor let move_before t elt ~anchor = if Elt.equal anchor elt then raise Invalid_move__elt_equals_anchor; if Header.equal (Elt.header anchor) (Elt.header elt) then ( match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if Header.equal (Elt.header first) (Elt.header elt) then ( (* unlink [elt] *) let after_elt = Elt.next elt in Elt.split_or_splice_before elt after_elt; let first = if Elt.equal first elt then ( t := Some after_elt; after_elt) else first in (* splice [elt] in before [anchor] *) Elt.split_or_splice_before anchor elt; if Elt.equal first anchor then t := Some elt) else raise Elt_does_not_belong_to_list) else raise Elt_does_not_belong_to_list ;; let move_to_front t elt = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if not (Elt.equal elt first) then move_before t elt ~anchor:first ;; let move_after t elt ~anchor = if Elt.equal anchor elt then raise Invalid_move__elt_equals_anchor; if Header.equal (Elt.header anchor) (Elt.header elt) then ( match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if Header.equal (Elt.header first) (Elt.header elt) then ( (* unlink [elt] *) let after_elt = Elt.next elt in Elt.split_or_splice_before elt after_elt; if Elt.equal first elt then t := Some after_elt; (* splice [elt] in after [anchor] *) Elt.split_or_splice_after anchor elt) else raise Elt_does_not_belong_to_list) else raise Elt_does_not_belong_to_list ;; let move_to_back t elt = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> let last = Elt.prev first in if not (Elt.equal elt last) then move_after t elt ~anchor:last ;; let to_sequence t = to_list t |> Sequence.of_list core-0.15.0/core/src/doubly_linked.mli000066400000000000000000000000701420273305200175660ustar00rootroot00000000000000include Doubly_linked_intf.Doubly_linked (** @inline *) core-0.15.0/core/src/doubly_linked_intf.ml000066400000000000000000000156601420273305200204500ustar00rootroot00000000000000(** Doubly-linked lists. Compared to other doubly-linked lists, in this one: 1. Calls to modification functions ([insert*], [move*], ...) detect if the list is being iterated over ([iter], [fold], ...), and if so raise an exception. For example, a use like the following would raise: {[ iter t ~f:(fun _ -> ... remove t e ...) ]} 2. There is a designated "front" and "back" of each list, rather than viewing each element as an equal in a ring. 3. Elements know which list they're in. Each operation that takes an [Elt.t] also takes a [t], first checks that the [Elt] belongs to the [t], and if not, raises. 4. Related to (3), lists cannot be split, though a sort of splicing is available as [transfer]. In other words, no operation will cause one list to become two. This makes this module unsuitable for maintaining the faces of a planar graph under edge insertion and deletion, for example. 5. Another property permitted by (3) and (4) is that [length] is O(1). *) open! Import module type S = sig module Elt : sig type 'a t val value : 'a t -> 'a (** pointer equality *) val equal : 'a t -> 'a t -> bool val set : 'a t -> 'a -> unit val sexp_of_t : ('a -> Base.Sexp.t) -> 'a t -> Base.Sexp.t end type 'a t [@@deriving compare, sexp, sexp_grammar] include Container.S1 with type 'a t := 'a t include Invariant.S1 with type 'a t := 'a t (** {2 Creating doubly-linked lists} *) val create : unit -> 'a t (** [of_list l] returns a doubly-linked list [t] with the same elements as [l] and in the same order (i.e., the first element of [l] is the first element of [t]). It is always the case that [l = to_list (of_list l)]. *) val of_list : 'a list -> 'a t val of_array : 'a array -> 'a t (** {2 Predicates} *) (** pointer equality *) val equal : 'a t -> 'a t -> bool val is_first : 'a t -> 'a Elt.t -> bool val is_last : 'a t -> 'a Elt.t -> bool val mem_elt : 'a t -> 'a Elt.t -> bool (** {2 Constant-time extraction of first and last elements} *) val first_elt : 'a t -> 'a Elt.t option val last_elt : 'a t -> 'a Elt.t option val first : 'a t -> 'a option val last : 'a t -> 'a option (** {2 Constant-time retrieval of next or previous element} *) val next : 'a t -> 'a Elt.t -> 'a Elt.t option val prev : 'a t -> 'a Elt.t -> 'a Elt.t option (** {2 Constant-time insertion of a new element} *) val insert_before : 'a t -> 'a Elt.t -> 'a -> 'a Elt.t val insert_after : 'a t -> 'a Elt.t -> 'a -> 'a Elt.t val insert_first : 'a t -> 'a -> 'a Elt.t val insert_last : 'a t -> 'a -> 'a Elt.t (** {2 Constant-time move of an element from and to positions in the same list} An exception is raised if [elt] is equal to [anchor]. *) val move_to_front : 'a t -> 'a Elt.t -> unit val move_to_back : 'a t -> 'a Elt.t -> unit val move_after : 'a t -> 'a Elt.t -> anchor:'a Elt.t -> unit val move_before : 'a t -> 'a Elt.t -> anchor:'a Elt.t -> unit (** {2 Constant-time removal of an element} *) val remove : 'a t -> 'a Elt.t -> unit val remove_first : 'a t -> 'a option val remove_last : 'a t -> 'a option val iteri : 'a t -> f:(int -> 'a -> unit) -> unit val foldi : 'a t -> init:'b -> f:(int -> 'b -> 'a -> 'b) -> 'b (** [fold_elt t ~init ~f] is the same as fold, except [f] is called with the ['a Elt.t]'s from the list instead of the contained ['a] values. Note that like other iteration functions, it is an error to mutate [t] inside the fold. If you'd like to call [remove] on any of the ['a Elt.t]'s, use [filter_inplace]. *) val fold_elt : 'a t -> init:'b -> f:('b -> 'a Elt.t -> 'b) -> 'b val foldi_elt : 'a t -> init:'b -> f:(int -> 'b -> 'a Elt.t -> 'b) -> 'b val iter_elt : 'a t -> f:('a Elt.t -> unit) -> unit val iteri_elt : 'a t -> f:(int -> 'a Elt.t -> unit) -> unit val fold_right : 'a t -> init:'b -> f:('a -> 'b -> 'b) -> 'b val fold_right_elt : 'a t -> init:'b -> f:('a Elt.t -> 'b -> 'b) -> 'b (** [find_elt t ~f] finds the first element in [t] that satisfies [f], by testing each of element of [t] in turn until [f] succeeds. *) val find_elt : 'a t -> f:('a -> bool) -> 'a Elt.t option val findi_elt : 'a t -> f:(int -> 'a -> bool) -> (int * 'a Elt.t) option (** [clear t] removes all elements from the list in constant time. *) val clear : 'a t -> unit val copy : 'a t -> 'a t (** [transfer ~src ~dst] has the same behavior as [iter src ~f:(insert_last dst); clear src] except that it runs in constant time. If [s = to_list src] and [d = to_list dst], then after [transfer ~src ~dst]: [to_list src = []] [to_list dst = d @ s] *) val transfer : src:'a t -> dst:'a t -> unit (** {2 Linear-time mapping of lists (creates a new list)} *) val map : 'a t -> f:('a -> 'b) -> 'b t val mapi : 'a t -> f:(int -> 'a -> 'b) -> 'b t val filter : 'a t -> f:('a -> bool) -> 'a t val filteri : 'a t -> f:(int -> 'a -> bool) -> 'a t val filter_map : 'a t -> f:('a -> 'b option) -> 'b t val filter_mapi : 'a t -> f:(int -> 'a -> 'b option) -> 'b t (** {2 Linear-time partition of lists (creates two new lists)} *) val partition_tf : 'a t -> f:('a -> bool) -> 'a t * 'a t val partitioni_tf : 'a t -> f:(int -> 'a -> bool) -> 'a t * 'a t val partition_map : 'a t -> f:('a -> ('b, 'c) Either.t) -> 'b t * 'c t val partition_mapi : 'a t -> f:(int -> 'a -> ('b, 'c) Either.t) -> 'b t * 'c t (** {2 Linear-time in-place mapping of lists} *) (** [map_inplace t ~f] replaces all values [v] with [f v] *) val map_inplace : 'a t -> f:('a -> 'a) -> unit val mapi_inplace : 'a t -> f:(int -> 'a -> 'a) -> unit (** [filter_inplace t ~f] removes all elements of [t] that don't satisfy [f]. *) val filter_inplace : 'a t -> f:('a -> bool) -> unit val filteri_inplace : 'a t -> f:(int -> 'a -> bool) -> unit (** If [f] returns [None], the element is removed, else the value is replaced with the contents of the [Some] *) val filter_map_inplace : 'a t -> f:('a -> 'a option) -> unit val filter_mapi_inplace : 'a t -> f:(int -> 'a -> 'a option) -> unit (** [unchecked_iter t ~f] behaves like [iter t ~f] except that [f] is allowed to modify [t]. Adding or removing elements before the element currently being visited has no effect on the traversal. Elements added after the element currently being visited will be traversed. Elements deleted after the element currently being visited will not be traversed. Deleting the element currently being visited is an error that is not detected (presumably leading to an infinite loop). *) val unchecked_iter : 'a t -> f:('a -> unit) -> unit (** A sequence of values from the doubly-linked list. It makes an intermediate copy of the list so that the returned sequence is immune to any subsequent mutation of the original list. *) val to_sequence : 'a t -> 'a Sequence.t end module type Doubly_linked = sig module type S = S include S end core-0.15.0/core/src/dune000066400000000000000000000012671420273305200151260ustar00rootroot00000000000000(rule (targets config.h) (deps) (action (bash "cp %{lib:jst-config:config.h} ."))) (library (name core) (public_name core) (install_c_headers time_ns_stubs) (libraries base base_bigstring base_for_tests base_quickcheck bin_prot base.caml fieldslib jane-street-headers base.md5 ppx_assert.runtime-lib ppx_hash.runtime-lib ppx_inline_test.runtime-lib sexplib splittable_random stdio time_now typerep validate variantslib) (c_flags :standard -D_LARGEFILE64_SOURCE) (c_names bigstring_stubs md5_stubs array_stubs gc_stubs time_ns_stubs heap_block_stubs) (preprocess (pps ppx_jane)) (preprocessor_deps config.h) (js_of_ocaml (javascript_files strftime.js runtime.js))) (documentation)core-0.15.0/core/src/either.ml000066400000000000000000000012071420273305200160540ustar00rootroot00000000000000module Stable = struct module V1 = struct type ('f, 's) t = ('f, 's) Base.Either.t = | First of 'f | Second of 's [@@deriving bin_io, compare, hash, sexp, typerep] let map x ~f1 ~f2 = match x with | First x1 -> First (f1 x1) | Second x2 -> Second (f2 x2) ;; end end include Stable.V1 include Base.Either include Comparator.Derived2 (struct type nonrec ('a, 'b) t = ('a, 'b) t [@@deriving sexp_of, compare] end) let quickcheck_generator = Base_quickcheck.Generator.either let quickcheck_observer = Base_quickcheck.Observer.either let quickcheck_shrinker = Base_quickcheck.Shrinker.either core-0.15.0/core/src/either.mli000066400000000000000000000011271420273305200162260ustar00rootroot00000000000000(** This module extends {{!Base.Either}[Base.Either]}. *) type ('f, 's) t = ('f, 's) Base.Either.t = | First of 'f | Second of 's [@@deriving bin_io, typerep] (** @inline *) include module type of struct include Base.Either end with type ('f, 's) t := ('f, 's) t include Comparator.Derived2 with type ('a, 'b) t := ('a, 'b) t include Quickcheckable.S2 with type ('a, 'b) t := ('a, 'b) t module Stable : sig module V1 : sig type nonrec ('f, 's) t = ('f, 's) t = | First of 'f | Second of 's include Stable_module_types.S2 with type ('f, 's) t := ('f, 's) t end end core-0.15.0/core/src/ephemeron.ml000066400000000000000000000013301420273305200165530ustar00rootroot00000000000000open! Import open Std_internal module Ephemeron = Caml.Ephemeron.K1 type ('a, 'b) t = ('a Heap_block.t, 'b Heap_block.t) Ephemeron.t let create = Ephemeron.create let set_key t = function | None -> Ephemeron.unset_key t | Some v -> Ephemeron.set_key t v ;; let get_key = Ephemeron.get_key let set_data t = function | None -> Ephemeron.unset_data t | Some v -> Ephemeron.set_data t v ;; let get_data = Ephemeron.get_data let is_key_some t = Ephemeron.check_key t let is_key_none t = not (is_key_some t) let is_data_some t = Ephemeron.check_data t let is_data_none t = not (is_data_some t) let sexp_of_t sexp_of_a sexp_of_b t = [%sexp_of: a Heap_block.t option * b Heap_block.t option] (get_key t, get_data t) ;; core-0.15.0/core/src/ephemeron.mli000066400000000000000000000022461420273305200167330ustar00rootroot00000000000000(** An ephemeron is a pair of pointers, one to a "key" and one to "data". The key pointer is a weak pointer: the garbage collector doesn't follow it when determining liveness. The garbage collector follows an ephemeron's data pointer iff the key is alive. If the garbage collector nulls an ephemeron's weak pointer then it also nulls the data pointer. Ephemerons are more powerful than weak pointers because they express conjunction of liveness -- the data in an ephemeron is live iff both the key {e and} the ephemeron are live. See "Ephemerons: A New Finalization Mechanism", Barry Hayes 1997. This module is like the OCaml standard library module [Ephemerons.K1], except that it requires that the keys and data are heap blocks. *) open! Import type ('a, 'b) t [@@deriving sexp_of] val create : unit -> _ t val set_key : ('a, _) t -> 'a Heap_block.t option -> unit val get_key : ('a, _) t -> 'a Heap_block.t option val set_data : (_, 'b) t -> 'b Heap_block.t option -> unit val get_data : (_, 'b) t -> 'b Heap_block.t option val is_key_some : _ t -> bool val is_key_none : _ t -> bool val is_data_some : _ t -> bool val is_data_none : _ t -> bool core-0.15.0/core/src/error.ml000066400000000000000000000004051420273305200157240ustar00rootroot00000000000000include Base.Error include Info.Extend (Base.Error) let failwiths ?strict ~here message a sexp_of_a = raise (create ?strict ~here message a sexp_of_a) ;; let failwithp ?strict here message a sexp_of_a = raise (create ?strict ~here message a sexp_of_a) ;; core-0.15.0/core/src/error.mli000066400000000000000000000023321420273305200160760ustar00rootroot00000000000000(** This module extends {{!module:Base.Error}[Base.Error]} with [bin_io]. *) open! Import (** @inline *) include module type of struct include Base.Error end (** This include is the source of the bin_io functions. *) include Info_intf.Extension with type t := t (** @inline *) (** [Error.t] is {e not} wire-compatible with [Error.Stable.V1.t]. See info.mli for details. *) (** {[ failwiths ?strict ~here message a sexp_of_a = Error.raise (Error.create ?strict ~here s a sexp_of_a) ]} As with [Error.create], [sexp_of_a a] is lazily computed when the error is converted to a sexp. So if [a] is mutated in the time between the call to [failwiths] and the sexp conversion, those mutations will be reflected in the error message. Use [~strict:()] to force [sexp_of_a a] to be computed immediately. In this signature we write [~here:Lexing.position] rather than [~here:Source_code_position.t] to avoid a circular dependency. *) val failwiths : ?strict:unit -> here:Lexing.position -> string -> 'a -> ('a -> Base.Sexp.t) -> _ val failwithp : ?strict:unit -> Lexing.position -> string -> 'a -> ('a -> Base.Sexp.t) -> _ [@@deprecated "[since 2020-03] Use [failwiths] instead."] core-0.15.0/core/src/fdeque.ml000066400000000000000000000220171420273305200160470ustar00rootroot00000000000000(** Simple implementation of a polymorphic functional double-ended queue. *) (** Invariants: - queue.length = List.length queue.front + List.length queue.back - if queue has >= 2 elements, neither front nor back are empty *) open! Import open Std_internal exception Empty [@@deriving sexp] type 'a t = { front : 'a list ; back : 'a list ; length : int } let length t = t.length let is_empty t = t.length = 0 let invariant f t = let n_front = List.length t.front in let n_back = List.length t.back in assert (t.length = n_front + n_back); assert (t.length < 2 || (n_front <> 0 && n_back <> 0)); List.iter t.front ~f; List.iter t.back ~f ;; let make ~length ~front ~back = match front, back with | [], [] | [ _ ], [] | [], [ _ ] | _ :: _, _ :: _ -> { front; back; length } | [], _ :: _ :: _ -> let back, rev_front = List.split_n back (length / 2) in { front = List.rev rev_front; back; length } | _ :: _ :: _, [] -> let front, rev_back = List.split_n front (length / 2) in { front; back = List.rev rev_back; length } ;; let empty = { front = []; back = []; length = 0 } let enqueue_front t x = make ~length:(t.length + 1) ~front:(x :: t.front) ~back:t.back let enqueue_back t x = make ~length:(t.length + 1) ~back:(x :: t.back) ~front:t.front let[@cold] raise_front_invariant () = raise_s [%sexp "BUG: Fdeque: |front| = 0, |back| >= 2"] ;; let[@cold] raise_back_invariant () = raise_s [%sexp "BUG: Fdeque: |back| = 0, |front| >= 2"] ;; let peek_front_exn t = match t.front with | x :: _ -> x | [] -> (match t.back with | [] -> raise Empty | [ x ] -> x | _ :: _ :: _ -> raise_front_invariant ()) ;; let peek_back_exn t = match t.back with | x :: _ -> x | [] -> (match t.front with | [] -> raise Empty | [ x ] -> x | _ :: _ :: _ -> raise_back_invariant ()) ;; let drop_front_exn t = match t.front with | _ :: xs -> make ~length:(t.length - 1) ~front:xs ~back:t.back | [] -> (match t.back with | [] -> raise Empty | [ _ ] -> empty | _ :: _ :: _ -> raise_front_invariant ()) ;; let drop_back_exn t = match t.back with | _ :: xs -> make ~length:(t.length - 1) ~back:xs ~front:t.front | [] -> (match t.front with | [] -> raise Empty | [ _ ] -> empty | _ :: _ :: _ -> raise_back_invariant ()) ;; let dequeue_front_exn t = peek_front_exn t, drop_front_exn t let dequeue_back_exn t = peek_back_exn t, drop_back_exn t let optional f t = match f t with | x -> Some x | exception Empty -> None ;; let peek_front t = optional peek_front_exn t let peek_back t = optional peek_back_exn t let drop_front t = optional drop_front_exn t let drop_back t = optional drop_back_exn t let dequeue_front t = optional dequeue_front_exn t let dequeue_back t = optional dequeue_back_exn t let enqueue t side x = match side with | `front -> enqueue_front t x | `back -> enqueue_back t x ;; let peek t side = match side with | `front -> peek_front t | `back -> peek_back t ;; let peek_exn t side = match side with | `front -> peek_front_exn t | `back -> peek_back_exn t ;; let drop t side = match side with | `front -> drop_front t | `back -> drop_back t ;; let drop_exn t side = match side with | `front -> drop_front_exn t | `back -> drop_back_exn t ;; let dequeue t side = match side with | `front -> dequeue_front t | `back -> dequeue_back t ;; let dequeue_exn t side = match side with | `front -> dequeue_front_exn t | `back -> dequeue_back_exn t ;; let rev t = { t with front = t.back; back = t.front } module Arbitrary_order = struct let is_empty = is_empty let length = length let to_list t = List.rev_append t.front t.back let to_array t = Array.of_list (to_list t) let to_sequence t = Sequence.append (Sequence.of_list t.front) (Sequence.of_list t.back) let sum (type a) (module M : Container.Summable with type t = a) t ~f = let open M in List.sum (module M) t.front ~f + List.sum (module M) t.back ~f ;; let count t ~f = List.count t.front ~f + List.count t.back ~f let for_all t ~f = List.for_all t.front ~f && List.for_all t.back ~f let exists t ~f = List.exists t.front ~f || List.exists t.back ~f let mem t x ~equal = List.mem ~equal t.front x || List.mem ~equal t.back x let iter t ~f = List.iter t.front ~f; List.iter t.back ~f ;; let fold t ~init ~f = List.fold t.front ~init ~f |> fun init -> List.fold t.back ~init ~f ;; let fold_result t ~init ~f = Container.fold_result ~fold ~init ~f t let fold_until t ~init ~f = Container.fold_until ~fold ~init ~f t let find t ~f = match List.find t.front ~f with | None -> List.find t.back ~f | some -> some ;; let find_map t ~f = match List.find_map t.front ~f with | None -> List.find_map t.back ~f | some -> some ;; let max_elt t ~compare = match List.max_elt t.front ~compare, List.max_elt t.back ~compare with | None, opt | opt, None -> opt | (Some x as some_x), (Some y as some_y) -> if compare x y >= 0 then some_x else some_y ;; let min_elt t ~compare = match List.min_elt t.front ~compare, List.min_elt t.back ~compare with | None, opt | opt, None -> opt | (Some x as some_x), (Some y as some_y) -> if compare x y <= 0 then some_x else some_y ;; end module Make_container (F : sig val to_list : 'a t -> 'a list end) = struct let to_list = F.to_list let is_empty = is_empty let length = length let mem t x ~equal = List.mem ~equal (to_list t) x let iter t ~f = List.iter (to_list t) ~f let fold t ~init ~f = List.fold (to_list t) ~init ~f let exists t ~f = List.exists (to_list t) ~f let for_all t ~f = List.for_all (to_list t) ~f let count t ~f = List.count (to_list t) ~f let sum m t ~f = List.sum m (to_list t) ~f let find t ~f = List.find (to_list t) ~f let find_map t ~f = List.find_map (to_list t) ~f let to_array t = List.to_array (to_list t) let min_elt t ~compare = List.min_elt (to_list t) ~compare let max_elt t ~compare = List.max_elt (to_list t) ~compare let fold_result t ~init ~f = Container.fold_result ~fold ~init ~f t let fold_until t ~init ~f = Container.fold_until ~fold ~init ~f t end module Front_to_back = struct let of_list list = make ~length:(List.length list) ~front:list ~back:[] let to_list t = t.front @ List.rev t.back let to_sequence t = Sequence.append (Sequence.of_list t.front) (Sequence.of_list (List.rev t.back)) ;; let of_sequence sequence = let length, back = Sequence.fold sequence ~init:(0, []) ~f:(fun (length, acc) a -> length + 1, a :: acc) in make ~length ~front:[] ~back ;; include Make_container (struct let to_list = to_list end) end module Back_to_front = struct let to_list t = t.back @ List.rev t.front let of_list list = make ~length:(List.length list) ~back:list ~front:[] let to_sequence t = Sequence.append (Sequence.of_list t.back) (Sequence.of_list (List.rev t.front)) ;; let of_sequence sequence = let length, front = Sequence.fold sequence ~init:(0, []) ~f:(fun (length, acc) a -> length + 1, a :: acc) in make ~length ~front ~back:[] ;; include Make_container (struct let to_list = to_list end) end include Front_to_back let singleton x = of_list [ x ] include Monad.Make (struct type nonrec 'a t = 'a t let bind t ~f = fold t ~init:empty ~f:(fun t elt -> fold (f elt) ~init:t ~f:enqueue_back) ;; let return = singleton let map = `Custom (fun t ~f -> { front = List.map t.front ~f; back = List.map t.back ~f; length = t.length }) ;; end) let compare cmp t1 t2 = List.compare cmp (to_list t1) (to_list t2) let equal eq t1 t2 = List.equal eq (to_list t1) (to_list t2) let hash_fold_t hash_fold_a state t = fold ~f:hash_fold_a ~init:([%hash_fold: int] state (length t)) t ;; module Stable = struct module V1 = struct type nonrec 'a t = 'a t let compare = compare let sexp_of_t sexp_of_elt t = [%sexp_of: elt list] (to_list t) let t_of_sexp elt_of_sexp sexp = of_list ([%of_sexp: elt list] sexp) let t_sexp_grammar = List.t_sexp_grammar let map = map include Bin_prot.Utils.Make_iterable_binable1 (struct type nonrec 'a t = 'a t type 'a el = 'a [@@deriving bin_io] let caller_identity = Bin_prot.Shape.Uuid.of_string "83f96982-4992-11e6-919d-fbddcfdca576" ;; let module_name = Some "Core.Fdeque" let length = length let iter t ~f = List.iter (to_list t) ~f let init ~len ~next = let rec loop next acc n = if len = n then acc else ( assert (n = length acc); let x = next () in loop next (enqueue_back acc x) (n + 1)) in loop next empty 0 ;; end) end end include (Stable.V1 : module type of Stable.V1 with type 'a t := 'a t) module Private = struct let build ~front ~back = let length = List.length front + List.length back in let t = { length; front; back } in invariant ignore t; t ;; end core-0.15.0/core/src/fdeque.mli000066400000000000000000000073151420273305200162240ustar00rootroot00000000000000(** A simple polymorphic functional double-ended queue. Use this if you need a queue-like data structure that provides enqueue and dequeue accessors on both ends. For strictly first-in, first-out access, see [Fqueue]. Amortized running times assume that [enqueue]/[dequeue] are used sequentially, threading the changing deque through the calls. *) open! Import type 'a t [@@deriving bin_io, compare, equal, hash, sexp] (** [Container] operations traverse deque elements front-to-back, like [Front_to_back] below. If you need faster traversal and don't care about the order, use [Arbitrary_order] below. [is_empty] and [length] have worst-case complexity O(1). *) include Container.S1 with type 'a t := 'a t include Invariant.S1 with type 'a t := 'a t include Monad.S with type 'a t := 'a t (** Traverse deque elements in arbitrary order. *) module Arbitrary_order : sig include Container.S1 with type 'a t := 'a t (** This does not match the ordering of [to_list] *) val to_sequence : 'a t -> 'a Sequence.t end (** Traverse deque elements front-to-back. Incurs up to O(n) additional time and space cost over [Arbitrary_order]. *) module Front_to_back : sig val of_list : 'a list -> 'a t include Container.S1 with type 'a t := 'a t val to_sequence : 'a t -> 'a Sequence.t val of_sequence : 'a Sequence.t -> 'a t end (** Traverse deque elements back-to-front. Incurs up to O(n) additional time and space cost over [Arbitrary_order]. *) module Back_to_front : sig val of_list : 'a list -> 'a t include Container.S1 with type 'a t := 'a t val to_sequence : 'a t -> 'a Sequence.t val of_sequence : 'a Sequence.t -> 'a t end (** The empty deque. *) val empty : _ t (** A one-element deque. *) val singleton : 'a -> 'a t (** [of_list] returns a deque with elements in the same front-to-back order as the list. *) val of_list : 'a list -> 'a t (** [rev t] returns [t], reversed. Complexity: worst-case O(1). *) val rev : 'a t -> 'a t (** [enqueue t side x] produces [t] updated with [x] added to its [side]. Complexity: worst-case O(1). *) val enqueue : 'a t -> [ `back | `front ] -> 'a -> 'a t val enqueue_front : 'a t -> 'a -> 'a t val enqueue_back : 'a t -> 'a -> 'a t (** [peek t side] produces [Some] of the element at the [side] of [t], or [None] if [t] is empty. Complexity: worst-case O(1). *) val peek : 'a t -> [ `back | `front ] -> 'a option val peek_exn : 'a t -> [ `back | `front ] -> 'a val peek_front : 'a t -> 'a option val peek_front_exn : 'a t -> 'a val peek_back : 'a t -> 'a option val peek_back_exn : 'a t -> 'a (** [drop t side] produces [Some] of [t] with the element at its [side] removed, or [None] if [t] is empty. Complexity: amortized O(1), worst-case O(length t). *) val drop : 'a t -> [ `back | `front ] -> 'a t option val drop_exn : 'a t -> [ `back | `front ] -> 'a t val drop_front : 'a t -> 'a t option val drop_front_exn : 'a t -> 'a t val drop_back : 'a t -> 'a t option val drop_back_exn : 'a t -> 'a t (** [dequeue t side] produces [Option.both (peek t side) (drop t side)]. Complexity: amortized O(1), worst-case O(length t). *) val dequeue : 'a t -> [ `back | `front ] -> ('a * 'a t) option val dequeue_exn : 'a t -> [ `back | `front ] -> 'a * 'a t val dequeue_front : 'a t -> ('a * 'a t) option val dequeue_front_exn : 'a t -> 'a * 'a t val dequeue_back : 'a t -> ('a * 'a t) option val dequeue_back_exn : 'a t -> 'a * 'a t module Stable : sig module V1 : Stable_module_types.S1 with type 'a t = 'a t end (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig val build : front:'a list -> back:'a list -> 'a t end core-0.15.0/core/src/filename.ml000066400000000000000000000104301420273305200163520ustar00rootroot00000000000000module Stable = struct module V1 = struct include ( String : sig type t = string [@@deriving bin_io, compare, hash, sexp] include Comparable.Stable.V1.S with type comparable := t with type comparator_witness = String.Stable.V1.comparator_witness val comparator : (t, comparator_witness) Comparator.t include Hashable.Stable.V1.S with type key := t end) end end open! Import open! Std_internal include ( String : sig type t = string [@@deriving bin_io, compare, sexp] include Comparable.S with type t := t with type comparator_witness = String.comparator_witness val comparator : (t, comparator_witness) Comparator.t include Hashable.S with type t := t end) include struct open Caml.Filename let check_suffix = check_suffix let chop_extension = chop_extension let chop_suffix = chop_suffix let chop_suffix_opt = chop_suffix_opt let current_dir_name = current_dir_name let is_implicit = is_implicit let is_relative = is_relative let parent_dir_name = parent_dir_name let dir_sep = dir_sep let quote = quote let temp_dir_name = get_temp_dir_name () let dirname = dirname let basename = basename end let is_absolute p = not (is_relative p) let concat p1 p2 = if String.is_empty p1 then failwithf "Filename.concat called with an empty string as its first argument (second \ argument: %s)" p2 (); let rec collapse_trailing s = match String.rsplit2 s ~on:'/' with | Some ("", ("." | "")) -> "" | Some (s, ("." | "")) -> collapse_trailing s | None | Some _ -> s in let rec collapse_leading s = match String.lsplit2 s ~on:'/' with | Some (("." | ""), s) -> collapse_leading s | Some _ | None -> s in collapse_trailing p1 ^ "/" ^ collapse_leading p2 ;; let to_absolute_exn p ~relative_to = if is_relative relative_to then failwithf "Filename.to_absolute_exn called with a [relative_to] that is a relative path: %s" relative_to () else if is_absolute p then p else concat relative_to p ;; let split s = dirname s, basename s (* [max_pathname_component_size] comes from getconf _POSIX_NAME_MAX / *) let max_pathname_component_size = 255 let is_posix_pathname_component s = let module S = String in s <> "." && s <> ".." && Int.(0 < S.length s) && Int.(S.length s <= max_pathname_component_size) && (not (S.contains s '/')) && not (S.contains s '\000') ;; let root = "/" let split_extension fn = let dir, fn = match String.rsplit2 ~on:'/' fn with | None -> None, fn | Some (path, fn) -> Some path, fn in let fn, ext = match String.rsplit2 ~on:'.' fn with | None -> fn, None | Some (base_fn, ext) -> base_fn, Some ext in let fn = match dir with | None -> fn | Some dir -> dir ^ "/" ^ fn in fn, ext ;; let parts filename = let rec loop acc filename = match split filename with | ("." as base), "." -> base :: acc | ("/" as base), "/" -> base :: acc | rest, dir -> loop (dir :: acc) rest in loop [] filename ;; let of_parts = function | [] -> failwith "Filename.of_parts: empty parts list" | root :: rest -> List.fold rest ~init:root ~f:Caml.Filename.concat ;; let rec skip_common_prefix l1 l2 = match l1, l2 with | h1 :: t1, h2 :: t2 when String.equal h1 h2 -> skip_common_prefix t1 t2 | _ -> l1, l2 ;; let of_absolute_exn a ~relative_to:b = if is_relative a then raise_s [%message "Filename.of_absolute_exn: first argument must be an absolute path" ~first_arg:(a : string)]; if is_relative b then raise_s [%message "Filename.of_absolute_exn: [~relative_to] must be an absolute path" ~relative_to:(b : string)]; let a_parts = parts a in let b_parts = parts b in let a_suffix, b_suffix = skip_common_prefix a_parts b_parts in let go_up = List.map ~f:(fun _ -> parent_dir_name) b_suffix in match go_up @ a_suffix with | [] -> current_dir_name | relpath -> of_parts relpath ;; let arg_type = `Use_Filename_unix let create_arg_type = `Use_Filename_unix let open_temp_file = `Use_Filename_unix let open_temp_file_fd = `Use_Filename_unix let realpath = `Use_Filename_unix let temp_dir = `Use_Filename_unix let temp_file = `Use_Filename_unix core-0.15.0/core/src/filename.mli000066400000000000000000000147621420273305200165370ustar00rootroot00000000000000open! Import type t = string [@@deriving bin_io, compare, hash, sexp] include Comparable.S with type t := t with type comparator_witness = String.comparator_witness include Hashable.S with type t := t (** The path of the root.*) val root : string (** {2 Pathname resolution} *) (** [is_posix_pathname_component f] @return true if [f] is a valid path component on a POSIX compliant OS Note that this checks a path component, and not a full path. http://www.opengroup.org/onlinepubs/000095399/basedefs/xbd_chap03.html#tag_03_169 *) val is_posix_pathname_component : string -> bool (** The name of the 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. *) val temp_dir_name : string (** The conventional name for the current directory (e.g. [.] in Unix). *) val current_dir_name : string (** The conventional name for the parent of the current directory (e.g. [..] in Unix). *) val parent_dir_name : string (** The directory separator (e.g. [/] in Unix). *) val dir_sep : string (** [concat p1 p2] returns a path equivalent to [p1 ^ "/" ^ p2]. In the resulting path p1 (resp. p2) has all its trailing (resp. leading) "." and "/" removed. eg: concat "a/." ".//b" => "a/b" concat "." "b" => "./b" concat "a" "." => "a/." concat "a" "/b" => "a/b" @throws Failure if [p1] is empty. *) val concat : string -> string -> string (** 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_relative : string -> bool val is_absolute : 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 is_implicit : string -> bool (** [check_suffix name suff] returns [true] if the filename [name] ends with the suffix [suff]. *) val check_suffix : string -> string -> bool (** [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.*) val chop_suffix : string -> string -> string (** [chop_suffix_opt ~suffix filename] removes the suffix from the [filename] if possible, or returns [None] if the filename does not end with the suffix. *) val chop_suffix_opt : suffix:string -> string -> string option (** Return the given file name without its extension. The extension is the shortest suffix starting with a period and not including a directory separator, [.xyz] for instance. Raise [Invalid_argument] if the given name does not contain an extension. *) val chop_extension : string -> string (** [split_extension fn] return the portion of the filename before the extension and the (optional) extension. Example: split_extension "/foo/my_file" = ("/foo/my_file", None) split_extension "/foo/my_file.txt" = ("/foo/my_file", Some "txt") split_extension "/home/c.falls/my_file" = ("/home/c.falls/my_file", None) *) val split_extension : string -> string * string option (** Respects the posix semantic. Split a file name into directory name / base file name. [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}. The result is not specified if the argument is not a valid file name (for example, under Unix if there is a NUL character in the string). *) val basename : string -> string (** See {!Filename.basename}. *) val dirname : string -> string (** Returns the absolute path by prepending [relative_to] if the path is not already absolute. Using the result of [Core_unix.getcwd] as [relative_to] is often a reasonable choice. Note that [to_absolute_exn] may return a non-canonical path (e.g. /foo/bar/../baz). Raises if [relative_to] is a relative path. *) val to_absolute_exn : string -> relative_to:string -> string (** Converts an absolute path to a relative one. Raises if either argument is a relative path. *) val of_absolute_exn : string -> relative_to:string -> string (** [split filename] returns (dirname filename, basename filename) *) val split : string -> string * string (** [parts filename] returns a list of path components in order. For instance: /tmp/foo/bar/baz -> ["/"; "tmp"; "foo"; "bar"; "baz"]. The first component is always either "." for relative paths or "/" for absolute ones. *) val parts : string -> string list (** [of_parts parts] joins a list of path components into a path. It does roughly the opposite of [parts], but they fail to be precisely mutually inverse because of ambiguities like multiple consecutive slashes and . components. Raises an error if given an empty list. *) val of_parts : string list -> 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. See [Sys.quote] for an alternative implementation that is more human readable but less portable. *) val quote : string -> string val arg_type : [ `Use_Filename_unix ] [@@deprecated "[since 2021-04] Use [Filename_unix]"] val create_arg_type : [ `Use_Filename_unix ] [@@deprecated "[since 2021-04] Use [Filename_unix]"] val open_temp_file : [ `Use_Filename_unix ] [@@deprecated "[since 2021-04] Use [Filename_unix]"] val open_temp_file_fd : [ `Use_Filename_unix ] [@@deprecated "[since 2021-04] Use [Filename_unix]"] val realpath : [ `Use_Filename_unix ] [@@deprecated "[since 2021-04] Use [Filename_unix]"] val temp_dir : [ `Use_Filename_unix ] [@@deprecated "[since 2021-04] Use [Filename_unix]"] val temp_file : [ `Use_Filename_unix ] [@@deprecated "[since 2021-04] Use [Filename_unix]"] module Stable : sig module V1 : sig type nonrec t = t include Stable_comparable.V1 with type t := t with type comparator_witness = comparator_witness include Hashable.Stable.V1.S with type key := t end end core-0.15.0/core/src/float.ml000066400000000000000000000110511420273305200156770ustar00rootroot00000000000000external format_float : string -> float -> string = "caml_format_float" (* Stolen from [pervasives.ml]. Adds a "." at the end if needed. It is in [pervasives.mli], but it also says not to use it directly, so we copy and paste the code. It makes the assumption on the string passed in argument that it was returned by [format_float] *) let valid_float_lexem s = let l = String.length s in let rec loop i = if i >= l then s ^ "." else ( match s.[i] with | '0' .. '9' | '-' -> loop (i + 1) | _ -> s) in loop 0 ;; open! Import module T = struct include Base.Float type t = float [@@deriving bin_io, typerep] end include T include Hashable.Make_binable (T) include Comparable.Map_and_set_binable_using_comparator (T) include Comparable.Validate_with_zero (T) module Replace_polymorphic_compare : Comparisons.S with type t := t = T let validate_ordinary t = Validate.of_error_opt (let module C = Class in match classify t with | C.Normal | C.Subnormal | C.Zero -> None | C.Infinite -> Some "value is infinite" | C.Nan -> Some "value is NaN") ;; module V = struct module ZZ = Comparable.Validate (T) let validate_bound ~min ~max t = Validate.first_failure (validate_ordinary t) (ZZ.validate_bound t ~min ~max) ;; let validate_lbound ~min t = Validate.first_failure (validate_ordinary t) (ZZ.validate_lbound t ~min) ;; let validate_ubound ~max t = Validate.first_failure (validate_ordinary t) (ZZ.validate_ubound t ~max) ;; end include V module Robust_compare = struct module type S = sig (* intended to be a tolerance on human-entered floats *) val robust_comparison_tolerance : float include Robustly_comparable.S with type t := float end module Make (T : sig val robust_comparison_tolerance : float end) : S = struct (* We have test in the tree that rely on these functions not allocating, even without X_LIBRARY_INLING. The only way to ensure that these don't create temporary boxed floats without X_LIBRARY_INLING is for this code to see the float operations as externals, as defined in [Pervasives]. That's why we use [Poly] and float arithmetic from [Caml]. *) open Poly let robust_comparison_tolerance = T.robust_comparison_tolerance let ( >=. ) x y = x >= Caml.( -. ) y robust_comparison_tolerance let ( <=. ) x y = y >=. x let ( =. ) x y = x >=. y && y >=. x let ( >. ) x y = x > Caml.( +. ) y robust_comparison_tolerance let ( <. ) x y = y >. x let ( <>. ) x y = not (x =. y) let robustly_compare x y = let d = Caml.( -. ) x y in if d < Caml.( ~-. ) robust_comparison_tolerance then -1 else if d > robust_comparison_tolerance then 1 else 0 ;; end end module Robustly_comparable = Robust_compare.Make (struct let robust_comparison_tolerance = 1E-7 end) include Robustly_comparable module O = struct include Base.Float.O include Robustly_comparable end module Terse = struct type nonrec t = t [@@deriving bin_io] include ( Base.Float.Terse : module type of struct include Base.Float.Terse end with type t := t) end let robust_sign t : Sign.t = if t >. 0. then Pos else if t <. 0. then Neg else Zero (* There are two issues: - Float.sign used to use robust comparison, and users of [Core] might have come to depend on this. - Robustness aside, what we get from Comparable.With_zero would map nan to Neg. *) let sign = robust_sign (* Standard 12 significant digits, exponential notation used as necessary, guaranteed to be a valid OCaml float lexem, not to look like an int. *) let to_string_12 x = valid_float_lexem (format_float "%.12g" x) let quickcheck_generator = Base_quickcheck.Generator.float let quickcheck_observer = Base_quickcheck.Observer.float let quickcheck_shrinker = Base_quickcheck.Shrinker.float let gen_uniform_excl = Base_quickcheck.Generator.float_uniform_exclusive let gen_incl = Base_quickcheck.Generator.float_inclusive let gen_without_nan = Base_quickcheck.Generator.float_without_nan let gen_finite = Base_quickcheck.Generator.float_finite let gen_positive = Base_quickcheck.Generator.float_strictly_positive let gen_negative = Base_quickcheck.Generator.float_strictly_negative let gen_zero = Base_quickcheck.Generator.float_of_class Zero let gen_nan = Base_quickcheck.Generator.float_of_class Nan let gen_subnormal = Base_quickcheck.Generator.float_of_class Subnormal let gen_normal = Base_quickcheck.Generator.float_of_class Normal let gen_infinite = Base_quickcheck.Generator.float_of_class Infinite core-0.15.0/core/src/float.mli000066400000000000000000000110111420273305200160440ustar00rootroot00000000000000(** Floating-point numbers. *) open! Import (** @inline *) include module type of struct include Base.Float end type t = float [@@deriving typerep] module Robust_compare : sig module type S = sig (** intended to be a tolerance on human-entered floats *) val robust_comparison_tolerance : float include Robustly_comparable.S with type t := float end module Make (T : sig val robust_comparison_tolerance : float end) : S end (** So-called "robust" comparisons, which include a small tolerance, so that float that differ by a small amount are considered equal. Note that the results of robust comparisons on [nan] should be considered undefined. *) include Robust_compare.S module O : sig include module type of struct include Base.Float.O end include Robustly_comparable.S with type t := t end module Robustly_comparable : Robust_compare.S module Terse : sig type nonrec t = t [@@deriving bin_io] include module type of struct include Base.Float.Terse end with type t := t end include Identifiable.S with type t := t and type comparator_witness := Base.Float.comparator_witness include Comparable.Validate_with_zero with type t := t (** [validate_ordinary] fails if class is [Nan] or [Infinite]. *) val validate_ordinary : t Validate.check (** [to_string_12 x] builds a string representing [x] using up to 12 significant digits. It loses precision. You can use ["%{Float#12}"] in formats, but consider ["%.12g"], ["%{Float#hum}"], or ["%{Float}"] as alternatives. *) val to_string_12 : t -> string (** [to_string x] builds a string [s] representing the float [x] that guarantees the round trip, i.e., [Float.equal x (Float.of_string s)]. It usually yields as few significant digits as possible. That is, it won't print [3.14] as [3.1400000000000001243]. The only exception is that occasionally it will output 17 significant digits when the number can be represented with just 16 (but not 15 or fewer) of them. *) val to_string : t -> string include Quickcheckable.S with type t := t (*_ Caution: If we remove this sig item, [sign] will still be present from [Comparable.With_zero]. *) val sign : t -> Sign.t [@@deprecated "[since 2016-01] Replace [sign] with [robust_sign] or [sign_exn]"] (** (Formerly [sign]) Uses robust comparison (so sufficiently small numbers are mapped to [Zero]). Also maps NaN to [Zero]. Using this function is weakly discouraged. *) val robust_sign : t -> Sign.t (** [gen_uniform_excl lo hi] creates a Quickcheck generator producing finite [t] values between [lo] and [hi], exclusive. The generator approximates a uniform distribution over the interval (lo, hi). Raises an exception if [lo] is not finite, [hi] is not finite, or the requested range is empty. The implementation chooses values uniformly distributed between 0 (inclusive) and 1 (exclusive) up to 52 bits of precision, then scales that interval to the requested range. Due to rounding errors and non-uniform floating point precision, the resulting distribution may not be precisely uniform and may not include all values between [lo] and [hi]. *) val gen_uniform_excl : t -> t -> t Quickcheck.Generator.t (** [gen_incl lo hi] creates a Quickcheck generator that produces values between [lo] and [hi], inclusive, approximately uniformly distributed, with extra weight given to generating the endpoints [lo] and [hi]. Raises an exception if [lo] is not finite, [hi] is not finite, or the requested range is empty. *) val gen_incl : t -> t -> t Quickcheck.Generator.t (** [gen_finite] produces all finite [t] values, excluding infinities and all NaN values. *) val gen_finite : t Quickcheck.Generator.t (** [gen_positive] produces all (strictly) positive finite [t] values. *) val gen_positive : t Quickcheck.Generator.t (** [gen_negative] produces all (strictly) negative finite [t] values. *) val gen_negative : t Quickcheck.Generator.t (** [gen_without_nan] produces all finite and infinite [t] values, excluding all NaN values. *) val gen_without_nan : t Quickcheck.Generator.t (** [gen_infinite] produces both infinite values *) val gen_infinite : t Quickcheck.Generator.t (** [gen_nan] produces all NaN values. *) val gen_nan : t Quickcheck.Generator.t (** [gen_normal] produces all normal values *) val gen_normal : t Quickcheck.Generator.t (** [gen_subnormal] produces all subnormal values *) val gen_subnormal : t Quickcheck.Generator.t (** [gen_zero] produces both zero values *) val gen_zero : t Quickcheck.Generator.t core-0.15.0/core/src/float_with_finite_only_serialization.ml000066400000000000000000000021061420273305200242670ustar00rootroot00000000000000open Ppx_compare_lib.Builtin module Stable = struct open Stable_internal module Binable = Binable.Stable module V1 = struct exception Nan_or_inf [@@deriving sexp] type t = float [@@deriving compare, hash, equal] let verify t = match Caml.classify_float t with | FP_normal | FP_subnormal | FP_zero -> () | FP_infinite | FP_nan -> raise Nan_or_inf ;; include Binable.Of_binable.V1 [@alert "-legacy"] (Float) (struct type nonrec t = t let of_binable t = verify t; t ;; let to_binable t = verify t; t ;; end) let sexp_of_t = Float.sexp_of_t let t_of_sexp = function | Sexp.Atom _ as sexp -> let t = Float.t_of_sexp sexp in (try verify t with | e -> Import.of_sexp_error (Import.Exn.to_string e) sexp); t | s -> Import.of_sexp_error "Decimal.t_of_sexp: Expected Atom, found List" s ;; let t_sexp_grammar = Float.t_sexp_grammar end end include Stable.V1 core-0.15.0/core/src/float_with_finite_only_serialization.mli000066400000000000000000000011711420273305200244410ustar00rootroot00000000000000(** An alias to the [Float.t] type that causes the sexp and bin-io serializers to fail when provided with [nan] or [infinity]. Note that while it makes sense to use this on the definition of a type in the ml file, where it will influence the construction of the sexp and bin-io serializers, it does {e not} make sense to use this in an mli, since it makes no guarantee at that level. *) open! Import type t = float [@@deriving bin_io, sexp, sexp_grammar, compare, hash, equal] module Stable : sig module V1 : sig type nonrec t = t [@@deriving bin_io, sexp, sexp_grammar, compare, hash, equal] end end core-0.15.0/core/src/fn.ml000066400000000000000000000001411420273305200151730ustar00rootroot00000000000000(** Extends {{!Base.Fn}[Base.Fn]}. *) include Base.Fn (** @open *) include Deprecate_pipe_bang core-0.15.0/core/src/fn.mli000066400000000000000000000002031420273305200153430ustar00rootroot00000000000000open! Import include module type of struct include Base.Fn end include module type of struct include Deprecate_pipe_bang end core-0.15.0/core/src/fqueue.ml000066400000000000000000000005751420273305200160750ustar00rootroot00000000000000open! Import include Fdeque let enqueue = enqueue_back let peek_exn = peek_front_exn let peek = peek_front let dequeue_exn = dequeue_front_exn let dequeue = dequeue_front let drop_exn = drop_front_exn let to_sequence = Front_to_back.to_sequence let of_sequence = Front_to_back.of_sequence (* Deprecated aliases *) let top = peek let top_exn = peek_exn let discard_exn = drop_exn core-0.15.0/core/src/fqueue.mli000066400000000000000000000052511420273305200162420ustar00rootroot00000000000000(** A simple polymorphic functional queue. Use this data structure for strictly first-in, first-out access to a sequence of values. For a similar data structure with enqueue and dequeue accessors on both ends of a sequence, see {{!Core.Fdeque}[Core.Fdeque]}. Amortized running times assume that [enqueue]/[dequeue] are used sequentially, threading the changing Fqueue through the calls. *) open! Import type 'a t [@@deriving bin_io, compare, equal, hash, sexp] include Container.S1 with type 'a t := 'a t include Invariant.S1 with type 'a t := 'a t include Monad.S with type 'a t := 'a t (** The empty queue. *) val empty : 'a t (** [enqueue t x] returns a queue with adds [x] to the end of [t]. Complexity: O(1). *) val enqueue : 'a t -> 'a -> 'a t (** Returns the front (least recently enqueued) element. Raises [Empty] if no element is found. Complexity: O(1). *) val peek_exn : 'a t -> 'a val top_exn : 'a t -> 'a [@@deprecated "[since 2019-11] Use [peek_exn] instead."] (** Like [peek_exn], but returns its result optionally, without exception. Complexity: O(1). *) val peek : 'a t -> 'a option val top : 'a t -> 'a option [@@deprecated "[since 2019-11] Use [peek] instead."] (** [dequeue_exn t] removes and returns the front of [t], raising [Empty] if [t] is empty. Complexity: amortized O(1). *) val dequeue_exn : 'a t -> 'a * 'a t (** Like [dequeue_exn], but returns result optionally, without exception. Complexity: amortized O(1). *) val dequeue : 'a t -> ('a * 'a t) option (** Returns version of queue with front element removed. Complexity: amortized O(1). *) val drop_exn : 'a t -> 'a t val discard_exn : 'a t -> 'a t [@@deprecated "[since 2019-11] Use [drop_exn] instead."] (** [to_list t] returns a list of the elements in [t] in order from least-recently-added (at the head) to most-recently-added (at the tail). Complexity: O(n). *) val to_list : 'a t -> 'a list (** [of_list] is the inverse of [to_list]. Complexity: O(n). *) val of_list : 'a list -> 'a t (** [to_sequence] returns a [Sequence.t] of the elements in [t] in order from from least-recently-added (at the head) to most-recently-added (at the tail). Complexity (if the sequence is fully traversed): O(n). {[to_list t = Sequence.to_list (to_sequence t)]} *) val to_sequence : 'a t -> 'a Sequence.t (** [of_sequence] is the inverse of [to_sequence]. Complexity (if the sequence is fully traversed): O(n). *) val of_sequence : 'a Sequence.t -> 'a t (** Complexity: O(1). *) val length : 'a t -> int (** Complexity: O(1). *) val is_empty : 'a t -> bool val singleton : 'a -> 'a t module Stable : sig module V1 : Stable_module_types.S1 with type 'a t = 'a t end core-0.15.0/core/src/gc.ml000066400000000000000000000425441420273305200151760ustar00rootroot00000000000000open! Import module Stable = struct module Allocation_policy = struct module V1 = struct type t = | Next_fit | First_fit | Best_fit [@@deriving bin_io, compare, equal, hash, sexp] end end module Stat = struct [%%if ocaml_version < (4, 12, 0)] module V1 = struct type t = Caml.Gc.stat = { minor_words : float ; promoted_words : float ; major_words : float ; minor_collections : int ; major_collections : int ; heap_words : int ; heap_chunks : int ; live_words : int ; live_blocks : int ; free_words : int ; free_blocks : int ; largest_free : int ; fragments : int ; compactions : int ; top_heap_words : int ; stack_size : int } [@@deriving bin_io, compare, equal, hash, sexp] end module V2 = struct type t = { minor_words : float ; promoted_words : float ; major_words : float ; minor_collections : int ; major_collections : int ; heap_words : int ; heap_chunks : int ; live_words : int ; live_blocks : int ; free_words : int ; free_blocks : int ; largest_free : int ; fragments : int ; compactions : int ; top_heap_words : int ; stack_size : int ; forced_major_collections : int } [@@deriving bin_io, compare, equal, hash, sexp] end [%%else] module V1 = struct type t = { minor_words : float ; promoted_words : float ; major_words : float ; minor_collections : int ; major_collections : int ; heap_words : int ; heap_chunks : int ; live_words : int ; live_blocks : int ; free_words : int ; free_blocks : int ; largest_free : int ; fragments : int ; compactions : int ; top_heap_words : int ; stack_size : int } [@@deriving bin_io, compare, equal, hash, sexp] end module V2 = struct type t = Caml.Gc.stat = { minor_words : float ; promoted_words : float ; major_words : float ; minor_collections : int ; major_collections : int ; heap_words : int ; heap_chunks : int ; live_words : int ; live_blocks : int ; free_words : int ; free_blocks : int ; largest_free : int ; fragments : int ; compactions : int ; top_heap_words : int ; stack_size : int ; forced_major_collections : int } [@@deriving bin_io, compare, equal, hash, sexp] end [%%endif] end module Control = struct module V1 = struct [@@@ocaml.warning "-3"] type t = Caml.Gc.control = { mutable minor_heap_size : int ; mutable major_heap_increment : int ; mutable space_overhead : int ; mutable verbose : int ; mutable max_overhead : int ; mutable stack_limit : int ; mutable allocation_policy : int ; window_size : int ; custom_major_ratio : int ; custom_minor_ratio : int ; custom_minor_max_size : int } [@@deriving bin_io, compare, equal, sexp] end end end include Caml.Gc module Stat = struct module T = struct [%%if ocaml_version < (4, 12, 0)] type t = Caml.Gc.stat = { minor_words : float ; promoted_words : float ; major_words : float ; minor_collections : int ; major_collections : int ; heap_words : int ; heap_chunks : int ; live_words : int ; live_blocks : int ; free_words : int ; free_blocks : int ; largest_free : int ; fragments : int ; compactions : int ; top_heap_words : int ; stack_size : int } [@@deriving compare, hash, bin_io, sexp, fields] [%%else] type t = Caml.Gc.stat = { minor_words : float ; promoted_words : float ; major_words : float ; minor_collections : int ; major_collections : int ; heap_words : int ; heap_chunks : int ; live_words : int ; live_blocks : int ; free_words : int ; free_blocks : int ; largest_free : int ; fragments : int ; compactions : int ; top_heap_words : int ; stack_size : int ; forced_major_collections : int } [@@deriving compare, hash, sexp_of, fields] [%%endif] end include T include Comparable.Make_plain (T) [%%if ocaml_version < (4, 12, 0)] let diff after before = { minor_words = after.minor_words -. before.minor_words ; promoted_words = after.promoted_words -. before.promoted_words ; major_words = after.major_words -. before.major_words ; minor_collections = after.minor_collections - before.minor_collections ; major_collections = after.major_collections - before.major_collections ; heap_words = after.heap_words - before.heap_words ; heap_chunks = after.heap_chunks - before.heap_chunks ; live_words = after.live_words - before.live_words ; live_blocks = after.live_blocks - before.live_blocks ; free_words = after.free_words - before.free_words ; free_blocks = after.free_blocks - before.free_blocks ; largest_free = after.largest_free - before.largest_free ; fragments = after.fragments - before.fragments ; compactions = after.compactions - before.compactions ; top_heap_words = after.top_heap_words - before.top_heap_words ; stack_size = after.stack_size - before.stack_size } ;; [%%else] let diff after before = { minor_words = after.minor_words -. before.minor_words ; promoted_words = after.promoted_words -. before.promoted_words ; major_words = after.major_words -. before.major_words ; minor_collections = after.minor_collections - before.minor_collections ; major_collections = after.major_collections - before.major_collections ; heap_words = after.heap_words - before.heap_words ; heap_chunks = after.heap_chunks - before.heap_chunks ; live_words = after.live_words - before.live_words ; live_blocks = after.live_blocks - before.live_blocks ; free_words = after.free_words - before.free_words ; free_blocks = after.free_blocks - before.free_blocks ; largest_free = after.largest_free - before.largest_free ; fragments = after.fragments - before.fragments ; compactions = after.compactions - before.compactions ; top_heap_words = after.top_heap_words - before.top_heap_words ; stack_size = after.stack_size - before.stack_size ; forced_major_collections = after.forced_major_collections - before.forced_major_collections } ;; [%%endif] end module Control = struct module T = struct [@@@ocaml.warning "-3"] type t = Caml.Gc.control = { mutable minor_heap_size : int ; mutable major_heap_increment : int ; mutable space_overhead : int ; mutable verbose : int ; mutable max_overhead : int ; mutable stack_limit : int ; mutable allocation_policy : int ; window_size : int ; custom_major_ratio : int ; custom_minor_ratio : int ; custom_minor_max_size : int } [@@deriving compare, sexp_of, fields] end include T include Comparable.Make_plain (T) end module Allocation_policy = struct type t = Stable.Allocation_policy.V1.t = | Next_fit | First_fit | Best_fit [@@deriving compare, equal, hash, sexp_of] let to_int = function | Next_fit -> 0 | First_fit -> 1 | Best_fit -> 2 ;; end let tune ?logger ?minor_heap_size ?major_heap_increment ?space_overhead ?verbose ?max_overhead ?stack_limit ?allocation_policy ?window_size ?custom_major_ratio ?custom_minor_ratio ?custom_minor_max_size () = let old_control_params = get () in let f opt to_string field = let old_value = Field.get field old_control_params in match opt with | None -> old_value | Some new_value -> Option.iter logger ~f:(fun f -> Printf.ksprintf f "Gc.Control.%s: %s -> %s" (Field.name field) (to_string old_value) (to_string new_value)); new_value in let allocation_policy = Option.map allocation_policy ~f:Allocation_policy.to_int in let new_control_params = Control.Fields.map ~minor_heap_size:(f minor_heap_size string_of_int) ~major_heap_increment:(f major_heap_increment string_of_int) ~space_overhead:(f space_overhead string_of_int) ~verbose:(f verbose string_of_int) ~max_overhead:(f max_overhead string_of_int) ~stack_limit:(f stack_limit string_of_int) ~allocation_policy:(f allocation_policy string_of_int) ~window_size:(f window_size string_of_int) ~custom_major_ratio:(f custom_major_ratio string_of_int) ~custom_minor_ratio:(f custom_minor_ratio string_of_int) ~custom_minor_max_size:(f custom_minor_max_size string_of_int) in set new_control_params ;; let disable_compaction ?logger ~allocation_policy () = let allocation_policy = match allocation_policy with | `Don't_change -> None | `Set_to policy -> Some policy in (* The value 1_000_000, according to http://caml.inria.fr/pub/docs/manual-ocaml-4.02/libref/Gc.html will disable compactions. *) tune ?logger ?allocation_policy ~max_overhead:1_000_000 () ;; external minor_words : unit -> int = "core_gc_minor_words" external major_words : unit -> int = "core_gc_major_words" [@@noalloc] external promoted_words : unit -> int = "core_gc_promoted_words" [@@noalloc] external minor_collections : unit -> int = "core_gc_minor_collections" [@@noalloc] external major_collections : unit -> int = "core_gc_major_collections" [@@noalloc] external heap_words : unit -> int = "core_gc_heap_words" [@@noalloc] external heap_chunks : unit -> int = "core_gc_heap_chunks" [@@noalloc] external compactions : unit -> int = "core_gc_compactions" [@@noalloc] external top_heap_words : unit -> int = "core_gc_top_heap_words" [@@noalloc] external major_plus_minor_words : unit -> int = "core_gc_major_plus_minor_words" external allocated_words : unit -> int = "core_gc_allocated_words" external run_memprof_callbacks : unit -> unit = "core_gc_run_memprof_callbacks" let zero = Sys.opaque_identity (int_of_string "0") (* The compiler won't optimize int_of_string away so it won't perform constant folding below. *) let rec keep_alive o = if zero <> 0 then keep_alive (Sys.opaque_identity o) module For_testing = struct let prepare_heap_to_count_minor_allocation () = (* We call [minor] to empty the minor heap, so that our allocation is unlikely to trigger a minor gc. *) minor (); (* We allocate two words in case the [Gc.minor] finishes a major gc cycle, in which case it requests a minor gc to occur at the next minor allocation. We don't want the subsequent minor allocation to trigger a minor GC, because there is a bug (https://github.com/ocaml/ocaml/issues/7798) in the OCaml runtime that double counts [Gc.minor_words] in that case. *) ignore (Sys.opaque_identity (ref (Sys.opaque_identity 1)) : int ref) ;; (* We disable inlining for this function so the GC stats and the call to [f] are never rearranged. *) let[@cold] measure_internal ~on_result f = let minor_words_before = minor_words () in let major_words_before = major_words () in (* We wrap [f ()] with [Sys.opaque_identity] to prevent the return value from being optimized away. *) let x = Sys.opaque_identity (f ()) in let minor_words_after = minor_words () in let major_words_after = major_words () in let major_words_allocated = major_words_after - major_words_before in let minor_words_allocated = minor_words_after - minor_words_before in on_result ~major_words_allocated ~minor_words_allocated x ;; let is_zero_alloc (type a) (f : unit -> a) = (* Instead of using [Allocation_report.measure], and matching on the result, we use this construction, in order to have [is_zero_alloc] not allocate itself. This enables [is_zero_alloc] to be used in a nested way. This also means we cannot call [prepare_heap_to_count_minor_allocation]. This is okay, since we do not need a precise count, we only need to check if the count is zero or not. *) measure_internal f ~on_result:(fun ~major_words_allocated ~minor_words_allocated value -> ignore (Sys.opaque_identity value : a); major_words_allocated == 0 && minor_words_allocated == 0) ;; module Allocation_report = struct type t = { major_words_allocated : int ; minor_words_allocated : int } [@@deriving sexp_of] let create ~major_words_allocated ~minor_words_allocated = { major_words_allocated; minor_words_allocated } ;; end let measure_allocation f = prepare_heap_to_count_minor_allocation (); measure_internal f ~on_result:(fun ~major_words_allocated ~minor_words_allocated x -> x, Allocation_report.create ~major_words_allocated ~minor_words_allocated) ;; module Allocation_log = struct type t = { size_in_words : int ; is_major : bool ; backtrace : string } [@@deriving sexp_of] end [%%if ocaml_version >= (4, 11, 0)] let measure_and_log_allocation f = let log : Allocation_log.t list ref = ref [] and major_allocs = ref 0 and minor_allocs = ref 0 in let on_alloc ~is_major (info : Caml.Gc.Memprof.allocation) = if is_major then major_allocs := !major_allocs + info.n_samples else minor_allocs := !minor_allocs + info.n_samples; let backtrace = Caml.Printexc.raw_backtrace_to_string info.callstack in (* Make backtraces easier to read by deleting everything below this function *) let backtrace = match String.substr_index backtrace ~pattern:"measure_and_log_allocation" with | None -> (* This case is possible: we may have logged allocations in another thread *) backtrace | Some p -> String.sub ~pos:0 ~len:p backtrace |> String.rstrip ~drop:(function | '\n' -> false | _ -> true) in let info : Allocation_log.t = { size_in_words = info.n_samples; is_major; backtrace } in log := info :: !log; None in let tracker = { Caml.Gc.Memprof.null_tracker with alloc_minor = on_alloc ~is_major:false ; alloc_major = on_alloc ~is_major:true } in Caml.Gc.Memprof.start ~sampling_rate:1.0 tracker; (* Exn.protect, manually inlined to guarantee no allocations *) let result = match f () with | x -> (* Memprof.stop does not guarantee that all memprof callbacks are run (some may be delayed if they happened during C code and there has been no allocation since), so we explictly flush them *) run_memprof_callbacks (); Caml.Gc.Memprof.stop (); x | exception e -> run_memprof_callbacks (); Caml.Gc.Memprof.stop (); raise e in ( result , Allocation_report.create ~major_words_allocated:!major_allocs ~minor_words_allocated:!minor_allocs , List.rev !log ) ;; [%%else] let measure_and_log_allocation f = let x, report = measure_allocation f in x, report, [] ;; [%%endif] end module Expert = struct let add_finalizer x f = try Caml.Gc.finalise (fun x -> Exn.handle_uncaught_and_exit (fun () -> f x)) x with | Invalid_argument _ -> (* The type of add_finalizer ensures that the only possible failure is due to [x] being static data. In this case, we simply drop the finalizer since static data would never have been collected by the GC anyway. *) () ;; (* [add_finalizer_exn] is the same as [add_finalizer]. However, their types in core_gc.mli are different, and the type of [add_finalizer] guarantees that it always receives a heap block, which ensures that it will not raise, while [add_finalizer_exn] accepts any type, and so may raise. *) let add_finalizer_exn x f = try Caml.Gc.finalise (fun x -> Exn.handle_uncaught_and_exit (fun () -> f x)) x with | Invalid_argument _ -> ignore (Heap_block.create x : _ Heap_block.t option); (* If [Heap_block.create] succeeds then [x] is static data and so we can simply drop the finaliser. *) () ;; let add_finalizer_last x f = try Caml.Gc.finalise_last (fun () -> Exn.handle_uncaught_and_exit f) x with | Invalid_argument _ -> (* The type of add_finalizer_last ensures that the only possible failure is due to [x] being static data. In this case, we simply drop the finalizer since static data would never have been collected by the GC anyway. *) () ;; let add_finalizer_last_exn x f = try Caml.Gc.finalise_last (fun () -> Exn.handle_uncaught_and_exit f) x with | Invalid_argument _ -> ignore (Heap_block.create x : _ Heap_block.t option); (* If [Heap_block.create] succeeds then [x] is static data and so we can simply drop the finaliser. *) () ;; let finalize_release = Caml.Gc.finalise_release module Alarm = struct type t = alarm let sexp_of_t _ = "" |> [%sexp_of: string] let create f = create_alarm (fun () -> Exn.handle_uncaught_and_exit f) let delete = delete_alarm end end core-0.15.0/core/src/gc.mli000066400000000000000000000571431420273305200153500ustar00rootroot00000000000000(** This is a wrapper around INRIA's standard [Gc] module. Provides memory management control and statistics, and finalized values. *) open! Import (*_ (***********************************************************************) (* *) (* Objective Caml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id: gc.mli,v 1.42 2005-10-25 18:34:07 doligez Exp $ *) *) module Stat : sig [%%if ocaml_version < (4, 12, 0)] type t = { 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. *) } [@@deriving bin_io, sexp, fields] [%%else] type t = { 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. *) ; forced_major_collections : int (** Number of forced full major collection cycles completed since the program was started. *) } [@@deriving sexp_of, fields] [%%endif] include Comparable.S_plain with type t := t (** [diff after before] computes [after-before] pointwise across each field; this helps show the effect (on all stats) of some code block. *) val diff : t -> t -> t end type stat = Stat.t (** 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. *) module Control : sig type t = { mutable minor_heap_size : int (** The size (in words) of the minor heap. Changing this parameter will trigger a minor collection. Default: 262144 words / 1MB (32bit) / 2MB (64bit). *) ; mutable major_heap_increment : int (** How much to add to the major heap when increasing it. If this number is less than or equal to 1000, it is a percentage of the current heap size (i.e. setting it to 100 will double the heap size at each increase). If it is more than 1000, it is a fixed number of words that will be added to the heap. Default: 15%. *) ; 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: 1048576 words / 4MB (32bit) / 8MB (64bit). *) ; 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. *) ; window_size : int (** The size of the window used by the major GC for smoothing out variations in its workload. This is an integer between 1 and 50. Default: 1. @since 4.03.0 *) ; custom_major_ratio : int (** Target ratio of floating garbage to major heap size for out-of-heap memory held by custom values located in the major heap. The GC speed is adjusted to try to use this much memory for dead values that are not yet collected. Expressed as a percentage of major heap size. The default value keeps the out-of-heap floating garbage about the same size as the in-heap overhead. Note: this only applies to values allocated with [caml_alloc_custom_mem] (e.g. bigarrays). Default: 44. @since 4.08.0 *) ; custom_minor_ratio : int (** Bound on floating garbage for out-of-heap memory held by custom values in the minor heap. A minor GC is triggered when this much memory is held by custom values located in the minor heap. Expressed as a percentage of minor heap size. Note: this only applies to values allocated with [caml_alloc_custom_mem] (e.g. bigarrays). Default: 100. @since 4.08.0 *) ; custom_minor_max_size : int (** Maximum amount of out-of-heap memory for each custom value allocated in the minor heap. When a custom value is allocated on the minor heap and holds more than this many bytes, only this value is counted against [custom_minor_ratio] and the rest is directly counted against [custom_major_ratio]. Note: this only applies to values allocated with [caml_alloc_custom_mem] (e.g. bigarrays). Default: 8192 bytes. @since 4.08.0 *) } [@@deriving sexp_of, fields] include Comparable.S_plain with type t := t end type control = Control.t (** 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. *) (** Return the current values of the memory management counters in a [stat] record. This function examines every heap block to get the statistics. *) external stat : unit -> stat = "caml_gc_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 quick_stat : unit -> stat = "caml_gc_quick_stat" (** Return [(minor_words, promoted_words, major_words)]. This function is as fast at [quick_stat]. *) external counters : unit -> float * float * float = "caml_gc_counters" (** The following functions return the same as [(Gc.quick_stat ()).Stat.f], avoiding any allocation (of the [stat] record or a float). On 32-bit machines the [int] may overflow. Note that [minor_words] does not allocate, but we do not annotate it as [noalloc] because we want the compiler to save the value of the allocation pointer register (%r15 on x86-64) to the global variable [caml_young_ptr] before the C stub tries to read its value. *) external minor_words : unit -> int = "core_gc_minor_words" external major_words : unit -> int = "core_gc_major_words" [@@noalloc] external promoted_words : unit -> int = "core_gc_promoted_words" [@@noalloc] external minor_collections : unit -> int = "core_gc_minor_collections" [@@noalloc] external major_collections : unit -> int = "core_gc_major_collections" [@@noalloc] external heap_words : unit -> int = "core_gc_heap_words" [@@noalloc] external heap_chunks : unit -> int = "core_gc_heap_chunks" [@@noalloc] external compactions : unit -> int = "core_gc_compactions" [@@noalloc] external top_heap_words : unit -> int = "core_gc_top_heap_words" [@@noalloc] (** This function returns [major_words () + minor_words ()]. It exists purely for speed (one call into C rather than two). Like [major_words] and [minor_words], [major_plus_minor_words] avoids allocating a [stat] record or a float, and may overflow on 32-bit machines. This function is not marked [[@@noalloc]] to ensure that the allocation pointer is up-to-date when the minor-heap measurement is made. *) external major_plus_minor_words : unit -> int = "core_gc_major_plus_minor_words" (** This function returns [major_words () - promoted_words () + minor_words ()], as fast as possible. As [major_plus_minor_words], we avoid allocating but cannot be marked [@@noalloc] yet. It may overflow in 32-bit mode. *) external allocated_words : unit -> int = "core_gc_allocated_words" (** Return the current values of the GC parameters in a [control] record. *) external get : unit -> control = "caml_gc_get" (** [set r] changes the GC parameters according to the [control] record [r]. The normal usage is: [Gc.set { (Gc.get()) with Gc.Control.verbose = 0x00d }] *) external set : control -> unit = "caml_gc_set" (** Trigger a minor collection. *) external minor : unit -> unit = "caml_gc_minor" (** 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_slice : int -> int = "caml_gc_major_slice" (** Do a minor collection and finish the current major collection cycle. *) external major : unit -> unit = "caml_gc_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 full_major : unit -> unit = "caml_gc_full_major" (** Perform a full major collection and compact the heap. Note that heap compaction is a lengthy operation. *) external compact : unit -> unit = "caml_gc_compaction" (** Print the current values of the memory management counters (in human-readable form) into the channel argument. *) val print_stat : out_channel -> unit (** 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. *) val allocated_bytes : unit -> float (** [keep_alive a] ensures that [a] is live at the point where [keep_alive a] is called. It is like [ignore a], except that the compiler won't be able to simplify it and potentially collect [a] too soon. *) val keep_alive : _ -> unit (** The policy used for allocating in the heap. The Next_fit policy is quite fast but can result in fragmentation. The First_fit policy can be slower in some cases but can be better for programs with fragmentation problems. The Best_fit policy is as fast as Next_fit and has less fragmentation than First_fit. The default is Best_fit. *) module Allocation_policy : sig type t = | Next_fit | First_fit | Best_fit [@@deriving compare, equal, hash, sexp_of] end (** Adjust the specified GC parameters. *) val tune : ?logger:(string -> unit) -> ?minor_heap_size:int -> ?major_heap_increment:int -> ?space_overhead:int -> ?verbose:int -> ?max_overhead:int -> ?stack_limit:int -> ?allocation_policy:Allocation_policy.t -> ?window_size:int -> ?custom_major_ratio:int -> ?custom_minor_ratio:int -> ?custom_minor_max_size:int -> unit -> unit val disable_compaction : ?logger:(string -> unit) -> allocation_policy:[ `Don't_change | `Set_to of Allocation_policy.t ] -> unit -> unit module For_testing : sig module Allocation_report : sig type t = { major_words_allocated : int ; minor_words_allocated : int } [@@deriving sexp_of] end (** [measure_allocation f] measures the words allocated by running [f ()] *) val measure_allocation : (unit -> 'a) -> 'a * Allocation_report.t module Allocation_log : sig type t = { size_in_words : int ; is_major : bool ; backtrace : string } [@@deriving sexp_of] end (** [measure_and_log_allocation f] logs each allocation that [f ()] performs, as well as reporting the total. (This can be slow if [f] allocates heavily). This function is only supported since OCaml 4.11. On prior versions, the function always returns an empty log. *) val measure_and_log_allocation : (unit -> 'a) -> 'a * Allocation_report.t * Allocation_log.t list (** [is_zero_alloc f] runs [f ()] and returns [true] if it does not allocate, or [false] otherwise. [is_zero_alloc] does not allocate. *) val is_zero_alloc : (unit -> _) -> bool (** [prepare_heap_to_count_minor_allocation] sets up the heap so that one can subsequently measure minor allocation via: {[ let minor_words_before = Gc.minor_words () in (* ... do stuff ... *) let minor_words_after = Gc.minor_words () in let minor_words_allocated = minor_words_after - minor_words_before in ]} Without calling [prepare_heap_to_count_minor_allocation], the resulting count may be inaccurate. *) val prepare_heap_to_count_minor_allocation : unit -> unit end (** The [Expert] module contains functions that novice users should not use, due to their complexity. In particular, finalizers are difficult to use correctly, because they can run at any time, even in the middle of other code, and because unhandled exceptions in a finalizer can be raised at any point in other code. This introduces all the semantic complexities of multithreading, which is usually a bad idea. It is much easier to use async finalizers, see {!Async_kernel.Async_gc.add_finalizer}, which do not involve multithreading, and runs user code as ordinary async jobs. If you do use [Core] finalizers, you should strive to make the finalization function perform a simple idempotent action, like setting a ref. The same rules as for signal handlers apply to finalizers. *) module Expert : sig (** [add_finalizer b f] ensures that [f] runs after [b] becomes unreachable. The OCaml runtime only supports finalizers on heap blocks, hence [add_finalizer] requires [b : _ Heap_block.t]. The runtime essentially maintains a set of finalizer pairs: {v 'a Heap_block.t * ('a Heap_block.t -> unit) v} Each call to [add_finalizer] adds a new pair to the set. It is allowed for many pairs to have the same heap block, the same function, or both. Each pair is a distinct element of the set. After a garbage collection determines that a heap block [b] is unreachable, it removes from the set of finalizers all finalizer pairs [(b, f)] whose block is [b], and then and runs [f b] for all such pairs. Thus, a finalizer registered with [add_finalizer] will run at most once. 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 [add_finalizer]. If [add_finalizer] 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. In a finalizer pair [(b, f)], it is a mistake for the closure of [f] to reference (directly or indirectly) [b] -- [f] should only access [b] via its argument. Referring to [b] in any other way will cause [b] to be kept alive forever, since [f] itself is a root of garbage collection, and can itself only be collected after the pair [(b, f)] is removed from the set of finalizers. 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 be called during the execution of f). It can call [add_finalizer] on [v] or other values to register other functions or even itself. All finalizers are called with [Exn.handle_uncaught_and_exit], to prevent the finalizer from raising, because raising from a finalizer could raise to any allocation or GC point in any thread, which would be impossible to reason about. [add_finalizer_exn b f] is like [add_finalizer], but will raise if [b] is not a heap block. *) val add_finalizer : 'a Heap_block.t -> ('a Heap_block.t -> unit) -> unit val add_finalizer_exn : 'a -> ('a -> unit) -> unit (** Same as {!add_finalizer} except that the function is not called until the value has become unreachable for the last time. This means that the finalization function does not recieve the value as an argument. Every weak pointer and ephemeron that contained this value as key or data is unset before running the finalization function. *) val add_finalizer_last : 'a Heap_block.t -> (unit -> unit) -> unit val add_finalizer_last_exn : 'a -> (unit -> unit) -> unit (** The runtime essentially maintains a bool ref: {[ val finalizer_is_running : bool ref ]} The runtime uses this bool ref to ensure that only one finalizer is running at a time, by setting it to [true] when a finalizer starts and setting it to [false] when a finalizer finishes. The runtime will not start running a finalizer if [!finalizer_is_running = true]. Calling [finalize_release] essentially does [finalizer_is_running := false], which allows another finalizer to start whether or not the current finalizer finishes. *) val finalize_release : unit -> unit (** A GC alarm calls a user function at the end of each major GC cycle. *) module Alarm : sig type t [@@deriving sexp_of] (** [create f] arranges for [f] to be called at the end of each major GC cycle, starting with the current cycle or the next one. [f] can be called in any thread, and so introduces all the complexity of threading. [f] is called with [Exn.handle_uncaught_and_exit], to prevent it from raising, because raising could raise to any allocation or GC point in any thread, which would be impossible to reason about. *) val create : (unit -> unit) -> t (** [delete t] will stop the calls to the function associated to [t]. Calling [delete t] again has no effect. *) val delete : t -> unit end end module Stable : sig module Stat : sig [%%if ocaml_version < (4, 12, 0)] module V1 : sig type nonrec t = Stat.t [@@deriving bin_io, compare, equal, hash, sexp] end module V2 : sig type nonrec t [@@deriving bin_io, compare, equal, hash, sexp] end [%%else] module V1 : sig type nonrec t [@@deriving bin_io, compare, equal, hash, sexp] end module V2 : sig type nonrec t = Stat.t [@@deriving bin_io, compare, equal, hash, sexp] end [%%endif] end module Allocation_policy : sig module V1 : sig type nonrec t = Allocation_policy.t [@@deriving bin_io, compare, equal, hash, sexp] end end module Control : sig module V1 : sig type nonrec t = Control.t [@@deriving bin_io, compare, equal, sexp] end end end core-0.15.0/core/src/gc_stubs.c000066400000000000000000000037201420273305200162210ustar00rootroot00000000000000#define CAML_INTERNALS #include #include #include #include static intnat minor_words(void) { return (intnat) (caml_stat_minor_words + (double) (caml_young_end - caml_young_ptr)); } static intnat promoted_words(void) { return ((intnat) caml_stat_promoted_words); } CAMLprim value core_gc_minor_words(value unit __attribute__((unused))) { return Val_long(minor_words()); } static intnat major_words(void) { return (intnat) (caml_stat_major_words + (double) caml_allocated_words); } CAMLprim value core_gc_major_words(value unit __attribute__((unused))) { return Val_long(major_words()); } CAMLprim value core_gc_promoted_words(value unit __attribute__((unused))) { return Val_long(promoted_words()); } CAMLprim value core_gc_minor_collections(value unit __attribute__((unused))) { return Val_long(caml_stat_minor_collections); } CAMLprim value core_gc_major_collections(value unit __attribute__((unused))) { return Val_long(caml_stat_major_collections); } CAMLprim value core_gc_heap_words(value unit __attribute__((unused))) { return Val_long(caml_stat_heap_wsz); } CAMLprim value core_gc_heap_chunks(value unit __attribute__((unused))) { return Val_long(caml_stat_heap_chunks); } CAMLprim value core_gc_compactions(value unit __attribute__((unused))) { return Val_long(caml_stat_compactions); } CAMLprim value core_gc_top_heap_words(value unit __attribute__((unused))) { return Val_long(caml_stat_top_heap_wsz); } CAMLprim value core_gc_major_plus_minor_words(value unit __attribute__((unused))) { return Val_long(minor_words() + major_words()); } CAMLprim value core_gc_allocated_words(value unit __attribute__((unused))) { return Val_long(minor_words() + major_words() - promoted_words()); } CAMLprim value core_gc_run_memprof_callbacks(value unit __attribute__((unused))) { value exn = caml_memprof_handle_postponed_exn(); caml_raise_if_exception(exn); return Val_unit; } core-0.15.0/core/src/hash_queue.ml000066400000000000000000000255511420273305200167330ustar00rootroot00000000000000open! Import open Hash_queue_intf module type Key = Key module type S_backend = S_backend module Make_backend (Table : Hashtbl_intf.Hashtbl) : S_backend = struct module type Backend = S1 with type 'key create_arg := 'key Hashtbl.Hashable.t with type 'key create_key := 'key module Backend : Backend = struct module Key_value = struct module T = struct type ('key, 'value) t = { key : 'key ; mutable value : 'value } end include T let key t = t.key let value t = t.value let sexp_of_t sexp_of_key sexp_of_data { key; value } = [%sexp_of: key * data] (key, value) ;; end open Key_value.T module Elt = Doubly_linked.Elt type ('key, 'data) t = { mutable num_readers : int ; queue : ('key, 'data) Key_value.t Doubly_linked.t ; table : ('key, ('key, 'data) Key_value.t Elt.t) Table.t } let sexp_of_t sexp_of_key sexp_of_data t = [%sexp_of: (key, data) Key_value.t Doubly_linked.t] t.queue ;; let invariant t = assert (Doubly_linked.length t.queue = Table.length t.table); (* Look at each element in the queue, checking: * - every element in the queue is in the hash table * - there are no duplicate keys *) let keys = Table.create ~size:(Table.length t.table) (Table.hashable_s t.table) in Doubly_linked.iter t.queue ~f:(fun kv -> let key = kv.key in match Table.find t.table key with | None -> assert false | Some _ -> assert (not (Table.mem keys key)); Table.set keys ~key ~data:()) ;; let create ?(growth_allowed = true) ?(size = 16) hashable = { num_readers = 0 ; queue = Doubly_linked.create () ; table = Table.create ~growth_allowed ~size (Table.Hashable.to_key hashable) } ;; let read t f = t.num_readers <- t.num_readers + 1; Exn.protect ~f ~finally:(fun () -> t.num_readers <- t.num_readers - 1) ;; let ensure_can_modify t = if t.num_readers > 0 then failwith "It is an error to modify a Hash_queue.t while iterating over it." ;; let clear t = ensure_can_modify t; Doubly_linked.clear t.queue; Table.clear t.table ;; let length t = Table.length t.table let is_empty t = length t = 0 let lookup t k = match Table.find t.table k with | None -> None | Some elt -> Some (Elt.value elt).value ;; let lookup_exn t k = (Elt.value (Table.find_exn t.table k)).value let mem t k = Table.mem t.table k (* Note that this is the tail-recursive Core_list.map *) let to_list t = List.map (Doubly_linked.to_list t.queue) ~f:Key_value.value let to_array t = Array.map (Doubly_linked.to_array t.queue) ~f:Key_value.value let for_all t ~f = read t (fun () -> Doubly_linked.for_all t.queue ~f:(fun kv -> f kv.value)) ;; let exists t ~f = read t (fun () -> Doubly_linked.exists t.queue ~f:(fun kv -> f kv.value)) ;; let find_map t ~f = read t (fun () -> Doubly_linked.find_map t.queue ~f:(fun kv -> f kv.value)) ;; let find t ~f = read t (fun () -> Option.map (Doubly_linked.find t.queue ~f:(fun kv -> f kv.value)) ~f:Key_value.value) ;; let enqueue t back_or_front key value = ensure_can_modify t; if Table.mem t.table key then `Key_already_present else ( let contents = { Key_value.key; value } in let elt = match back_or_front with | `back -> Doubly_linked.insert_last t.queue contents | `front -> Doubly_linked.insert_first t.queue contents in Table.set t.table ~key ~data:elt; `Ok) ;; let enqueue_back t = enqueue t `back let enqueue_front t = enqueue t `front let raise_enqueue_duplicate_key t key = raise_s [%message "Hash_queue.enqueue_exn: duplicate key" ~_:(Table.sexp_of_key t.table key : Sexp.t)] ;; let enqueue_exn t back_or_front key value = match enqueue t back_or_front key value with | `Key_already_present -> raise_enqueue_duplicate_key t key | `Ok -> () ;; let enqueue_back_exn t = enqueue_exn t `back let enqueue_front_exn t = enqueue_exn t `front (* Performance hack: we implement this version separately to avoid allocation from the option. *) let lookup_and_move_to_back_exn t key = ensure_can_modify t; let elt = Table.find_exn t.table key in Doubly_linked.move_to_back t.queue elt; Key_value.value (Elt.value elt) ;; let lookup_and_move_to_back t key = let open Option.Let_syntax in ensure_can_modify t; let%map elt = Table.find t.table key in Doubly_linked.move_to_back t.queue elt; Key_value.value (Elt.value elt) ;; let lookup_and_move_to_front_exn t key = ensure_can_modify t; let elt = Table.find_exn t.table key in Doubly_linked.move_to_front t.queue elt; Key_value.value (Elt.value elt) ;; let lookup_and_move_to_front t key = let open Option.Let_syntax in ensure_can_modify t; let%map elt = Table.find t.table key in Doubly_linked.move_to_front t.queue elt; Key_value.value (Elt.value elt) ;; let dequeue_with_key t back_or_front = ensure_can_modify t; let maybe_kv = match back_or_front with | `back -> Doubly_linked.remove_last t.queue | `front -> Doubly_linked.remove_first t.queue in match maybe_kv with | None -> None | Some kv -> Table.remove t.table kv.key; Some (kv.key, kv.value) ;; let raise_dequeue_with_key_empty () = raise_s [%message "Hash_queue.dequeue_with_key: empty queue"] ;; let dequeue_with_key_exn t back_or_front = match dequeue_with_key t back_or_front with | None -> raise_dequeue_with_key_empty () | Some (k, v) -> k, v ;; let dequeue_back_with_key t = dequeue_with_key t `back let dequeue_back_with_key_exn t = dequeue_with_key_exn t `back let dequeue_front_with_key t = dequeue_with_key t `front let dequeue_front_with_key_exn t = dequeue_with_key_exn t `front let dequeue t back_or_front = match dequeue_with_key t back_or_front with | None -> None | Some (_, v) -> Some v ;; let dequeue_back t = dequeue t `back let dequeue_front t = dequeue t `front let last_with_key t = match Doubly_linked.last t.queue with | None -> None | Some { key; value } -> Some (key, value) ;; let last t = match Doubly_linked.last t.queue with | None -> None | Some kv -> Some kv.value ;; let first_with_key t = match Doubly_linked.first t.queue with | None -> None | Some { key; value } -> Some (key, value) ;; let first t = match Doubly_linked.first t.queue with | None -> None | Some kv -> Some kv.value ;; let raise_dequeue_empty () = raise_s [%message "Hash_queue.dequeue_exn: empty queue"] let dequeue_exn t back_or_front = match dequeue t back_or_front with | None -> raise_dequeue_empty () | Some v -> v ;; let dequeue_back_exn t = dequeue_exn t `back let dequeue_front_exn t = dequeue_exn t `front let keys t = (* Return the keys in the order of the queue. *) List.map (Doubly_linked.to_list t.queue) ~f:Key_value.key ;; let iteri t ~f = read t (fun () -> Doubly_linked.iter t.queue ~f:(fun kv -> f ~key:kv.key ~data:kv.value)) ;; let iter t ~f = iteri t ~f:(fun ~key:_ ~data -> f data) let foldi t ~init ~f = read t (fun () -> Doubly_linked.fold t.queue ~init ~f:(fun ac kv -> f ac ~key:kv.key ~data:kv.value)) ;; let fold t ~init ~f = foldi t ~init ~f:(fun ac ~key:_ ~data -> f ac data) let count t ~f = Container.count ~fold t ~f let sum m t ~f = Container.sum m ~fold t ~f let min_elt t ~compare = Container.min_elt ~fold t ~compare let max_elt t ~compare = Container.max_elt ~fold t ~compare let fold_result t ~init ~f = Container.fold_result ~fold ~init ~f t let fold_until t ~init ~f = Container.fold_until ~fold ~init ~f t let dequeue_all t ~f = let rec loop () = match dequeue_front t with | None -> () | Some v -> f v; loop () in loop () ;; let remove t k = ensure_can_modify t; match Table.find_and_remove t.table k with | None -> `No_such_key | Some elt -> Doubly_linked.remove t.queue elt; `Ok ;; let raise_remove_unknown_key t key = raise_s [%message "Hash_queue.remove_exn: unknown key" ~_:(Table.sexp_of_key t.table key : Sexp.t)] ;; let remove_exn t k = ensure_can_modify t; match remove t k with | `No_such_key -> raise_remove_unknown_key t k | `Ok -> () ;; let lookup_and_remove t k = ensure_can_modify t; match Table.find_and_remove t.table k with | None -> None | Some elt -> Doubly_linked.remove t.queue elt; Some (Elt.value elt).value ;; let replace t k v = ensure_can_modify t; match Table.find t.table k with | None -> `No_such_key | Some elt -> (Elt.value elt).value <- v; `Ok ;; let raise_replace_unknown_key t key = raise_s [%message "Hash_queue.replace_exn: unknown key" ~_:(Table.sexp_of_key t.table key : Sexp.t)] ;; let replace_exn t k v = ensure_can_modify t; match replace t k v with | `No_such_key -> raise_replace_unknown_key t k | `Ok -> () ;; let drop ?(n = 1) t back_or_front = if n >= length t then clear t else for _ = 1 to n do ignore (dequeue_with_key t back_or_front : _ option) done ;; let drop_back ?n t = drop ?n t `back let drop_front ?n t = drop ?n t `front let copy t = let copied = create ~size:(length t) (Table.hashable t.table) in iteri t ~f:(fun ~key ~data -> enqueue_back_exn copied key data); copied ;; end module type S = S0 with type ('key, 'data) hash_queue := ('key, 'data) Backend.t module Make_with_hashable (T : sig module Key : Key val hashable : Key.t Hashtbl.Hashable.t end) : S with type key = T.Key.t = struct include (Backend : Backend with type ('k, 'd) t := ('k, 'd) Backend.t) type key = T.Key.t type 'data t = (T.Key.t, 'data) Backend.t [@@deriving sexp_of] let hashable = T.hashable let create ?growth_allowed ?size () = create ?growth_allowed ?size hashable end module Make (Key : Key) : S with type key = Key.t = Make_with_hashable (struct module Key = Key let hashable = Table.Hashable.of_key (module Key) end) include Backend end include Make_backend (Hashtbl) core-0.15.0/core/src/hash_queue.mli000066400000000000000000000000621420273305200170720ustar00rootroot00000000000000include Hash_queue_intf.Hash_queue (** @inline *) core-0.15.0/core/src/hash_queue_intf.ml000066400000000000000000000212461420273305200177500ustar00rootroot00000000000000open! Import (** The key is used for the hashtable of queue elements. *) module type Key = Hashtbl.Key_plain module type S1 = sig type 'key create_arg type 'key create_key (** A hash-queue, where the values are of type ['data]. *) type ('key, 'data) t [@@deriving sexp_of] include Container.S1_phantom_invariant with type ('data, 'key) t := ('key, 'data) t (** [invariant t] checks the invariants of the queue. *) val invariant : ('key, 'data) t -> unit (** [create ()] returns an empty queue. The arguments [growth_allowed] and [size] are referring to the underlying hashtable. @param growth_allowed defaults to true @param size initial size -- default to 16 *) val create : ?growth_allowed:bool -> ?size:int -> 'key create_arg -> ('key create_key, 'data) t (** Clears the queue. *) val clear : ('key, 'data) t -> unit (** Makes a fresh copy of the queue with identical contents to the original. *) val copy : ('key, 'data) t -> ('key, 'data) t (** {2 Finding elements} *) (** [mem q k] returns true iff there is some (k, v) in the queue. *) val mem : ('key, 'data) t -> 'key -> bool (** [lookup t k] returns the value of the key-value pair in the queue with key k, if there is one. *) val lookup : ('key, 'data) t -> 'key -> 'data option val lookup_exn : ('key, 'data) t -> 'key -> 'data (** {2 Adding, removing, and replacing elements} Note that even the non-[*_exn] versions can raise, but only if there is an ongoing iteration. *) (** [enqueue t back_or_front k v] adds the key-value pair (k, v) to the front or back of the queue, returning [`Ok] if the pair was added, or [`Key_already_present] if there is already a (k, v') in the queue. *) val enqueue : ('key, 'data) t -> [ `back | `front ] -> 'key -> 'data -> [ `Ok | `Key_already_present ] (** Like {!enqueue}, but it raises in the [`Key_already_present] case *) val enqueue_exn : ('key, 'data) t -> [ `back | `front ] -> 'key -> 'data -> unit (** See {!enqueue}. [enqueue_back t k v] is the same as [enqueue t `back k v] *) val enqueue_back : ('key, 'data) t -> 'key -> 'data -> [ `Ok | `Key_already_present ] (** See {!enqueue_exn}. [enqueue_back_exn t k v] is the same as [enqueue_exn t `back k v] *) val enqueue_back_exn : ('key, 'data) t -> 'key -> 'data -> unit (** See {!enqueue}. [enqueue_front t k v] is the same as [enqueue t `front k v] *) val enqueue_front : ('key, 'data) t -> 'key -> 'data -> [ `Ok | `Key_already_present ] (** See {!enqueue_exn}. [enqueue_front_exn t k v] is the same as [enqueue_exn t `front k v] *) val enqueue_front_exn : ('key, 'data) t -> 'key -> 'data -> unit (** [lookup_and_move_to_back] finds the key-value pair (k, v) and moves it to the back of the queue if it exists, otherwise returning [None]. The [_exn] versions of these functions raise if key-value pair does not exist. *) val lookup_and_move_to_back : ('key, 'data) t -> 'key -> 'data option (** Like {!lookup_and_move_to_back}, but raises instead of returning an option *) val lookup_and_move_to_back_exn : ('key, 'data) t -> 'key -> 'data (** Like {!lookup_and_move_to_back}, but moves element to the front of the queue *) val lookup_and_move_to_front : ('key, 'data) t -> 'key -> 'data option (** Like {!lookup_and_move_to_front}, but raises instead of returning an option *) val lookup_and_move_to_front_exn : ('key, 'data) t -> 'key -> 'data (** [last t] returns the last element of the queue, without removing it. *) val last : ('key, 'data) t -> 'data option (** [last_with_key t] returns the last element of the queue and its key, without removing it. *) val last_with_key : ('key, 'data) t -> ('key * 'data) option (** [first t] returns the front element of the queue, without removing it. *) val first : ('key, 'data) t -> 'data option (** [first_with_key t] returns the front element of the queue and its key, without removing it. *) val first_with_key : ('key, 'data) t -> ('key * 'data) option (** [keys t] returns the keys in the order of the queue. *) val keys : ('key, 'data) t -> 'key list (** [dequeue t front_or_back] returns the front or back element of the queue. *) val dequeue : ('key, 'data) t -> [ `back | `front ] -> 'data option (** Like {!dequeue}, but it raises if the queue is empty. *) val dequeue_exn : ('key, 'data) t -> [ `back | `front ] -> 'data (** [dequeue_back t] returns the back element of the queue. *) val dequeue_back : ('key, 'data) t -> 'data option (** Like {!dequeue_back}, but it raises if the queue is empty. *) val dequeue_back_exn : ('key, 'data) t -> 'data (** [dequeue_front t] returns the front element of the queue. *) val dequeue_front : ('key, 'data) t -> 'data option (** Like {!dequeue_front}, but it raises if the queue is empty. *) val dequeue_front_exn : ('key, 'data) t -> 'data (** [dequeue_with_key t] returns the front or back element of the queue and its key. *) val dequeue_with_key : ('key, 'data) t -> [ `back | `front ] -> ('key * 'data) option (** Like {!dequeue_with_key}, but it raises if the queue is empty. *) val dequeue_with_key_exn : ('key, 'data) t -> [ `back | `front ] -> 'key * 'data (** [dequeue_back_with_key t] returns the back element of the queue and its key. *) val dequeue_back_with_key : ('key, 'data) t -> ('key * 'data) option (** Like {!dequeue_back_with_key}, but it raises if the queue is empty. *) val dequeue_back_with_key_exn : ('key, 'data) t -> 'key * 'data (** [dequeue_front_with_key t] returns the front element of the queue and its key. *) val dequeue_front_with_key : ('key, 'data) t -> ('key * 'data) option (** Like {!dequeue_front_with_key}, but it raises if the queue is empty. *) val dequeue_front_with_key_exn : ('key, 'data) t -> 'key * 'data (** [dequeue_all t ~f] dequeues every element of the queue and applies [f] to each one. The dequeue order is from front to back. *) val dequeue_all : ('key, 'data) t -> f:('data -> unit) -> unit (** [remove q k] removes the key-value pair with key [k] from the queue. *) val remove : ('key, 'data) t -> 'key -> [ `Ok | `No_such_key ] val remove_exn : ('key, 'data) t -> 'key -> unit (** like {!remove}, but returns the removed element *) val lookup_and_remove : ('key, 'data) t -> 'key -> 'data option (** [replace q k v] changes the value of key [k] in the queue to [v]. *) val replace : ('key, 'data) t -> 'key -> 'data -> [ `Ok | `No_such_key ] val replace_exn : ('key, 'data) t -> 'key -> 'data -> unit (** [drop ?n q back_or_front] drops [n] elements (default 1) from the back or front of the queue. If the queue has fewer than [n] elements then it is cleared. *) val drop : ?n:int -> ('key, 'data) t -> [ `back | `front ] -> unit (** Equivalent to [drop ?n q `front]. *) val drop_front : ?n:int -> ('key, 'data) t -> unit (** Equivalent to [drop ?n q `back]. *) val drop_back : ?n:int -> ('key, 'data) t -> unit (** {2 Iterating over elements} *) (** [iter t ~f] applies [f] to each key and element of the queue. *) val iteri : ('key, 'data) t -> f:(key:'key -> data:'data -> unit) -> unit val foldi : ('key, 'data) t -> init:'b -> f:('b -> key:'key -> data:'data -> 'b) -> 'b end module type S0 = sig type ('key, 'data) hash_queue type key include S1 with type 'key create_key := key with type 'key create_arg := unit with type ('key, 'data) t := ('key, 'data) hash_queue type 'data t = (key, 'data) hash_queue [@@deriving sexp_of] end module type S_backend = sig include S1 with type 'key create_arg := 'key Hashtbl.Hashable.t with type 'key create_key := 'key module type S = S0 with type ('key, 'data) hash_queue := ('key, 'data) t module Make (Key : Key) : S with type key = Key.t module Make_with_hashable (T : sig module Key : Key val hashable : Key.t Hashtbl.Hashable.t end) : S with type key = T.Key.t end (** A hash-queue is a combination of a queue and a hashtable that supports constant-time lookup and removal of queue elements in addition to the usual queue operations (enqueue, dequeue). The queue elements are key-value pairs. The hashtable has one entry for each element of the queue. Calls to functions that would modify a hash-queue (e.g. [enqueue], [dequeue], [remove], [replace]) detect if a client is in the middle of iterating over the queue (e.g., [iter], [fold], [for_all], [exists]) and if so, raise an exception. *) module type Hash_queue = sig module type Key = Key module type S_backend = S_backend module Make_backend (Table : Hashtbl_intf.Hashtbl) : S_backend (** equivalent to [Make_backend (Hashtbl)] *) include S_backend end core-0.15.0/core/src/hash_set.ml000066400000000000000000000064141420273305200163770ustar00rootroot00000000000000open! Import include Hash_set_intf include Base.Hash_set module type S_plain = S_plain with type 'a hash_set := 'a t module type S = S with type 'a hash_set := 'a t module type S_binable = S_binable with type 'a hash_set := 'a t module type Elt_plain = Hashtbl.Key_plain module type Elt = Hashtbl.Key module type Elt_binable = Hashtbl.Key_binable module Make_plain_with_hashable (T : sig module Elt : Elt_plain val hashable : Elt.t Hashtbl.Hashable.t end) = struct type elt = T.Elt.t type nonrec t = elt t let equal = equal include Creators (struct type 'a t = T.Elt.t let hashable = T.hashable end) let sexp_of_t t = Poly.sexp_of_t T.Elt.sexp_of_t t module Provide_of_sexp (X : sig type t [@@deriving of_sexp] end with type t := elt) = struct let t_of_sexp sexp = t_of_sexp X.t_of_sexp sexp end module Provide_bin_io (X : sig type t [@@deriving bin_io] end with type t := elt) = Bin_prot.Utils.Make_iterable_binable (struct module Elt = struct include T.Elt include X end type nonrec t = t type el = Elt.t [@@deriving bin_io] let _ = bin_el let caller_identity = Bin_prot.Shape.Uuid.of_string "ad381672-4992-11e6-9e36-b76dc8cd466f" ;; let module_name = Some "Core.Hash_set" let length = length let iter = iter let init ~len ~next = let t = create ~size:len () in for _i = 0 to len - 1 do let v = next () in add t v done; t ;; end) end module Make_with_hashable (T : sig module Elt : Elt val hashable : Elt.t Hashtbl.Hashable.t end) = struct include Make_plain_with_hashable (T) include Provide_of_sexp (T.Elt) end module Make_binable_with_hashable (T : sig module Elt : Elt_binable val hashable : Elt.t Hashtbl.Hashable.t end) = struct include Make_with_hashable (T) include Provide_bin_io (T.Elt) end module Make_plain (Elt : Elt_plain) = Make_plain_with_hashable (struct module Elt = Elt let hashable = Hashtbl.Hashable.of_key (module Elt) end) module Make (Elt : Elt) = struct include Make_plain (Elt) include Provide_of_sexp (Elt) end module Make_binable (Elt : Elt_binable) = struct include Make (Elt) include Provide_bin_io (Elt) end module Using_hashable = struct type 'a elt = 'a let create ?growth_allowed ?size ~hashable () = create ?growth_allowed ?size (Base.Hashable.to_key hashable) ;; let of_list ?growth_allowed ?size ~hashable l = of_list ?growth_allowed ?size (Base.Hashable.to_key hashable) l ;; end let hashable = Private.hashable let create ?growth_allowed ?size m = create ?growth_allowed ?size m let quickcheck_generator_m__t (type key) (module Key : M_quickcheck with type t = key) = [%quickcheck.generator: Key.t List0.t] |> Quickcheck.Generator.map ~f:(of_list (module Key)) ;; let quickcheck_observer_m__t (type key) (module Key : M_quickcheck with type t = key) = [%quickcheck.observer: Key.t List0.t] |> Quickcheck.Observer.unmap ~f:to_list ;; let quickcheck_shrinker_m__t (type key) (module Key : M_quickcheck with type t = key) = [%quickcheck.shrinker: Key.t List0.t] |> Quickcheck.Shrinker.map ~f:(of_list (module Key)) ~f_inverse:to_list ;; core-0.15.0/core/src/hash_set.mli000066400000000000000000000000371420273305200165430ustar00rootroot00000000000000include Hash_set_intf.Hash_set core-0.15.0/core/src/hash_set_intf.ml000066400000000000000000000073701420273305200174210ustar00rootroot00000000000000(** A mutable set of elements. *) open! Import module Binable = Binable0 open Base.Hash_set module type M_quickcheck = sig type t [@@deriving compare, hash, quickcheck, sexp_of] end module type For_deriving = sig include For_deriving module type M_quickcheck = M_quickcheck val quickcheck_generator_m__t : (module M_quickcheck with type t = 'key) -> 'key t Base_quickcheck.Generator.t val quickcheck_observer_m__t : (module M_quickcheck with type t = 'key) -> 'key t Base_quickcheck.Observer.t val quickcheck_shrinker_m__t : (module M_quickcheck with type t = 'key) -> 'key t Base_quickcheck.Shrinker.t end module type S_plain = sig type elt type 'a hash_set type t = elt hash_set [@@deriving equal, sexp_of] include Creators_generic with type 'a t := t with type 'a elt := elt with type ('a, 'z) create_options := ('a, 'z) create_options_without_first_class_module module Provide_of_sexp (X : sig type t [@@deriving of_sexp] end with type t := elt) : sig type t [@@deriving of_sexp] end with type t := t module Provide_bin_io (X : sig type t [@@deriving bin_io] end with type t := elt) : sig type t [@@deriving bin_io] end with type t := t end module type S = sig include S_plain include sig type t [@@deriving of_sexp] end with type t := t end module type S_binable = sig include S include Binable.S with type t := t end type ('key, 'z) create_options_with_hashable_required = ('key, unit, 'z) Hashtbl_intf.create_options_with_hashable module type Hash_set = sig type 'a t = 'a Base.Hash_set.t [@@deriving sexp_of] (** We use [[@@deriving sexp_of]] but not [[@@deriving sexp]] because we want people to be explicit about the hash and comparison functions used when creating hashtables. One can use [Hash_set.Poly.t], which does have [[@@deriving sexp]], to use polymorphic comparison and hashing. *) include Creators with type 'a t := 'a t include Accessors with type 'a t := 'a t with type 'a elt := 'a elt val hashable : 'key t -> 'key Hashtbl.Hashable.t module type Elt_plain = Hashtbl.Key_plain module type Elt = Hashtbl.Key module type Elt_binable = Hashtbl.Key_binable module type S_plain = S_plain with type 'a hash_set := 'a t module type S = S with type 'a hash_set := 'a t module type S_binable = S_binable with type 'a hash_set := 'a t module Using_hashable : sig include Creators_generic with type 'a t := 'a t with type 'a elt = 'a with type ('key, 'z) create_options := ('key, 'z) create_options_with_hashable_required end (** A hash set that uses polymorphic comparison. *) module Poly : sig type nonrec 'a t = 'a t [@@deriving sexp] include Creators_generic with type 'a t := 'a t with type 'a elt = 'a with type ('key, 'z) create_options := ('key, 'z) create_options_without_first_class_module include Accessors with type 'a t := 'a t with type 'a elt := 'a elt end module Make_plain (Elt : Elt_plain) : S_plain with type elt = Elt.t module Make (Elt : Elt) : S with type elt = Elt.t module Make_binable (Elt : Elt_binable) : S_binable with type elt = Elt.t module Make_plain_with_hashable (T : sig module Elt : Elt_plain val hashable : Elt.t Hashtbl.Hashable.t end) : S_plain with type elt = T.Elt.t module Make_with_hashable (T : sig module Elt : Elt val hashable : Elt.t Hashtbl.Hashable.t end) : S with type elt = T.Elt.t module Make_binable_with_hashable (T : sig module Elt : Elt_binable val hashable : Elt.t Hashtbl.Hashable.t end) : S_binable with type elt = T.Elt.t include For_deriving with type 'a t := 'a t end core-0.15.0/core/src/hashable.ml000066400000000000000000000102201420273305200163360ustar00rootroot00000000000000(** Functors and interfaces used to make modules hashable. *) open! Import include Hashable_intf module Make_plain (T : sig type t [@@deriving hash] include Hashtbl.Key_plain with type t := t end) : S_plain with type t := T.t = struct include T module Table = Hashtbl.Make_plain (T) module Hash_set = Hash_set.Make_plain (T) module Hash_queue = Hash_queue.Make (T) let hashable = Table.hashable end module Make_plain_and_derive_hash_fold_t (T : Hashtbl.Key_plain) : S_plain with type t := T.t = Make_plain (struct include T let hash_fold_t state t = hash_fold_int state (hash t) end) module Make (T : sig type t [@@deriving hash] include Hashtbl.Key with type t := t end) : S with type t := T.t = struct include T module Table = Hashtbl.Make (T) module Hash_set = Hash_set.Make (T) module Hash_queue = Hash_queue.Make (T) let hashable = Table.hashable end module Make_and_derive_hash_fold_t (T : Hashtbl.Key) : S with type t := T.t = Make (struct include T let hash_fold_t state t = hash_fold_int state (hash t) end) module Make_binable (T : sig type t [@@deriving hash] include Hashtbl.Key_binable with type t := t end) : S_binable with type t := T.t = struct module Table = Hashtbl.Make_binable (T) module Hash_set = Hash_set.Make_binable (T) module Hash_queue = Hash_queue.Make (T) include T let hashable = Table.hashable end module Make_plain_with_hashable (T : sig module Key : sig type t [@@deriving hash] include Hashtbl.Key_plain with type t := t end val hashable : Key.t Hashtbl_intf.Hashable.t end) : S_plain with type t := T.Key.t = struct include T.Key module Table = Hashtbl.Make_plain_with_hashable (T) module Hash_set = Hash_set.Make_plain_with_hashable (struct module Elt = T.Key let hashable = T.hashable end) module Hash_queue = Hash_queue.Make_with_hashable (T) let hashable = T.hashable end module Make_with_hashable (T : sig module Key : sig type t [@@deriving hash] include Hashtbl.Key with type t := t end val hashable : Key.t Hashtbl_intf.Hashable.t end) : S with type t := T.Key.t = struct include T.Key module Table = Hashtbl.Make_with_hashable (T) module Hash_set = Hash_set.Make_with_hashable (struct module Elt = T.Key let hashable = T.hashable end) module Hash_queue = Hash_queue.Make_with_hashable (T) let hashable = T.hashable end module Make_binable_with_hashable (T : sig module Key : sig type t [@@deriving hash] include Hashtbl.Key_binable with type t := t end val hashable : Key.t Hashtbl_intf.Hashable.t end) : S_binable with type t := T.Key.t = struct module Table = Hashtbl.Make_binable_with_hashable (T) module Hash_set = Hash_set.Make_binable_with_hashable (struct module Elt = T.Key let hashable = T.hashable end) module Hash_queue = Hash_queue.Make_with_hashable (T) include T.Key let hashable = T.hashable end module Make_binable_and_derive_hash_fold_t (T : Hashtbl.Key_binable) : S_binable with type t := T.t = Make_binable (struct include T let hash_fold_t state t = hash_fold_int state (hash t) end) module Stable = struct module V1 = struct module type S = sig type key module Table : sig type 'a t = (key, 'a) Hashtbl.t [@@deriving sexp, bin_io] end module Hash_set : sig type t = key Hash_set.t [@@deriving sexp, bin_io] end val hashable : key Hashtbl.Hashable.t end module Make (Key : Hashtbl.Key_binable) : S with type key := Key.t = struct module Table = Hashtbl.Make_binable (Key) module Hash_set = Hash_set.Make_binable (Key) let hashable = Table.hashable end module Make_with_hashable (T : sig module Key : Hashtbl.Key_binable val hashable : Key.t Hashtbl_intf.Hashable.t end) : S with type key := T.Key.t = struct module Table = Hashtbl.Make_binable_with_hashable (T) module Hash_set = Hash_set.Make_binable_with_hashable (struct module Elt = T.Key let hashable = T.hashable end) let hashable = T.hashable end end end core-0.15.0/core/src/hashable.mli000066400000000000000000000000371420273305200165140ustar00rootroot00000000000000include Hashable_intf.Hashable core-0.15.0/core/src/hashable_intf.ml000066400000000000000000000057021420273305200173670ustar00rootroot00000000000000open! Import module type Common = sig type t [@@deriving compare, hash] val hashable : t Hashtbl.Hashable.t end module type S_plain = sig include Common module Table : Hashtbl.S_plain with type key = t module Hash_set : Hash_set.S_plain with type elt = t module Hash_queue : Hash_queue.S with type key = t end module type S = sig include Common module Table : Hashtbl.S with type key = t module Hash_set : Hash_set.S with type elt = t module Hash_queue : Hash_queue.S with type key = t end module type S_binable = sig type t [@@deriving hash] val hashable : t Hashtbl.Hashable.t module Table : Hashtbl.S_binable with type key = t module Hash_set : Hash_set.S_binable with type elt = t module Hash_queue : Hash_queue.S with type key = t end module type Hashable = sig module type Common = Common module type S = S module type S_binable = S_binable module type S_plain = S_plain module Make_plain (T : sig type t [@@deriving hash] include Hashtbl.Key_plain with type t := t end) : S_plain with type t := T.t module Make_plain_and_derive_hash_fold_t (T : Hashtbl.Key_plain) : S_plain with type t := T.t module Make (T : sig type t [@@deriving hash] include Hashtbl.Key with type t := t end) : S with type t := T.t module Make_and_derive_hash_fold_t (T : Hashtbl.Key) : S with type t := T.t module Make_binable (T : sig type t [@@deriving hash] include Hashtbl.Key_binable with type t := t end) : S_binable with type t := T.t module Make_plain_with_hashable (T : sig module Key : sig type t [@@deriving hash] include Hashtbl.Key_plain with type t := t end val hashable : Key.t Hashtbl.Hashable.t end) : S_plain with type t := T.Key.t module Make_with_hashable (T : sig module Key : sig type t [@@deriving hash] include Hashtbl.Key with type t := t end val hashable : Key.t Hashtbl.Hashable.t end) : S with type t := T.Key.t module Make_binable_with_hashable (T : sig module Key : sig type t [@@deriving hash] include Hashtbl.Key_binable with type t := t end val hashable : Key.t Hashtbl.Hashable.t end) : S_binable with type t := T.Key.t module Make_binable_and_derive_hash_fold_t (T : Hashtbl.Key_binable) : S_binable with type t := T.t module Stable : sig module V1 : sig module type S = sig type key module Table : sig type 'a t = (key, 'a) Hashtbl.t [@@deriving sexp, bin_io] end module Hash_set : sig type t = key Hash_set.t [@@deriving sexp, bin_io] end val hashable : key Hashtbl.Hashable.t end module Make (Key : Hashtbl.Key_binable) : S with type key := Key.t module Make_with_hashable (T : sig module Key : Hashtbl.Key_binable val hashable : Key.t Hashtbl.Hashable.t end) : S with type key := T.Key.t end end end core-0.15.0/core/src/hashtbl.ml000066400000000000000000000166411420273305200162310ustar00rootroot00000000000000open! Import open Hashtbl_intf module Hashable = Hashtbl_intf.Hashable module Merge_into_action = Hashtbl_intf.Merge_into_action module List = List0 let failwiths = Error.failwiths module Creators = Hashtbl.Creators include ( Hashtbl : sig type ('a, 'b) t = ('a, 'b) Hashtbl.t [@@deriving sexp_of] include Base.Hashtbl.S_without_submodules with type ('a, 'b) t := ('a, 'b) t end) let validate ~name f t = Validate.alist ~name f (to_alist t) module Using_hashable = struct type nonrec ('a, 'b) t = ('a, 'b) t [@@deriving sexp_of] let create ?growth_allowed ?size ~hashable () = create ?growth_allowed ?size (Base.Hashable.to_key hashable) ;; let of_alist ?growth_allowed ?size ~hashable l = of_alist ?growth_allowed ?size (Base.Hashable.to_key hashable) l ;; let of_alist_report_all_dups ?growth_allowed ?size ~hashable l = of_alist_report_all_dups ?growth_allowed ?size (Base.Hashable.to_key hashable) l ;; let of_alist_or_error ?growth_allowed ?size ~hashable l = of_alist_or_error ?growth_allowed ?size (Base.Hashable.to_key hashable) l ;; let of_alist_exn ?growth_allowed ?size ~hashable l = of_alist_exn ?growth_allowed ?size (Base.Hashable.to_key hashable) l ;; let of_alist_multi ?growth_allowed ?size ~hashable l = of_alist_multi ?growth_allowed ?size (Base.Hashable.to_key hashable) l ;; let create_mapped ?growth_allowed ?size ~hashable ~get_key ~get_data l = create_mapped ?growth_allowed ?size (Base.Hashable.to_key hashable) ~get_key ~get_data l ;; let create_with_key ?growth_allowed ?size ~hashable ~get_key l = create_with_key ?growth_allowed ?size (Base.Hashable.to_key hashable) ~get_key l ;; let create_with_key_or_error ?growth_allowed ?size ~hashable ~get_key l = create_with_key_or_error ?growth_allowed ?size (Base.Hashable.to_key hashable) ~get_key l ;; let create_with_key_exn ?growth_allowed ?size ~hashable ~get_key l = create_with_key_exn ?growth_allowed ?size (Base.Hashable.to_key hashable) ~get_key l ;; let group ?growth_allowed ?size ~hashable ~get_key ~get_data ~combine l = group ?growth_allowed ?size (Base.Hashable.to_key hashable) ~get_key ~get_data ~combine l ;; end module type S_plain = S_plain with type ('a, 'b) hashtbl = ('a, 'b) t module type S = S with type ('a, 'b) hashtbl = ('a, 'b) t module type S_binable = S_binable with type ('a, 'b) hashtbl = ('a, 'b) t module type Key_plain = Key_plain module type Key = Key module type Key_binable = Key_binable module Poly = struct include Hashtbl.Poly let validate = validate include Bin_prot.Utils.Make_iterable_binable2 (struct type nonrec ('a, 'b) t = ('a, 'b) t type ('a, 'b) el = 'a * 'b [@@deriving bin_io] let caller_identity = Bin_prot.Shape.Uuid.of_string "8f3e445c-4992-11e6-a279-3703be311e7b" ;; let module_name = Some "Core.Hashtbl" let length = length let iter t ~f = iteri t ~f:(fun ~key ~data -> f (key, data)) let init ~len ~next = let t = create ~size:len () in for _i = 0 to len - 1 do let key, data = next () in match find t key with | None -> set t ~key ~data | Some _ -> failwith "Core_hashtbl.bin_read_t_: duplicate key" done; t ;; end) end module Make_plain_with_hashable (T : sig module Key : Key_plain val hashable : Key.t Hashable.t end) = struct let hashable = T.hashable type key = T.Key.t type ('a, 'b) hashtbl = ('a, 'b) t type 'a t = (T.Key.t, 'a) hashtbl type ('a, 'b) t__ = (T.Key.t, 'b) hashtbl type 'a key_ = T.Key.t include Creators (struct type 'a t = T.Key.t let hashable = hashable end) include ( Hashtbl : sig include Hashtbl.Accessors with type ('a, 'b) t := ('a, 'b) t__ with type 'a key := 'a key_ include Hashtbl.Multi with type ('a, 'b) t := ('a, 'b) t__ with type 'a key := 'a key_ include Invariant.S2 with type ('a, 'b) t := ('a, 'b) hashtbl end) let validate = validate let invariant invariant_key t = invariant ignore invariant_key t let sexp_of_t sexp_of_v t = Poly.sexp_of_t T.Key.sexp_of_t sexp_of_v t module Provide_of_sexp (Key : sig type t [@@deriving of_sexp] end with type t := key) = struct let t_of_sexp v_of_sexp sexp = t_of_sexp Key.t_of_sexp v_of_sexp sexp end module Provide_bin_io (Key' : sig type t [@@deriving bin_io] end with type t := key) = Bin_prot.Utils.Make_iterable_binable1 (struct module Key = struct include T.Key include Key' end type nonrec 'a t = 'a t type 'a el = Key.t * 'a [@@deriving bin_io] let caller_identity = Bin_prot.Shape.Uuid.of_string "8fabab0a-4992-11e6-8cca-9ba2c4686d9e" ;; let module_name = Some "Core.Hashtbl" let length = length let iter t ~f = iteri t ~f:(fun ~key ~data -> f (key, data)) let init ~len ~next = let t = create ~size:len () in for _i = 0 to len - 1 do let key, data = next () in match find t key with | None -> set t ~key ~data | Some _ -> failwiths ~here:[%here] "Hashtbl.bin_read_t: duplicate key" key [%sexp_of: Key.t] done; t ;; end) end module Make_with_hashable (T : sig module Key : Key val hashable : Key.t Hashable.t end) = struct include Make_plain_with_hashable (T) include Provide_of_sexp (T.Key) end module Make_binable_with_hashable (T : sig module Key : Key_binable val hashable : Key.t Hashable.t end) = struct include Make_with_hashable (T) include Provide_bin_io (T.Key) end module Make_plain (Key : Key_plain) = Make_plain_with_hashable (struct module Key = Key let hashable = { Hashable.hash = Key.hash; compare = Key.compare; sexp_of_t = Key.sexp_of_t } ;; end) module Make (Key : Key) = struct include Make_plain (Key) include Provide_of_sexp (Key) end module Make_binable (Key : Key_binable) = struct include Make (Key) include Provide_bin_io (Key) end module M = Hashtbl.M module type For_deriving = For_deriving module For_deriving : For_deriving with type ('a, 'b) t := ('a, 'b) t = struct include (Hashtbl : Hashtbl.For_deriving with type ('a, 'b) t := ('a, 'b) t) module type M_quickcheck = M_quickcheck let of_alist_option m alist = Result.ok (of_alist_or_error m alist) let quickcheck_generator_m__t (type key) (module Key : M_quickcheck with type t = key) quickcheck_generator_data = [%quickcheck.generator: (Key.t * data) List.t] |> Quickcheck.Generator.filter_map ~f:(of_alist_option (module Key)) ;; let quickcheck_observer_m__t (type key) (module Key : M_quickcheck with type t = key) quickcheck_observer_data = [%quickcheck.observer: (Key.t * data) List.t] |> Quickcheck.Observer.unmap ~f:to_alist ;; let quickcheck_shrinker_m__t (type key) (module Key : M_quickcheck with type t = key) quickcheck_shrinker_data = [%quickcheck.shrinker: (Key.t * data) List.t] |> Quickcheck.Shrinker.filter_map ~f:(of_alist_option (module Key)) ~f_inverse:to_alist ;; end include For_deriving let hashable = Hashtbl.Private.hashable core-0.15.0/core/src/hashtbl.mli000066400000000000000000000001511420273305200163670ustar00rootroot00000000000000open! Import include Hashtbl_intf.Hashtbl with type ('a, 'b) t = ('a, 'b) Base.Hashtbl.t (** @inline *) core-0.15.0/core/src/hashtbl_intf.ml000066400000000000000000000210671420273305200172470ustar00rootroot00000000000000(** Hashtbl is a reimplementation of the standard {{: https://caml.inria.fr/pub/docs/manual-ocaml/libref/MoreLabels.Hashtbl.html}[MoreLabels.Hashtbl]}. Its worst case time complexity is O(log(N)) for lookups and additions, unlike the standard [MoreLabels.Hashtbl], which is O(N). A hash table is implemented as an array of AVL trees (see [Avltree]). If [growth_allowed] (default true) is false then [size] is the final size of the array; the table can always hold more elements than [size], but they will all go into tree nodes. If it is true (default) then the array will double in size when the number of elements in the table reaches twice the size of the array. When this happens, all existing elements will be reinserted, which can take a long time. If you care about latency, set [size] and [growth_allowed=false] if possible. In most cases, functions passed as arguments to hash table accessors must not mutate the hash table while it is being accessed, as this will result in an exception. For example, [iter] and [change] take a function [f] which must not modify [t]. In a few cases, mutation is allowed, such as in [Hashtbl.find_and_call], where all access to [t] is finished before the [~if_found] and [~if_not_found] arguments are invoked. We have three kinds of hash table modules: - [Hashtbl] - [Hashtbl.Poly] - [Key.Table] (a class of similar modules) There are three kinds of hash-table functions: - creation from nothing ([create], [of_alist]) - sexp converters ([t_of_sexp], [sexp_of_t], and [bin_io] too) - accessors and mappers ([fold], [mem], [find], [map], [filter_map], ...) Here is a table showing what classes of functions are available in each kind of hash-table module: {v creation sexp-conv accessors Hashtbl X Hashtbl.Poly X X Key.Table X X X' v} The entry marked with [X'] is there for historical reasons, and may be eliminated at some point. The upshot is that one should use [Hashtbl] for accessors, [Hashtbl.Poly] for hash-table creation and sexp conversion using polymorphic compare/hash, and [Key.Table] for hash-table creation and sexp conversion using [Key.compare] and [Key.hash]. {2:usage Usage} For many students of OCaml, using hashtables is complicated by the functors. Here are a few tips: {ol {- For a list of hashtable functions see {!Core.Hashtbl_intf.S}.} {- To create a hashtable with string keys use [String.Table]: {[ let table = String.Table.create () ~size:4 in List.iter ~f:(fun (key, data) -> Hashtbl.set table ~key ~data) [ ("A", 1); ("B", 2); ("C", 3); ]; Hashtbl.find table "C" ]} Here 4 need only be a guess at the hashtable's future size. There are other similar pre-made hashtables, e.g., [Int63.Table] or [Host_and_port.Table]. } {- To create a hashtable with a custom key type use Hashable: {[ module Key = struct module T = struct type t = String.t * Int63.t [@@deriving compare, hash, sexp] end include T include Hashable.Make (T) end let table = Key.Table.create () ~size:4 in List.iter ~f:(fun (key, data) -> Hashtbl.set table ~key ~data) [ (("pi", Int63.zero), 3.14159); (("e", Int63.minus_one), 2.71828); (("Euler", Int63.one), 0.577215); ]; Hashtbl.find table ("pi", Int63.zero) ]} Performance {i may} improve if you define [equal] and [hash] explicitly, e.g.: {[ let equal (x, y) (x', y') = String.(=) x x' && Int63.(=) y y' let hash (x, y) = String.hash x + Int63.hash y * 65599 ]} } } *) open! Import module Binable = Binable0 module Hashtbl = Base.Hashtbl module type Key_plain = Hashtbl.Key.S module Hashable = Base.Hashable module Merge_into_action = Base.Hashtbl.Merge_into_action module type Hashable = Base.Hashable.Hashable module type Key = sig type t [@@deriving sexp] include Key_plain with type t := t end module type Key_binable = sig type t [@@deriving bin_io, sexp] include Key with type t := t end module type Creators = Hashtbl.Private.Creators_generic module type Accessors = sig include Hashtbl.Accessors val validate : name:('a key -> string) -> 'b Validate.check -> ('a, 'b) t Validate.check end module type Multi = Hashtbl.Multi type ('key, 'data, 'z) create_options_with_first_class_module = ('key, 'data, 'z) Hashtbl.create_options type ('key, 'data, 'z) create_options_without_hashable = ('key, 'data, 'z) Hashtbl.Private.create_options_without_first_class_module type ('key, 'data, 'z) create_options_with_hashable = ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 0 *) -> hashable:'key Hashable.t -> 'z module type M_quickcheck = sig type t [@@deriving compare, hash, quickcheck, sexp_of] end module type For_deriving = sig include Base.Hashtbl.For_deriving module type M_quickcheck = M_quickcheck val quickcheck_generator_m__t : (module M_quickcheck with type t = 'k) -> 'v Base_quickcheck.Generator.t -> ('k, 'v) t Quickcheck.Generator.t val quickcheck_observer_m__t : (module M_quickcheck with type t = 'k) -> 'v Quickcheck.Observer.t -> ('k, 'v) t Quickcheck.Observer.t val quickcheck_shrinker_m__t : (module M_quickcheck with type t = 'k) -> 'v Quickcheck.Shrinker.t -> ('k, 'v) t Quickcheck.Shrinker.t end module type S_plain = sig type key type ('a, 'b) hashtbl type 'b t = (key, 'b) hashtbl [@@deriving equal, sexp_of] type ('a, 'b) t_ = 'b t type 'a key_ = key val hashable : key Hashable.t include Invariant.S1 with type 'b t := 'b t include Creators with type ('a, 'b) t := ('a, 'b) t_ with type 'a key := 'a key_ with type ('key, 'data, 'z) create_options := ('key, 'data, 'z) create_options_without_hashable include Accessors with type ('a, 'b) t := ('a, 'b) t_ with type 'a key := 'a key_ include Multi with type ('a, 'b) t := ('a, 'b) t_ with type 'a key := 'a key_ module Provide_of_sexp (Key : sig type t [@@deriving of_sexp] end with type t := key) : sig type _ t [@@deriving of_sexp] end with type 'a t := 'a t module Provide_bin_io (Key : sig type t [@@deriving bin_io] end with type t := key) : sig type 'a t [@@deriving bin_io] end with type 'a t := 'a t end module type S = sig include S_plain include sig type _ t [@@deriving of_sexp] end with type 'a t := 'a t end module type S_binable = sig include S include Binable.S1 with type 'v t := 'v t end module type Hashtbl = sig include Hashtbl.S_without_submodules (** @inline *) val validate : name:('a key -> string) -> 'b Validate.check -> ('a, 'b) t Validate.check module Using_hashable : sig include Creators with type ('a, 'b) t := ('a, 'b) t with type 'a key := 'a key with type ('a, 'b, 'z) create_options := ('a, 'b, 'z) create_options_with_hashable end module Poly : sig type nonrec ('a, 'b) t = ('a, 'b) t [@@deriving bin_io] include Hashtbl.S_poly with type ('a, 'b) t := ('a, 'b) t val validate : name:('a key -> string) -> 'b Validate.check -> ('a, 'b) t Validate.check end module type Key_plain = Key_plain module type Key = Key module type Key_binable = Key_binable module type S_plain = S_plain with type ('a, 'b) hashtbl = ('a, 'b) t module type S = S with type ('a, 'b) hashtbl = ('a, 'b) t module type S_binable = S_binable with type ('a, 'b) hashtbl = ('a, 'b) t module Make_plain (Key : Key_plain) : S_plain with type key = Key.t module Make (Key : Key) : S with type key = Key.t module Make_binable (Key : Key_binable) : S_binable with type key = Key.t module Make_plain_with_hashable (T : sig module Key : Key_plain val hashable : Key.t Hashable.t end) : S_plain with type key = T.Key.t module Make_with_hashable (T : sig module Key : Key val hashable : Key.t Hashable.t end) : S with type key = T.Key.t module Make_binable_with_hashable (T : sig module Key : Key_binable val hashable : Key.t Hashable.t end) : S_binable with type key = T.Key.t module M (K : T.T) : sig type nonrec 'v t = (K.t, 'v) t end module Hashable = Hashable module Merge_into_action = Merge_into_action val hashable : ('key, _) t -> 'key Hashable.t module type For_deriving = For_deriving include For_deriving with type ('a, 'b) t := ('a, 'b) t end core-0.15.0/core/src/heap_block.ml000066400000000000000000000010051420273305200166570ustar00rootroot00000000000000open! Import type 'a t = 'a [@@deriving sexp_of] external is_heap_block : Caml.Obj.t -> bool = "core_heap_block_is_heap_block" [@@noalloc] let is_ok v = is_heap_block (Caml.Obj.repr v) let create v = if is_ok v then Some v else None let create_exn v = if is_ok v then v else failwith "Heap_block.create_exn called with non heap block" ;; let value t = t let bytes_per_word = Word_size.(num_bits word_size) / 8 let bytes (type a) (t : a t) = (Caml.Obj.size (Caml.Obj.repr (t : a t)) + 1) * bytes_per_word ;; core-0.15.0/core/src/heap_block.mli000066400000000000000000000033101420273305200170310ustar00rootroot00000000000000(** A heap block is a value that is guaranteed to live on the OCaml heap, and is hence guaranteed to be usable with finalization or in a weak pointer. It is an abstract type so we can use the type system to guarantee that the values we put in weak pointers and use with finalizers are heap blocks. 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 optimizations may duplicate some immutable values, for example floating-point numbers when stored into arrays; thus they can be finalized and collected while another copy is still in use by the program. The results of calling {!String.make}, {!Bytes.create}, {!Bytes.make}, {!Array.make}, and {!Pervasives.ref} are guaranteed to be heap-allocated and non-constant except when the length argument is [0]. *) open! Import type +'a t = private 'a [@@deriving sexp_of] (** [create v] returns [Some t] if [v] is a heap block, where [t] is physically equal to [v]. *) val create : 'a -> 'a t option val create_exn : 'a -> 'a t (** [value t] returns the value that is physically equal to [t]. *) val value : 'a t -> 'a (** [bytes t] returns the number of bytes on the heap taken by heap block [t], including the header. This is just the space for the single block, not anything it points to. *) val bytes : _ t -> int core-0.15.0/core/src/heap_block_stubs.c000066400000000000000000000004721420273305200177200ustar00rootroot00000000000000#include #include CAMLprim value core_heap_block_is_heap_block(value v) { return (Is_block(v) && Is_in_value_area(v) && Tag_val (v) != Lazy_tag && Tag_val (v) != Double_tag && Tag_val (v) != Forward_tag) ? Val_true : Val_false; } core-0.15.0/core/src/hexdump.ml000066400000000000000000000116611420273305200162530ustar00rootroot00000000000000open! Import module Char = Base.Char module Int = Base.Int module String = Base.String include Hexdump_intf let bytes_per_line = 16 (* Initialize to enough lines to display 4096 bytes -- large enough that, for example, a complete Ethernet packet can always be displayed -- including the line containing the final index. *) let default_max_lines = ref ((4096 / bytes_per_line) + 1) module Of_indexable2 (T : Indexable2) = struct module Hexdump = struct include T let hex_of_pos pos = Printf.sprintf "%08x" pos let hex_of_char t ~start ~until offset = let pos = start + offset in if pos >= until then " " else Printf.sprintf "%02x" (Char.to_int (get t pos)) ;; let hex_of_line t ~start ~until = Printf.sprintf "%s %s %s %s %s %s %s %s %s %s %s %s %s %s %s %s" (hex_of_char t ~start ~until 0) (hex_of_char t ~start ~until 1) (hex_of_char t ~start ~until 2) (hex_of_char t ~start ~until 3) (hex_of_char t ~start ~until 4) (hex_of_char t ~start ~until 5) (hex_of_char t ~start ~until 6) (hex_of_char t ~start ~until 7) (hex_of_char t ~start ~until 8) (hex_of_char t ~start ~until 9) (hex_of_char t ~start ~until 10) (hex_of_char t ~start ~until 11) (hex_of_char t ~start ~until 12) (hex_of_char t ~start ~until 13) (hex_of_char t ~start ~until 14) (hex_of_char t ~start ~until 15) ;; let printable_string t ~start ~until = String.init (until - start) ~f:(fun i -> let char = get t (start + i) in if Char.is_print char then char else '.') ;; let line t ~pos ~len ~line_index = let start = pos + (line_index * bytes_per_line) in let until = min (start + bytes_per_line) (pos + len) in Printf.sprintf "%s %s |%s|" (hex_of_pos start) (hex_of_line t ~start ~until) (printable_string t ~start ~until) ;; let to_sequence ?max_lines ?pos ?len t = let pos, len = Ordered_collection_common.get_pos_len_exn () ?pos ?len ~total_length:(length t) in let max_lines = match max_lines with | Some max_lines -> max_lines | None -> !default_max_lines in (* always produce at least 3 lines: first line of hex, ellipsis, last line of hex *) let max_lines = max max_lines 3 in (* unabridged lines = lines of hex + line with final index *) let unabridged_lines = Int.round_up len ~to_multiple_of:bytes_per_line / bytes_per_line in (* Figure out where we need to skip from and to if [max_lines < unabridged_lines]. Skip after half the actual hex lines (subtracting one line for the ellipsis). Skip to near the end, less the number of lines remaining to produce, plus the ellipsis line. *) let skip_from = (max_lines - 1) / 2 in let skip_to = unabridged_lines - (max_lines - skip_from) + 1 in Sequence.unfold_step ~init:0 ~f:(fun line_index -> if line_index >= unabridged_lines then Done else if line_index = skip_from && max_lines < unabridged_lines then Yield ("...", skip_to) else Yield (line t ~pos ~len ~line_index, line_index + 1)) ;; let to_string_hum ?max_lines ?pos ?len t = to_sequence ?max_lines ?pos ?len t |> Sequence.to_list |> String.concat ~sep:"\n" ;; let sexp_of_t _ _ t = to_sequence t |> Sequence.to_list |> [%sexp_of: string list] module Pretty = struct include T let printable = let rec printable_from t ~pos ~length = pos >= length || (Char.is_print (get t pos) && printable_from t ~pos:(pos + 1) ~length) in fun t -> printable_from t ~pos:0 ~length:(length t) ;; let to_string t = String.init (length t) ~f:(fun pos -> get t pos) let sexp_of_t sexp_of_a sexp_of_b t = if printable t then [%sexp (to_string t : string)] else [%sexp (t : (a, b) t)] ;; end end end module Of_indexable1 (T : Indexable1) = struct module M = Of_indexable2 (struct type ('a, _) t = 'a T.t let length = T.length let get = T.get end) module Hexdump = struct include T let sexp_of_t x t = M.Hexdump.sexp_of_t x [%sexp_of: _] t let to_sequence = M.Hexdump.to_sequence let to_string_hum = M.Hexdump.to_string_hum module Pretty = struct include T let sexp_of_t sexp_of_a t = [%sexp (t : (a, _) M.Hexdump.Pretty.t)] end end end module Of_indexable (T : Indexable) = struct module M = Of_indexable1 (struct type _ t = T.t let length = T.length let get = T.get end) module Hexdump = struct include T let sexp_of_t t = M.Hexdump.sexp_of_t [%sexp_of: _] t let to_sequence = M.Hexdump.to_sequence let to_string_hum = M.Hexdump.to_string_hum module Pretty = struct include T let sexp_of_t t = [%sexp (t : _ M.Hexdump.Pretty.t)] end end end core-0.15.0/core/src/hexdump.mli000066400000000000000000000000541420273305200164160ustar00rootroot00000000000000include Hexdump_intf.Hexdump (** @inline *) core-0.15.0/core/src/hexdump_intf.ml000066400000000000000000000101121420273305200172610ustar00rootroot00000000000000(** A functor for displaying a type as a sequence of ASCII characters printed in hexadecimal. [sexp_of_t] and [to_string_hum] print [t] in a similar format to 'hexdump' on Unix systems. For example, the string "Back off, man, I'm a scientist." renders as: {v 00000000 42 61 63 6b 20 6f 66 66 2c 20 6d 61 6e 2c 20 49 |Back off, man, I| 00000010 27 6d 20 61 20 73 63 69 65 6e 74 69 73 74 2e |'m a scientist.| v} [to_sequence] produces a sequence of strings representing lines in the hex dump. It can be used to process a hex dump incrementally, for example with potentially infinite values, or to avoid keeping the entire output in memory at once. *) open! Import module type S = sig type t module Hexdump : sig type nonrec t = t [@@deriving sexp_of] (** [to_string_hum] renders [t] as a multi-line ASCII string in hexdump format. [pos] and [len] select a subrange of [t] to render. [max_lines] determines the maximum number of lines of hex dump to produce. If the full hex dump exceeds this number, lines in the middle are replaced by a single "..."; the beginning and end of the hex dump are left intact. In order to produce at least some readable hex dump, at least 3 lines are always produced. *) val to_string_hum : ?max_lines:int (** default: [!default_max_lines] *) -> ?pos:int -> ?len:int -> t -> string (** [to_sequence] produces the lines of [to_string_hum] as a sequence of strings. This may be useful for incrementally rendering a large hex dump without producing the whole thing in memory. Optional arguments function as in [to_string_hum]. *) val to_sequence : ?max_lines:int (** default: [!default_max_lines] *) -> ?pos:int -> ?len:int -> t -> string Sequence.t (** [[%sexp_of: Hexdump.Pretty.t]] is the same as [[%sexp_of: Hexdump.t]], unless the underlying sequence of characters is entirely printable. In that case, it is rendered directly as a string. This allows e.g. test output to be much more compact in the common (printable) case while still being interpretable for any byte sequence. *) module Pretty : sig type nonrec t = t [@@deriving sexp_of] end end end module type S1 = sig type _ t module Hexdump : sig type nonrec 'a t = 'a t [@@deriving sexp_of] val to_string_hum : ?max_lines:int -> ?pos:int -> ?len:int -> _ t -> string val to_sequence : ?max_lines:int -> ?pos:int -> ?len:int -> _ t -> string Sequence.t module Pretty : sig type nonrec 'a t = 'a t [@@deriving sexp_of] end end end module type S2 = sig type (_, _) t module Hexdump : sig type nonrec ('a, 'b) t = ('a, 'b) t [@@deriving sexp_of] val to_string_hum : ?max_lines:int -> ?pos:int -> ?len:int -> (_, _) t -> string val to_sequence : ?max_lines:int -> ?pos:int -> ?len:int -> (_, _) t -> string Sequence.t module Pretty : sig type nonrec ('a, 'b) t = ('a, 'b) t [@@deriving sexp_of] end end end (** The functor [Hexdump.Of_indexable] uses [length] and [get] to iterate over the characters in a value and produce a hex dump. *) module type Indexable = sig type t val length : t -> int val get : t -> int -> char end module type Indexable1 = sig type _ t val length : _ t -> int val get : _ t -> int -> char end module type Indexable2 = sig type (_, _) t val length : (_, _) t -> int val get : (_, _) t -> int -> char end module type Hexdump = sig module type Indexable = Indexable module type Indexable1 = Indexable1 module type Indexable2 = Indexable2 module type S = S module type S1 = S1 module type S2 = S2 (** Can be used to override the default [~lines] argument for [to_string_hum] and [to_sequence] in [S]. *) val default_max_lines : int ref module Of_indexable (T : Indexable) : S with type t := T.t module Of_indexable1 (T : Indexable1) : S1 with type 'a t := 'a T.t module Of_indexable2 (T : Indexable2) : S2 with type ('a, 'b) t := ('a, 'b) T.t end core-0.15.0/core/src/host_and_port.ml000066400000000000000000000065051420273305200174450ustar00rootroot00000000000000module Stable = struct open Stable_internal module V1 = struct module Serializable = struct type t = string * int [@@deriving sexp, bin_io] end module T0 = struct type t = { host : String.t ; port : Int.t } [@@deriving compare, equal, hash, quickcheck] let to_serializable { host; port } = host, port let of_serializable (host, port) = { host; port } end module T1 = struct include T0 include Binable.Stable.Of_binable.V1 [@alert "-legacy"] (Serializable) (struct include T0 let to_binable = to_serializable let of_binable = of_serializable end) let%expect_test "stable" = print_endline [%bin_digest: t]; print_endline [%bin_digest: Serializable.t]; [%expect {| 957990f0fc4161fb874e66872550fb40 957990f0fc4161fb874e66872550fb40 |}] ;; include Sexpable.Stable.Of_sexpable.V1 (Serializable) (struct include T0 let to_sexpable = to_serializable let of_sexpable = of_serializable end) open! Import open! Std_internal open! T0 let to_string { host; port } = sprintf "%s:%d" host port let of_string s = match String.split s ~on:':' with | [ host; port ] -> let port = try Int.of_string port with | _exn -> failwithf "Host_and_port.of_string: bad port: %s" s () in { host; port } | _ -> failwithf "Host_and_port.of_string: %s" s () ;; let t_of_sexp = function | Sexp.Atom s as sexp -> (try of_string s with | Failure err -> of_sexp_error err sexp) | sexp -> t_of_sexp sexp ;; let t_sexp_grammar = Sexplib.Sexp_grammar. { untyped = Union [ (* handles the host:port string case *) String ; (* handles the list (host port) case *) List (Cons (String, Cons (Integer, Empty))) ] } ;; include (val Comparator.Stable.V1.make ~compare ~sexp_of_t) end include T1 include Comparable.Stable.V1.Make (T1) let%test_unit "t_of_sexp" = [%test_result: t] (t_of_sexp (Sexp.of_string {|(localhost 8080)|})) ~expect:{ host = "localhost"; port = 8080 }; [%test_result: t] (t_of_sexp (Sexp.of_string {|localhost:8080|})) ~expect:{ host = "localhost"; port = 8080 } ;; let%test_unit "sexp roundtrip" = Quickcheck.test [%quickcheck.generator: t] ~f:(fun t -> [%test_result: t] (t_of_sexp (sexp_of_t t)) ~expect:t) ;; end end open! Import open! Std_internal module Latest = struct include Stable.V1 end include Latest let create ~host ~port = { host; port } let host t = t.host let port t = t.port let tuple t = to_serializable t include Pretty_printer.Register (struct type nonrec t = t let to_string = to_string let module_name = "Core.Host_and_port" end) include (Hashable.Make_binable (Latest) : Hashable.S_binable with type t := t) include Comparable.Make_binable_using_comparator (Latest) let type_id = Type_equal.Id.create ~name:"Host_and_port" sexp_of_t core-0.15.0/core/src/host_and_port.mli000066400000000000000000000012271420273305200176120ustar00rootroot00000000000000(** Type for the commonly-used notion of host and port in networking. *) open Std_internal type t = { host : string ; port : int } [@@deriving hash] val create : host:string -> port:int -> t val host : t -> string val port : t -> int val tuple : t -> string * int include Identifiable with type t := t module Stable : sig module V1 : sig type nonrec t = t [@@deriving sexp, sexp_grammar, bin_io, compare, equal, hash, quickcheck] include Base.Stringable.S with type t := t include Stable_comparable.V1 with type t := t and type comparator_witness = comparator_witness end end val type_id : t Type_equal.Id.t core-0.15.0/core/src/identifiable.ml000066400000000000000000000043141420273305200172150ustar00rootroot00000000000000open! Import include Identifiable_intf module Binable = Binable0 module Make_plain (T : sig type t [@@deriving compare, hash, sexp_of] include Stringable.S with type t := t val module_name : string end) = struct include T include Comparable.Make_plain (T) include Hashable.Make_plain (T) include Pretty_printer.Register (T) end module Make (T : sig type t [@@deriving bin_io, compare, hash, sexp] include Stringable.S with type t := t val module_name : string end) = struct include T include Comparable.Make_binable (T) include Hashable.Make_binable (T) include Pretty_printer.Register (T) end module Make_with_sexp_grammar (T : sig type t [@@deriving bin_io, compare, hash, sexp, sexp_grammar] include Stringable.S with type t := t val module_name : string end) = struct include T include Make (T) end module Make_and_derive_hash_fold_t (T : sig type t [@@deriving bin_io, compare, sexp] include Stringable.S with type t := t val hash : t -> int val module_name : string end) = Make (struct include T let hash_fold_t state t = hash_fold_int state (hash t) end) module Make_using_comparator (T : sig type t [@@deriving bin_io, compare, hash, sexp] include Comparator.S with type t := t include Stringable.S with type t := t val module_name : string end) = struct include T include Comparable.Make_binable_using_comparator (T) include Hashable.Make_binable (T) include Pretty_printer.Register (T) end module Make_using_comparator_and_derive_hash_fold_t (T : sig type t [@@deriving bin_io, compare, sexp] include Comparator.S with type t := t include Stringable.S with type t := t val hash : t -> int val module_name : string end) = Make_using_comparator (struct include T let hash_fold_t state t = hash_fold_int state (hash t) end) module Extend (M : Base.Identifiable.S) (B : Binable0.S with type t = M.t) = struct module T = struct include M include (B : Binable.S with type t := t) end include T include Comparable.Extend_binable (M) (T) include Hashable.Make_binable_with_hashable (struct module Key = T let hashable = M.hashable end) end core-0.15.0/core/src/identifiable.mli000066400000000000000000000000661420273305200173660ustar00rootroot00000000000000include Identifiable_intf.Identifiable (** @inline *) core-0.15.0/core/src/identifiable_intf.ml000066400000000000000000000064461420273305200202450ustar00rootroot00000000000000(** Signatures and functors for making types that are used as identifiers. *) open! Import module type S_common = sig type t [@@deriving compare, hash, sexp_of] include Stringable.S with type t := t include Pretty_printer.S with type t := t end module type S_plain = sig include S_common include Comparable.S_plain with type t := t include Hashable.S_plain with type t := t end module type S_not_binable = sig type t [@@deriving hash, sexp] include S_common with type t := t include Comparable.S with type t := t include Hashable.S with type t := t end module type S = sig type t [@@deriving bin_io, hash, sexp] include S_common with type t := t include Comparable.S_binable with type t := t include Hashable.S_binable with type t := t end module type S_sexp_grammar = sig type t [@@deriving sexp_grammar] include S with type t := t end module type Identifiable = sig module type S_common = S_common module type S_plain = S_plain module type S_not_binable = S_not_binable module type S = S module type S_sexp_grammar = S_sexp_grammar module Make_plain (M : sig type t [@@deriving compare, hash, sexp_of] include Stringable.S with type t := t (** for registering the pretty printer *) val module_name : string end) : S_plain with type t := M.t (** Used for making an Identifiable module. Here's an example: {[ module Id = struct module T = struct type t = A | B [@@deriving bin_io, compare, hash, sexp] include Sexpable.To_stringable (struct type nonrec t = t [@@deriving sexp] end) let module_name = "My_library.Id" end include T include Identifiable.Make (T) end ]} *) module Make (M : sig type t [@@deriving bin_io, compare, hash, sexp] include Stringable.S with type t := t (** for registering the pretty printer *) val module_name : string end) : S with type t := M.t module Make_with_sexp_grammar (M : sig type t [@@deriving bin_io, compare, hash, sexp, sexp_grammar] include Stringable.S with type t := t (** for registering the pretty printer *) val module_name : string end) : S_sexp_grammar with type t := M.t module Make_and_derive_hash_fold_t (M : sig type t [@@deriving bin_io, compare, sexp] include Stringable.S with type t := t val hash : t -> int (** for registering the pretty printer *) val module_name : string end) : S with type t := M.t module Make_using_comparator (M : sig type t [@@deriving bin_io, compare, hash, sexp] include Comparator.S with type t := t include Stringable.S with type t := t val module_name : string end) : S with type t := M.t with type comparator_witness := M.comparator_witness module Make_using_comparator_and_derive_hash_fold_t (M : sig type t [@@deriving bin_io, compare, sexp] include Comparator.S with type t := t include Stringable.S with type t := t val hash : t -> int val module_name : string end) : S with type t := M.t with type comparator_witness := M.comparator_witness module Extend (M : Base.Identifiable.S) (B : Binable0.S with type t = M.t) : S with type t := M.t with type comparator_witness := M.comparator_witness end core-0.15.0/core/src/immediate_option.ml000066400000000000000000000000361420273305200201210ustar00rootroot00000000000000include Immediate_option_intf core-0.15.0/core/src/immediate_option.mli000066400000000000000000000000761420273305200202760ustar00rootroot00000000000000include Immediate_option_intf.Immediate_option (** @inline *) core-0.15.0/core/src/immediate_option_intf.ml000066400000000000000000000063521420273305200211500ustar00rootroot00000000000000(** A non-allocating alternative to the standard Option type. *) open! Import module type S_without_immediate_plain = sig (** The immediate value carried by the immediate option. Given the presence of {!unchecked_value}, the [value] type should not have operations that depend on the value's validity for memory safety. In particular, [unchecked_value] is not called [unsafe_value] as it would be if it could return a value that later resulted in a segmentation fault. For pointer-like values, use {!Ext.Nullable}, for example. *) type value (** Represents [value option] without allocating a [Some] tag. The interface does not enforce that [t] is immediate because some types, like [Int63.t], are only immediate on 64-bit platforms. For representations whose type is immediate, use [S] below which adds the [[@@immediate]] annotation. *) type t (** Constructors analogous to [None] and [Some]. If [not (some_is_representable x)] then [some x] may raise or return [none]. *) val none : t val some : value -> t (** For some representations of immediate options, the encodings of [none] and [some] overlap. For these representations, [some_is_representable value = false] if [value] cannot be represented as an option. For example, [Int.Option] uses [min_value] to represent [none]. For other representations, [some_is_representable] always returns [true]. *) val some_is_representable : value -> bool val is_none : t -> bool val is_some : t -> bool (** [value (some x) ~default = x] and [value none ~default = default]. *) val value : t -> default:value -> value (** [value_exn (some x) = x]. [value_exn none] raises. Unlike [Option.value_exn], there is no [?message] argument, so that calls to [value_exn] that do not raise also do not have to allocate. *) val value_exn : t -> value (** [unchecked_value (some x) = x]. [unchecked_value none] returns an unspecified value. [unchecked_value t] is intended as an optimization of [value_exn t] when [is_some t] is known to be true. *) val unchecked_value : t -> value val to_option : t -> value option val of_option : value option -> t module Optional_syntax : Optional_syntax.S with type t := t with type value := value end module type S_without_immediate = sig type t [@@deriving compare, hash, sexp_of, typerep] include S_without_immediate_plain with type t := t end module type S_plain = sig type t [@@immediate] include S_without_immediate_plain with type t := t end module type S = sig type t [@@immediate] include S_without_immediate with type t := t end module type S_int63 = sig type t [@@immediate64] include S_without_immediate with type t := t end module type S_int63_plain = sig type t [@@immediate64] include S_without_immediate_plain with type t := t end module type Immediate_option = sig (** Always immediate. *) module type S = S module type S_plain = S_plain (** Immediate only on 64-bit machines. *) module type S_int63 = S_int63 module type S_int63_plain = S_int63_plain (** Never immediate. *) module type S_without_immediate = S_without_immediate module type S_without_immediate_plain = S_without_immediate_plain end core-0.15.0/core/src/import.ml000066400000000000000000000074351420273305200161170ustar00rootroot00000000000000 (* We do not [include Base] here, and instead import modules that [Core] doesn't extend, because we want code in [Core] to be clear when it references a [Base] module that [Core] is overriding. *) module Applicative = Base.Applicative module Avltree = Base.Avltree module Backtrace = Base.Backtrace module Binary_search = Base.Binary_search module Comparisons = Base.Comparisons module Continue_or_stop = Base.Continue_or_stop module Equal = Base.Equal module Exn = Base.Exn module Floatable = Base.Floatable module Formatter = Base.Formatter module Hash = Base.Hash module Hasher = Base.Hasher module Indexed_container = Base.Indexed_container module Intable = Base.Intable module Int_conversions = Base.Int_conversions module Int_math = Base.Int_math module Invariant = Base.Invariant module Monad = Base.Monad module Poly = Base.Poly module Popcount = Base.Popcount [@@warning "-3"] [@@deprecated "[since 2018-10] use [popcount] functions in individual int modules"] module Pretty_printer = Base.Pretty_printer module Random = Base.Random module Staged = Base.Staged module Stringable = Base.Stringable module Sys = Base.Sys module Uchar = Base.Uchar module With_return = Base.With_return module Word_size = Base.Word_size (* We do include [Base]'s top-level value and type bindings, because they don't cause any confusion, and duplicating them would be error prone. *) include Base.Export include Stdio include Base_for_tests include Bin_prot.Std module Field = Fieldslib.Field module From_sexplib : sig type bigstring = Sexplib.Conv.bigstring [@@deriving sexp] type mat = Sexplib.Conv.mat [@@deriving sexp] type vec = Sexplib.Conv.vec [@@deriving sexp] (* [sexp_of_opaque] and [opaque_of_sexp] are used by the code generated from [[@@deriving sexp]], [[%sexp_of: ]], and [[%of_sexp: ]]. The type [_ sexp_opaque] expands to uses of [sexp_of_opaque] and [opaque_of_sexp]. *) val sexp_of_opaque : _ -> Base.Sexp.t val opaque_of_sexp : Base.Sexp.t -> _ val sexp_of_pair : ('a -> Base.Sexp.t) -> ('b -> Base.Sexp.t) -> 'a * 'b -> Base.Sexp.t val pair_of_sexp : (Base.Sexp.t -> 'a) -> (Base.Sexp.t -> 'b) -> Base.Sexp.t -> 'a * 'b exception Of_sexp_error of exn * Base.Sexp.t val of_sexp_error : string -> Base.Sexp.t -> _ val of_sexp_error_exn : exn -> Base.Sexp.t -> _ end = Sexplib.Conv include From_sexplib (* [sexp_opaque] indicates to [ppx_sexp_conv] that a value should be rendered as [_], i.e. [Sexp.Atom "_"]. Here we expose the [@@deriving] aspects of [sexp_opaque] so that other ppx's treat [sexp_opaque] correctly, by ignoring it and processing the underlying type. *) include ( struct type 'a sexp_opaque = 'a [@@deriving bin_io, compare, hash, typerep] end : sig type 'a sexp_opaque [@@deriving bin_io, compare, hash, typerep] end with type 'a sexp_opaque := 'a) include ( Typerep_lib.Std : module type of struct include Typerep_lib.Std end with module Type_equal := Typerep_lib.Std.Type_equal) module Variant = Variantslib.Variant let with_return = With_return.with_return let am_running_inline_test = Ppx_inline_test_lib.Runtime.am_running_inline_test let am_running_test = try ignore (Caml.Sys.getenv "TESTING_FRAMEWORK" : string); true with (* [Caml.*] never raises [Not_found_s] *) | Caml.Not_found -> false ;; type 'a identity = 'a module Not_found = struct exception Not_found = Not_found [@deprecated {|[since 2018-02] Instead of raising [Not_found], consider using [raise_s] with an informative error message. If code needs to distinguish [Not_found] from other exceptions, please change it to handle both [Not_found] and [Not_found_s]. Then, instead of raising [Not_found], raise [Not_found_s] with an informative error message.|}] exception Not_found_s = Base.Not_found_s end include Not_found core-0.15.0/core/src/index.mld000066400000000000000000000016511420273305200160520ustar00rootroot00000000000000{0 Core} {b {{!Core} The full API is browsable here}}. {!Core} is an industrial-strength alternative to the OCaml standard library. It was developed by Jane Street, which is the largest industrial user of OCaml. Core works with Javascript. It provides an overlay on the usual namespace, so the best way to use it is to start your file with: {[open! Core]} {1 Relationship between Core and Base} In sum: - {b {!Base}}: Minimal stdlib replacement. Portable and lightweight and intended to be highly stable. - {b {!Core}}: Extension of Base. More fully featured, with more code and dependencies, and APIs that evolve more quickly. Portable, and works on Javascript. Many of Core's modules are extensions of modules in Base, where the Core version adds bin_io support or locks in an API with Stable. Some modules, like {{!Core.Map} Map}, extend their Base equivalents to follow Core conventions for the use of comparators. core-0.15.0/core/src/info.ml000066400000000000000000000067161420273305200155410ustar00rootroot00000000000000(* This module is trying to minimize dependencies on modules in Core, so as to allow [Info], [Error], and [Or_error] to be used in is many places places as possible. Please avoid adding new dependencies. *) open! Import open! Info_intf module type S = Base.Info.S module Source_code_position = Source_code_position0 module Binable = Binable0 module Sexp = struct include Sexplib.Sexp include ( struct type t = Base.Sexp.t = | Atom of string | List of t list [@@deriving bin_io, compare, hash] end : sig type t [@@deriving bin_io, compare, hash] end with type t := t) end module Binable_exn = struct module Stable = struct module V1 = struct module T = struct type t = exn [@@deriving sexp_of] end include T include Binable.Stable.Of_binable.V1 [@alert "-legacy"] (Sexp) (struct include T let to_binable t = t |> [%sexp_of: t] let of_binable = Exn.create_s end) end end end module Extend (Info : Base.Info.S) = struct include Info module Internal_repr = struct module Stable = struct module Binable_exn = Binable_exn.Stable module Source_code_position = struct module V1 = struct type t = Source_code_position.Stable.V1.t [@@deriving bin_io] (* [sexp_of_t] as defined here is unstable; this is OK because there is no [t_of_sexp]. [sexp_of_t] is only used to produce a sexp that is never deserialized as a [Source_code_position]. *) let sexp_of_t = Source_code_position.sexp_of_t end end module V2 = struct type t = Info.Internal_repr.t = | Could_not_construct of Sexp.t | String of string | Exn of Binable_exn.V1.t | Sexp of Sexp.t | Tag_sexp of string * Sexp.t * Source_code_position.V1.t option | Tag_t of string * t | Tag_arg of string * Sexp.t * t | Of_list of int option * t list | With_backtrace of t * string (* backtrace *) [@@deriving bin_io, sexp_of] end end include Stable.V2 let to_info = Info.Internal_repr.to_info let of_info = Info.Internal_repr.of_info end module Stable = struct module V2 = struct module T = struct type t = Info.t [@@deriving sexp, compare, hash] end include T include Comparator.Stable.V1.Make (T) include Binable.Stable.Of_binable.V1 [@alert "-legacy"] (Internal_repr.Stable.V2) (struct type nonrec t = t let to_binable = Info.Internal_repr.of_info let of_binable = Info.Internal_repr.to_info end) end module V1 = struct module T = struct type t = Info.t [@@deriving compare] include Sexpable.Stable.Of_sexpable.V1 (Sexp) (struct type nonrec t = t let to_sexpable = Info.sexp_of_t let of_sexpable = Info.t_of_sexp end) let compare = compare end include T include Comparator.Stable.V1.Make (T) include Binable.Stable.Of_binable.V1 [@alert "-legacy"] (Sexp) (struct type nonrec t = t let to_binable = sexp_of_t let of_binable = t_of_sexp end) end end type t = Stable.V2.t [@@deriving bin_io] end include Extend (Base.Info) core-0.15.0/core/src/info.mli000066400000000000000000000002261420273305200157000ustar00rootroot00000000000000(** This module extends {{!Base.Info}[Base.Info]}, which provides a type for info-level debug messages. *) include Info_intf.Info (** @inline *) core-0.15.0/core/src/info_intf.ml000066400000000000000000000015331420273305200165510ustar00rootroot00000000000000open! Import (** Extension to the base signature *) module type Extension = sig type t [@@deriving bin_io] module Stable : sig (** [Info.t] is wire-compatible with [V2.t], but not [V1.t]. [V1] bin-prots a sexp of the underlying message, whereas [V2] bin-prots the underlying message. *) module V1 : Stable_module_types.S0 with type t = t module V2 : sig type nonrec t = t [@@deriving hash] include Stable_module_types.S0 with type t := t end end end module type S = sig include Base.Info.S include Extension with type t := t end module type Info = sig (** @inline *) include module type of struct include Base.Info end module Internal_repr : module type of Base.Info.Internal_repr include Extension with type t := t module Extend (Info : Base.Info.S) : Extension with type t := Info.t end core-0.15.0/core/src/int.ml000066400000000000000000000021541420273305200153700ustar00rootroot00000000000000open! Import module Stable = struct module V1 = struct module T = struct include Base.Int type t = int [@@deriving hash, bin_io, sexp] end include T include Comparable.Stable.V1.Make (T) end end include Identifiable.Extend (Base.Int) (struct type t = int [@@deriving bin_io] end) module Replace_polymorphic_compare = Base.Int include Base.Int include Comparable.Validate_with_zero (Base.Int) (* This is already defined by Comparable.Validate_with_zero, but Sign.of_int is more direct. *) let sign = Sign.of_int type t = int [@@deriving typerep] module Hex = struct include Hex type nonrec t = t [@@deriving typerep, bin_io] end let quickcheck_generator = Base_quickcheck.Generator.int let quickcheck_observer = Base_quickcheck.Observer.int let quickcheck_shrinker = Base_quickcheck.Shrinker.int let gen_incl = Base_quickcheck.Generator.int_inclusive let gen_uniform_incl = Base_quickcheck.Generator.int_uniform_inclusive let gen_log_incl = Base_quickcheck.Generator.int_log_inclusive let gen_log_uniform_incl = Base_quickcheck.Generator.int_log_uniform_inclusive core-0.15.0/core/src/int.mli000066400000000000000000000007711420273305200155440ustar00rootroot00000000000000(** This module extends {{!Base.Int}[Base.Int]}. *) include Base.Int.Int_without_module_types (** @inline *) (** Note that [int] is already stable by itself, since as a primitive type it is an integral part of the sexp / bin_io protocol. [Int.Stable] exists only to introduce [Int.Stable.Set] and [Int.Stable.Map], and provide interface uniformity with other stable types. *) include Int_intf.Extension_with_stable with type t := t and type comparator_witness := comparator_witness core-0.15.0/core/src/int32.ml000066400000000000000000000014021420273305200155300ustar00rootroot00000000000000open! Import include Identifiable.Extend (Base.Int32) (struct type t = int32 [@@deriving bin_io] end) include Base.Int32 include Comparable.Validate_with_zero (Base.Int32) type t = int32 [@@deriving typerep] module Hex = struct include Hex type nonrec t = t [@@deriving typerep, bin_io] end let quickcheck_generator = Base_quickcheck.Generator.int32 let quickcheck_observer = Base_quickcheck.Observer.int32 let quickcheck_shrinker = Base_quickcheck.Shrinker.int32 let gen_incl = Base_quickcheck.Generator.int32_inclusive let gen_uniform_incl = Base_quickcheck.Generator.int32_uniform_inclusive let gen_log_incl = Base_quickcheck.Generator.int32_log_inclusive let gen_log_uniform_incl = Base_quickcheck.Generator.int32_log_uniform_inclusive core-0.15.0/core/src/int32.mli000066400000000000000000000004461420273305200157100ustar00rootroot00000000000000(** This module extends {{!Base.Int32}[Base.Int32]}. *) (** {2 Interface from Base} *) (** @inline *) include module type of struct include Base.Int32 end (** {2 Extensions} *) (** @inline *) include Int_intf.Extension with type t := t and type comparator_witness := comparator_witness core-0.15.0/core/src/int63.ml000066400000000000000000000043411420273305200155410ustar00rootroot00000000000000open! Import module Bin : Binable0.S with type t := Base.Int63.t = struct module Bin_emulated = struct type t = Base.Int63.Private.Emul.t include Binable0.Of_binable_without_uuid [@alert "-legacy"] (Int64) (struct type nonrec t = t let of_binable = Base.Int63.Private.Emul.W.wrap_exn let to_binable = Base.Int63.Private.Emul.W.unwrap end) end type 'a binable = (module Binable0.S with type t = 'a) let binable_of_repr : type a b. (a, b) Base.Int63.Private.Repr.t -> b binable = function | Base.Int63.Private.Repr.Int -> (module Int) | Base.Int63.Private.Repr.Int64 -> (module Bin_emulated) ;; let binable : Base.Int63.t binable = binable_of_repr Base.Int63.Private.repr include (val binable) let bin_shape_t = Bin_prot.Shape.bin_shape_int63 end module Stable = struct module V1 = struct module T = struct type t = Base.Int63.t [@@deriving hash, sexp] include Bin include ( Base.Int63 : Base.Comparable.S with type t := t with type comparator_witness = Base.Int63.comparator_witness) end include T include Comparable.Stable.V1.Make (T) end end (* This [include struct] is required because it lets us shadow [t] when we include [Base.Int63] later on. *) include struct type t = Base.Int63.t end let typerep_of_t = typerep_of_int63 let typename_of_t = typename_of_int63 include Identifiable.Extend (Base.Int63) (struct type nonrec t = t include Bin end) module Replace_polymorphic_compare : Comparable.Polymorphic_compare with type t := t = Base.Int63 include Base.Int63 include Comparable.Validate_with_zero (Base.Int63) module Hex = struct include Hex type nonrec t = t [@@deriving typerep, bin_io] end let quickcheck_generator = Base_quickcheck.Generator.int63 let quickcheck_observer = Base_quickcheck.Observer.int63 let quickcheck_shrinker = Base_quickcheck.Shrinker.int63 let gen_incl = Base_quickcheck.Generator.int63_inclusive let gen_uniform_incl = Base_quickcheck.Generator.int63_uniform_inclusive let gen_log_incl = Base_quickcheck.Generator.int63_log_inclusive let gen_log_uniform_incl = Base_quickcheck.Generator.int63_log_uniform_inclusive core-0.15.0/core/src/int63.mli000066400000000000000000000004671420273305200157170ustar00rootroot00000000000000(** This module extends {{!Base.Int63}[Base.Int63]}. *) (** {2 Interface from Base} *) (** @inline *) include module type of struct include Base.Int63 end (** {2 Extensions} *) (** @inline *) include Int_intf.Extension_with_stable with type t := t and type comparator_witness := comparator_witness core-0.15.0/core/src/int64.ml000066400000000000000000000014021420273305200155350ustar00rootroot00000000000000open! Import include Identifiable.Extend (Base.Int64) (struct type t = int64 [@@deriving bin_io] end) include Base.Int64 include Comparable.Validate_with_zero (Base.Int64) type t = int64 [@@deriving typerep] module Hex = struct include Hex type nonrec t = t [@@deriving typerep, bin_io] end let quickcheck_generator = Base_quickcheck.Generator.int64 let quickcheck_observer = Base_quickcheck.Observer.int64 let quickcheck_shrinker = Base_quickcheck.Shrinker.int64 let gen_incl = Base_quickcheck.Generator.int64_inclusive let gen_uniform_incl = Base_quickcheck.Generator.int64_uniform_inclusive let gen_log_incl = Base_quickcheck.Generator.int64_log_inclusive let gen_log_uniform_incl = Base_quickcheck.Generator.int64_log_uniform_inclusive core-0.15.0/core/src/int64.mli000066400000000000000000000004461420273305200157150ustar00rootroot00000000000000(** This module extends {{!Base.Int64}[Base.Int64]}. *) (** {2 Interface from Base} *) (** @inline *) include module type of struct include Base.Int64 end (** {2 Extensions} *) (** @inline *) include Int_intf.Extension with type t := t and type comparator_witness := comparator_witness core-0.15.0/core/src/int_intf.ml000066400000000000000000000023621420273305200164110ustar00rootroot00000000000000(** This module extends {{!Base.Int_intf}[Base.Int_intf]}. *) module type Round = Base.Int.Round module type Stable = sig module V1 : Stable_comparable.V1 end module type Hexable = sig type t module Hex : sig type nonrec t = t [@@deriving bin_io, sexp, sexp_grammar, compare, hash, typerep] include Base.Stringable.S with type t := t val to_string_hum : ?delimiter:char -> t -> string end (*_ Ensure that this module is an extension of [Base.Int.Hexable]. *) include Base.Int.Hexable with type t := t and module Hex := Hex end module type Extension = sig type t [@@deriving bin_io, typerep] include Hexable with type t := t include Identifiable.S with type t := t include Comparable.Validate_with_zero with type t := t include Quickcheckable.S_int with type t := t end module type S_unbounded = sig include Base.Int.S_unbounded include Extension with type t := t with type comparator_witness := comparator_witness end module type S = sig include Base.Int.S include Extension with type t := t with type comparator_witness := comparator_witness end module type Extension_with_stable = sig include Extension module Stable : Stable with type V1.t = t and type V1.comparator_witness = comparator_witness end core-0.15.0/core/src/interfaces.ml000066400000000000000000000020211420273305200167120ustar00rootroot00000000000000(** Various interface exports. *) open! Import module type Applicative = Applicative.S module type Binable = Binable0.S module type Comparable = Comparable.S module type Comparable_binable = Comparable.S_binable module type Floatable = Floatable.S module type Hashable = Hashable.S module type Hashable_binable = Hashable.S_binable module type Identifiable = Identifiable.S module type Infix_comparators = Comparable.Infix module type Intable = Intable.S module type Monad = Monad.S module type Quickcheckable = Quickcheckable.S module type Robustly_comparable = Robustly_comparable.S module type Sexpable = Sexpable.S module type Stable = Stable_module_types.S0 module type Stable_int63able = Stable_int63able.S module type Stable_without_comparator = Stable_module_types.S0_without_comparator module type Stable1 = Stable_module_types.S1 module type Stable2 = Stable_module_types.S2 module type Stable3 = Stable_module_types.S3 module type Stable4 = Stable_module_types.S4 module type Stringable = Stringable.S module type Unit = Unit.S core-0.15.0/core/src/lazy.ml000066400000000000000000000006061420273305200155550ustar00rootroot00000000000000open! Import open Base_quickcheck.Export module Stable = struct module V1 = struct open Sexplib.Std type 'a t = 'a lazy_t [@@deriving bin_io, quickcheck, sexp, typerep] let map = Base.Lazy.map let compare = Base.Lazy.compare end end module type Base_mask = module type of Base.Lazy with type 'a t := 'a Stable.V1.t include Stable.V1 include (Base.Lazy : Base_mask) core-0.15.0/core/src/lazy.mli000066400000000000000000000005101420273305200157200ustar00rootroot00000000000000(** This module extends {{!Base.Lazy}[Base.Lazy]}. *) open! Import type 'a t = 'a Base.Lazy.t [@@deriving bin_io, compare, hash, quickcheck, sexp, sexp_grammar, typerep] include module type of Base.Lazy with type 'a t := 'a t (** @inline *) module Stable : sig module V1 : Stable_module_types.S1 with type 'a t = 'a t end core-0.15.0/core/src/linked_queue.ml000066400000000000000000000013201420273305200172420ustar00rootroot00000000000000open! Import module Queue = Base.Linked_queue include Queue include Bin_prot.Utils.Make_iterable_binable1 (struct type 'a t = 'a Queue.t type 'a el = 'a [@@deriving bin_io] let caller_identity = Bin_prot.Shape.Uuid.of_string "800df9a0-4992-11e6-881d-ffe1a5c8aced" ;; let module_name = Some "Core.Linked_queue" let length = length let iter = iter (* Bin_prot reads the elements in the same order they were written out, as determined by [iter]. So, we can ignore the index and just enqueue each element as it is read in. *) let init ~len ~next = let t = create () in for _ = 1 to len do enqueue t (next ()) done; t ;; end) core-0.15.0/core/src/linked_queue.mli000066400000000000000000000007551420273305200174260ustar00rootroot00000000000000(** This module extends the {{!Base.Linked_queue}[Base.Linked_queue]} module with bin_io support. As a reminder, the [Base.Linked_queue] module is a wrapper around OCaml's standard [Queue] module that follows Base idioms and adds some functions. See also {!Core.Queue}, which has different performance characteristics. *) type 'a t = 'a Base.Linked_queue.t [@@deriving bin_io] (** @inline *) include module type of struct include Base.Linked_queue end with type 'a t := 'a t core-0.15.0/core/src/list.ml000066400000000000000000000033221420273305200155470ustar00rootroot00000000000000include List0 (** @inline *) (** [stable_dedup] Same as [dedup] but maintains the order of the list and doesn't allow compare function to be specified (otherwise, the implementation in terms of Set.t would hide a heavyweight functor instantiation at each call). *) let stable_dedup = Set.Poly.stable_dedup_list (* This function is staged to indicate that real work (the functor application) takes place after a partial application. *) let stable_dedup_staged (type a) ~(compare : a -> a -> int) : (a list -> a list) Base.Staged.t = let module Set = Set.Make (struct type t = a let compare = compare (* [stable_dedup_list] never calls these *) let t_of_sexp _ = assert false let sexp_of_t _ = assert false end) in Base.Staged.stage Set.stable_dedup_list ;; let zip_with_remainder = let rec zip_with_acc_and_remainder acc xs ys = match xs, ys with | [], [] -> rev acc, None | fst, [] -> rev acc, Some (Either.First fst) | [], snd -> rev acc, Some (Either.Second snd) | x :: xs, y :: ys -> zip_with_acc_and_remainder ((x, y) :: acc) xs ys in fun xs ys -> zip_with_acc_and_remainder [] xs ys ;; type sexp_thunk = unit -> Base.Sexp.t let sexp_of_sexp_thunk x = x () exception Duplicate_found of sexp_thunk * Base.String.t [@@deriving sexp] let exn_if_dup ~compare ?(context = "exn_if_dup") t ~to_sexp = match find_a_dup ~compare t with | None -> () | Some dup -> raise (Duplicate_found ((fun () -> to_sexp dup), context)) ;; let slice a start stop = Ordered_collection_common.slice ~length_fun:length ~sub_fun:sub a start stop ;; module Stable = struct module V1 = struct type nonrec 'a t = 'a t [@@deriving sexp, bin_io, compare] end end core-0.15.0/core/src/list.mli000066400000000000000000000076031420273305200157260ustar00rootroot00000000000000(** This module extends {{!Base.List}[Base.List]} with bin_io and quickcheck. *) open! Import (** {2 The interface from Base} *) (** @inline *) include module type of struct include Base.List end type 'a t = 'a list [@@deriving bin_io, typerep] module Assoc : sig type ('a, 'b) t = ('a, 'b) Base.List.Assoc.t [@@deriving bin_io] val compare : [%compare: 'a] -> [%compare: 'b] -> [%compare: ('a, 'b) t] [@@deprecated "[since 2016-06] This does not respect the equivalence class promised by List.Assoc.\n\ Use List.compare directly if that's what you want."] include module type of struct include Base.List.Assoc end with type ('a, 'b) t := ('a, 'b) t end (** {2 Extensions} *) (** [stable_dedup] Same as [dedup] but maintains the order of the list and doesn't allow compare function to be specified (otherwise, the implementation in terms of Set.t would hide a heavyweight functor instantiation at each call). This function is deprecated because it uses polymorphic comparison under the hood without being obvious to the caller. *) val stable_dedup : 'a t -> 'a t [@@deprecated "[since 2021-08] Use [Set.stable_dedup_list] or [stable_dedup_staged] instead."] (** [stable_dedup_staged] is the same as [dedup_and_sort] but maintains the order of the list. This function is staged because it instantiates a functor when [compare] is passed. See also [Set.stable_dedup_list], which is the underlying implementation of this function and lets you avoid the functor instantiation when you already have such a module on hand. *) val stable_dedup_staged : compare:('a -> 'a -> int) -> ('a list -> 'a list) Staged.t (** Only raised in [exn_if_dup] below. *) exception Duplicate_found of (unit -> Base.Sexp.t) * string [@deprecated "[since 2018-03] stop matching on Duplicate_found. [exn_if_dup] will eventually \ raise a different and unspecified exception"] (** [exn_if_dup ~compare ?context t ~to_sexp] raises if [t] contains a duplicate. It will specifically raise a [Duplicate_found] exception and use [context] as its second argument. O(n log n) time complexity. *) val exn_if_dup : compare:('a -> 'a -> int) -> ?context:string -> 'a t -> to_sexp:('a -> Base.Sexp.t) -> unit (** [slice t start stop] returns a new list including elements [t.(start)] through [t.(stop-1)], normalized Python-style with the exception that [stop = 0] is treated as [stop = length t]. *) val slice : 'a t -> int -> int -> 'a t include Comparator.Derived with type 'a t := 'a t include Quickcheckable.S1 with type 'a t := 'a t val to_string : f:('a -> string) -> 'a t -> string (** Like [gen], but never generates the empty list. *) val gen_non_empty : 'a Quickcheck.Generator.t -> 'a t Quickcheck.Generator.t (** Like [gen], but generates lists with the given length. *) val gen_with_length : int -> 'a Quickcheck.Generator.t -> 'a t Quickcheck.Generator.t (** Randomly drops elements from the input list. Length is chosen uniformly between 0 and the length of the input, inclusive. *) val gen_filtered : 'a t -> 'a t Quickcheck.Generator.t (** [gen_permutations t] generates all permutations of [list]. If [t] contains duplicate values, then [gen_permutations t] will produce duplicate lists. *) val gen_permutations : 'a t -> 'a t Quickcheck.Generator.t (** [zip_with_remainder xs ys] zips as many elements as possible of [xs] and [ys] together and also returns the un-zipped remainder of the longer input, if the inputs have different lengths. If [xs] and [ys] have the same length, [zip_with_remainder xs ys] returns the same thing as [(zip_exn xs ys, None)] *) val zip_with_remainder : 'a list -> 'b list -> ('a * 'b) list * ('a list, 'b list) Either.t option module Stable : sig module V1 : sig type nonrec 'a t = 'a t [@@deriving sexp, bin_io, compare] end end core-0.15.0/core/src/list0.ml000066400000000000000000000017071420273305200156340ustar00rootroot00000000000000open! Import open! Typerep_lib.Std include Base.List type 'a t = 'a list [@@deriving bin_io, typerep] module Assoc = struct include Assoc type ('a, 'b) t = ('a * 'b) list [@@deriving bin_io] let compare (type a b) compare_a compare_b = [%compare: (a * b) list] end let to_string ~f t = Sexplib.Sexp.to_string (sexp_of_t (fun x -> Sexplib.Sexp.Atom x) (map t ~f)) ;; include Comparator.Derived (struct type nonrec 'a t = 'a t [@@deriving sexp_of, compare] end) let quickcheck_generator = Base_quickcheck.Generator.list let gen_non_empty = Base_quickcheck.Generator.list_non_empty let gen_with_length length quickcheck_generator = Base_quickcheck.Generator.list_with_length quickcheck_generator ~length ;; let gen_filtered = Base_quickcheck.Generator.list_filtered let gen_permutations = Base_quickcheck.Generator.list_permutations let quickcheck_observer = Base_quickcheck.Observer.list let quickcheck_shrinker = Base_quickcheck.Shrinker.list core-0.15.0/core/src/list0.mli000066400000000000000000000017101420273305200157770ustar00rootroot00000000000000open! Import include module type of struct include Base.List end type 'a t = 'a Base.List.t [@@deriving bin_io, typerep] include Comparator.Derived with type 'a t := 'a t include Quickcheckable.S1 with type 'a t := 'a t val to_string : f:('a -> string) -> 'a t -> string val gen_non_empty : 'a Quickcheck.Generator.t -> 'a t Quickcheck.Generator.t val gen_with_length : int -> 'a Quickcheck.Generator.t -> 'a t Quickcheck.Generator.t val gen_filtered : 'a t -> 'a t Quickcheck.Generator.t val gen_permutations : 'a t -> 'a t Quickcheck.Generator.t module Assoc : sig include module type of struct include Base.List.Assoc end type ('a, 'b) t = ('a, 'b) Base.List.Assoc.t [@@deriving bin_io] val compare : ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int [@@deprecated "[since 2016-06] This does not respect the equivalence class promised by \ List.Assoc. Use List.compare directly if that's what you want."] end core-0.15.0/core/src/make_stable.ml000066400000000000000000000047731420273305200170560ustar00rootroot00000000000000open Stable_module_types module Binable = Binable.Stable module Comparator = Comparator.Stable module Sexpable = Sexpable.Stable module Of_stable_format = struct module V1 (Stable_format : sig type t [@@deriving bin_io, sexp] end) (M : sig type t [@@deriving compare] val to_stable_format : t -> Stable_format.t val of_stable_format : Stable_format.t -> t end) : S0 with type t = M.t = struct module T1 = struct module T2 = struct include M let to_sexpable = to_stable_format let of_sexpable = of_stable_format let to_binable = to_stable_format let of_binable = of_stable_format end include T2 include Sexpable.Of_sexpable.V1 (Stable_format) (T2) include Binable.Of_binable.V1 [@alert "-legacy"] (Stable_format) (T2) end include T1 include Comparator.V1.Make (T1) end end module Of_stable_format1 = struct module V1 (Stable_format : sig type 'a t [@@deriving bin_io, sexp] end) (M : sig type 'a t [@@deriving compare] val map : 'a t -> f:('a -> 'b) -> 'b t val to_stable_format : 'a t -> 'a Stable_format.t val of_stable_format : 'a Stable_format.t -> 'a t end) : S1 with type 'a t = 'a M.t = struct module T = struct include M let to_sexpable = to_stable_format let of_sexpable = of_stable_format let to_binable = to_stable_format let of_binable = of_stable_format end include T include Sexpable.Of_sexpable1.V1 (Stable_format) (T) include Binable.Of_binable1.V1 [@alert "-legacy"] (Stable_format) (T) end end module Of_stable_format2 = struct module V1 (Stable_format : sig type ('a1, 'a2) t [@@deriving bin_io, sexp] end) (M : sig type ('a1, 'a2) t [@@deriving compare] val map : ('a1, 'a2) t -> f1:('a1 -> 'b1) -> f2:('a2 -> 'b2) -> ('b1, 'b2) t val to_stable_format : ('a1, 'a2) t -> ('a1, 'a2) Stable_format.t val of_stable_format : ('a1, 'a2) Stable_format.t -> ('a1, 'a2) t end) : S2 with type ('a1, 'a2) t = ('a1, 'a2) M.t = struct module T = struct include M let to_sexpable = to_stable_format let of_sexpable = of_stable_format let to_binable = to_stable_format let of_binable = of_stable_format end include T include Sexpable.Of_sexpable2.V1 (Stable_format) (T) include Binable.Of_binable2.V1 [@alert "-legacy"] (Stable_format) (T) end end core-0.15.0/core/src/make_stable.mli000066400000000000000000000023301420273305200172120ustar00rootroot00000000000000open! Import open Stable_module_types module Of_stable_format : sig module V1 (Stable_format : sig type t [@@deriving bin_io, sexp] end) (M : sig type t [@@deriving compare] val to_stable_format : t -> Stable_format.t val of_stable_format : Stable_format.t -> t end) : S0 with type t = M.t end module Of_stable_format1 : sig module V1 (Stable_format : sig type 'a t [@@deriving bin_io, sexp] end) (M : sig type 'a t [@@deriving compare] val map : 'a t -> f:('a -> 'b) -> 'b t val to_stable_format : 'a t -> 'a Stable_format.t val of_stable_format : 'a Stable_format.t -> 'a t end) : S1 with type 'a t = 'a M.t end module Of_stable_format2 : sig module V1 (Stable_format : sig type ('a1, 'a2) t [@@deriving bin_io, sexp] end) (M : sig type ('a1, 'a2) t [@@deriving compare] val map : ('a1, 'a2) t -> f1:('a1 -> 'b1) -> f2:('a2 -> 'b2) -> ('b1, 'b2) t val to_stable_format : ('a1, 'a2) t -> ('a1, 'a2) Stable_format.t val of_stable_format : ('a1, 'a2) Stable_format.t -> ('a1, 'a2) t end) : S2 with type ('a1, 'a2) t = ('a1, 'a2) M.t end core-0.15.0/core/src/make_substring.ml000066400000000000000000000156241420273305200176210ustar00rootroot00000000000000(* A substring is a contiguous sequence of characters in a string. We use a functor because we want substrings of [string] and [bigstring]. *) open! Import open Std_internal include Make_substring_intf type bigstring = Bigstring.t module Blit = struct type ('src, 'dst) t = ('src, 'dst) Blit.blito let string_bytes ~src ?src_pos ?src_len ~dst ?(dst_pos = 0) () = let src_pos, len = Ordered_collection_common.get_pos_len_exn () ?pos:src_pos ?len:src_len ~total_length:(String.length src) in Bytes.From_string.blit ~src ~src_pos ~len ~dst ~dst_pos ;; let string_string = string_bytes let bytes_bytes = Bytes.blito let string_bigstring = Bigstring.From_string.blito let bytes_bigstring = Bigstring.From_bytes.blito let bigstring_bigstring = Bigstring.blito let bigstring_string = Bigstring.To_bytes.blito let bigstring_bytes = Bigstring.To_bytes.blito end (* We can't call the base module [Base] because [@@deriving quickcheck] wants to access the [Base] library directly, and we'd be shadowing it. *) module F (Underlying : Base) : S with type base = Underlying.t = struct type base = Underlying.t type t = { base : Underlying.t ; pos : int ; len : int } [@@deriving quickcheck] (* note we override the generated [quickcheck_generator] below, once we've defined [create] *) (* {[ let invariant t = assert (0 <= t.pos); assert (0 <= t.len); assert (t.pos + t.len <= Base.length t.base); ;; ]} *) let base t = t.base let pos t = t.pos let length t = t.len let is_empty t = Int.equal t.len 0 let base_of_string s = let len = String.length s in let buf = Underlying.create len in Underlying.blit_from_string ~src:s ~dst:buf (); buf ;; let base_of_bigstring s = let len = Bigstring.length s in let buf = Underlying.create len in Underlying.blit_from_bigstring ~src:s ~dst:buf (); buf ;; let create ?pos ?len base = let pos, len = Ordered_collection_common.get_pos_len_exn () ?pos ?len ~total_length:(Underlying.length base) in { base; pos; len } ;; let quickcheck_generator = let open Quickcheck.Let_syntax in let%bind base = Underlying.quickcheck_generator in let base_len = Underlying.length base in let%bind len = Int.gen_uniform_incl 0 base_len in let%bind pos = Int.gen_uniform_incl 0 (base_len - len) in return (create ~pos ~len base) ;; let get_no_bounds_check t i = Underlying.get (base t) (pos t + i) let get t i = if i >= 0 && i < length t then get_no_bounds_check t i else raise (Invalid_argument "index out of bounds") ;; let sub ?pos ?len t = let pos, len = Ordered_collection_common.get_pos_len_exn () ?pos ?len ~total_length:(length t) in { base = t.base; pos = t.pos + pos; len } ;; module Make_arg = struct type nonrec t = t module Elt = Char let fold t ~init ~f = let rec go acc i = if i >= length t then acc else go (f acc (get t i)) (i + 1) in go init 0 ;; let iter = `Custom (fun t ~f -> for i = 0 to length t - 1 do f (get t i) done) ;; let foldi = `Custom (fun t ~init ~f -> let rec go acc i = if i >= length t then acc else go (f i acc (get_no_bounds_check t i)) (i + 1) in go init 0) ;; let iteri = `Custom (fun t ~f -> for i = 0 to length t - 1 do f i (get_no_bounds_check t i) done) ;; let length = `Custom length end module C = Indexed_container.Make0 (Make_arg) let fold = C.fold let iter = C.iter let fold_result = C.fold_result let fold_until = C.fold_until (* [C.to_list] has to construct then reverse the list *) let to_list t = List.init (length t) ~f:(get t) let to_array = C.to_array let find_map = C.find_map let find = C.find let exists = C.exists let for_all = C.for_all let mem = C.mem let count = C.count let sum = C.sum let min_elt = C.min_elt let max_elt = C.max_elt let foldi = C.foldi let iteri = C.iteri let existsi = C.existsi let for_alli = C.for_alli let counti = C.counti let findi = C.findi let find_mapi = C.find_mapi let wrap_sub_n t n ~name ~pos ~len ~on_error = if n < 0 then invalid_arg (name ^ " expecting nonnegative argument") else ( try sub t ~pos ~len with | _ -> on_error) ;; let drop_prefix t n = wrap_sub_n ~name:"drop_prefix" t n ~pos:n ~len:(length t - n) ~on_error:{ t with len = 0 } ;; let drop_suffix t n = wrap_sub_n ~name:"drop_suffix" t n ~pos:0 ~len:(length t - n) ~on_error:{ t with len = 0 } ;; let prefix t n = wrap_sub_n ~name:"prefix" t n ~pos:0 ~len:n ~on_error:t let suffix t n = wrap_sub_n ~name:"suffix" t n ~pos:(length t - n) ~len:n ~on_error:t let blit_to (type a) (blit : (Underlying.t, a) Blit.t) t ~dst ~dst_pos = blit ~src:t.base ~src_pos:t.pos ~src_len:t.len ~dst ~dst_pos () ;; let blit_to_string = blit_to Underlying.blit_to_bytes let blit_to_bytes = blit_to Underlying.blit_to_bytes let blit_to_bigstring = blit_to Underlying.blit_to_bigstring let blit_base = blit_to Underlying.blit let blit_from ~name (type a) (blit : (a, base) Blit.t) t ~src ~src_pos ~len = if len > t.len then failwithf "Substring.blit_from_%s len > substring length : %d > %d" name len t.len (); blit ~src ~src_pos ~src_len:len ~dst:t.base ~dst_pos:t.pos () ;; let blit_from_string = blit_from ~name:"string" Underlying.blit_from_string let blit_from_bigstring = blit_from ~name:"bigstring" Underlying.blit_from_bigstring let of_base base = { base; pos = 0; len = Underlying.length base } let of_string x = of_base (base_of_string x) let of_bigstring x = of_base (base_of_bigstring x) let make (type a) create (blit : (base, a) Blit.t) t = let dst = create t.len in blit ~src:t.base ~src_pos:t.pos ~src_len:t.len ~dst ~dst_pos:0 (); dst ;; let to_string x = Bytes.unsafe_to_string ~no_mutation_while_string_reachable:(make Bytes.create Underlying.blit_to_bytes x) ;; let to_bigstring = make Bigstring.create Underlying.blit_to_bigstring let concat_gen create_dst blit_dst ts = let len = List.fold ts ~init:0 ~f:(fun len t -> len + length t) in let dst = create_dst len in ignore (List.fold ts ~init:0 ~f:(fun dst_pos t -> blit_dst t ~dst ~dst_pos; dst_pos + length t) : int); dst ;; let concat ts = of_base (concat_gen Underlying.create blit_base ts) let concat_string ts = Bytes.unsafe_to_string ~no_mutation_while_string_reachable:(concat_gen Bytes.create blit_to_string ts) ;; let concat_bigstring ts = concat_gen Bigstring.create blit_to_bigstring ts end core-0.15.0/core/src/make_substring.mli000066400000000000000000000000531420273305200177600ustar00rootroot00000000000000include Make_substring_intf.Make_substring core-0.15.0/core/src/make_substring_intf.ml000066400000000000000000000023721420273305200206350ustar00rootroot00000000000000open! Import module type Base = sig type t [@@deriving quickcheck] val create : int -> t val length : t -> int val blit : (t, t) Blit.blito val blit_to_bytes : (t, bytes) Blit.blito val blit_to_bigstring : (t, bigstring) Blit.blito val blit_from_string : (string, t) Blit.blito val blit_from_bigstring : (bigstring, t) Blit.blito val blit_to_string : (t, bytes) Blit.blito [@@deprecated "[since 2017-10] use [blit_to_bytes] instead"] val get : t -> int -> char end module type S = Substring_intf.S module type Make_substring = sig module type Base = Base module type S = S type bigstring = Bigstring.t module Blit : sig type ('src, 'dst) t = ('src, 'dst) Blit.blito val string_string : (string, bytes) t [@@deprecated "[since 2017-10] use [string_bytes] instead"] val bigstring_string : (bigstring, bytes) t [@@deprecated "[since 2017-10] use [bigstring_bytes] instead"] val string_bytes : (string, bytes) t val bytes_bytes : (bytes, bytes) t val bigstring_bytes : (bigstring, bytes) t val string_bigstring : (string, bigstring) t val bytes_bigstring : (bytes, bigstring) t val bigstring_bigstring : (bigstring, bigstring) t end module F (Base : Base) : S with type base = Base.t end core-0.15.0/core/src/map.ml000066400000000000000000000551401420273305200153560ustar00rootroot00000000000000open! Import open Map_intf module List = List0 module Symmetric_diff_element = struct module Stable = struct module V1 = struct type ('k, 'v) t = 'k * [ `Left of 'v | `Right of 'v | `Unequal of 'v * 'v ] [@@deriving bin_io, compare, sexp] let%expect_test _ = print_endline [%bin_digest: (int, string) t]; [%expect {| 00674be9fe8dfe9e9ad476067d7d8101 |}] ;; let map (k, diff) ~f1 ~f2 = let k = f1 k in let diff = match diff with | `Left v -> `Left (f2 v) | `Right v -> `Right (f2 v) | `Unequal (v1, v2) -> `Unequal (f2 v1, f2 v2) in k, diff ;; let map_data t ~f = map t ~f1:Fn.id ~f2:f let left (_key, diff) = match diff with | `Left x | `Unequal (x, _) -> Some x | `Right _ -> None ;; let right (_key, diff) = match diff with | `Right x | `Unequal (_, x) -> Some x | `Left _ -> None ;; end end include Stable.V1 end module Merge_element = Base.Map.Merge_element module Continue_or_stop = Base.Map.Continue_or_stop module Finished_or_unfinished = Base.Map.Finished_or_unfinished type ('k, 'cmp) comparator = (module Comparator.S with type t = 'k and type comparator_witness = 'cmp) let to_comparator (type k cmp) ((module M) : (k, cmp) Comparator.Module.t) = M.comparator let of_comparator (type k cmp) comparator : (k, cmp) Comparator.Module.t = (module struct type t = k type comparator_witness = cmp let comparator = comparator end) ;; module For_quickcheck = struct let gen_tree ~comparator k_gen v_gen = Base_quickcheck.Generator.map_tree_using_comparator ~comparator k_gen v_gen ;; let quickcheck_generator ~comparator k_gen v_gen = Base_quickcheck.Generator.map_t_m (of_comparator comparator) k_gen v_gen ;; let obs_tree k_obs v_obs = Base_quickcheck.Observer.map_tree k_obs v_obs let shr_tree ~comparator k_shr v_shr = Base_quickcheck.Shrinker.map_tree_using_comparator ~comparator k_shr v_shr ;; end let quickcheck_generator = Base_quickcheck.Generator.map_t_m let quickcheck_observer = Base_quickcheck.Observer.map_t let quickcheck_shrinker = Base_quickcheck.Shrinker.map_t module Using_comparator = struct include Map.Using_comparator include For_quickcheck let of_hashtbl_exn ~comparator hashtbl = match of_iteri ~comparator ~iteri:(Hashtbl.iteri hashtbl) with | `Ok map -> map | `Duplicate_key key -> Error.failwiths ~here:[%here] "Map.of_hashtbl_exn: duplicate key" key comparator.sexp_of_t ;; let tree_of_hashtbl_exn ~comparator hashtbl = to_tree (of_hashtbl_exn ~comparator hashtbl) ;; let key_set ~comparator t = Base.Set.Using_comparator.of_sorted_array_unchecked ~comparator (List.to_array (keys t)) ;; let key_set_of_tree ~comparator t = key_set ~comparator (of_tree ~comparator t) let of_key_set key_set ~f = of_sorted_array_unchecked ~comparator:(Base.Set.comparator key_set) (Array.map (Base.Set.to_array key_set) ~f:(fun key -> key, f key)) ;; let tree_of_key_set key_set ~f = to_tree (of_key_set key_set ~f) end module Accessors = struct include ( Map.Using_comparator : Map.Accessors3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) Map.t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Tree.t) let validate ~name f t = Validate.alist ~name f (to_alist t) let validatei ~name f t = Validate.list ~name:(Fn.compose name fst) f (to_alist t) let quickcheck_observer k v = quickcheck_observer k v let quickcheck_shrinker k v = quickcheck_shrinker k v let key_set t = Using_comparator.key_set t ~comparator:(Using_comparator.comparator t) end let key_set t = Using_comparator.key_set ~comparator:(Using_comparator.comparator t) t let of_key_set = Using_comparator.of_key_set let hash_fold_direct = Using_comparator.hash_fold_direct let comparator = Using_comparator.comparator let comparator_s = Base.Map.comparator_s type 'k key = 'k type 'c cmp = 'c include ( struct include Map let validate ~name f t = Validate.alist ~name f (to_alist t) let validatei ~name f t = Validate.list ~name:(Fn.compose name fst) f (to_alist t) let of_tree m = Map.Using_comparator.of_tree ~comparator:(to_comparator m) let to_tree = Map.Using_comparator.to_tree end : sig type ('a, 'b, 'c) t = ('a, 'b, 'c) Map.t include Map.Creators_generic with type ('a, 'b, 'c) options := ('a, 'b, 'c) Map.With_first_class_module.t with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Tree.t with type 'k key := 'k key with type 'c cmp := 'c cmp include Map.Accessors3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Tree.t val validate : name:('k -> string) -> 'v Validate.check -> ('k, 'v, _) t Validate.check val validatei : name:('k key -> string) -> ('k key * 'v) Validate.check -> ('k, 'v, _) t Validate.check end) module Empty_without_value_restriction = Using_comparator.Empty_without_value_restriction let find_or_error t key = let comparator = comparator t in match find t key with | Some data -> Ok data | None -> let sexp_of_key = comparator.sexp_of_t in Or_error.error_s [%message "key not found" ~_:(key : key)] ;; let merge_skewed = Map.merge_skewed let of_hashtbl_exn m t = Using_comparator.of_hashtbl_exn ~comparator:(to_comparator m) t module Creators (Key : Comparator.S1) : sig type ('a, 'b, 'c) t_ = ('a Key.t, 'b, Key.comparator_witness) t type ('a, 'b, 'c) tree = ('a, 'b, Key.comparator_witness) Tree.t type ('a, 'b, 'c) options = ('a, 'b, 'c) Without_comparator.t val t_of_sexp : (Base.Sexp.t -> 'a Key.t) -> (Base.Sexp.t -> 'b) -> Base.Sexp.t -> ('a, 'b, _) t_ include Creators_generic with type ('a, 'b, 'c) t := ('a, 'b, 'c) t_ with type ('a, 'b, 'c) tree := ('a, 'b, 'c) tree with type 'a key := 'a Key.t with type 'a cmp := Key.comparator_witness with type ('a, 'b, 'c) options := ('a, 'b, 'c) options end = struct type ('a, 'b, 'c) options = ('a, 'b, 'c) Without_comparator.t let comparator = Key.comparator type ('a, 'b, 'c) t_ = ('a Key.t, 'b, Key.comparator_witness) t type ('a, 'b, 'c) tree = ('a, 'b, Key.comparator_witness) Tree.t module M_empty = Empty_without_value_restriction (Key) let empty = M_empty.empty let of_tree tree = Using_comparator.of_tree ~comparator tree let singleton k v = Using_comparator.singleton ~comparator k v let of_sorted_array_unchecked array = Using_comparator.of_sorted_array_unchecked ~comparator array ;; let of_sorted_array array = Using_comparator.of_sorted_array ~comparator array let of_increasing_iterator_unchecked ~len ~f = Using_comparator.of_increasing_iterator_unchecked ~comparator ~len ~f ;; let of_increasing_sequence seq = Using_comparator.of_increasing_sequence ~comparator seq let of_sequence seq = Using_comparator.of_sequence ~comparator seq let of_sequence_or_error seq = Using_comparator.of_sequence_or_error ~comparator seq let of_sequence_exn seq = Using_comparator.of_sequence_exn ~comparator seq let of_sequence_multi seq = Using_comparator.of_sequence_multi ~comparator seq let of_sequence_fold seq ~init ~f = Using_comparator.of_sequence_fold ~comparator seq ~init ~f ;; let of_sequence_reduce seq ~f = Using_comparator.of_sequence_reduce ~comparator seq ~f let of_alist alist = Using_comparator.of_alist ~comparator alist let of_alist_or_error alist = Using_comparator.of_alist_or_error ~comparator alist let of_alist_exn alist = Using_comparator.of_alist_exn ~comparator alist let of_hashtbl_exn hashtbl = Using_comparator.of_hashtbl_exn ~comparator hashtbl let of_alist_multi alist = Using_comparator.of_alist_multi ~comparator alist let of_alist_fold alist ~init ~f = Using_comparator.of_alist_fold ~comparator alist ~init ~f ;; let of_alist_reduce alist ~f = Using_comparator.of_alist_reduce ~comparator alist ~f let of_iteri ~iteri = Using_comparator.of_iteri ~comparator ~iteri let of_iteri_exn ~iteri = Using_comparator.of_iteri_exn ~comparator ~iteri let t_of_sexp k_of_sexp v_of_sexp sexp = Using_comparator.t_of_sexp_direct ~comparator k_of_sexp v_of_sexp sexp ;; let of_key_set key_set ~f = Using_comparator.of_key_set key_set ~f let map_keys t ~f = Using_comparator.map_keys ~comparator t ~f let map_keys_exn t ~f = Using_comparator.map_keys_exn ~comparator t ~f let quickcheck_generator gen_k gen_v = Using_comparator.quickcheck_generator ~comparator gen_k gen_v ;; end module Make_tree_S1 (Key : Comparator.S1) = struct open Tree let comparator = Key.comparator let sexp_of_t = sexp_of_t let t_of_sexp a b c = t_of_sexp_direct a b c ~comparator let empty = empty_without_value_restriction let of_tree tree = tree let singleton a = singleton a ~comparator let of_sorted_array_unchecked a = of_sorted_array_unchecked a ~comparator let of_sorted_array a = of_sorted_array a ~comparator let of_increasing_iterator_unchecked ~len ~f = of_increasing_iterator_unchecked ~len ~f ~comparator ;; let of_increasing_sequence seq = of_increasing_sequence ~comparator seq let of_sequence s = of_sequence s ~comparator let of_sequence_or_error s = of_sequence_or_error s ~comparator let of_sequence_exn s = of_sequence_exn s ~comparator let of_sequence_multi s = of_sequence_multi s ~comparator let of_sequence_fold s ~init ~f = of_sequence_fold s ~init ~f ~comparator let of_sequence_reduce s ~f = of_sequence_reduce s ~f ~comparator let of_alist a = of_alist a ~comparator let of_alist_or_error a = of_alist_or_error a ~comparator let of_alist_exn a = of_alist_exn a ~comparator let of_hashtbl_exn a = Using_comparator.tree_of_hashtbl_exn a ~comparator let of_alist_multi a = of_alist_multi a ~comparator let of_alist_fold a ~init ~f = of_alist_fold a ~init ~f ~comparator let of_alist_reduce a ~f = of_alist_reduce a ~f ~comparator let of_iteri ~iteri = of_iteri ~iteri ~comparator let of_iteri_exn ~iteri = of_iteri_exn ~iteri ~comparator let of_key_set = Using_comparator.tree_of_key_set let to_tree t = t let invariants a = invariants a ~comparator let is_empty a = is_empty a let length a = length a let set a ~key ~data = set a ~key ~data ~comparator let add a ~key ~data = add a ~key ~data ~comparator let add_exn a ~key ~data = add_exn a ~key ~data ~comparator let add_multi a ~key ~data = add_multi a ~key ~data ~comparator let remove_multi a b = remove_multi a b ~comparator let find_multi a b = find_multi a b ~comparator let change a b ~f = change a b ~f ~comparator let update a b ~f = update a b ~f ~comparator let find_exn a b = find_exn a b ~comparator let find a b = find a b ~comparator let remove a b = remove a b ~comparator let mem a b = mem a b ~comparator let iter_keys = iter_keys let iter = iter let iteri = iteri let iteri_until = iteri_until let iter2 a b ~f = iter2 a b ~f ~comparator let map = map let mapi = mapi let fold = fold let fold_until = fold_until let fold_right = fold_right let fold2 a b ~init ~f = fold2 a b ~init ~f ~comparator let filter_keys a ~f = filter_keys a ~f ~comparator let filter a ~f = filter a ~f ~comparator let filteri a ~f = filteri a ~f ~comparator let filter_map a ~f = filter_map a ~f ~comparator let filter_mapi a ~f = filter_mapi a ~f ~comparator let partition_mapi t ~f = partition_mapi t ~f ~comparator let partition_map t ~f = partition_map t ~f ~comparator let partitioni_tf t ~f = partitioni_tf t ~f ~comparator let partition_tf t ~f = partition_tf t ~f ~comparator let combine_errors t = combine_errors t ~comparator let compare_direct a b c = compare_direct a b c ~comparator let equal a b c = equal a b c ~comparator let keys = keys let data = data let to_alist = to_alist let validate ~name f t = Validate.alist ~name f (to_alist t) let validatei ~name f t = Validate.list ~name:(Fn.compose name fst) f (to_alist t) let symmetric_diff a b ~data_equal = symmetric_diff a b ~data_equal ~comparator let fold_symmetric_diff a b ~data_equal ~init ~f = fold_symmetric_diff a b ~data_equal ~f ~init ~comparator ;; let merge a b ~f = merge a b ~f ~comparator let merge_skewed a b ~combine = merge_skewed a b ~combine ~comparator let min_elt = min_elt let min_elt_exn = min_elt_exn let max_elt = max_elt let max_elt_exn = max_elt_exn let for_all = for_all let for_alli = for_alli let exists = exists let existsi = existsi let count = count let counti = counti let split a b = split a b ~comparator let append ~lower_part ~upper_part = append ~lower_part ~upper_part ~comparator let subrange t ~lower_bound ~upper_bound = subrange t ~lower_bound ~upper_bound ~comparator ;; let fold_range_inclusive t ~min ~max ~init ~f = fold_range_inclusive t ~min ~max ~init ~f ~comparator ;; let range_to_alist t ~min ~max = range_to_alist t ~min ~max ~comparator let closest_key a b c = closest_key a b c ~comparator let nth = nth let nth_exn = nth_exn let rank a b = rank a b ~comparator let to_sequence ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t = to_sequence ~comparator ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t ;; let binary_search t ~compare how v = binary_search ~comparator t ~compare how v let binary_search_segmented t ~segment_of how = binary_search_segmented ~comparator t ~segment_of how ;; let binary_search_subrange t ~compare ~lower_bound ~upper_bound = binary_search_subrange ~comparator t ~compare ~lower_bound ~upper_bound ;; let key_set t = Using_comparator.key_set_of_tree ~comparator t let map_keys t ~f = map_keys t ~f ~comparator let map_keys_exn t ~f = map_keys_exn t ~f ~comparator let quickcheck_generator k v = For_quickcheck.gen_tree ~comparator k v let quickcheck_observer k v = For_quickcheck.obs_tree k v let quickcheck_shrinker k v = For_quickcheck.shr_tree ~comparator k v end module Make_tree_plain (Key : sig type t [@@deriving sexp_of] include Comparator.S with type t := t end) = struct module Key_S1 = Comparator.S_to_S1 (Key) include Make_tree_S1 (Key_S1) type +'v t = (Key.t, 'v, Key.comparator_witness) Tree.t let sexp_of_t sexp_of_v t = sexp_of_t Key.sexp_of_t sexp_of_v [%sexp_of: _] t module Provide_of_sexp (X : sig type t [@@deriving of_sexp] end with type t := Key.t) = struct let t_of_sexp v_of_sexp sexp = t_of_sexp X.t_of_sexp v_of_sexp sexp end end module Make_tree (Key : sig type t [@@deriving sexp] include Comparator.S with type t := t end) = struct include Make_tree_plain (Key) include Provide_of_sexp (Key) end (* Don't use [of_sorted_array] to avoid the allocation of an intermediate array *) let init_for_bin_prot ~len ~f ~comparator = let map = Using_comparator.of_increasing_iterator_unchecked ~len ~f ~comparator in if invariants map then map else ( (* The invariants are broken, but we can still traverse the structure. *) match Using_comparator.of_iteri ~iteri:(iteri map) ~comparator with | `Ok map -> map | `Duplicate_key _key -> failwith "Map.bin_read_t: duplicate element in map") ;; module Poly = struct include Creators (Comparator.Poly) type ('a, 'b, 'c) map = ('a, 'b, 'c) t type ('k, 'v) t = ('k, 'v, Comparator.Poly.comparator_witness) map type comparator_witness = Comparator.Poly.comparator_witness include Accessors let compare _ cmpv t1 t2 = compare_direct cmpv t1 t2 let sexp_of_t sexp_of_k sexp_of_v t = Using_comparator.sexp_of_t sexp_of_k sexp_of_v [%sexp_of: _] t ;; let t_sexp_grammar k_grammar v_grammar = Sexplib.Sexp_grammar.coerce (List.Assoc.t_sexp_grammar k_grammar v_grammar) ;; include Bin_prot.Utils.Make_iterable_binable2 (struct type nonrec ('a, 'b) t = ('a, 'b) t type ('a, 'b) el = 'a * 'b [@@deriving bin_io] let _ = bin_el let caller_identity = Bin_prot.Shape.Uuid.of_string "b7d7b1a0-4992-11e6-8a32-bbb221fa025c" ;; let module_name = Some "Core.Map" let length = length let iter t ~f = iteri t ~f:(fun ~key ~data -> f (key, data)) let init ~len ~next = init_for_bin_prot ~len ~f:(fun _ -> next ()) ~comparator:Comparator.Poly.comparator ;; end) module Tree = struct include Make_tree_S1 (Comparator.Poly) type ('k, +'v) t = ('k, 'v, Comparator.Poly.comparator_witness) tree type comparator_witness = Comparator.Poly.comparator_witness let sexp_of_t sexp_of_k sexp_of_v t = sexp_of_t sexp_of_k sexp_of_v [%sexp_of: _] t let t_sexp_grammar k_grammar v_grammar = Sexplib.Sexp_grammar.coerce (List.Assoc.t_sexp_grammar k_grammar v_grammar) ;; end end module type Key_plain = Key_plain module type Key = Key module type Key_binable = Key_binable module type Key_hashable = Key_hashable module type Key_binable_hashable = Key_binable_hashable module type S_plain = S_plain module type S = S module type S_binable = S_binable module Key_bin_io = Key_bin_io module Provide_bin_io (Key : Key_bin_io.S) = Bin_prot.Utils.Make_iterable_binable1 (struct module Key = Key type nonrec 'v t = (Key.t, 'v, Key.comparator_witness) t type 'v el = Key.t * 'v [@@deriving bin_io] let _ = bin_el let caller_identity = Bin_prot.Shape.Uuid.of_string "dfb300f8-4992-11e6-9c15-73a2ac6b815c" ;; let module_name = Some "Core.Map" let length = length let iter t ~f = iteri t ~f:(fun ~key ~data -> f (key, data)) let init ~len ~next = init_for_bin_prot ~len ~f:(fun _ -> next ()) ~comparator:Key.comparator ;; end) module Make_plain_using_comparator (Key : sig type t [@@deriving sexp_of] include Comparator.S with type t := t end) = struct module Key = Key module Key_S1 = Comparator.S_to_S1 (Key) include Creators (Key_S1) type key = Key.t type ('a, 'b, 'c) map = ('a, 'b, 'c) t type 'v t = (key, 'v, Key.comparator_witness) map include Accessors let compare cmpv t1 t2 = compare_direct cmpv t1 t2 let sexp_of_t sexp_of_v t = Using_comparator.sexp_of_t Key.sexp_of_t sexp_of_v [%sexp_of: _] t ;; module Provide_of_sexp (Key : sig type t [@@deriving of_sexp] end with type t := Key.t) = struct let t_of_sexp v_of_sexp sexp = t_of_sexp Key.t_of_sexp v_of_sexp sexp end module Provide_hash (Key' : Hasher.S with type t := Key.t) = struct let hash_fold_t (type a) hash_fold_data state (t : a t) = Using_comparator.hash_fold_direct Key'.hash_fold_t hash_fold_data state t ;; end module Provide_bin_io (Key' : sig type t [@@deriving bin_io] end with type t := Key.t) = Provide_bin_io (struct include Key include Key' end) end module Make_plain (Key : Key_plain) = Make_plain_using_comparator (struct include Key include Comparator.Make (Key) end) module Make_using_comparator (Key_sexp : sig type t [@@deriving sexp] include Comparator.S with type t := t end) = struct include Make_plain_using_comparator (Key_sexp) module Key = Key_sexp include Provide_of_sexp (Key) module _ = struct include Tree include Provide_of_sexp (Key) end end module Make (Key : Key) = Make_using_comparator (struct include Key include Comparator.Make (Key) end) module Make_binable_using_comparator (Key_bin_sexp : sig type t [@@deriving bin_io, sexp] include Comparator.S with type t := t end) = struct include Make_using_comparator (Key_bin_sexp) module Key = Key_bin_sexp include Provide_bin_io (Key) end module Make_binable (Key : Key_binable) = Make_binable_using_comparator (struct include Key include Comparator.Make (Key) end) module For_deriving = struct module M = Map.M let bin_shape_m__t (type t c) (m : (t, c) Key_bin_io.t) = let module M = Provide_bin_io ((val m)) in M.bin_shape_t ;; let bin_size_m__t (type t c) (m : (t, c) Key_bin_io.t) = let module M = Provide_bin_io ((val m)) in M.bin_size_t ;; let bin_write_m__t (type t c) (m : (t, c) Key_bin_io.t) = let module M = Provide_bin_io ((val m)) in M.bin_write_t ;; let bin_read_m__t (type t c) (m : (t, c) Key_bin_io.t) = let module M = Provide_bin_io ((val m)) in M.bin_read_t ;; let __bin_read_m__t__ (type t c) (m : (t, c) Key_bin_io.t) = let module M = Provide_bin_io ((val m)) in M.__bin_read_t__ ;; module type Quickcheck_generator_m = sig include Comparator.S val quickcheck_generator : t Quickcheck.Generator.t end module type Quickcheck_observer_m = sig include Comparator.S val quickcheck_observer : t Quickcheck.Observer.t end module type Quickcheck_shrinker_m = sig include Comparator.S val quickcheck_shrinker : t Quickcheck.Shrinker.t end let quickcheck_generator_m__t (type k cmp) (module Key : Quickcheck_generator_m with type t = k and type comparator_witness = cmp) v_generator = quickcheck_generator (module Key) Key.quickcheck_generator v_generator ;; let quickcheck_observer_m__t (type k cmp) (module Key : Quickcheck_observer_m with type t = k and type comparator_witness = cmp) v_observer = quickcheck_observer Key.quickcheck_observer v_observer ;; let quickcheck_shrinker_m__t (type k cmp) (module Key : Quickcheck_shrinker_m with type t = k and type comparator_witness = cmp) v_shrinker = quickcheck_shrinker Key.quickcheck_shrinker v_shrinker ;; module type For_deriving = Map.For_deriving include (Map : For_deriving with type ('a, 'b, 'c) t := ('a, 'b, 'c) t) end include For_deriving module Tree = struct include Tree let validate ~name f t = Validate.alist ~name f (to_alist t) let validatei ~name f t = Validate.list ~name:(Fn.compose name fst) f (to_alist t) let of_hashtbl_exn = Using_comparator.tree_of_hashtbl_exn let key_set = Using_comparator.key_set_of_tree let of_key_set = Using_comparator.tree_of_key_set let quickcheck_generator ~comparator k v = For_quickcheck.gen_tree ~comparator k v let quickcheck_observer k v = For_quickcheck.obs_tree k v let quickcheck_shrinker ~comparator k v = For_quickcheck.shr_tree ~comparator k v end module Stable = struct module V1 = struct type nonrec ('k, 'v, 'cmp) t = ('k, 'v, 'cmp) t module type S = sig type key type comparator_witness type nonrec 'a t = (key, 'a, comparator_witness) t include Stable_module_types.S1 with type 'a t := 'a t end include For_deriving module Make (Key : Stable_module_types.S0) = Make_binable_using_comparator (Key) end module Symmetric_diff_element = Symmetric_diff_element.Stable end core-0.15.0/core/src/map.mli000066400000000000000000001075121420273305200155300ustar00rootroot00000000000000(** [Map] is a functional data structure (balanced binary tree) implementing finite maps over a totally-ordered domain, called a "key". For example: {[ let empty = Map.empty (module String) let numbers = Map.of_alist_exn (module String) ["three", Substr "three"; "four", Substr "four"] ]} Note that the functions in Map are polymorphic over the type of the key and of the data; you just need to pass in the first-class module for the key type (here, [String]). Suppose you wanted to define a new module [Foo] to use in a map. You would write: {[ module Foo = struct module T = struct type t = int * int [@@deriving compare, sexp_of] end include T include Comparable.Make_plain(T) end ]} This gives you a module [Foo] with the appropriate comparator in it, and then this: {[ let m = Map.empty (module Foo) ]} lets you create a map keyed by [Foo]. The reason you need to write a sexp-converter and a comparison function for this to work is that maps both need comparison and the ability to serialize the key for generating useful errors. {2 The interface} *) open! Import open Map_intf type ('key, +'value, 'cmp) t = ('key, 'value, 'cmp) Base.Map.t type ('k, 'cmp) comparator = (module Comparator.S with type t = 'k and type comparator_witness = 'cmp) (** Test if invariants of internal AVL search tree hold. *) val invariants : (_, _, _) t -> bool val comparator : ('a, _, 'cmp) t -> ('a, 'cmp) Comparator.t val comparator_s : ('a, _, 'cmp) t -> ('a, 'cmp) comparator (** The empty map. *) val empty : ('a, 'cmp) comparator -> ('a, 'b, 'cmp) t (** Map with one (key, data) pair. *) val singleton : ('a, 'cmp) comparator -> 'a -> 'b -> ('a, 'b, 'cmp) t (** Creates map from an association list with unique keys. *) val of_alist : ('a, 'cmp) comparator -> ('a * 'b) list -> [ `Ok of ('a, 'b, 'cmp) t | `Duplicate_key of 'a ] (** Creates map from an association list with unique keys. Returns an error if duplicate ['a] keys are found. *) val of_alist_or_error : ('a, 'cmp) comparator -> ('a * 'b) list -> ('a, 'b, 'cmp) t Or_error.t (** Creates map from an association list with unique keys. Raises an exception if duplicate ['a] keys are found. *) val of_alist_exn : ('a, 'cmp) comparator -> ('a * 'b) list -> ('a, 'b, 'cmp) t (** [of_hashtbl_exn] creates a map from bindings present in a hash table. [of_hashtbl_exn] raises if there are distinct keys [a1] and [a2] in the table with [comparator.compare a1 a2 = 0], which is only possible if the hash-table comparison function is different than [comparator.compare]. In the common case, the comparison is the same, in which case [of_hashtbl_exn] does not raise, regardless of the keys present in the table. *) val of_hashtbl_exn : ('a, 'cmp) comparator -> ('a, 'b) Hashtbl.t -> ('a, 'b, 'cmp) t (** Creates map from an association list with possibly repeated keys. *) val of_alist_multi : ('a, 'cmp) comparator -> ('a * 'b) list -> ('a, 'b list, 'cmp) t (** Combines an association list into a map, folding together bound values with common keys. *) val of_alist_fold : ('a, 'cmp) comparator -> ('a * 'b) list -> init:'c -> f:('c -> 'b -> 'c) -> ('a, 'c, 'cmp) t (** Combines an association list into a map, reducing together bound values with common keys. *) val of_alist_reduce : ('a, 'cmp) comparator -> ('a * 'b) list -> f:('b -> 'b -> 'b) -> ('a, 'b, 'cmp) t (** [of_iteri ~iteri] behaves like [of_alist], except that instead of taking a concrete datastructure, it takes an iteration function. For instance, to convert a string table into a map: [of_iteri (module String) ~iteri:(Hashtbl.iteri table)]. It is faster than adding the elements one by one. *) val of_iteri : ('a, 'cmp) comparator -> iteri:(f:(key:'a -> data:'b -> unit) -> unit) -> [ `Ok of ('a, 'b, 'cmp) t | `Duplicate_key of 'a ] (** Like [of_iteri] except that it raises an exception if duplicate ['a] keys are found. *) val of_iteri_exn : ('a, 'cmp) comparator -> iteri:(f:(key:'a -> data:'b -> unit) -> unit) -> ('a, 'b, 'cmp) t (** {2 Trees} Parallel to the three kinds of map modules [Map], [Map.Poly], and [Key.Map], there are also tree modules [Map.Tree], [Map.Poly.Tree], and [Key.Map.Tree]. A tree is a bare representation of a map, without the comparator. Thus tree operations need to obtain the comparator from somewhere. For [Map.Poly.Tree] and [Key.Map.Tree], the comparator is implicit in the module name. For [Map.Tree], the comparator must be passed to each operation. The main advantages of trees over maps are slightly improved space usage (there is no outer container holding the comparator) and the ability to marshal trees, because a tree doesn't contain a closure, the way a map does. The main disadvantages of using trees are needing to be more explicit about the comparator, and the possibility of accidentally using polymorphic equality on a tree (for which maps dynamically detect failure due to the presence of a closure in the data structure). *) module Tree : sig type ('k, +'v, 'cmp) t = ('k, 'v, 'cmp) Tree.t [@@deriving sexp_of] include Creators_and_accessors3_with_comparator with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) t end val to_tree : ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) Tree.t (** Creates a [t] from a [Tree.t] and a [Comparator.t]. This is an O(n) operation as it must discover the length of the [Tree.t]. *) val of_tree : ('k, 'cmp) comparator -> ('k, 'v, 'cmp) Tree.t -> ('k, 'v, 'cmp) t (** {2 More interface} *) (** Creates map from a sorted array of key-data pairs. The input array must be sorted, as given by the relevant comparator (either in ascending or descending order), and must not contain any duplicate keys. If either of these conditions does not hold, an error is returned. *) val of_sorted_array : ('a, 'cmp) comparator -> ('a * 'b) array -> ('a, 'b, 'cmp) t Or_error.t (** Like [of_sorted_array] except it returns a map with broken invariants when an [Error] would have been returned. *) val of_sorted_array_unchecked : ('a, 'cmp) comparator -> ('a * 'b) array -> ('a, 'b, 'cmp) t (** [of_increasing_iterator_unchecked c ~len ~f] behaves like [of_sorted_array_unchecked c (Array.init len ~f)], with the additional restriction that a decreasing order is not supported. The advantage is not requiring you to allocate an intermediate array. [f] will be called with 0, 1, ... [len - 1], in order. *) val of_increasing_iterator_unchecked : ('a, 'cmp) comparator -> len:int -> f:(int -> 'a * 'b) -> ('a, 'b, 'cmp) t (** [of_increasing_sequence c seq] behaves like [of_sorted_array c (Sequence.to_array seq)], but does not allocate the intermediate array. The sequence will be folded over once, and the additional time complexity is O(n). *) val of_increasing_sequence : ('k, 'cmp) comparator -> ('k * 'v) Sequence.t -> ('k, 'v, 'cmp) t Or_error.t (** Creates a map from an association sequence with unique keys. [of_sequence c seq] behaves like [of_alist c (Sequence.to_list seq)] but does not allocate the intermediate list. If your sequence is increasing, use {!of_increasing_sequence} for better performance. *) val of_sequence : ('k, 'cmp) comparator -> ('k * 'v) Sequence.t -> [ `Ok of ('k, 'v, 'cmp) t | `Duplicate_key of 'k ] (** Creates a map from an association sequence with unique keys, returning an error if duplicate ['a] keys are found. [of_sequence_or_error c seq] behaves like [of_alist_or_error c (Sequence.to_list seq)] but does not allocate the intermediate list. *) val of_sequence_or_error : ('a, 'cmp) comparator -> ('a * 'b) Sequence.t -> ('a, 'b, 'cmp) t Or_error.t (** Creates a map from an association sequence with unique keys, raising an exception if duplicate ['a] keys are found. [of_sequence_exn c seq] behaves like [of_alist_exn c (Sequence.to_list seq)] but does not allocate the intermediate list. *) val of_sequence_exn : ('a, 'cmp) comparator -> ('a * 'b) Sequence.t -> ('a, 'b, 'cmp) t (** Creates a map from an association sequence with possibly repeated keys. The values in the map for a given key appear in the same order as they did in the association list. [of_sequence_multi c seq] behaves like [of_alist_multi c (Sequence.to_list seq)] but does not allocate the intermediate list. *) val of_sequence_multi : ('a, 'cmp) comparator -> ('a * 'b) Sequence.t -> ('a, 'b list, 'cmp) t (** Combines an association sequence into a map, folding together bound values with common keys. [of_sequence_fold c seq ~init ~f] behaves like [of_alist_fold c (Sequence.to_list seq) ~init ~f] but does not allocate the intermediate list. *) val of_sequence_fold : ('a, 'cmp) comparator -> ('a * 'b) Sequence.t -> init:'c -> f:('c -> 'b -> 'c) -> ('a, 'c, 'cmp) t (** Combines an association sequence into a map, reducing together bound values with common keys. [of_sequence_reduce c seq ~f] behaves like [of_alist_reduce c (Sequence.to_list seq) ~f] but does not allocate the intermediate list. *) val of_sequence_reduce : ('a, 'cmp) comparator -> ('a * 'b) Sequence.t -> f:('b -> 'b -> 'b) -> ('a, 'b, 'cmp) t (** Tests whether a map is empty or not. *) val is_empty : (_, _, _) t -> bool (** [length map] returns number of elements in [map]. O(1), but [Tree.length] is O(n). *) val length : (_, _, _) t -> int (** [add t ~key ~data] adds a new entry to [t] mapping [key] to [data] and returns [`Ok] with the new map, or if [key] is already present in [t], returns [`Duplicate]. *) val add : ('k, 'v, 'cmp) t -> key:'k -> data:'v -> ('k, 'v, 'cmp) t Or_duplicate.t (** [add_exn t ~key ~data] adds a new entry to [t] mapping [key] to [data] and returns the new map, or if [key] is already present in [t], raises. *) val add_exn : ('k, 'v, 'cmp) t -> key:'k -> data:'v -> ('k, 'v, 'cmp) t (** Returns a new map with the specified new binding; if the key was already bound, its previous binding disappears. *) val set : ('k, 'v, 'cmp) t -> key:'k -> data:'v -> ('k, 'v, 'cmp) t (** If [key] is not present then add a singleton list, otherwise, cons data onto the head of the existing list. *) val add_multi : ('k, 'v list, 'cmp) t -> key:'k -> data:'v -> ('k, 'v list, 'cmp) t (** If [k] is present then remove its head element; if result is empty, remove the key. *) val remove_multi : ('k, 'v list, 'cmp) t -> 'k -> ('k, 'v list, 'cmp) t (** [find_multi t key] returns [t]'s values for [key] if [key] is present in the table, and returns the empty list otherwise. *) val find_multi : ('k, 'v list, 'cmp) t -> 'k -> 'v list (** [change t key ~f] returns a new map [m] that is the same as [t] on all keys except for [key], and whose value for [key] is defined by [f], i.e., [find m key = f (find t key)]. *) val change : ('k, 'v, 'cmp) t -> 'k -> f:('v option -> 'v option) -> ('k, 'v, 'cmp) t (** [update t key ~f] is [change t key ~f:(fun o -> Some (f o))]. *) val update : ('k, 'v, 'cmp) t -> 'k -> f:('v option -> 'v) -> ('k, 'v, 'cmp) t (** Returns the value bound to the given key if it exists, and [None] otherwise. *) val find : ('k, 'v, 'cmp) t -> 'k -> 'v option (** Returns the value bound to the given key, raising [Caml.Not_found] or [Not_found_s] if none exists. *) val find_exn : ('k, 'v, 'cmp) t -> 'k -> 'v val find_or_error : ('k, 'v, 'cmp) t -> 'k -> 'v Or_error.t (** Returns a new map with any binding for the key in question removed. *) val remove : ('k, 'v, 'cmp) t -> 'k -> ('k, 'v, 'cmp) t (** [mem map key] tests whether [map] contains a binding for [key]. *) val mem : ('k, _, 'cmp) t -> 'k -> bool (** [iter_keys t ~f] calls [f] on every key in the map, going in order from the smallest to the largest keys. *) val iter_keys : ('k, _, _) t -> f:('k -> unit) -> unit (** [iter t ~f] calls [f] on every element in the map, going in order from the smallest to the largest keys. *) val iter : (_, 'v, _) t -> f:('v -> unit) -> unit (** [iteri t ~f] calls [f] on every key and element in the map, going in order from the smallest to the largest keys. *) val iteri : ('k, 'v, _) t -> f:(key:'k -> data:'v -> unit) -> unit module Continue_or_stop : sig type t = Base.Map.Continue_or_stop.t = | Continue | Stop [@@deriving compare, enumerate, equal, sexp_of] end module Finished_or_unfinished : sig type t = Base.Map.Finished_or_unfinished.t = | Finished | Unfinished [@@deriving compare, enumerate, equal, sexp_of] (** Maps [Continue] to [Finished] and [Stop] to [Unfinished]. *) val of_continue_or_stop : Continue_or_stop.t -> t (** Maps [Finished] to [Continue] and [Unfinished] to [Stop]. *) val to_continue_or_stop : t -> Continue_or_stop.t end (** Iterates until [f] returns [Stop]. If [f] returns [Stop], the final result is [Unfinished]. Otherwise, the final result is [Finished]. *) val iteri_until : ('k, 'v, _) t -> f:(key:'k -> data:'v -> Continue_or_stop.t) -> Finished_or_unfinished.t module Merge_element : sig type ('left, 'right) t = [ `Both of 'left * 'right | `Left of 'left | `Right of 'right ] val left : ('left, 'a) t -> 'left option val right : ('a, 'right) t -> 'right option val left_value : ('left, 'a) t -> default:'left -> 'left val right_value : ('a, 'right) t -> default:'right -> 'right val values : ('left, 'right) t -> left_default:'left -> right_default:'right -> 'left * 'right end (** Iterates two maps side by side. The complexity of this function is O(M+N). If two inputs are [[(0, a); (1, a)]] and [[(1, b); (2, b)]], [f] will be called with [[(0, `Left a); (1, `Both (a, b)); (2, `Right b)]] *) val iter2 : ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t -> f:(key:'k -> data:('v1, 'v2) Merge_element.t -> unit) -> unit (** Returns new map with bound values replaced by the result of [f] applied to them. *) val map : ('k, 'v1, 'cmp) t -> f:('v1 -> 'v2) -> ('k, 'v2, 'cmp) t (** Like [map], but [f] takes both key and data as arguments. *) val mapi : ('k, 'v1, 'cmp) t -> f:(key:'k -> data:'v1 -> 'v2) -> ('k, 'v2, 'cmp) t (** Convert map with keys of type ['k1] to a map with keys of type ['k2] using [f]. *) val map_keys : ('k2, 'cmp2) comparator -> ('k1, 'v, 'cmp1) t -> f:('k1 -> 'k2) -> [ `Ok of ('k2, 'v, 'cmp2) t | `Duplicate_key of 'k2 ] (** Like [map_keys], but raises on duplicate key. *) val map_keys_exn : ('k2, 'cmp2) comparator -> ('k1, 'v, 'cmp1) t -> f:('k1 -> 'k2) -> ('k2, 'v, 'cmp2) t (** Folds over keys and data in map in increasing order of key. *) val fold : ('k, 'v, _) t -> init:'a -> f:(key:'k -> data:'v -> 'a -> 'a) -> 'a (** Folds over keys and data in the map in increasing order of [key], until the first time that [f] returns [Stop _]. If [f] returns [Stop final], this function returns immediately with the value [final]. If [f] never returns [Stop _], and the final call to [f] returns [Continue last], this function returns [finish last]. *) val fold_until : ('k, 'v, _) t -> init:'acc -> f:(key:'k -> data:'v -> 'acc -> ('acc, 'final) Container.Continue_or_stop.t) -> finish:('acc -> 'final) -> 'final (** Folds over keys and data in map in decreasing order of key. *) val fold_right : ('k, 'v, _) t -> init:'a -> f:(key:'k -> data:'v -> 'a -> 'a) -> 'a (** Folds over two maps side by side, like [iter2]. *) val fold2 : ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t -> init:'a -> f:(key:'k -> data:('v1, 'v2) Merge_element.t -> 'a -> 'a) -> 'a (** [filter], [filteri], [filter_keys], [filter_map], and [filter_mapi] run in O(n * lg n) time; they simply accumulate each key & data retained by [f] into a new map using [add]. *) val filter_keys : ('k, 'v, 'cmp) t -> f:('k -> bool) -> ('k, 'v, 'cmp) t val filter : ('k, 'v, 'cmp) t -> f:('v -> bool) -> ('k, 'v, 'cmp) t val filteri : ('k, 'v, 'cmp) t -> f:(key:'k -> data:'v -> bool) -> ('k, 'v, 'cmp) t (** Returns new map with bound values filtered by the result of [f] applied to them. *) val filter_map : ('k, 'v1, 'cmp) t -> f:('v1 -> 'v2 option) -> ('k, 'v2, 'cmp) t (** Like [filter_map], but function takes both key and data as arguments. *) val filter_mapi : ('k, 'v1, 'cmp) t -> f:(key:'k -> data:'v1 -> 'v2 option) -> ('k, 'v2, 'cmp) t (** [partition_mapi t ~f] returns two new [t]s, with each key in [t] appearing in exactly one of the result maps depending on its mapping in [f]. *) val partition_mapi : ('k, 'v1, 'cmp) t -> f:(key:'k -> data:'v1 -> ('v2, 'v3) Either.t) -> ('k, 'v2, 'cmp) t * ('k, 'v3, 'cmp) t (** [partition_map t ~f = partition_mapi t ~f:(fun ~key:_ ~data -> f data)] *) val partition_map : ('k, 'v1, 'cmp) t -> f:('v1 -> ('v2, 'v3) Either.t) -> ('k, 'v2, 'cmp) t * ('k, 'v3, 'cmp) t (** {[ partitioni_tf t ~f = partition_mapi t ~f:(fun ~key ~data -> if f ~key ~data then First data else Second data) ]} *) val partitioni_tf : ('k, 'v, 'cmp) t -> f:(key:'k -> data:'v -> bool) -> ('k, 'v, 'cmp) t * ('k, 'v, 'cmp) t (** [partition_tf t ~f = partitioni_tf t ~f:(fun ~key:_ ~data -> f data)] *) val partition_tf : ('k, 'v, 'cmp) t -> f:('v -> bool) -> ('k, 'v, 'cmp) t * ('k, 'v, 'cmp) t (** Produces [Ok] of a map including all keys if all data is [Ok], or an [Error] including all errors otherwise. *) val combine_errors : ('k, 'v Or_error.t, 'cmp) t -> ('k, 'v, 'cmp) t Or_error.t (** Total ordering between maps. The first argument is a total ordering used to compare data associated with equal keys in the two maps. *) val compare_direct : ('v -> 'v -> int) -> ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> int (** Hash function: a building block to use when hashing data structures containing maps in them. [hash_fold_direct hash_fold_key] is compatible with [compare_direct] iff [hash_fold_key] is compatible with [(comparator m).compare] of the map [m] being hashed. *) val hash_fold_direct : 'k Hash.folder -> 'v Hash.folder -> ('k, 'v, 'cmp) t Hash.folder (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, that is, contain equal keys and associate them with equal data. [cmp] is the equality predicate used to compare the data associated with the keys. *) val equal : ('v -> 'v -> bool) -> ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> bool (** Returns list of keys in map in increasing order. *) val keys : ('k, _, _) t -> 'k list (** Returns list of data in map in increasing order of key. *) val data : (_, 'v, _) t -> 'v list (** Creates association list from map. @param key_order default is [`Increasing] *) val to_alist : ?key_order:[ `Increasing | `Decreasing ] -> ('k, 'v, _) t -> ('k * 'v) list val validate : name:('k -> string) -> 'v Validate.check -> ('k, 'v, _) t Validate.check val validatei : name:('k -> string) -> ('k * 'v) Validate.check -> ('k, 'v, _) t Validate.check (** {2 Additional operations on maps} *) (** Merges two maps. The runtime is O(length(t1) + length(t2)). In particular, you shouldn't use this function to merge a list of maps. Consider using [merge_skewed] instead. *) val merge : ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t -> f:(key:'k -> ('v1, 'v2) Merge_element.t -> 'v3 option) -> ('k, 'v3, 'cmp) t (** A special case of [merge], [merge_skewed t1 t2] is a map containing all the bindings of [t1] and [t2]. Bindings that appear in both [t1] and [t2] are merged using the [combine] function. In a call [combine ~key v1 v2] the value [v1] comes from [t1] and [v2] from [t2]. The runtime of [merge_skewed] is [O(l1 * log(l2))], where [l1] is the length of the smaller map and [l2] the length of the larger map. This is likely to be faster than [merge] when one of the maps is a lot smaller, or when you merge a list of maps. *) val merge_skewed : ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> combine:(key:'k -> 'v -> 'v -> 'v) -> ('k, 'v, 'cmp) t module Symmetric_diff_element : sig type ('k, 'v) t = 'k * [ `Left of 'v | `Right of 'v | `Unequal of 'v * 'v ] [@@deriving bin_io, compare, sexp] val map_data : ('k, 'v1) t -> f:('v1 -> 'v2) -> ('k, 'v2) t (** [left] is defined as: {[ function | (`Left x | `Unequal (x, _)) -> Some x | `Right _ -> None ]} and [right] is similar. *) val left : (_, 'v) t -> 'v option val right : (_, 'v) t -> 'v option end (** [symmetric_diff t1 t2 ~data_equal] returns a list of changes between [t1] and [t2]. It is intended to be efficient in the case where [t1] and [t2] share a large amount of structure. In the case where [t2] (resp. [t1]) is obtained by applying k additions and/or removals to [t1] (resp. [t2]), this runs in [min(O(k log n), O(n))], where [n] is [length t1 + length t2]. The keys in the output sequence will be in sorted order. *) val symmetric_diff : ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> data_equal:('v -> 'v -> bool) -> ('k, 'v) Symmetric_diff_element.t Sequence.t (** [fold_symmetric_diff t1 t2 ~data_equal] folds across an implicit sequence of changes between [t1] and [t2], in sorted order by keys. Equivalent to [Sequence.fold (symmetric_diff t1 t2 ~data_equal)], and more efficient. *) val fold_symmetric_diff : ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> data_equal:('v -> 'v -> bool) -> init:'a -> f:('a -> ('k, 'v) Symmetric_diff_element.t -> 'a) -> 'a (** [min_elt map] returns [Some (key, data)] pair corresponding to the minimum key in [map], [None] if [map] is empty. *) val min_elt : ('k, 'v, _) t -> ('k * 'v) option val min_elt_exn : ('k, 'v, _) t -> 'k * 'v (** [max_elt map] returns [Some (key, data)] pair corresponding to the maximum key in [map], and [None] if [map] is empty. *) val max_elt : ('k, 'v, _) t -> ('k * 'v) option val max_elt_exn : ('k, 'v, _) t -> 'k * 'v (** The following functions have the same semantics as similar functions in {!Core.List}. *) val for_all : ('k, 'v, _) t -> f:('v -> bool) -> bool val for_alli : ('k, 'v, _) t -> f:(key:'k -> data:'v -> bool) -> bool val exists : ('k, 'v, _) t -> f:('v -> bool) -> bool val existsi : ('k, 'v, _) t -> f:(key:'k -> data:'v -> bool) -> bool val count : ('k, 'v, _) t -> f:('v -> bool) -> int val counti : ('k, 'v, _) t -> f:(key:'k -> data:'v -> bool) -> int (** [split t key] returns a map of keys strictly less than [key], the mapping of [key] if any, and a map of keys strictly greater than [key]. Runtime is O(m + log n) where n is the size of the input map, and m is the size of the smaller of the two output maps. The O(m) term is due to the need to calculate the length of the output maps. **) val split : ('k, 'v, 'cmp) t -> 'k -> ('k, 'v, 'cmp) t * ('k * 'v) option * ('k, 'v, 'cmp) t (** [append ~lower_part ~upper_part] returns [`Ok map] where [map] contains all the [(key, value)] pairs from the two input maps if all the keys from [lower_part] are less than all the keys from [upper_part]. Otherwise it returns [`Overlapping_key_ranges]. Runtime is O(log n) where n is the size of the larger input map. This can be significantly faster than [Map.merge] or repeated [Map.add]. {[ assert (match Map.append ~lower_part ~upper_part with | `Ok whole_map -> whole_map = Map.(of_alist_exn (List.append (to_alist lower_part) (to_alist upper_part))) | `Overlapping_key_ranges -> true); ]} *) val append : lower_part:('k, 'v, 'cmp) t -> upper_part:('k, 'v, 'cmp) t -> [ `Ok of ('k, 'v, 'cmp) t | `Overlapping_key_ranges ] (** [subrange t ~lower_bound ~upper_bound] returns a map containing all the entries from [t] whose keys lie inside the interval indicated by [~lower_bound] and [~upper_bound]. If this interval is empty, an empty map is returned. Runtime is O(m + log n) where n is the size of the input map, and m is the size of the output map. The O(m) term is due to the need to calculate the length of the output map. *) val subrange : ('k, 'v, 'cmp) t -> lower_bound:'k Maybe_bound.t -> upper_bound:'k Maybe_bound.t -> ('k, 'v, 'cmp) t (** [fold_range_inclusive t ~min ~max ~init ~f] folds [f] (with initial value [~init]) over all keys (and their associated values) that are in the range [[min, max]] (inclusive). *) val fold_range_inclusive : ('k, 'v, 'cmp) t -> min:'k -> max:'k -> init:'a -> f:(key:'k -> data:'v -> 'a -> 'a) -> 'a (** [range_to_alist t ~min ~max] returns an associative list of the elements whose keys lie in [[min, max]] (inclusive), with the smallest key being at the head of the list. *) val range_to_alist : ('k, 'v, 'cmp) t -> min:'k -> max:'k -> ('k * 'v) list (** [closest_key t dir k] returns the [(key, value)] pair in [t] with [key] closest to [k], which satisfies the given inequality bound. For example, [closest_key t `Less_than k] would be the pair with the closest key to [k] where [key < k]. [to_sequence] can be used to get the same results as [closest_key]. It is less efficient for individual lookups but more efficient for finding many elements starting at some value. *) val closest_key : ('k, 'v, 'cmp) t -> [ `Greater_or_equal_to | `Greater_than | `Less_or_equal_to | `Less_than ] -> 'k -> ('k * 'v) option (** [nth t n] finds the (key, value) pair of rank n (i.e., such that there are exactly n keys strictly less than the found key), if one exists. O(log(length t) + n) time. *) val nth : ('k, 'v, _) t -> int -> ('k * 'v) option val nth_exn : ('k, 'v, _) t -> int -> 'k * 'v (** [rank t k] if [k] is in [t], returns the number of keys strictly less than [k] in [t], otherwise [None]. *) val rank : ('k, 'v, 'cmp) t -> 'k -> int option (** [to_sequence ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t] gives a sequence of key-value pairs between [keys_less_or_equal_to] and [keys_greater_or_equal_to] inclusive, presented in [order]. If [keys_greater_or_equal_to > keys_less_or_equal_to], the sequence is empty. Cost is O(log n) up front and amortized O(1) to produce each element. @param order [`Increasing_key] is the default *) val to_sequence : ?order:[ `Increasing_key | `Decreasing_key ] -> ?keys_greater_or_equal_to:'k -> ?keys_less_or_equal_to:'k -> ('k, 'v, 'cmp) t -> ('k * 'v) Sequence.t (** [binary_search t ~compare which elt] returns the [(key, value)] pair in [t] specified by [compare] and [which], if one exists. [t] must be sorted in increasing order according to [compare], where [compare] and [elt] divide [t] into three (possibly empty) segments: {v | < elt | = elt | > elt | v} [binary_search] returns an element on the boundary of segments as specified by [which]. See the diagram below next to the [which] variants. [binary_search] does not check that [compare] orders [t], and behavior is unspecified if [compare] doesn't order [t]. Behavior is also unspecified if [compare] mutates [t]. *) val binary_search : ('k, 'v, 'cmp) t -> compare:(key:'k -> data:'v -> 'key -> int) -> [ `Last_strictly_less_than (** {v | < elt X | v} *) | `Last_less_than_or_equal_to (** {v | <= elt X | v} *) | `Last_equal_to (** {v | = elt X | v} *) | `First_equal_to (** {v | X = elt | v} *) | `First_greater_than_or_equal_to (** {v | X >= elt | v} *) | `First_strictly_greater_than (** {v | X > elt | v} *) ] -> 'key -> ('k * 'v) option (** [binary_search_segmented t ~segment_of which] takes a [segment_of] function that divides [t] into two (possibly empty) segments: {v | segment_of elt = `Left | segment_of elt = `Right | v} [binary_search_segmented] returns the [(key, value)] pair on the boundary of the segments as specified by [which]: [`Last_on_left] yields the last element of the left segment, while [`First_on_right] yields the first element of the right segment. It returns [None] if the segment is empty. [binary_search_segmented] does not check that [segment_of] segments [t] as in the diagram, and behavior is unspecified if [segment_of] doesn't segment [t]. Behavior is also unspecified if [segment_of] mutates [t]. *) val binary_search_segmented : ('k, 'v, 'cmp) t -> segment_of:(key:'k -> data:'v -> [ `Left | `Right ]) -> [ `Last_on_left | `First_on_right ] -> ('k * 'v) option (** [binary_search_subrange] takes a [compare] function that divides [t] into three (possibly empty) segments with respect to [lower_bound] and [upper_bound]: {v | Below_lower_bound | In_range | Above_upper_bound | v} and returns a map of the key-value pairs in [range]. Runtime is O(log n + m) where [n] is the length of the input map and [m] is the length of the output. The linear term is to compute the length of the output. Behavior is undefined if [compare] does not segment [t] as shown above, or is [compare] mutates its inputs. *) val binary_search_subrange : ('k, 'v, 'cmp) t -> compare:(key:'k -> data:'v -> 'bound -> int) -> lower_bound:'bound Maybe_bound.t -> upper_bound:'bound Maybe_bound.t -> ('k, 'v, 'cmp) t (** Convert a set to a map. Runs in [O(length t)] time plus a call to [f] for each key to compute the associated data. *) val of_key_set : ('key, 'cmp) Base.Set.t -> f:('key -> 'data) -> ('key, 'data, 'cmp) t (** Converts a map to a set of its keys. Runs in [O(length t)] time. *) val key_set : ('key, _, 'cmp) t -> ('key, 'cmp) Base.Set.t val quickcheck_generator : ('k, 'cmp) comparator -> 'k Quickcheck.Generator.t -> 'v Quickcheck.Generator.t -> ('k, 'v, 'cmp) t Quickcheck.Generator.t val quickcheck_observer : 'k Quickcheck.Observer.t -> 'v Quickcheck.Observer.t -> ('k, 'v, 'cmp) t Quickcheck.Observer.t (** This shrinker and the other shrinkers for maps and trees produce a shrunk value by dropping a key-value pair, shrinking a key or shrinking a value. A shrunk key will override an existing key's value. *) val quickcheck_shrinker : 'k Quickcheck.Shrinker.t -> 'v Quickcheck.Shrinker.t -> ('k, 'v, 'cmp) t Quickcheck.Shrinker.t (** {2 Which Map module should you use?} The map types and operations appear in three places: - Map: polymorphic map operations - Map.Poly: maps that use polymorphic comparison to order keys - Key.Map: maps with a fixed key type that use [Key.compare] to order keys where [Key] is any module defining values that can be used as keys of a map, like [Int], [String], etc. To add this functionality to an arbitrary module, use the [Comparable.Make] functor. You should use [Map] for functions that access existing maps, like [find], [mem], [add], [fold], [iter], and [to_alist]. For functions that create maps, like [empty], [singleton], and [of_alist], strive to use the corresponding [Key.Map] function, which will use the comparison function specifically for [Key]. As a last resort, if you don't have easy access to a comparison function for the keys in your map, use [Map.Poly] to create the map. This will use OCaml's built-in polymorphic comparison to compare keys, with all the usual performance and robustness problems that entails. {2 Interface design details} An instance of the map type is determined by the types of the map's keys and values, and the comparison function used to order the keys: {[ type ('key, 'value, 'cmp) Map.t ]} ['cmp] is a phantom type uniquely identifying the comparison function, as generated by [Comparator.Make]. [Map.Poly] supports arbitrary key and value types, but enforces that the comparison function used to order the keys is polymorphic comparison. [Key.Map] has a fixed key type and comparison function, and supports arbitrary values. {[ type ('key, 'value) Map.Poly.t = ('key , 'value, Comparator.Poly.t ) Map.t type 'value Key.Map.t = (Key.t, 'value, Key.comparator_witness) Map.t ]} The same map operations exist in [Map], [Map.Poly], and [Key.Map], albeit with different types. For example: {[ val Map.length : (_, _, _) Map.t -> int val Map.Poly.length : (_, _) Map.Poly.t -> int val Key.Map.length : _ Key.Map.t -> int ]} Because [Map.Poly.t] and [Key.Map.t] are exposed as instances of the more general [Map.t] type, one can use [Map.length] on any map. The same is true for all of the functions that access an existing map, such as [add], [change], [find], [fold], [iter], [map], [to_alist], etc. Depending on the number of type variables [N], the type of accessor (resp. creator) functions is defined in the module type [AccessorsN] ([CreatorsN]) in {!Map_intf}. Also for creators, when the comparison function is not fixed, i.e., the ['cmp] variable of [Map.t] is free, we need to pass a comparator to the function creating the map. The module type is called [Creators3_with_comparator]. There is also a module type [Accessors3_with_comparator] in addition to [Accessors3] which used for trees since the comparator is not known. *) module Using_comparator : sig include Creators3_with_comparator with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Tree.t end module Poly : sig type ('a, +'b, 'c) map module Tree : sig type ('k, +'v) t = ('k, 'v, Comparator.Poly.comparator_witness) Tree.t [@@deriving sexp, sexp_grammar] include Creators_and_accessors2 with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) t end type ('a, +'b) t = ('a, 'b, Comparator.Poly.comparator_witness) map [@@deriving bin_io, sexp, sexp_grammar, compare] include Creators_and_accessors2 with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) Tree.t end with type ('a, 'b, 'c) map = ('a, 'b, 'c) t module type Key_plain = Key_plain module type Key = Key module type Key_binable = Key_binable module type S_plain = S_plain module type S = S module type S_binable = S_binable module Make_plain (Key : Key_plain) : S_plain with type Key.t = Key.t module Make_plain_using_comparator (Key : sig type t [@@deriving sexp_of] include Comparator.S with type t := t end) : S_plain with type Key.t = Key.t with type Key.comparator_witness = Key.comparator_witness module Make (Key : Key) : S with type Key.t = Key.t module Make_using_comparator (Key : sig type t [@@deriving sexp] include Comparator.S with type t := t end) : S with type Key.t = Key.t with type Key.comparator_witness = Key.comparator_witness module Make_binable (Key : Key_binable) : S_binable with type Key.t = Key.t module Make_binable_using_comparator (Key : sig type t [@@deriving bin_io, sexp] include Comparator.S with type t := t end) : S_binable with type Key.t = Key.t with type Key.comparator_witness = Key.comparator_witness module Key_bin_io = Key_bin_io include For_deriving with type ('a, 'b, 'c) t := ('a, 'b, 'c) t module Make_tree_plain (Key : sig type t [@@deriving sexp_of] include Comparator.S with type t := t end) : Make_S_plain_tree(Key).S module Make_tree (Key : sig type t [@@deriving sexp] include Comparator.S with type t := t end) : sig include Make_S_plain_tree(Key).S include Sexpable.S1 with type 'a t := 'a t end (** The following functors may be used to define stable modules *) module Stable : sig module V1 : sig type nonrec ('a, 'b, 'c) t = ('a, 'b, 'c) t module type S = sig type key type comparator_witness type nonrec 'a t = (key, 'a, comparator_witness) t include Stable_module_types.S1 with type 'a t := 'a t end include For_deriving with type ('a, 'b, 'c) t := ('a, 'b, 'c) t module Make (Key : Stable_module_types.S0) : S with type key := Key.t with type comparator_witness := Key.comparator_witness end module Symmetric_diff_element : sig module V1 : Stable_module_types.S2 with type ('a, 'b) t = ('a, 'b) Symmetric_diff_element.t end end core-0.15.0/core/src/map_intf.ml000066400000000000000000000340171420273305200163760ustar00rootroot00000000000000(** This module defines interfaces used in {{!Map}[Map]}. See those docs for a description of the design. This module defines module types [{Creators,Accessors}{1,2,3,_generic,_with_comparator}]. It uses check functors to ensure that each module type is an instance of the corresponding [_generic] one. We must treat [Creators] and [Accessors] separately, because we sometimes need to choose different instantiations of their [options]. In particular, [Map] itself matches [Creators3_with_comparator] but [Accessors3] (without comparator). *) open! Import open T module Binable = Binable0 module Map = Base.Map module Or_duplicate = Map.Or_duplicate module With_comparator = Map.With_comparator module With_first_class_module = Map.With_first_class_module module Without_comparator = Map.Without_comparator module Tree = Map.Using_comparator.Tree module type Key_plain = sig type t [@@deriving compare, sexp_of] end module type Key = sig type t [@@deriving compare, sexp] end module type Key_binable = sig type t [@@deriving bin_io, compare, sexp] end module type Key_hashable = sig type t [@@deriving compare, hash, sexp] end module type Key_binable_hashable = sig type t [@@deriving bin_io, compare, hash, sexp] end module Key_bin_io = struct module type S = sig type t [@@deriving bin_io] type comparator_witness val comparator : (t, comparator_witness) Comparator.t end type ('t, 'c) t = (module S with type t = 't and type comparator_witness = 'c) end module type Accessors_generic = sig include Map.Accessors_generic val key_set : ('k, 'cmp, ('k, _, 'cmp) t -> ('k key, 'cmp cmp) Base.Set.t) options val validate : name:('k key -> string) -> 'v Validate.check -> ('k, 'v, _) t Validate.check val validatei : name:('k key -> string) -> ('k key * 'v) Validate.check -> ('k, 'v, _) t Validate.check val quickcheck_observer : 'k key Quickcheck.Observer.t -> 'v Quickcheck.Observer.t -> ('k, 'v, 'cmp) t Quickcheck.Observer.t val quickcheck_shrinker : ( 'k , 'cmp , 'k key Quickcheck.Shrinker.t -> 'v Quickcheck.Shrinker.t -> ('k, 'v, 'cmp) t Quickcheck.Shrinker.t ) options end module type Accessors1 = sig include Map.Accessors1 val key_set : _ t -> (key, comparator_witness) Base.Set.t val validate : name:(key -> string) -> 'a Validate.check -> 'a t Validate.check val validatei : name:(key -> string) -> (key * 'a) Validate.check -> 'a t Validate.check val quickcheck_observer : key Quickcheck.Observer.t -> 'v Quickcheck.Observer.t -> 'v t Quickcheck.Observer.t val quickcheck_shrinker : key Quickcheck.Shrinker.t -> 'v Quickcheck.Shrinker.t -> 'v t Quickcheck.Shrinker.t end module type Accessors2 = sig include Map.Accessors2 val key_set : ('k, 'v) t -> ('k, comparator_witness) Base.Set.t val validate : name:('a -> string) -> 'b Validate.check -> ('a, 'b) t Validate.check val validatei : name:('a -> string) -> ('a * 'b) Validate.check -> ('a, 'b) t Validate.check val quickcheck_observer : 'k Quickcheck.Observer.t -> 'v Quickcheck.Observer.t -> ('k, 'v) t Quickcheck.Observer.t val quickcheck_shrinker : 'k Quickcheck.Shrinker.t -> 'v Quickcheck.Shrinker.t -> ('k, 'v) t Quickcheck.Shrinker.t end module type Accessors3 = sig include Map.Accessors3 val key_set : ('k, _, 'cmp) t -> ('k, 'cmp) Base.Set.t val validate : name:('a -> string) -> 'b Validate.check -> ('a, 'b, _) t Validate.check val validatei : name:('a -> string) -> ('a * 'b) Validate.check -> ('a, 'b, _) t Validate.check val quickcheck_observer : 'k Quickcheck.Observer.t -> 'v Quickcheck.Observer.t -> ('k, 'v, _) t Quickcheck.Observer.t val quickcheck_shrinker : 'k Quickcheck.Shrinker.t -> 'v Quickcheck.Shrinker.t -> ('k, 'v, _) t Quickcheck.Shrinker.t end module type Accessors3_with_comparator = sig include Map.Accessors3_with_comparator val key_set : comparator:('k, 'cmp) Comparator.t -> ('k, _, 'cmp) t -> ('k, 'cmp) Base.Set.t val validate : name:('a -> string) -> 'b Validate.check -> ('a, 'b, _) t Validate.check val validatei : name:('k -> string) -> ('k * 'v) Validate.check -> ('k, 'v, _) t Validate.check val quickcheck_observer : 'k Quickcheck.Observer.t -> 'v Quickcheck.Observer.t -> ('k, 'v, 'cmp) t Quickcheck.Observer.t val quickcheck_shrinker : comparator:('k, 'cmp) Comparator.t -> 'k Quickcheck.Shrinker.t -> 'v Quickcheck.Shrinker.t -> ('k, 'v, 'cmp) t Quickcheck.Shrinker.t end (** Consistency checks (same as in [Container]). *) module Check_accessors (T : T3) (Tree : T3) (Key : T1) (Cmp : T1) (Options : T3) (_ : Accessors_generic with type ('a, 'b, 'c) options := ('a, 'b, 'c) Options.t with type ('a, 'b, 'c) t := ('a, 'b, 'c) T.t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Tree.t with type 'a key := 'a Key.t with type 'a cmp := 'a Cmp.t) = struct end module Check_accessors1 (M : Accessors1) = Check_accessors (struct type ('a, 'b, 'c) t = 'b M.t end) (struct type ('a, 'b, 'c) t = 'b M.tree end) (struct type 'a t = M.key end) (struct type 'a t = M.comparator_witness end) (Without_comparator) (M) module Check_accessors2 (M : Accessors2) = Check_accessors (struct type ('a, 'b, 'c) t = ('a, 'b) M.t end) (struct type ('a, 'b, 'c) t = ('a, 'b) M.tree end) (struct type 'a t = 'a end) (struct type 'a t = M.comparator_witness end) (Without_comparator) (M) module Check_accessors3 (M : Accessors3) = Check_accessors (struct type ('a, 'b, 'c) t = ('a, 'b, 'c) M.t end) (struct type ('a, 'b, 'c) t = ('a, 'b, 'c) M.tree end) (struct type 'a t = 'a end) (struct type 'a t = 'a end) (Without_comparator) (M) module Check_accessors3_with_comparator (M : Accessors3_with_comparator) = Check_accessors (struct type ('a, 'b, 'c) t = ('a, 'b, 'c) M.t end) (struct type ('a, 'b, 'c) t = ('a, 'b, 'c) M.tree end) (struct type 'a t = 'a end) (struct type 'a t = 'a end) (With_comparator) (M) module type Creators_generic = sig include Map.Creators_generic val of_hashtbl_exn : ('k, 'cmp, ('k key, 'v) Hashtbl.t -> ('k, 'v, 'cmp) t) options (** Never requires a comparator because it can get one from the input [Set.t]. *) val of_key_set : ('k key, 'cmp cmp) Base.Set.t -> f:('k key -> 'v) -> ('k, 'v, 'cmp) t val quickcheck_generator : ( 'k , 'cmp , 'k key Quickcheck.Generator.t -> 'v Quickcheck.Generator.t -> ('k, 'v, 'cmp) t Quickcheck.Generator.t ) options end module type Creators1 = sig include Map.Creators1 val of_hashtbl_exn : (key, 'a) Hashtbl.t -> 'a t val of_key_set : (key, comparator_witness) Base.Set.t -> f:(key -> 'v) -> 'v t val quickcheck_generator : key Quickcheck.Generator.t -> 'a Quickcheck.Generator.t -> 'a t Quickcheck.Generator.t end module type Creators2 = sig include Map.Creators2 val of_hashtbl_exn : ('a, 'b) Hashtbl.t -> ('a, 'b) t val of_key_set : ('a, comparator_witness) Base.Set.t -> f:('a -> 'b) -> ('a, 'b) t val quickcheck_generator : 'a Quickcheck.Generator.t -> 'b Quickcheck.Generator.t -> ('a, 'b) t Quickcheck.Generator.t end module type Creators3_with_comparator = sig include Map.Creators3_with_comparator val of_hashtbl_exn : comparator:('a, 'cmp) Comparator.t -> ('a, 'b) Hashtbl.t -> ('a, 'b, 'cmp) t val of_key_set : ('a, 'cmp) Base.Set.t -> f:('a -> 'b) -> ('a, 'b, 'cmp) t val quickcheck_generator : comparator:('a, 'cmp) Comparator.t -> 'a Quickcheck.Generator.t -> 'b Quickcheck.Generator.t -> ('a, 'b, 'cmp) t Quickcheck.Generator.t end module Check_creators (T : T3) (Tree : T3) (Key : T1) (Cmp : T1) (Options : T3) (_ : Creators_generic with type ('a, 'b, 'c) options := ('a, 'b, 'c) Options.t with type ('a, 'b, 'c) t := ('a, 'b, 'c) T.t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Tree.t with type 'a key := 'a Key.t with type 'a cmp := 'a Cmp.t) = struct end module Check_creators1 (M : Creators1) = Check_creators (struct type ('a, 'b, 'c) t = 'b M.t end) (struct type ('a, 'b, 'c) t = 'b M.tree end) (struct type 'a t = M.key end) (struct type 'a t = M.comparator_witness end) (Without_comparator) (M) module Check_creators2 (M : Creators2) = Check_creators (struct type ('a, 'b, 'c) t = ('a, 'b) M.t end) (struct type ('a, 'b, 'c) t = ('a, 'b) M.tree end) (struct type 'a t = 'a end) (struct type 'a t = M.comparator_witness end) (Without_comparator) (M) module Check_creators3_with_comparator (M : Creators3_with_comparator) = Check_creators (struct type ('a, 'b, 'c) t = ('a, 'b, 'c) M.t end) (struct type ('a, 'b, 'c) t = ('a, 'b, 'c) M.tree end) (struct type 'a t = 'a end) (struct type 'a t = 'a end) (With_comparator) (M) module type Creators_and_accessors_generic = sig include Creators_generic include Accessors_generic with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) tree with type 'a key := 'a key with type 'a cmp := 'a cmp with type ('a, 'b, 'c) options := ('a, 'b, 'c) options end module type Creators_and_accessors1 = sig include Creators1 include Accessors1 with type 'a t := 'a t with type 'a tree := 'a tree with type key := key with type comparator_witness := comparator_witness end module type Creators_and_accessors2 = sig include Creators2 include Accessors2 with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) tree with type comparator_witness := comparator_witness end module type Creators_and_accessors3_with_comparator = sig include Creators3_with_comparator include Accessors3_with_comparator with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) tree end module Make_S_plain_tree (Key : Comparator.S) = struct module type S = sig type 'a t = (Key.t, 'a, Key.comparator_witness) Tree.t [@@deriving sexp_of] include Creators_and_accessors1 with type 'a t := 'a t with type 'a tree := 'a t with type key := Key.t with type comparator_witness := Key.comparator_witness module Provide_of_sexp (K : sig type t [@@deriving of_sexp] end with type t := Key.t) : sig type _ t [@@deriving of_sexp] end with type 'a t := 'a t end end module type S_plain = sig module Key : sig type t [@@deriving sexp_of] include Comparator.S with type t := t end type +'a t = (Key.t, 'a, Key.comparator_witness) Map.t [@@deriving compare, sexp_of] include Creators_and_accessors1 with type 'a t := 'a t with type 'a tree := (Key.t, 'a, Key.comparator_witness) Tree.t with type key := Key.t with type comparator_witness := Key.comparator_witness module Provide_of_sexp (Key : sig type t [@@deriving of_sexp] end with type t := Key.t) : sig type _ t [@@deriving of_sexp] end with type 'a t := 'a t module Provide_bin_io (Key : sig type t [@@deriving bin_io] end with type t := Key.t) : Binable.S1 with type 'a t := 'a t module Provide_hash (Key : Hasher.S with type t := Key.t) : sig type 'a t [@@deriving hash] end with type 'a t := 'a t end module type S = sig module Key : sig type t [@@deriving sexp] include Comparator.S with type t := t end include S_plain with module Key := Key include Sexpable.S1 with type 'a t := 'a t end module type S_binable = sig module Key : sig type t [@@deriving bin_io, sexp] include Comparator.S with type t := t end include S with module Key := Key include Binable.S1 with type 'a t := 'a t end module type For_deriving = sig include Base.Map.For_deriving module M = Base.Map.M (** The following [*bin*] functions support bin-io on base-style maps, e.g.: {[ type t = int Map.M(String).t [@@deriving bin_io] ]} *) val bin_shape_m__t : ('a, 'c) Key_bin_io.t -> Bin_prot.Shape.t -> Bin_prot.Shape.t val bin_size_m__t : ('a, 'c) Key_bin_io.t -> 'b Bin_prot.Size.sizer -> ('a, 'b, 'c) t Bin_prot.Size.sizer val bin_write_m__t : ('a, 'c) Key_bin_io.t -> 'b Bin_prot.Write.writer -> ('a, 'b, 'c) t Bin_prot.Write.writer val bin_read_m__t : ('a, 'c) Key_bin_io.t -> 'b Bin_prot.Read.reader -> ('a, 'b, 'c) t Bin_prot.Read.reader val __bin_read_m__t__ : ('a, 'c) Key_bin_io.t -> 'b Bin_prot.Read.reader -> (int -> ('a, 'b, 'c) t) Bin_prot.Read.reader (** The following [quickcheck*] functions support deriving quickcheck on base-style maps, e.g.: {[ type t = int Map.M(String).t [@@deriving quickcheck] ]} *) module type Quickcheck_generator_m = sig include Comparator.S val quickcheck_generator : t Quickcheck.Generator.t end module type Quickcheck_observer_m = sig include Comparator.S val quickcheck_observer : t Quickcheck.Observer.t end module type Quickcheck_shrinker_m = sig include Comparator.S val quickcheck_shrinker : t Quickcheck.Shrinker.t end val quickcheck_generator_m__t : (module Quickcheck_generator_m with type t = 'k and type comparator_witness = 'cmp) -> 'v Quickcheck.Generator.t -> ('k, 'v, 'cmp) t Quickcheck.Generator.t val quickcheck_observer_m__t : (module Quickcheck_observer_m with type t = 'k and type comparator_witness = 'cmp) -> 'v Quickcheck.Observer.t -> ('k, 'v, 'cmp) t Quickcheck.Observer.t val quickcheck_shrinker_m__t : (module Quickcheck_shrinker_m with type t = 'k and type comparator_witness = 'cmp) -> 'v Quickcheck.Shrinker.t -> ('k, 'v, 'cmp) t Quickcheck.Shrinker.t end core-0.15.0/core/src/maybe_bound.ml000066400000000000000000000026131420273305200170620ustar00rootroot00000000000000open! Import module Stable = struct module V1 = struct type 'a t = 'a Base.Maybe_bound.t = | Incl of 'a | Excl of 'a | Unbounded [@@deriving bin_io, compare, sexp] let map x ~f = match x with | Incl x -> Incl (f x) | Excl x -> Excl (f x) | Unbounded -> Unbounded ;; end end include Base.Maybe_bound type 'a t = 'a Stable.V1.t = | Incl of 'a | Excl of 'a | Unbounded [@@deriving bin_io, compare, quickcheck, sexp] let compare_one_sided ~side compare_a t1 t2 = match t1, t2 with | Unbounded, Unbounded -> 0 | Unbounded, _ -> (match side with | `Lower -> -1 | `Upper -> 1) | _, Unbounded -> (match side with | `Lower -> 1 | `Upper -> -1) | Incl a1, Incl a2 -> compare_a a1 a2 | Excl a1, Excl a2 -> compare_a a1 a2 | Incl a1, Excl a2 -> let c = compare_a a1 a2 in if c = 0 then ( match side with | `Lower -> -1 | `Upper -> 1) else c | Excl a1, Incl a2 -> let c = compare_a a1 a2 in if c = 0 then ( match side with | `Lower -> 1 | `Upper -> -1) else c ;; module As_lower_bound = struct type nonrec 'a t = 'a t let compare compare_a t1 t2 = compare_one_sided ~side:`Lower compare_a t1 t2 end module As_upper_bound = struct type nonrec 'a t = 'a t let compare compare_a t1 t2 = compare_one_sided ~side:`Upper compare_a t1 t2 end core-0.15.0/core/src/maybe_bound.mli000066400000000000000000000027201420273305200172320ustar00rootroot00000000000000(** This module extends {{!Base.Maybe_bound}[Base.Maybe_bound]} with bin_io and with compare functions in the form of [As_lower_bound] and [As_upper_bound] modules. *) type 'a t = 'a Base.Maybe_bound.t = | Incl of 'a | Excl of 'a | Unbounded [@@deriving bin_io, quickcheck] (** @inline *) include module type of struct include Base.Maybe_bound end with type 'a t := 'a t (** Compares [t] values as lower bounds, where [Unbounded] is lowest, [Incl x < Excl x], and other cases of [Incl] and/or [Excl] are compared based on ['a]. If [As_lower_bound.compare compare t1 t2 <= 0] and [is_lower_bound t2 ~of_:a ~compare], then [is_lower_bound t1 ~of_:a ~compare]. For example, for [int As_lower_bound.t]: {[ Unbounded < ... < Incl 13 < Excl 13 < Incl 14 < Excl 14 < ... ]} *) module As_lower_bound : sig type nonrec 'a t = 'a t [@@deriving compare] end (** Compares [t] values as upper bounds, where [Unbounded] is highest, [Incl x > Excl x], and other cases of [Incl] and/or [Excl] are compared based on ['a]. If [As_upper_bound.compare compare_a t1 t2 <= 0] and [is_upper_bound t1 ~of_:a ~compare], then [is_upper_bound t2 ~of_:a ~compare]. For example, for [int As_upper_bound.t]: {[ ... < Excl 13 < Incl 13 < Excl 14 < Incl 14 < ... < Unbounded ]} *) module As_upper_bound : sig type nonrec 'a t = 'a t [@@deriving compare] end module Stable : sig module V1 : Stable_module_types.S1 with type 'a t = 'a t end core-0.15.0/core/src/md5.ml000066400000000000000000000072671420273305200152750ustar00rootroot00000000000000module T = struct include Bin_prot.Md5 let sexp_of_t t = t |> to_hex |> String.sexp_of_t let t_of_sexp s = s |> String.t_of_sexp |> of_hex_exn let t_sexp_grammar = Sexplib.Sexp_grammar.coerce String.t_sexp_grammar end let hash_fold_t accum t = String.hash_fold_t accum (T.to_binary t) let hash t = String.hash (T.to_binary t) module As_binary_string = struct module Stable = struct module V1 = struct type t = T.t [@@deriving compare] let hash_fold_t = hash_fold_t let hash = hash let sexp_of_t x = String.sexp_of_t (T.to_binary x) let t_of_sexp x = T.of_binary_exn (String.t_of_sexp x) let t_sexp_grammar = Sexplib.Sexp_grammar.coerce String.t_sexp_grammar include Bin_prot.Utils.Make_binable_without_uuid [@alert "-legacy"] (struct module Binable = String type t = Bin_prot.Md5.t let to_binable = T.to_binary let of_binable = T.of_binary_exn end) end end include Stable.V1 include Comparable.Make (Stable.V1) include Hashable.Make (Stable.V1) end module Stable = struct module V1 = struct type t = T.t [@@deriving compare, sexp, sexp_grammar] let hash_fold_t = hash_fold_t let hash = hash include Bin_prot.Utils.Make_binable_without_uuid [@alert "-legacy"] (struct module Binable = Bin_prot.Md5 type t = Bin_prot.Md5.t let to_binable = Fn.id let of_binable = Fn.id end) end let digest_string s = Md5_lib.string s end include Stable.V1 include Comparable.Make (Stable.V1) include Hashable.Make (Stable.V1) let digest_num_bytes = 16 let to_hex = T.to_hex let from_hex = T.of_hex_exn let of_hex_exn = T.of_hex_exn let of_binary_exn = T.of_binary_exn let to_binary = T.to_binary let digest_string = Stable.digest_string let digest_bytes = Md5_lib.bytes external caml_sys_open : string -> Caml.open_flag list -> perm:int -> int = "caml_sys_open" external caml_sys_close : int -> unit = "caml_sys_close" external digest_fd_blocking : int -> string = "core_md5_fd" let digest_file_blocking path = of_binary_exn (Base.Exn.protectx (caml_sys_open path [ Open_rdonly; Open_binary ] ~perm:0o000) ~f:digest_fd_blocking ~finally:caml_sys_close) ;; let file = digest_file_blocking let digest_channel_blocking_without_releasing_runtime_lock channel ~len = of_binary_exn (Caml.Digest.channel channel len) ;; let channel channel len = digest_channel_blocking_without_releasing_runtime_lock channel ~len ;; let output_blocking t oc = Caml.Digest.output oc (to_binary t) let output oc t = output_blocking t oc let input_blocking ic = of_binary_exn (Caml.Digest.input ic) let input = input_blocking let digest_subbytes = Md5_lib.subbytes let string = digest_string let bytes = digest_bytes let subbytes s pos len = digest_subbytes s ~pos ~len let digest_bin_prot writer value = digest_string (Core_bin_prot.Writer.to_string writer value) ;; external c_digest_subbigstring : Bigstring.t -> pos:int -> len:int -> res:Bytes.t -> unit = "core_md5_digest_subbigstring" let unsafe_digest_subbigstring buf ~pos ~len = (* It's more efficient to allocate the result on the OCaml side and declare the C function as noalloc than to let the C function allocate. *) let res = Bytes.create 16 in c_digest_subbigstring buf ~pos ~len ~res; Md5_lib.unsafe_of_binary (Bytes.unsafe_to_string ~no_mutation_while_string_reachable:res) ;; let digest_subbigstring buf ~pos ~len = Ordered_collection_common.check_pos_len_exn ~pos ~len ~total_length:(Bigstring.length buf); unsafe_digest_subbigstring buf ~pos ~len ;; let digest_bigstring buf = unsafe_digest_subbigstring buf ~pos:0 ~len:(Bigstring.length buf) ;; core-0.15.0/core/src/md5.mli000066400000000000000000000110361420273305200154330ustar00rootroot00000000000000(** This module implements the [MD5] message-digest algorithm as described IETF RFC 1321. [t] is the result type and [val digest_string : string -> t] is the implementation of the algorithm itself. This is currently a thin wrapper over the [Digest] module in INRIA's standard library. *) open Interfaces module Stable : sig module V1 : sig type t = Md5_lib.t [@@deriving sexp, sexp_grammar, bin_io, compare, hash] end end (** Both bin_io and sexp serializations produce a binary 16-character string. *) module As_binary_string : sig module Stable : sig module V1 : sig type t = Md5_lib.t [@@deriving sexp, sexp_grammar, bin_io, compare, hash] end end type t = Stable.V1.t [@@deriving bin_io, sexp, sexp_grammar, hash] include Comparable with type t := t include Binable with type t := t include Hashable with type t := t end (** Intended to represent a 16-byte string that is the output of MD5 algorithm. Note that any 16-byte string can be converted to this type, so a value of type [t] is not an evidence of someone having found an input corresponding to this output. *) type t = Stable.V1.t [@@deriving bin_io, sexp, sexp_grammar, hash] include Comparable with type t := t include Binable with type t := t include Hashable with type t := t (** [digest_num_bytes = 16] is the size of the digest in bytes. *) val digest_num_bytes : int (** Binary representations are 16 bytes long, and not human readable. *) val to_binary : t -> string val of_binary_exn : string -> t (** [to_hex] prints each byte of [t] as a big-endian sequence of 2 hex digits (e.g. byte 31 is written as "1f") and then concatenates them. For example, {[ Md5.to_hex (Md5.digest_string "a") = Md5.to_hex ( Md5.of_binary_exn "\x0c\xc1\x75\xb9\xc0\xf1\xb6\xa8\x31\xc3\x99\xe2\x69\x77\x26\x61") = "0cc175b9c0f1b6a831c399e269772661" ]} *) val to_hex : t -> string (** The inverse of [to_hex]. This function ignores case. It will raise an exception if the string is not a 32-byte-long string of hex digits. *) val of_hex_exn : string -> t val digest_string : string -> t val digest_bytes : bytes -> t (** [digest_subbytes m ~pos ~len] computes Md5 digest of the substring of [m] of length [len] starting at [pos]. *) val digest_subbytes : bytes -> pos:int -> len:int -> t (** [digest_file_blocking filename] reads the contents of file [filename] and computes its digest. *) val digest_file_blocking : string -> t (** Reads [len] bytes from the given channel and computes md5 digest of that. WARNING: This function does digest computation with OCaml global lock held, so it can be slow and make the other threads starve. See [digest_file_blocking]. *) val digest_channel_blocking_without_releasing_runtime_lock : in_channel -> len:int -> t (** Reads an Md5 digest from the given channel (in a format written by [output_blocking]) *) val input_blocking : in_channel -> t (** Writes the Md5 digest to the given channel. *) val output_blocking : t -> out_channel -> unit val string : string -> t [@@ocaml.deprecated "[since 2017-07] use [Md5.digest_string]."] val bytes : bytes -> t [@@ocaml.deprecated "[since 2017-07] use [Md5.digest_bytes]."] val subbytes : bytes -> int -> int -> t [@@ocaml.deprecated "[since 2017-07] use [Md5.digest_subbytes]."] val from_hex : string -> t [@@ocaml.deprecated "[since 2017-07] use [of_hex_exn]."] val file : string -> t [@@ocaml.deprecated "[since 2017-07] blocking functions should be avoided. Use [file_blocking] if you \ really want this."] val channel : in_channel -> int -> t [@@ocaml.deprecated "[since 2017-07] blocking functions should be avoided. Use [channel_blocking] if you \ really want this."] val output : out_channel -> t -> unit [@@ocaml.deprecated "[since 2017-07] Use [to_binary] together with [Out_channel.output_string]"] val input : in_channel -> t [@@ocaml.deprecated "[since 2017-07] blocking functions should be avoided. Use [input_blocking] if you \ really want this."] (** [digest_bin_prot w x] digests the serialization of [x] by [w]. It is a cheap way (in dev time) to compute the digest of an ocaml value, for a fixed and deterministic serialization function. It is currently implemented inefficiently and allocates large strings. For a more efficient and resource-aware version, use [Bigbuffer.add_bin_prot] and [Bigbuffer_blocking.md5]. *) val digest_bin_prot : 'a Bin_prot.Type_class.writer -> 'a -> t val digest_bigstring : Bigstring.t -> t val digest_subbigstring : Bigstring.t -> pos:int -> len:int -> t core-0.15.0/core/src/md5_stubs.c000066400000000000000000000040571420273305200163210ustar00rootroot00000000000000#include #include #include #include #include #include #include #include #define CAML_INTERNALS #if __GNUC__ < 8 #pragma GCC diagnostic ignored "-pedantic" #endif #include #include #undef CAML_INTERNALS /* Contrary to caml_md5_chan, this function releases the runtime lock. [fd] must be a file descriptor open for reading and not be nonblocking, otherwise the function might fail non-deterministically. */ CAMLprim value core_md5_fd(value fd) { CAMLparam1 (fd); value res; struct MD5Context ctx; caml_enter_blocking_section(); { intnat bytes_read; char buffer[4096]; caml_MD5Init(&ctx); while (1){ bytes_read = read (Int_val(fd), buffer, sizeof(buffer)); if (bytes_read < 0) { if (errno == EINTR) continue; caml_leave_blocking_section(); caml_sys_io_error(NO_ARG); } if (bytes_read == 0) break; caml_MD5Update (&ctx, (unsigned char *) buffer, bytes_read); } } caml_leave_blocking_section(); res = caml_alloc_string(16); caml_MD5Final(&Byte_u(res, 0), &ctx); CAMLreturn (res); } /* Cutoff point at which we need to release the runtime lock. The idea is that computing the md5 of a large block is slow so it's worth releasing the runtime lock to allow the computation to happen in parallel with OCaml code. The divisor is obtained by running the "md5 vs memcpy" benchmarks and comparing the results. */ #define MD5_CUTOFF (THREAD_IO_CUTOFF / 50) CAMLprim value core_md5_digest_subbigstring(value buf, value ofs, value vlen, value res) { CAMLparam2(buf, res); struct MD5Context ctx; unsigned char *data = (unsigned char*)Caml_ba_data_val(buf) + Long_val(ofs); size_t len = Long_val(vlen); caml_MD5Init(&ctx); if (len > MD5_CUTOFF) caml_enter_blocking_section(); caml_MD5Update(&ctx, data, len); if (len > MD5_CUTOFF) caml_leave_blocking_section(); caml_MD5Final(&Byte_u(res, 0), &ctx); CAMLreturn(Val_unit); } core-0.15.0/core/src/memo.ml000066400000000000000000000063461420273305200155420ustar00rootroot00000000000000open! Import open Std_internal type ('a, 'b) fn = 'a -> 'b module Result = struct type 'a t = | Rval of 'a | Expt of exn let return = function | Rval v -> v | Expt e -> raise e ;; let capture f x = try Rval (f x) with | Caml.Sys.Break as e -> raise e | e -> Expt e ;; end let unit f = let l = Lazy.from_fun f in fun () -> Lazy.force l ;; let unbounded (type a) ?(hashable = Hashtbl.Hashable.poly) f = let cache = let module A = Hashable.Make_plain_and_derive_hash_fold_t (struct type t = a let { Hashtbl.Hashable.hash; compare; sexp_of_t } = hashable end) in A.Table.create () ~size:0 in (* Allocate this closure at the call to [unbounded], not at each call to the memoized function. *) let really_call_f arg = Result.capture f arg in fun arg -> Result.return (Hashtbl.findi_or_add cache arg ~default:really_call_f) ;; (* the same but with a bound on cache size *) let lru (type a) ?(hashable = Hashtbl.Hashable.poly) ~max_cache_size f = if max_cache_size <= 0 then failwithf "Memo.lru: max_cache_size of %i <= 0" max_cache_size (); let module Cache = Hash_queue.Make (struct type t = a let { Hashtbl.Hashable.hash; compare; sexp_of_t } = hashable end) in let cache = Cache.create () in fun arg -> Result.return (match Cache.lookup_and_move_to_back cache arg with | Some result -> result | None -> let result = Result.capture f arg in Cache.enqueue_back_exn cache arg result; (* eject least recently used cache entry *) if Cache.length cache > max_cache_size then ignore (Cache.dequeue_front_exn cache : _ Result.t); result) ;; let general ?hashable ?cache_size_bound f = match cache_size_bound with | None -> unbounded ?hashable f | Some n -> lru ?hashable ~max_cache_size:n f ;; (* We expect [f_onestep] to be a one-step unrolled recursive function; see the mli. Hence, here we create the memoized function _and_ pass it to [f_onestep] to be used for recursive calls. Note that we immediately apply [f_onestep] to its first argument here so that any precomputation is performed when the user calls [recursive]. As an example, if someone writes this non-memoized code: [ let rec f = let data = compute_without_using_f () in fun x -> ... f ... ] and converts to memoization by doing: {[ let f = let f_onestep f = let data = compute_without_using_f () in fun x -> ... f ... in recursive f_onestep ]} we want to compute [data] immediately. If we had [fun x -> f_onestep (force memoized) x] below, we'd recompute [data] each time the user calls [f] on an argument that hadn't yet been memoized. *) let recursive ~hashable ?cache_size_bound f_onestep = let rec memoized = lazy (general ~hashable ?cache_size_bound (f_onestep (fun x -> (force memoized) x))) in force memoized ;; let of_comparable (type index) (module M : Comparable.S_plain with type t = index) f = let m = ref M.Map.empty in fun (x : M.t) -> let v = match Map.find !m x with | Some v -> v | None -> let v = Result.capture f x in m := Map.set !m ~key:x ~data:v; v in Result.return v ;; core-0.15.0/core/src/memo.mli000066400000000000000000000067351420273305200157150ustar00rootroot00000000000000open! Import (** Memoization of OCaml functions of a single argument. The default caching policy is to remember everything for the lifetime of the returned closure, but [cache_size_bound] allows one to specify an upper bound on cache size. Whenever a cache entry must be forgotten in order to obey this bound, we pick the least-recently-used one. The functions raise exceptions if [cache_size_bound] is negative or zero. As you can tell from the type, the function that is memoized is the function of the first argument. To memoize a function with multiple arguments, pack them up in a tuple. See ../test/src/memo_argument.mlt for some examples. This module does not detect or prevent infinite loops (e.g., due to a recursive call that repeats an argument). The implementation is not thread-safe. *) (** A type definition to indicate that the expected use outputs a function *) type ('a, 'b) fn = 'a -> 'b (** Returns a memoized version of a function with a single argument. Of course, if the supplied function is recursive, only the outer calls are memoized; recursive calls are not. For that, see [recursive] below. *) val general : ?hashable:'a Hashtbl.Hashable.t -> ?cache_size_bound:int -> ('a -> 'b) -> ('a, 'b) fn (** [recursive] is like [general] but can be used to memoize recursive functions in such a way that the recursive calls are memoized as well. As a concrete example, consider the following definition of the Fibonacci function. {[ let rec fib x = if x < 2 then x else fib (x - 1) + fib (x - 2) ]} We can create a memoized version of this by first creating a non-recursive version of [fib] called [fib_nonrecursive], where the recursive knot has been untied. {[ let fib_nonrecursive fib x = if x < 2 then x else fib (x - 1) + fib (x - 2) ]} Here, rather than recursively calling itself, the function calls a function provided to it as an argument. We can now use [recursive] to retie the recursive knot, injecting memoization at that point. {[ let fib = Memo.recursive ~hashable:Int.hashable fib_nonrecursive ]} Note that calling [recursive ~hashable f_nonrecursive] does the partial application, [f_nonrecursive f], at the time it is called, so that any side-effects or expensive computations that happen at the partial application stage happen just once, not once per evaluation. [recursive] does not detect or prevent infinite loops, e.g., [Memo.recursive ~hashable (fun f x -> f x)] will just run until it overflows the stack. Finally, note that [recursive] keeps memory around between invocations of the produced function, which may not be what you want if you're only trying to optimize recursive calls. You can achieve this with [recursive] by eta-expanding. {[ let fib x = Memo.recursive ~hashable:Int.hashable fib_nonrecursive x ]} Note that the above would be a mistake when using [general], since it would completely obviate the point of the call, but makes sense for [recursive], since it would still optimize recursive calls within one outer invocation. *) val recursive : hashable:'a Hashtbl.Hashable.t -> ?cache_size_bound: int -> (('a -> 'b) -> 'a -> 'b) -> ('a, 'b) fn (** efficient special case for argument type [unit] *) val unit : (unit -> 'a) -> (unit, 'a) fn (** Use a comparable instead of hashable type *) val of_comparable : (module Comparable.S_plain with type t = 'a) -> ('a -> 'b) -> ('a, 'b) fn core-0.15.0/core/src/month.ml000066400000000000000000000065651420273305200157350ustar00rootroot00000000000000open! Import module Stable = struct module V1 = struct type t = | Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec [@@deriving sexp, compare, equal, hash, quickcheck, variants] let failwithf = Printf.failwithf let of_int_exn i : t = match i with | 1 -> Jan | 2 -> Feb | 3 -> Mar | 4 -> Apr | 5 -> May | 6 -> Jun | 7 -> Jul | 8 -> Aug | 9 -> Sep | 10 -> Oct | 11 -> Nov | 12 -> Dec | _ -> failwithf "Month.of_int_exn %d" i () ;; let of_int i = try Some (of_int_exn i) with | _ -> None ;; let to_int (t : t) = match t with | Jan -> 1 | Feb -> 2 | Mar -> 3 | Apr -> 4 | May -> 5 | Jun -> 6 | Jul -> 7 | Aug -> 8 | Sep -> 9 | Oct -> 10 | Nov -> 11 | Dec -> 12 ;; include Binable.Stable.Of_binable.V1 [@alert "-legacy"] (Int) (struct type nonrec t = t let to_binable t = to_int t - 1 let of_binable i = of_int_exn (i + 1) end) include (val Comparator.Stable.V1.make ~compare ~sexp_of_t) end end let num_months = 12 module T = struct include Stable.V1 let all = [ Jan; Feb; Mar; Apr; May; Jun; Jul; Aug; Sep; Oct; Nov; Dec ] let hash = to_int end include T include ( Hashable.Make_binable (struct include T end) : Hashable.S_binable with type t := t) include Comparable.Make_binable_using_comparator (struct include T (* In 108.06a and earlier, months in sexps of Maps and Sets were raw ints. From 108.07 through 109.13, the output format remained raw as before, but both the raw and pretty format were accepted as input. From 109.14 on, the output format was changed from raw to pretty, while continuing to accept both formats. Once we believe most programs are beyond 109.14, we will switch the input format to no longer accept raw. *) let t_of_sexp sexp = match Option.try_with (fun () -> Int.t_of_sexp sexp) with | Some i -> of_int_exn (i + 1) | None -> T.t_of_sexp sexp ;; end) (* Replace the overriden sexp converters from [Comparable.Make_binable] with the ordinary symbolic converters. *) let sexp_of_t = T.sexp_of_t let t_of_sexp = T.t_of_sexp let shift t i = of_int_exn (1 + Int.( % ) (to_int t - 1 + i) num_months) let all_strings = lazy (Array.of_list (List.map all ~f:(fun variant -> Sexp.to_string (sexp_of_t variant)))) ;; let to_string (t : t) = let all_strings = Lazy.force all_strings in all_strings.(to_int t - 1) ;; let of_string = let table = lazy (let module T = String.Table in let table = T.create ~size:num_months () in Array.iteri (Lazy.force all_strings) ~f:(fun i s -> let t = of_int_exn (i + 1) in Hashtbl.set table ~key:s ~data:t; Hashtbl.set table ~key:(String.lowercase s) ~data:t; Hashtbl.set table ~key:(String.uppercase s) ~data:t); table) in fun str -> match Hashtbl.find (Lazy.force table) str with | Some x -> x | None -> failwithf "Invalid month: %s" str () ;; module Export = struct type month = t = | Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec end core-0.15.0/core/src/month.mli000066400000000000000000000003051420273305200160700ustar00rootroot00000000000000(** Provides a variant type for representing months (e.g., [Jan], [Feb], or [Nov]) and functions for converting them to other formats (like an int). *) include Month_intf.Month (** @inline *) core-0.15.0/core/src/month_intf.ml000066400000000000000000000031551420273305200167450ustar00rootroot00000000000000open! Import module type Month = sig type t = | Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec [@@deriving bin_io, hash, equal, quickcheck, sexp, variants] include Comparable.S_binable with type t := t include Hashable.S_binable with type t := t (** [of_string s] accepts three-character abbreviations with three capitalizations (e.g. Jan, JAN, and jan). *) include Stringable.S with type t := t val all : t list (** [of_int i] returns the [i]th month if [i] is in 1, 2, ... , 12. Otherwise it returns [None]. *) val of_int : int -> t option val of_int_exn : int -> t (** [to_int t] returns an int in 1, 2, ... 12. *) val to_int : t -> int (** [shift t i] goes forward (or backward) the specified number of months. *) val shift : t -> int -> t module Export : sig type month = t = | Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec [@@deprecated "[since 2016-06] no longer needed since ocaml is now better at inferring the \ module where a constructor is defined"] end module Stable : sig module V1 : sig type nonrec t = t = | Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec [@@deriving sexp, bin_io, compare, hash, equal] include Stable_module_types.S0 with type comparator_witness = comparator_witness and type t := t end end end core-0.15.0/core/src/nativeint.ml000066400000000000000000000014621420273305200166000ustar00rootroot00000000000000open! Import include Identifiable.Extend (Base.Nativeint) (struct type t = nativeint [@@deriving bin_io] end) include Base.Nativeint include Comparable.Validate_with_zero (Base.Nativeint) type t = nativeint [@@deriving typerep] module Hex = struct include Hex type nonrec t = t [@@deriving typerep, bin_io] end let quickcheck_generator = Base_quickcheck.Generator.nativeint let quickcheck_observer = Base_quickcheck.Observer.nativeint let quickcheck_shrinker = Base_quickcheck.Shrinker.nativeint let gen_incl = Base_quickcheck.Generator.nativeint_inclusive let gen_uniform_incl = Base_quickcheck.Generator.nativeint_uniform_inclusive let gen_log_incl = Base_quickcheck.Generator.nativeint_log_inclusive let gen_log_uniform_incl = Base_quickcheck.Generator.nativeint_log_uniform_inclusive core-0.15.0/core/src/nativeint.mli000066400000000000000000000003541420273305200167500ustar00rootroot00000000000000(** This module extends {{!Base.Nativeint}[Base.Nativeint]}. *) (** @inline *) include module type of struct include Base.Nativeint end include Int_intf.Extension with type t := t and type comparator_witness := comparator_witness core-0.15.0/core/src/never_returns.ml000066400000000000000000000001601420273305200174720ustar00rootroot00000000000000open! Import type never_returns = Nothing.t [@@deriving sexp_of] let never_returns = Nothing.unreachable_code core-0.15.0/core/src/never_returns.mli000066400000000000000000000007651420273305200176560ustar00rootroot00000000000000(** [never_returns] should be used as the return type of functions that don't return and might block forever, rather than ['a] or [_]. This forces callers of such functions to have a call to [never_returns] at the call site, which makes it clear to readers what's going on. We do not intend to use this type for functions such as [failwithf] that always raise an exception. *) open! Import type never_returns = Nothing.t [@@deriving sexp_of] val never_returns : never_returns -> _ core-0.15.0/core/src/no_polymorphic_compare.ml000066400000000000000000000010171420273305200213420ustar00rootroot00000000000000open! Import type compare = [ `no_polymorphic_compare ] -> [ `no_polymorphic_compare ] -> [ `no_polymorphic_compare ] let compare _ _ = `no_polymorphic_compare let ( < ) _ _ = `no_polymorphic_compare let ( <= ) _ _ = `no_polymorphic_compare let ( > ) _ _ = `no_polymorphic_compare let ( >= ) _ _ = `no_polymorphic_compare let ( = ) _ _ = `no_polymorphic_compare let ( <> ) _ _ = `no_polymorphic_compare let equal _ _ = `no_polymorphic_compare let min _ _ = `no_polymorphic_compare let max _ _ = `no_polymorphic_compare core-0.15.0/core/src/no_polymorphic_compare.mli000066400000000000000000000007321420273305200215160ustar00rootroot00000000000000(** Open this in modules where you don't want to accidentally use polymorphic comparison. Then, use [Poly.(<)], for example, where needed. *) open! Import type compare = [ `no_polymorphic_compare ] -> [ `no_polymorphic_compare ] -> [ `no_polymorphic_compare ] val compare : compare val ( < ) : compare val ( <= ) : compare val ( > ) : compare val ( >= ) : compare val ( = ) : compare val ( <> ) : compare val equal : compare val min : compare val max : compare core-0.15.0/core/src/nothing.ml000066400000000000000000000024311420273305200162420ustar00rootroot00000000000000open! Import module Stable = struct module V1 = struct type t = Base.Nothing.t = | module Shape = struct type t [@@deriving bin_shape] end let unreachable_code = Base.Nothing.unreachable_code let bin_shape_t = Shape.bin_shape_t let tp_loc = [%here].pos_fname ^ ".Stable.V1.t" let all = [] let hash_fold_t _ t = unreachable_code t let hash = unreachable_code let compare a _ = unreachable_code a let bin_size_t = unreachable_code let bin_write_t _buf ~pos:_ t = unreachable_code t let bin_writer_t = { Bin_prot.Type_class.size = bin_size_t; write = bin_write_t } let __bin_read_t__ _buf ~pos_ref _ = Bin_prot.Common.raise_variant_wrong_type tp_loc !pos_ref ;; let bin_read_t _buf ~pos_ref = Bin_prot.Common.raise_read_error (Empty_type tp_loc) !pos_ref ;; let bin_reader_t = { Bin_prot.Type_class.read = bin_read_t; vtag_read = __bin_read_t__ } ;; let bin_t = { Bin_prot.Type_class.writer = bin_writer_t ; reader = bin_reader_t ; shape = bin_shape_t } ;; let sexp_of_t = unreachable_code let t_of_sexp sexp = Sexplib.Conv_error.empty_type tp_loc sexp end end include Stable.V1 include Base.Nothing include Identifiable.Extend (Base.Nothing) (Stable.V1) core-0.15.0/core/src/nothing.mli000066400000000000000000000013541420273305200164160ustar00rootroot00000000000000(** This module extends {{!Base.Nothing}[Base.Nothing]}. *) open! Import (** @inline *) include module type of struct include Base.Nothing end (** It may seem weird that this is identifiable, but we're just trying to anticipate all the contexts in which people may need this. It would be a crying shame if you had some variant type involving [Nothing.t] that you wished to make identifiable, but were prevented for lack of [Identifiable.S] here. Obviously, [of_string] and [t_of_sexp] will raise an exception. *) include Identifiable.S with type t := t and type comparator_witness := comparator_witness module Stable : sig module V1 : sig type nonrec t = t [@@deriving bin_io, compare, enumerate, hash, sexp] end end core-0.15.0/core/src/ofday_float.ml000066400000000000000000000254601420273305200170720ustar00rootroot00000000000000open! Import open Std_internal open Digit_string_helpers open! Int.Replace_polymorphic_compare module Span = Span_float (* Create an abstract type for Ofday to prevent us from confusing it with other floats. *) module Stable = struct module V1 = struct module T : sig type underlying = float type t = private underlying [@@deriving bin_io, hash, typerep] include Comparable.S_common with type t := t include Robustly_comparable with type t := t include Floatable with type t := t val add : t -> Span.t -> t option val sub : t -> Span.t -> t option val next : t -> t option val prev : t -> t option val diff : t -> t -> Span.t val of_span_since_start_of_day_exn : Span.t -> t val of_span_since_start_of_day_unchecked : Span.t -> t val span_since_start_of_day_is_valid : Span.t -> bool val to_span_since_start_of_day : t -> Span.t val start_of_day : t val start_of_next_day : t end = struct (* Number of seconds since midnight. *) type underlying = Float.t include ( struct include Float let sign = sign_exn end : sig type t = underlying [@@deriving bin_io, hash, typerep] include Comparable.S_common with type t := t include Comparable.With_zero with type t := t include Robustly_comparable with type t := t include Floatable with type t := t end) (* IF THIS REPRESENTATION EVER CHANGES, ENSURE THAT EITHER (1) all values serialize the same way in both representations, or (2) you add a new Time.Ofday version to stable.ml *) (* due to precision limitations in float we can't expect better than microsecond precision *) include Float.Robust_compare.Make (struct let robust_comparison_tolerance = 1E-6 end) let to_span_since_start_of_day t = Span.of_sec t (* Another reasonable choice would be only allowing Ofday.t to be < 24hr, but this choice was made early on and people became used to being able to easily call 24hr the end of the day. It's a bit sad because it shares that moment with the beginning of the next day, and round trips oddly if passed through Time.to_date_ofday/Time.of_date_ofday. Note: [Schedule.t] requires that the end of day be representable, as it's the only way to write a schedule in terms of [Ofday.t]s that spans two weekdays. *) (* ofday must be >= 0 and <= 24h *) let is_valid (t : t) = let t = to_span_since_start_of_day t in Span.( <= ) Span.zero t && Span.( <= ) t Span.day ;; let of_span_since_start_of_day_unchecked span = Span.to_sec span let span_since_start_of_day_is_valid span = is_valid (of_span_since_start_of_day_unchecked span) ;; let of_span_since_start_of_day_exn span = let module C = Float.Class in let s = Span.to_sec span in match Float.classify s with | C.Infinite -> invalid_arg "Ofday.of_span_since_start_of_day_exn: infinite value" | C.Nan -> invalid_arg "Ofday.of_span_since_start_of_day_exn: NaN value" | C.Normal | C.Subnormal | C.Zero -> if not (is_valid s) then invalid_argf !"Ofday out of range: %{Span}" span () else s ;; let start_of_day = 0. let start_of_next_day = of_span_since_start_of_day_exn Span.day let add (t : t) (span : Span.t) = let t = t +. Span.to_sec span in if is_valid t then Some t else None ;; let sub (t : t) (span : Span.t) = let t = t -. Span.to_sec span in if is_valid t then Some t else None ;; let next t = let candidate = Float.one_ulp `Up t in if is_valid candidate then Some candidate else None ;; let prev t = let candidate = Float.one_ulp `Down t in if is_valid candidate then Some candidate else None ;; let diff t1 t2 = Span.( - ) (to_span_since_start_of_day t1) (to_span_since_start_of_day t2) ;; end let approximate_end_of_day = Option.value_exn (T.sub T.start_of_next_day Span.microsecond) ;; (* [create] chops off any subsecond part when [sec = 60] to handle leap seconds. In particular it's trying to be generous about reading in times on things like fix messages that might include an extra unlikely second. Other ways of writing a time, like 1000ms, while mathematically valid, don't match ways that people actually write times down, so we didn't see the need to support them. That is, a clock might legitimately read 23:59:60 (or, with 60 seconds at times of day other than 23:59, depending on the time zone), but it doesn't seem reasonable for a clock to read "23:59:59 and 1000ms". *) let create ?hr ?min ?sec ?ms ?us ?ns () = let ms, us, ns = match sec with | Some 60 -> Some 0, Some 0, Some 0 | _ -> ms, us, ns in T.of_span_since_start_of_day_exn (Span.create ?hr ?min ?sec ?ms ?us ?ns ()) ;; let to_parts t = Span.to_parts (T.to_span_since_start_of_day t) let to_string_gen ~drop_ms ~drop_us ~trim t = let ( / ) = Int63.( / ) in let ( ! ) = Int63.of_int in let ( mod ) = Int63.rem in let i = Int63.to_int_exn in assert (if drop_ms then drop_us else true); let float_sec = Span.to_sec (T.to_span_since_start_of_day t) in let us = Float.int63_round_nearest_exn (float_sec *. 1e6) in let ms, us = us / !1000, us mod !1000 |> i in let sec, ms = ms / !1000, ms mod !1000 |> i in let min, sec = sec / !60, sec mod !60 |> i in let hr, min = min / !60, min mod !60 |> i in let hr = i hr in let dont_print_us = drop_us || (trim && us = 0) in let dont_print_ms = drop_ms || (trim && ms = 0 && dont_print_us) in let dont_print_s = trim && sec = 0 && dont_print_ms in let len = if dont_print_s then 5 else if dont_print_ms then 8 else if dont_print_us then 12 else 15 in let buf = Bytes.create len in write_2_digit_int buf ~pos:0 hr; Bytes.set buf 2 ':'; write_2_digit_int buf ~pos:3 min; if dont_print_s then () else ( Bytes.set buf 5 ':'; write_2_digit_int buf ~pos:6 sec; if dont_print_ms then () else ( Bytes.set buf 8 '.'; write_3_digit_int buf ~pos:9 ms; if dont_print_us then () else write_3_digit_int buf ~pos:12 us)); Bytes.unsafe_to_string ~no_mutation_while_string_reachable:buf ;; let to_string_trimmed t = to_string_gen ~drop_ms:false ~drop_us:false ~trim:true t let to_sec_string t = to_string_gen ~drop_ms:true ~drop_us:true ~trim:false t let to_millisecond_string t = to_string_gen ~drop_ms:false ~drop_us:true ~trim:false t let small_diff = let hour = 3600. in fun ofday1 ofday2 -> let ofday1 = Span.to_sec (T.to_span_since_start_of_day ofday1) in let ofday2 = Span.to_sec (T.to_span_since_start_of_day ofday2) in let diff = ofday1 -. ofday2 in (* d1 is in (-hour; hour) *) let d1 = Float.mod_float diff hour in (* d2 is in (0;hour) *) let d2 = Float.mod_float (d1 +. hour) hour in let d = if Float.( > ) d2 (hour /. 2.) then d2 -. hour else d2 in Span.of_sec d ;; include T let to_string t = to_string_gen ~drop_ms:false ~drop_us:false ~trim:false t include Pretty_printer.Register (struct type nonrec t = t let to_string = to_string let module_name = "Core.Time.Ofday" end) let create_from_parsed string ~hr ~min ~sec ~subsec_pos ~subsec_len = let subsec = if Int.equal subsec_len 0 then 0. else Float.of_string (String.sub string ~pos:subsec_pos ~len:subsec_len) in Float.of_int ((hr * 3600) + (min * 60) + sec) +. subsec |> Span.of_sec |> T.of_span_since_start_of_day_exn ;; let of_string s = Ofday_helpers.parse s ~f:create_from_parsed let t_of_sexp sexp = match sexp with | Sexp.Atom s -> (try of_string s with | Invalid_argument s -> of_sexp_error ("Ofday.t_of_sexp: " ^ s) sexp) | _ -> of_sexp_error "Ofday.t_of_sexp" sexp ;; let t_sexp_grammar = Sexplib.Sexp_grammar.coerce String.t_sexp_grammar let sexp_of_t span = Sexp.Atom (to_string span) let of_string_iso8601_extended ?pos ?len str = try Ofday_helpers.parse_iso8601_extended ?pos ?len str ~f:create_from_parsed with | exn -> invalid_argf "Ofday.of_string_iso8601_extended(%s): %s" (String.subo str ?pos ?len) (Exn.to_string exn) () ;; end end include Stable.V1 let gen_incl lo hi = Span.gen_incl (to_span_since_start_of_day lo) (to_span_since_start_of_day hi) |> Quickcheck.Generator.map ~f:of_span_since_start_of_day_exn ;; let gen_uniform_incl lo hi = Span.gen_uniform_incl (to_span_since_start_of_day lo) (to_span_since_start_of_day hi) |> Quickcheck.Generator.map ~f:of_span_since_start_of_day_exn ;; let quickcheck_generator = gen_incl start_of_day start_of_next_day let quickcheck_observer = Quickcheck.Observer.unmap Span.quickcheck_observer ~f:to_span_since_start_of_day ;; let quickcheck_shrinker = Quickcheck.Shrinker.empty () include Hashable.Make_binable (struct type nonrec t = t [@@deriving bin_io, compare, hash, sexp_of] (* Previous versions rendered hash-based containers using float serialization rather than time serialization, so when reading hash-based containers in we accept either serialization. *) let t_of_sexp sexp = match Float.t_of_sexp sexp with | float -> of_float float | exception _ -> t_of_sexp sexp ;; end) module C = struct type t = T.t [@@deriving bin_io] type comparator_witness = T.comparator_witness let comparator = T.comparator let compare = T.comparator.compare (* In 108.06a and earlier, ofdays in sexps of Maps and Sets were raw floats. From 108.07 through 109.13, the output format remained raw as before, but both the raw and pretty format were accepted as input. From 109.14 on, the output format was changed from raw to pretty, while continuing to accept both formats. Once we believe most programs are beyond 109.14, we will switch the input format to no longer accept raw. *) let sexp_of_t = sexp_of_t let t_of_sexp sexp = match Option.try_with (fun () -> T.of_float (Float.t_of_sexp sexp)) with | Some t -> t | None -> t_of_sexp sexp ;; end module Map = Map.Make_binable_using_comparator (C) module Set = Set.Make_binable_using_comparator (C) include Comparable.Validate (C) let of_span_since_start_of_day = of_span_since_start_of_day_exn let to_millisec_string = to_millisecond_string core-0.15.0/core/src/ofday_float.mli000066400000000000000000000003331420273305200172330ustar00rootroot00000000000000open! Import include Ofday_intf.S with type underlying = float and module Span := Span_float module Stable : sig module V1 : sig type nonrec t = t [@@deriving bin_io, compare, hash, sexp, sexp_grammar] end end core-0.15.0/core/src/ofday_helpers.ml000066400000000000000000000222431420273305200174230ustar00rootroot00000000000000open! Import open Std_internal open Digit_string_helpers let suffixes char = let sprintf = Printf.sprintf in [ sprintf "%c" char; sprintf "%cM" char; sprintf "%c.M" char; sprintf "%c.M." char ] |> List.concat_map ~f:(fun suffix -> [ String.lowercase suffix; String.uppercase suffix ]) ;; let am_suffixes = lazy (suffixes 'A') let pm_suffixes = lazy (suffixes 'P') (* Avoids the allocation that [List.find] would entail in both both the closure input and the option output. *) let rec find_suffix string suffixes = match suffixes with | suffix :: suffixes -> if String.is_suffix string ~suffix then suffix else find_suffix string suffixes | [] -> "" ;; let has_colon string pos ~until = pos < until && Char.equal ':' string.[pos] (* This function defines what we meant by "decimal point", because in some string formats it means '.' and in some it can be '.' or ','. There's no particular demand for support for ',', and using just '.' lets us use [Float.of_string] for the decimal substring without any substitutions. *) let char_is_decimal_point string pos = Char.equal '.' string.[pos] let decrement_length_if_ends_in_space string len = if len > 0 && Char.equal ' ' string.[len - 1] then len - 1 else len ;; let[@cold] invalid_string string ~reason = raise_s [%message "Time.Ofday: invalid string" string reason] ;; let check_digits_with_underscore_and_return_if_nonzero string pos ~until = let nonzero = ref false in for pos = pos to until - 1 do match string.[pos] with | '0' | '_' -> () | '1' .. '9' -> nonzero := true | _ -> invalid_string string ~reason:"expected digits and/or underscores after decimal point" done; !nonzero ;; let check_digits_without_underscore_and_return_if_nonzero string pos ~until = let nonzero = ref false in for pos = pos to until - 1 do match string.[pos] with | '0' -> () | '1' .. '9' -> nonzero := true | _ -> invalid_string string ~reason:"expected digits after decimal point" done; !nonzero ;; let parse string ~f = let len = String.length string in let am_or_pm, until = (* discriminate among AM (1:30am), PM (12:30:00 P.M.), or 24-hr (13:00). *) match ( find_suffix string (Lazy.force am_suffixes) , find_suffix string (Lazy.force pm_suffixes) ) with | "", "" -> `hr_24, len | am, "" -> `hr_AM, decrement_length_if_ends_in_space string (len - String.length am) | "", pm -> `hr_PM, decrement_length_if_ends_in_space string (len - String.length pm) | _, _ -> `hr_24, assert false (* Immediately above, it may seem nonsensical to write [`hr_24, assert false] when the [`hr_24] can never be returned. We do this to help the compiler figure out never to allocate a tuple in this code: the [let] pattern is syntactically a tuple and every match clause is syntactically a tuple. *) in let pos = 0 in let pos, hr, expect_minutes_and_seconds = (* e.g. "1:00" or "1:00:00" *) if has_colon string (pos + 1) ~until then pos + 2, read_1_digit_int string ~pos, `Minutes_and_maybe_seconds (* e.g. "12:00" or "12:00:00" *) else if has_colon string (pos + 2) ~until then pos + 3, read_2_digit_int string ~pos, `Minutes_and_maybe_seconds (* e.g. "1am"; must have AM or PM (checked below) *) else if pos + 1 = until then pos + 1, read_1_digit_int string ~pos, `Neither_minutes_nor_seconds (* e.g. "12am"; must have AM or PM (checked below) *) else if pos + 2 = until then pos + 2, read_2_digit_int string ~pos, `Neither_minutes_nor_seconds (* e.g. "0930"; must not have seconds *) else pos + 2, read_2_digit_int string ~pos, `Minutes_but_not_seconds in let pos, min, expect_seconds = match expect_minutes_and_seconds with | `Neither_minutes_nor_seconds -> (* e.g. "12am" *) pos, 0, false | (`Minutes_and_maybe_seconds | `Minutes_but_not_seconds) as maybe_seconds -> (* e.g. "12:00:00" *) if has_colon string (pos + 2) ~until then ( pos + 3 , read_2_digit_int string ~pos , match maybe_seconds with | `Minutes_and_maybe_seconds -> true | `Minutes_but_not_seconds -> invalid_string string ~reason:"expected end of string after minutes" ) (* e.g. "12:00" *) else if pos + 2 = until then pos + 2, read_2_digit_int string ~pos, false else invalid_string string ~reason:"expected colon or am/pm suffix with optional space after minutes" in let sec, subsec_pos, subsec_len, subsec_nonzero = match expect_seconds with | false -> (* e.g. "12am" or "12:00" *) if pos = until then 0, pos, 0, false else (* This case is actually unreachable, based on the various ways that [expect_seconds] can end up false. *) invalid_string string ~reason:"BUG: did not expect seconds, but found them" | true -> (* e.g. "12:00:00" *) if pos + 2 > until then (* e.g. "12:00:0" *) invalid_string string ~reason:"expected two digits of seconds" else ( let sec = read_2_digit_int string ~pos in let pos = pos + 2 in (* e.g. "12:00:00" *) if pos = until then sec, pos, 0, false (* e.g. "12:00:00.123" *) else if pos < until && char_is_decimal_point string pos then ( sec , pos , until - pos , check_digits_with_underscore_and_return_if_nonzero string (pos + 1) ~until ) else invalid_string string ~reason:"expected decimal point or am/pm suffix after seconds") in let hr = (* NB. We already know [hr] is non-negative, because it's the result of [read_2_digit_int]. *) match am_or_pm with | `hr_AM -> (* e.g. "12:00am" *) if hr < 1 || hr > 12 then invalid_string string ~reason:"hours out of bounds" else if hr = 12 then 0 else hr | `hr_PM -> (* e.g. "12:00pm" *) if hr < 1 || hr > 12 then invalid_string string ~reason:"hours out of bounds" else if hr = 12 then 12 else hr + 12 | `hr_24 -> (match expect_minutes_and_seconds with | `Neither_minutes_nor_seconds -> invalid_string string ~reason:"hours without minutes or AM/PM" | `Minutes_but_not_seconds | `Minutes_and_maybe_seconds -> if hr > 24 then invalid_string string ~reason:"hours out of bounds" else if hr = 24 && (min > 0 || sec > 0 || subsec_nonzero) then invalid_string string ~reason:"time is past 24:00:00" (* e.g. "13:00:00" *) else hr) in let min = if min > 59 then invalid_string string ~reason:"minutes out of bounds" else min in let sec = if sec > 60 then invalid_string string ~reason:"seconds out of bounds" else sec in let subsec_len = if sec = 60 || not subsec_nonzero then 0 else subsec_len in f string ~hr ~min ~sec ~subsec_pos ~subsec_len ;; let parse_iso8601_extended ?pos ?len str ~f = let pos, len = match Ordered_collection_common.get_pos_len () ?pos ?len ~total_length:(String.length str) with | Result.Ok z -> z | Result.Error s -> failwithf "Ofday.of_string_iso8601_extended: %s" (Error.to_string_mach s) () in if len < 2 then failwith "len < 2" else ( let hr = read_2_digit_int str ~pos in if hr > 24 then failwith "hour > 24"; if len = 2 then f str ~hr ~min:0 ~sec:0 ~subsec_pos:(pos + len) ~subsec_len:0 else if len < 5 then failwith "2 < len < 5" else if not (Char.equal str.[pos + 2] ':') then failwith "first colon missing" else ( let min = read_2_digit_int str ~pos:(pos + 3) in if min >= 60 then failwith "minute > 60"; if hr = 24 && min <> 0 then failwith "24 hours and non-zero minute"; if len = 5 then f str ~hr ~min ~sec:0 ~subsec_pos:(pos + len) ~subsec_len:0 else if len < 8 then failwith "5 < len < 8" else if not (Char.equal str.[pos + 5] ':') then failwith "second colon missing" else ( let sec = read_2_digit_int str ~pos:(pos + 6) in (* second can be 60 in the case of a leap second. Unfortunately, what with non-hour-multiple timezone offsets, we can't say anything about what the hour or minute must be in that case *) if sec > 60 then failwithf "invalid second: %i" sec (); if hr = 24 && sec <> 0 then failwith "24 hours and non-zero seconds"; if len = 8 then f str ~hr ~min ~sec ~subsec_pos:(pos + len) ~subsec_len:0 else if len = 9 then failwith "length = 9" else ( match str.[pos + 8] with | '.' | ',' -> let subsec_pos = pos + 8 in let subsec_len = match check_digits_without_underscore_and_return_if_nonzero str (subsec_pos + 1) ~until:(pos + len) with | true when sec = 60 -> 0 | true when hr = 24 -> failwith "24 hours and non-zero subseconds" | _ -> len - 8 in f str ~hr ~min ~sec ~subsec_pos ~subsec_len | _ -> failwith "missing subsecond separator")))) ;; core-0.15.0/core/src/ofday_helpers.mli000066400000000000000000000034641420273305200176000ustar00rootroot00000000000000(** This module is only used in the implementation of ofday.ml, and isn't exposed as a submodule of [Core]. *) open! Import (** Parses a given time-of-day string. If the string is invalid, raises. If the string is valid, calls [f] with the string, the parsed numbers of hours, minutes, and seconds, and the position and length of the substring representing subseconds, which can be parsed with the appropriate precision for a given representation. The substring [String.sub string ~pos:subsec_pos ~len:subsec_len] will be either the empty string (representing zero) or a decimal point ('.') and one or more digits and/or underscores (representing a fractional number of seconds in decimal notation). Illegal hours, minutes, or seconds values are rejected by [parse], as are times with the hour of 24 and non-zero minutes or seconds. The time "24:00:00" itself is accepted. If seconds is 60 (a leap second), the client will be passed [~subsec_len:0] regardless of the subsecond part. *) val parse : string -> f:(string -> hr:int -> min:int -> sec:int -> subsec_pos:int -> subsec_len:int -> 'a) -> 'a (** As [parse], for strings in ISO 8601 extended format. Allows substring parsing via [~pos] and [~len] arguments. *) val parse_iso8601_extended : ?pos:int -> ?len:int -> string -> f:(string -> hr:int -> min:int -> sec:int -> subsec_pos:int -> subsec_len:int -> 'a) -> 'a (** Raises ofday-parsing errors for the given string, annotated with the given reason. Useful inside the [~f] argument to [parse] in order to generate error messages that are consistent with what [parse] raises. *) val invalid_string : string -> reason:string -> _ (** Allowed AM/PM suffixes; useful for testing. *) val am_suffixes : string list Lazy.t val pm_suffixes : string list Lazy.t core-0.15.0/core/src/ofday_intf.ml000066400000000000000000000125611420273305200167230ustar00rootroot00000000000000open! Import open Std_internal module type S = sig (** Time of day. [t] represents a clock-face time of day. Usually this is equivalent to a time-offset from midnight, and each [t] occurs exactly once in each calendar day. However, when daylight saving time begins or ends, some clock face times (and therefore [t]'s) can occur more than once per day or not at all, and e.g. 04:00 can occur three or five hours after midnight, so knowing your current offset from midnight is *not* in general equivalent to knowing the current [t]. (See {!Zone} for tools to help you cope with DST.) There is one nonstandard representable value, [start_of_next_day], which can be thought of as "24:00:00" in 24-hour time. It is essentially "00:00:00" on the next day. By having this value, we allow comparisons against a strict upper bound on [t] values. However, it has some odd properties; for example, [Time.of_date_ofday ~zone date start_of_next_day |> Time.to_date ~zone] yields a different date. Any [ofday] will satisfy [start_of_day <= ofday <= start_of_next_day]. *) type underlying type t = private underlying [@@deriving bin_io, sexp, sexp_grammar, typerep] include Comparable_binable with type t := t include Hashable_binable with type t := t include Pretty_printer.S with type t := t include Robustly_comparable with type t := t include Quickcheck.S_range with type t := t module Span : Span_intf.S (** [of_string] supports and correctly interprets 12h strings with the following suffixes: {v "A", "AM", "A.M.", "A.M" "P", "PM", "P.M.", "P.M" v} as well as the lowercase and space-prefixed versions of these suffixes. [of_string] also fully supports 24h wall-clock times. [to_string] only produces the 24h format. *) include Stringable with type t := t val create : ?hr:int -> ?min:int -> ?sec:int -> ?ms:int -> ?us:int -> ?ns:int -> unit -> t val to_parts : t -> Span.Parts.t (** Smallest valid ofday. *) val start_of_day : t (** Largest representable ofday; see notes above on how [start_of_next_day] behaves differently from other ofday values. *) val start_of_next_day : t (** A time very close to the end of a day. Not necessarily the largest representable value before [start_of_next_day], but as close as possible such that using this ofday with [Time.of_date_ofday] and [Time.to_date] should round-trip to the same date. With floating-point representations of time, this may not be possible for dates extremely far from epoch. The clock-face time represented by [approximate_end_of_day] may vary with different time and ofday representations, depending on their precision. *) val approximate_end_of_day : t (** Note that these names are only really accurate on days without DST transitions. When clocks move forward or back, [of_span_since_start_of_day_exn s] will not necessarily occur [s] after that day's midnight. *) val to_span_since_start_of_day : t -> Span.t val of_span_since_start_of_day_exn : Span.t -> t val of_span_since_start_of_day : Span.t -> t [@@deprecated "[since 2018-04] use [of_span_since_start_of_day_exn] instead"] (** Reports whether a span represents a valid time since the start of the day, i.e. whether [of_span_since_start_of_day_exn span] would succeed. *) val span_since_start_of_day_is_valid : Span.t -> bool (** [of_span_since_start_of_day_unchecked] does not validate that the [Span] represents a valid [Ofday]. Behavior of other [Ofday] accessors is unspecified, but still safe (e.g., won't segfault), if the input does not satisfy [span_since_start_of_day_is_valid]. *) val of_span_since_start_of_day_unchecked : Span.t -> t (** [add t s] shifts the time of day [t] by the span [s]. It returns [None] if the result is not in the same 24-hour day. *) val add : t -> Span.t -> t option val sub : t -> Span.t -> t option (** [next t] return the next [t] (next t > t) or None if [t] = end of day. *) val next : t -> t option (** [prev t] return the previous [t] (prev t < t) or None if [t] = start of day. *) val prev : t -> t option (** [diff t1 t2] returns the difference in time between two ofdays, as if they occurred on the same 24-hour day. *) val diff : t -> t -> Span.t (** Returns the time-span separating the two of-days, ignoring the hour information, and assuming that the of-days represent times that are within a half-hour of each other. This is useful for comparing two ofdays in unknown time-zones. *) val small_diff : t -> t -> Span.t (** Trailing groups of zeroes are trimmed such that the output is printed in terms of the smallest non-zero units among nanoseconds, microseconds, milliseconds, or seconds; or minutes if all of the above are zero. *) val to_string_trimmed : t -> string (** HH:MM:SS, without any subsecond components. Seconds appear even if they are zero. *) val to_sec_string : t -> string (** 24-hour times according to the ISO 8601 standard. This function can raise. *) val of_string_iso8601_extended : ?pos:int -> ?len:int -> string -> t (** with milliseconds *) val to_millisecond_string : t -> string val to_millisec_string : t -> string [@@deprecated "[since 2018-04] use [to_millisecond_string] instead"] end core-0.15.0/core/src/ofday_ns.ml000066400000000000000000000260521420273305200164030ustar00rootroot00000000000000open! Import module Span = Span_ns type underlying = Int63.t type t = Span.t (* since wall-clock midnight *) [@@deriving bin_io, compare, hash, typerep] include (Span : Robustly_comparable.S with type t := t) let to_parts t = Span.to_parts t let start_of_day : t = Span.zero let start_of_next_day : t = Span.day let approximate_end_of_day = Span.( - ) start_of_next_day Span.nanosecond let to_span_since_start_of_day t = t let[@cold] input_out_of_bounds span = raise_s [%message "Time_ns.Ofday.of_span_since_start_of_day_exn: input out of bounds" ~_:(span : Span.t)] ;; let[@inline always] is_invalid span = (* Why we use [Span.( > )] rather than [( >= )] below: We allow to represent the end-of-day sentinel value ([24.000000000h]), which is not itself a valid clock face time. However, since valid clock face times readily round up to it, it's better to allow it to be represented. *) Span.( < ) span start_of_day || Span.( > ) span start_of_next_day ;; let span_since_start_of_day_is_valid span = not (is_invalid span) let of_span_since_start_of_day_unchecked span = span let of_span_since_start_of_day_exn span = if is_invalid span then input_out_of_bounds span else span ;; let of_span_since_start_of_day_opt span = if is_invalid span then None else Some span let add_exn t span = of_span_since_start_of_day_exn (Span.( + ) t span) let sub_exn t span = of_span_since_start_of_day_exn (Span.( - ) t span) let add t span = of_span_since_start_of_day_opt (Span.( + ) t span) let sub t span = of_span_since_start_of_day_opt (Span.( - ) t span) let next t = of_span_since_start_of_day_opt (Span.next t) let prev t = of_span_since_start_of_day_opt (Span.prev t) let diff t u = Span.( - ) t u let create ?hr ?min ?sec ?ms ?us ?ns () = (* Similar to [Time.Ofday.create], if we detect a leap second we strip off all sub-second elements so that HH:MM:60.XXXXXXXXX is all mapped to HH:MM:60. *) let ms, us, ns = match sec with | Some 60 -> Some 0, Some 0, Some 0 | _ -> ms, us, ns in of_span_since_start_of_day_exn (Span.create ?hr ?min ?sec ?ms ?us ?ns ()) ;; module Stable = struct module Option = struct end module Zoned = struct end module V1 = struct include ( Span.Stable.V2 : Comparator.S with type t = t and type comparator_witness = Span.Stable.V2.comparator_witness) type nonrec t = t [@@deriving compare, bin_io] let to_string_with_unit = let ( / ) = Int63.( / ) in let ( mod ) = Int63.rem in let ( ! ) = Int63.of_int in let i = Int63.to_int_exn in fun t ~unit -> if Span.( < ) t start_of_day || Span.( < ) start_of_next_day t then "Incorrect day" else ( let sixty = !60 in let thousand = !1000 in let ns = Span.to_int63_ns t in let us = ns / thousand in let ns = ns mod thousand |> i in let ms = us / thousand in let us = us mod thousand |> i in let s = ms / thousand in let ms = ms mod thousand |> i in let m = s / sixty in let s = s mod sixty |> i in let h = m / sixty |> i in let m = m mod sixty |> i in let unit = match unit with | (`Nanosecond | `Microsecond | `Millisecond | `Second) as unit -> unit | `Minute_or_less -> if ns <> 0 then `Nanosecond else if us <> 0 then `Microsecond else if ms <> 0 then `Millisecond else if s <> 0 then `Second else `Minute in let len = match unit with | `Minute -> 5 | `Second -> 8 | `Millisecond -> 12 | `Microsecond -> 15 | `Nanosecond -> 18 in let str = Bytes.create len in Digit_string_helpers.write_2_digit_int str ~pos:0 h; Bytes.set str 2 ':'; Digit_string_helpers.write_2_digit_int str ~pos:3 m; (match unit with | `Minute -> () | (`Second | `Millisecond | `Microsecond | `Nanosecond) as unit -> Bytes.set str 5 ':'; Digit_string_helpers.write_2_digit_int str ~pos:6 s; (match unit with | `Second -> () | (`Millisecond | `Microsecond | `Nanosecond) as unit -> Bytes.set str 8 '.'; Digit_string_helpers.write_3_digit_int str ~pos:9 ms; (match unit with | `Millisecond -> () | (`Microsecond | `Nanosecond) as unit -> Digit_string_helpers.write_3_digit_int str ~pos:12 us; (match unit with | `Microsecond -> () | `Nanosecond -> Digit_string_helpers.write_3_digit_int str ~pos:15 ns)))); Bytes.unsafe_to_string ~no_mutation_while_string_reachable:str) ;; let parse_nanoseconds string ~pos ~until = let open Int.O in let digits = ref 0 in let num_digits = ref 0 in let pos = ref pos in (* read up to 10 digits; store the first 9, use the 10th to round *) while !pos < until && !num_digits < 10 do let c = string.[!pos] in if Char.is_digit c then ( incr num_digits; if !num_digits < 10 then digits := (!digits * 10) + Char.get_digit_exn c else if Char.get_digit_exn c >= 5 then incr digits else ()); incr pos done; (* if there are missing digits, add zeroes *) if !num_digits < 9 then digits := !digits * Int.pow 10 (9 - !num_digits); !digits ;; let create_from_parsed string ~hr ~min ~sec ~subsec_pos ~subsec_len = let nanoseconds = if Int.equal subsec_len 0 then 0 else parse_nanoseconds string ~pos:(subsec_pos + 1) ~until:(subsec_pos + subsec_len) in Span.of_int63_ns (Int63.of_int nanoseconds) |> Span.( + ) (Span.scale_int Span.second sec) |> Span.( + ) (Span.scale_int Span.minute min) |> Span.( + ) (Span.scale_int Span.hour hr) |> of_span_since_start_of_day_exn ;; let of_string string = Ofday_helpers.parse string ~f:create_from_parsed let t_of_sexp sexp : t = match sexp with | Sexp.List _ -> of_sexp_error "expected an atom" sexp | Sexp.Atom s -> (try of_string s with | exn -> of_sexp_error_exn exn sexp) ;; let t_sexp_grammar = String.t_sexp_grammar let to_string (t : t) = to_string_with_unit t ~unit:`Nanosecond let sexp_of_t (t : t) = Sexp.Atom (to_string t) let to_int63 t = Span_ns.Stable.V2.to_int63 t let of_int63_exn t = of_span_since_start_of_day_exn (Span_ns.Stable.V2.of_int63_exn t) end end include ( Stable.V1 : Comparator.S with type t := t and type comparator_witness = Stable.V1.comparator_witness) include Identifiable.Make_using_comparator (struct type t = Stable.V1.t [@@deriving bin_io, compare, sexp] include ( Stable.V1 : Comparator.S with type t := t and type comparator_witness = Stable.V1.comparator_witness) include (Stable.V1 : Stringable.S with type t := t) let module_name = "Core.Time_ns.Ofday" let hash = Span.hash let hash_fold_t = Span.hash_fold_t end) let t_sexp_grammar = Sexplib.Sexp_grammar.coerce Stable.V1.t_sexp_grammar let to_microsecond_string t = Stable.V1.to_string_with_unit t ~unit:`Microsecond let to_millisecond_string t = Stable.V1.to_string_with_unit t ~unit:`Millisecond let to_sec_string t = Stable.V1.to_string_with_unit t ~unit:`Second let to_string_trimmed t = Stable.V1.to_string_with_unit t ~unit:`Minute_or_less let of_string_iso8601_extended ?pos ?len str = try Ofday_helpers.parse_iso8601_extended ?pos ?len str ~f:Stable.V1.create_from_parsed with | exn -> raise_s [%message "Time_ns.Ofday.of_string_iso8601_extended: cannot parse string" ~_:(String.subo str ?pos ?len : string) ~_:(exn : exn)] ;; let every = let rec every_valid_ofday_span span ~start ~stop ~acc = (* Assumes [span], [start], and [stop] are valid ofdays. Assumes [start < stop]. Assumes [span > 0]. *) let acc = start :: acc in let start = Span.( + ) start span in if Span.( > ) start stop (* cannot overflow *) then List.rev acc else every_valid_ofday_span span ~start ~stop ~acc in (* internal [every] named to show up in stack traces *) let every span ~start ~stop = if Span.( > ) start stop then Or_error.error_s [%message "[Time_ns.Ofday.every] called with [start] > [stop]" (start : t) (stop : t)] else if Span.( <= ) span Span.zero then Or_error.error_s [%message "[Time_ns.Ofday.every] called with negative span" ~_:(span : Span.t)] else if is_invalid span then Ok [ start ] else Ok (every_valid_ofday_span span ~start ~stop ~acc:[]) in every ;; let small_diff = let hour = Span.to_int63_ns Span.hour in fun ofday1 ofday2 -> let open Int63.O in let ofday1 = Span.to_int63_ns (to_span_since_start_of_day ofday1) in let ofday2 = Span.to_int63_ns (to_span_since_start_of_day ofday2) in let diff = ofday1 - ofday2 in (* d1 is in (-hour; hour) *) let d1 = Int63.rem diff hour in (* d2 is in (0;hour) *) let d2 = Int63.rem (d1 + hour) hour in let d = if d2 > hour / Int63.of_int 2 then d2 - hour else d2 in Span.of_int63_ns d ;; let%expect_test "small_diff" = let test x y = let diff = small_diff x y in printf !"small_diff %s %s = %s\n" (to_string x) (to_string y) (Span.to_string diff) in let examples = List.map ~f:(fun (x, y) -> of_string x, of_string y) [ "12:00", "12:05"; "12:58", "13:02"; "00:52", "23:19"; "00:00", "24:00" ] in List.iter examples ~f:(fun (x, y) -> test x y; test y x); [%expect {| small_diff 12:00:00.000000000 12:05:00.000000000 = -5m small_diff 12:05:00.000000000 12:00:00.000000000 = 5m small_diff 12:58:00.000000000 13:02:00.000000000 = -4m small_diff 13:02:00.000000000 12:58:00.000000000 = 4m small_diff 00:52:00.000000000 23:19:00.000000000 = -27m small_diff 23:19:00.000000000 00:52:00.000000000 = 27m small_diff 00:00:00.000000000 24:00:00.000000000 = 0s small_diff 24:00:00.000000000 00:00:00.000000000 = 0s |}] ;; let gen_incl = Span.gen_incl let gen_uniform_incl = Span.gen_uniform_incl let quickcheck_generator = gen_incl start_of_day start_of_next_day let quickcheck_observer = Span.quickcheck_observer let quickcheck_shrinker = Quickcheck.Shrinker.empty () include (Span : Comparisons.S with type t := t) (* deprecated bindings *) let of_span_since_start_of_day = of_span_since_start_of_day_exn let to_millisec_string = to_millisecond_string let arg_type = `Use_Time_ns_unix let now = `Use_Time_ns_unix let of_ofday_float_round_nearest = `Use_Time_ns_unix let of_ofday_float_round_nearest_microsecond = `Use_Time_ns_unix let to_ofday_float_round_nearest = `Use_Time_ns_unix let to_ofday_float_round_nearest_microsecond = `Use_Time_ns_unix module Option = struct end module Zoned = struct end core-0.15.0/core/src/ofday_ns.mli000066400000000000000000000005751420273305200165560ustar00rootroot00000000000000open! Import open Std_internal include Time_ns_intf.Ofday with module Span := Span_ns module Stable : sig module V1 : Stable_int63able with type t = t and type comparator_witness = comparator_witness module Option : sig end [@@deprecated "[since 2021-02] Use [Time_ns_unix.Stable]"] module Zoned : sig end [@@deprecated "[since 2021-02] Use [Time_ns_unix.Stable]"] end core-0.15.0/core/src/only_in_test.ml000066400000000000000000000000631420273305200173010ustar00rootroot00000000000000open! Import include Lazy let of_thunk = from_fun core-0.15.0/core/src/only_in_test.mli000066400000000000000000000025101420273305200174510ustar00rootroot00000000000000(** This module can be used to safely expose functions and values in signatures that should only be used in unit tests. Under the hood, ['a t = 'a Lazy.t] and the only thing that ever forces them is the [force] function below which should only be called in unit tests. For example, suppose in some module, [type t] is actually an [int]. You want to keep the type definition opaque, but use the underlying representation in unit tests. You could write in the ml: {[ let test_to_int t = Only_in_test.return t let test_of_int n = Only_in_test.return n]} You would then expose in the mli: {[ type t val test_to_int : t -> int Only_in_test.t val test_of_int : int -> t Only_in_test.t]} Finally, if you have specific values that you might want to use in unit tests, but that have top-level side-effects or take too long to compute, you can delay the side-effects or computation until the unit tests are run by writing, e.g.: [let (test_special_value : t Only_in_test.t) = Only_in_test.of_thunk (fun () -> factorial 100)] instead of [let (test_special_value : t Only_in_test.t) = Only_in_test.return (factorial 100)] *) open! Import type 'a t include Monad.S with type 'a t := 'a t val of_thunk : (unit -> 'a) -> 'a t val force : 'a t -> 'a core-0.15.0/core/src/option.ml000066400000000000000000000031311420273305200161020ustar00rootroot00000000000000open! Import include Base.Option type 'a t = 'a option [@@deriving bin_io, typerep] include Comparator.Derived (struct type nonrec 'a t = 'a t [@@deriving sexp_of, compare] end) let validate ~none ~some t = let module V = Validate in match t with | None -> V.name "none" (V.protect none ()) | Some x -> V.name "some" (V.protect some x) ;; let quickcheck_generator = Base_quickcheck.Generator.option let quickcheck_observer = Base_quickcheck.Observer.option let quickcheck_shrinker = Base_quickcheck.Shrinker.option module Stable = struct module V1 = struct type nonrec 'a t = 'a t [@@deriving bin_io, compare, equal, sexp] end end module Optional_syntax = struct module Optional_syntax = struct let is_none = is_none (* [unsafe_value] is only safe to call when [is_none] returns [false]. To avoid repeating the [is_none] check, we declare [Unchecked_some]. [Unchecked_some x] has the same representation as [Some x], but the type has no [None] clause. We make sure all this works with tests of [unsafe_value] in test_option.ml. We tried using [Obj.field] instead. It generates much worse native code due to float array representations. *) module Unchecked_some = struct (* Warning 37 tells us [Unchecked_some] is never used as a constructor. This is intentional, so we disable the warning. *) type 'a t = Unchecked_some of 'a [@@ocaml.boxed] [@@ocaml.warning "-37"] end let unsafe_value (type a) (t : a t) : a = let (Unchecked_some value) = (Obj.magic t : a Unchecked_some.t) in value ;; end end core-0.15.0/core/src/option.mli000066400000000000000000000022351420273305200162570ustar00rootroot00000000000000(** This module extends {{!Base.Option}[Base.Option]} with bin_io, quickcheck, and support for ppx_optional. *) type 'a t = 'a Base.Option.t [@@deriving bin_io, typerep] (** @inline *) include module type of struct include Base.Option end with type 'a t := 'a option include Comparator.Derived with type 'a t := 'a t include Quickcheckable.S1 with type 'a t := 'a t val validate : none:unit Validate.check -> some:'a Validate.check -> 'a t Validate.check module Stable : sig module V1 : sig type nonrec 'a t = 'a t [@@deriving bin_io, compare, equal, sexp] end end (** You might think that it's pointless to have [Optional_syntax] on options because OCaml already has nice syntax for matching on options. The reason to have this here is that you might have, for example, a tuple of an option and some other type that supports [Optional_syntax]. Since [Optional_syntax] can only be opted into at the granularity of the whole match expression, we need this [Optional_syntax] support for options in order to use it for the other half of the tuple. *) module Optional_syntax : Optional_syntax.S1 with type 'a t := 'a t and type 'a value := 'a core-0.15.0/core/src/option_array.ml000066400000000000000000000004531420273305200173040ustar00rootroot00000000000000open! Import include Base.Option_array include Binable.Of_binable1_without_uuid [@alert "-legacy"] (struct type 'a t = 'a option array [@@deriving sexp, bin_io] end) (struct type nonrec 'a t = 'a t let to_binable = to_array let of_binable = of_array end) core-0.15.0/core/src/option_array.mli000066400000000000000000000003701420273305200174530ustar00rootroot00000000000000(** This module extends {{!Base.Option_array}[Base.Option_array]} with bin_io. *) open! Import type 'a t = 'a Base.Option_array.t [@@deriving bin_io, sexp] include module type of struct include Base.Option_array end with type 'a t := 'a t core-0.15.0/core/src/optional_syntax.ml000066400000000000000000000000721420273305200200260ustar00rootroot00000000000000open! Import include Optional_syntax_intf (** @inline *) core-0.15.0/core/src/optional_syntax.mli000066400000000000000000000002251420273305200201770ustar00rootroot00000000000000(** Interfaces for use with the [match%optional] syntax, provided by [ppx_optional]. *) include Optional_syntax_intf.Optional_syntax (** @inline *) core-0.15.0/core/src/optional_syntax_intf.ml000066400000000000000000000045241420273305200210540ustar00rootroot00000000000000open! Import module type S = sig type t type value module Optional_syntax : sig val is_none : t -> bool val unsafe_value : t -> value end end module type S1 = sig type 'a t type 'a value module Optional_syntax : sig val is_none : _ t -> bool val unsafe_value : 'a t -> 'a value end end module type S2 = sig type ('a, 'b) t type ('a, 'b) value module Optional_syntax : sig val is_none : _ t -> bool val unsafe_value : ('a, 'b) t -> ('a, 'b) value end end module type Optional_syntax = sig (** Idiomatic usage is to have a module [M] like: {[ module M : sig type t module Optional_syntax : Optional_syntax.S with type t := t with type value := ... end = struct ... module Optional_syntax = struct module Optional_syntax = struct let is_none = is_none let unsafe_value = unsafe_value end end end ]} Then, uses look like: {[ match%optional.M m with | None -> ? | Some v -> ? ]} [match%optional] then expands to references to [M.Optional_syntax]'s [is_none] and [unsafe_value] functions. The reason for the double [module Optional_syntax] is historical. The idiom used to use [open M.Optional_syntax], and we wanted that to bring into scope as little as possible, so we made it put in scope only [module Optional_syntax]. [unsafe_value] does not have to be memory-safe if not guarded by [is_none]. Implementations of [is_none] and [unsafe_value] must not have any side effects. More precisely, if you mutate any value currently being match'ed on (not necessarily your own argument) you risk a segfault as well. This is because [match%optional] does not make any guarantee about [is_none] call being immediately followed by the corresponding [unsafe_value] call. In fact it makes several [is_none] calls followed by several [unsafe_value] calls, so in the presence of side-effects by the time it makes an [unsafe_value] call the result of the corresponding [is_none] can go stale. For more details on the syntax extension, see [ppx/ppx_optional/README.md]. *) module type S = S module type S1 = S1 module type S2 = S2 end core-0.15.0/core/src/or_error.ml000066400000000000000000000022001420273305200164170ustar00rootroot00000000000000open! Import include Base.Or_error type 'a t = ('a, Error.t) Result.t [@@deriving bin_io] module Expect_test_config_with_unit_expect = struct module IO_run = Base.Or_error module IO_flush = struct include Expect_test_config.IO_flush let to_run t = Base.Or_error.return t end let run f = ok_exn (f ()) let sanitize s = s let flushed () = true let upon_unreleasable_issue = Expect_test_config.upon_unreleasable_issue end module Expect_test_config = struct module IO = Base.Or_error module IO_run = IO module IO_flush = struct include IO let to_run t = t end let run f = ok_exn (f ()) let flushed () = true let upon_unreleasable_issue = Expect_test_config.upon_unreleasable_issue let sanitize s = s end module Stable = struct module V1 = struct type 'a t = ('a, Error.Stable.V1.t) Result.Stable.V1.t [@@deriving bin_io, compare, sexp] let map x ~f = Result.Stable.V1.map x ~f1:f ~f2:Fn.id end module V2 = struct type 'a t = ('a, Error.Stable.V2.t) Result.Stable.V1.t [@@deriving bin_io, compare, sexp] let map x ~f = Result.Stable.V1.map x ~f1:f ~f2:Fn.id end end core-0.15.0/core/src/or_error.mli000066400000000000000000000013571420273305200166040ustar00rootroot00000000000000(** This module extends {{!Base.Or_error}[Base.Or_error]} with bin_io. *) open! Import type 'a t = ('a, Error.t) Result.t [@@deriving bin_io] (** @inline *) include module type of struct include Base.Or_error end with type 'a t := 'a t module Expect_test_config : Expect_test_config_types.S with type 'a IO_flush.t = 'a t with type 'a IO_run.t = 'a t module Expect_test_config_with_unit_expect : Expect_test_config_types.S with type 'a IO_flush.t = 'a with type 'a IO_run.t = 'a t module Stable : sig (** [Or_error.t] is wire compatible with [V2.t], but not [V1.t], like [Info.Stable] and [Error.Stable]. *) module V1 : Stable_module_types.S1 with type 'a t = 'a t module V2 : Stable_module_types.S1 with type 'a t = 'a t end core-0.15.0/core/src/ordered_collection_common.ml000066400000000000000000000005151420273305200220040ustar00rootroot00000000000000include Base.Ordered_collection_common let normalize ~length_fun t i = if i < 0 then i + length_fun t else i let slice ~length_fun ~sub_fun t start stop = let stop = if stop = 0 then length_fun t else stop in let pos = normalize ~length_fun t start in let len = normalize ~length_fun t stop - pos in sub_fun t ~pos ~len ;; core-0.15.0/core/src/ordered_collection_common.mli000066400000000000000000000005401420273305200221530ustar00rootroot00000000000000(** This module extends {{!Base.Ordered_collection_common}[Base.Ordered_collection_common]}. *) include module type of struct include Base.Ordered_collection_common end val normalize : length_fun:('a -> int) -> 'a -> int -> int val slice : length_fun:('a -> int) -> sub_fun:('a -> pos:int -> len:int -> 'a) -> 'a -> int -> int -> 'a core-0.15.0/core/src/ordering.ml000066400000000000000000000003351420273305200164060ustar00rootroot00000000000000open! Import type t = Base.Ordering.t = | Less | Equal | Greater [@@deriving bin_io, compare, hash, sexp] module type Base_mask = module type of Base.Ordering with type t := t include (Base.Ordering : Base_mask) core-0.15.0/core/src/ordering.mli000066400000000000000000000005201420273305200165530ustar00rootroot00000000000000(** Extends {{!Base.Ordering}[Base.Ordering]}, intended to make code that matches on the result of a comparison more concise and easier to read. *) open! Import type t = Base.Ordering.t = | Less | Equal | Greater [@@deriving bin_io, compare, hash, sexp] include module type of Base.Ordering with type t := t (** @inline *) core-0.15.0/core/src/percent.ml000066400000000000000000000160101420273305200162320ustar00rootroot00000000000000open! Import open Std_internal module Stable = struct module V1 = struct type t = (float[@quickcheck.generator Float.gen_finite]) [@@deriving compare, hash, quickcheck, typerep] let of_mult f = f let to_mult t = t let of_percentage f = f /. 100. let to_percentage t = t *. 100. let of_bp f = f /. 10_000. let to_bp t = t *. 10_000. let of_bp_int i = of_bp (Float.of_int i) let to_bp_int t = Float.to_int (to_bp t) let round_significant p ~significant_digits = Float.round_significant p ~significant_digits ;; let round_decimal_mult p ~decimal_digits = Float.round_decimal p ~decimal_digits let round_decimal_percentage p ~decimal_digits = Float.round_decimal (p *. 100.) ~decimal_digits /. 100. ;; let round_decimal_bp p ~decimal_digits = Float.round_decimal (p *. 10000.) ~decimal_digits /. 10000. ;; module Format = struct type t = | Exponent of int | Exponent_E of int | Decimal of int | Ocaml | Compact of int | Compact_E of int | Hex of int | Hex_E of int [@@deriving sexp_of] let exponent ~precision = Exponent precision let exponent_E ~precision = Exponent_E precision let decimal ~precision = Decimal precision let ocaml = Ocaml let compact ~precision = Compact precision let compact_E ~precision = Compact_E precision let hex ~precision = Hex precision let hex_E ~precision = Hex_E precision let format_float t = match t with | Exponent precision -> sprintf "%.*e" precision | Exponent_E precision -> sprintf "%.*E" precision | Decimal precision -> sprintf "%.*f" precision | Ocaml -> sprintf "%F" | Compact precision -> sprintf "%.*g" precision | Compact_E precision -> sprintf "%.*G" precision | Hex precision -> sprintf "%.*h" precision | Hex_E precision -> sprintf "%.*H" precision ;; end let format x format = let x_abs = Float.abs x in let string float = Format.format_float format float in if Float.( = ) x_abs 0. then "0x" else if Float.( >= ) x_abs 1. then string (x *. 1.) ^ "x" else if Float.( >= ) x_abs 0.01 then string (x *. 100.) ^ "%" else string (x *. 10_000.) ^ "bp" ;; module Stringable = struct type t = float (* WARNING - PLEASE READ BEFORE EDITING THESE FUNCTIONS: The string converters in Stable.V1 should never change. If you are changing the semantics of anything that affects the sexp or bin-io representation of values of this type (this includes to_string and of_string) make a Stable.V2 and make your changes there. Thanks! *) let to_string x = let x_abs = Float.abs x in let string float = sprintf "%.6G" float in if Float.( = ) x_abs 0. then "0x" else if Float.( >= ) x_abs 1. then string (x *. 1.) ^ "x" else if Float.( >= ) x_abs 0.01 then string (x *. 100.) ^ "%" else string (x *. 10_000.) ^ "bp" ;; let really_of_string str float_of_string = match String.chop_suffix str ~suffix:"x" with | Some str -> float_of_string str | None -> (match String.chop_suffix str ~suffix:"%" with | Some str -> float_of_string str *. 0.01 | None -> (match String.chop_suffix str ~suffix:"bp" with | Some str -> of_bp (float_of_string str) | None -> failwithf "Percent.of_string: must end in x, %%, or bp: %s" str ())) ;; let of_string str = let float str = Float_with_finite_only_serialization.t_of_sexp (Sexp.Atom str) in really_of_string str float ;; let of_string_allow_nan_and_inf str = really_of_string str Float.of_string end include ( Stringable : sig type t val of_string : string -> t val to_string : t -> string end with type t := t) let t_sexp_grammar = Sexplib.Sexp_grammar.coerce String.t_sexp_grammar include (Sexpable.Stable.Of_stringable.V1 (Stringable) : Sexpable.S with type t := t) include (Float : Binable with type t := t) include Comparable.Make_binable (struct type nonrec t = t [@@deriving compare, sexp_of, bin_io] (* Previous versions rendered comparable-based containers using float serialization rather than percent serialization, so when reading comparable-based containers in we accept either serialization. *) let t_of_sexp sexp = match Float.t_of_sexp sexp with | float -> float | exception _ -> t_of_sexp sexp ;; end) end module Option = struct module V1 = struct type t = V1.t [@@deriving bin_io, compare, hash, typerep] let none = Float.nan let is_none t = Float.is_nan t let is_some t = not (is_none t) let some_is_representable = is_some let some = Fn.id let unchecked_value = Fn.id let to_option t = if is_some t then Some (unchecked_value t) else None let apply_with_none_as_nan = ( *. ) let of_mult_with_nan_as_none = Fn.id let to_mult_with_none_as_nan = Fn.id let of_option opt = match opt with | None -> none | Some v -> some v ;; let value_exn t = if is_some t then unchecked_value t else raise_s [%message [%here] "Percent.Option.value_exn none"] ;; let value t ~default = if is_some t then unchecked_value t else default let sexp_of_t t = to_option t |> Option.sexp_of_t V1.sexp_of_t let t_of_sexp sexp = (Option.t_of_sexp V1.t_of_sexp) sexp |> of_option let t_sexp_grammar = Sexplib.Sexp_grammar.coerce [%sexp_grammar: V1.t Option.t] end end end include Stable.V1 module Option = struct module Stable = Stable.Option include Stable.V1 module Optional_syntax = struct module Optional_syntax = struct let is_none = is_none let unsafe_value = unchecked_value end end end let is_zero t = t = 0. let apply t f = t *. f let scale t f = t *. f include ( struct include Float let ( // ) x y = of_mult x /. of_mult y end : sig val zero : t val ( * ) : t -> t -> t val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( / ) : t -> t -> t val ( // ) : t -> t -> float val abs : t -> t val neg : t -> t val is_nan : t -> bool val is_inf : t -> bool val sign_exn : t -> Sign.t include Robustly_comparable with type t := t end) include Comparable.With_zero (struct include Stable.V1 let zero = zero end) let validate = Float.validate_ordinary let of_string_allow_nan_and_inf s = Stringable.of_string_allow_nan_and_inf s let t_of_sexp_allow_nan_and_inf sexp = of_string_allow_nan_and_inf (Sexp.to_string sexp) module Always_percentage = struct type nonrec t = t let format x format = Format.format_float format (x *. 100.) ^ "%" let to_string x = sprintf "%.6G%%" (x * 100.) let sexp_of_t t = Sexp.Atom (to_string t) end core-0.15.0/core/src/percent.mli000066400000000000000000000130101420273305200164000ustar00rootroot00000000000000(** A scale factor, not bounded between 0% and 100%, represented as a float. *) open! Import open Std_internal (** Exposing that this is a float allows for more optimization. E.g. compiler can optimize some local refs and not box them. *) type t = private float [@@deriving hash, typerep] (** [of_string] and [t_of_sexp] disallow [nan], [inf], etc. *) include Stringable with type t := t (** Sexps are of the form 5bp or 0.05% or 0.0005x. Warning: [equal (t) (t_of_sexp (sexp_of_t t))] is not guaranteed. Multiple serialization round-trips may cause multiple small drifts. *) include Sexpable with type t := t include Binable with type t := t include Comparable_binable with type t := t include Comparable.With_zero with type t := t include Robustly_comparable.S with type t := t include Quickcheckable.S with type t := t (** The value [nan] cannot be represented as an [Option.t] *) module Option : sig type value := t type t = private float [@@deriving sexp_grammar] include Immediate_option.S_without_immediate with type value := value and type t := t (** [apply_with_none_as_nan (some x) y = apply x y], and [apply_with_none_as_nan none y = apply (of_mult Float.nan) y] *) val apply_with_none_as_nan : t -> float -> float (** [of_mult_with_nan_as_none Float.nan = none], and [of_mult_with_nan_as_none x = some (of_mult x)] otherwise *) val of_mult_with_nan_as_none : float -> t (** [to_mult_with_none_as_nan none = Float.nan], and [to_mult_with_none_as_nan (some x) = to_mult x] *) val to_mult_with_none_as_nan : t -> float end val ( * ) : t -> t -> t val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( / ) : t -> t -> t val ( // ) : t -> t -> float val zero : t val neg : t -> t val abs : t -> t val is_zero : t -> bool val is_nan : t -> bool val is_inf : t -> bool (** [apply t x] multiplies the percent [t] by [x], returning a float. *) val apply : t -> float -> float (** [scale t x] scales the percent [t] by [x], returning a new [t]. *) val scale : t -> float -> t (** [of_mult 5.] is 5x = 500% = 50_000bp *) val of_mult : float -> t val to_mult : t -> float (** [of_percentage 5.] is 5% = 0.05x = 500bp *) val of_percentage : float -> t val to_percentage : t -> float (** [of_bp 5.] is 5bp = 0.05% = 0.0005x *) val of_bp : float -> t val to_bp : t -> float val of_bp_int : int -> t (** rounds down *) val to_bp_int : t -> int (** 0.0123456% ~significant_digits:4 is 1.235bp *) val round_significant : t -> significant_digits:int -> t (** 0.0123456% ~decimal_digits:4 is 0.0001 = 1bp *) val round_decimal_mult : t -> decimal_digits:int -> t (** 0.0123456% ~decimal_digits:4 is 0.0123% = 1.23bp *) val round_decimal_percentage : t -> decimal_digits:int -> t (** 0.0123456% ~decimal_digits:4 is 1.2346bp *) val round_decimal_bp : t -> decimal_digits:int -> t val t_of_sexp_allow_nan_and_inf : Sexp.t -> t val of_string_allow_nan_and_inf : string -> t (** A [Format.t] tells [Percent.format] how to render a floating-point value as a string, like a [printf] conversion specification. For example: {[ format (Format.exponent ~precision) = sprintf "%.e" precision ]} The [_E] naming suffix in [Format] values is mnenomic of a capital [E] (rather than [e]) being used in floating-point exponent notation. Here is the documentation of the floating-point conversion specifications from the OCaml manual: - 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). - h or H: convert a floating-point argument to hexadecimal notation, in the style 0xh.hhhh e+-dd (hexadecimal mantissa, exponent in decimal and denotes a power of 2). *) module Format : sig type t [@@deriving sexp_of] (** [sprintf "%.*e" precision] *) val exponent : precision:int -> t (** [sprintf "%.*E" precision] *) val exponent_E : precision:int -> t (** [sprintf "%.*f" precision] *) val decimal : precision:int -> t (** [sprintf "%F"] *) val ocaml : t (** [sprintf "%.*g" precision] *) val compact : precision:int -> t (** [sprintf "%.*G" precision] *) val compact_E : precision:int -> t (** [sprintf "%.*h" precision] *) val hex : precision:int -> t (** [sprintf "%.*H" precision] *) val hex_E : precision:int -> t end val format : t -> Format.t -> string val validate : t -> Validate.t (*_ Caution: If we remove this sig item, [sign] will still be present from [Comparable.With_zero]. *) val sign : t -> Sign.t [@@deprecated "[since 2016-01] Replace [sign] with [sign_exn]"] (** The sign of a [Percent.t]. Both [-0.] and [0.] map to [Zero]. Raises on nan. All other values map to [Neg] or [Pos]. *) val sign_exn : t -> Sign.t module Stable : sig module V1 : sig type nonrec t = t [@@deriving sexp, bin_io, compare, hash, equal, typerep] end module Option : sig module V1 : sig type t = Option.t [@@deriving bin_io, compare, hash, sexp] end end end (** Does not format small values as "3bp" or large ones as "2x"; always uses percentages ("0.0003%" or "200%"). The standard [of_sexp] can read these just fine. *) module Always_percentage : sig type nonrec t = t [@@deriving sexp_of] val to_string : t -> string val format : t -> Format.t -> string end core-0.15.0/core/src/perms.ml000066400000000000000000000101541420273305200157230ustar00rootroot00000000000000open! Import module Binable = Binable0 (* All the types as exposed in the mli are defined in this [Types] module. The rest of this file is simply overriding all the bin_io, compare, and sexp functions to raise exceptions. *) module Types = struct module Nobody = struct type t [@@deriving bin_io, compare, hash, sexp] let name = "Nobody" end module Me = struct type t [@@deriving bin_io, compare, hash, sexp] let name = "Me" end module Read = struct type t = [ `Read ] [@@deriving bin_io, compare, hash, sexp] let name = "Read" end module Write = struct type t = [ `Who_can_write of Me.t ] [@@deriving bin_io, compare, hash, sexp] let name = "Write" end module Immutable = struct type t = [ Read.t | `Who_can_write of Nobody.t ] [@@deriving bin_io, compare, hash, sexp] let name = "Immutable" end module Read_write = struct type t = [ Read.t | Write.t ] [@@deriving bin_io, compare, hash, sexp] let name = "Read_write" end module Upper_bound = struct type 'a t = [ Read.t | `Who_can_write of 'a ] [@@deriving bin_io, compare, hash, sexp] let name = "Upper_bound" end end let failwithf = Printf.failwithf (* This is an explicit module type instead of just given inline as the return signature of [Only_used_as_phantom_type1] to avoid an unused value warning with bin_io values. *) module type Sexpable_binable_comparable = sig type 'a t = 'a [@@deriving bin_io, compare, hash, sexp, sexp_grammar] end (* Override all bin_io, sexp, compare functions to raise exceptions *) module Only_used_as_phantom_type1 (Name : sig val name : string end) : Sexpable_binable_comparable = struct type 'a t = 'a let sexp_of_t _ _ = failwithf "Unexpectedly called [%s.sexp_of_t]" Name.name () let t_of_sexp _ _ = failwithf "Unexpectedly called [%s.t_of_sexp]" Name.name () let compare _ _ _ = failwithf "Unexpectedly called [%s.compare]" Name.name () let hash_fold_t _ _ _ = failwithf "Unexpectedly called [%s.hash_fold_t]" Name.name () let t_sexp_grammar _ = Sexplib.Sexp_grammar.coerce Base.Nothing.t_sexp_grammar include Binable.Of_binable1_without_uuid [@alert "-legacy"] (struct type 'a t = 'a [@@deriving bin_io] end) (struct type nonrec 'a t = 'a t let to_binable _ = failwithf "Unexpectedly used %s bin_io serialization" Name.name () ;; let of_binable _ = failwithf "Unexpectedly used %s bin_io deserialization" Name.name () ;; end) end module Only_used_as_phantom_type0 (T : sig type t [@@deriving bin_io, compare, hash, sexp] val name : string end) : sig type t = T.t [@@deriving bin_io, compare, hash, sexp_poly] end = struct module M = Only_used_as_phantom_type1 (T) type t = T.t M.t [@@deriving bin_io, compare, hash, sexp] let __t_of_sexp__ = t_of_sexp end module Stable = struct module V1 = struct module Nobody = Only_used_as_phantom_type0 (Types.Nobody) module Me = Only_used_as_phantom_type0 (Types.Me) module Read = Only_used_as_phantom_type0 (Types.Read) module Write = Only_used_as_phantom_type0 (Types.Write) module Read_write = Only_used_as_phantom_type0 (Types.Read_write) module Immutable = Only_used_as_phantom_type0 (Types.Immutable) type nobody = Nobody.t [@@deriving bin_io, compare, hash, sexp] type me = Me.t [@@deriving bin_io, compare, hash, sexp] module Upper_bound = struct module M = Only_used_as_phantom_type1 (Types.Upper_bound) type 'a t = 'a Types.Upper_bound.t M.t [@@deriving bin_io, compare, hash, sexp] let __t_of_sexp__ = t_of_sexp end end module Export = struct type read = V1.Read.t [@@deriving bin_io, compare, hash, sexp] type write = V1.Write.t [@@deriving compare, hash, sexp] type immutable = V1.Immutable.t [@@deriving bin_io, compare, hash, sexp] type read_write = V1.Read_write.t [@@deriving bin_io, compare, hash, sexp] type 'a perms = 'a V1.Upper_bound.t [@@deriving bin_io, compare, hash, sexp] end end include Stable.V1 module Export = Stable.Export core-0.15.0/core/src/perms.mli000066400000000000000000000141611420273305200160760ustar00rootroot00000000000000(** These types are intended to be used as phantom types encoding the permissions on a given type. {2 Basic Usage} Here's a hypothetical interface to an on-off switch which uses them: {[ open Perms.Export module Switch : sig type -'permissions t val create : unit -> [< _ perms] t val read : [> read] t -> [`On | `Off] val write : [> write] t -> [`On | `Off] -> unit end ]} Note that the permissions parameter must be contravariant -- you are allowed to forget that you have any particular permissions, but not give yourself new permissions. You can now create different "views" of a switch. For example, in: {[ let read_write_s1 : read_write Switch.t = Switch.create () let read_only_s1 = (read_write_s1 :> read t) ]} [read_write_s1] and [read_only_s1] are physically equal, but calling [Switch.write read_only_s1] is a type error, while [Switch.write read_write_s1] is allowed. Also note that this is a type error: {[ let s1 = Switch.create () let read_write_s1 = (s1 :> read_write t) let immutable_s1 = (s1 :> immutable t) ]} which is good, since it would be incorrect if it were allowed. This is enforced by: 1. Having the permissions parameter be contravariant and the only way to create a [t] be a function call. This causes the compiler to require that created [t]s have a concrete type (due to the value restriction). 2. Ensuring that there is no type that has both [read_write] and [immutable] as subtypes. This is why the variants are [`Who_can_write of Me.t] and [`Who_can_write of Nobody.t] rather than [`I_can_write] and [`Nobody_can_write]. Note that, as a consequence of 1, exposing a global switch as in: {[ module Switch : sig ... val global : [< _ perms] t end ]} would be a mistake, since one library could annotate [Switch.global] as an [immutable Switch.t], while another library writes to it. {2 More Usage Patterns} The standard usage pattern is as above: {ul {- The permissions type parameter is contravariant with no constraints.} {- The result of creation functions is a [t] with [[< _ perms]] permissions.} {- Functions which take a [t] and access it in some way represent that access in the type. } } The reason for having creation functions return a [t] with [[< _ perms]] permissions is to help give early warning if you create a [t] with a nonsensical permission type that you wouldn't be able to use with the other functions in the module. Ideally, this would be done with a constraint on the type in a usage pattern like this: {ul {- The permissions type parameter is contravariant with constraint [[< _ perms]].} {- The result of creation functions is a [t] with no constraint on the permissions.} {- Functions which take a [t] and access it in some way represent that access in the type. } } Unfortunately, that doesn't work for us due to some quirks in the way constraints of this form are handled: In particular, they don't work well with [[@@deriving sexp]] and they don't work well with included signatures. But you could try this usage pattern if you don't do either of those things. For some types you may expect to always have read permissions, and it may therefore by annoying to keep rewriting [[> read]]. In that case you may want to try this usage pattern: {ul {- The permissions type parameter is contravariant with constraint [[> read]].} {- The result of creation functions is a [t] with [[< _ perms]] permissions.} {- Functions which take a [t] and access it in some way represent that access in the type, except that you don't have to specify read permissions. } } However, the standard usage pattern is again preferred to this one: [constraint] has lots of sharp edges, and putting [[> read]] instead of [_] in the types provides explicitness. *) open! Import (** Every type in this module besides the following two represent permission sets; these two represent who is allowed to write in the [Write.t] and [Immutable.t] types. *) type nobody [@@deriving bin_io, compare, hash, sexp] type me [@@deriving bin_io, compare, hash, sexp] module Read : sig type t = [ `Read ] [@@deriving bin_io, compare, hash, sexp] end module Write : sig type t = [ `Who_can_write of me ] [@@deriving bin_io, compare, hash, sexp] end module Immutable : sig type t = [ Read.t | `Who_can_write of nobody ] [@@deriving bin_io, compare, hash, sexp] end module Read_write : sig type t = [ Read.t | Write.t ] [@@deriving bin_io, compare, hash, sexp] end module Upper_bound : sig type 'a t = [ Read.t | `Who_can_write of 'a ] [@@deriving bin_io, compare, hash, sexp] end module Export : sig type read = Read.t [@@deriving bin_io, compare, hash, sexp] (** We don't expose [bin_io] for [write] due to a naming conflict with the functions exported by [bin_io] for [read_write]. If you want [bin_io] for [write], use [Write.t]. *) type write = Write.t [@@deriving compare, hash, sexp] type immutable = Immutable.t [@@deriving bin_io, compare, hash, sexp] type read_write = Read_write.t [@@deriving bin_io, compare, hash, sexp] type 'a perms = 'a Upper_bound.t [@@deriving bin_io, compare, hash, sexp] end module Stable : sig module V1 : sig type nonrec nobody = nobody [@@deriving bin_io, compare, hash, sexp] type nonrec me = me [@@deriving bin_io, compare, hash, sexp] module Read : sig type t = Read.t [@@deriving bin_io, compare, hash, sexp] end module Write : sig type t = Write.t [@@deriving bin_io, compare, hash, sexp] end module Immutable : sig type t = Immutable.t [@@deriving bin_io, compare, hash, sexp] end module Read_write : sig type t = Read_write.t [@@deriving bin_io, compare, hash, sexp] end module Upper_bound : sig type 'a t = 'a Upper_bound.t [@@deriving bin_io, compare, hash, sexp] end end module Export : module type of Export end core-0.15.0/core/src/pid.ml000066400000000000000000000027231420273305200153540ustar00rootroot00000000000000module Stable = struct module V1 = struct module Without_containers = struct type nonrec t = Int.Stable.V1.t [@@deriving compare] exception Pid_must_be_positive of Int.Stable.V1.t [@@deriving sexp] let ensure i = if i <= 0 then raise (Pid_must_be_positive i) else i include Sexpable.Stable.Of_sexpable.V1 (Int.Stable.V1) (struct type t = Int.Stable.V1.t let to_sexpable = Fn.id let of_sexpable = ensure end) include Binable.Stable.Of_binable.V1 [@alert "-legacy"] (Int.Stable.V1) (struct type t = Int.Stable.V1.t let to_binable = Fn.id let of_binable = ensure end) include (val Comparator.Stable.V1.make ~compare ~sexp_of_t) end include Comparable.Stable.V1.Make (Without_containers) include Without_containers end module Latest = V1 end open! Import include Stable.Latest.Without_containers type t = int [@@deriving hash] let of_int i = ensure i let to_int = Fn.id let of_string string = ensure (Int.of_string string) let to_string = Int.to_string let init = of_int 1 include Identifiable.Make_using_comparator (struct type nonrec t = t [@@deriving bin_io, compare, hash, sexp] type nonrec comparator_witness = comparator_witness let comparator = comparator let of_string = of_string let to_string = to_string let module_name = "Core.Pid" end) core-0.15.0/core/src/pid.mli000066400000000000000000000005601420273305200155220ustar00rootroot00000000000000(** Process ID. *) open! Import type t [@@deriving bin_io, hash, sexp] include Identifiable.S with type t := t val of_int : int -> t val to_int : t -> int (** The pid of the "init" process, which is [1] by convention. *) val init : t module Stable : sig module V1 : Stable_comparable.V1 with type t = t and type comparator_witness = comparator_witness end core-0.15.0/core/src/printexc.ml000066400000000000000000000006061420273305200164320ustar00rootroot00000000000000open! Import let to_string _ = `Deprecated_use_Exn_to_string_instead let print _ = `Deprecated_use_Exn_to_string_instead let catch _ _ = `Deprecated_use_Exn_handle_uncaught_instead let print_backtrace = Caml.Printexc.print_backtrace let get_backtrace = Caml.Printexc.get_backtrace let record_backtrace = Caml.Printexc.record_backtrace let backtrace_status = Caml.Printexc.backtrace_status core-0.15.0/core/src/printexc.mli000066400000000000000000000007361420273305200166070ustar00rootroot00000000000000(** This module is here to ensure that we don't use the functions in [Caml.Printexc] inadvertently. *) open! Import val to_string : exn -> [ `Deprecated_use_Exn_to_string_instead ] val print : exn -> [ `Deprecated_use_Exn_to_string_instead ] val catch : ('a -> _) -> 'a -> [ `Deprecated_use_Exn_handle_uncaught_instead ] val print_backtrace : out_channel -> unit val get_backtrace : unit -> string val record_backtrace : bool -> unit val backtrace_status : unit -> bool core-0.15.0/core/src/printf.ml000066400000000000000000000015521420273305200161010ustar00rootroot00000000000000(** This module extends {{!Base.Printf}[Base.Printf]}. *) open! Import include Base.Printf (** @open *) let eprintf = Stdio.Out_channel.eprintf let fprintf = Stdio.Out_channel.fprintf let kfprintf = Stdio.Out_channel.kfprintf let printf = Stdio.Out_channel.printf (** print to stderr; exit 1 *) let exitf fmt = ksprintf (fun s () -> eprintf "%s\n%!" s; exit 1) fmt ;; type printf = { printf : 'a. ('a, Buffer.t, unit) format -> 'a } let collect_to_string f = let buf = Buffer.create 64 in let done_ = ref false in let printf fmt = kbprintf (fun buf -> if !done_ then ( Buffer.reset buf; raise_s [%message "[printf] used after [collect_to_string] returned"])) buf fmt in f { printf }; done_ := true; let output = Buffer.contents buf in Buffer.reset buf; output ;; core-0.15.0/core/src/printf.mli000066400000000000000000000023551420273305200162540ustar00rootroot00000000000000open! Import (** @inline *) include module type of struct include Base.Printf end val eprintf : ('a, out_channel, unit) format -> 'a val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a val kfprintf : (out_channel -> 'a) -> out_channel -> ('b, out_channel, unit, 'a) format4 -> 'b val printf : ('a, out_channel, unit) format -> 'a (** print to stderr; exit 1 *) val exitf : ('a, unit, string, unit -> _) format4 -> 'a type printf = { printf : 'a. ('a, Buffer.t, unit) format -> 'a } (** [collect_to_string (fun { printf } -> ...)] lets you easily convert code that was printing to stdout into code that produces a string. For example, this original code... {[ printf "hello "; (* long computation *) printf "%s%c" "world" '!' ]} ... can be wrapped like so. {[ Printf.collect_to_string (fun { printf } -> printf "hello "; (* long computation *) printf "%s%c" "world" '!') ]} The above is easier than manually editing many lines of the original: {[ let hello = sprintf "hello " in (* long computation *) let world = sprintf "%s%c" "world" '!' in hello ^ world ]} *) val collect_to_string : (printf -> unit) -> string core-0.15.0/core/src/queue.ml000066400000000000000000000030551420273305200157230ustar00rootroot00000000000000open! Import include Base.Queue include Test_binary_searchable.Make1_and_test (struct type nonrec 'a t = 'a t let get = get let length = length module For_test = struct let of_array a = let r = create () in (* We enqueue everything twice, and dequeue it once to ensure: - that the queue has the same content as the array. - that it has, in most cases, an interesting internal structure*) for i = 0 to Array.length a - 1 do enqueue r a.(i) done; for i = 0 to Array.length a - 1 do ignore (dequeue_exn r : bool); enqueue r a.(i) done; r ;; end end) module Serialization_v1 = struct let sexp_of_t = sexp_of_t let t_of_sexp = t_of_sexp let t_sexp_grammar = t_sexp_grammar include Bin_prot.Utils.Make_iterable_binable1 (struct type nonrec 'a t = 'a t type 'a el = 'a [@@deriving bin_io] let caller_identity = Bin_prot.Shape.Uuid.of_string "b4c84254-4992-11e6-9ba7-734e154027bd" ;; let module_name = Some "Core.Queue" let length = length let iter = iter let init ~len ~next = init len ~f:(fun _ -> next ()) end) end include Serialization_v1 module Stable = struct module V1 = struct type nonrec 'a t = 'a t [@@deriving compare] include Serialization_v1 (* We don't have a [%bin_digest] expect test here because the bin_io is mostly hand written, and [core_queue_unit_tests.ml] has unit tests for specific values. *) let map = map end end core-0.15.0/core/src/queue.mli000066400000000000000000000006311420273305200160710ustar00rootroot00000000000000(** This module extends {{!Base.Queue}[Base.Queue]} with bin_io. *) open! Import type 'a t = 'a Base.Queue.t [@@deriving sexp_of, bin_io] (** {2 The interface from Base} *) include module type of Base.Queue with type 'a t := 'a t (** @inline *) (** {2 Extensions} *) include Binary_searchable.S1 with type 'a t := 'a t module Stable : sig module V1 : Stable_module_types.S1 with type 'a t = 'a t end core-0.15.0/core/src/queue_intf.ml000066400000000000000000000002041420273305200167340ustar00rootroot00000000000000open! Import module type S = sig type 'a t [@@deriving bin_io] include Base.Queue.S with type 'a t := 'a t (** @inline *) end core-0.15.0/core/src/quickcheck.ml000066400000000000000000000261071420273305200167140ustar00rootroot00000000000000open! Import open Quickcheck_intf open Base_quickcheck module Float = Base.Float module Int = Base.Int module List = Base.List module Option = Base.Option module Polymorphic_types = struct type ('a, 'b) variant2 = [ `A of 'a | `B of 'b ] [@@deriving quickcheck] type ('a, 'b, 'c) variant3 = [ `A of 'a | `B of 'b | `C of 'c ] [@@deriving quickcheck] type ('a, 'b, 'c, 'd) variant4 = [ `A of 'a | `B of 'b | `C of 'c | `D of 'd ] [@@deriving quickcheck] type ('a, 'b, 'c, 'd, 'e) variant5 = [ `A of 'a | `B of 'b | `C of 'c | `D of 'd | `E of 'e ] [@@deriving quickcheck] type ('a, 'b, 'c, 'd, 'e, 'f) variant6 = [ `A of 'a | `B of 'b | `C of 'c | `D of 'd | `E of 'e | `F of 'f ] [@@deriving quickcheck] type ('a, 'b) tuple2 = 'a * 'b [@@deriving quickcheck] type ('a, 'b, 'c) tuple3 = 'a * 'b * 'c [@@deriving quickcheck] type ('a, 'b, 'c, 'd) tuple4 = 'a * 'b * 'c * 'd [@@deriving quickcheck] type ('a, 'b, 'c, 'd, 'e) tuple5 = 'a * 'b * 'c * 'd * 'e [@@deriving quickcheck] type ('a, 'b, 'c, 'd, 'e, 'f) tuple6 = 'a * 'b * 'c * 'd * 'e * 'f [@@deriving quickcheck] type (-'a, -'b, 'r) fn2 = 'a -> 'b -> 'r [@@deriving quickcheck] type (-'a, -'b, -'c, 'r) fn3 = 'a -> 'b -> 'c -> 'r [@@deriving quickcheck] type (-'a, -'b, -'c, -'d, 'r) fn4 = 'a -> 'b -> 'c -> 'd -> 'r [@@deriving quickcheck] type (-'a, -'b, -'c, -'d, -'e, 'r) fn5 = 'a -> 'b -> 'c -> 'd -> 'e -> 'r [@@deriving quickcheck] type (-'a, -'b, -'c, -'d, -'e, -'f, 'r) fn6 = 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'r [@@deriving quickcheck] end module Observer = struct include Observer let of_hash (type a) (module M : Deriving_hash with type t = a) = of_hash_fold M.hash_fold_t ;; let variant2 = Polymorphic_types.quickcheck_observer_variant2 let variant3 = Polymorphic_types.quickcheck_observer_variant3 let variant4 = Polymorphic_types.quickcheck_observer_variant4 let variant5 = Polymorphic_types.quickcheck_observer_variant5 let variant6 = Polymorphic_types.quickcheck_observer_variant6 let tuple2 = Polymorphic_types.quickcheck_observer_tuple2 let tuple3 = Polymorphic_types.quickcheck_observer_tuple3 let tuple4 = Polymorphic_types.quickcheck_observer_tuple4 let tuple5 = Polymorphic_types.quickcheck_observer_tuple5 let tuple6 = Polymorphic_types.quickcheck_observer_tuple6 let of_predicate a b ~f = unmap (variant2 a b) ~f:(fun x -> if f x then `A x else `B x) let singleton () = opaque let doubleton f = of_predicate (singleton ()) (singleton ()) ~f let enum _ ~f = unmap int ~f let of_list list ~equal = let f x = match List.findi list ~f:(fun _ y -> equal x y) with | None -> failwith "Quickcheck.Observer.of_list: value not found" | Some (i, _) -> i in enum (List.length list) ~f ;; let of_fun f = create (fun x ~size ~hash -> observe (f ()) x ~size ~hash) let comparison ~compare ~eq ~lt ~gt = unmap (variant3 lt (singleton ()) gt) ~f:(fun x -> let c = compare x eq in if c < 0 then `A x else if c > 0 then `C x else `B x) ;; end module Generator = struct include Generator open Let_syntax let singleton = return let doubleton x y = create (fun ~size:_ ~random -> if Splittable_random.bool random then x else y) ;; let of_fun f = create (fun ~size ~random -> generate (f ()) ~size ~random) let of_sequence ~p seq = if Float.( <= ) p 0. || Float.( > ) p 1. then failwith (Printf.sprintf "Generator.of_sequence: probability [%f] out of bounds" p); Sequence.delayed_fold seq ~init:() ~finish:(fun () -> failwith "Generator.of_sequence: ran out of values") ~f:(fun () x ~k -> weighted_union [ p, singleton x; 1. -. p, of_fun k ]) ;; let rec bounded_geometric ~p ~maximum init = if init = maximum then singleton maximum else weighted_union [ p, singleton init ; 1. -. p, of_fun (fun () -> bounded_geometric ~p ~maximum (init + 1)) ] ;; let geometric ~p init = bounded_geometric ~p ~maximum:Int.max_value init let small_non_negative_int = small_positive_or_zero_int let small_positive_int = small_strictly_positive_int let list_with_length length t = list_with_length t ~length let variant2 = Polymorphic_types.quickcheck_generator_variant2 let variant3 = Polymorphic_types.quickcheck_generator_variant3 let variant4 = Polymorphic_types.quickcheck_generator_variant4 let variant5 = Polymorphic_types.quickcheck_generator_variant5 let variant6 = Polymorphic_types.quickcheck_generator_variant6 let tuple2 = Polymorphic_types.quickcheck_generator_tuple2 let tuple3 = Polymorphic_types.quickcheck_generator_tuple3 let tuple4 = Polymorphic_types.quickcheck_generator_tuple4 let tuple5 = Polymorphic_types.quickcheck_generator_tuple5 let tuple6 = Polymorphic_types.quickcheck_generator_tuple6 let fn2 = Polymorphic_types.quickcheck_generator_fn2 let fn3 = Polymorphic_types.quickcheck_generator_fn3 let fn4 = Polymorphic_types.quickcheck_generator_fn4 let fn5 = Polymorphic_types.quickcheck_generator_fn5 let fn6 = Polymorphic_types.quickcheck_generator_fn6 let compare_fn dom = fn dom int >>| fun get_index x y -> [%compare: int] (get_index x) (get_index y) ;; let equal_fn dom = compare_fn dom >>| fun cmp x y -> Int.( = ) (cmp x y) 0 end module Shrinker = struct include Shrinker let empty () = atomic let variant2 = Polymorphic_types.quickcheck_shrinker_variant2 let variant3 = Polymorphic_types.quickcheck_shrinker_variant3 let variant4 = Polymorphic_types.quickcheck_shrinker_variant4 let variant5 = Polymorphic_types.quickcheck_shrinker_variant5 let variant6 = Polymorphic_types.quickcheck_shrinker_variant6 let tuple2 = Polymorphic_types.quickcheck_shrinker_tuple2 let tuple3 = Polymorphic_types.quickcheck_shrinker_tuple3 let tuple4 = Polymorphic_types.quickcheck_shrinker_tuple4 let tuple5 = Polymorphic_types.quickcheck_shrinker_tuple5 let tuple6 = Polymorphic_types.quickcheck_shrinker_tuple6 end module Let_syntax = struct module Let_syntax = struct include Generator module Open_on_rhs = Generator end include Generator.Monad_infix let return = Generator.return end module Configure (Config : Quickcheck_config) = struct include Config let nondeterministic_state = lazy (Random.State.make_self_init ()) let random_state_of_seed seed = match seed with | `Nondeterministic -> Splittable_random.State.create (force nondeterministic_state) | `Deterministic str -> Splittable_random.State.of_int ([%hash: string] str) ;; let make_seed seed : Test.Config.Seed.t = match seed with | `Nondeterministic -> Nondeterministic | `Deterministic string -> Deterministic string ;; let make_shrink_count = function | `Exhaustive -> Int.max_value | `Limit n -> n ;; let make_config ~seed ~sizes ~trials ~shrink_attempts : Test.Config.t = { seed = make_seed (Option.value seed ~default:default_seed) ; sizes = Option.value sizes ~default:default_sizes ; test_count = Option.value trials ~default:default_trial_count ; shrink_count = make_shrink_count (Option.value shrink_attempts ~default:default_shrink_attempts) } ;; let make_test_m (type a) ~gen ~shrinker ~sexp_of : (module Test.S with type t = a) = let module M = struct type t = a let quickcheck_generator = gen let quickcheck_shrinker = Option.value shrinker ~default:Shrinker.atomic let sexp_of_t = Option.value sexp_of ~default:[%sexp_of: _] end in (module M) ;; let random_value ?(seed = default_seed) ?(size = 30) gen = let random = random_state_of_seed seed in Generator.generate gen ~size ~random ;; let random_sequence ?seed ?sizes gen = let config = make_config ~seed ~sizes ~trials:(Some Int.max_value) ~shrink_attempts:None in let return = ref Sequence.empty in Test.with_sample_exn ~config gen ~f:(fun sequence -> return := sequence); !return ;; let iter ?seed ?sizes ?trials gen ~f = let config = make_config ~seed ~sizes ~trials ~shrink_attempts:None in Test.with_sample_exn ~config gen ~f:(fun sequence -> Sequence.iter sequence ~f) ;; let test ?seed ?sizes ?trials ?shrinker ?shrink_attempts ?sexp_of ?examples gen ~f = let config = make_config ~seed ~sizes ~trials ~shrink_attempts in let test_m = make_test_m ~gen ~shrinker ~sexp_of in Test.run_exn ~config ?examples ~f test_m ;; let test_or_error ?seed ?sizes ?trials ?shrinker ?shrink_attempts ?sexp_of ?examples gen ~f = let config = make_config ~seed ~sizes ~trials ~shrink_attempts in let test_m = make_test_m ~gen ~shrinker ~sexp_of in Test.run ~config ?examples ~f test_m ;; let test_distinct_values (type key) ?seed ?sizes ?sexp_of gen ~trials ~distinct_values ~compare = let module S = Caml.Set.Make (struct type t = key let compare = compare end) in let fail set = let expect_count = distinct_values in let actual_count = S.cardinal set in let values = match sexp_of with | None -> None | Some sexp_of_elt -> Some [%sexp (S.elements set : elt list)] in raise_s [%message "insufficient distinct values" (trials : int) (expect_count : int) (actual_count : int) (values : (Base.Sexp.t option[@sexp.option]))] in with_return (fun r -> let set = ref S.empty in iter ?seed ?sizes ~trials gen ~f:(fun elt -> set := S.add elt !set; if S.cardinal !set >= distinct_values then r.return ()); fail !set) ;; let test_can_generate ?seed ?sizes ?(trials = default_can_generate_trial_count) ?sexp_of gen ~f = let r = ref [] in let f_and_enqueue return x = if f x then return `Can_generate else r := x :: !r in match With_return.with_return (fun return -> iter ?seed ?sizes ~trials gen ~f:(f_and_enqueue return.return); `Cannot_generate) with | `Can_generate -> () | `Cannot_generate -> (match sexp_of with | None -> failwith "cannot generate" | Some sexp_of_value -> Error.raise_s [%message "cannot generate" ~attempts:(!r : value list)]) ;; end include Configure (struct let default_seed = `Deterministic "an arbitrary but deterministic string" let default_trial_count = match Word_size.word_size with | W64 -> 10_000 | W32 -> 1_000 ;; let default_can_generate_trial_count = 10_000 let default_shrink_attempts = `Limit 1000 let default_sizes = Sequence.cycle_list_exn (List.range 0 30 ~stop:`inclusive) ;; end) module type S = S module type S1 = S1 module type S2 = S2 module type S_int = S_int module type S_range = S_range type nonrec seed = seed type nonrec shrink_attempts = shrink_attempts module type Quickcheck_config = Quickcheck_config module type Quickcheck_configured = Quickcheck_configured core-0.15.0/core/src/quickcheck.mli000066400000000000000000000000621420273305200170550ustar00rootroot00000000000000include Quickcheck_intf.Quickcheck (** @inline *) core-0.15.0/core/src/quickcheck_intf.ml000066400000000000000000000556201420273305200177360ustar00rootroot00000000000000(** Quickcheck is a library that uses predicate-based tests and pseudo-random inputs to automate testing. For examples see {e lib/base_quickcheck/examples}. *) open! Import open Base_quickcheck module type Generator = sig (** An ['a t] a generates values of type ['a] with a specific probability distribution. Generators are constructed as functions that produce a value from a splittable pseudorandom number generator (see [Splittable_random]), with a [~size] argument threaded through to bound the size of the result value and the depth of recursion. There is no prescribed semantics for [size] other than that it must be non-negative. Non-recursive generators are free to ignore it, and recursive generators need only make sure it decreases in recursive calls and that recursion bottoms out at 0. *) type +'a t = 'a Generator.t val create : (size:int -> random:Splittable_random.State.t -> 'a) -> 'a t val generate : 'a t -> size:int -> random:Splittable_random.State.t -> 'a (** Generators form a monad. [t1 >>= fun x -> t2] replaces each value [x] in [t1] with the values in [t2]; each value's probability is the product of its probability in [t1] and [t2]. This can be used to form distributions of related values. For instance, the following expression creates a distribution of pairs [x,y] where [x <= y]: {[ Int.gen >>= fun x -> Int.gen_incl x Int.max_value >>| fun y -> x, y ]} *) include Monad.S with type 'a t := 'a t include Applicative.S with type 'a t := 'a t (** [size = create (fun ~size _ -> size)] *) val size : int t (** [with_size t ~size = create (fun ~size:_ random -> generate t ~size random)] *) val with_size : 'a t -> size:int -> 'a t val bool : bool t val char : char t val char_digit : char t val char_lowercase : char t val char_uppercase : char t val char_alpha : char t val char_alphanum : char t val char_print : char t val char_whitespace : char t val singleton : 'a -> 'a t val doubleton : 'a -> 'a -> 'a t (** Produce any of the given values, weighted equally. [of_list [ v1 ; ... ; vN ] = union [ singleton v1 ; ... ; singleton vN ]] *) val of_list : 'a list -> 'a t (** Combine arbitary generators, weighted equally. [ union [ g1 ; ... ; gN ] = weighted_union [ (1.0, g1) ; ... ; (1.0, gN) ] ] *) val union : 'a t list -> 'a t (** Generator for the values from a potentially infinite sequence. Chooses each value with probability [p], or continues with probability [1-p]. Must satisfy [0. < p && p <= 1.]. *) val of_sequence : p:float -> 'a Sequence.t -> 'a t val tuple2 : 'a t -> 'b t -> ('a * 'b) t val tuple3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t val tuple4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t val tuple5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t val tuple6 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> ('a * 'b * 'c * 'd * 'e * 'f) t val variant2 : 'a t -> 'b t -> [ `A of 'a | `B of 'b ] t val variant3 : 'a t -> 'b t -> 'c t -> [ `A of 'a | `B of 'b | `C of 'c ] t val variant4 : 'a t -> 'b t -> 'c t -> 'd t -> [ `A of 'a | `B of 'b | `C of 'c | `D of 'd ] t val variant5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> [ `A of 'a | `B of 'b | `C of 'c | `D of 'd | `E of 'e ] t val variant6 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> [ `A of 'a | `B of 'b | `C of 'c | `D of 'd | `E of 'e | `F of 'f ] t (** [geometric ~p init] produces a geometric distribution (think "radioactive decay") that produces [init] with probability [p], and otherwise recursively chooses from [geometric ~p (init+1)]. Must satisfy [0. < p && p <= 1.]. *) val geometric : p:float -> int -> int t (** [small_non_negative_int] produces a non-negative int of a tractable size, e.g. allocating a value of this size should not run out of memory. *) val small_non_negative_int : int t (** [small_positive_int] produces a positive int of a tractable size, e.g. allocating a value of this size should not run out of memory. *) val small_positive_int : int t (** Generators for functions; take observers for inputs and a generator for outputs. *) val fn : 'a Observer.t -> 'b t -> ('a -> 'b) t val fn2 : 'a Observer.t -> 'b Observer.t -> 'c t -> ('a -> 'b -> 'c) t val fn3 : 'a Observer.t -> 'b Observer.t -> 'c Observer.t -> 'd t -> ('a -> 'b -> 'c -> 'd) t val fn4 : 'a Observer.t -> 'b Observer.t -> 'c Observer.t -> 'd Observer.t -> 'e t -> ('a -> 'b -> 'c -> 'd -> 'e) t val fn5 : 'a Observer.t -> 'b Observer.t -> 'c Observer.t -> 'd Observer.t -> 'e Observer.t -> 'f t -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f) t val fn6 : 'a Observer.t -> 'b Observer.t -> 'c Observer.t -> 'd Observer.t -> 'e Observer.t -> 'f Observer.t -> 'g t -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) t (** Generator for comparison functions; result is guaranteed to be a partial order. *) val compare_fn : 'a Observer.t -> ('a -> 'a -> int) t (** Generator for equality functions; result is guaranteed to be an equivalence relation. *) val equal_fn : 'a Observer.t -> ('a -> 'a -> bool) t (** [filter_map t ~f] produces [y] for every [x] in [t] such that [f x = Some y]. *) val filter_map : 'a t -> f:('a -> 'b option) -> 'b t (** [filter t ~f] produces every [x] in [t] such that [f x = true]. *) val filter : 'a t -> f:('a -> bool) -> 'a t (** Generator for recursive data type with multiple clauses. At size 0, chooses only among the non-recursive cases; at sizes greater than 0, chooses among non-recursive and recursive cases, calling the recursive cases with decremented size. {[ type tree = Leaf | Node of tree * int * tree;; recursive_union [return Leaf] ~f:(fun self -> [let%map left = self and int = Int.gen and right = self in Node (left, int, right)]) ]} *) val recursive_union : 'a t list -> f:('a t -> 'a t list) -> 'a t (** Like [recursive_union], with the addition of non-uniform weights for each clause. *) val weighted_recursive_union : (float * 'a t) list -> f:('a t -> (float * 'a t) list) -> 'a t (** Fixed-point generator. Use [size] to bound the size of the value and the depth of the recursion. There is no prescribed semantics for [size] except that it must be non-negative. For example, the following produces a naive generator for natural numbers: {[ fixed_point (fun self -> match%bind size with | 0 -> singleton 0 | n -> with_size self ~size:(n-1) >>| Int.succ) ]} *) val fixed_point : ('a t -> 'a t) -> 'a t (** [weighted_union alist] produces a generator that combines the distributions of each [t] in [alist] with the associated weights, which must be finite positive floating point values. *) val weighted_union : (float * 'a t) list -> 'a t (** [of_fun f] produces a generator that lazily applies [f]. It is recommended that [f] not be memoized. Instead, spread out the work of generating a whole distribution over many [of_fun] calls combined with [weighted_union]. This allows lazily generated generators to be garbage collected after each test and the relevant portions cheaply recomputed in subsequent tests, rather than accumulating without bound over time. *) val of_fun : (unit -> 'a t) -> 'a t (** Generators for lists, choosing each element independently from the given element generator. [list] and [list_non_empty] distribute [size] among the list length and the sizes of each element. [list_non_empty] never generates the empty list. [list_with_length] generates lists of the given length, and distributes [size] among the sizes of the elements. *) val list : 'a t -> 'a list t val list_non_empty : 'a t -> 'a list t val list_with_length : int -> 'a t -> 'a list t end module type Deriving_hash = sig type t [@@deriving hash] end module type Observer = sig (** An ['a Quickcheck.Observer.t] represents a hash function on ['a]. Observers are used to construct distributions of random functions; see [Quickcheck.Generator.fn]. Like generators, observers have a [~size] argument that is threaded through to bound the depth of recursion in potentially infinite cases. For finite values, [size] can be ignored. For hashable types, one can construct an observer using [of_hash]. For other types, use the built-in observers and observer combinators below, or use [create] directly. *) type -'a t = 'a Observer.t val create : ('a -> size:int -> hash:Hash.state -> Hash.state) -> 'a t val observe : 'a t -> 'a -> size:int -> hash:Hash.state -> Hash.state (** [of_hash] creates an observer for any hashable type. *) val of_hash : (module Deriving_hash with type t = 'a) -> 'a t val bool : bool t val char : char t (** [doubleton f] maps values to two "buckets" (as described in [t] above), depending on whether they satisfy [f]. *) val doubleton : ('a -> bool) -> 'a t (** [enum n ~f] maps values to [n] buckets, where [f] produces the index for a bucket from [0] to [n-1] for each value. *) val enum : int -> f:('a -> int) -> 'a t (** [of_list list ~equal] maps values in [list] to separate buckets, and compares observed values to the elements of [list] using [equal]. *) val of_list : 'a list -> equal:('a -> 'a -> bool) -> 'a t (** Fixed point observer for recursive types. For example: {[ let sexp_obs = fixed_point (fun sexp_t -> unmap (variant2 string (list sexp_t)) ~f:(function | Sexp.Atom atom -> `A atom | Sexp.List list -> `B list)) ]} *) val fixed_point : ('a t -> 'a t) -> 'a t val variant2 : 'a t -> 'b t -> [ `A of 'a | `B of 'b ] t val variant3 : 'a t -> 'b t -> 'c t -> [ `A of 'a | `B of 'b | `C of 'c ] t val variant4 : 'a t -> 'b t -> 'c t -> 'd t -> [ `A of 'a | `B of 'b | `C of 'c | `D of 'd ] t val variant5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> [ `A of 'a | `B of 'b | `C of 'c | `D of 'd | `E of 'e ] t val variant6 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> [ `A of 'a | `B of 'b | `C of 'c | `D of 'd | `E of 'e | `F of 'f ] t (** [of_predicate t1 t2 ~f] combines [t1] and [t2], where [t1] observes values that satisfy [f] and [t2] observes values that do not satisfy [f]. *) val of_predicate : 'a t -> 'a t -> f:('a -> bool) -> 'a t (** [comparison ~compare ~eq ~lt ~gt] combines observers [lt] and [gt], where [lt] observes values less than [eq] according to [compare], and [gt] observes values greater than [eq] according to [compare]. *) val comparison : compare:('a -> 'a -> int) -> eq:'a -> lt:'a t -> gt:'a t -> 'a t (** maps all values to a single bucket. *) val singleton : unit -> _ t (** [unmap t ~f] applies [f] to values before observing them using [t]. *) val unmap : 'a t -> f:('b -> 'a) -> 'b t val tuple2 : 'a t -> 'b t -> ('a * 'b) t val tuple3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t val tuple4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t val tuple5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t val tuple6 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> ('a * 'b * 'c * 'd * 'e * 'f) t (** Observer for function type. [fn gen t] observes a function by generating random inputs from [gen], applying the function, and observing the output using [t]. *) val fn : 'a Generator.t -> 'b t -> ('a -> 'b) t (** [of_fun f] produces an observer that lazily applies [f]. It is recommended that [f] should not do a lot of expensive work and should not be memoized. Instead, spread out the work of generating an observer over many [of_fun] calls combined with, e.g., [variant] or [tuple]. This allows lazily generated observers to be garbage collected after each test and the relevant portions cheaply recomputed in subsequent tests, rather than accumulating without bound over time. *) val of_fun : (unit -> 'a t) -> 'a t end module type Shrinker = sig (** A ['a Quickcheck.Shrinker.t] takes a value of type ['a] and produces similar values that are smaller by some metric. The defined shrinkers generally try to make a single change for each value based on the assumption that the first resulting value that preserves the desired property will be used to create another sequence of shrunk values. Within [Quickcheck.test] the shrinker is used as described above. Shrinkers aim to aid understanding of what's causing an error by reducing the input down to just the elements making it fail. The default shrinkers remove elements of compound structures, but leave atomic values alone. For example, the default list shrinker tries removing elements from the list, but the default int shrinker does nothing. This default strikes a balance between performance and precision. Individual tests can use different shrinking behavior as necessary. See lib/core/example/quickcheck/shrinker_example.ml for some example shrinkers. *) type 'a t = 'a Shrinker.t val shrink : 'a t -> 'a -> 'a Sequence.t val create : ('a -> 'a Sequence.t) -> 'a t val empty : unit -> 'a t val bool : bool t val char : char t val map : 'a t -> f:('a -> 'b) -> f_inverse:('b -> 'a) -> 'b t val filter : 'a t -> f:('a -> bool) -> 'a t (** Filters and maps according to [f], and provides input to [t] via [f_inverse]. Only the [f] direction produces options, intentionally. *) val filter_map : 'a t -> f:('a -> 'b option) -> f_inverse:('b -> 'a) -> 'b t val tuple2 : 'a t -> 'b t -> ('a * 'b) t val tuple3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t val tuple4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t val tuple5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t val tuple6 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> ('a * 'b * 'c * 'd * 'e * 'f) t val variant2 : 'a t -> 'b t -> [ `A of 'a | `B of 'b ] t val variant3 : 'a t -> 'b t -> 'c t -> [ `A of 'a | `B of 'b | `C of 'c ] t val variant4 : 'a t -> 'b t -> 'c t -> 'd t -> [ `A of 'a | `B of 'b | `C of 'c | `D of 'd ] t val variant5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> [ `A of 'a | `B of 'b | `C of 'c | `D of 'd | `E of 'e ] t val variant6 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> [ `A of 'a | `B of 'b | `C of 'c | `D of 'd | `E of 'e | `F of 'f ] t (** [fixed_point] assists with shrinking structures recursively. Its advantage over directly using [rec] in the definition of the shrinker is that it causes lazy evaluation where possible. *) val fixed_point : ('a t -> 'a t) -> 'a t end module type S = sig type t val quickcheck_generator : t Generator.t val quickcheck_observer : t Observer.t val quickcheck_shrinker : t Shrinker.t end module type S1 = sig type 'a t val quickcheck_generator : 'a Generator.t -> 'a t Generator.t val quickcheck_observer : 'a Observer.t -> 'a t Observer.t val quickcheck_shrinker : 'a Shrinker.t -> 'a t Shrinker.t end module type S2 = sig type ('a, 'b) t val quickcheck_generator : 'a Generator.t -> 'b Generator.t -> ('a, 'b) t Generator.t val quickcheck_observer : 'a Observer.t -> 'b Observer.t -> ('a, 'b) t Observer.t val quickcheck_shrinker : 'a Shrinker.t -> 'b Shrinker.t -> ('a, 'b) t Shrinker.t end module type S_range = sig include S (** [gen_incl lower_bound upper_bound] produces values between [lower_bound] and [upper_bound], inclusive. It uses an ad hoc distribution that stresses boundary conditions more often than a uniform distribution, while still able to produce any value in the range. Raises if [lower_bound > upper_bound]. *) val gen_incl : t -> t -> t Generator.t (** [gen_uniform_incl lower_bound upper_bound] produces a generator for values uniformly distributed between [lower_bound] and [upper_bound], inclusive. Raises if [lower_bound > upper_bound]. *) val gen_uniform_incl : t -> t -> t Generator.t end module type S_int = sig include S_range (** [gen_log_uniform_incl lower_bound upper_bound] produces a generator for values between [lower_bound] and [upper_bound], inclusive, where the number of bits used to represent the value is uniformly distributed. Raises if [(lower_bound < 0) || (lower_bound > upper_bound)]. *) val gen_log_uniform_incl : t -> t -> t Generator.t (** [gen_log_incl lower_bound upper_bound] is like [gen_log_uniform_incl], but weighted slightly more in favor of generating [lower_bound] and [upper_bound] specifically. *) val gen_log_incl : t -> t -> t Generator.t end (** [seed] specifies how to initialize a pseudo-random number generator. When multiple tests share a deterministic seed, they each get a separate copy of the random generator's state; random choices in one test do not affect those in another. The nondeterministic seed causes a fresh random state to be generated nondeterministically for each test. *) type seed = [ `Deterministic of string | `Nondeterministic ] type shrink_attempts = [ `Exhaustive | `Limit of int ] module type Quickcheck_config = sig (** [default_seed] is used initialize the pseudo-random generator that chooses random values from generators, in each test that is not provided its own seed. *) val default_seed : seed (** [default_sizes] determines the default sequence of sizes used in generating values. *) val default_sizes : int Sequence.t (** [default_trial_count] determines the number of trials per test, except in tests that explicitly override it. *) val default_trial_count : int (** [default_can_generate_trial_count] determines the number of trials used in attempts to generate satisfying values, except in tests that explicitly override it. *) val default_can_generate_trial_count : int (** [default_shrink_attempts] determines the number of attempts at shrinking when running [test] or [iter] with [~shrinker] and without [~shrink_attempts] *) val default_shrink_attempts : shrink_attempts end module type Quickcheck_configured = sig include Quickcheck_config (** [random_value gen] produces a single value chosen from [gen] using [seed]. *) val random_value : ?seed:seed -> ?size:int -> 'a Generator.t -> 'a (** [iter gen ~f] runs [f] on up to [trials] different values generated by [gen]. It stops successfully after [trials] successful trials or if [gen] runs out of values. It raises an exception if [f] raises an exception. *) val iter : ?seed:seed -> ?sizes:int Sequence.t -> ?trials:int -> 'a Generator.t -> f:('a -> unit) -> unit (** [test gen ~f] is like [iter], with optional concrete [examples] that are tested before values from [gen], and additional information provided on failure. If [f] raises an exception and [sexp_of] is provided, the exception is re-raised with a description of the random input that triggered the failure. If [f] raises an exception and [shrinker] is provided, it will be used to attempt to shrink the value that caused the exception with re-raising behaving the same as for unshrunk inputs. *) val test : ?seed:seed -> ?sizes:int Sequence.t -> ?trials:int -> ?shrinker:'a Shrinker.t -> ?shrink_attempts:shrink_attempts -> ?sexp_of:('a -> Base.Sexp.t) -> ?examples:'a list -> 'a Generator.t -> f:('a -> unit) -> unit (** [test_or_error] is like [test], except failure is determined using [Or_error.t]. Any exceptions raised by [f] are also treated as failures. *) val test_or_error : ?seed:seed -> ?sizes:int Sequence.t -> ?trials:int -> ?shrinker:'a Shrinker.t -> ?shrink_attempts:shrink_attempts -> ?sexp_of:('a -> Base.Sexp.t) -> ?examples:'a list -> 'a Generator.t -> f:('a -> unit Or_error.t) -> unit Or_error.t (** [test_can_generate gen ~f] is useful for testing [gen] values, to make sure they can generate useful examples. It tests [gen] by generating up to [trials] values and passing them to [f]. Once a value satisfies [f], the iteration stops. If no values satisfy [f], [test_can_generate] raises an exception. If [sexp_of] is provided, the exception includes all of the generated values. *) val test_can_generate : ?seed:seed -> ?sizes:int Sequence.t -> ?trials:int -> ?sexp_of:('a -> Base.Sexp.t) -> 'a Generator.t -> f:('a -> bool) -> unit (** [test_distinct_values gen] is useful for testing [gen] values, to make sure they create sufficient distinct values. It tests [gen] by generating up to [trials] values and making sure at least [distinct_values] of the resulting values are unique with respect to [compare]. If too few distinct values are generated, [test_distinct_values] raises an exception. If [sexp_of] is provided, the exception includes the values generated. *) val test_distinct_values : ?seed:seed -> ?sizes:int Sequence.t -> ?sexp_of:('a -> Base.Sexp.t) -> 'a Generator.t -> trials:int -> distinct_values:int -> compare:('a -> 'a -> int) -> unit (** [random_sequence ~seed gen] produces a sequence of values chosen from [gen]. *) val random_sequence : ?seed:seed -> ?sizes:int Sequence.t -> 'a Generator.t -> 'a Sequence.t end (** Includes [Let_syntax] from [Monad.Syntax]. Sets [Open_on_rhs] to be all of [Generator], except that it does not shadow [Let_syntax] itself. Both [Generator] and [Open_on_rhs] are meant to be destructively assigned. *) module type Syntax = sig module Generator : Generator module Open_on_rhs : Generator with type 'a t := 'a Generator.t and module Let_syntax := Generator.Let_syntax include Monad.Syntax with type 'a t := 'a Generator.t and module Let_syntax.Let_syntax.Open_on_rhs = Open_on_rhs end module type Quickcheck = sig type nonrec seed = seed type nonrec shrink_attempts = shrink_attempts module Generator : Generator module Observer : Observer module Shrinker : Shrinker module type S = S module type S1 = S1 module type S2 = S2 module type S_int = S_int module type S_range = S_range include Syntax with module Generator := Generator and module Open_on_rhs := Generator module type Quickcheck_config = Quickcheck_config module type Quickcheck_configured = Quickcheck_configured (** with a default config *) include Quickcheck_configured module Configure (Config : Quickcheck_config) : Quickcheck_configured end core-0.15.0/core/src/quickcheckable.ml000066400000000000000000000055351420273305200175420ustar00rootroot00000000000000open! Import open Quickcheckable_intf module type Conv = Conv module type Conv_filtered = Conv_filtered module type Conv1 = Conv1 module type Conv_filtered1 = Conv_filtered1 module type S = Quickcheck.S module type S1 = Quickcheck.S1 module type S2 = Quickcheck.S2 module type S_int = Quickcheck.S_int module Of_quickcheckable (Quickcheckable : S) (Conv : Conv with type quickcheckable := Quickcheckable.t) : S with type t := Conv.t = struct let quickcheck_generator = Quickcheck.Generator.map Quickcheckable.quickcheck_generator ~f:Conv.of_quickcheckable ;; let quickcheck_observer = Quickcheck.Observer.unmap Quickcheckable.quickcheck_observer ~f:Conv.to_quickcheckable ;; let quickcheck_shrinker = Quickcheck.Shrinker.map Quickcheckable.quickcheck_shrinker ~f:Conv.of_quickcheckable ~f_inverse:Conv.to_quickcheckable ;; end module Of_quickcheckable1 (Quickcheckable : S1) (Conv : Conv1 with type 'a quickcheckable := 'a Quickcheckable.t) : S1 with type 'a t := 'a Conv.t = struct let quickcheck_generator generate_a = Quickcheck.Generator.map (Quickcheckable.quickcheck_generator generate_a) ~f:Conv.of_quickcheckable ;; let quickcheck_observer observe_a = Quickcheck.Observer.unmap (Quickcheckable.quickcheck_observer observe_a) ~f:Conv.to_quickcheckable ;; let quickcheck_shrinker shrink_a = Quickcheck.Shrinker.map (Quickcheckable.quickcheck_shrinker shrink_a) ~f:Conv.of_quickcheckable ~f_inverse:Conv.to_quickcheckable ;; end module Of_quickcheckable_filtered (Quickcheckable : S) (Conv : Conv_filtered with type quickcheckable := Quickcheckable.t) : S with type t := Conv.t = struct let quickcheck_generator = Quickcheck.Generator.filter_map Quickcheckable.quickcheck_generator ~f:Conv.of_quickcheckable ;; let quickcheck_observer = Quickcheck.Observer.unmap Quickcheckable.quickcheck_observer ~f:Conv.to_quickcheckable ;; let quickcheck_shrinker = Quickcheck.Shrinker.filter_map Quickcheckable.quickcheck_shrinker ~f:Conv.of_quickcheckable ~f_inverse:Conv.to_quickcheckable ;; end module Of_quickcheckable_filtered1 (Quickcheckable : S1) (Conv : Conv_filtered1 with type 'a quickcheckable := 'a Quickcheckable.t) : S1 with type 'a t := 'a Conv.t = struct let quickcheck_generator generate_a = Quickcheck.Generator.filter_map (Quickcheckable.quickcheck_generator generate_a) ~f:Conv.of_quickcheckable ;; let quickcheck_observer observe_a = Quickcheck.Observer.unmap (Quickcheckable.quickcheck_observer observe_a) ~f:Conv.to_quickcheckable ;; let quickcheck_shrinker shrink_a = Quickcheck.Shrinker.filter_map (Quickcheckable.quickcheck_shrinker shrink_a) ~f:Conv.of_quickcheckable ~f_inverse:Conv.to_quickcheckable ;; end core-0.15.0/core/src/quickcheckable.mli000066400000000000000000000000721420273305200177020ustar00rootroot00000000000000include Quickcheckable_intf.Quickcheckable (** @inline *) core-0.15.0/core/src/quickcheckable_intf.ml000066400000000000000000000033311420273305200205520ustar00rootroot00000000000000open! Import module type Conv = sig type quickcheckable type t val of_quickcheckable : quickcheckable -> t val to_quickcheckable : t -> quickcheckable end module type Conv1 = sig type 'a quickcheckable type 'a t val of_quickcheckable : 'a quickcheckable -> 'a t val to_quickcheckable : 'a t -> 'a quickcheckable end module type Conv_filtered = sig type quickcheckable type t val of_quickcheckable : quickcheckable -> t option val to_quickcheckable : t -> quickcheckable end module type Conv_filtered1 = sig type 'a quickcheckable type 'a t val of_quickcheckable : 'a quickcheckable -> 'a t option val to_quickcheckable : 'a t -> 'a quickcheckable end (** Provides functors for making a module quickcheckable with {!Quickcheck}. *) module type Quickcheckable = sig module type Conv = Conv module type Conv1 = Conv1 module type Conv_filtered = Conv_filtered module type Conv_filtered1 = Conv_filtered1 module type S = Quickcheck.S module type S1 = Quickcheck.S1 module type S2 = Quickcheck.S2 module type S_int = Quickcheck.S_int module Of_quickcheckable (Quickcheckable : S) (Conv : Conv with type quickcheckable := Quickcheckable.t) : S with type t := Conv.t module Of_quickcheckable1 (Quickcheckable : S1) (Conv : Conv1 with type 'a quickcheckable := 'a Quickcheckable.t) : S1 with type 'a t := 'a Conv.t module Of_quickcheckable_filtered (Quickcheckable : S) (Conv : Conv_filtered with type quickcheckable := Quickcheckable.t) : S with type t := Conv.t module Of_quickcheckable_filtered1 (Quickcheckable : S1) (Conv : Conv_filtered1 with type 'a quickcheckable := 'a Quickcheckable.t) : S1 with type 'a t := 'a Conv.t end core-0.15.0/core/src/ref.ml000066400000000000000000000007631420273305200153560ustar00rootroot00000000000000open! Import open Base_quickcheck.Export module T = struct include Base.Ref include ( struct type 'a t = 'a ref [@@deriving bin_io, quickcheck, typerep] end : sig type 'a t = 'a ref [@@deriving bin_io, quickcheck, typerep] end with type 'a t := 'a t) end include T module Permissioned = struct include T type ('a, -'perms) t = 'a T.t [@@deriving bin_io, sexp] let read_only = Fn.id let of_ref = Fn.id let to_ref = Fn.id let set = ( := ) let get = ( ! ) end core-0.15.0/core/src/ref.mli000066400000000000000000000020351420273305200155210ustar00rootroot00000000000000(** This module extends {{!Base.Ref}[Base.Ref]}. *) open! Import open Perms.Export type 'a t = 'a Base.Ref.t = { mutable contents : 'a } [@@deriving bin_io, quickcheck, typerep] (** @inline *) include module type of struct include Base.Ref end with type 'a t := 'a t module Permissioned : sig type ('a, -'perms) t [@@deriving sexp, bin_io] val create : 'a -> ('a, [< _ perms ]) t val read_only : ('a, [> read ]) t -> ('a, read) t (** [get] and [(!)] are two names for the same function. *) val ( ! ) : ('a, [> read ]) t -> 'a val get : ('a, [> read ]) t -> 'a (** [set] and [(:=)] are two names for the same function. *) val set : ('a, [> write ]) t -> 'a -> unit val ( := ) : ('a, [> write ]) t -> 'a -> unit val of_ref : 'a ref -> ('a, [< read_write ]) t val to_ref : ('a, [> read_write ]) t -> 'a ref val swap : ('a, [> read_write ]) t -> ('a, [> read_write ]) t -> unit val replace : ('a, [> read_write ]) t -> ('a -> 'a) -> unit val set_temporarily : ('a, [> read_write ]) t -> 'a -> f:(unit -> 'b) -> 'b end core-0.15.0/core/src/result.ml000066400000000000000000000011701420273305200161110ustar00rootroot00000000000000open! Import module Result = Base.Result module Stable = struct module V1 = struct type ('a, 'b) t = ('a, 'b) Result.t = | Ok of 'a | Error of 'b [@@deriving bin_io, compare, hash, sexp] let map x ~f1 ~f2 = match x with | Error err -> Error (f2 err) | Ok x -> Ok (f1 x) ;; end module V1_stable_unit_test = struct type t = (string, int) V1.t [@@deriving bin_io, compare, hash, sexp] let equal = [%compare.equal: t] let tests = [ V1.Ok "foo", "(Ok foo)", "\000\003foo"; V1.Error 7, "(Error 7)", "\001\007" ] ;; end end include Stable.V1 include Result core-0.15.0/core/src/result.mli000066400000000000000000000013331420273305200162630ustar00rootroot00000000000000(** This module extends {{!Base.Result}[Base.Result]}. *) open! Import type ('a, 'b) t = ('a, 'b) Base.Result.t = | Ok of 'a | Error of 'b [@@deriving bin_io, compare, equal, hash, sexp] include module type of Base.Result with type ('a, 'b) t := ('a, 'b) t (** @inline *) module Stable : sig module V1 : sig type nonrec ('ok, 'err) t = ('ok, 'err) t = | Ok of 'ok | Error of 'err include Stable_module_types.S2 with type ('ok, 'err) t := ('ok, 'err) t end (** We export the unit test arg rather than instantiate the functor inside result.ml in order to avoid circular dependencies. The functor is instantiated in stable.ml. *) module V1_stable_unit_test : Stable_unit_test_intf.Arg end core-0.15.0/core/src/robustly_comparable.ml000066400000000000000000000010751420273305200206470ustar00rootroot00000000000000(** This interface compares float-like objects with a small tolerance. For example [=.] returns true if the floats are almost but not quite equal, and [>.] returns false if the floats are almost equal. The tolerance is intended to be about right for human-entered values like prices and seconds. *) module type S = sig type t val ( >=. ) : t -> t -> bool val ( <=. ) : t -> t -> bool val ( =. ) : t -> t -> bool val ( >. ) : t -> t -> bool val ( <. ) : t -> t -> bool val ( <>. ) : t -> t -> bool val robustly_compare : t -> t -> int end core-0.15.0/core/src/runtime.js000066400000000000000000000065421420273305200162720ustar00rootroot00000000000000///////// CORE //Provides: core_array_unsafe_int_blit //Requires: caml_array_blit var core_array_unsafe_int_blit = caml_array_blit //Provides: core_array_unsafe_float_blit //Requires: caml_array_blit var core_array_unsafe_float_blit = caml_array_blit //Provides: core_time_ns_format //Requires: caml_jsbytes_of_string, caml_string_of_jsbytes function core_time_ns_format(time,format){ var d = new Date(time * 1000); var formatjs = caml_jsbytes_of_string(format); var jstring = joo_global_object.strftime(formatjs, d); return caml_string_of_jsbytes(jstring); } //Provides: core_gc_compactions function core_gc_compactions () { return 0 } //Provides: core_gc_heap_chunks function core_gc_heap_chunks () { return 0 } //Provides: core_gc_heap_words function core_gc_heap_words () { return 0 } //Provides: core_gc_major_collections function core_gc_major_collections () { return 0 } //Provides: core_gc_major_plus_minor_words function core_gc_major_plus_minor_words () { return 0 } //Provides: core_gc_major_words function core_gc_major_words () { return 0 } //Provides: core_gc_minor_collections function core_gc_minor_collections () { return 0 } //Provides: core_gc_minor_words function core_gc_minor_words () { return 0 } //Provides: core_gc_promoted_words function core_gc_promoted_words () { return 0 } //Provides: core_gc_top_heap_words function core_gc_top_heap_words () { return 0 } //Provides: core_gc_run_memprof_callbacks function core_gc_run_memprof_callbacks () { return 0 } //Provides: core_heap_block_is_heap_block function core_heap_block_is_heap_block(x){ return +(x instanceof Array); } //Provides: core_md5_fd //Requires: caml_ml_open_descriptor_in, caml_md5_chan, caml_ml_close_channel function core_md5_fd(fd){ var ic = caml_ml_open_descriptor_in(fd); try { return caml_md5_chan(ic, -1); } finally { caml_ml_close_channel(ic); } } //Provides: core_md5_digest_subbigstring //Requires: caml_md5_string, caml_blit_string, caml_create_bytes //Requires: bigstring_blit_bigstring_bytes_stub, caml_string_of_bytes function core_md5_digest_subbigstring(buf, ofs, len, res){ var bytes = caml_create_bytes(len); bigstring_blit_bigstring_bytes_stub(buf, ofs, bytes, 0, len); var res2 = caml_md5_string(caml_string_of_bytes(bytes), 0, len); caml_blit_string(res2, 0, res, 0, 16); return 0; } //Bigstring //Provides: bigstring_destroy_stub //Requires: caml_invalid_argument function bigstring_destroy_stub(v_bstr) { if (v_bstr.hasOwnProperty('__is_deallocated')) { caml_invalid_argument("bigstring_destroy: bigstring is already deallocated"); } // Mutate the original bigstring in-place, to simulate what the C version does v_bstr.__is_deallocated = true; v_bstr.data = new v_bstr.data.__proto__.constructor(0); v_bstr.dims = [ 0 ]; return 0; } //Provides: bigstring_realloc //Requires: caml_invalid_argument, caml_ba_create_unsafe, bigstring_destroy_stub function bigstring_realloc(bigstring, size) { if (bigstring.hasOwnProperty('__is_deallocated')) { caml_invalid_argument("bigstring_realloc: bigstring is already deallocated"); } var new_data = new bigstring.data.__proto__.constructor(size); new_data.set(bigstring.data.slice(0, size)); var new_bigstring = caml_ba_create_unsafe(bigstring.kind, bigstring.layout, [size], new_data); bigstring_destroy_stub(bigstring); return new_bigstring; } core-0.15.0/core/src/sequence.ml000066400000000000000000000034761420273305200164160ustar00rootroot00000000000000open! Import include Base.Sequence include Bin_prot.Utils.Make_binable1_without_uuid [@alert "-legacy"] (struct module Binable = struct type 'a t = 'a list [@@deriving bin_io] end type 'a t = 'a Base.Sequence.t let of_binable = Base.Sequence.of_list let to_binable = Base.Sequence.to_list end) module Step = struct include Step type ('a, 's) t = ('a, 's) Step.t = | Done | Skip of 's | Yield of 'a * 's [@@deriving bin_io] end module Merge_with_duplicates_element = struct include Merge_with_duplicates_element type ('a, 'b) t = ('a, 'b) Merge_with_duplicates_element.t = | Left of 'a | Right of 'b | Both of 'a * 'b [@@deriving bin_io] end module type Heap = sig type 'a t val create : compare:('a -> 'a -> int) -> 'a t val add : 'a t -> 'a -> 'a t val pop_min : 'a t -> ('a * 'a t) option end let merge_all (module Heap : Heap) seqs ~compare = let module Merge_all_state = struct type 'a t = { heap : ('a * 'a Base.Sequence.t) Heap.t ; not_yet_in_heap : 'a Base.Sequence.t list } [@@deriving fields] let create = Fields.create end in unfold_step ~init: (Merge_all_state.create ~heap:(Heap.create ~compare:(Base.Comparable.lift compare ~f:fst)) ~not_yet_in_heap:seqs) ~f:(fun { heap; not_yet_in_heap } -> match not_yet_in_heap with | seq :: not_yet_in_heap -> (match Expert.next_step seq with | Done -> Skip { not_yet_in_heap; heap } | Skip seq -> Skip { not_yet_in_heap = seq :: not_yet_in_heap; heap } | Yield (elt, seq) -> Skip { not_yet_in_heap; heap = Heap.add heap (elt, seq) }) | [] -> (match Heap.pop_min heap with | None -> Done | Some ((elt, seq), heap) -> Yield (elt, { heap; not_yet_in_heap = [ seq ] }))) ;; core-0.15.0/core/src/sequence.mli000066400000000000000000000030441420273305200165560ustar00rootroot00000000000000(** This module extends {{!Base.Sequence}[Base.Sequence]} with bin_io. *) type 'a t = 'a Base.Sequence.t [@@deriving bin_io] module Step : sig type ('a, 's) t = ('a, 's) Base.Sequence.Step.t = | Done | Skip of 's | Yield of 'a * 's [@@deriving bin_io] include module type of struct include Base.Sequence.Step end with type ('a, 's) t := ('a, 's) t end module Merge_with_duplicates_element : sig type ('a, 'b) t = ('a, 'b) Base.Sequence.Merge_with_duplicates_element.t = | Left of 'a | Right of 'b | Both of 'a * 'b [@@deriving bin_io] include module type of struct include Base.Sequence.Merge_with_duplicates_element end with type ('a, 'b) t := ('a, 'b) t end (** @inline *) include module type of struct include Base.Sequence end with type 'a t := 'a Base.Sequence.t and module Step := Base.Sequence.Step and module Merge_with_duplicates_element := Base.Sequence.Merge_with_duplicates_element module type Heap = sig type 'a t val create : compare:('a -> 'a -> int) -> 'a t val add : 'a t -> 'a -> 'a t val pop_min : 'a t -> ('a * 'a t) option end (** Merges elements from sequences that are assumed to be sorted by [compare] to produce a sequence also sorted by [compare]. If any of the inputs are not sorted, the order of the output is not guaranteed to be sorted. This includes duplicate elements in the output (whether they occur within one input sequence, or across different input sequences). *) val merge_all : (module Heap) -> 'a t list -> compare:('a -> 'a -> int) -> 'a t core-0.15.0/core/src/set.ml000066400000000000000000000427361420273305200154030ustar00rootroot00000000000000open! Import module List = List0 open Set_intf module Merge_to_sequence_element = Merge_to_sequence_element module Named = Named module type Elt_plain = Elt_plain module type Elt = Elt module type Elt_binable = Elt_binable let to_comparator (type k cmp) ((module M) : (k, cmp) Comparator.Module.t) = M.comparator let of_comparator (type k cmp) comparator : (k, cmp) Comparator.Module.t = (module struct type t = k type comparator_witness = cmp let comparator = comparator end) ;; module For_quickcheck = struct let quickcheck_generator ~comparator elt_gen = Base_quickcheck.Generator.set_t_m (of_comparator comparator) elt_gen ;; let gen_tree ~comparator elt_gen = Base_quickcheck.Generator.set_tree_using_comparator ~comparator elt_gen ;; let quickcheck_observer elt_obs = Base_quickcheck.Observer.set_t elt_obs let obs_tree elt_obs = Base_quickcheck.Observer.set_tree elt_obs let quickcheck_shrinker elt_shr = Base_quickcheck.Shrinker.set_t elt_shr let shr_tree ~comparator elt_shr = Base_quickcheck.Shrinker.set_tree_using_comparator ~comparator elt_shr ;; end let quickcheck_generator m elt_gen = For_quickcheck.quickcheck_generator ~comparator:(to_comparator m) elt_gen ;; let quickcheck_observer = For_quickcheck.quickcheck_observer let quickcheck_shrinker = For_quickcheck.quickcheck_shrinker module Tree = struct include Tree let to_map ~comparator t = Map.of_key_set (Set.Using_comparator.of_tree t ~comparator) let of_map_keys m = Set.Using_comparator.to_tree (Map.key_set m) let of_hash_set ~comparator hset = Hash_set.fold hset ~init:(empty ~comparator) ~f:(fun t x -> add t x ~comparator) ;; let of_hashtbl_keys ~comparator hashtbl = Hashtbl.fold hashtbl ~init:(empty ~comparator) ~f:(fun ~key:x ~data:_ t -> add t x ~comparator) ;; let quickcheck_generator = For_quickcheck.gen_tree let quickcheck_observer = For_quickcheck.obs_tree let quickcheck_shrinker = For_quickcheck.shr_tree end module Accessors = struct include ( Set.Using_comparator : Set.Accessors2 with type ('a, 'b) t := ('a, 'b) Set.t with type ('a, 'b) tree := ('a, 'b) Tree.t with type ('a, 'b) named := ('a, 'b) Set.Named.t) let to_map = Map.of_key_set let quickcheck_observer = quickcheck_observer let quickcheck_shrinker = quickcheck_shrinker end type 'a cmp = 'a type 'a elt = 'a include ( struct include Set let of_tree m = Set.Using_comparator.of_tree ~comparator:(to_comparator m) let to_tree = Set.Using_comparator.to_tree let sexp_of_t = Set.Using_comparator.sexp_of_t end : sig type ('a, 'b) t = ('a, 'b) Set.t [@@deriving sexp_of] include Set.Creators_generic with type ('a, 'b, 'c) options := ('a, 'b, 'c) Set.With_first_class_module.t with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) set := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) Tree.t with type 'a cmp := 'a cmp with type 'a elt := 'a elt include Set.Accessors2 with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) Tree.t with type ('a, 'b) named := ('a, 'b) Set.Named.t with module Named := Named end) type ('k, 'cmp) comparator = (module Comparator.S with type t = 'k and type comparator_witness = 'cmp) let compare _ _ t1 t2 = compare_direct t1 t2 module Using_comparator = struct include ( Set.Using_comparator : module type of struct include Set.Using_comparator end with module Tree := Set.Using_comparator.Tree) include For_quickcheck let of_map_keys = Map.key_set let of_hash_set ~comparator hset = of_tree ~comparator (Tree.of_hash_set hset ~comparator) ;; let of_hashtbl_keys ~comparator hashtbl = of_tree ~comparator (Tree.of_hashtbl_keys hashtbl ~comparator) ;; end let to_map = Map.of_key_set let of_map_keys = Map.key_set let hash_fold_direct = Using_comparator.hash_fold_direct let comparator = Using_comparator.comparator let of_hash_set m hset = Using_comparator.of_hash_set ~comparator:(to_comparator m) hset let of_hashtbl_keys m hashtbl = Using_comparator.of_hashtbl_keys ~comparator:(to_comparator m) hashtbl ;; module Creators (Elt : Comparator.S1) : sig type nonrec ('a, 'comparator) t_ = ('a Elt.t, Elt.comparator_witness) t type ('a, 'b) tree = ('a, Elt.comparator_witness) Tree.t type 'a elt_ = 'a Elt.t type 'a cmp_ = Elt.comparator_witness val t_of_sexp : (Base.Sexp.t -> 'a Elt.t) -> Base.Sexp.t -> ('a, 'comparator) t_ include Creators_generic with type ('a, 'b) t := ('a, 'b) t_ with type ('a, 'b) set := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) tree with type 'a elt := 'a elt_ with type ('a, 'b, 'c) options := ('a, 'b, 'c) Without_comparator.t with type 'a cmp := 'a cmp_ end = struct open Using_comparator type nonrec ('a, 'comparator) t_ = ('a Elt.t, Elt.comparator_witness) t type ('a, 'b) tree = ('a, Elt.comparator_witness) Tree.t type 'a elt_ = 'a Elt.t type 'cmp cmp_ = Elt.comparator_witness let comparator = Elt.comparator let of_tree tree = of_tree ~comparator tree let of_sorted_array_unchecked array = of_sorted_array_unchecked ~comparator array let of_increasing_iterator_unchecked ~len ~f = of_increasing_iterator_unchecked ~comparator ~len ~f ;; let of_sorted_array array = of_sorted_array ~comparator array module M_empty = Empty_without_value_restriction (Elt) let empty = M_empty.empty let singleton e = singleton ~comparator e let union_list l = union_list ~comparator l let of_list l = of_list ~comparator l let of_sequence s = of_sequence ~comparator s let of_hash_set h = of_hash_set ~comparator h let of_hashtbl_keys h = of_hashtbl_keys ~comparator h let of_array a = of_array ~comparator a let stable_dedup_list xs = stable_dedup_list ~comparator xs let map t ~f = map ~comparator t ~f let filter_map t ~f = filter_map ~comparator t ~f let t_of_sexp a_of_sexp sexp = of_tree (Tree.t_of_sexp_direct a_of_sexp sexp ~comparator) ;; let of_map_keys = Map.key_set let quickcheck_generator elt = quickcheck_generator ~comparator elt end module Make_tree_S1 (Elt : Comparator.S1) = struct let comparator = Elt.comparator let empty = Tree.empty_without_value_restriction let singleton e = Tree.singleton ~comparator e let invariants t = Tree.invariants t ~comparator let length t = Tree.length t let is_empty t = Tree.is_empty t let elements t = Tree.elements t let min_elt t = Tree.min_elt t let min_elt_exn t = Tree.min_elt_exn t let max_elt t = Tree.max_elt t let max_elt_exn t = Tree.max_elt_exn t let choose t = Tree.choose t let choose_exn t = Tree.choose_exn t let to_list t = Tree.to_list t let to_array t = Tree.to_array t let iter t ~f = Tree.iter t ~f let iter2 a b ~f = Tree.iter2 a b ~f ~comparator let exists t ~f = Tree.exists t ~f let for_all t ~f = Tree.for_all t ~f let count t ~f = Tree.count t ~f let sum m t ~f = Tree.sum m t ~f let find t ~f = Tree.find t ~f let find_exn t ~f = Tree.find_exn t ~f let find_map t ~f = Tree.find_map t ~f let fold t ~init ~f = Tree.fold t ~init ~f let fold_until t ~init ~f = Tree.fold_until t ~init ~f let fold_right t ~init ~f = Tree.fold_right t ~init ~f let fold_result t ~init ~f = Container.fold_result ~fold ~init ~f t let map t ~f = Tree.map t ~f ~comparator let filter t ~f = Tree.filter t ~f ~comparator let filter_map t ~f = Tree.filter_map t ~f ~comparator let partition_tf t ~f = Tree.partition_tf t ~f ~comparator let mem t a = Tree.mem t a ~comparator let add t a = Tree.add t a ~comparator let remove t a = Tree.remove t a ~comparator let union t1 t2 = Tree.union t1 t2 ~comparator let inter t1 t2 = Tree.inter t1 t2 ~comparator let diff t1 t2 = Tree.diff t1 t2 ~comparator let symmetric_diff t1 t2 = Tree.symmetric_diff t1 t2 ~comparator let compare_direct t1 t2 = Tree.compare_direct ~comparator t1 t2 let equal t1 t2 = Tree.equal t1 t2 ~comparator let is_subset t ~of_ = Tree.is_subset t ~of_ ~comparator let are_disjoint t1 t2 = Tree.are_disjoint t1 t2 ~comparator let of_list l = Tree.of_list l ~comparator let of_sequence s = Tree.of_sequence s ~comparator let of_hash_set h = Tree.of_hash_set h ~comparator let of_hashtbl_keys h = Tree.of_hashtbl_keys h ~comparator let of_array a = Tree.of_array a ~comparator let of_sorted_array_unchecked a = Tree.of_sorted_array_unchecked a ~comparator let of_increasing_iterator_unchecked ~len ~f = Tree.of_increasing_iterator_unchecked ~len ~f ~comparator ;; let of_sorted_array a = Tree.of_sorted_array a ~comparator let union_list l = Tree.union_list l ~comparator let stable_dedup_list xs = Tree.stable_dedup_list xs ~comparator let group_by t ~equiv = Tree.group_by t ~equiv ~comparator let split t a = Tree.split t a ~comparator let nth t i = Tree.nth t i let remove_index t i = Tree.remove_index t i ~comparator let to_tree t = t let of_tree t = t let to_sequence ?order ?greater_or_equal_to ?less_or_equal_to t = Tree.to_sequence ~comparator ?order ?greater_or_equal_to ?less_or_equal_to t ;; let binary_search t ~compare how v = Tree.binary_search ~comparator t ~compare how v let binary_search_segmented t ~segment_of how = Tree.binary_search_segmented ~comparator t ~segment_of how ;; let merge_to_sequence ?order ?greater_or_equal_to ?less_or_equal_to t t' = Tree.merge_to_sequence ~comparator ?order ?greater_or_equal_to ?less_or_equal_to t t' ;; let of_map_keys = Tree.of_map_keys let to_map t ~f = Tree.to_map ~comparator t ~f module Named = struct let is_subset t ~of_ = Tree.Named.is_subset t ~of_ ~comparator let equal t1 t2 = Tree.Named.equal t1 t2 ~comparator end let quickcheck_generator elt = For_quickcheck.gen_tree elt ~comparator let quickcheck_observer elt = For_quickcheck.obs_tree elt let quickcheck_shrinker elt = For_quickcheck.shr_tree elt ~comparator end module Make_tree_plain (Elt : sig type t [@@deriving sexp_of] include Comparator.S with type t := t end) = struct module Elt_S1 = Comparator.S_to_S1 (Elt) include Make_tree_S1 (Elt_S1) type t = (Elt.t, Elt.comparator_witness) Tree.t type named = (Elt.t, Elt.comparator_witness) Tree.Named.t let compare t1 t2 = compare_direct t1 t2 let sexp_of_t t = Tree.sexp_of_t Elt.sexp_of_t [%sexp_of: _] t module Provide_of_sexp (X : sig type t [@@deriving of_sexp] end with type t := Elt.t) = struct let t_of_sexp sexp = Tree.t_of_sexp_direct X.t_of_sexp sexp ~comparator:Elt_S1.comparator ;; end end module Make_tree (Elt : sig type t [@@deriving sexp] include Comparator.S with type t := t end) = struct include Make_tree_plain (Elt) include Provide_of_sexp (Elt) end (* Don't use [of_sorted_array] to avoid the allocation of an intermediate array *) let init_for_bin_prot ~len ~f ~comparator = let set = Using_comparator.of_increasing_iterator_unchecked ~comparator ~len ~f in if invariants set then set else Using_comparator.of_tree ~comparator (fold set ~init:(Tree.empty ~comparator) ~f:(fun acc elt -> if Tree.mem acc elt ~comparator then failwith "Set.bin_read_t: duplicate element in map" else Tree.add acc elt ~comparator)) ;; module Poly = struct module Elt = Comparator.Poly include Creators (Elt) type nonrec 'a t = ('a, Elt.comparator_witness) t type 'a named = ('a, Elt.comparator_witness) Named.t include Accessors let compare _ t1 t2 = compare_direct t1 t2 let sexp_of_t sexp_of_k t = sexp_of_t sexp_of_k [%sexp_of: _] t let t_sexp_grammar elt_grammar = Sexplib.Sexp_grammar.coerce (List.t_sexp_grammar elt_grammar) ;; include Bin_prot.Utils.Make_iterable_binable1 (struct type nonrec 'a t = 'a t type 'a el = 'a [@@deriving bin_io] let _ = bin_el let caller_identity = Bin_prot.Shape.Uuid.of_string "88bcc478-4992-11e6-a95d-ff4831acf410" ;; let module_name = Some "Core.Set" let length = length let iter t ~f = iter ~f:(fun key -> f key) t let init ~len ~next = init_for_bin_prot ~len ~f:(fun _ -> next ()) ~comparator:Comparator.Poly.comparator ;; end) module Tree = struct include Make_tree_S1 (Comparator.Poly) type 'elt t = ('elt, Comparator.Poly.comparator_witness) tree type 'a named = ('a, Elt.comparator_witness) Tree.Named.t let sexp_of_t sexp_of_elt t = Tree.sexp_of_t sexp_of_elt [%sexp_of: _] t let t_of_sexp elt_of_sexp sexp = Tree.t_of_sexp_direct elt_of_sexp sexp ~comparator:Comparator.Poly.comparator ;; let t_sexp_grammar grammar = Sexplib.Sexp_grammar.coerce (List.t_sexp_grammar grammar) end end module type S_plain = S_plain module type S = S module type S_binable = S_binable module Elt_bin_io = Elt_bin_io module Provide_bin_io (Elt : Elt_bin_io.S) = Bin_prot.Utils.Make_iterable_binable (struct type nonrec t = (Elt.t, Elt.comparator_witness) t type el = Elt.t [@@deriving bin_io] let _ = bin_el let caller_identity = Bin_prot.Shape.Uuid.of_string "8989278e-4992-11e6-8f4a-6b89776b1e53" ;; let module_name = Some "Core.Set" let length = length let iter t ~f = iter ~f:(fun key -> f key) t let init ~len ~next = init_for_bin_prot ~len ~f:(fun _ -> next ()) ~comparator:Elt.comparator ;; end) module Make_plain_using_comparator (Elt : sig type t [@@deriving sexp_of] include Comparator.S with type t := t end) = struct module Elt = Elt module Elt_S1 = Comparator.S_to_S1 (Elt) include Creators (Elt_S1) type ('a, 'b) set = ('a, 'b) t type t = (Elt.t, Elt.comparator_witness) set type named = (Elt.t, Elt.comparator_witness) Named.t include Accessors let compare t1 t2 = compare_direct t1 t2 let sexp_of_t t = sexp_of_t Elt.sexp_of_t [%sexp_of: _] t module Provide_of_sexp (Elt : sig type t [@@deriving of_sexp] end with type t := Elt.t) = struct let t_of_sexp sexp = t_of_sexp Elt.t_of_sexp sexp end module Provide_hash (Elt : Hasher.S with type t := Elt.t) = struct let hash_fold_t state t = Using_comparator.hash_fold_direct Elt.hash_fold_t state t let hash t = Ppx_hash_lib.Std.Hash.get_hash_value (hash_fold_t (Ppx_hash_lib.Std.Hash.create ()) t) ;; end module Provide_bin_io (Elt' : sig type t [@@deriving bin_io] end with type t := Elt.t) = Provide_bin_io (struct include Elt include Elt' end) end module Make_plain (Elt : Elt_plain) = Make_plain_using_comparator (struct include Elt include Comparator.Make (Elt) end) module Make_using_comparator (Elt_sexp : sig type t [@@deriving sexp] include Comparator.S with type t := t end) = struct include Make_plain_using_comparator (Elt_sexp) module Elt = Elt_sexp include Provide_of_sexp (Elt) end module Make (Elt : Elt) = Make_using_comparator (struct include Elt include Comparator.Make (Elt) end) module Make_binable_using_comparator (Elt_bin_sexp : sig type t [@@deriving bin_io, sexp] include Comparator.S with type t := t end) = struct include Make_using_comparator (Elt_bin_sexp) module Elt = Elt_bin_sexp include Provide_bin_io (Elt) end module Make_binable (Elt : Elt_binable) = Make_binable_using_comparator (struct include Elt include Comparator.Make (Elt) end) module For_deriving = struct module M = Set.M let bin_shape_m__t (type t c) (m : (t, c) Elt_bin_io.t) = let module M = Provide_bin_io ((val m)) in M.bin_shape_t ;; let bin_size_m__t (type t c) (m : (t, c) Elt_bin_io.t) = let module M = Provide_bin_io ((val m)) in M.bin_size_t ;; let bin_write_m__t (type t c) (m : (t, c) Elt_bin_io.t) = let module M = Provide_bin_io ((val m)) in M.bin_write_t ;; let bin_read_m__t (type t c) (m : (t, c) Elt_bin_io.t) = let module M = Provide_bin_io ((val m)) in M.bin_read_t ;; let __bin_read_m__t__ (type t c) (m : (t, c) Elt_bin_io.t) = let module M = Provide_bin_io ((val m)) in M.__bin_read_t__ ;; module type Quickcheck_generator_m = sig include Comparator.S val quickcheck_generator : t Quickcheck.Generator.t end module type Quickcheck_observer_m = sig include Comparator.S val quickcheck_observer : t Quickcheck.Observer.t end module type Quickcheck_shrinker_m = sig include Comparator.S val quickcheck_shrinker : t Quickcheck.Shrinker.t end let quickcheck_generator_m__t (type t cmp) (module Elt : Quickcheck_generator_m with type t = t and type comparator_witness = cmp) = quickcheck_generator (module Elt) Elt.quickcheck_generator ;; let quickcheck_observer_m__t (type t cmp) (module Elt : Quickcheck_observer_m with type t = t and type comparator_witness = cmp) = quickcheck_observer Elt.quickcheck_observer ;; let quickcheck_shrinker_m__t (type t cmp) (module Elt : Quickcheck_shrinker_m with type t = t and type comparator_witness = cmp) = quickcheck_shrinker Elt.quickcheck_shrinker ;; module type For_deriving = Set.For_deriving include (Set : For_deriving with type ('a, 'b) t := ('a, 'b) t) end include For_deriving module Stable = struct module V1 = struct type nonrec ('a, 'cmp) t = ('a, 'cmp) t module type S = sig type elt type elt_comparator_witness type nonrec t = (elt, elt_comparator_witness) t include Stable_module_types.S0_without_comparator with type t := t end include For_deriving module Make (Elt : Stable_module_types.S0) = Make_binable_using_comparator (Elt) end end core-0.15.0/core/src/set.mli000066400000000000000000000534041420273305200155460ustar00rootroot00000000000000(** This module defines the [Set] module for [Core]. Functions that construct a set take as an argument the comparator for the element type. This module uses the same organizational approach as {{!Map}[Map]}. *) open! Import open Set_intf (** The type of a set. The first type parameter identifies the type of the element, and the second identifies the comparator, which determines the comparison function that is used for ordering elements in this set. Many operations (e.g., {!union}), require that they be passed sets with the same element type and the same comparator type. *) type ('elt, 'cmp) t = ('elt, 'cmp) Base.Set.t [@@deriving compare] type ('k, 'cmp) comparator = (module Comparator.S with type t = 'k and type comparator_witness = 'cmp) module Tree : sig (** A [Tree.t] contains just the tree data structure that a set is based on, without including the comparator. Accordingly, any operation on a [Tree.t] must also take as an argument the corresponding comparator. *) type ('elt, 'cmp) t = ('elt, 'cmp) Tree.t [@@deriving sexp_of] module Named = Tree.Named include Creators_and_accessors2_with_comparator with type ('a, 'b) set := ('a, 'b) t with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) t with type ('a, 'b) named := ('a, 'b) Named.t with module Named := Named end module Using_comparator : sig include Creators2_with_comparator with type ('a, 'b) set := ('a, 'b) t with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) Tree.t end (** Tests internal invariants of the set data structure. Returns true on success. *) val invariants : (_, _) t -> bool val comparator : ('a, 'cmp) t -> ('a, 'cmp) Comparator.t (** Creates an empty set based on the provided comparator. *) val empty : ('a, 'cmp) comparator -> ('a, 'cmp) t (** Creates a set based on the provided comparator that contains only the provided element. *) val singleton : ('a, 'cmp) comparator -> 'a -> ('a, 'cmp) t (** Returns the cardinality of the set. [O(1)]. *) val length : (_, _) t -> int (** [is_empty t] is [true] iff [t] is empty. [O(1)]. *) val is_empty : (_, _) t -> bool (** [mem t a] returns [true] iff [a] is in [t]. [O(log n)]. *) val mem : ('a, _) t -> 'a -> bool (** [add t a] returns a new set with [a] added to [t], or returns [t] if [mem t a]. [O(log n)]. *) val add : ('a, 'cmp) t -> 'a -> ('a, 'cmp) t (** [remove t a] returns a new set with [a] removed from [t] if [mem t a], or returns [t] otherwise. [O(log n)]. *) val remove : ('a, 'cmp) t -> 'a -> ('a, 'cmp) t (** [union t1 t2] returns the union of the two sets. [O(length t1 + length t2)]. *) val union : ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t (** [union c list] returns the union of all the sets in [list]. The [c] argument is required for the case where [list] is empty. [O(max(List.length list, n log n))], where [n] is the sum of sizes of the input sets. *) val union_list : ('a, 'cmp) comparator -> ('a, 'cmp) t list -> ('a, 'cmp) t (** [inter t1 t2] computes the intersection of sets [t1] and [t2]. [O(length t1 + length t2)]. *) val inter : ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t (** [diff t1 t2] computes the set difference [t1 - t2], i.e., the set containing all elements in [t1] that are not in [t2]. [O(length t1 + length t2)]. *) val diff : ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t (** [symmetric_diff t1 t2] returns a sequence of changes between [t1] and [t2]. It is intended to be efficient in the case where [t1] and [t2] share a large amount of structure. In the case where [t2] (resp. [t1]) is obtained by applying k additions and/or removals to [t1] (resp. [t2]), this runs in [min(O(k log n), O(n))], where [n] is [length t1 + length t2]. *) val symmetric_diff : ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'a) Either.t Sequence.t (** [compare_direct t1 t2] compares the sets [t1] and [t2]. It returns the same result as [compare], but unlike compare, doesn't require arguments to be passed in for the type parameters of the set. [O(length t1 + length t2)]. *) val compare_direct : ('a, 'cmp) t -> ('a, 'cmp) t -> int (** Hash function: a building block to use when hashing data structures containing sets in them. [hash_fold_direct hash_fold_key] is compatible with [compare_direct] iff [hash_fold_key] is compatible with [(comparator s).compare] of the set [s] being hashed. *) val hash_fold_direct : 'a Hash.folder -> ('a, 'cmp) t Hash.folder (** [equal t1 t2] returns [true] iff the two sets have the same elements. [O(length t1 + length t2)] *) val equal : ('a, 'cmp) t -> ('a, 'cmp) t -> bool (** [exists t ~f] returns [true] iff there exists an [a] in [t] for which [f a]. [O(n)], but returns as soon as it finds an [a] for which [f a]. *) val exists : ('a, _) t -> f:('a -> bool) -> bool (** [for_all t ~f] returns [true] iff for all [a] in [t], [f a]. [O(n)], but returns as soon as it finds an [a] for which [not (f a)]. *) val for_all : ('a, _) t -> f:('a -> bool) -> bool (** [count t] returns the number of elements of [t] for which [f] returns [true]. [O(n)]. *) val count : ('a, _) t -> f:('a -> bool) -> int (** [sum t] returns the sum of [f t] for each [t] in the set. [O(n)]. *) val sum : (module Container.Summable with type t = 'sum) -> ('a, _) t -> f:('a -> 'sum) -> 'sum (** [find t f] returns an element of [t] for which [f] returns true, with no guarantee as to which element is returned. [O(n)], but returns as soon as a suitable element is found. *) val find : ('a, _) t -> f:('a -> bool) -> 'a option (** [find_map t f] returns [b] for some [a] in [t] for which [f a = Some b]. If no such [a] exists, then [find] returns [None]. [O(n)], but returns as soon as a suitable element is found. *) val find_map : ('a, _) t -> f:('a -> 'b option) -> 'b option (** Like [find], but throws an exception on failure. *) val find_exn : ('a, _) t -> f:('a -> bool) -> 'a (** [nth t i] returns the [i]th smallest element of [t], in [O(log n)] time. The smallest element has [i = 0]. Returns [None] if [i < 0] or [i >= length t]. *) val nth : ('a, _) t -> int -> 'a option (** [remove_index t i] returns a version of [t] with the [i]th smallest element removed, in [O(log n)] time. The smallest element has [i = 0]. Returns [t] if [i < 0] or [i >= length t]. *) val remove_index : ('a, 'cmp) t -> int -> ('a, 'cmp) t (** [is_subset t1 ~of_:t2] returns true iff [t1] is a subset of [t2]. *) val is_subset : ('a, 'cmp) t -> of_:('a, 'cmp) t -> bool (** [are_disjoint t1 t2] returns [true] iff [is_empty (inter t1 t2)], but is more efficient. *) val are_disjoint : ('a, 'cmp) t -> ('a, 'cmp) t -> bool (** [Named] allows the validation of subset and equality relationships between sets. A [Named.t] is a record of a set and a name, where the name is used in error messages, and [Named.is_subset] and [Named.equal] validate subset and equality relationships respectively. The error message for, e.g., {[ Named.is_subset { set = set1; name = "set1" } ~of_:{set = set2; name = "set2" } ]} looks like {v ("set1 is not a subset of set2" (invalid_elements (...elements of set1 - set2...))) v} so [name] should be a noun phrase that doesn't sound awkward in the above error message. Even though it adds verbosity, choosing [name]s that start with the phrase "the set of" often makes the error message sound more natural. *) module Named : sig type nonrec ('a, 'cmp) t = ('a, 'cmp) Named.t = { set : ('a, 'cmp) t ; name : string } (** [is_subset t1 ~of_:t2] returns [Ok ()] if [t1] is a subset of [t2] and a human-readable error otherwise. *) val is_subset : ('a, 'cmp) t -> of_:('a, 'cmp) t -> unit Or_error.t (** [equal t1 t2] returns [Ok ()] if [t1] is equal to [t2] and a human-readable error otherwise. *) val equal : ('a, 'cmp) t -> ('a, 'cmp) t -> unit Or_error.t end (** The list or array given to [of_list] and [of_array] need not be sorted. *) val of_list : ('a, 'cmp) comparator -> 'a list -> ('a, 'cmp) t val of_sequence : ('a, 'cmp) comparator -> 'a Sequence.t -> ('a, 'cmp) t val of_array : ('a, 'cmp) comparator -> 'a array -> ('a, 'cmp) t val of_hash_set : ('a, 'cmp) comparator -> 'a Hash_set.t -> ('a, 'cmp) t val of_hashtbl_keys : ('a, 'cmp) comparator -> ('a, _) Hashtbl.t -> ('a, 'cmp) t (** [to_list] and [to_array] produce sequences sorted in ascending order according to the comparator. *) val to_list : ('a, _) t -> 'a list val to_array : ('a, _) t -> 'a array val to_tree : ('a, 'cmp) t -> ('a, 'cmp) Tree.t val of_tree : ('a, 'cmp) comparator -> ('a, 'cmp) Tree.t -> ('a, 'cmp) t (** Create set from sorted array. The input must be sorted (either in ascending or descending order as given by the comparator) and contain no duplicates, otherwise the result is an error. The complexity of this function is [O(n)]. *) val of_sorted_array : ('a, 'cmp) comparator -> 'a array -> ('a, 'cmp) t Or_error.t (** Similar to [of_sorted_array], but without checking the input array. *) val of_sorted_array_unchecked : ('a, 'cmp) comparator -> 'a array -> ('a, 'cmp) t (** [of_increasing_iterator_unchecked c ~len ~f] behaves like [of_sorted_array_unchecked c (Array.init len ~f)], with the additional restriction that a decreasing order is not supported. The advantage is not requiring you to allocate an intermediate array. [f] will be called with 0, 1, ... [len - 1], in order. *) val of_increasing_iterator_unchecked : ('a, 'cmp) comparator -> len:int -> f:(int -> 'a) -> ('a, 'cmp) t (** [stable_dedup_list] is here rather than in the [List] module because the implementation relies crucially on sets, and because doing so allows one to avoid uses of polymorphic comparison by instantiating the functor at a different implementation of [Comparator] and using the resulting [stable_dedup_list]. *) val stable_dedup_list : ('a, _) comparator -> 'a list -> 'a list (** [map c t ~f] returns a new set created by applying [f] to every element in [t]. The returned set is based on the provided [c]. [O(n log n)]. *) val map : ('b, 'cmp) comparator -> ('a, _) t -> f:('a -> 'b) -> ('b, 'cmp) t (** Like {!map}, except elements for which [f] returns [None] will be dropped. *) val filter_map : ('b, 'cmp) comparator -> ('a, _) t -> f:('a -> 'b option) -> ('b, 'cmp) t (** [filter t ~f] returns the subset of [t] for which [f] evaluates to true. [O(n log n)]. *) val filter : ('a, 'cmp) t -> f:('a -> bool) -> ('a, 'cmp) t (** [fold t ~init ~f] folds over the elements of the set from smallest to largest. *) val fold : ('a, _) t -> init:'accum -> f:('accum -> 'a -> 'accum) -> 'accum (** [fold_result ~init ~f] folds over the elements of the set from smallest to largest, short circuiting the fold if [f accum x] is an [Error _] *) val fold_result : ('a, _) t -> init:'accum -> f:('accum -> 'a -> ('accum, 'e) Result.t) -> ('accum, 'e) Result.t (** [fold_until t ~init ~f] is a short-circuiting version of [fold]. If [f] returns [Stop _] the computation ceases and results in that value. If [f] returns [Continue _], the fold will proceed. *) val fold_until : ('a, _) t -> init:'accum -> f:('accum -> 'a -> ('accum, 'final) Continue_or_stop.t) -> finish:('accum -> 'final) -> 'final (** Like {!fold}, except that it goes from the largest to the smallest element. *) val fold_right : ('a, _) t -> init:'accum -> f:('a -> 'accum -> 'accum) -> 'accum (** [iter t ~f] calls [f] on every element of [t], going in order from the smallest to largest. *) val iter : ('a, _) t -> f:('a -> unit) -> unit (** Iterate two sets side by side. Complexity is [O(m+n)] where [m] and [n] are the sizes of the two input sets. As an example, with the inputs [0; 1] and [1; 2], [f] will be called with [`Left 0]; [`Both (1, 1)]; and [`Right 2]. *) val iter2 : ('a, 'cmp) t -> ('a, 'cmp) t -> f:([ `Left of 'a | `Right of 'a | `Both of 'a * 'a ] -> unit) -> unit (** If [a, b = partition_tf set ~f] then [a] is the elements on which [f] produced [true], and [b] is the elements on which [f] produces [false]. *) val partition_tf : ('a, 'cmp) t -> f:('a -> bool) -> ('a, 'cmp) t * ('a, 'cmp) t (** Same as {!to_list}. *) val elements : ('a, _) t -> 'a list (** Returns the smallest element of the set. [O(log n)]. *) val min_elt : ('a, _) t -> 'a option (** Like {!min_elt}, but throws an exception when given an empty set. *) val min_elt_exn : ('a, _) t -> 'a (** Returns the largest element of the set. [O(log n)]. *) val max_elt : ('a, _) t -> 'a option (** Like {!max_elt}, but throws an exception when given an empty set. *) val max_elt_exn : ('a, _) t -> 'a (** returns an arbitrary element, or [None] if the set is empty. *) val choose : ('a, _) t -> 'a option (** Like {!choose}, but throws an exception on an empty set. *) val choose_exn : ('a, _) t -> 'a (** [split t x] produces a triple [(t1, maybe_x, t2)] where [t1] is the set of elements strictly less than [x], [maybe_x] is the member (if any) of [t] which compares equal to [x], and [t2] is the set of elements strictly larger than [x]. *) val split : ('a, 'cmp) t -> 'a -> ('a, 'cmp) t * 'a option * ('a, 'cmp) t (** If [equiv] is an equivalence predicate, then [group_by set ~equiv] produces a list of equivalence classes (i.e., a set-theoretic quotient). E.g., {[ let chars = Set.of_list ['A'; 'a'; 'b'; 'c'] in let equiv c c' = Char.equal (Char.uppercase c) (Char.uppercase c') in group_by chars ~equiv ]} produces: {[ [Set.of_list ['A';'a']; Set.singleton 'b'; Set.singleton 'c'] ]} [group_by] runs in O(n^2) time, so if you have a comparison function, it's usually much faster to use [Set.of_list]. *) val group_by : ('a, 'cmp) t -> equiv:('a -> 'a -> bool) -> ('a, 'cmp) t list (** [to_sequence t] converts the set [t] to a sequence of the elements between [greater_or_equal_to] and [less_or_equal_to] inclusive in the order indicated by [order]. If [greater_or_equal_to > less_or_equal_to] the sequence is empty. Cost is O(log n) up front and amortized O(1) for each element produced. *) val to_sequence : ?order:[ `Increasing (** default *) | `Decreasing ] -> ?greater_or_equal_to:'a -> ?less_or_equal_to:'a -> ('a, 'cmp) t -> 'a Sequence.t (** [binary_search t ~compare which elt] returns the element in [t] specified by [compare] and [which], if one exists. [t] must be sorted in increasing order according to [compare], where [compare] and [elt] divide [t] into three (possibly empty) segments: {v | < elt | = elt | > elt | v} [binary_search] returns an element on the boundary of segments as specified by [which]. See the diagram below next to the [which] variants. [binary_search] does not check that [compare] orders [t], and behavior is unspecified if [compare] doesn't order [t]. Behavior is also unspecified if [compare] mutates [t]. *) val binary_search : ('a, 'cmp) t -> compare:('a -> 'key -> int) -> [ `Last_strictly_less_than (** {v | < elt X | v} *) | `Last_less_than_or_equal_to (** {v | <= elt X | v} *) | `Last_equal_to (** {v | = elt X | v} *) | `First_equal_to (** {v | X = elt | v} *) | `First_greater_than_or_equal_to (** {v | X >= elt | v} *) | `First_strictly_greater_than (** {v | X > elt | v} *) ] -> 'key -> 'a option (** [binary_search_segmented t ~segment_of which] takes a [segment_of] function that divides [t] into two (possibly empty) segments: {v | segment_of elt = `Left | segment_of elt = `Right | v} [binary_search_segmented] returns the element on the boundary of the segments as specified by [which]: [`Last_on_left] yields the last element of the left segment, while [`First_on_right] yields the first element of the right segment. It returns [None] if the segment is empty. [binary_search_segmented] does not check that [segment_of] segments [t] as in the diagram, and behavior is unspecified if [segment_of] doesn't segment [t]. Behavior is also unspecified if [segment_of] mutates [t]. *) val binary_search_segmented : ('a, 'cmp) t -> segment_of:('a -> [ `Left | `Right ]) -> [ `Last_on_left | `First_on_right ] -> 'a option (** Produces the elements of the two sets between [greater_or_equal_to] and [less_or_equal_to] in [order], noting whether each element appears in the left set, the right set, or both. In the both case, both elements are returned, in case the caller can distinguish between elements that are equal to the sets' comparator. Runs in O(length t + length t'). *) module Merge_to_sequence_element : sig type ('a, 'b) t = ('a, 'b) Sequence.Merge_with_duplicates_element.t = | Left of 'a | Right of 'b | Both of 'a * 'b [@@deriving bin_io, compare, sexp, sexp_grammar] end val merge_to_sequence : ?order:[ `Increasing (** default *) | `Decreasing ] -> ?greater_or_equal_to:'a -> ?less_or_equal_to:'a -> ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'a) Merge_to_sequence_element.t Sequence.t (** Convert a set to or from a map. [to_map] takes a function to produce data for each key. Both functions run in O(n) time (assuming the function passed to [to_map] runs in constant time). *) val to_map : ('key, 'cmp) t -> f:('key -> 'data) -> ('key, 'data, 'cmp) Base.Map.t val of_map_keys : ('key, _, 'cmp) Base.Map.t -> ('key, 'cmp) t val quickcheck_generator : ('key, 'cmp) comparator -> 'key Quickcheck.Generator.t -> ('key, 'cmp) t Quickcheck.Generator.t val quickcheck_observer : 'key Quickcheck.Observer.t -> ('key, 'cmp) t Quickcheck.Observer.t val quickcheck_shrinker : 'key Quickcheck.Shrinker.t -> ('key, 'cmp) t Quickcheck.Shrinker.t (** {2 Polymorphic sets} Module {!Poly} deals with sets that use OCaml's polymorphic comparison to compare elements. *) module Poly : sig type ('a, 'b) set module Tree : sig type 'elt t = ('elt, Comparator.Poly.comparator_witness) Tree.t [@@deriving sexp, sexp_grammar] type 'a named = ('a, Comparator.Poly.comparator_witness) Tree.Named.t include Creators_and_accessors1 with type ('a, 'b) set := ('a, 'b) Tree.t with type 'elt t := 'elt t with type 'elt tree := 'elt t with type 'a named := 'a named with type comparator_witness := Comparator.Poly.comparator_witness end type 'elt t = ('elt, Comparator.Poly.comparator_witness) set [@@deriving bin_io, compare, sexp, sexp_grammar] type 'a named = ('a, Comparator.Poly.comparator_witness) Named.t include Creators_and_accessors1 with type ('a, 'b) set := ('a, 'b) set with type 'elt t := 'elt t with type 'elt tree := 'elt Tree.t with type 'a named := 'a named with type comparator_witness := Comparator.Poly.comparator_witness end with type ('a, 'b) set := ('a, 'b) t (** {2 Signatures and functors for building [Set] modules} *) module type Elt_plain = Elt_plain (** The signature that something needs to match in order to be used as a set element. *) module type Elt = Elt (** The signature that something needs to match in order to be used as a set element if the resulting set is going to support [bin_io]. *) module type Elt_binable = Elt_binable (** Module signature for a Set that doesn't support [of_sexp]. *) module type S_plain = S_plain (** Module signature for a Set. *) module type S = S (** Module signature for a Set that supports [bin_io]. *) module type S_binable = S_binable (** [Make] builds a set from an element type that has a [compare] function but doesn't have a comparator. This generates a new comparator. [Make_binable] is similar, except the element and set types support [bin_io]. *) module Make_plain (Elt : Elt_plain) : S_plain with type Elt.t = Elt.t module Make (Elt : Elt) : S with type Elt.t = Elt.t module Make_binable (Elt : Elt_binable) : S_binable with type Elt.t = Elt.t module Make_plain_using_comparator (Elt : sig type t [@@deriving sexp_of] include Comparator.S with type t := t end) : S_plain with type Elt.t = Elt.t with type Elt.comparator_witness = Elt.comparator_witness (** [Make_using_comparator] builds a set from an element type that has a comparator. [Make_binable_using_comparator] is similar, except the element and set types support [bin_io]. *) module Make_using_comparator (Elt : sig type t [@@deriving sexp] include Comparator.S with type t := t end) : S with type Elt.t = Elt.t with type Elt.comparator_witness = Elt.comparator_witness module Make_binable_using_comparator (Elt : sig type t [@@deriving bin_io, sexp] include Comparator.S with type t := t end) : S_binable with type Elt.t = Elt.t with type Elt.comparator_witness = Elt.comparator_witness module Elt_bin_io = Elt_bin_io include For_deriving with type ('a, 'b) t := ('a, 'b) t module Make_tree_plain (Elt : sig type t [@@deriving sexp_of] include Comparator.S with type t := t end) : Make_S_plain_tree(Elt).S module Make_tree (Elt : sig type t [@@deriving sexp] include Comparator.S with type t := t end) : sig include Make_S_plain_tree(Elt).S include Sexpable.S with type t := t end (** The following types and functors may be used to define stable modules. *) module Stable : sig module V1 : sig type nonrec ('a, 'b) t = ('a, 'b) t module type S = sig type elt type elt_comparator_witness type nonrec t = (elt, elt_comparator_witness) t include Stable_module_types.S0_without_comparator with type t := t end include For_deriving with type ('a, 'b) t := ('a, 'b) t module Make (Elt : Stable_module_types.S0) : S with type elt := Elt.t with type elt_comparator_witness := Elt.comparator_witness end end core-0.15.0/core/src/set_intf.ml000066400000000000000000000331171420273305200164140ustar00rootroot00000000000000(** This module defines interfaces used in {{!Core.Set}[Set]}. See the {!Map} docs for a description of the design. This module defines module types [{Creators,Accessors}{0,1,2,_generic,_with_comparator}]. It uses check functors to ensure that each module type is an instance of the corresponding [_generic] one. We must treat [Creators] and [Accessors] separately, because we sometimes need to choose different instantiations of their [options]. In particular, [Set] itself matches [Creators2_with_comparator] but [Accessors2] (without comparator). *) (* CRs and comments about [Set] functions do not belong in this file. They belong next to the appropriate function in set.mli. *) open! Import open T module Binable = Binable0 module Set = Base.Set module Tree = Set.Using_comparator.Tree module Named = Set.Named module Container = Base.Container module type Elt_plain = Set.Elt_plain module type Elt = sig type t [@@deriving compare, sexp] end module type Elt_binable = sig type t [@@deriving bin_io, compare, sexp] end module Elt_bin_io = struct module type S = sig type t [@@deriving bin_io] type comparator_witness val comparator : (t, comparator_witness) Comparator.t end type ('t, 'c) t = (module S with type t = 't and type comparator_witness = 'c) end module type For_deriving = sig include Base.Set.For_deriving module M = Base.Set.M (** The following [*bin*] functions support bin-io on base-style sets, e.g.: {[ type t = Set.M(String).t [@@deriving bin_io] ]} *) val bin_shape_m__t : ('a, 'b) Elt_bin_io.t -> Bin_prot.Shape.t val bin_size_m__t : ('a, 'b) Elt_bin_io.t -> ('a, 'b) t Bin_prot.Size.sizer val bin_write_m__t : ('a, 'b) Elt_bin_io.t -> ('a, 'b) t Bin_prot.Write.writer val bin_read_m__t : ('a, 'b) Elt_bin_io.t -> ('a, 'b) t Bin_prot.Read.reader val __bin_read_m__t__ : ('a, 'b) Elt_bin_io.t -> (int -> ('a, 'b) t) Bin_prot.Read.reader (** The following [quickcheck*] functions support deriving quickcheck on base-style sets, e.g.: {[ type t = Set.M(String).t [@@deriving quickcheck] ]} *) module type Quickcheck_generator_m = sig include Comparator.S val quickcheck_generator : t Quickcheck.Generator.t end module type Quickcheck_observer_m = sig include Comparator.S val quickcheck_observer : t Quickcheck.Observer.t end module type Quickcheck_shrinker_m = sig include Comparator.S val quickcheck_shrinker : t Quickcheck.Shrinker.t end val quickcheck_generator_m__t : (module Quickcheck_generator_m with type t = 'a and type comparator_witness = 'cmp) -> ('a, 'cmp) t Quickcheck.Generator.t val quickcheck_observer_m__t : (module Quickcheck_observer_m with type t = 'a and type comparator_witness = 'cmp) -> ('a, 'cmp) t Quickcheck.Observer.t val quickcheck_shrinker_m__t : (module Quickcheck_shrinker_m with type t = 'a and type comparator_witness = 'cmp) -> ('a, 'cmp) t Quickcheck.Shrinker.t end module Without_comparator = Set.Without_comparator module With_comparator = Set.With_comparator module With_first_class_module = Set.With_first_class_module module Continue_or_stop = Container.Continue_or_stop module Merge_to_sequence_element = Sequence.Merge_with_duplicates_element module type Accessors_generic = sig include Set.Accessors_generic val to_map : ( 'a , 'cmp , ('a, 'cmp) t -> f:('a elt -> 'b) -> ('a elt, 'b, 'cmp cmp) Base.Map.t ) options val quickcheck_observer : 'a elt Quickcheck.Observer.t -> ('a, 'cmp) t Quickcheck.Observer.t val quickcheck_shrinker : ( 'a , 'cmp , 'a elt Quickcheck.Shrinker.t -> ('a, 'cmp) t Quickcheck.Shrinker.t ) options end module type Accessors0 = sig include Set.Accessors0 val to_map : t -> f:(elt -> 'data) -> (elt, 'data, comparator_witness) Base.Map.t val quickcheck_observer : elt Quickcheck.Observer.t -> t Quickcheck.Observer.t val quickcheck_shrinker : elt Quickcheck.Shrinker.t -> t Quickcheck.Shrinker.t end module type Accessors1 = sig include Set.Accessors1 val to_map : 'a t -> f:('a -> 'b) -> ('a, 'b, comparator_witness) Base.Map.t val quickcheck_observer : 'a Quickcheck.Observer.t -> 'a t Quickcheck.Observer.t val quickcheck_shrinker : 'a Quickcheck.Shrinker.t -> 'a t Quickcheck.Shrinker.t end module type Accessors2 = sig include Set.Accessors2 val to_map : ('a, 'cmp) t -> f:('a -> 'b) -> ('a, 'b, 'cmp) Base.Map.t val quickcheck_observer : 'a Quickcheck.Observer.t -> ('a, 'cmp) t Quickcheck.Observer.t val quickcheck_shrinker : 'a Quickcheck.Shrinker.t -> ('a, 'cmp) t Quickcheck.Shrinker.t end module type Accessors2_with_comparator = sig include Set.Accessors2_with_comparator val to_map : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> f:('a -> 'b) -> ('a, 'b, 'cmp) Base.Map.t val quickcheck_observer : 'a Quickcheck.Observer.t -> ('a, 'cmp) t Quickcheck.Observer.t val quickcheck_shrinker : comparator:('a, 'cmp) Comparator.t -> 'a Quickcheck.Shrinker.t -> ('a, 'cmp) t Quickcheck.Shrinker.t end (** Consistency checks (same as in [Container]). *) module Check_accessors (T : T2) (Tree : T2) (Elt : T1) (Named : T2) (Cmp : T1) (Options : T3) (_ : Accessors_generic with type ('a, 'b, 'c) options := ('a, 'b, 'c) Options.t with type ('a, 'b) t := ('a, 'b) T.t with type ('a, 'b) tree := ('a, 'b) Tree.t with type 'a elt := 'a Elt.t with type 'cmp cmp := 'cmp Cmp.t with type ('a, 'b) named := ('a, 'b) Named.t) = struct end module Check_accessors0 (M : Accessors0) = Check_accessors (struct type ('a, 'b) t = M.t end) (struct type ('a, 'b) t = M.tree end) (struct type 'a t = M.elt end) (struct type ('a, 'b) t = M.named end) (struct type 'a t = M.comparator_witness end) (Without_comparator) (M) module Check_accessors1 (M : Accessors1) = Check_accessors (struct type ('a, 'b) t = 'a M.t end) (struct type ('a, 'b) t = 'a M.tree end) (struct type 'a t = 'a end) (struct type ('a, 'b) t = 'a M.named end) (struct type 'a t = M.comparator_witness end) (Without_comparator) (M) module Check_accessors2 (M : Accessors2) = Check_accessors (struct type ('a, 'b) t = ('a, 'b) M.t end) (struct type ('a, 'b) t = ('a, 'b) M.tree end) (struct type 'a t = 'a end) (struct type ('a, 'b) t = ('a, 'b) M.named end) (struct type 'a t = 'a end) (Without_comparator) (M) module Check_accessors2_with_comparator (M : Accessors2_with_comparator) = Check_accessors (struct type ('a, 'b) t = ('a, 'b) M.t end) (struct type ('a, 'b) t = ('a, 'b) M.tree end) (struct type 'a t = 'a end) (struct type ('a, 'b) t = ('a, 'b) M.named end) (struct type 'a t = 'a end) (With_comparator) (M) module type Creators_generic = sig include Set.Creators_generic val of_hash_set : ('a, 'cmp, 'a elt Hash_set.t -> ('a, 'cmp) t) options val of_hashtbl_keys : ('a, 'cmp, ('a elt, _) Hashtbl.t -> ('a, 'cmp) t) options (** Never requires a comparator because it can get one from the input [Map.t]. *) val of_map_keys : ('a elt, _, 'cmp cmp) Base.Map.t -> ('a, 'cmp) t val quickcheck_generator : ( 'a , 'cmp , 'a elt Quickcheck.Generator.t -> ('a, 'cmp) t Quickcheck.Generator.t ) options end module type Creators0 = sig include Set.Creators0 val of_hash_set : elt Hash_set.t -> t val of_hashtbl_keys : (elt, _) Hashtbl.t -> t val of_map_keys : (elt, _, comparator_witness) Base.Map.t -> t val quickcheck_generator : elt Quickcheck.Generator.t -> t Quickcheck.Generator.t end module type Creators1 = sig include Set.Creators1 val of_hash_set : 'a Hash_set.t -> 'a t val of_hashtbl_keys : ('a, _) Hashtbl.t -> 'a t val of_map_keys : ('a, _, comparator_witness) Base.Map.t -> 'a t val quickcheck_generator : 'a Quickcheck.Generator.t -> 'a t Quickcheck.Generator.t end module type Creators2 = sig include Set.Creators2 val of_hash_set : 'a Hash_set.t -> ('a, 'cmp) t val of_hashtbl_keys : ('a, _) Hashtbl.t -> ('a, 'cmp) t val of_map_keys : ('a, _, 'cmp) Base.Map.t -> ('a, 'cmp) t val quickcheck_generator : 'a Quickcheck.Generator.t -> ('a, 'cmp) t Quickcheck.Generator.t end module type Creators2_with_comparator = sig include Set.Creators2_with_comparator val of_hash_set : comparator:('a, 'cmp) Comparator.t -> 'a Hash_set.t -> ('a, 'cmp) t val of_hashtbl_keys : comparator:('a, 'cmp) Comparator.t -> ('a, _) Hashtbl.t -> ('a, 'cmp) t val of_map_keys : ('a, _, 'cmp) Base.Map.t -> ('a, 'cmp) t val quickcheck_generator : comparator:('a, 'cmp) Comparator.t -> 'a Quickcheck.Generator.t -> ('a, 'cmp) t Quickcheck.Generator.t end module Check_creators (T : T2) (Tree : T2) (Elt : T1) (Cmp : T1) (Options : T3) (_ : Creators_generic with type ('a, 'b, 'c) options := ('a, 'b, 'c) Options.t with type ('a, 'b) t := ('a, 'b) T.t with type ('a, 'b) tree := ('a, 'b) Tree.t with type 'a elt := 'a Elt.t with type 'cmp cmp := 'cmp Cmp.t) = struct end module Check_creators0 (M : Creators0) = Check_creators (struct type ('a, 'b) t = M.t end) (struct type ('a, 'b) t = M.tree end) (struct type 'a t = M.elt end) (struct type 'cmp t = M.comparator_witness end) (Without_comparator) (M) module Check_creators1 (M : Creators1) = Check_creators (struct type ('a, 'b) t = 'a M.t end) (struct type ('a, 'b) t = 'a M.tree end) (struct type 'a t = 'a end) (struct type 'cmp t = M.comparator_witness end) (Without_comparator) (M) module Check_creators2 (M : Creators2) = Check_creators (struct type ('a, 'b) t = ('a, 'b) M.t end) (struct type ('a, 'b) t = ('a, 'b) M.tree end) (struct type 'a t = 'a end) (struct type 'cmp t = 'cmp end) (Without_comparator) (M) module Check_creators2_with_comparator (M : Creators2_with_comparator) = Check_creators (struct type ('a, 'b) t = ('a, 'b) M.t end) (struct type ('a, 'b) t = ('a, 'b) M.tree end) (struct type 'a t = 'a end) (struct type 'cmp t = 'cmp end) (With_comparator) (M) module type Creators_and_accessors_generic = sig include Accessors_generic include Creators_generic with type ('a, 'b, 'c) options := ('a, 'b, 'c) options with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) tree with type 'a elt := 'a elt with type 'cmp cmp := 'cmp cmp end module type Creators_and_accessors0 = sig include Accessors0 include Creators0 with type t := t with type tree := tree with type elt := elt with type comparator_witness := comparator_witness end module type Creators_and_accessors1 = sig include Accessors1 include Creators1 with type 'a t := 'a t with type 'a tree := 'a tree with type comparator_witness := comparator_witness end module type Creators_and_accessors2 = sig include Accessors2 include Creators2 with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) tree end module type Creators_and_accessors2_with_comparator = sig include Accessors2_with_comparator include Creators2_with_comparator with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) tree end module Make_S_plain_tree (Elt : Comparator.S) = struct module type S = sig type t = (Elt.t, Elt.comparator_witness) Tree.t [@@deriving compare, sexp_of] type named = (Elt.t, Elt.comparator_witness) Tree.Named.t include Creators_and_accessors0 with type ('a, 'b) set := ('a, 'b) Tree.t with type t := t with type tree := t with type elt := Elt.t with type named := named with type comparator_witness := Elt.comparator_witness module Provide_of_sexp (Elt : sig type t [@@deriving of_sexp] end with type t := Elt.t) : sig type t [@@deriving of_sexp] end with type t := t end end module type S_plain = sig module Elt : sig type t [@@deriving sexp_of] include Comparator.S with type t := t end type t = (Elt.t, Elt.comparator_witness) Base.Set.t [@@deriving compare, sexp_of] type named = (Elt.t, Elt.comparator_witness) Named.t include Creators_and_accessors0 with type ('a, 'b) set := ('a, 'b) Base.Set.t with type t := t with type tree := (Elt.t, Elt.comparator_witness) Tree.t with type elt := Elt.t with type named := named with type comparator_witness := Elt.comparator_witness module Provide_of_sexp (Elt : sig type t [@@deriving of_sexp] end with type t := Elt.t) : sig type t [@@deriving of_sexp] end with type t := t module Provide_bin_io (Elt : sig type t [@@deriving bin_io] end with type t := Elt.t) : Binable.S with type t := t module Provide_hash (Elt : Hasher.S with type t := Elt.t) : sig type t [@@deriving hash] end with type t := t end module type S = sig module Elt : sig type t [@@deriving sexp] include Comparator.S with type t := t end include S_plain with module Elt := Elt include Sexpable.S with type t := t end module type S_binable = sig module Elt : sig type t [@@deriving sexp, bin_io] include Comparator.S with type t := t end include S with module Elt := Elt include Binable.S with type t := t end core-0.15.0/core/src/set_once.ml000066400000000000000000000045041420273305200163760ustar00rootroot00000000000000module Stable = struct open Stable_internal module T = struct type 'a t = { mutable value : 'a option ; mutable set_at : Source_code_position.Stable.V1.t } [@@deriving fields] end module V1 = struct module Format = struct type 'a t = 'a option ref [@@deriving bin_io, sexp] end module T = struct type 'a t = 'a T.t let of_format (v1 : 'a Format.t) : 'a t = { value = !v1; set_at = [%here] } let to_format (t : 'a t) : 'a Format.t = ref t.value end include T include Binable.Of_binable1_without_uuid [@alert "-legacy"] (Format) (struct include T let of_binable = of_format let to_binable = to_format end) include Sexpable.Of_sexpable1 (Format) (struct include T let of_sexpable = of_format let to_sexpable = to_format end) end end open! Import module Unstable = Stable.V1 open Stable.T type 'a t = 'a Stable.T.t let sexp_of_t sexp_of_a { value; set_at } = match value with | None -> [%message "unset"] | Some value -> [%message "" (value : a) ~set_at:(set_at |> Source_code_position.to_string)] ;; let invariant invariant_a t = match t.value with | None -> () | Some a -> invariant_a a ;; let create () = { value = None; set_at = [%here] } let set_internal t here value = t.value <- Some value; t.set_at <- here ;; let set_if_none t here value = if Option.is_none t.value then set_internal t here value let set t here value = if Option.is_none t.value then ( set_internal t here value; Ok ()) else Or_error.error_s [%message "[Set_once.set_exn] already set" ~setting_at:(here : Source_code_position.t) ~previously_set_at:(t.set_at : Source_code_position.t)] ;; let set_exn t here value = Or_error.ok_exn (set t here value) let get t = t.value let get_exn (t : _ t) here = match t.value with | Some a -> a | None -> raise_s [%message "[Set_once.get_exn] unset" ~at:(here : Source_code_position.t)] ;; let is_none t = Option.is_none t.value let is_some t = Option.is_some t.value let iter t ~f = Option.iter t.value ~f module Optional_syntax = struct module Optional_syntax = struct let is_none = is_none let unsafe_value t = get_exn t [%here] end end core-0.15.0/core/src/set_once.mli000066400000000000000000000021031420273305200165400ustar00rootroot00000000000000(** A ['a Set_once.t] is like an ['a option ref] that can only be set once. A [Set_once.t] starts out as [None], the first [set] transitions it to [Some], and subsequent [set]s fail. *) open! Import type 'a t [@@deriving sexp_of] (** Passes when unset. *) include Invariant.S1 with type 'a t := 'a t val create : unit -> _ t val set : 'a t -> Source_code_position.t -> 'a -> unit Or_error.t val set_exn : 'a t -> Source_code_position.t -> 'a -> unit (** [set_if_none t here a] will do nothing if [is_some t], otherwise it will [set_exn t here a]. *) val set_if_none : 'a t -> Source_code_position.t -> 'a -> unit val get : 'a t -> 'a option val get_exn : 'a t -> Source_code_position.t -> 'a val is_none : _ t -> bool val is_some : _ t -> bool val iter : 'a t -> f:('a -> unit) -> unit module Optional_syntax : Optional_syntax.S1 with type 'a t := 'a t with type 'a value := 'a identity module Unstable : sig type nonrec 'a t = 'a t [@@deriving bin_io, sexp] end module Stable : sig module V1 : sig type nonrec 'a t = 'a t [@@deriving bin_io, sexp] end end core-0.15.0/core/src/sexp.ml000066400000000000000000000056761420273305200155710ustar00rootroot00000000000000open! Import module Stable = struct module V1 = struct type t = Base.Sexp.t = | Atom of string | List of t list [@@deriving bin_io, compare, hash] let t_of_sexp = Sexplib.Sexp.t_of_sexp let sexp_of_t = Sexplib.Sexp.sexp_of_t end end include Stable.V1 include ( Base.Sexp : module type of struct include Base.Sexp end with type t := t) include ( Sexplib.Sexp : module type of struct include Sexplib.Sexp end with type t := t) module O = struct type sexp = Base.Sexp.t = | Atom of string | List of t list end module Sexp_maybe = struct type nonrec 'a t = ('a, t * Error.t) Result.t [@@deriving bin_io, compare, hash] let sexp_of_t sexp_of_a t = match t with | Result.Ok a -> sexp_of_a a | Result.Error (sexp, err) -> List [ Atom "sexp_parse_error"; sexp; Error.sexp_of_t err ] ;; let t_of_sexp a_of_sexp sexp = match sexp with | List [ Atom "sexp_parse_error"; sexp; _ ] | sexp -> (try Result.Ok (a_of_sexp sexp) with | exn -> Result.Error (sexp, Error.of_exn exn)) ;; let t_sexp_grammar (grammar : _ Sexplib.Sexp_grammar.t) : _ t Sexplib.Sexp_grammar.t = { untyped = Union [ grammar.untyped; Base.Sexp.t_sexp_grammar.untyped ] } ;; end module With_text = struct open Result.Export type 'a t = { value : 'a ; text : string } [@@deriving bin_io] let sexp_of_t _ t = Atom t.text let of_text value_of_sexp ?(filename = "") text = match Or_error.try_with (fun () -> of_string_conv text value_of_sexp) with | Ok (`Result value) -> Ok { value; text } | Error _ as err -> err | Ok (`Error (exn, annotated)) -> Error (Error.of_exn (Annotated.get_conv_exn annotated ~file:filename ~exc:exn)) ;; let t_of_sexp a_of_sexp sexp = match sexp with | List _ -> of_sexp_error "With_text.t should be stored as an atom, but instead a list was found." sexp | Atom text -> of_text a_of_sexp text |> Or_error.ok_exn ;; let t_sexp_grammar _ = Sexplib.Sexp_grammar.coerce Base.String.t_sexp_grammar let text t = t.text let value t = t.value let of_value sexp_of_value value = let text = sexp_of_value value |> to_string_hum in { value; text } ;; end type 'a no_raise = 'a [@@deriving bin_io, sexp] let sexp_of_no_raise sexp_of_a a = try sexp_of_a a with | exn -> (try List [ Atom "failure building sexp"; sexp_of_exn exn ] with | _ -> Atom "could not build sexp for exn raised when building sexp for value") ;; include Comparable.Extend (Base.Sexp) (Base.Sexp) let of_sexp_allow_extra_fields_recursively of_sexp sexp = let r = Sexplib.Conv.record_check_extra_fields in let prev = !r in Exn.protect ~finally:(fun () -> r := prev) ~f:(fun () -> r := false; of_sexp sexp) ;; let quickcheck_generator = Base_quickcheck.Generator.sexp let quickcheck_observer = Base_quickcheck.Observer.sexp let quickcheck_shrinker = Base_quickcheck.Shrinker.sexp core-0.15.0/core/src/sexp.mli000066400000000000000000000074041420273305200157310ustar00rootroot00000000000000(** Code for managing s-expressions. *) open! Import type t = Base.Sexp.t = | Atom of string | List of t list [@@deriving bin_io, hash, sexp, sexp_grammar] module O : sig type sexp = Base.Sexp.t = | Atom of string | List of t list end include Comparable.S with type t := t include Stringable.S with type t := t include Quickcheckable.S with type t := t include module type of struct include Sexplib.Sexp end with type t := t exception Of_sexp_error of exn * t val of_float_style : [ `Underscores | `No_underscores ] ref val of_int_style : [ `Underscores | `No_underscores ] ref (** [no_raise] is the identity, but by using ['a no_raise] in a sexpable type, the resulting use [sexp_of_no_raise] protects the conversion of ['a] to a sexp so that if it fails, one gets a sexp with an error message about the failure, rather than an exception being raised. WARNING: The resulting [no_raise_of_sexp] can still raise. *) type 'a no_raise = 'a [@@deriving bin_io, sexp] (** If [sexp_of_t fails], it returns [Error] rather than raising. You can convert values of this type to and from sexp in processes that can or cannot parse the underlying sexp in any combination and still recover the original value. Also, the [Error] case contains a human-readable description of the error. A common use case is to parse most of a sexp even when some small part fails to parse, e.g.: {[ type query = | Start of Initial_config.t Sexp_maybe.t | Stop of Reason_to_stop.t Sexp_maybe.t [@@deriving sexp] ]} If [Reason_to_stop.t_of_sexp] fails, you can still tell it was a [Stop] query. *) module Sexp_maybe : sig type 'a t = ('a, Base.Sexp.t * Error.t) Result.t [@@deriving bin_io, compare, hash, sexp, sexp_grammar] end (** A [With_text.t] is a value paired with the full textual representation of its sexp. This is useful for dealing with the case where you want to keep track of a value along with the format of the s-expression it was generated from, which allows you to maintain formatting details, comments, etc. The s-expression representation of a [With_text.t] is the raw text, stored as an atom. The bin_io representation contains both the bin_io of the underlying value and the bin_io'd version of the raw text. This is similar to but simpler than the [With_layout] module included above (via [Sexp_intf.S]), which gives you access to a fully parsed version of the s-expression, with attached comments and layout information, to allow you to build layout-preserving s-expression transformations. The invariants of a [x With_text.t] are broken if the [x] value is mutated. *) module With_text : sig type 'a t [@@deriving sexp, sexp_grammar, bin_io] (** Generates a [t] from the value by creating the text automatically using the provided s-expression converter. *) val of_value : ('a -> Base.Sexp.t) -> 'a -> 'a t (** Creates a [t] from the text, by first converting the text to an s-expression, and then parsing the s-expression with the provided converter. *) val of_text : (Base.Sexp.t -> 'a) -> ?filename:string (** used for error reporting *) -> string -> 'a t Or_error.t val value : 'a t -> 'a val text : 'a t -> string end (** [of_sexp_allow_extra_fields_recursively of_sexp sexp] uses [of_sexp] to convert [sexp] to a value, but will not fail if there are any extra fields in a record (even deeply nested records). The implementation uses global state, so it is not thread safe. *) val of_sexp_allow_extra_fields_recursively : (Base.Sexp.t -> 'a) -> Base.Sexp.t -> 'a module Stable : sig module V1 : sig type nonrec t = t = | Atom of string | List of t list [@@deriving sexp, bin_io, hash, compare] end end core-0.15.0/core/src/sexpable.ml000066400000000000000000000065541420273305200164110ustar00rootroot00000000000000open! Import include Base.Sexpable module Stable = struct module Of_sexpable = struct module V1 (Sexpable : S) (M : sig type t val to_sexpable : t -> Sexpable.t val of_sexpable : Sexpable.t -> t end) : S with type t := M.t = struct let t_of_sexp sexp = let s = Sexpable.t_of_sexp sexp in try M.of_sexpable s with | exn -> of_sexp_error_exn exn sexp ;; let sexp_of_t t = Sexpable.sexp_of_t (M.to_sexpable t) end end module Of_sexpable1 = struct module V1 (Sexpable : S1) (M : sig type 'a t val to_sexpable : 'a t -> 'a Sexpable.t val of_sexpable : 'a Sexpable.t -> 'a t end) : S1 with type 'a t := 'a M.t = struct let t_of_sexp a_of_sexp sexp = let s = Sexpable.t_of_sexp a_of_sexp sexp in try M.of_sexpable s with | exn -> of_sexp_error_exn exn sexp ;; let sexp_of_t sexp_of_a t = Sexpable.sexp_of_t sexp_of_a (M.to_sexpable t) end end module Of_sexpable2 = struct module V1 (Sexpable : S2) (M : sig type ('a, 'b) t val to_sexpable : ('a, 'b) t -> ('a, 'b) Sexpable.t val of_sexpable : ('a, 'b) Sexpable.t -> ('a, 'b) t end) : S2 with type ('a, 'b) t := ('a, 'b) M.t = struct let t_of_sexp a_of_sexp b_of_sexp sexp = let s = Sexpable.t_of_sexp a_of_sexp b_of_sexp sexp in try M.of_sexpable s with | exn -> of_sexp_error_exn exn sexp ;; let sexp_of_t sexp_of_a sexp_of_b t = Sexpable.sexp_of_t sexp_of_a sexp_of_b (M.to_sexpable t) ;; end end module Of_sexpable3 = struct module V1 (Sexpable : S3) (M : sig type ('a, 'b, 'c) t val to_sexpable : ('a, 'b, 'c) t -> ('a, 'b, 'c) Sexpable.t val of_sexpable : ('a, 'b, 'c) Sexpable.t -> ('a, 'b, 'c) t end) : S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) M.t = struct let t_of_sexp a_of_sexp b_of_sexp c_of_sexp sexp = let s = Sexpable.t_of_sexp a_of_sexp b_of_sexp c_of_sexp sexp in try M.of_sexpable s with | exn -> of_sexp_error_exn exn sexp ;; let sexp_of_t sexp_of_a sexp_of_b sexp_of_c t = Sexpable.sexp_of_t sexp_of_a sexp_of_b sexp_of_c (M.to_sexpable t) ;; end end module Of_stringable = struct module V1 (M : Stringable.S) : S with type t := M.t = struct let t_of_sexp sexp = match sexp with | Sexplib.Sexp.Atom s -> (try M.of_string s with | exn -> of_sexp_error_exn exn sexp) | Sexplib.Sexp.List _ -> of_sexp_error "Sexpable.Of_stringable.t_of_sexp expected an atom, but got a list" sexp ;; let sexp_of_t t = Sexplib.Sexp.Atom (M.to_string t) end end module To_stringable = struct module V1 (M : S) : Stringable.S with type t := M.t = struct let of_string x = Sexplib.Conv.of_string__of__of_sexp M.t_of_sexp x let to_string x = Sexplib.Conv.string_of__of__sexp_of M.sexp_of_t x end end end module To_stringable = Stable.To_stringable.V1 core-0.15.0/core/src/sexpable.mli000066400000000000000000000020531420273305200165500ustar00rootroot00000000000000(** This module extends {!Base.Sexpable}. *) open! Import (** @inline *) include module type of struct include Base.Sexpable end module To_stringable (M : S) : Stringable.S with type t := M.t (** The following functors preserve stability: if applied to stable types with stable (de)serializations, they will produce stable types with stable (de)serializations. Note: In all cases, stability of the input (and therefore the output) depends on the semantics of all conversion functions (e.g. to_string, to_sexpable) not changing in the future. *) module Stable : sig module Of_sexpable : sig module V1 : module type of Of_sexpable end module Of_sexpable1 : sig module V1 : module type of Of_sexpable1 end module Of_sexpable2 : sig module V1 : module type of Of_sexpable2 end module Of_sexpable3 : sig module V1 : module type of Of_sexpable3 end module Of_stringable : sig module V1 : module type of Of_stringable end module To_stringable : sig module V1 : module type of To_stringable end end core-0.15.0/core/src/sign.ml000066400000000000000000000004471420273305200155410ustar00rootroot00000000000000open! Import module Sign = Base.Sign module Stable = struct module V1 = struct type t = Sign.t = | Neg | Zero | Pos [@@deriving sexp, bin_io, compare, hash, typerep, enumerate] end end include Stable.V1 include Sign include Identifiable.Extend (Sign) (Stable.V1) core-0.15.0/core/src/sign.mli000066400000000000000000000010471420273305200157070ustar00rootroot00000000000000(** This module extends {{!Base.Sign}[Base.Sign]} with bin_io. *) open! Import type t = Base.Sign.t = | Neg | Zero | Pos [@@deriving typerep] include module type of Base.Sign with type t := t (** @inline *) (** This provides [to_string]/[of_string], sexp/bin_io conversion, Map, Hashtbl, etc. *) include Identifiable.S with type t := t and type comparator_witness := comparator_witness module Stable : sig module V1 : sig type nonrec t = t = | Neg | Zero | Pos [@@deriving bin_io, compare, hash, sexp] end end core-0.15.0/core/src/sign_or_nan.ml000066400000000000000000000005261420273305200170730ustar00rootroot00000000000000open! Import module Sign_or_nan = Base.Sign_or_nan module Stable = struct module V1 = struct type t = Sign_or_nan.t = | Neg | Zero | Pos | Nan [@@deriving sexp, bin_io, compare, hash, typerep, enumerate] end end include Stable.V1 include Sign_or_nan include Identifiable.Extend (Sign_or_nan) (Stable.V1) core-0.15.0/core/src/sign_or_nan.mli000066400000000000000000000011271420273305200172420ustar00rootroot00000000000000(** This module extends {{!Base.Sign_or_nan}[Base.Sign_or_nan]} with bin_io. *) open! Import type t = Base.Sign_or_nan.t = | Neg | Zero | Pos | Nan [@@deriving typerep] include module type of Base.Sign_or_nan with type t := t (** @inline *) (** This provides [to_string]/[of_string], sexp/bin_io conversion, Map, Hashtbl, etc. *) include Identifiable.S with type t := t and type comparator_witness := comparator_witness module Stable : sig module V1 : sig type nonrec t = t = | Neg | Zero | Pos | Nan [@@deriving bin_io, compare, hash, sexp] end end core-0.15.0/core/src/signal.ml000066400000000000000000000133611420273305200160550ustar00rootroot00000000000000open! Import include ( Int : sig type t = int [@@deriving bin_io] include Comparable.S with type t := t include Hashable.S with type t := t end) let of_caml_int t = t let to_caml_int t = t type sys_behavior = [ `Continue (** Continue the process if it is currently stopped *) | `Dump_core (** Terminate the process and dump core *) | `Ignore (** Ignore the signal *) | `Stop (** Stop the process *) | `Terminate (** Terminate the process *) ] [@@deriving sexp] let equal (t : t) t' = t = t' include struct (* Please keep in sync with the list for to_string/sys_behavior *) open Caml.Sys let abrt = sigabrt let alrm = sigalrm let bus = sigbus let chld = sigchld let cont = sigcont let fpe = sigfpe let hup = sighup let ill = sigill let int = sigint let kill = sigkill let pipe = sigpipe let poll = sigpoll let prof = sigprof let quit = sigquit let segv = sigsegv let stop = sigstop let sys = sigsys let term = sigterm let trap = sigtrap let tstp = sigtstp let ttin = sigttin let ttou = sigttou let urg = sigurg let usr1 = sigusr1 let usr2 = sigusr2 let vtalrm = sigvtalrm let xcpu = sigxcpu let xfsz = sigxfsz let zero = 0 end exception Invalid_signal_mnemonic_or_number of string [@@deriving sexp] let to_string_with_version, of_string, default_sys_behavior = let known = [ "sigabrt", abrt, `Dump_core, 1 ; "sigalrm", alrm, `Terminate, 1 ; "sigbus", bus, `Dump_core, 2 ; "sigchld", chld, `Ignore, 1 ; "sigcont", cont, `Continue, 1 ; "sigfpe", fpe, `Dump_core, 1 ; "sighup", hup, `Terminate, 1 ; "sigill", ill, `Dump_core, 1 ; "sigint", int, `Terminate, 1 ; "sigkill", kill, `Terminate, 1 ; "sigpipe", pipe, `Terminate, 1 ; "sigpoll", poll, `Terminate, 2 ; "sigprof", prof, `Terminate, 1 ; "sigquit", quit, `Dump_core, 1 ; "sigsegv", segv, `Dump_core, 1 ; "sigstop", stop, `Stop, 1 ; "sigsys", sys, `Dump_core, 2 ; "sigterm", term, `Terminate, 1 ; "sigtrap", trap, `Dump_core, 2 ; "sigtstp", tstp, `Stop, 1 ; "sigttin", ttin, `Stop, 1 ; "sigttou", ttou, `Stop, 1 ; "sigurg", urg, `Ignore, 2 ; "sigusr1", usr1, `Terminate, 1 ; "sigusr2", usr2, `Terminate, 1 ; "sigvtalrm", vtalrm, `Terminate, 1 ; "sigxcpu", xcpu, `Dump_core, 2 ; "sigxfsz", xfsz, `Dump_core, 2 ; "sigzero", zero, `Ignore, 1 ] in let name_and_version_by_t = Int.Table.create ~size:1 () in let t_by_name = String.Table.create ~size:1 () in let behavior_by_t = Int.Table.create ~size:1 () in List.iter known ~f:(fun (name, t, behavior, stable_version) -> Hashtbl.set name_and_version_by_t ~key:t ~data:(name, stable_version); Hashtbl.set t_by_name ~key:name ~data:t; Hashtbl.set behavior_by_t ~key:t ~data:behavior); (* For unknown signal numbers, [to_string] returns a meaningful string, while [default_sys_behavior] has to raise an exception because we don't know what the right answer is. *) let to_string_with_version t ~version:requested_version = match Hashtbl.find name_and_version_by_t t with | Some (string, needed_version) when requested_version >= needed_version -> string | _ -> "" in let of_string s = let s = String.lowercase (String.strip s) in match Hashtbl.find t_by_name s with | Some sn -> sn | None -> if String.is_prefix s ~prefix:" raise (Invalid_signal_mnemonic_or_number s)) else raise (Invalid_signal_mnemonic_or_number s) in let default_sys_behavior t = match Hashtbl.find behavior_by_t t with | None -> raise (Invalid_argument ("Signal.default_sys_behavior: unknown signal " ^ Int.to_string t)) | Some behavior -> behavior in to_string_with_version, of_string, default_sys_behavior ;; exception Expected_atom of Sexp.t [@@deriving sexp] let sexp_of_t_with_version t ~version = Sexp.Atom (to_string_with_version t ~version) let to_string s = to_string_with_version s ~version:2 let sexp_of_t t = sexp_of_t_with_version t ~version:1 let t_of_sexp s = match s with | Sexp.Atom s -> of_string s | _ -> raise (Expected_atom s) ;; type pid_spec = [ `Use_Signal_unix ] type sigprocmask_command = [ `Use_Signal_unix ] let can_send_to = `Use_Signal_unix let of_system_int = `Use_Signal_unix let send = `Use_Signal_unix let send_exn = `Use_Signal_unix let send_i = `Use_Signal_unix let sexp_of_pid_spec = `Use_Signal_unix let sigpending = `Use_Signal_unix let sigprocmask = `Use_Signal_unix let sigsuspend = `Use_Signal_unix let to_system_int = `Use_Signal_unix module Expert = struct type behavior = [ `Default | `Ignore | `Handle of t -> unit ] module Behavior = struct let of_caml = function | Caml.Sys.Signal_default -> `Default | Signal_ignore -> `Ignore | Signal_handle f -> `Handle f ;; let to_caml = function | `Default -> Caml.Sys.Signal_default | `Ignore -> Signal_ignore | `Handle f -> Signal_handle (fun t -> Exn.handle_uncaught_and_exit (fun () -> f t)) ;; end let signal t behavior = Behavior.of_caml (Caml.Sys.signal t (Behavior.to_caml behavior)) let set t behavior = ignore (signal t behavior : behavior) let handle t f = set t (`Handle f) end open Expert let handle_default t = set t `Default let ignore t = set t `Ignore module Stable = struct module V2 = struct type nonrec t = t [@@deriving bin_io, compare] let t_of_sexp = t_of_sexp let sexp_of_t t = sexp_of_t_with_version t ~version:2 end module V1 = struct type nonrec t = t [@@deriving bin_io, compare] let t_of_sexp = t_of_sexp let sexp_of_t t = sexp_of_t_with_version t ~version:1 end end core-0.15.0/core/src/signal.mli000066400000000000000000000146571420273305200162370ustar00rootroot00000000000000(** Signal handlers. *) open! Import type t [@@deriving bin_io, sexp] include Comparable.S with type t := t include Hashable.S with type t := t include Stringable.S with type t := t val equal : t -> t -> bool (** [of_caml_int] constructs a [Signal.t] given an OCaml internal signal number. This is only for the use of the [Core_unix] module. *) val of_caml_int : int -> t val to_caml_int : t -> int (** [to_string t] returns a human-readable name: "sigabrt", "sigalrm", ... *) val to_string : t -> string (** The behaviour of the system if a signal is received by a process. See include/linux/kernel.h in the Linux kernel source tree (not the file /usr/include/linux/kernel.h). *) type sys_behavior = [ `Continue (** Continue the process if it is currently stopped *) | `Dump_core (** Terminate the process and dump core *) | `Ignore (** Ignore the signal *) | `Stop (** Stop (suspend) the process *) | `Terminate (** Terminate the process *) ] [@@deriving sexp] (** Queries the default system behavior for a signal. *) val default_sys_behavior : t -> sys_behavior (** [handle_default t] is [set t `Default]. *) val handle_default : t -> unit (** [ignore t] is [set t `Ignore]. *) val ignore : t -> unit (** Specific signals, along with their default behavior and meaning. *) (** [Dump_core] Abnormal termination *) val abrt : t (** [Terminate] Timeout *) val alrm : t (** [Dump_core] Bus error *) val bus : t (** [Ignore] Child process terminated *) val chld : t (** [Continue] Continue *) val cont : t (** [Dump_core] Arithmetic exception *) val fpe : t (** [Terminate] Hangup on controlling terminal *) val hup : t (** [Dump_core] Invalid hardware instruction *) val ill : t (** [Terminate] Interactive interrupt (ctrl-C) *) val int : t (** [Terminate] Termination (cannot be ignored) *) val kill : t (** [Terminate] Broken pipe *) val pipe : t (** [Terminate] Pollable event *) val poll : t (** [Terminate] Profiling interrupt *) val prof : t (** [Dump_core] Interactive termination *) val quit : t (** [Dump_core] Invalid memory reference *) val segv : t (** [Dump_core] Bad argument to routine *) val sys : t (** [Stop] Stop *) val stop : t (** [Terminate] Termination *) val term : t (** [Dump_core] Trace/breakpoint trap *) val trap : t (** [Stop] Interactive stop *) val tstp : t (** [Stop] Terminal read from background process *) val ttin : t (** [Stop] Terminal write from background process *) val ttou : t (** [Ignore] Urgent condition on socket *) val urg : t (** [Terminate] Application-defined signal 1 *) val usr1 : t (** [Terminate] Application-defined signal 2 *) val usr2 : t (** [Terminate] Timeout in virtual time *) val vtalrm : t (** [Dump_core] Timeout in cpu time *) val xcpu : t (** [Dump_core] File size limit exceeded *) val xfsz : t (** [Ignore] No-op; can be used to test whether the target process exists and the current process has permission to signal it *) val zero : t type pid_spec = [ `Use_Signal_unix ] [@@deprecated "[since 2021-04] Use [Signal_unix]"] type sigprocmask_command = [ `Use_Signal_unix ] [@@deprecated "[since 2021-04] Use [Signal_unix]"] val can_send_to : [ `Use_Signal_unix ] [@@deprecated "[since 2021-04] Use [Signal_unix]"] val of_system_int : [ `Use_Signal_unix ] [@@deprecated "[since 2021-04] Use [Signal_unix]"] val send : [ `Use_Signal_unix ] [@@deprecated "[since 2021-04] Use [Signal_unix]"] val send_exn : [ `Use_Signal_unix ] [@@deprecated "[since 2021-04] Use [Signal_unix]"] val send_i : [ `Use_Signal_unix ] [@@deprecated "[since 2021-04] Use [Signal_unix]"] val sexp_of_pid_spec : [ `Use_Signal_unix ] [@@deprecated "[since 2021-04] Use [Signal_unix]"] val sigpending : [ `Use_Signal_unix ] [@@deprecated "[since 2021-04] Use [Signal_unix]"] val sigprocmask : [ `Use_Signal_unix ] [@@deprecated "[since 2021-04] Use [Signal_unix]"] val sigsuspend : [ `Use_Signal_unix ] [@@deprecated "[since 2021-04] Use [Signal_unix]"] val to_system_int : [ `Use_Signal_unix ] [@@deprecated "[since 2021-04] Use [Signal_unix]"] (** The [Expert] module contains functions that novice users should avoid, due to their complexity. An OCaml signal handler can run at any time, which introduces all the semantic complexities of multithreading. It is much easier to use Async's signal handling, see {!Async_unix.Signal}, which does not involve multithreading, and runs user code as ordinary Async jobs. Also, beware that there can only be a single OCaml signal handler for any signal, so handling a signal with a [Core] signal handler will interfere if Async is attempting to handle the same signal. All signal handler functions are called with [Exn.handle_uncaught_and_exit], to prevent the signal handler from raising, because raising from a signal handler could raise to any allocation or GC point in any thread, which would be impossible to reason about. If you do use [Core] signal handlers, you should strive to make the signal handler perform a simple idempotent action, like setting a ref. *) module Expert : sig type behavior = [ `Default | `Ignore | `Handle of t -> unit ] (** [signal t] sets the behavior of the system on receipt of signal [t] and returns the behavior previously associated with [t]. If [t] is not available on your system, [signal] raises. *) val signal : t -> behavior -> behavior (** [set t b] is [ignore (signal t b)]. *) val set : t -> behavior -> unit (** [handle t f] is [set t (`Handle f)]. *) val handle : t -> (t -> unit) -> unit end module Stable : sig module V2 : sig type nonrec t = t [@@deriving bin_io, compare, sexp] end module V1 : sig type nonrec t = t [@@deriving bin_io, compare, sexp] end end core-0.15.0/core/src/source_code_position.ml000066400000000000000000000003111420273305200210050ustar00rootroot00000000000000open! Import include Base.Source_code_position include Source_code_position0 include Comparable.Extend (Base.Source_code_position) (Source_code_position0) include Hashable.Make (Source_code_position0) core-0.15.0/core/src/source_code_position.mli000066400000000000000000000010061420273305200211600ustar00rootroot00000000000000(** This module extends {{!Base.Source_code_position}[Base.Source_code_position]}. *) (** @inline *) include module type of struct include Base.Source_code_position end type t = Base.Source_code_position.t = { pos_fname : string ; pos_lnum : int ; pos_bol : int ; pos_cnum : int } [@@deriving fields] include Comparable.S with type t := t and type comparator_witness := comparator_witness include Hashable.S with type t := t module Stable : sig module V1 : Stable_module_types.S0 with type t = t end core-0.15.0/core/src/source_code_position0.ml000066400000000000000000000006561420273305200211010ustar00rootroot00000000000000open! Import module Stable = struct module V1 = struct include Base.Source_code_position type t = Base.Source_code_position.t = { pos_fname : string ; pos_lnum : int ; pos_bol : int ; pos_cnum : int } [@@deriving bin_io, compare, fields, hash, sexp] end end include Stable.V1 let to_string = Base.Source_code_position.to_string let sexp_of_t = Base.Source_code_position.sexp_of_t core-0.15.0/core/src/source_code_position0.mli000066400000000000000000000006451420273305200212500ustar00rootroot00000000000000open! Import include module type of struct include Base.Source_code_position end type t = Base.Source_code_position.t = { pos_fname : string ; pos_lnum : int ; pos_bol : int ; pos_cnum : int } [@@deriving bin_io, compare, fields, hash, sexp] module Stable : sig module V1 : sig type nonrec t = t [@@deriving bin_io, compare, hash, sexp] include Comparator.Stable.V1.S with type t := t end end core-0.15.0/core/src/span_float.ml000066400000000000000000000734671420273305200167430ustar00rootroot00000000000000open! Import open Std_internal open! Int.Replace_polymorphic_compare module Stable = struct module V1 = struct module Parts = struct type t = { sign : Sign.t ; hr : int ; min : int ; sec : int ; ms : int ; us : int ; ns : int } [@@deriving compare, sexp, sexp_grammar] end module type Like_a_float = sig type t [@@deriving bin_io, hash, quickcheck, typerep] include Comparable.S_common with type t := t include Comparable.With_zero with type t := t include Floatable with type t := t val ( + ) : t -> t -> t val ( - ) : t -> t -> t val zero : t val robust_comparison_tolerance : t val abs : t -> t val neg : t -> t val scale : t -> float -> t end module T : sig type underlying = float [@@deriving hash] type t = private underlying [@@deriving bin_io, hash] include Like_a_float with type t := t include Robustly_comparable with type t := t module Constant : sig val nanoseconds_per_second : float val microseconds_per_second : float val milliseconds_per_second : float val nanosecond : t val microsecond : t val millisecond : t val second : t val minute : t val hour : t val day : t end val to_parts : t -> Parts.t val next : t -> t val prev : t -> t end = struct type underlying = float [@@deriving hash] type t = underlying [@@deriving hash] let next t = Float.one_ulp `Up t let prev t = Float.one_ulp `Down t (* IF THIS REPRESENTATION EVER CHANGES, ENSURE THAT EITHER (1) all values serialize the same way in both representations, or (2) you add a new Time.Span version to stable.ml *) include ( struct include Float let sign = sign_exn end : Like_a_float with type t := t) (* due to precision limitations in float we can't expect better than microsecond precision *) include Float.Robust_compare.Make (struct let robust_comparison_tolerance = 1E-6 end) (* this prevents any worry about having these very common names redefined below and makes their usage within this module safer. Constant is included at the very bottom to re-export these constants in a more convenient way *) module Constant = struct let nanoseconds_per_second = 1E9 let microseconds_per_second = 1E6 let milliseconds_per_second = 1E3 (* spans are stored as a float in seconds *) let nanosecond = of_float (1. /. nanoseconds_per_second) let microsecond = of_float (1. /. microseconds_per_second) let millisecond = of_float (1. /. milliseconds_per_second) let second = of_float 1. let minute = of_float 60. let hour = of_float (60. *. 60.) let day = of_float (24. *. 60. *. 60.) end let to_parts t : Parts.t = let sign = Float.sign_exn t in let t = abs t in let integral = Float.round_down t in let fractional = t -. integral in let seconds = Float.iround_down_exn integral in let nanoseconds = Float.iround_nearest_exn (fractional *. 1E9) in let seconds, nanoseconds = if Int.equal nanoseconds 1_000_000_000 then Int.succ seconds, 0 else seconds, nanoseconds in let sec = seconds mod 60 in let minutes = seconds / 60 in let min = minutes mod 60 in let hr = minutes / 60 in let ns = nanoseconds mod 1000 in let microseconds = nanoseconds / 1000 in let us = microseconds mod 1000 in let milliseconds = microseconds / 1000 in let ms = milliseconds in { sign; hr; min; sec; ms; us; ns } ;; end let ( / ) t f = T.of_float ((t : T.t :> float) /. f) let ( // ) (f : T.t) (t : T.t) = (f :> float) /. (t :> float) (* Multiplying by 1E3 is more accurate than division by 1E-3 *) let to_ns (x : T.t) = (x :> float) *. T.Constant.nanoseconds_per_second let to_us (x : T.t) = (x :> float) *. T.Constant.microseconds_per_second let to_ms (x : T.t) = (x :> float) *. T.Constant.milliseconds_per_second let to_sec (x : T.t) = (x :> float) let to_min x = x // T.Constant.minute let to_hr x = x // T.Constant.hour let to_day x = x // T.Constant.day let to_int63_seconds_round_down_exn x = Float.int63_round_down_exn (to_sec x) let ( ** ) f (t : T.t) = T.of_float (f *. (t :> float)) (* Division by 1E3 is more accurate than multiplying by 1E-3 *) let of_ns x = T.of_float (x /. T.Constant.nanoseconds_per_second) let of_us x = T.of_float (x /. T.Constant.microseconds_per_second) let of_ms x = T.of_float (x /. T.Constant.milliseconds_per_second) let of_sec x = T.of_float x let of_int_sec x = of_sec (Float.of_int x) let of_int32_seconds sec = of_sec (Int32.to_float sec) (* Note that [Int63.to_float] can lose precision, but only on inputs large enough that [of_sec] in either the Time_ns or Time_float case would lose precision (or just be plain out of bounds) anyway. *) let of_int63_seconds sec = of_sec (Int63.to_float sec) let of_min x = x ** T.Constant.minute let of_hr x = x ** T.Constant.hour let of_day x = x ** T.Constant.day let divide_by_unit_of_time t unit_of_time = match (unit_of_time : Unit_of_time.t) with | Nanosecond -> to_ns t | Microsecond -> to_us t | Millisecond -> to_ms t | Second -> to_sec t | Minute -> to_min t | Hour -> to_hr t | Day -> to_day t ;; let scale_by_unit_of_time float unit_of_time = match (unit_of_time : Unit_of_time.t) with | Nanosecond -> of_ns float | Microsecond -> of_us float | Millisecond -> of_ms float | Second -> of_sec float | Minute -> of_min float | Hour -> of_hr float | Day -> of_day float ;; let create ?(sign = Sign.Pos) ?(day = 0) ?(hr = 0) ?(min = 0) ?(sec = 0) ?(ms = 0) ?(us = 0) ?(ns = 0) () = let ( + ) = T.( + ) in let t = of_day (Float.of_int day) + of_hr (Float.of_int hr) + of_min (Float.of_int min) + of_sec (Float.of_int sec) + of_ms (Float.of_int ms) + of_us (Float.of_int us) + of_ns (Float.of_int ns) in match sign with | Neg -> T.( - ) T.zero t | Pos | Zero -> t ;; include T include Constant let randomize t ~percent = Span_helpers.randomize t ~percent ~scale let to_short_string t = let ({ sign; hr; min; sec; ms; us; ns } : Parts.t) = to_parts t in Span_helpers.short_string ~sign ~hr ~min ~sec ~ms ~us ~ns ;; (* WARNING: if you are going to change this function in any material way, make sure you update Stable appropriately. *) let of_string_v1_v2 (s : string) ~is_v2 = try match s with | "" -> failwith "empty string" | _ -> let float n = match String.drop_suffix s n with | "" -> failwith "no number given" | s -> let v = Float.of_string s in Validate.maybe_raise (Float.validate_ordinary v); v in let len = String.length s in (match s.[Int.( - ) len 1] with | 's' -> if Int.( >= ) len 2 && Char.( = ) s.[Int.( - ) len 2] 'm' then of_ms (float 2) else if is_v2 && Int.( >= ) len 2 && Char.( = ) s.[Int.( - ) len 2] 'u' then of_us (float 2) else if is_v2 && Int.( >= ) len 2 && Char.( = ) s.[Int.( - ) len 2] 'n' then of_ns (float 2) else T.of_float (float 1) | 'm' -> of_min (float 1) | 'h' -> of_hr (float 1) | 'd' -> of_day (float 1) | _ -> if is_v2 then failwith "Time spans must end in ns, us, ms, s, m, h, or d." else failwith "Time spans must end in ms, s, m, h, or d.") with | exn -> invalid_argf "Span.of_string could not parse '%s': %s" s (Exn.to_string exn) () ;; let of_sexp_error_exn exn sexp = of_sexp_error (Exn.to_string exn) sexp exception T_of_sexp of Sexp.t * exn [@@deriving sexp] exception T_of_sexp_expected_atom_but_got of Sexp.t [@@deriving sexp] let t_of_sexp_v1_v2 sexp ~is_v2 = match sexp with | Sexp.Atom x -> (try of_string_v1_v2 x ~is_v2 with | exn -> of_sexp_error_exn (T_of_sexp (sexp, exn)) sexp) | Sexp.List _ -> of_sexp_error_exn (T_of_sexp_expected_atom_but_got sexp) sexp ;; let string ~is_v2 suffix float = if is_v2 (* This is the same float-to-string conversion used in [Float.sexp_of_t]. It's like [Float.to_string], but may leave off trailing period. *) then !Sexplib.Conv.default_string_of_float float ^ suffix else sprintf "%g%s" float suffix ;; (* WARNING: if you are going to change this function in any material way, make sure you update Stable appropriately. *) (* I'd like it to be the case that you could never construct an infinite span, but I can't think of a good way to enforce it. So this to_string function can produce strings that will raise an exception when they are fed to of_string *) let to_string_v1_v2 (t : T.t) ~is_v2 = (* this is a sad broken abstraction... *) let module C = Float.Class in match Float.classify (t :> float) with | C.Subnormal | C.Zero -> "0s" | C.Infinite -> if T.( > ) t T.zero then "inf" else "-inf" | C.Nan -> "nan" | C.Normal -> let ( < ) = T.( < ) in let abs_t = T.of_float (Float.abs (t :> float)) in if is_v2 && abs_t < T.Constant.microsecond then string ~is_v2 "ns" (to_ns t) else if is_v2 && abs_t < T.Constant.millisecond then string ~is_v2 "us" (to_us t) else if abs_t < T.Constant.second then string ~is_v2 "ms" (to_ms t) else if abs_t < T.Constant.minute then string ~is_v2 "s" (to_sec t) else if abs_t < T.Constant.hour then string ~is_v2 "m" (to_min t) else if abs_t < T.Constant.day then string ~is_v2 "h" (to_hr t) else string ~is_v2 "d" (to_day t) ;; let sexp_of_t_v1_v2 t ~is_v2 = Sexp.Atom (to_string_v1_v2 t ~is_v2) let t_of_sexp sexp = t_of_sexp_v1_v2 sexp ~is_v2:false let sexp_of_t t = sexp_of_t_v1_v2 t ~is_v2:false let t_sexp_grammar = Sexplib.Sexp_grammar.coerce String.t_sexp_grammar end module V2 = struct include V1 let t_of_sexp sexp = t_of_sexp_v1_v2 sexp ~is_v2:true let sexp_of_t t = sexp_of_t_v1_v2 t ~is_v2:true end module V3 = struct include V1 let to_unit_of_time t : Unit_of_time.t = let open T in let open Constant in let abs_t = T.abs t in if abs_t >= day then Day else if abs_t >= hour then Hour else if abs_t >= minute then Minute else if abs_t >= second then Second else if abs_t >= millisecond then Millisecond else if abs_t >= microsecond then Microsecond else Nanosecond ;; let of_unit_of_time : Unit_of_time.t -> T.t = let open T.Constant in function | Nanosecond -> nanosecond | Microsecond -> microsecond | Millisecond -> millisecond | Second -> second | Minute -> minute | Hour -> hour | Day -> day ;; let suffix_of_unit_of_time unit_of_time = match (unit_of_time : Unit_of_time.t) with | Nanosecond -> "ns" | Microsecond -> "us" | Millisecond -> "ms" | Second -> "s" | Minute -> "m" | Hour -> "h" | Day -> "d" ;; module Of_string = struct let invalid_string string ~reason = let message = "Time.Span.of_string: " ^ reason in raise_s [%message message string] ;; let rec find_unit_of_time_by_suffix string ~index unit_of_time_list = match unit_of_time_list with | [] -> invalid_string string ~reason:"invalid span part suffix" | unit_of_time :: rest -> let suffix = suffix_of_unit_of_time unit_of_time in if String.is_substring_at string ~pos:index ~substring:suffix then unit_of_time else find_unit_of_time_by_suffix string ~index rest ;; let parse_suffix string ~index = (* We rely on the fact that "ms" comes before "m" in [Unit_of_time.all] to get a correct match on millisecond timestamps. This assumption is demonstrated in the expect test below. *) find_unit_of_time_by_suffix string ~index Unit_of_time.all ;; (* We validate magnitude strings so that we know where the unit-of-time suffix begins, and so that only sensible strings are allowed. We do not want to be as permissive as [Float.of_string]; for example, hexadecimal span magnitudes are not allowed. After validation, we still use [Float.of_string] to produce the actual value. *) module Float_parser = struct (* [In_decimal_have_digit] includes having a digit before the decimal point. *) type state = | In_integer_need_digit | In_integer_have_digit | In_decimal_need_digit | In_decimal_have_digit | In_exponent_need_digit_or_sign | In_exponent_need_digit | In_exponent_have_digit type token = | Digit | Point | Under | Sign | Expt let state_is_final = function | In_integer_have_digit | In_decimal_have_digit | In_exponent_have_digit -> true | In_integer_need_digit | In_decimal_need_digit | In_exponent_need_digit_or_sign | In_exponent_need_digit -> false ;; let token_of_char = function | '0' .. '9' -> Some Digit | '.' -> Some Point | '_' -> Some Under | '-' | '+' -> Some Sign | 'E' | 'e' -> Some Expt | _ -> None ;; let invalid_string string = invalid_string string ~reason:"invalid span part magnitude" ;; let rec find_index_after_float_in_state string ~index ~len ~state = let open Int.O in if index = len then if state_is_final state then index else invalid_string string else ( match token_of_char string.[index] with | None -> if state_is_final state then index else invalid_string string | Some token -> let state = match state, token with | In_integer_need_digit, Digit -> In_integer_have_digit | In_integer_need_digit, Point -> In_decimal_need_digit | In_integer_need_digit, Under | In_integer_need_digit, Sign | In_integer_need_digit, Expt -> invalid_string string | In_integer_have_digit, Digit | In_integer_have_digit, Under -> In_integer_have_digit | In_integer_have_digit, Point -> In_decimal_have_digit | In_integer_have_digit, Expt -> In_exponent_need_digit_or_sign | In_integer_have_digit, Sign -> invalid_string string | In_decimal_need_digit, Digit -> In_decimal_have_digit | In_decimal_need_digit, Point | In_decimal_need_digit, Under | In_decimal_need_digit, Expt | In_decimal_need_digit, Sign -> invalid_string string | In_decimal_have_digit, Digit | In_decimal_have_digit, Under -> In_decimal_have_digit | In_decimal_have_digit, Expt -> In_exponent_need_digit_or_sign | In_decimal_have_digit, Point | In_decimal_have_digit, Sign -> invalid_string string | In_exponent_need_digit_or_sign, Digit -> In_exponent_have_digit | In_exponent_need_digit_or_sign, Sign -> In_exponent_need_digit | In_exponent_need_digit_or_sign, Point | In_exponent_need_digit_or_sign, Under | In_exponent_need_digit_or_sign, Expt -> invalid_string string | In_exponent_need_digit, Digit -> In_exponent_have_digit | In_exponent_need_digit, Point | In_exponent_need_digit, Under | In_exponent_need_digit, Expt | In_exponent_need_digit, Sign -> invalid_string string | In_exponent_have_digit, Digit | In_exponent_have_digit, Under -> In_exponent_have_digit | In_exponent_have_digit, Point | In_exponent_have_digit, Expt | In_exponent_have_digit, Sign -> invalid_string string in find_index_after_float_in_state string ~index:(index + 1) ~len ~state) ;; let find_index_after_float string ~index ~len = find_index_after_float_in_state string ~index ~len ~state:In_integer_need_digit ;; end let rec accumulate_magnitude string ~magnitude ~index ~len = if Int.equal index len then magnitude else ( let suffix_index = Float_parser.find_index_after_float string ~index ~len in let unit_of_time = parse_suffix string ~index:suffix_index in let until_index = Int.( + ) suffix_index (String.length (suffix_of_unit_of_time unit_of_time)) in let float_string = String.sub string ~pos:index ~len:(Int.( - ) suffix_index index) in let float = Float.of_string float_string in let magnitude = magnitude + scale_by_unit_of_time float unit_of_time in accumulate_magnitude string ~magnitude ~index:until_index ~len) ;; let parse_magnitude string ~index ~len = accumulate_magnitude string ~magnitude:T.zero ~index ~len ;; let of_string string = let open Int.O in match string with | "NANs" -> of_sec Float.nan | "-INFs" -> of_sec Float.neg_infinity | "INFs" -> of_sec Float.infinity | _ -> let len = String.length string in if len = 0 then invalid_string string ~reason:"empty input"; let negative, index = match string.[0] with | '-' -> true, 1 | '+' -> false, 1 | _ -> false, 0 in if index >= len then invalid_string string ~reason:"empty input"; let magnitude = parse_magnitude string ~index ~len in if negative then T.neg magnitude else magnitude ;; end let of_string = Of_string.of_string module To_string = struct let string_of_float_without_trailing_decimal float = let string = Float.to_string float in let suffix = "." in if String.is_suffix string ~suffix then String.chop_suffix_exn string ~suffix else string ;; (* As we build up a string, we keep a running sum of the value that will be read back in, so that we can compute the remainder that needs to be generated. *) let sum ~sum_t ~unit_of_time ~magnitude = sum_t + scale_by_unit_of_time magnitude unit_of_time ;; (* For some units (very large numbers of days, or seconds and smaller) we just render a float directly, with a fix for roundoff error. *) let to_float_string ~abs_t ~unit_of_time ~fixup_unit_of_time = let magnitude = divide_by_unit_of_time abs_t unit_of_time in let sum_t = sum ~sum_t:zero ~unit_of_time ~magnitude in if sum_t = abs_t then string_of_float_without_trailing_decimal magnitude ^ suffix_of_unit_of_time unit_of_time else ( let magnitude = if sum_t < abs_t then magnitude else divide_by_unit_of_time (prev abs_t) unit_of_time in let sum_t = sum ~sum_t:zero ~unit_of_time ~magnitude in let rem_t = abs_t - sum_t in let fixup_magnitude = divide_by_unit_of_time rem_t fixup_unit_of_time in string_of_float_without_trailing_decimal magnitude ^ suffix_of_unit_of_time unit_of_time (* [rem_t] is at ULP size of [abs_t], it needs just one bit of precision *) ^ sprintf "%.1g" fixup_magnitude ^ suffix_of_unit_of_time fixup_unit_of_time) ;; (* For non-decimal units (minutes and greater), we render an integer magnitude, and return that with the running sum so the remainder can be rendered at a smaller unit. *) let to_int_string_and_sum unit_of_time ~abs_t ~sum_t = let unit_span = of_unit_of_time unit_of_time in let rem_t = abs_t - sum_t in (* We calculate the approximate multiple of [unit_of_time] that needs to be added to [sum_t]. Due to rounding, this can be off by one (we've never seen a case off by two or more), so we re-compute the remainder and correct if necessary. *) let magnitude = Float.round_down (rem_t // unit_span) in let new_sum_t = sum ~sum_t ~unit_of_time ~magnitude in let new_rem_t = abs_t - new_sum_t in let magnitude = if new_rem_t = zero then magnitude else if new_rem_t < zero then magnitude -. 1. else ( let next_magnitude = magnitude +. 1. in let next_sum_t = sum ~sum_t ~unit_of_time ~magnitude:next_magnitude in let next_rem_t = abs_t - next_sum_t in if next_rem_t < zero then magnitude else next_magnitude) in if Float.( <= ) magnitude 0. then "", sum_t else ( let new_sum_t = sum ~sum_t ~unit_of_time ~magnitude in let string = Int63.to_string (Int63.of_float magnitude) ^ suffix_of_unit_of_time unit_of_time in string, new_sum_t) ;; let decimal_order_of_magnitude t = Float.log10 (to_sec t) (* The final seconds-or-smaller unit needs to be printed with enough digits to round-trip the whole span (which is minutes or greater); this can be significantly fewer digits than would be needed for the seconds-or-smaller remainder itself. *) let to_float_string_after_int_strings ~sum_t ~abs_t = if sum_t >= abs_t then "" else ( let rem_t = abs_t - sum_t in let unit_of_time = to_unit_of_time rem_t in let unit_span = of_unit_of_time unit_of_time in let magnitude = rem_t // unit_span in let new_sum_t = sum ~sum_t ~unit_of_time ~magnitude in let new_rem_t = abs_t - new_sum_t in if abs rem_t <= abs new_rem_t then "" else ( let order_of_magnitude_of_first_digit = Float.iround_down_exn (decimal_order_of_magnitude rem_t) in let half_ulp = (abs_t - prev abs_t) / 2. in let order_of_magnitude_of_final_digit = (* This works out to rounding down, except in the case of exact integers, which are decremented. This makes sure we always stop at a digit with strictly more precision than half the ULP. *) Int.pred (Float.iround_up_exn (decimal_order_of_magnitude half_ulp)) in let number_of_digits = let open Int.O in 1 + order_of_magnitude_of_first_digit - order_of_magnitude_of_final_digit in let suffix = suffix_of_unit_of_time unit_of_time in sprintf "%.*g" number_of_digits magnitude ^ suffix)) ;; (* This helper avoids unnecessary allocation, because for our use below, it is common to have either or both arguments be empty. Currently (2018-02), the built-in [^] allocates even when appending to an empty string. *) let ( ^? ) x y = if String.is_empty x then y else if String.is_empty y then x else x ^ y ;; let to_string t = let float = to_float t in if not (Float.is_finite float) then if (* We print specific special strings for non-finite floats *) Float.is_nan float then "NANs" else if Float.is_negative float then "-INFs" else "INFs" else if t = zero then "0s" else ( let unit_of_time = to_unit_of_time t in let abs_t = abs t in let sign = if t < zero then "-" else "" in let magnitude_string = match unit_of_time with (* We can use normal float notation for seconds and sub-second units, they are readable with a decimal point. *) | Nanosecond | Microsecond | Millisecond | Second -> to_float_string ~abs_t ~unit_of_time ~fixup_unit_of_time:Nanosecond (* For large enough values that the ULP is a day or more, we can use float notation because we are expressing a single, very large integer. *) | Day when next abs_t - abs_t >= day -> to_float_string ~abs_t ~unit_of_time ~fixup_unit_of_time:Day (* For everything in between, we need to use integer units of days, hours, and/or minutes, because those units are not readable as decimals, and we tack on a decimal remainder of a seconds-or-smaller unit if necessary. *) | Minute | Hour | Day -> let sum_t = zero in let day_string, sum_t = to_int_string_and_sum ~abs_t ~sum_t Day in let hour_string, sum_t = to_int_string_and_sum ~abs_t ~sum_t Hour in let minute_string, sum_t = to_int_string_and_sum ~abs_t ~sum_t Minute in let float_string = to_float_string_after_int_strings ~abs_t ~sum_t in day_string ^? hour_string ^? minute_string ^? float_string in sign ^? magnitude_string) ;; end let to_string = To_string.to_string let sexp_of_t t = Sexp.Atom (to_string t) let t_of_sexp s = match s with | Sexp.Atom x -> (try of_string x with | exn -> of_sexp_error (Exn.to_string exn) s) | Sexp.List _ -> of_sexp_error "Time.Span.Stable.V3.t_of_sexp: sexp must be an Atom" s ;; let t_sexp_grammar = Sexplib.Sexp_grammar.coerce String.t_sexp_grammar end end include Stable.V3 let to_proportional_float = to_float let to_string_hum ?(delimiter = '_') ?(decimals = 3) ?(align_decimal = false) ?unit_of_time t = let float, suffix = match Option.value unit_of_time ~default:(to_unit_of_time t) with | Day -> to_day t, "d" | Hour -> to_hr t, "h" | Minute -> to_min t, "m" | Second -> to_sec t, "s" | Millisecond -> to_ms t, "ms" | Microsecond -> to_us t, "us" | Nanosecond -> to_ns t, "ns" in let prefix = Float.to_string_hum float ~delimiter ~decimals ~strip_zero:(not align_decimal) in let suffix = if align_decimal && Int.( = ) (String.length suffix) 1 then suffix ^ " " else suffix in prefix ^ suffix ;; let gen_incl lo hi = Float.gen_incl (to_sec lo) (to_sec hi) |> Quickcheck.Generator.map ~f:of_sec ;; let gen_uniform_incl lo hi = (* Technically exclusive rather than inclusive, but otherwise satisfies the contract to within 1ulp of the given bounds. *) Float.gen_uniform_excl (to_sec lo) (to_sec hi) |> Quickcheck.Generator.map ~f:of_sec ;; let quickcheck_generator = (* We generate spans up to (slightly more than) a millenium, positive or negative. This is based on the Gregorian calendar, in which years average 365.2425 days when accounting for leap days. Covering a two-millenium span is more than enough for most practical purposes, certainly more than enough to cover the representable range of [Span_ns], and results in finite spans and times that can be serialized. We generate by filtering the default generator so that spans are still skewed toward small values, even though the bounds are large. *) let millenium = of_day (Float.round_up (365.2425 *. 1000.)) in Quickcheck.Generator.filter quickcheck_generator ~f:(fun t -> neg millenium <= t && t <= millenium) ;; include Pretty_printer.Register (struct type nonrec t = t let to_string = to_string let module_name = "Core.Time.Span" end) include Hashable.Make_binable (struct type nonrec t = t [@@deriving bin_io, compare, hash, sexp_of] (* Previous versions rendered hash-based containers using float serialization rather than time serialization, so when reading hash-based containers in we accept either serialization. *) let t_of_sexp sexp = match Float.t_of_sexp sexp with | float -> of_float float | exception _ -> t_of_sexp sexp ;; end) module C = struct type t = T.t [@@deriving bin_io] type comparator_witness = T.comparator_witness let comparator = T.comparator (* In 108.06a and earlier, spans in sexps of Maps and Sets were raw floats. From 108.07 through 109.13, the output format remained raw as before, but both the raw and pretty format were accepted as input. From 109.14 on, the output format was changed from raw to pretty, while continuing to accept both formats. Once we believe most programs are beyond 109.14, we will switch the input format to no longer accept raw. *) let sexp_of_t = sexp_of_t let t_of_sexp sexp = match Option.try_with (fun () -> T.of_float (Float.t_of_sexp sexp)) with | Some t -> t | None -> t_of_sexp sexp ;; end module Map = Map.Make_binable_using_comparator (C) module Set = Set.Make_binable_using_comparator (C) include Comparable.With_zero (struct type nonrec t = t [@@deriving compare, sexp_of] let zero = zero end) module Private = struct let suffix_of_unit_of_time = suffix_of_unit_of_time let parse_suffix = Stable.V3.Of_string.parse_suffix end core-0.15.0/core/src/span_float.mli000066400000000000000000000023571420273305200171020ustar00rootroot00000000000000open! Import include Span_intf.S with type underlying = float module Stable : sig (** [V1]'s sexps use single-unit format and support units from [d] to [ms]; it does not support [us] or [ns]. [V1]'s sexp conversions do not round-trip precisely. *) module V1 : sig type nonrec t = t [@@deriving sexp, sexp_grammar, bin_io, compare, hash, equal] end (** [V2]'s sexps use single-unit format and support units from [d] to [ns]. [V2] can read [V1] sexps but not vice versa. [V2]'s sexp conversions do not round-trip precisely. *) module V2 : sig type nonrec t = t [@@deriving sexp, sexp_grammar, bin_io, compare, hash, equal] end (** [V3] uses mixed-unit format and supports units from [d] to [ns]. [V3] can read [V2] and [V1] sexps but not vice versa. [V3]'s sexp conversions round-trip precisely. *) module V3 : sig type nonrec t = t [@@deriving sexp, sexp_grammar, bin_io, compare, hash, typerep, equal] end end (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig val parse_suffix : string -> index:int -> Unit_of_time.t val suffix_of_unit_of_time : Unit_of_time.t -> string end core-0.15.0/core/src/span_helpers.ml000066400000000000000000000021441420273305200172600ustar00rootroot00000000000000open! Import open Std_internal let randomize span ~percent ~scale = let mult = Percent.to_mult percent in if Float.( < ) mult 0. || Float.( > ) mult 1. then raise_s [%message "Span.randomize: percent is out of range [0x, 1x]" (percent : Percent.t)]; let factor = Random.float_range (1. -. mult) (Float.one_ulp `Up (1. +. mult)) in scale span factor ;; let format_decimal n tenths units = assert (tenths >= 0 && tenths < 10); if n < 10 && tenths <> 0 then sprintf "%d.%d%s" n tenths units else sprintf "%d%s" n units ;; let short_string ~sign ~hr ~min ~sec ~ms ~us ~ns = let s = if hr >= 24 then format_decimal (hr / 24) (Int.of_float (Float.of_int (hr % 24) /. 2.4)) "d" else if hr > 0 then format_decimal hr (min / 6) "h" else if min > 0 then format_decimal min (sec / 6) "m" else if sec > 0 then format_decimal sec (ms / 100) "s" else if ms > 0 then format_decimal ms (us / 100) "ms" else if us > 0 then format_decimal us (ns / 100) "us" else sprintf "%ins" ns in match (sign : Sign.t) with | Neg -> "-" ^ s | Zero | Pos -> s ;; core-0.15.0/core/src/span_helpers.mli000066400000000000000000000003361420273305200174320ustar00rootroot00000000000000open! Import val randomize : 'span -> percent:Percent.t -> scale:('span -> float -> 'span) -> 'span val short_string : sign:Sign.t -> hr:int -> min:int -> sec:int -> ms:int -> us:int -> ns:int -> string core-0.15.0/core/src/span_intf.ml000066400000000000000000000150521420273305200165600ustar00rootroot00000000000000open! Import open Std_internal (** Parts represents the individual parts of a Span as if it were written out (it is the counterpart to [Span.create]). For example, 90 seconds is represented by: {[ {sign = Pos; hr = 0; min = 1; sec = 30; ms = 0; ns = 0} ]} The fields will always be non-negative, and will never be large enough to form the next larger unit (e.g., [min < 60]). *) module type Parts = sig type t = private { sign : Sign.t ; hr : int ; min : int ; sec : int ; ms : int ; us : int ; ns : int } [@@deriving compare, sexp, sexp_grammar] end module type S = sig (** Span.t represents a span of time (e.g. 7 minutes, 3 hours, 12.8 days). The span may be positive or negative. *) type underlying type t = private underlying [@@deriving bin_io, hash, sexp, sexp_grammar, typerep] module Parts : Parts include Comparable_binable with type t := t include Comparable.With_zero with type t := t include Hashable_binable with type t := t include Pretty_printer.S with type t := t include Robustly_comparable with type t := t include Quickcheck.S_range with type t := t (** Time spans are denominated as a float suffixed by a unit of time; the valid suffixes are listed below: d - days h - hours m - minutes s - seconds ms - milliseconds us - microseconds ns - nanoseconds [to_string] and [sexp_of_t] use a mixed-unit format, which breaks the input span into parts and concatenates them in descending order of unit size. For example, pi days is rendered as "3d3h23m53.60527015815s". If the span is negative, a single "-" precedes the entire string. For extremely large (>10^15 days) or small (<1us) spans, a unit may be repeated to ensure the string conversion round-trips. [of_string] and [t_of_sexp] accept any combination of (nonnegative float string)(unit of time suffix) in any order, without spaces, and sums up the durations of each of the parts for the magnitude of the span. The input may be prefixed by "-" for negative spans. String and sexp conversions round-trip precisely, that is: {[ Span.of_string (Span.to_string t) = t ]} *) val to_string : t -> string val of_string : string -> t (** {6 values} *) val nanosecond : t val microsecond : t val millisecond : t val second : t val minute : t val hour : t val day : t (** 10^-6 seconds, used in robustly comparable operators (<., >., =., ...) to determine equality *) val robust_comparison_tolerance : t val zero : t (** [?sign] defaults to positive. Setting it to negative is equivalent to negating all the integers. *) val create : ?sign:Sign.t -> ?day:int -> ?hr:int -> ?min:int -> ?sec:int -> ?ms:int -> ?us:int -> ?ns:int -> unit -> t val to_parts : t -> Parts.t (** {6 converters} *) val of_ns : float -> t val of_us : float -> t val of_ms : float -> t val of_sec : float -> t val of_int_sec : int -> t val of_int32_seconds : Int32.t -> t val of_int63_seconds : Int63.t -> t val of_min : float -> t val of_hr : float -> t val of_day : float -> t val to_ns : t -> float val to_us : t -> float val to_ms : t -> float val to_sec : t -> float val to_min : t -> float val to_hr : t -> float val to_day : t -> float (** [to_int63_seconds_round_down_exn t] returns the number of seconds represented by [t], rounded down, raising if the result is not representable as an [Int63.t]. *) val to_int63_seconds_round_down_exn : t -> Int63.t (** The only condition [to_proportional_float] is supposed to satisfy is that for all [t1, t2 : t]: [to_proportional_float t1 /. to_proportional_float t2 = t1 // t2]. *) val to_proportional_float : t -> float (** {6 Basic operations on spans} The arithmetic operations rely on the behavior of the underlying representation of a span. For example, if addition overflows with float-represented spans, the result is an infinite span; with fixed-width integer-represented spans, the result silently wraps around as in two's-complement arithmetic. *) val ( + ) : t -> t -> t val ( - ) : t -> t -> t (** absolute value *) val abs : t -> t (** negation *) val neg : t -> t val scale : t -> float -> t val ( / ) : t -> float -> t val ( // ) : t -> t -> float (** [next t] is the smallest representable span greater than [t] (and therefore representation-dependent) *) val next : t -> t (** [prev t] is the largest representable span less than [t] (and therefore representation-dependent) *) val prev : t -> t (** [to_short_string t] pretty-prints approximate time span using no more than five characters if the span is positive, and six if the span is negative. Examples {ul {li ["4h"] = 4 hours} {li ["5m"] = 5 minutes} {li ["4s"] = 4 seconds} {li ["10ms"] = 10 milliseconds} } only the most significant denomination is shown. *) val to_short_string : t -> string (** [to_unit_of_time t] = [Day] if [abs t >= day], [Hour] if [abs t >= hour], and so on down to [Microsecond] if [abs t >= microsecond], and [Nanosecond] otherwise. *) val to_unit_of_time : t -> Unit_of_time.t (** [of_unit_of_time unit_of_time] produces a [t] representing the corresponding span. *) val of_unit_of_time : Unit_of_time.t -> t (** [to_string_hum t ~delimiter ~decimals ~align_decimal ~unit_of_time] formats [t] using the given unit of time, or the largest appropriate units if none is specified, among "d"=day, "h"=hour, "m"=minute, "s"=second, "ms"=millisecond, "us"=microsecond, or "ns"=nanosecond. The magnitude of the time span in the chosen unit is formatted by: [Float.to_string_hum ~delimiter ~decimals ~strip_zero:(not align_decimal)] If [align_decimal] is true, the single-character suffixes are padded with an extra space character. In combination with not stripping zeroes, this means that the decimal point will occur a fixed number of characters from the end of the string. *) val to_string_hum : ?delimiter:char (** defaults to ['_'] *) -> ?decimals:int (** defaults to 3 *) -> ?align_decimal:bool (** defaults to [false] *) -> ?unit_of_time:Unit_of_time.t (** defaults to [to_unit_of_time t] *) -> t -> string (** [randomize t ~percent] returns a span +/- percent * original span. Percent must be between 0% and 100% inclusive, and must be positive. *) val randomize : t -> percent:Percent.t -> t end core-0.15.0/core/src/span_ns.ml000066400000000000000000000674611420273305200162530ustar00rootroot00000000000000open! Import open Std_internal open! Int63.O let module_name = "Core.Time_ns.Span" type underlying = Int63.t let arch_sixtyfour = Int.equal Sys.word_size_in_bits 64 let round_nearest = Float.int63_round_nearest_exn let float x = Int63.to_float x (* [Span] is basically a [Int63]. It even silently ignores overflow. *) module T = struct type t = Int63.t (* nanoseconds *) [@@deriving hash, bin_io, quickcheck, typerep] module Replace_polymorphic_compare = Int63.Replace_polymorphic_compare let zero = Int63.zero end include T open Replace_polymorphic_compare module Parts = struct type t = { sign : Sign.t ; hr : int ; min : int ; sec : int ; ms : int ; us : int ; ns : int } [@@deriving compare, sexp, sexp_grammar] end let next t = Int63.succ t let prev t = Int63.pred t let nanosecond = Int63.of_int 1 let microsecond = Int63.(of_int 1000 * nanosecond) let millisecond = Int63.(of_int 1000 * microsecond) let second = Int63.(of_int 1000 * millisecond) let minute = Int63.(of_int 60 * second) let hour = Int63.(of_int 60 * minute) let day = Int63.(of_int 24 * hour) (* Beyond [min_value_for_1us_rounding..max_value_for_1us_rounding], not every microsecond can be represented as a [float] number of seconds. (In fact, it is around 135y, but we leave a small margin.) In the presence of silently ignored overflow, note that [t] is not actually bound to stay between these limits. *) let max_value_for_1us_rounding = Int63.(of_int 135 * of_int 365 * day) let min_value_for_1us_rounding = Int63.neg max_value_for_1us_rounding let create ?sign:(sign_ = Sign.Pos (* rebind so not shadowed by [open Int63] below *)) ?day:(days = 0) ?(hr = 0) ?min:(minutes = 0) ?(sec = 0) ?(ms = 0) ?(us = 0) ?(ns = 0) () = let open Int63 in let t = (of_int days * day) + (of_int hr * hour) + (of_int minutes * minute) + (of_int sec * second) + (of_int ms * millisecond) + (of_int us * microsecond) + (of_int ns * nanosecond) in match sign_ with | Neg -> neg t | Pos | Zero -> t ;; let to_parts t = let open Int63 in let mag = abs t in { Parts.sign = (if t < zero then Neg else if t > zero then Pos else Zero) ; hr = to_int_exn (mag / hour) ; min = to_int_exn (rem mag hour / minute) ; sec = to_int_exn (rem mag minute / second) ; ms = to_int_exn (rem mag second / millisecond) ; us = to_int_exn (rem mag millisecond / microsecond) ; ns = to_int_exn (rem mag microsecond / nanosecond) } ;; let of_parts { Parts.sign; hr; min; sec; ms; us; ns } = create ~sign ~hr ~min ~sec ~ms ~us ~ns () ;; let of_ns f = round_nearest f let of_int63_ns i = i let of_int_us i = Int63.(of_int i * microsecond) let of_int_ms i = Int63.(of_int i * millisecond) let of_int_sec i = Int63.(of_int i * second) let of_us f = round_nearest (f *. float microsecond) let of_ms f = round_nearest (f *. float millisecond) let of_sec f = round_nearest (f *. float second) let of_min f = round_nearest (f *. float minute) let of_hr f = round_nearest (f *. float hour) let of_day f = round_nearest (f *. float day) let of_sec_with_microsecond_precision sec = let us = round_nearest (sec *. 1e6) in of_int63_ns Int63.(us * of_int 1000) ;; let of_int63_seconds x = x * second let of_int32_seconds x = of_int63_seconds (Int63.of_int32 x) let to_ns t = float t let to_int63_ns t = t let to_us t = float t /. float microsecond let to_ms t = float t /. float millisecond let to_sec t = float t /. float second let to_min t = float t /. float minute let to_hr t = float t /. float hour let to_day t = float t /. float day let to_int_us t = Int63.(to_int_exn (t / microsecond)) let to_int_ms t = Int63.(to_int_exn (t / millisecond)) let to_int_sec t = Int63.(to_int_exn (t / second)) let to_int63_seconds_round_down_exn t = t /% second let of_int_ns i = of_int63_ns (Int63.of_int i) let to_int_ns = if arch_sixtyfour then fun t -> Int63.to_int_exn (to_int63_ns t) else fun _ -> failwith "Time_ns.Span.to_int_ns: unsupported on 32bit machines" ;; let ( + ) t u = Int63.( + ) t u let ( - ) t u = Int63.( - ) t u let abs = Int63.abs let neg = Int63.neg let scale t f = round_nearest (float t *. f) let scale_int63 t i = Int63.( * ) t i let scale_int t i = scale_int63 t (Int63.of_int i) let div = Int63.( /% ) let ( / ) t f = round_nearest (float t /. f) let ( // ) = Int63.( // ) let to_proportional_float t = Int63.to_float t let of_unit_of_time u = match (u : Unit_of_time.t) with | Nanosecond -> nanosecond | Microsecond -> microsecond | Millisecond -> millisecond | Second -> second | Minute -> minute | Hour -> hour | Day -> day ;; let to_unit_of_time t : Unit_of_time.t = let abs_t = abs t in if abs_t >= day then Day else if abs_t >= hour then Hour else if abs_t >= minute then Minute else if abs_t >= second then Second else if abs_t >= millisecond then Millisecond else if abs_t >= microsecond then Microsecond else Nanosecond ;; module Stable = struct module V1 = struct end module Option = struct end module V2 = struct module T = struct module T0 = struct type nonrec t = t [@@deriving bin_io, compare, hash, equal] let of_int63_exn t = of_int63_ns t let to_int63 t = to_int63_ns t module To_string = struct let number_of_digits_to_write ~span_part_magnitude = let open Int.O in if span_part_magnitude = 0 then 0 else if span_part_magnitude < 10 then 1 else if span_part_magnitude < 100 then 2 else if span_part_magnitude < 1_000 then 3 else if span_part_magnitude < 10_000 then 4 else if span_part_magnitude < 100_000 then 5 else assert false ;; (* span part magnitudes are always < 100_000 *) let number_of_decimal_places_to_write ~billionths = let open Int.O in assert (billionths >= 0 && billionths <= 999_999_999); if billionths = 0 then 0 else if billionths % 10 <> 0 then 9 else if billionths % 100 <> 0 then 8 else if billionths % 1_000 <> 0 then 7 else if billionths % 10_000 <> 0 then 6 else if billionths % 100_000 <> 0 then 5 else if billionths % 1_000_000 <> 0 then 4 else if billionths % 10_000_000 <> 0 then 3 else if billionths % 100_000_000 <> 0 then 2 else 1 ;; let write_char buf ~pos char = let open Int.O in Bytes.unsafe_set buf pos char; pos + 1 ;; let write_2_chars buf ~pos char1 char2 = let open Int.O in Bytes.unsafe_set buf pos char1; Bytes.unsafe_set buf (pos + 1) char2; pos + 2 ;; let write_digits buf ~pos ~digits int = let open Int.O in Digit_string_helpers.write_int63 buf ~pos ~digits (Int63.of_int int); pos + digits ;; let write_decimals buf ~pos ~decimals ~billionths = let open Int.O in Digit_string_helpers.write_int63 buf ~pos ~digits:decimals (Int63.of_int (billionths / Int.pow 10 (9 - decimals))); pos + decimals ;; let write_if_non_empty buf ~pos ~digits int suffix = let open Int.O in if digits = 0 then pos else ( let pos = write_digits buf ~pos ~digits int in let pos = write_char buf ~pos suffix in pos) ;; let nanos_of_millisecond = to_int63_ns millisecond |> Int63.to_int_exn let nanos_of_microsecond = to_int63_ns microsecond |> Int63.to_int_exn let int63_60 = Int63.of_int 60 let int63_24 = Int63.of_int 24 (* Units of seconds and smaller can be written in decimal notation without worrying about non-power-of-ten factors. *) module Decimal_unit = struct type t = | Second | Millisecond | Microsecond | Nanosecond | None [@@deriving compare, sexp_of] let create ~s ~ns = let open Int.O in if s > 0 then Second else if ns >= nanos_of_millisecond then Millisecond else if ns >= nanos_of_microsecond then Microsecond else if ns >= 1 then Nanosecond else None ;; let integer t ~s ~ns = let open Int.O in match t with | Second -> s | Millisecond -> ns / nanos_of_millisecond | Microsecond -> ns / nanos_of_microsecond | Nanosecond -> ns | None -> 0 ;; let billionths t ~ns = let open Int.O in match t with | Second -> ns | Millisecond -> ns % nanos_of_millisecond * 1_000 | Microsecond -> ns % nanos_of_microsecond * 1_000_000 | Nanosecond -> 0 | None -> 0 ;; let length t ~digits ~decimals = let open Int.O in let digits_len = match t with | Second -> digits + 1 | Millisecond | Microsecond | Nanosecond -> digits + 2 | None -> 0 in let decimals_len = if decimals > 0 then decimals + 1 else 0 in digits_len + decimals_len ;; let write_suffix t buf ~pos = match t with | Second -> write_char buf ~pos 's' | Millisecond -> write_2_chars buf ~pos 'm' 's' | Microsecond -> write_2_chars buf ~pos 'u' 's' | Nanosecond -> write_2_chars buf ~pos 'n' 's' | None -> pos ;; let write t buf ~pos ~integer ~digits ~billionths ~decimals = let open Int.O in if digits = 0 then pos else ( let pos = write_digits buf ~pos integer ~digits in let pos = if decimals = 0 then pos else ( let pos = write_char buf ~pos '.' in write_decimals buf ~pos ~billionths ~decimals) in write_suffix t buf ~pos) ;; end let to_string t = if equal t zero then "0s" else ( let is_negative = t < zero in let seconds = Int63.( / ) (to_int63_ns t) (to_int63_ns second) in let ns = Int63.rem (to_int63_ns t) (to_int63_ns second) |> Int63.to_int_exn in let seconds = Int63.abs seconds in let ns = Int.abs ns in let s = Int63.rem seconds int63_60 |> Int63.to_int_exn in let minutes = Int63.( / ) seconds int63_60 in let m = Int63.rem minutes int63_60 |> Int63.to_int_exn in let hours = Int63.( / ) minutes int63_60 in let h = Int63.rem hours int63_24 |> Int63.to_int_exn in let d = Int63.( / ) hours int63_24 |> Int63.to_int_exn in let open Int.O in let digits_of_d = number_of_digits_to_write ~span_part_magnitude:d in let digits_of_h = number_of_digits_to_write ~span_part_magnitude:h in let digits_of_m = number_of_digits_to_write ~span_part_magnitude:m in let decimal_unit = Decimal_unit.create ~s ~ns in let decimal_unit_integer = Decimal_unit.integer decimal_unit ~s ~ns in let decimal_unit_billionths = Decimal_unit.billionths decimal_unit ~ns in let digits_of_decimal_unit = number_of_digits_to_write ~span_part_magnitude:decimal_unit_integer in let decimals_of_decimal_unit = number_of_decimal_places_to_write ~billionths:decimal_unit_billionths in let string_length = let sign_len = if is_negative then 1 else 0 in let d_len = if digits_of_d > 0 then digits_of_d + 1 else 0 in let h_len = if digits_of_h > 0 then digits_of_h + 1 else 0 in let m_len = if digits_of_m > 0 then digits_of_m + 1 else 0 in let decimal_unit_len = Decimal_unit.length decimal_unit ~digits:digits_of_decimal_unit ~decimals:decimals_of_decimal_unit in sign_len + d_len + h_len + m_len + decimal_unit_len in assert (string_length > 0); let buf = Bytes.create string_length in let pos = 0 in let pos = if is_negative then write_char buf ~pos '-' else pos in let pos = write_if_non_empty buf ~pos ~digits:digits_of_d d 'd' in let pos = write_if_non_empty buf ~pos ~digits:digits_of_h h 'h' in let pos = write_if_non_empty buf ~pos ~digits:digits_of_m m 'm' in let pos = Decimal_unit.write decimal_unit buf ~pos ~integer:decimal_unit_integer ~digits:digits_of_decimal_unit ~billionths:decimal_unit_billionths ~decimals:decimals_of_decimal_unit in assert (pos = string_length); Bytes.unsafe_to_string ~no_mutation_while_string_reachable:buf) ;; end let to_string = To_string.to_string module Of_string = struct (* We do computations using negative numbers everywhere and test against things related to [Int63.min_value] rather than using positive numbers and testing against things related to [Int63.max_value] because the negative integer range is one wider than the positive integer range (-2**63 vs 2**63-1), and we need that to be able to handle Int63.min_value nicely. *) let int63_10 = Int63.of_int 10 let min_mult10_without_underflow = Int63.(min_value / int63_10) let[@cold] invalid_string string ~reason = raise_s [%message "Time_ns.Span.of_string: invalid string" (string : string) (reason : string)] ;; (* Assumes x and y are both nonpositive *) let add_without_underflow ~string x y = let open Int63.O in let sum = x + y in if sum > x then invalid_string string ~reason:"span would be outside of int63 range"; sum ;; let add_neg_digit ~string int63 char = let open Int63.O in let digit = Int63.of_int (Char.get_digit_exn char) in if int63 < min_mult10_without_underflow then invalid_string string ~reason:"span would be outside of int63 range"; add_without_underflow ~string (int63 * int63_10) (-digit) ;; let min_factor_of span = Int63.( / ) Int63.min_value (to_int63_ns span) let min_days_without_underflow = min_factor_of day let min_hours_without_underflow = min_factor_of hour let min_minutes_without_underflow = min_factor_of minute let min_seconds_without_underflow = min_factor_of second let min_milliseconds_without_underflow = min_factor_of millisecond let min_microseconds_without_underflow = min_factor_of microsecond let min_nanoseconds_without_underflow = min_factor_of nanosecond let min_without_underflow_of_unit_of_time unit_of_time = match (unit_of_time : Unit_of_time.t) with | Day -> min_days_without_underflow | Hour -> min_hours_without_underflow | Minute -> min_minutes_without_underflow | Second -> min_seconds_without_underflow | Millisecond -> min_milliseconds_without_underflow | Microsecond -> min_microseconds_without_underflow | Nanosecond -> min_nanoseconds_without_underflow ;; let negative_part string ~neg_integer ~decimal_pos ~end_pos ~unit_of_time ~round_ties_before_negating = let open Int.O in let scale = to_int63_ns (of_unit_of_time unit_of_time) in let min_without_underflow = min_without_underflow_of_unit_of_time unit_of_time in if Int63.( < ) neg_integer min_without_underflow then invalid_string string ~reason:"span would be outside of int63 range"; let neg_integer_ns = Int63.( * ) neg_integer scale in let fraction_pos = decimal_pos + 1 in if fraction_pos >= end_pos then neg_integer_ns else ( let decimal_ns = Digit_string_helpers.read_int63_decimal string ~pos:fraction_pos ~scale ~decimals:(end_pos - fraction_pos) ~allow_underscore:true ~round_ties:round_ties_before_negating in add_without_underflow ~string neg_integer_ns (Int63.( ~- ) decimal_ns)) ;; let of_string string = let open Int.O in let neg_ns = ref Int63.zero in let pos = ref 0 in let len = String.length string in if len = 0 then invalid_string string ~reason:"empty string"; let is_negative = match String.unsafe_get string !pos with | '-' -> incr pos; true | '+' -> incr pos; false | _ -> false in let round_ties_before_negating : Digit_string_helpers.Round.t = (* Ultimately, we always round parsed spans towards positive infinity when the nearest round ns are equidistant. For example, "1.5ns" is read as 2.0ns, and "-1.5ns" is read as -1ns. Since we read absolute values before applying the sign, we must choose our rounding direction based on the sign. Rounding decimal values happens before negating their magnitude. *) match is_negative with | false -> Toward_positive_infinity | true -> Toward_negative_infinity in (* Loop over parts, like "5m" in "1h5m30s" *) while !pos < len do let has_digit = ref false in let neg_integer = let i = ref Int63.zero in let end_of_digits = ref false in while !pos < len && not !end_of_digits do let c = String.unsafe_get string !pos in match c with | '0' .. '9' -> i := add_neg_digit ~string !i c; has_digit := true; incr pos | '_' -> incr pos | _ -> end_of_digits := true done; !i in let decimal_pos = !pos in if !pos < len && Char.equal '.' (String.unsafe_get string !pos) then ( incr pos; let end_of_decimals = ref false in while !pos < len && not !end_of_decimals do match String.unsafe_get string !pos with | '0' .. '9' -> has_digit := true; incr pos | '_' -> incr pos | _ -> end_of_decimals := true done); let end_pos = !pos in if not !has_digit then invalid_string string ~reason:"no digits before unit suffix"; let unit_of_time : Unit_of_time.t = if !pos + 1 < len && Char.equal 's' (String.unsafe_get string (!pos + 1)) then ( match String.unsafe_get string !pos with | 'm' -> pos := !pos + 2; Millisecond | 'u' -> pos := !pos + 2; Microsecond | 'n' -> pos := !pos + 2; Nanosecond | _ -> invalid_string string ~reason:"unparseable unit suffix") else if !pos < len then ( match String.unsafe_get string !pos with | 'd' -> incr pos; Day | 'h' -> incr pos; Hour | 'm' -> incr pos; Minute | 's' -> incr pos; Second | _ -> invalid_string string ~reason:"unparseable unit suffix") else invalid_string string ~reason:"no unit suffix after digits" in let neg_nanos_of_part = negative_part string ~neg_integer ~decimal_pos ~end_pos ~unit_of_time ~round_ties_before_negating in neg_ns := add_without_underflow ~string !neg_ns neg_nanos_of_part done; let ns = if is_negative then !neg_ns else if Int63.( = ) !neg_ns Int63.min_value then invalid_string string ~reason:"span would be outside of int63 range" else Int63.( ~- ) !neg_ns in of_int63_ns ns ;; end let of_string = Of_string.of_string let sexp_of_t t = Sexp.Atom (to_string t) let t_of_sexp sexp = match sexp with | Sexp.Atom x -> (try of_string x with | exn -> of_sexp_error (Exn.to_string exn) sexp) | Sexp.List _ -> of_sexp_error "Time_ns.Span.Stable.V2.t_of_sexp: sexp must be an Atom" sexp ;; let t_sexp_grammar = Sexplib.Sexp_grammar.coerce String.t_sexp_grammar end include T0 include Comparator.Stable.V1.Make (T0) end include T include Comparable.Stable.V1.Make (T) end end let to_string = Stable.V2.to_string let of_string = Stable.V2.of_string let sexp_of_t = Stable.V2.sexp_of_t let t_of_sexp = Stable.V2.t_of_sexp let t_sexp_grammar = Stable.V2.t_sexp_grammar module Alternate_sexp = struct type nonrec t = t [@@deriving sexp, sexp_grammar] end include Comparable.With_zero (struct type nonrec t = t [@@deriving compare, sexp] let zero = zero end) (* Functions required by [Robustly_comparable]: allows for [robust_comparison_tolerance] granularity. A microsecond is a reasonable granularity because there is very little network activity that can be measured to sub-microsecond resolution. *) let robust_comparison_tolerance = microsecond let ( >=. ) t u = t >= Int63.(u - robust_comparison_tolerance) let ( <=. ) t u = t <= Int63.(u + robust_comparison_tolerance) let ( =. ) t u = Int63.(abs (t - u)) <= robust_comparison_tolerance let ( >. ) t u = t > Int63.(u + robust_comparison_tolerance) let ( <. ) t u = t < Int63.(u - robust_comparison_tolerance) let ( <>. ) t u = Int63.(abs (t - u)) > robust_comparison_tolerance let robustly_compare t u = if t <. u then -1 else if t >. u then 1 else 0 (* We don't just convert to [Time.Span.t] and use the conversion there because our [to_span] conversion is limited to microsecond precision. *) let to_string_hum ?(delimiter = '_') ?(decimals = 3) ?(align_decimal = false) ?unit_of_time t = let float, suffix = match Option.value unit_of_time ~default:(to_unit_of_time t) with | Day -> to_day t, "d" | Hour -> to_hr t, "h" | Minute -> to_min t, "m" | Second -> to_sec t, "s" | Millisecond -> to_ms t, "ms" | Microsecond -> to_us t, "us" | Nanosecond -> to_ns t, "ns" in let prefix = Float.to_string_hum float ~delimiter ~decimals ~strip_zero:(not align_decimal) in let suffix = if align_decimal && Int.( = ) (String.length suffix) 1 then suffix ^ " " else suffix in prefix ^ suffix ;; let since_unix_epoch () = Time_now.nanoseconds_since_unix_epoch () |> of_int63_ns let random ?state () = Int63.random ?state (max_value_for_1us_rounding + Int63.one) - Int63.random ?state (neg min_value_for_1us_rounding + Int63.one) ;; let randomize t ~percent = Span_helpers.randomize t ~percent ~scale let to_short_string t = let ({ sign; hr; min; sec; ms; us; ns } : Parts.t) = to_parts t in Span_helpers.short_string ~sign ~hr ~min ~sec ~ms ~us ~ns ;; let gen_incl = Int63.gen_incl let gen_uniform_incl = Int63.gen_uniform_incl include Pretty_printer.Register (struct type nonrec t = t let to_string = to_string let module_name = module_name end) include Hashable.Make_binable (struct type nonrec t = t [@@deriving bin_io, compare, hash, sexp] end) type comparator_witness = Stable.V2.comparator_witness include Comparable.Make_binable_using_comparator (struct type nonrec t = t [@@deriving bin_io, compare, sexp] type nonrec comparator_witness = comparator_witness let comparator = Stable.V2.comparator end) (* re-include [Replace_polymorphic_compare] and its comparisons to shadow the un-inlineable ones from [Comparable] *) module Replace_polymorphic_compare = T.Replace_polymorphic_compare include Replace_polymorphic_compare let to_span_float_round_nearest t = Span_float.of_sec (to_sec t) let of_span_float_round_nearest s = of_sec (Span_float.to_sec s) let half_microsecond = Int63.of_int 500 let nearest_microsecond t = Int63.((to_int63_ns t + half_microsecond) /% of_int 1000) let[@cold] invalid_range_for_1us_rounding t = raise_s [%message "Span.t exceeds limits" (t : t) (min_value_for_1us_rounding : t) (max_value_for_1us_rounding : t)] ;; let check_range_for_1us_rounding t = if t < min_value_for_1us_rounding || t > max_value_for_1us_rounding then invalid_range_for_1us_rounding t else t ;; let to_span_float_round_nearest_microsecond t = Span_float.of_us (Int63.to_float (nearest_microsecond (check_range_for_1us_rounding t))) ;; let min_span_float_value_for_1us_rounding = to_span_float_round_nearest min_value_for_1us_rounding ;; let max_span_float_value_for_1us_rounding = to_span_float_round_nearest max_value_for_1us_rounding ;; let of_span_float_round_nearest_microsecond s = if Span_float.( > ) s max_span_float_value_for_1us_rounding || Span_float.( < ) s min_span_float_value_for_1us_rounding then failwiths ~here:[%here] "Time_ns.Span does not support this span" s [%sexp_of: Span_float.t]; (* Using [Time.Span.to_sec] (being the identity) so that we make don't apply too many conversion - Too many : `[Span.t] -> [a] -> [t]` - Only One : `[Span.t]==[a] -> [t]`. *) of_sec_with_microsecond_precision (Span_float.to_sec s) ;; let min_value_representable = of_int63_ns Int63.min_value let max_value_representable = of_int63_ns Int63.max_value module Private = struct let of_parts = of_parts let to_parts = to_parts end (* Legacy definitions based on rounding to the nearest microsecond. *) let min_value = min_value_for_1us_rounding let max_value = max_value_for_1us_rounding let of_span = of_span_float_round_nearest_microsecond let to_span = to_span_float_round_nearest_microsecond let arg_type = `Use_Time_ns_unix module Option = struct end core-0.15.0/core/src/span_ns.mli000066400000000000000000000012161420273305200164060ustar00rootroot00000000000000open! Import open Std_internal include Time_ns_intf.Span module Stable : sig module V1 : sig end [@@deprecated "[since 2021-02] Use [Time_ns_unix.Stable]"] module Option : sig end [@@deprecated "[since 2021-02] Use [Time_ns_unix.Stable]"] module V2 : sig type nonrec t = t [@@deriving hash, equal] type nonrec comparator_witness = comparator_witness include Stable_int63able with type t := t with type comparator_witness := comparator_witness include Comparable.Stable.V1.S with type comparable := t with type comparator_witness := comparator_witness include Stringable.S with type t := t end end core-0.15.0/core/src/stable.ml000066400000000000000000000037451420273305200160570ustar00rootroot00000000000000module Unit_test = Stable_unit_test.Make module type Stable = Stable_module_types.S0 module type Stable_without_comparator = Stable_module_types.S0_without_comparator module type Stable1 = Stable_module_types.S1 module type Stable2 = Stable_module_types.S2 module type Stable3 = Stable_module_types.S3 module type Stable4 = Stable_module_types.S4 module Make_stable = Make_stable include Stable_internal module Hashable = Hashable.Stable module Bigstring = Bigstring.Stable module Binable = Binable.Stable module Blang = Blang.Stable module Bool = Bool.Stable module Byte_units = Byte_units.Stable module Bytes = Bytes.Stable module Comparable = Comparable.Stable module Comparator = Comparator.Stable module Date = Date.Stable module Day_of_week = Day_of_week.Stable module Md5 = Md5.Stable module Either = Either.Stable module Error = Error.Stable module Fdeque = Fdeque.Stable module Filename = Filename.Stable module Float_with_finite_only_serialization = Float_with_finite_only_serialization.Stable module Fqueue = Fqueue.Stable module Gc = Gc.Stable module Host_and_port = Host_and_port.Stable module Info = Info.Stable module Int = Int.Stable module Int63 = Int63.Stable module Lazy = Lazy.Stable module List = List.Stable module Map = Map.Stable module Maybe_bound = Maybe_bound.Stable module Month = Month.Stable module Nothing = Nothing.Stable module Option = Option.Stable module Or_error = Or_error.Stable module Percent = Percent.Stable module Perms = Perms.Stable module Pid = Pid.Stable module Queue = Queue.Stable module Result = Result.Stable module Set = Set.Stable module Sexp = Sexp.Stable module Sexpable = Sexpable.Stable module Source_code_position = Source_code_position.Stable module String = String.Stable module String_id = String_id.Stable module Time_ns = Time_ns.Stable module Time = Time_float.Stable module Unit = Unit.Stable module Unix = struct end [@@deprecated "[since 2021-02] Use [Core_unix.Stable]"] include Perms.Export include Ppx_compare_lib.Builtin include Import.Not_found core-0.15.0/core/src/stable_comparable.ml000066400000000000000000000002651420273305200202360ustar00rootroot00000000000000module type V1 = sig include Stable_module_types.S0 include Comparable.Stable.V1.S with type comparable := t with type comparator_witness := comparator_witness end core-0.15.0/core/src/stable_int63able.ml000066400000000000000000000006631420273305200177220ustar00rootroot00000000000000open! Import module type S = sig include Stable_module_types.S0 (** [to_int63] and [of_int63_exn] encode [t] for use in wire protocols; they are intended to avoid allocation on 64-bit machines and should be implemented efficiently. [of_int63_exn (to_int63 t) = t] for all [t]; [of_int63_exn] raises for inputs not produced by [to_int63]. *) val to_int63 : t -> Int63.t val of_int63_exn : Int63.t -> t end core-0.15.0/core/src/stable_internal.ml000066400000000000000000000026441420273305200177500ustar00rootroot00000000000000open! Import include Bin_prot.Std include Hash.Builtin include ( Base : sig type nonrec 'a array = 'a array [@@deriving sexp, sexp_grammar] type nonrec bool = bool [@@deriving sexp, sexp_grammar] type nonrec char = char [@@deriving sexp, sexp_grammar] type nonrec exn = exn [@@deriving sexp_of] type nonrec float = float [@@deriving sexp, sexp_grammar] type nonrec int = int [@@deriving sexp, sexp_grammar] type nonrec int32 = int32 [@@deriving sexp, sexp_grammar] type nonrec int64 = int64 [@@deriving sexp, sexp_grammar] type nonrec 'a list = 'a list [@@deriving sexp, sexp_grammar] type nonrec nativeint = nativeint [@@deriving sexp, sexp_grammar] type nonrec 'a option = 'a option [@@deriving sexp, sexp_grammar] type nonrec 'a ref = 'a ref [@@deriving sexp, sexp_grammar] type nonrec string = string [@@deriving sexp, sexp_grammar] type nonrec bytes = bytes [@@deriving sexp, sexp_grammar] type nonrec unit = unit [@@deriving sexp, sexp_grammar] end with type 'a array := 'a array with type bool := bool with type char := char with type exn := exn with type float := float with type int := int with type int32 := int32 with type int64 := int64 with type 'a list := 'a list with type nativeint := nativeint with type 'a option := 'a option with type 'a ref := 'a ref with type string := string with type bytes := bytes with type unit := unit) core-0.15.0/core/src/stable_module_types.ml000066400000000000000000000022401420273305200206350ustar00rootroot00000000000000open! Import module type S0_without_comparator = sig type t [@@deriving bin_io, compare, sexp] end module type S0 = sig include S0_without_comparator include Comparator.Stable.V1.S with type t := t end (** The polymorphic signatures require a mapping function so people can write conversion functions without either (1) re-implementing the mapping function inline or (2) reaching into the unstable part of the module. *) module type S1 = sig type 'a t [@@deriving bin_io, compare, sexp] val map : 'a t -> f:('a -> 'b) -> 'b t end module type S2 = sig type ('a1, 'a2) t [@@deriving bin_io, compare, sexp] val map : ('a1, 'a2) t -> f1:('a1 -> 'b1) -> f2:('a2 -> 'b2) -> ('b1, 'b2) t end module type S3 = sig type ('a1, 'a2, 'a3) t [@@deriving bin_io, compare, sexp] val map : ('a1, 'a2, 'a3) t -> f1:('a1 -> 'b1) -> f2:('a2 -> 'b2) -> f3:('a3 -> 'b3) -> ('b1, 'b2, 'b3) t end module type S4 = sig type ('a1, 'a2, 'a3, 'a4) t [@@deriving bin_io, compare, sexp] val map : ('a1, 'a2, 'a3, 'a4) t -> f1:('a1 -> 'b1) -> f2:('a2 -> 'b2) -> f3:('a3 -> 'b3) -> f4:('a4 -> 'b4) -> ('b1, 'b2, 'b3, 'b4) t end core-0.15.0/core/src/stable_unit_test.ml000066400000000000000000000136121420273305200201470ustar00rootroot00000000000000open! Import open Std_internal include Stable_unit_test_intf module Make_sexp_deserialization_test (T : Stable_unit_test_intf.Arg) = struct let%test_unit "sexp deserialization" = Or_error.combine_errors_unit (List.map T.tests ~f:(fun (t, sexp_as_string, _) -> match Or_error.try_with (fun () -> sexp_as_string |> Sexp.of_string |> [%of_sexp: T.t]) with | Error _ as error -> Or_error.tag_arg error "could not deserialize sexp" (sexp_as_string, `Expected t) [%sexp_of: string * [ `Expected of T.t ]] | Ok t' -> if T.equal t t' then Ok () else Or_error.error "sexp deserialization mismatch" (`Expected t, `But_got t') [%sexp_of: [ `Expected of T.t ] * [ `But_got of T.t ]])) |> ok_exn ;; end module Make_sexp_serialization_test (T : Stable_unit_test_intf.Arg) = struct let%test_unit "sexp serialization" = Or_error.combine_errors_unit (List.map T.tests ~f:(fun (t, sexp_as_string, _) -> Or_error.try_with (fun () -> let sexp = Sexp.of_string sexp_as_string in let serialized_sexp = T.sexp_of_t t in if Sexp.( <> ) serialized_sexp sexp then failwiths ~here:[%here] "sexp serialization mismatch" (`Expected sexp, `But_got serialized_sexp) [%sexp_of: [ `Expected of Sexp.t ] * [ `But_got of Sexp.t ]]))) |> ok_exn ;; end module Make_bin_io_test (T : Stable_unit_test_intf.Arg) = struct let%test_unit "bin_io" = List.iter T.tests ~f:(fun (t, _, expected_bin_io) -> let binable_m = (module T : Binable.S with type t = T.t) in let to_bin_string t = Binable.to_string binable_m t in let serialized_bin_io = to_bin_string t in if String.( <> ) serialized_bin_io expected_bin_io then failwiths ~here:[%here] "bin_io serialization mismatch" (t, `Expected expected_bin_io, `But_got serialized_bin_io) [%sexp_of: T.t * [ `Expected of string ] * [ `But_got of string ]]; let t' = Binable.of_string binable_m serialized_bin_io in if not (T.equal t t') then failwiths ~here:[%here] "bin_io deserialization mismatch" (`Expected t, `But_got t') [%sexp_of: [ `Expected of T.t ] * [ `But_got of T.t ]]) ;; end module Make (T : Stable_unit_test_intf.Arg) = struct include Make_sexp_deserialization_test (T) include Make_sexp_serialization_test (T) include Make_bin_io_test (T) end module Make_unordered_container (T : Stable_unit_test_intf.Unordered_container_arg) = struct module Test = Stable_unit_test_intf.Unordered_container_test let%test_unit "sexp" = List.iter T.tests ~f:(fun (t, { Test.sexps; _ }) -> let sexps = List.map sexps ~f:Sexp.of_string in let serialized_elements = match T.sexp_of_t t with | Sexp.List sexps -> sexps | Sexp.Atom _ -> failwiths ~here:[%here] "expected list when serializing unordered container" t T.sexp_of_t in let sorted_sexps = List.sort ~compare:Sexp.compare sexps in let sorted_serialized = List.sort ~compare:Sexp.compare serialized_elements in if not (List.equal Sexp.( = ) sorted_sexps sorted_serialized) then failwiths ~here:[%here] "sexp serialization mismatch" (`Expected sexps, `But_got serialized_elements) [%sexp_of: [ `Expected of Sexp.t list ] * [ `But_got of Sexp.t list ]]; let sexp_permutations = List.init 10 ~f:(fun _ -> List.permute sexps) in List.iter sexp_permutations ~f:(fun sexps -> let t' = T.t_of_sexp (Sexp.List sexps) in if not (T.equal t t') then failwiths ~here:[%here] "sexp deserialization msimatch" (`Expected t, `But_got t') [%sexp_of: [ `Expected of T.t ] * [ `But_got of T.t ]])) ;; let rec is_concatenation string strings = if String.is_empty string then List.for_all strings ~f:String.is_empty else ( let rec loop rev_skipped strings = match strings with | [] -> false | prefix :: strings -> let continue () = loop (prefix :: rev_skipped) strings in (match String.chop_prefix ~prefix string with | None -> continue () | Some string -> is_concatenation string (List.rev_append rev_skipped strings) || continue ()) in loop [] strings) ;; let%test_unit "bin_io" = List.iter T.tests ~f:(fun (t, { Test.bin_io_header; bin_io_elements; _ }) -> let binable_m = (module T : Binable.S with type t = T.t) in let elements = bin_io_elements in let bin_io_of_elements elements = bin_io_header ^ String.concat elements in let serialized = Binable.to_string binable_m t in let serialization_matches = match String.chop_prefix ~prefix:bin_io_header serialized with | None -> false | Some elements_string -> is_concatenation elements_string elements in if not serialization_matches then failwiths ~here:[%here] "serialization mismatch" (`Expected (bin_io_header, elements), `But_got serialized) [%sexp_of: [ `Expected of string * string list ] * [ `But_got of string ]]; let permutatations = List.init 10 ~f:(fun _ -> List.permute elements) in List.iter permutatations ~f:(fun elements -> let t' = Binable.of_string binable_m (bin_io_of_elements elements) in if not (T.equal t t') then failwiths ~here:[%here] "bin-io deserialization mismatch" (`Expected t, `But_got t') [%sexp_of: [ `Expected of T.t ] * [ `But_got of T.t ]])) ;; end core-0.15.0/core/src/stable_unit_test.mli000066400000000000000000000021051420273305200203130ustar00rootroot00000000000000(** The tests generated by these functors are run like any other unit tests: by the inline test runner when the functor is applied. See [stable_unit_test_intf.ml] for documentation regarding the argument module types. *) open! Import open! Stable_unit_test_intf (** We provide separate access to sexp serialization and deserialization tests because some stable types will have varying sexp serializations. Notably, Time.sexp_of_t depends on the local timezone. For such types it is still important to check that all the sexps can be deserialized correctly. *) module Make_sexp_deserialization_test (T : Arg) : sig end module Make_sexp_serialization_test (T : Arg) : sig end module Make_bin_io_test (T : Arg) : sig end (** Include all of the above tests. *) module Make (T : Stable_unit_test_intf.Arg) : sig end (** See [stable_unit_test_intf.ml] for documentation. *) module type Unordered_container_arg = Unordered_container_arg module Unordered_container_test = Unordered_container_test module Make_unordered_container (T : Unordered_container_arg) : sig end core-0.15.0/core/src/stable_unit_test_intf.ml000066400000000000000000000017771420273305200212000ustar00rootroot00000000000000(** An interface for creating unit tests to check stability of sexp and bin-io serializations *) open! Import module type Arg = sig type t [@@deriving sexp, bin_io] val equal : t -> t -> bool (** [tests] is a list of (value, sexp-representation, bin-io-representation) triples. The unit tests check that the type properly serializes and de-serializes according to the given representations. *) val tests : (t * string * string) list end (** Unordered container tests are for types with serializations that will contain a certain set of elements (each represented by a single sexp or bin-io string) which may appear in any order, such as hash tables and hash sets. *) module Unordered_container_test = struct type t = { sexps : string list ; bin_io_header : string ; bin_io_elements : string list } end module type Unordered_container_arg = sig type t [@@deriving sexp, bin_io] val equal : t -> t -> bool val tests : (t * Unordered_container_test.t) list end core-0.15.0/core/src/stack.ml000066400000000000000000000003321420273305200156770ustar00rootroot00000000000000include Base.Stack include Bin_prot.Utils.Make_binable1_without_uuid [@alert "-legacy"] (struct type nonrec 'a t = 'a t module Binable = List let to_binable = to_list let of_binable = of_list end) core-0.15.0/core/src/stack.mli000066400000000000000000000001601420273305200160470ustar00rootroot00000000000000open! Import include module type of struct include Base.Stack end include Binable.S1 with type 'a t := 'a t core-0.15.0/core/src/std_internal.ml000066400000000000000000000216631420273305200172720ustar00rootroot00000000000000(* We don't just include Sexplib.Std because one can only define Hashtbl once in this module. *) open! Import (** [include]d first so that everything else shadows it *) include Core_pervasives include Int.Replace_polymorphic_compare include Base_quickcheck.Export include Deprecate_pipe_bang include Either.Export include From_sexplib include Interfaces include List.Infix include Never_returns include Ordering.Export include Perms.Export include Result.Export type -'a return = 'a With_return.return = private { return : 'b. 'a -> 'b } [@@unboxed] include struct exception Bug of string [@deprecated "[since 2020-03] Don't use [Bug]"] [@@deriving sexp] end [@@alert "-deprecated"] (** Raised if malloc in C bindings fail (errno * size). *) exception C_malloc_exn of int * int (* errno, size *) let () = Callback.register_exception "C_malloc_exn" (C_malloc_exn (0, 0)) exception Finally = Exn.Finally let fst3 (x, _, _) = x let snd3 (_, y, _) = y let trd3 (_, _, z) = z include ( struct let uw = function | Some x -> x | None -> raise Caml.Not_found ;; end : sig val uw : 'a option -> 'a [@@deprecated "[since 2018-12] Use [Option.value_exn]"] end) (** [phys_same] is like [phys_equal], but with a more general type. [phys_same] is useful when dealing with existential types, when one has a packed value and an unpacked value that one wants to check are physically equal. One can't use [phys_equal] in such a situation because the types are different. *) let phys_same (type a b) (a : a) (b : b) = phys_equal a (Obj.magic b : a) let ( % ) = Int.( % ) let ( /% ) = Int.( /% ) let ( // ) = Int.( // ) let ( ==> ) a b = (not a) || b let bprintf = Printf.bprintf let const = Fn.const let eprintf = Printf.eprintf let error = Or_error.error let error_s = Or_error.error_s let failwithf = Base.Printf.failwithf include ( struct let failwithp = (Error.failwithp [@alert "-deprecated"]) end : sig val failwithp : ?strict:unit -> Source_code_position.t -> string -> 'a -> ('a -> Sexp.t) -> _ [@@deprecated "[since 2020-03] Use [failwiths] instead."] end) let failwiths = Error.failwiths let force = Base.Lazy.force let fprintf = Printf.fprintf include ( struct let ident = Fn.id end : sig val ident : 'a -> 'a [@@deprecated "[since 2021-08] Use [Fn.id] instead."] end) let invalid_argf = Base.Printf.invalid_argf let ifprintf = Printf.ifprintf let is_none = Option.is_none let is_some = Option.is_some let ksprintf = Printf.ksprintf let ok_exn = Or_error.ok_exn let phys_equal = Base.phys_equal let phys_same = phys_same let print_s = Stdio.print_s let eprint_s = Stdio.eprint_s let printf = Printf.printf let protect = Exn.protect let protectx = Exn.protectx let raise_s = Error.raise_s let round = Float.round let ( **. ) = Base.( **. ) let ( %. ) = Base.( %. ) let sprintf = Printf.sprintf let stage = Staged.stage let unstage = Staged.unstage let with_return = With_return.with_return let with_return_option = With_return.with_return_option (* With the following aliases, we are just making extra sure that the toplevel sexp converters line up with the ones in our modules. *) include Typerep_lib.Std_internal include ( struct (* [deriving hash] is missing for [array], [bytes], and [ref] since these types are mutable. *) type 'a array = 'a Array.t [@@deriving bin_io, compare, equal, sexp, sexp_grammar, typerep] type bool = Bool.t [@@deriving bin_io, compare, hash, equal, sexp, sexp_grammar, typerep] type char = Char.t [@@deriving bin_io, compare, hash, equal, sexp, sexp_grammar, typerep] type float = Float.t [@@deriving bin_io, compare, hash, equal, sexp, sexp_grammar, typerep] type int = Int.t [@@deriving bin_io, compare, hash, equal, sexp, sexp_grammar, typerep] type int32 = Int32.t [@@deriving bin_io, compare, hash, equal, sexp, sexp_grammar, typerep] type int64 = Int64.t [@@deriving bin_io, compare, hash, equal, sexp, sexp_grammar, typerep] type 'a lazy_t = 'a Lazy.t [@@deriving bin_io, compare, hash, sexp, sexp_grammar, typerep] type 'a list = 'a List.t [@@deriving bin_io, compare, hash, equal, sexp, sexp_grammar, typerep] type nativeint = Nativeint.t [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar, typerep] type 'a option = 'a Option.t [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar, typerep] type string = String.t [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar, typerep] type bytes = Bytes.t [@@deriving bin_io, compare, equal, sexp, sexp_grammar, typerep] type 'a ref = 'a Ref.t [@@deriving bin_io, compare, equal, sexp, sexp_grammar, typerep] type unit = Unit.t [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar, typerep] (* Bin_prot has optimized functions for float arrays *) include struct type float_array = float array [@@deriving bin_io] end [@alert "-deprecated"] include ( struct type float_array = Float.t array [@@deriving compare, sexp, sexp_grammar, typerep] end : sig type float_array [@@deriving compare, sexp, sexp_grammar, typerep] end with type float_array := float_array) end : sig type 'a array [@@deriving bin_io, compare, equal, sexp, sexp_grammar, typerep] type bool [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar, typerep] type char [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar, typerep] type float [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar, typerep] type int [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar, typerep] type int32 [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar, typerep] type int64 [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar, typerep] type 'a lazy_t [@@deriving bin_io, compare, hash, sexp, sexp_grammar, typerep] type 'a list [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar, typerep] type nativeint [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar, typerep] type 'a option [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar, typerep] type string [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar, typerep] type bytes [@@deriving bin_io, compare, equal, sexp, sexp_grammar, typerep] type 'a ref [@@deriving bin_io, compare, equal, sexp, sexp_grammar, typerep] type unit [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar, typerep] include sig type float_array = float array [@@deriving bin_io, compare, sexp, sexp_grammar, typerep] [@@deprecated "[since 2021-09] use [float array] or [floatarray] instead"] end [@alert "-deprecated"] end with type 'a array := 'a array with type bool := bool with type char := char with type float := float with type int := int with type int32 := int32 with type int64 := int64 with type 'a list := 'a list with type nativeint := nativeint with type 'a option := 'a option with type string := string with type bytes := bytes with type 'a lazy_t := 'a lazy_t with type 'a ref := 'a ref with type unit := unit) let sexp_of_exn = Exn.sexp_of_t (* The code below checks that the signatures in map.mli and set.mli are consistent with the generic map and set signatures defined in map_intf.ml and set_intf.ml. *) let () = let module T = struct type 'a elt = 'a type 'a cmp = 'a end in let module _ : sig open Set_intf module Tree : sig type ('a, 'b) t include Creators_and_accessors2_with_comparator with type ('a, 'b) set := ('a, 'b) t with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) t with type ('a, 'b) named := ('a, 'b) Tree.Named.t end type ('a, 'b) t include Accessors2 with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) Tree.t with type ('a, 'b) named := ('a, 'b) Named.t include Creators_generic with type ('a, 'b) set := ('a, 'b) t with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) Tree.t with type 'a elt := 'a T.elt with type 'a cmp := 'a T.cmp with type ('a, 'cmp, 'z) options := ('a, 'cmp, 'z) Set_intf.With_first_class_module.t end = Set in () ;; let () = let module T = struct type 'k key = 'k type 'c cmp = 'c end in let module _ : sig open Map_intf module Tree : sig type ('a, 'b, 'c) t include Creators_and_accessors3_with_comparator with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) t end type ('a, 'b, 'c) t include Accessors3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Tree.t include Creators_generic with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Tree.t with type ('a, 'cmp, 'z) options := ('a, 'cmp, 'z) Map_intf.With_first_class_module.t with type 'k key := 'k T.key with type 'c cmp := 'c T.cmp end = Map in () ;; core-0.15.0/core/src/strftime.js000066400000000000000000000560131420273305200164420ustar00rootroot00000000000000// // strftime // github.com/samsonjs/strftime // @_sjs // // Copyright 2010 - 2015 Sami Samhuri // // MIT License // http://sjs.mit-license.org // ;(function() { var DefaultLocale = { days: ['Sunday', 'Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday'], shortDays: ['Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'], months: ['January', 'February', 'March', 'April', 'May', 'June', 'July', 'August', 'September', 'October', 'November', 'December'], shortMonths: ['Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'], AM: 'AM', PM: 'PM', am: 'am', pm: 'pm', formats: { D: '%m/%d/%y', F: '%Y-%m-%d', R: '%H:%M', T: '%H:%M:%S', X: '%T', c: '%a %b %d %X %Y', r: '%I:%M:%S %p', v: '%e-%b-%Y', x: '%D' } }, defaultStrftime = new Strftime(DefaultLocale, 0, false), isCommonJS = typeof module !== 'undefined', namespace; // CommonJS / Node module if (isCommonJS) { namespace = module.exports = adaptedStrftime; namespace.strftime = deprecatedStrftime; if(joo_global_object) joo_global_object.strftime = adaptedStrftime; } // Browsers and other environments else { // Get the global object. Works in ES3, ES5, and ES5 strict mode. namespace = joo_global_object || (function() { return this || (1,eval)('this'); }()); namespace.strftime = adaptedStrftime; } // Deprecated API, to be removed in v1.0 var _require = isCommonJS ? "require('strftime')" : "strftime"; var _deprecationWarnings = {}; function deprecationWarning(name, instead) { if (!_deprecationWarnings[name]) { if (typeof console !== 'undefined' && typeof console.warn == 'function') { console.warn("[WARNING] " + name + " is deprecated and will be removed in version 1.0. Instead, use `" + instead + "`."); } _deprecationWarnings[name] = true; } } namespace.strftimeTZ = deprecatedStrftimeTZ; namespace.strftimeUTC = deprecatedStrftimeUTC; namespace.localizedStrftime = deprecatedStrftimeLocalized; // Adapt the old API while preserving the new API. function adaptForwards(fn) { fn.localize = defaultStrftime.localize.bind(defaultStrftime); fn.timezone = defaultStrftime.timezone.bind(defaultStrftime); fn.utc = defaultStrftime.utc.bind(defaultStrftime); } adaptForwards(adaptedStrftime); function adaptedStrftime(fmt, d, locale) { // d and locale are optional, check if this is (format, locale) if (d && d.days) { locale = d; d = undefined; } if (locale) { deprecationWarning("`" + _require + "(format, [date], [locale])`", "var s = " + _require + ".localize(locale); s(format, [date])"); } var strftime = locale ? defaultStrftime.localize(locale) : defaultStrftime; return strftime(fmt, d); } adaptForwards(deprecatedStrftime); function deprecatedStrftime(fmt, d, locale) { if (locale) { deprecationWarning("`" + _require + ".strftime(format, [date], [locale])`", "var s = " + _require + ".localize(locale); s(format, [date])"); } else { deprecationWarning("`" + _require + ".strftime(format, [date])`", _require + "(format, [date])"); } var strftime = locale ? defaultStrftime.localize(locale) : defaultStrftime; return strftime(fmt, d); } function deprecatedStrftimeTZ(fmt, d, locale, timezone) { // locale is optional, check if this is (format, date, timezone) if ((typeof locale == 'number' || typeof locale == 'string') && timezone == null) { timezone = locale; locale = undefined; } if (locale) { deprecationWarning("`" + _require + ".strftimeTZ(format, date, locale, tz)`", "var s = " + _require + ".localize(locale).timezone(tz); s(format, [date])` or `var s = " + _require + ".localize(locale); s.timezone(tz)(format, [date])"); } else { deprecationWarning("`" + _require + ".strftimeTZ(format, date, tz)`", "var s = " + _require + ".timezone(tz); s(format, [date])` or `" + _require + ".timezone(tz)(format, [date])"); } var strftime = (locale ? defaultStrftime.localize(locale) : defaultStrftime).timezone(timezone); return strftime(fmt, d); } var utcStrftime = defaultStrftime.utc(); function deprecatedStrftimeUTC(fmt, d, locale) { if (locale) { deprecationWarning("`" + _require + ".strftimeUTC(format, date, locale)`", "var s = " + _require + ".localize(locale).utc(); s(format, [date])"); } else { deprecationWarning("`" + _require + ".strftimeUTC(format, [date])`", "var s = " + _require + ".utc(); s(format, [date])"); } var strftime = locale ? utcStrftime.localize(locale) : utcStrftime; return strftime(fmt, d); } function deprecatedStrftimeLocalized(locale) { deprecationWarning("`" + _require + ".localizedStrftime(locale)`", _require + ".localize(locale)"); return defaultStrftime.localize(locale); } // End of deprecated API // Polyfill Date.now for old browsers. if (typeof Date.now !== 'function') { Date.now = function() { return +new Date(); }; } function Strftime(locale, customTimezoneOffset, useUtcTimezone) { var _locale = locale || DefaultLocale, _customTimezoneOffset = customTimezoneOffset || 0, _useUtcBasedDate = useUtcTimezone || false, // we store unix timestamp value here to not create new Date() each iteration (each millisecond) // Date.now() is 2 times faster than new Date() // while millisecond precise is enough here // this could be very helpful when strftime triggered a lot of times one by one _cachedDateTimestamp = 0, _cachedDate; function _strftime(format, date) { var timestamp; if (!date) { var currentTimestamp = Date.now(); if (currentTimestamp > _cachedDateTimestamp) { _cachedDateTimestamp = currentTimestamp; _cachedDate = new Date(_cachedDateTimestamp); timestamp = _cachedDateTimestamp; if (_useUtcBasedDate) { // how to avoid duplication of date instantiation for utc here? // we tied to getTimezoneOffset of the current date _cachedDate = new Date(_cachedDateTimestamp + getTimestampToUtcOffsetFor(_cachedDate) + _customTimezoneOffset); } } date = _cachedDate; } else { timestamp = date.getTime(); if (_useUtcBasedDate) { date = new Date(date.getTime() + getTimestampToUtcOffsetFor(date) + _customTimezoneOffset); } } return _processFormat(format, date, _locale, timestamp); } function _processFormat(format, date, locale, timestamp) { var resultString = '', padding = null, isInScope = false, length = format.length, extendedTZ = false; for (var i = 0; i < length; i++) { var currentCharCode = format.charCodeAt(i); if (isInScope === true) { // '-' if (currentCharCode === 45) { padding = ''; continue; } // '_' else if (currentCharCode === 95) { padding = ' '; continue; } // '0' else if (currentCharCode === 48) { padding = '0'; continue; } // ':' else if (currentCharCode === 58) { if (extendedTZ) { if (typeof console !== 'undefined' && typeof console.warn == 'function') { console.warn("[WARNING] detected use of unsupported %:: or %::: modifiers to strftime"); } } extendedTZ = true; continue; } switch (currentCharCode) { // Examples for new Date(0) in GMT // 'Thursday' // case 'A': case 65: resultString += locale.days[date.getDay()]; break; // 'January' // case 'B': case 66: resultString += locale.months[date.getMonth()]; break; // '19' // case 'C': case 67: resultString += padTill2(Math.floor(date.getFullYear() / 100), padding); break; // '01/01/70' // case 'D': case 68: resultString += _processFormat(locale.formats.D, date, locale, timestamp); break; // '1970-01-01' // case 'F': case 70: resultString += _processFormat(locale.formats.F, date, locale, timestamp); break; // '00' // case 'H': case 72: resultString += padTill2(date.getHours(), padding); break; // '12' // case 'I': case 73: resultString += padTill2(hours12(date.getHours()), padding); break; // '000' // case 'L': case 76: resultString += padTill3(Math.floor(timestamp % 1000)); break; // '00' // case 'M': case 77: resultString += padTill2(date.getMinutes(), padding); break; // 'am' // case 'P': case 80: resultString += date.getHours() < 12 ? locale.am : locale.pm; break; // '00:00' // case 'R': case 82: resultString += _processFormat(locale.formats.R, date, locale, timestamp); break; // '00' // case 'S': case 83: resultString += padTill2(date.getSeconds(), padding); break; // '00:00:00' // case 'T': case 84: resultString += _processFormat(locale.formats.T, date, locale, timestamp); break; // '00' // case 'U': case 85: resultString += padTill2(weekNumber(date, 'sunday'), padding); break; // '00' // case 'W': case 87: resultString += padTill2(weekNumber(date, 'monday'), padding); break; // '16:00:00' // case 'X': case 88: resultString += _processFormat(locale.formats.X, date, locale, timestamp); break; // '1970' // case 'Y': case 89: resultString += date.getFullYear(); break; // 'GMT' // case 'Z': case 90: if (_useUtcBasedDate && _customTimezoneOffset === 0) { resultString += "GMT"; } else { // fixme optimize var tzString = date.toString().match(/\(([\w\s]+)\)/); resultString += tzString && tzString[1] || ''; } break; // 'Thu' // case 'a': case 97: resultString += locale.shortDays[date.getDay()]; break; // 'Jan' // case 'b': case 98: resultString += locale.shortMonths[date.getMonth()]; break; // '' // case 'c': case 99: resultString += _processFormat(locale.formats.c, date, locale, timestamp); break; // '01' // case 'd': case 100: resultString += padTill2(date.getDate(), padding); break; // ' 1' // case 'e': case 101: resultString += padTill2(date.getDate(), padding == null ? ' ' : padding); break; // 'Jan' // case 'h': case 104: resultString += locale.shortMonths[date.getMonth()]; break; // '000' // case 'j': case 106: var y = new Date(date.getFullYear(), 0, 1); var day = Math.ceil((date.getTime() - y.getTime()) / (1000 * 60 * 60 * 24)); resultString += padTill3(day); break; // ' 0' // case 'k': case 107: resultString += padTill2(date.getHours(), padding == null ? ' ' : padding); break; // '12' // case 'l': case 108: resultString += padTill2(hours12(date.getHours()), padding == null ? ' ' : padding); break; // '01' // case 'm': case 109: resultString += padTill2(date.getMonth() + 1, padding); break; // '\n' // case 'n': case 110: resultString += '\n'; break; // '1st' // case 'o': case 111: resultString += String(date.getDate()) + ordinal(date.getDate()); break; // 'AM' // case 'p': case 112: resultString += date.getHours() < 12 ? locale.AM : locale.PM; break; // '12:00:00 AM' // case 'r': case 114: resultString += _processFormat(locale.formats.r, date, locale, timestamp); break; // '0' // case 's': case 115: resultString += Math.floor(timestamp / 1000); break; // '\t' // case 't': case 116: resultString += '\t'; break; // '4' // case 'u': case 117: var day = date.getDay(); resultString += day === 0 ? 7 : day; break; // 1 - 7, Monday is first day of the week // ' 1-Jan-1970' // case 'v': case 118: resultString += _processFormat(locale.formats.v, date, locale, timestamp); break; // '4' // case 'w': case 119: resultString += date.getDay(); break; // 0 - 6, Sunday is first day of the week // '12/31/69' // case 'x': case 120: resultString += _processFormat(locale.formats.x, date, locale, timestamp); break; // '70' // case 'y': case 121: resultString += ('' + date.getFullYear()).slice(2); break; // '+0000' // case 'z': case 122: if (_useUtcBasedDate && _customTimezoneOffset === 0) { resultString += extendedTZ ? "+00:00" : "+0000"; } else { var off; if (_customTimezoneOffset !== 0) { off = _customTimezoneOffset / (60 * 1000); } else { off = -date.getTimezoneOffset(); } var sign = off < 0 ? '-' : '+'; var sep = extendedTZ ? ':' : ''; var hours = Math.floor(Math.abs(off / 60)); var mins = Math.abs(off % 60); resultString += sign + padTill2(hours) + sep + padTill2(mins); } break; default: resultString += format[i]; break; } padding = null; isInScope = false; continue; } // '%' if (currentCharCode === 37) { isInScope = true; continue; } resultString += format[i]; } return resultString; } var strftime = _strftime; strftime.localize = function(locale) { return new Strftime(locale || _locale, _customTimezoneOffset, _useUtcBasedDate); }; strftime.timezone = function(timezone) { var customTimezoneOffset = _customTimezoneOffset; var useUtcBasedDate = _useUtcBasedDate; var timezoneType = typeof timezone; if (timezoneType === 'number' || timezoneType === 'string') { useUtcBasedDate = true; // ISO 8601 format timezone string, [-+]HHMM if (timezoneType === 'string') { var sign = timezone[0] === '-' ? -1 : 1, hours = parseInt(timezone.slice(1, 3), 10), minutes = parseInt(timezone.slice(3, 5), 10); customTimezoneOffset = sign * ((60 * hours) + minutes) * 60 * 1000; // in minutes: 420 } else if (timezoneType === 'number') { customTimezoneOffset = timezone * 60 * 1000; } } return new Strftime(_locale, customTimezoneOffset, useUtcBasedDate); }; strftime.utc = function() { return new Strftime(_locale, _customTimezoneOffset, true); }; return strftime; } function padTill2(numberToPad, paddingChar) { if (paddingChar === '' || numberToPad > 9) { return numberToPad; } if (paddingChar == null) { paddingChar = '0'; } return paddingChar + numberToPad; } function padTill3(numberToPad) { if (numberToPad > 99) { return numberToPad; } if (numberToPad > 9) { return '0' + numberToPad; } return '00' + numberToPad; } function hours12(hour) { if (hour === 0) { return 12; } else if (hour > 12) { return hour - 12; } return hour; } // firstWeekday: 'sunday' or 'monday', default is 'sunday' // // Pilfered & ported from Ruby's strftime implementation. function weekNumber(date, firstWeekday) { firstWeekday = firstWeekday || 'sunday'; // This works by shifting the weekday back by one day if we // are treating Monday as the first day of the week. var weekday = date.getDay(); if (firstWeekday === 'monday') { if (weekday === 0) // Sunday weekday = 6; else weekday--; } var firstDayOfYearUtc = Date.UTC(date.getFullYear(), 0, 1), dateUtc = Date.UTC(date.getFullYear(), date.getMonth(), date.getDate()), yday = Math.floor((dateUtc - firstDayOfYearUtc) / 86400000), weekNum = (yday + 7 - weekday) / 7; return Math.floor(weekNum); } // Get the ordinal suffix for a number: st, nd, rd, or th function ordinal(number) { var i = number % 10; var ii = number % 100; if ((ii >= 11 && ii <= 13) || i === 0 || i >= 4) { return 'th'; } switch (i) { case 1: return 'st'; case 2: return 'nd'; case 3: return 'rd'; } } function getTimestampToUtcOffsetFor(date) { return (date.getTimezoneOffset() || 0) * 60000; } }()); core-0.15.0/core/src/string.ml000066400000000000000000000041071420273305200161040ustar00rootroot00000000000000open! Import include Base.String (* These two are needed because [include Identifiable.Extend] (present later in the file) binds new [Map] and [Set] modules. *) module Stable = struct module V1 = struct module T = struct include Base.String type t = string [@@deriving bin_io] end include T let to_string = Fn.id let of_string = Fn.id include Comparable.Stable.V1.Make (T) include Hashable.Stable.V1.Make (T) end end module Caseless = struct module T = struct include Caseless type t = string [@@deriving bin_io] end include T include Comparable.Make_binable_using_comparator (T) include Hashable.Make_binable (T) end type t = string [@@deriving typerep] include Identifiable.Extend (struct include Base.String let hashable = Stable.V1.hashable end) (struct type t = string [@@deriving bin_io] end) include Comparable.Validate (Base.String) include Hexdump.Of_indexable (struct type t = string let length = length let get = get end) let quickcheck_generator = Base_quickcheck.Generator.string let quickcheck_observer = Base_quickcheck.Observer.string let quickcheck_shrinker = Base_quickcheck.Shrinker.string let gen_nonempty = Base_quickcheck.Generator.string_non_empty let gen' = Base_quickcheck.Generator.string_of let gen_nonempty' = Base_quickcheck.Generator.string_non_empty_of let gen_with_length length chars = Base_quickcheck.Generator.string_with_length_of chars ~length ;; let take_while t ~f = match lfindi t ~f:(fun _ elt -> not (f elt)) with | None -> t | Some i -> sub t ~pos:0 ~len:i ;; let rtake_while t ~f = match rfindi t ~f:(fun _ elt -> not (f elt)) with | None -> t | Some i -> sub t ~pos:(i + 1) ~len:(length t - i - 1) ;; (** See {!Array.normalize} for the following 4 functions. *) let normalize t i = Ordered_collection_common.normalize ~length_fun:length t i let slice t start stop = Ordered_collection_common.slice ~length_fun:length ~sub_fun:sub t start stop ;; let nget x i = let module String = Base.String in x.[normalize x i] ;; core-0.15.0/core/src/string.mli000066400000000000000000000056021420273305200162560ustar00rootroot00000000000000(** This module extends {{!Base.String}[Base.String]}. *) (** @inline *) include module type of struct include Base.String end type t = string [@@deriving bin_io, typerep] (** [Caseless] compares and hashes strings ignoring case, so that for example [Caseless.equal "OCaml" "ocaml"] and [Caseless.("apple" < "Banana")] are [true], and [Caseless.Map], [Caseless.Table] lookup and [Caseless.Set] membership is case-insensitive. [Caseless] also provides case-insensitive [is_suffix] and [is_prefix] functions, so that for example [Caseless.is_suffix "OCaml" ~suffix:"AmL"] and [Caseless.is_prefix "OCaml" ~prefix:"oc"] are [true]. *) module Caseless : sig include module type of struct include Caseless end type nonrec t = t [@@deriving bin_io, hash, sexp] include Comparable.S_binable with type t := t include Hashable.S_binable with type t := t end (** [slice t start stop] returns a new string including elements [t.(start)] through [t.(stop-1)], normalized Python-style with the exception that [stop = 0] is treated as [stop = length t]. *) val slice : t -> int -> int -> t (** [nget s i] gets the char at normalized position [i] in [s]. *) val nget : t -> int -> char (** [take_while s ~f] returns the longest prefix of [s] satisfying [for_all prefix ~f] (See [lstrip] to drop such a prefix) *) val take_while : t -> f:(char -> bool) -> t (** [rtake_while s ~f] returns the longest suffix of [s] satisfying [for_all suffix ~f] (See [rstrip] to drop such a suffix) *) val rtake_while : t -> f:(char -> bool) -> t include Hexdump.S with type t := t include Identifiable.S with type t := t and type comparator_witness := comparator_witness include Quickcheckable.S with type t := t (** Like [quickcheck_generator], but without empty strings. *) val gen_nonempty : t Quickcheck.Generator.t (** Like [quickcheck_generator], but generate strings with the given distribution of characters. *) val gen' : char Quickcheck.Generator.t -> t Quickcheck.Generator.t (** Like [gen'], but without empty strings. *) val gen_nonempty' : char Quickcheck.Generator.t -> t Quickcheck.Generator.t (** Like [gen'], but generate strings with the given length. *) val gen_with_length : int -> char Quickcheck.Generator.t -> t Quickcheck.Generator.t (** Note that [string] is already stable by itself, since as a primitive type it is an integral part of the sexp / bin_io protocol. [String.Stable] exists only to introduce [String.Stable.Set], [String.Stable.Map], [String.Stable.Table], and provide interface uniformity with other stable types. *) module Stable : sig module V1 : sig type nonrec t = t [@@deriving equal, hash, sexp_grammar] include Base.Stringable.S with type t := t include Stable_comparable.V1 with type t := t with type comparator_witness = comparator_witness include Hashable.Stable.V1.S with type key := t end end core-0.15.0/core/src/string_id.ml000066400000000000000000000074431420273305200165660ustar00rootroot00000000000000open! Import open Std_internal include String_id_intf module Make_with_validate_without_pretty_printer (M : sig val module_name : string val validate : string -> unit Or_error.t val include_default_validation : bool end) () = struct module Stable = struct module V1 = struct module T = struct type t = string [@@deriving compare, equal, hash, sexp, sexp_grammar, typerep] let check_for_whitespace = let invalid s reason = Error (sprintf "'%s' is not a valid %s because %s" s M.module_name reason) in fun s -> let len = String.length s in if Int.( = ) len 0 then invalid s "it is empty" else if Char.is_whitespace s.[0] || Char.is_whitespace s.[len - 1] then invalid s "it has whitespace on the edge" else Ok () ;; let validate s = Result.map_error (M.validate s) ~f:Error.to_string_mach let check s = if M.include_default_validation then ( match check_for_whitespace s with | Ok () -> validate s | Error error -> Error error) else validate s ;; let to_string = Fn.id let pp = String.pp let of_string s = match check s with | Ok () -> s | Error err -> invalid_arg err ;; let t_of_sexp sexp = let s = String.Stable.V1.t_of_sexp sexp in match check s with | Ok () -> s | Error err -> of_sexp_error err sexp ;; include Binable.Of_binable_without_uuid [@alert "-legacy"] (String) (struct type nonrec t = t let to_binable = Fn.id let of_binable = of_string end) end module T_with_comparator = struct include T include Comparator.Stable.V1.Make (T) end include T_with_comparator include Comparable.Stable.V1.Make (T_with_comparator) include Hashable.Stable.V1.Make (T_with_comparator) end end module Stable_latest = Stable.V1 include Stable_latest.T_with_comparator include Comparable.Make_binable_using_comparator (Stable_latest.T_with_comparator) include Hashable.Make_binable (Stable_latest.T_with_comparator) let quickcheck_shrinker = Quickcheck.Shrinker.empty () let quickcheck_observer = String.quickcheck_observer let quickcheck_generator = String.gen_nonempty' Char.gen_print |> Quickcheck.Generator.filter ~f:(fun string -> check string |> Result.is_ok) ;; let arg_type = Command.Arg_type.create of_string end module Make_without_pretty_printer (M : sig val module_name : string end) () = struct include Make_with_validate_without_pretty_printer (struct let module_name = M.module_name let validate = Fn.const (Ok ()) let include_default_validation = true end) () end module Make_with_validate (M : sig val module_name : string val validate : string -> unit Or_error.t val include_default_validation : bool end) () = struct include Make_with_validate_without_pretty_printer (M) () include Pretty_printer.Register (struct type nonrec t = t let module_name = M.module_name let to_string = to_string end) end module Make (M : sig val module_name : string end) () = struct include Make_without_pretty_printer (M) () include Pretty_printer.Register (struct type nonrec t = t let module_name = M.module_name let to_string = to_string end) end include Make (struct let module_name = "Core.String_id" end) () module String_without_validation_without_pretty_printer = struct include String let arg_type = Command.Arg_type.create Fn.id end core-0.15.0/core/src/string_id.mli000066400000000000000000000002001420273305200167170ustar00rootroot00000000000000(** Like {!Identifiable}, but with [t = private string] and stable modules. *) include String_id_intf.String_id (** @inline *) core-0.15.0/core/src/string_id_intf.ml000066400000000000000000000065401420273305200176030ustar00rootroot00000000000000(** Disallows the empty string and whitespace around the edges in [of_string] and [t_of_sexp], but doesn't check when reading from bin_io. *) open! Import open Std_internal module type S = sig type t = private string [@@deriving equal, hash, sexp_grammar] include Identifiable with type t := t include Quickcheckable.S with type t := t val arg_type : t Command.Arg_type.t module Stable : sig module V1 : sig type nonrec t = t [@@deriving equal, hash, sexp_grammar] include Stringable.S with type t := t include Stable_comparable.V1 with type t := t with type comparator_witness = comparator_witness include Hashable.Stable.V1.S with type key := t end end end (** Some extra features we provide in [Make] and other functors here, but don't want to require of any string ID like type. *) module type S_with_extras = sig type t = private string [@@deriving typerep] include S with type t := t end module type String_id = sig module type S = S include S (** [Make] customizes the error messages generated by [of_string]/[of_sexp] to include [module_name]. It also registers a pretty printer. The resulting [quickcheck_generator] generates non-empty strings containing only printable characters, and no whitespace at the edges. *) module Make (M : sig val module_name : string end) () : S_with_extras (** [Make_with_validate] is like [Make], but modifies [of_string]/[of_sexp]/[bin_read_t] to raise if [validate] returns an error. Before using this functor one should be mindful of the performance implications (the [validate] function will run every time an instance is created) as well as potential versioning issues (when [validate] changes old binaries still run the old version of the function). The resulting [quickcheck_generator] uses a naive [Generator.filter] to satisfy [validate]. For complex validation predictes, the generator may spin indefinitely trying to generate a satisfying string. In these cases, the client should shadow [quickcheck_generator] with a generator that constructs valid strings more directly. *) module Make_with_validate (M : sig val module_name : string val validate : string -> unit Or_error.t (** By default, String_id performs some validation of its own in addition to calling [validate], namely: - The string cannot be empty; - The string may not have whitespace at the beginning or the end. You can turn this validation off using this flag. *) val include_default_validation : bool end) () : S_with_extras (** This does what [Make] does without registering a pretty printer. Use this when the module that is made is not exposed in mli. Registering a pretty printer without exposing it causes an error in utop. *) module Make_without_pretty_printer (M : sig val module_name : string end) () : S_with_extras (** See [Make_with_validate] and [Make_without_pretty_printer] *) module Make_with_validate_without_pretty_printer (M : sig val module_name : string val validate : string -> unit Or_error.t val include_default_validation : bool end) () : S_with_extras module String_without_validation_without_pretty_printer : S with type t = string end core-0.15.0/core/src/substring.ml000066400000000000000000000010061420273305200166110ustar00rootroot00000000000000open! Import module type S = Make_substring.S include Make_substring.F (struct type t = Bytes.t [@@deriving quickcheck] let create = Bytes.create let length = Bytes.length let get = Bytes.get module Blit = Make_substring.Blit let blit = Blit.bytes_bytes let blit_to_string = Blit.bytes_bytes let blit_to_bytes = Blit.bytes_bytes let blit_to_bigstring = Blit.bytes_bigstring let blit_from_string = Blit.string_bytes let blit_from_bigstring = Blit.bigstring_bytes end) core-0.15.0/core/src/substring.mli000066400000000000000000000003751420273305200167720ustar00rootroot00000000000000(** A substring is a contiguous set of characters within a string. Creating a substring does not copy. Therefore modifying the string also modifies the substring. *) module type S = Make_substring.S include S with type base = bytes (** @inline *) core-0.15.0/core/src/substring_intf.ml000066400000000000000000000045101420273305200176340ustar00rootroot00000000000000(** Interface for {{!Core.Substring}[Substring]}. *) open! Import module type S = sig (** The type of strings that type [t] is a substring of. *) type base type t [@@deriving quickcheck] include Indexed_container.S0 with type t := t with type elt := char val base : t -> base (** [pos] refers to the position in the base string, not any other substring that this substring was generated from. *) val pos : t -> int (** Per [String.get] and [Bigstring.get], this raises an exception if the index is out of bounds. *) val get : t -> int -> char (** [create ?pos ?len base] creates a substring of the base sequence of length [len] starting at position [pos], i.e., {[ base.[pos], base.[pos + 1], ... base.[pos + len - 1] ]} An exception is raised if any of those indices into [base] is invalid. It does not copy the characters, so mutating [base] mutates [t] and vice versa. *) val create : ?pos:int -> ?len:int -> base -> t val sub : ?pos:int -> ?len:int -> t -> t (** {2 Blit functions} For copying characters from a substring to and from both strings and substrings. *) val blit_to_string : t -> dst:bytes -> dst_pos:int -> unit val blit_to_bytes : t -> dst:bytes -> dst_pos:int -> unit val blit_to_bigstring : t -> dst:Bigstring.t -> dst_pos:int -> unit val blit_from_string : t -> src:string -> src_pos:int -> len:int -> unit val blit_from_bigstring : t -> src:Bigstring.t -> src_pos:int -> len:int -> unit (** {2 String concatenation} *) (** These functions always copy. *) val concat : t list -> t val concat_string : t list -> string val concat_bigstring : t list -> Bigstring.t (** {2 Conversion to/from substrings} *) (** These functions always copy. *) val to_string : t -> string val to_bigstring : t -> Bigstring.t (** These functions always copy. Use [create] if you want sharing. *) val of_string : string -> t [@@deprecated "[since 2017-11] use [create] instead"] val of_bigstring : Bigstring.t -> t [@@deprecated "[since 2017-11] use [create] instead"] (** {2 Prefixes and suffixes} The result of these functions share data with their input, but don't mutate the underlying string. *) val drop_prefix : t -> int -> t val drop_suffix : t -> int -> t val prefix : t -> int -> t val suffix : t -> int -> t end core-0.15.0/core/src/t.ml000066400000000000000000000002511420273305200150350ustar00rootroot00000000000000(** Derived from [Base.T]. Used for matching bare signatures with just a type. *) open! Import include Base.T module type T_bin = sig type t [@@deriving bin_io] end core-0.15.0/core/src/time.ml000066400000000000000000000415471420273305200155450ustar00rootroot00000000000000(* See time_float.ml for the primary instantiation of this functor that is visible outside of Core as Time (see core.ml). *) open! Import open Std_internal open! Int.Replace_polymorphic_compare include Time_intf module Make (Time0 : Time0_intf.S) = struct module Time0 = Time0 include Time0 let epoch = of_span_since_epoch Span.zero let is_earlier t1 ~than:t2 = t1 <. t2 let is_later t1 ~than:t2 = t1 >. t2 module Zone : sig include Time_intf.Zone with module Time := Time0 end = struct include Zone let of_span_in_seconds span_in_seconds = (* NB. no actual rounding or exns can occur here *) Time_in_seconds.Span.to_int63_seconds_round_down_exn span_in_seconds |> Time0.Span.of_int63_seconds ;; let of_time_in_seconds time_in_seconds = Time_in_seconds.to_span_since_epoch time_in_seconds (* NB. no actual rounding or exns can occur here *) |> Time_in_seconds.Span.to_int63_seconds_round_down_exn |> Time0.Span.of_int63_seconds |> Time0.of_span_since_epoch ;; let to_time_in_seconds_round_down_exn time = Time0.to_span_since_epoch time |> Time0.Span.to_int63_seconds_round_down_exn |> Time_in_seconds.Span.of_int63_seconds |> Time_in_seconds.of_span_since_epoch ;; let to_date_and_ofday_in_seconds_round_down_exn relative = Time0.Date_and_ofday.to_synthetic_span_since_epoch relative |> Time0.Span.to_int63_seconds_round_down_exn |> Time_in_seconds.Span.of_int63_seconds |> Time_in_seconds.Date_and_ofday.of_synthetic_span_since_epoch ;; let index t time = index t (to_time_in_seconds_round_down_exn time) let index_of_date_and_ofday t relative = index_of_date_and_ofday t (to_date_and_ofday_in_seconds_round_down_exn relative) ;; let index_offset_from_utc_exn t index = of_span_in_seconds (index_offset_from_utc_exn t index) ;; let index_prev_clock_shift_time_exn t index = of_time_in_seconds (index_prev_clock_shift_time_exn t index) ;; let index_next_clock_shift_time_exn t index = of_time_in_seconds (index_next_clock_shift_time_exn t index) ;; let index_prev_clock_shift_amount_exn t index = of_span_in_seconds (index_prev_clock_shift_amount_exn t index) ;; let index_next_clock_shift_amount_exn t index = of_span_in_seconds (index_next_clock_shift_amount_exn t index) ;; let abbreviation t time = (* no exn because [index] always returns a valid index *) index_abbreviation_exn t (index t time) ;; let index_prev_clock_shift t index = match index_has_prev_clock_shift t index with | false -> None | true -> Some ( index_prev_clock_shift_time_exn t index , index_prev_clock_shift_amount_exn t index ) ;; let index_next_clock_shift t index = index_prev_clock_shift t (Index.next index) let prev_clock_shift t ~at_or_before:time = index_prev_clock_shift t (index t time) let next_clock_shift t ~strictly_after:time = index_next_clock_shift t (index t time) let date_and_ofday_of_absolute_time t time = let index = index t time in (* no exn because [index] always returns a valid index *) let offset_from_utc = index_offset_from_utc_exn t index in Time0.Date_and_ofday.of_absolute time ~offset_from_utc ;; let absolute_time_of_date_and_ofday t relative = let index = index_of_date_and_ofday t relative in (* no exn because [index_of_date_and_ofday] always returns a valid index *) let offset_from_utc = index_offset_from_utc_exn t index in Time0.Date_and_ofday.to_absolute relative ~offset_from_utc ;; end let abs_diff t1 t2 = Span.abs (diff t1 t2) let of_date_ofday ~zone date ofday = let relative = Date_and_ofday.of_date_ofday date ofday in Zone.absolute_time_of_date_and_ofday zone relative ;; let of_date_ofday_precise date ofday ~zone = (* We assume that there will be only one zone shift within a given local day. *) let start_of_day = of_date_ofday ~zone date Ofday.start_of_day in let proposed_time = add start_of_day (Ofday.to_span_since_start_of_day ofday) in match Zone.next_clock_shift zone ~strictly_after:start_of_day with | None -> `Once proposed_time | Some (shift_start, shift_amount) -> let shift_backwards = Span.(shift_amount < zero) in (* start and end of the "problematic region" *) let s, e = if shift_backwards then add shift_start shift_amount, shift_start else shift_start, add shift_start shift_amount in if proposed_time < s then `Once proposed_time else if s <= proposed_time && proposed_time < e then if shift_backwards then `Twice (proposed_time, sub proposed_time shift_amount) else `Never shift_start else `Once (sub proposed_time shift_amount) ;; module Date_cache = struct type t = { mutable zone : Zone.t ; mutable cache_start_incl : Time0.t ; mutable cache_until_excl : Time0.t ; mutable effective_day_start : Time0.t ; mutable date : Date0.t } end let date_cache : Date_cache.t = { zone = Zone.utc ; cache_start_incl = epoch ; cache_until_excl = epoch ; effective_day_start = epoch ; date = Date0.unix_epoch } ;; let reset_date_cache () = date_cache.zone <- Zone.utc; date_cache.cache_start_incl <- epoch; date_cache.cache_until_excl <- epoch; date_cache.effective_day_start <- epoch; date_cache.date <- Date0.unix_epoch ;; let is_in_cache time ~zone = phys_equal zone date_cache.zone && Time0.( >= ) time date_cache.cache_start_incl && Time0.( < ) time date_cache.cache_until_excl ;; let set_date_cache time ~zone = match is_in_cache time ~zone with | true -> () | false -> let index = Zone.index zone time in (* no exn because [Zone.index] always returns a valid index *) let offset_from_utc = Zone.index_offset_from_utc_exn zone index in let rel = Date_and_ofday.of_absolute time ~offset_from_utc in let date = Date_and_ofday.to_date rel in let span = Date_and_ofday.to_ofday rel |> Ofday.to_span_since_start_of_day in let effective_day_start = Time0.sub (Date_and_ofday.to_absolute rel ~offset_from_utc) span in let effective_day_until = Time0.add effective_day_start Span.day in let cache_start_incl = match Zone.index_has_prev_clock_shift zone index with | false -> effective_day_start | true -> effective_day_start |> Time0.max (Zone.index_prev_clock_shift_time_exn zone index) in let cache_until_excl = match Zone.index_has_next_clock_shift zone index with | false -> effective_day_until | true -> effective_day_until |> Time0.min (Zone.index_next_clock_shift_time_exn zone index) in date_cache.zone <- zone; date_cache.cache_start_incl <- cache_start_incl; date_cache.cache_until_excl <- cache_until_excl; date_cache.effective_day_start <- effective_day_start; date_cache.date <- date ;; let to_date time ~zone = set_date_cache time ~zone; date_cache.date ;; let end_of_day = Ofday.prev Ofday.start_of_next_day |> Option.value_exn ~here:[%here] let to_ofday time ~zone = set_date_cache time ~zone; let of_day = Time0.diff time date_cache.effective_day_start |> Ofday.of_span_since_start_of_day_exn in if Ofday.equal of_day Ofday.start_of_next_day then end_of_day else of_day ;; let to_date_ofday time ~zone = to_date time ~zone, to_ofday time ~zone (* The correctness of this algorithm (interface, even) depends on the fact that timezone shifts aren't too close together (as in, it can't simultaneously be the case that a timezone shift of X hours occurred less than X hours ago, *and* a timezone shift of Y hours will occur in less than Y hours' time) *) let to_date_ofday_precise time ~zone = let date, ofday = to_date_ofday time ~zone in let clock_shift_after = Zone.next_clock_shift zone ~strictly_after:time in let clock_shift_before_or_at = Zone.prev_clock_shift zone ~at_or_before:time in let also_skipped_earlier amount = (* Using [date] and raising on [None] here is OK on the assumption that clock shifts can't cross date boundaries. This is true in all cases I've ever heard of (and [of_date_ofday_precise] would need revisiting if it turned out to be false) *) match Ofday.sub ofday amount with | Some ofday -> `Also_skipped (date, ofday) | None -> raise_s [%message "Time.to_date_ofday_precise" ~span_since_epoch:(to_span_since_epoch time : Span.t) (zone : Zone.t)] in let ambiguity = (* Edge cases: the instant of transition belongs to the new zone regime. So if the clock moved by an hour exactly one hour ago, there's no ambiguity, because the hour-ago time belongs to the same regime as you, and conversely, if the clock will move by an hour in an hours' time, there *is* ambiguity. Hence [>.] for the first case and [<=.] for the second. *) match clock_shift_before_or_at, clock_shift_after with | Some (start, amount), _ when add start (Span.abs amount) >. time -> (* clock shifted recently *) if Span.(amount > zero) then (* clock shifted forward recently: we skipped a time *) also_skipped_earlier amount else ( (* clock shifted back recently: this date/ofday already happened *) assert (Span.(amount < zero)); `Also_at (sub time (Span.abs amount))) | _, Some (start, amount) when sub start (Span.abs amount) <=. time -> (* clock is about to shift *) if Span.(amount > zero) then (* clock about to shift forward: no effect *) `Only else ( (* clock about to shift back: this date/ofday will be repeated *) assert (Span.(amount < zero)); `Also_at (add time (Span.abs amount))) | _ -> `Only in date, ofday, ambiguity ;; let convert ~from_tz ~to_tz date ofday = let start_time = of_date_ofday ~zone:from_tz date ofday in to_date_ofday ~zone:to_tz start_time ;; let utc_offset t ~zone = let utc_epoch = Zone.date_and_ofday_of_absolute_time zone t in Span.( - ) (Date_and_ofday.to_synthetic_span_since_epoch utc_epoch) (to_span_since_epoch t) ;; let offset_string time ~zone = let utc_offset = utc_offset time ~zone in let is_utc = Span.( = ) utc_offset Span.zero in if is_utc then "Z" else String.concat [ (if Span.( < ) utc_offset Span.zero then "-" else "+") ; Ofday.to_string_trimmed (Ofday.of_span_since_start_of_day_exn (Span.abs utc_offset)) ] ;; let to_string_abs_parts time ~zone = let date, ofday = to_date_ofday time ~zone in let offset_string = offset_string time ~zone in [ Date0.to_string date ; String.concat ~sep:"" [ Ofday.to_string ofday; offset_string ] ] ;; let to_string_abs_trimmed time ~zone = let date, ofday = to_date_ofday time ~zone in let offset_string = offset_string time ~zone in String.concat ~sep:" " [ Date0.to_string date; Ofday.to_string_trimmed ofday ^ offset_string ] ;; let to_string_abs time ~zone = String.concat ~sep:" " (to_string_abs_parts ~zone time) let to_string_utc t = to_string_abs t ~zone:Zone.utc let to_string = to_string_utc let to_string_iso8601_basic time ~zone = String.concat ~sep:"T" (to_string_abs_parts ~zone time) ;; let to_string_trimmed t ~zone = let date, sec = to_date_ofday ~zone t in Date0.to_string date ^ " " ^ Ofday.to_string_trimmed sec ;; let to_sec_string t ~zone = let date, sec = to_date_ofday ~zone t in Date0.to_string date ^ " " ^ Ofday.to_sec_string sec ;; let to_sec_string_with_zone t ~zone = to_sec_string t ~zone ^ offset_string t ~zone let to_filename_string t ~zone = let date, ofday = to_date_ofday ~zone t in Date0.to_string date ^ "_" ^ String.tr ~target:':' ~replacement:'-' (Ofday.to_string ofday) ;; let of_filename_string s ~zone = try match String.lsplit2 s ~on:'_' with | None -> failwith "no space in filename string" | Some (date, ofday) -> let date = Date0.of_string date in let ofday = String.tr ~target:'-' ~replacement:':' ofday in let ofday = Ofday.of_string ofday in of_date_ofday date ofday ~zone with | exn -> invalid_argf "Time.of_filename_string (%s): %s" s (Exn.to_string exn) () ;; let of_localized_string ~zone str = try match String.lsplit2 str ~on:' ' with | None -> invalid_arg (sprintf "no space in date_ofday string: %s" str) | Some (date, time) -> let date = Date0.of_string date in let ofday = Ofday.of_string time in of_date_ofday ~zone date ofday with | e -> Exn.reraise e "Time.of_localized_string" ;; let occurrence before_or_after t ~ofday ~zone = let first_guess_date = to_date t ~zone in let first_guess = of_date_ofday ~zone first_guess_date ofday in let cmp, increment = match before_or_after with | `Last_before_or_at -> ( <= ), -1 | `First_after_or_at -> ( >= ), 1 in if cmp first_guess t then first_guess else of_date_ofday ~zone (Date0.add_days first_guess_date increment) ofday ;; let ensure_colon_in_offset offset = let offset_length = String.length offset in if Int.( <= ) offset_length 2 && Char.is_digit offset.[0] && Char.is_digit offset.[offset_length - 1] then offset ^ ":00" else if Char.( = ) offset.[1] ':' || Char.( = ) offset.[2] ':' then offset else if Int.( < ) offset_length 3 || Int.( > ) offset_length 4 then failwithf "invalid offset %s" offset () else String.concat [ String.slice offset 0 (offset_length - 2) ; ":" ; String.slice offset (offset_length - 2) offset_length ] ;; exception Time_of_string of string * Exn.t [@@deriving sexp] let of_string_gen ~default_zone ~find_zone s = try let date, ofday, tz = match String.split s ~on:' ' with | [ day; month; year; ofday ] -> String.concat [ day; " "; month; " "; year ], ofday, None | [ date; ofday; tz ] -> date, ofday, Some tz | [ date; ofday ] -> date, ofday, None | [ s ] -> (match String.rsplit2 ~on:'T' s with | Some (date, ofday) -> date, ofday, None | None -> failwith "no spaces or T found") | _ -> failwith "too many spaces" in let ofday_to_sec od = Span.to_sec (Ofday.to_span_since_start_of_day od) in let ofday, utc_offset = match tz with | Some _ -> ofday, None | None -> if Char.( = ) ofday.[String.length ofday - 1] 'Z' then String.sub ofday ~pos:0 ~len:(String.length ofday - 1), Some 0. else ( match String.lsplit2 ~on:'+' ofday with | Some (l, r) -> l, Some (ofday_to_sec (Ofday.of_string (ensure_colon_in_offset r))) | None -> (match String.lsplit2 ~on:'-' ofday with | Some (l, r) -> l, Some (-1. *. ofday_to_sec (Ofday.of_string (ensure_colon_in_offset r))) | None -> ofday, None)) in let date = Date0.of_string date in let ofday = Ofday.of_string ofday in match tz with | Some tz -> of_date_ofday ~zone:(find_zone tz) date ofday | None -> (match utc_offset with | None -> let zone = default_zone () in of_date_ofday ~zone date ofday | Some utc_offset -> let utc_t = of_date_ofday ~zone:Zone.utc date ofday in sub utc_t (Span.of_sec utc_offset)) with | e -> raise (Time_of_string (s, e)) ;; let of_string_with_utc_offset s = let default_zone () = raise_s [%message "time has no time zone or UTC offset" s] in let find_zone zone_name = failwithf "unable to lookup Zone %s. Try using Core.Time.of_string" zone_name () in of_string_gen ~default_zone ~find_zone s ;; let of_string = of_string_with_utc_offset let quickcheck_shrinker = Quickcheck.Shrinker.map Span.quickcheck_shrinker ~f:of_span_since_epoch ~f_inverse:to_span_since_epoch ;; let quickcheck_observer = Quickcheck.Observer.unmap Span.quickcheck_observer ~f:to_span_since_epoch ;; let quickcheck_generator = Quickcheck.Generator.map Span.quickcheck_generator ~f:of_span_since_epoch ;; let gen_incl lo hi = Span.gen_incl (to_span_since_epoch lo) (to_span_since_epoch hi) |> Quickcheck.Generator.map ~f:of_span_since_epoch ;; let gen_uniform_incl lo hi = Span.gen_uniform_incl (to_span_since_epoch lo) (to_span_since_epoch hi) |> Quickcheck.Generator.map ~f:of_span_since_epoch ;; end core-0.15.0/core/src/time.mli000066400000000000000000000000271420273305200157020ustar00rootroot00000000000000include Time_intf.Time core-0.15.0/core/src/time0_intf.ml000066400000000000000000000067721420273305200166460ustar00rootroot00000000000000open! Import open Std_internal module type Basic = sig module Span : Span_intf.S type t module Replace_polymorphic_compare : Comparable.Polymorphic_compare with type t := t include Comparable.Polymorphic_compare with type t := t include Robustly_comparable with type t := t val add : t -> Span.t -> t val sub : t -> Span.t -> t val diff : t -> t -> Span.t (** [next t] returns the next t (forwards in time) *) val next : t -> t (** [prev t] returns the previous t (backwards in time) *) val prev : t -> t val to_span_since_epoch : t -> Span.t val of_span_since_epoch : Span.t -> t end module type S = sig type underlying type t = private underlying [@@deriving bin_io, compare, hash, typerep] module Span : Span_intf.S with type underlying = underlying module Ofday : Ofday_intf.S with type underlying := underlying and module Span := Span include Basic with type t := t and module Span := Span include Comparable.S_common with type t := t and module Replace_polymorphic_compare := Replace_polymorphic_compare (** Equivalent to a [Date.t] and an [Ofday.t] with no time zone. A [Date_and_ofday.t] does not correspond to a single, unambiguous point in time. *) module Date_and_ofday : sig type absolute = t type t = private underlying (** {2 Constructors and accessors} *) val of_date_ofday : Date0.t -> Ofday.t -> t val to_date_ofday : t -> Date0.t * Ofday.t val to_date : t -> Date0.t val to_ofday : t -> Ofday.t (** {2 Conversions between absolute times and date + ofday} Based on the offset from UTC at the given time. It is usually simpler to use the [Time.Zone] wrappers of these conversions. *) val of_absolute : absolute -> offset_from_utc:Span.t -> t val to_absolute : t -> offset_from_utc:Span.t -> absolute (** {2 Low-level conversions} Convert between [t] and a synthetic span representing the difference in date from epoch, times the length of a day, plus the ofday's distance from midnight. These spans do not correspond with any actual duration of time. Arithmetic on these spans is only meaningful within a range where no DST transitions can occur. For example, rounding to the nearest second makes sense but adding arbitrary spans does not. These functions are intended for low-level DST transition arithmetic. Most clients should not call these functions directly. *) val of_synthetic_span_since_epoch : Span.t -> t val to_synthetic_span_since_epoch : t -> Span.t end with type absolute := t (** [next_multiple ~base ~after ~interval] returns the smallest [time] of the form: {[ time = base + k * interval ]} where [k >= 0] and [time > after]. It is an error if [interval <= 0]. Supplying [~can_equal_after:true] allows the result to satisfy [time >= after]. *) val next_multiple : ?can_equal_after:bool (** default is [false] *) -> base:t -> after:t -> interval:Span.t -> unit -> t (** [prev_multiple ~base ~before ~interval] returns the largest [time] of the form: {[ time = base + k * interval ]} where [k >= 0] and [time < before]. It is an error if [interval <= 0]. Supplying [~can_equal_before:true] allows the result to satisfy [time <= before]. *) val prev_multiple : ?can_equal_before:bool (** default is [false] *) -> base:t -> before:t -> interval:Span.t -> unit -> t val now : unit -> t end core-0.15.0/core/src/time_float.ml000066400000000000000000000101021420273305200167110ustar00rootroot00000000000000open! Import open! Std_internal module type S_kernel_without_zone = Time0_intf.S module type S_kernel = Time_intf.S module Zone_stable = Zone.Stable include Time.Make (Time_float0) include Time_float0 module Stable = struct include Time_float0.Stable module V1 = struct end module With_t_of_sexp_abs = struct end module Ofday = struct include Ofday module Zoned = struct end end module With_utc_sexp = struct module V1 = struct end module V2 = struct type nonrec t = t [@@deriving bin_io, compare, hash] let sexp_of_t t = [%sexp (to_string_abs_parts t ~zone:Zone.utc : string list)] let t_of_sexp sexp = try match sexp with | Sexp.List [ Sexp.Atom date; Sexp.Atom ofday_and_possibly_zone ] -> of_string_gen ~default_zone:(fun () -> Zone.utc) ~find_zone:(fun _ -> of_sexp_error "Time.Stable.With_utc.V2.t_of_sexp: unknown time zone" sexp) (date ^ " " ^ ofday_and_possibly_zone) | _ -> of_sexp_error "Time.Stable.With_utc.V2.t_of_sexp" sexp with | Of_sexp_error _ as e -> raise e | e -> of_sexp_error (sprintf "Time.Stable.With_utc.V2.t_of_sexp: %s" (Exn.to_string e)) sexp ;; let t_sexp_grammar = Sexplib.Sexp_grammar.coerce Sexplib.Sexp.t_sexp_grammar let comparator = `Use_Time_unix module Map = struct end module Set = struct end end end module Zone = struct module V1 = struct end include Zone_stable end end module Ofday = struct include Ofday let arg_type = `Use_Time_unix let now = `Use_Time_unix module Zoned = struct end end module Span = struct include Span let arg_type = `Use_Time_unix end module Zone = struct include Zone module Hash_queue = struct end module Hash_set = struct end module Map = struct end module Replace_polymorphic_compare = struct end module Set = struct end module Table = struct end let ( < ) = `Use_Time_unix let ( <= ) = `Use_Time_unix let ( <> ) = `Use_Time_unix let ( = ) = `Use_Time_unix let ( > ) = `Use_Time_unix let ( >= ) = `Use_Time_unix let __bin_read_t__ = `Use_Time_unix let arg_type = `Use_Time_unix let ascending = `Use_Time_unix let between = `Use_Time_unix let bin_read_t = `Use_Time_unix let bin_reader_t = `Use_Time_unix let bin_shape_t = `Use_Time_unix let bin_size_t = `Use_Time_unix let bin_t = `Use_Time_unix let bin_write_t = `Use_Time_unix let bin_writer_t = `Use_Time_unix let clamp = `Use_Time_unix let clamp_exn = `Use_Time_unix let comparator = `Use_Time_unix let descending = `Use_Time_unix let equal = `Use_Time_unix let find = `Use_Time_unix let find_exn = `Use_Time_unix let hash = `Use_Time_unix let hash_fold_t = `Use_Time_unix let hashable = `Use_Time_unix let init = `Use_Time_unix let initialized_zones = `Use_Time_unix let local = `Use_Time_unix let max = `Use_Time_unix let min = `Use_Time_unix let of_string = `Use_Time_unix let pp = `Use_Time_unix let t_of_sexp = `Use_Time_unix let to_string = `Use_Time_unix let validate_bound = `Use_Time_unix let validate_lbound = `Use_Time_unix let validate_ubound = `Use_Time_unix end module Exposed_for_tests = struct end module Hash_queue = struct end module Hash_set = struct end module Map = struct end module Set = struct end module Table = struct end let arg_type = `Use_Time_unix let format = `Use_Time_unix let get_sexp_zone = `Use_Time_unix let hashable = `Use_Time_unix let interruptible_pause = `Use_Time_unix let of_date_ofday_zoned = `Use_Time_unix let of_string_abs = `Use_Time_unix let of_string_fix_proto = `Use_Time_unix let of_tm = `Use_Time_unix let parse = `Use_Time_unix let pause = `Use_Time_unix let pause_forever = `Use_Time_unix let pp = `Use_Time_unix let set_sexp_zone = `Use_Time_unix let sexp_of_t = `Use_Time_unix let sexp_of_t_abs = `Use_Time_unix let t_of_sexp = `Use_Time_unix let t_of_sexp_abs = `Use_Time_unix let to_date_ofday_zoned = `Use_Time_unix let to_ofday_zoned = `Use_Time_unix let to_string_fix_proto = `Use_Time_unix core-0.15.0/core/src/time_float.mli000066400000000000000000000200371420273305200170720ustar00rootroot00000000000000open! Import open! Std_internal module type S_kernel_without_zone = Time0_intf.S module type S_kernel = Time_intf.S include Time_intf.S with module Time := Time_float0 module Ofday : sig include module type of struct include Ofday end val arg_type : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val now : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] module Zoned : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] end module Span : sig include module type of struct include Span end val arg_type : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] end module Zone : sig include module type of struct include Zone end module Hash_queue : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] module Hash_set : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] module Map : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] module Replace_polymorphic_compare : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] module Set : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] module Table : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] val ( < ) : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val ( <= ) : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val ( <> ) : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val ( = ) : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val ( > ) : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val ( >= ) : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val __bin_read_t__ : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val arg_type : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val ascending : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val between : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val bin_read_t : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val bin_reader_t : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val bin_shape_t : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val bin_size_t : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val bin_t : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val bin_write_t : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val bin_writer_t : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val clamp : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val clamp_exn : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val comparator : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val descending : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val equal : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val find : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val find_exn : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val hash : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val hash_fold_t : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val hashable : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val init : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val initialized_zones : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val local : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val max : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val min : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val of_string : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val pp : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val t_of_sexp : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val to_string : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val validate_bound : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val validate_lbound : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val validate_ubound : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] end module Stable : sig include module type of struct include Time_float0.Stable end module Ofday : sig include module type of struct include Ofday end module Zoned : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] end module V1 : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] module With_t_of_sexp_abs : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] module With_utc_sexp : sig module V1 : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] (** [Time_unix.Stable.V1.t_of_sexp] has parsing that understands non-UTC time zones. *) module V2 : sig type t = Time_float0.t [@@deriving hash, sexp_grammar] include Stable_without_comparator with type t := t val comparator : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] module Map : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] module Set : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] end end module Zone : sig module V1 : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] include Zone_intf.S_stable with type t := Zone.t end end module Exposed_for_tests : sig end [@@deprecated "[since 2021-03] use [Time_unix]"] module Hash_queue : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] module Hash_set : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] module Map : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] module Set : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] module Table : sig end [@@deprecated "[since 2021-03] Use [Time_unix]"] val arg_type : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val format : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val get_sexp_zone : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val hashable : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val interruptible_pause : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val of_date_ofday_zoned : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val of_string : string -> t [@@deprecated "[since 2021-03] Use [of_string_with_utc_offset] or [Time_unix.of_string]"] val of_string_abs : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val of_string_fix_proto : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val of_tm : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val parse : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val pause : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val pause_forever : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val pp : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val set_sexp_zone : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val sexp_of_t : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val sexp_of_t_abs : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val t_of_sexp : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val t_of_sexp_abs : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val to_date_ofday_zoned : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val to_ofday_zoned : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] val to_string : t -> string [@@deprecated "[since 2021-03] Use [to_string_utc] or [Time_unix.to_string]"] val to_string_fix_proto : [ `Use_Time_unix ] [@@deprecated "[since 2021-03] Use [Time_unix]"] core-0.15.0/core/src/time_float0.ml000066400000000000000000000111261420273305200170000ustar00rootroot00000000000000open! Import open Std_internal open! Int.Replace_polymorphic_compare module Span = Span_float module Ofday = Ofday_float module Absolute = struct type underlying = Float.t include ( Float : sig type t = float [@@deriving bin_io, hash, typerep] include Comparable.S_common with type t := t include module type of struct include Float.O end end) (* due to precision limitations in float we can't expect better than microsecond precision *) include Float.Robust_compare.Make (struct let robust_comparison_tolerance = 1E-6 end) let diff t1 t2 = Span.of_sec (t1 - t2) let add t span = t +. Span.to_sec span let sub t span = t -. Span.to_sec span let prev t = Float.one_ulp `Down t let next t = Float.one_ulp `Up t let to_span_since_epoch = Span.of_sec let of_span_since_epoch = Span.to_sec end include Absolute module Date_and_ofday = struct type t = float let of_synthetic_span_since_epoch span = Span.to_sec span let to_synthetic_span_since_epoch t = Span.of_sec t let of_date_ofday date ofday = let days = Float.of_int (Date0.Days.diff (Date0.Days.of_date date) Date0.Days.unix_epoch) in (days *. 86400.) +. Span.to_sec (Ofday.to_span_since_start_of_day ofday) ;; let to_absolute relative ~offset_from_utc = sub relative offset_from_utc let of_absolute absolute ~offset_from_utc = add absolute offset_from_utc (* Years out of range for [Date.create_exn]. *) let[@cold] assert_in_bounds ~sec_since_epoch = (* $ TZ=UTC date --date=@-62167219200 Sat Jan 1 00:00:00 UTC 0000 *) let gmtime_lower_bound = -62_167_219_200. in (* $ TZ=UTC date --date=@253402300799 Fri Dec 31 23:59:59 UTC 9999 *) let gmtime_upper_bound = 253_402_300_799. in if Float.( >= ) sec_since_epoch (gmtime_upper_bound +. 1.) || Float.( < ) sec_since_epoch gmtime_lower_bound then failwithf "Time.gmtime: out of range (%f)" sec_since_epoch () ;; let sec_per_day = Int63.of_int 86_400 let to_days_from_epoch t = assert_in_bounds ~sec_since_epoch:t; let open Int63.O in let days_from_epoch_approx = Int63.of_float t / sec_per_day in (* when [t] is negative the integer division that calculated days_from_epoch_approx will leave us one day short because it truncates (e.g. -100 / 86_400 = 0 and we want -1) -- adjust for that here. *) if Float.( < ) t (Int63.to_float (days_from_epoch_approx * sec_per_day)) then Int63.pred days_from_epoch_approx else days_from_epoch_approx ;; let ofday_of_days_from_epoch t ~days_from_epoch = let open Int63.O in let days_from_epoch_in_sec = Int63.to_float (days_from_epoch * sec_per_day) in let remainder = t -. days_from_epoch_in_sec in Span.of_sec remainder |> Ofday.of_span_since_start_of_day_exn ;; let date_of_days_from_epoch ~days_from_epoch = Int63.to_int_exn days_from_epoch |> Date0.Days.add_days Date0.Days.unix_epoch |> Date0.Days.to_date ;; let to_date t = let days_from_epoch = to_days_from_epoch t in date_of_days_from_epoch ~days_from_epoch ;; let to_ofday t = let days_from_epoch = to_days_from_epoch t in ofday_of_days_from_epoch t ~days_from_epoch ;; let to_date_ofday t = let days_from_epoch = to_days_from_epoch t in let date = date_of_days_from_epoch ~days_from_epoch in let ofday = ofday_of_days_from_epoch t ~days_from_epoch in date, ofday ;; end let next_multiple_internal ~can_equal_after ~base ~after ~interval = if Span.( <= ) interval Span.zero then failwiths ~here:[%here] "Time.next_multiple got nonpositive interval" interval [%sexp_of: Span.t]; let base_to_after = diff after base in if Span.( < ) base_to_after Span.zero then base (* [after < base], choose [k = 0]. *) else ( let next = add base (Span.scale interval (Float.round ~dir:`Down (Span.( // ) base_to_after interval))) in if next > after || (can_equal_after && next = after) then next else add next interval) ;; let next_multiple ?(can_equal_after = false) ~base ~after ~interval () = next_multiple_internal ~can_equal_after ~base ~after ~interval ;; let prev_multiple ?(can_equal_before = false) ~base ~before ~interval () = next_multiple_internal ~can_equal_after:(not can_equal_before) ~base ~after:(sub before interval) ~interval ;; let now () = let float_ns = Time_now.nanoseconds_since_unix_epoch () |> Int63.to_float in of_span_since_epoch (Span.of_sec (float_ns *. 1E-9)) ;; module Stable = struct module Span = Span.Stable module Ofday = Ofday.Stable end core-0.15.0/core/src/time_float0.mli000066400000000000000000000006521420273305200171530ustar00rootroot00000000000000open! Import module Span : module type of struct include Span_float end with module Stable := Span_float.Stable module Ofday : module type of struct include Ofday_float end with module Stable := Ofday_float.Stable include Time0_intf.S with type underlying = float and module Span := Span and module Ofday := Ofday module Stable : sig module Span = Span_float.Stable module Ofday = Ofday_float.Stable end core-0.15.0/core/src/time_intf.ml000066400000000000000000000223371420273305200165610ustar00rootroot00000000000000open! Import open! Std_internal module Date = Date0 module type Zone = sig module Time : Time0_intf.S include Zone.S with type t = Zone.t and module Time_in_seconds := Time (** [abbreviation t time] returns the abbreviation name (such as EDT, EST, JST) of given zone [t] at [time]. This string conversion is one-way only, and cannot reliably be turned back into a [t]. This function reads and writes the zone's cached index. *) val abbreviation : t -> Time.t -> string (** [absolute_time_of_date_and_ofday] and [date_and_ofday_of_absolute_time] convert between absolute times and date + ofday forms. These are low level functions not intended for most clients. These functions read and write the zone's cached index. *) val absolute_time_of_date_and_ofday : t -> Time.Date_and_ofday.t -> Time.t val date_and_ofday_of_absolute_time : t -> Time.t -> Time.Date_and_ofday.t (** Takes a [Time.t] and returns the next [Time.t] strictly after it, if any, that the time zone UTC offset changes, and by how much it does so. *) val next_clock_shift : t -> strictly_after:Time.t -> (Time.t * Time.Span.t) option (** As [next_clock_shift], but *at or before* the given time. *) val prev_clock_shift : t -> at_or_before:Time.t -> (Time.t * Time.Span.t) option end module type Basic = sig module Time : Time0_intf.S (*_ necessary to preserve type equality with the Time functor argument *) include module type of struct include Time end [@ocaml.remove_aliases] (** [now ()] returns a [t] representing the current time *) val now : unit -> t module Zone : Zone with module Time := Time (** {6 Basic operations on times} *) (** [add t s] adds the span [s] to time [t] and returns the resulting time. NOTE: adding spans as a means of adding days is not accurate, and may run into trouble due to shifts in daylight savings time, float arithmetic issues, and leap seconds. See the comment at the top of Zone.mli for a more complete discussion of some of the issues of time-keeping. For spans that cross date boundaries, use date functions instead. *) val add : t -> Span.t -> t (** [sub t s] subtracts the span [s] from time [t] and returns the resulting time. See important note for [add]. *) val sub : t -> Span.t -> t (** [diff t1 t2] returns time [t1] minus time [t2]. *) val diff : t -> t -> Span.t (** [abs_diff t1 t2] returns the absolute span of time [t1] minus time [t2]. *) val abs_diff : t -> t -> Span.t end module type Shared = sig type t include Quickcheck.S_range with type t := t module Span : sig type t end module Ofday : sig type t end (** {6 Comparisons} *) val is_earlier : t -> than:t -> bool val is_later : t -> than:t -> bool (** {6 Conversions} *) val of_date_ofday : zone:Zone.t -> Date.t -> Ofday.t -> t (** Because timezone offsets change throughout the year (clocks go forward or back) some local times can occur twice or not at all. In the case that they occur twice, this function gives [`Twice] with both occurrences in order; if they do not occur at all, this function gives [`Never] with the time at which the local clock skips over the desired time of day. Note that this is really only intended to work with DST transitions and not unusual or dramatic changes, like the calendar change in 1752 (run "cal 9 1752" in a shell to see). In particular it makes the assumption that midnight of each day is unambiguous. Most callers should use {!of_date_ofday} rather than this function. In the [`Twice] and [`Never] cases, {!of_date_ofday} will return reasonable times for most uses. *) val of_date_ofday_precise : Date.t -> Ofday.t -> zone:Zone.t -> [ `Once of t | `Twice of t * t | `Never of t ] val to_date_ofday : t -> zone:Zone.t -> Date.t * Ofday.t (** Always returns the [Date.t * Ofday.t] that [to_date_ofday] would have returned, and in addition returns a variant indicating whether the time is associated with a time zone transition. {v - `Only -> there is a one-to-one mapping between [t]'s and [Date.t * Ofday.t] pairs - `Also_at -> there is another [t] that maps to the same [Date.t * Ofday.t] (this date/time pair happened twice because the clock fell back) - `Also_skipped -> there is another [Date.t * Ofday.t] pair that never happened (due to a jump forward) that [of_date_ofday] would map to the same [t]. v} *) val to_date_ofday_precise : t -> zone:Zone.t -> Date.t * Ofday.t * [ `Only | `Also_at of t | `Also_skipped of Date.t * Ofday.t ] val to_date : t -> zone:Zone.t -> Date.t val to_ofday : t -> zone:Zone.t -> Ofday.t (** For performance testing only; [reset_date_cache ()] resets an internal cache used to speed up [to_date] and related functions when called repeatedly on times that fall within the same day. *) val reset_date_cache : unit -> unit (** Unlike [Time_ns], this module purposely omits [max_value] and [min_value]: 1. They produce unintuitive corner cases because most people's mental models of time do not include +/- infinity as concrete values 2. In practice, when people ask for these values, it is for questionable uses, e.g., as null values to use in place of explicit options. *) (** midnight, Jan 1, 1970 in UTC *) val epoch : t (** It's unspecified what happens if the given date/ofday/zone correspond to more than one date/ofday pair in the other zone. *) val convert : from_tz:Zone.t -> to_tz:Zone.t -> Date.t -> Ofday.t -> Date.t * Ofday.t val utc_offset : t -> zone:Zone.t -> Span.t (** {6 Other string conversions} *) (** The [{to,of}_string] functions in [Time] convert to UTC time, because a local time zone is not necessarily available. They are generous in what they will read in. *) include Stringable with type t := t (** [to_filename_string t ~zone] converts [t] to string with format YYYY-MM-DD_HH-MM-SS.mmm which is suitable for using in filenames. *) val to_filename_string : t -> zone:Zone.t -> string (** [of_filename_string s ~zone] converts [s] that has format YYYY-MM-DD_HH-MM-SS.mmm into time. *) val of_filename_string : string -> zone:Zone.t -> t (** [to_string_abs ~zone t] is the same as [to_string t] except that it uses the given time zone. *) val to_string_abs : t -> zone:Zone.t -> string (** [to_string_abs_trimmed] is the same as [to_string_abs], but drops trailing seconds and milliseconds if they are 0. *) val to_string_abs_trimmed : t -> zone:Zone.t -> string val to_string_abs_parts : t -> zone:Zone.t -> string list (** Same as [to_string_abs_trimmed], except it leaves off the timezone, so won't reliably round trip. *) val to_string_trimmed : t -> zone:Zone.t -> string (** Same as [to_string_abs], but without milliseconds and the timezone *) val to_sec_string : t -> zone:Zone.t -> string (** Same as [to_sec_string] but includes timezone *) val to_sec_string_with_zone : t -> zone:Zone.t -> string (** [of_localized_string ~zone str] read in the given string assuming that it represents a time in zone and return the appropriate Time.t *) val of_localized_string : zone:Zone.t -> string -> t (** [of_string_gen ~default_zone ~find_zone s] attempts to parse [s] as a [t], calling out to [default_zone] and [find_zone] as needed. *) val of_string_gen : default_zone:(unit -> Zone.t) -> find_zone:(string -> Zone.t) -> string -> t (** [to_string_iso8601_basic] return a string representation of the following form: %Y-%m-%dT%H:%M:%S.%s%Z e.g. [ to_string_iso8601_basic ~zone:Time.Zone.utc epoch = "1970-01-01T00:00:00.000000Z" ] *) val to_string_iso8601_basic : t -> zone:Zone.t -> string (** [occurrence side time ~ofday ~zone] returns a [Time.t] that is the occurrence of ofday (in the given [zone]) that is the latest occurrence (<=) [time] or the earliest occurrence (>=) [time], according to [side]. NOTE: If the given time converted to wall clock time in the given zone is equal to ofday then the t returned will be equal to the t given. *) val occurrence : [ `First_after_or_at | `Last_before_or_at ] -> t -> ofday:Ofday.t -> zone:Zone.t -> t end module type S = sig include Basic include Shared with type t := t with module Span := Span with module Ofday := Ofday val of_string : string -> t [@@deprecated "[since 2021-04] Use [of_string_with_utc_offset] or [Time_unix.of_string]"] (** [of_string_with_utc_offset] requires its input to have an explicit UTC offset, e.g. [2000-01-01 12:34:56.789012-23], or use the UTC zone, "Z", e.g. [2000-01-01 12:34:56.789012Z]. *) val of_string_with_utc_offset : string -> t val to_string : t -> string [@@deprecated "[since 2021-04] Use [to_string_utc] or [Time_unix.to_string]"] (** [to_string_utc] generates a time string with the UTC zone, "Z", e.g. [2000-01-01 12:34:56.789012Z]. *) val to_string_utc : t -> string end module type Time = sig module type S = S module Make (Time : Time0_intf.S) : S with module Time := Time end core-0.15.0/core/src/time_ns.ml000066400000000000000000001032011420273305200162270ustar00rootroot00000000000000open! Import open Std_internal let arch_sixtyfour = Sys.word_size_in_bits = 64 module Span = Span_ns module Ofday = Ofday_ns type t = Span.t (* since the Unix epoch (1970-01-01 00:00:00 UTC) *) [@@deriving bin_io, compare, hash, typerep] module Replace_polymorphic_compare_efficient = Span.Replace_polymorphic_compare module Replace_polymorphic_compare = Replace_polymorphic_compare_efficient include Replace_polymorphic_compare_efficient include (Span : Quickcheck.S_range with type t := t) let now = Span.since_unix_epoch let equal = Span.equal let min_value_for_1us_rounding = Span.min_value_for_1us_rounding let max_value_for_1us_rounding = Span.max_value_for_1us_rounding let epoch = Span.zero let add = Span.( + ) let sub = Span.( - ) let diff = Span.( - ) let abs_diff t u = Span.abs (diff t u) let max = Span.max let min = Span.min let next = Span.next let prev = Span.prev let to_span_since_epoch t = t let of_span_since_epoch s = s let to_int63_ns_since_epoch t : Int63.t = Span.to_int63_ns (to_span_since_epoch t) let of_int63_ns_since_epoch i = of_span_since_epoch (Span.of_int63_ns i) let[@cold] overflow () = raise_s [%message "Time_ns: overflow"] let is_earlier t1 ~than:t2 = t1 < t2 let is_later t1 ~than:t2 = t1 > t2 let add_overflowed x y ~sum = if Span.( > ) y Span.zero then Span.( < ) sum x else Span.( > ) sum x ;; let sub_overflowed x y ~diff = if Span.( > ) y Span.zero then Span.( > ) diff x else Span.( < ) diff x ;; let add_exn x y = let sum = add x y in if add_overflowed x y ~sum then overflow () else sum ;; let sub_exn x y = let diff = sub x y in if sub_overflowed x y ~diff then overflow () else diff ;; let add_saturating x y = let sum = add x y in if add_overflowed x y ~sum then if Span.(y > zero) then Span.max_value_representable else Span.min_value_representable else sum ;; let sub_saturating x y = let diff = sub x y in if sub_overflowed x y ~diff then if Span.(y > zero) then Span.min_value_representable else Span.max_value_representable else diff ;; let to_int_ns_since_epoch = if arch_sixtyfour then fun t -> Int63.to_int_exn (to_int63_ns_since_epoch t) else fun _ -> failwith "Time_ns.to_int_ns_since_epoch: unsupported on 32bit machines" ;; let of_int_ns_since_epoch i = of_int63_ns_since_epoch (Int63.of_int i) let to_time_float_round_nearest t = Time_float.of_span_since_epoch (Span.to_span_float_round_nearest (to_span_since_epoch t)) ;; let to_time_float_round_nearest_microsecond t = Time_float.of_span_since_epoch (Span.to_span_float_round_nearest_microsecond (to_span_since_epoch t)) ;; let min_time_value_for_1us_rounding = to_time_float_round_nearest min_value_for_1us_rounding ;; let max_time_value_for_1us_rounding = to_time_float_round_nearest max_value_for_1us_rounding ;; let check_before_conversion_for_1us_rounding time = if Time_float.( < ) time min_time_value_for_1us_rounding || Time_float.( > ) time max_time_value_for_1us_rounding then failwiths ~here:[%here] "Time_ns does not support this time" time [%sexp_of: Time_float.Stable.With_utc_sexp.V2.t] ;; let of_time_float_round_nearest time = of_span_since_epoch (Span.of_span_float_round_nearest (Time_float.to_span_since_epoch time)) ;; let of_time_float_round_nearest_microsecond time = check_before_conversion_for_1us_rounding time; of_span_since_epoch (Span.of_span_float_round_nearest_microsecond (Time_float.to_span_since_epoch time)) ;; let[@cold] raise_next_multiple_got_nonpositive_interval interval = failwiths ~here:[%here] "Time_ns.next_multiple got nonpositive interval" interval [%sexp_of: Span.t] ;; let next_multiple_internal ~can_equal_after ~base ~after ~interval = if Span.( <= ) interval Span.zero then raise_next_multiple_got_nonpositive_interval interval; let base_to_after = diff after base in if Span.( < ) base_to_after Span.zero then base (* [after < base], choose [k = 0]. *) else ( let next = add base (Span.scale_int63 interval (Span.div base_to_after interval)) in if next > after || (can_equal_after && next = after) then next else add next interval) ;; let next_multiple ?(can_equal_after = false) ~base ~after ~interval () = next_multiple_internal ~can_equal_after ~base ~after ~interval ;; let prev_multiple ?(can_equal_before = false) ~base ~before ~interval () = next_multiple_internal ~can_equal_after:(not can_equal_before) ~base ~after:(sub before interval) ~interval ;; let random ?state () = Span.random ?state () module Utc : sig val to_date_and_span_since_start_of_day : t -> Date0.t * Span.t val of_date_and_span_since_start_of_day : Date0.t -> Span.t -> t end = struct (* a recreation of the system call gmtime specialized to the fields we need that also doesn't rely on Unix. *) let to_date_and_span_since_start_of_day t = let open Int63.O in let ( !< ) i = Int63.of_int_exn i in let ( !> ) t = Int63.to_int_exn t in let ns_since_epoch = to_int63_ns_since_epoch t in let ns_per_day = !<86_400 * !<1_000_000_000 in let approx_days_from_epoch = ns_since_epoch / ns_per_day in let days_from_epoch = if ns_since_epoch < !<0 && approx_days_from_epoch * ns_per_day <> ns_since_epoch then approx_days_from_epoch - !<1 else approx_days_from_epoch in let ns_since_start_of_day = ns_since_epoch - (ns_per_day * days_from_epoch) in let date = Date0.Days.add_days Date0.Days.unix_epoch !>days_from_epoch |> Date0.Days.to_date in let span_since_start_of_day = Span.of_int63_ns ns_since_start_of_day in date, span_since_start_of_day ;; let of_date_and_span_since_start_of_day date span_since_start_of_day = assert ( Span.( >= ) span_since_start_of_day Span.zero && Span.( < ) span_since_start_of_day Span.day); let days_from_epoch = Date0.Days.diff (Date0.Days.of_date date) Date0.Days.unix_epoch in let span_in_days_since_epoch = Span.scale_int Span.day days_from_epoch in let span_since_epoch = Span.( + ) span_in_days_since_epoch span_since_start_of_day in of_span_since_epoch span_since_epoch ;; end module Alternate_sexp = struct module T = struct type nonrec t = t [@@deriving compare, hash] module Ofday_as_span = struct open Int.O let seconds_to_string seconds_span = let seconds = Span.to_int_sec seconds_span in let h = seconds / 3600 in let m = seconds / 60 % 60 in let s = seconds % 60 in sprintf "%02d:%02d:%02d" h m s ;; let two_digit_of_string string = assert (String.length string = 2 && String.for_all string ~f:Char.is_digit); Int.of_string string ;; let seconds_of_string seconds_string = match String.split seconds_string ~on:':' with | [ h_string; m_string; s_string ] -> let h = two_digit_of_string h_string in let m = two_digit_of_string m_string in let s = two_digit_of_string s_string in Span.of_int_sec ((((h * 60) + m) * 60) + s) | _ -> assert false ;; let ns_of_100_ms = 100_000_000 let ns_of_10_ms = 10_000_000 let ns_of_1_ms = 1_000_000 let ns_of_100_us = 100_000 let ns_of_10_us = 10_000 let ns_of_1_us = 1_000 let ns_of_100_ns = 100 let ns_of_10_ns = 10 let ns_of_1_ns = 1 let sub_second_to_string sub_second_span = let open Int.O in let ns = Span.to_int63_ns sub_second_span |> Int63.to_int_exn in if ns = 0 then "" else if ns % ns_of_100_ms = 0 then sprintf ".%01d" (ns / ns_of_100_ms) else if ns % ns_of_10_ms = 0 then sprintf ".%02d" (ns / ns_of_10_ms) else if ns % ns_of_1_ms = 0 then sprintf ".%03d" (ns / ns_of_1_ms) else if ns % ns_of_100_us = 0 then sprintf ".%04d" (ns / ns_of_100_us) else if ns % ns_of_10_us = 0 then sprintf ".%05d" (ns / ns_of_10_us) else if ns % ns_of_1_us = 0 then sprintf ".%06d" (ns / ns_of_1_us) else if ns % ns_of_100_ns = 0 then sprintf ".%07d" (ns / ns_of_100_ns) else if ns % ns_of_10_ns = 0 then sprintf ".%08d" (ns / ns_of_10_ns) else sprintf ".%09d" ns ;; let sub_second_of_string string = if String.is_empty string then Span.zero else ( let digits = String.chop_prefix_exn string ~prefix:"." in assert (String.for_all digits ~f:Char.is_digit); let multiplier = match String.length digits with | 1 -> ns_of_100_ms | 2 -> ns_of_10_ms | 3 -> ns_of_1_ms | 4 -> ns_of_100_us | 5 -> ns_of_10_us | 6 -> ns_of_1_us | 7 -> ns_of_100_ns | 8 -> ns_of_10_ns | 9 -> ns_of_1_ns | _ -> assert false in Span.of_int63_ns (Int63.of_int (Int.of_string digits * multiplier))) ;; let to_string span = assert (Span.( >= ) span Span.zero && Span.( < ) span Span.day); let seconds_span = span |> Span.to_int_sec |> Span.of_int_sec in let sub_second_span = Span.( - ) span seconds_span in seconds_to_string seconds_span ^ sub_second_to_string sub_second_span ;; let of_string string = let len = String.length string in let prefix_len = 8 in (* "HH:MM:DD" *) let suffix_len = len - prefix_len in let seconds_string = String.sub string ~pos:0 ~len:prefix_len in let sub_second_string = String.sub string ~pos:prefix_len ~len:suffix_len in let seconds_span = seconds_of_string seconds_string in let sub_second_span = sub_second_of_string sub_second_string in Span.( + ) seconds_span sub_second_span ;; end let to_string t = let date, span_since_start_of_day = Utc.to_date_and_span_since_start_of_day t in Date0.to_string date ^ " " ^ Ofday_as_span.to_string span_since_start_of_day ^ "Z" ;; let of_string string = let date_string, ofday_string_with_zone = String.lsplit2_exn string ~on:' ' in let ofday_string = String.chop_suffix_exn ofday_string_with_zone ~suffix:"Z" in let date = Date0.of_string date_string in let ofday = Ofday_as_span.of_string ofday_string in Utc.of_date_and_span_since_start_of_day date ofday ;; let t_sexp_grammar = Sexplib.Sexp_grammar.coerce String.t_sexp_grammar include Sexpable.Of_stringable (struct type nonrec t = t let to_string = to_string let of_string = of_string end) end include T include Comparable.Make (T) include Replace_polymorphic_compare_efficient module Stable = struct module V1 = struct module T = struct (* see tests in lib/core/test/src/test_time_ns that ensure stability of this representation *) type nonrec t = t [@@deriving bin_io, compare, hash, sexp, sexp_grammar] type nonrec comparator_witness = comparator_witness let comparator = comparator end include T include Comparable.Stable.V1.Make (T) end end end module Stable = struct module V1 = struct end module Option = struct end module Alternate_sexp = Alternate_sexp.Stable module Span = Span.Stable module Ofday = Ofday.Stable end (* this code is directly duplicated from Time.ml functor, converted enough to get Time_ns to/of_string working *) module To_and_of_string : sig val of_date_ofday : zone:Zone.t -> Date.t -> Ofday.t -> t val of_date_ofday_precise : Date.t -> Ofday.t -> zone:Zone.t -> [ `Once of t | `Twice of t * t | `Never of t ] val to_date_ofday : t -> zone:Zone.t -> Date.t * Ofday.t val to_date_ofday_precise : t -> zone:Zone.t -> Date.t * Ofday.t * [ `Only | `Also_at of t | `Also_skipped of Date.t * Ofday.t ] val to_date : t -> zone:Zone.t -> Date.t val to_ofday : t -> zone:Zone.t -> Ofday.t val convert : from_tz:Zone.t -> to_tz:Zone.t -> Date.t -> Ofday.t -> Date.t * Ofday.t val reset_date_cache : unit -> unit val utc_offset : t -> zone:Zone.t -> Span.t val of_string : string -> t [@@deprecated "[since 2021-04] Use [of_string_with_utc_offset]"] val of_string_with_utc_offset : string -> t val to_string : t -> string [@@deprecated "[since 2021-04] Use [to_string_utc]"] val to_string_utc : t -> string val to_filename_string : t -> zone:Zone.t -> string val of_filename_string : string -> zone:Zone.t -> t val to_string_trimmed : t -> zone:Zone.t -> string val to_sec_string : t -> zone:Zone.t -> string val to_sec_string_with_zone : t -> zone:Zone.t -> string val of_localized_string : zone:Zone.t -> string -> t val of_string_gen : default_zone:(unit -> Zone.t) -> find_zone:(string -> Zone.t) -> string -> t val to_string_abs : t -> zone:Zone.t -> string val to_string_abs_trimmed : t -> zone:Zone.t -> string val to_string_abs_parts : t -> zone:Zone.t -> string list val to_string_iso8601_basic : t -> zone:Zone.t -> string val occurrence : [ `First_after_or_at | `Last_before_or_at ] -> t -> ofday:Ofday.t -> zone:Zone.t -> t end = struct (* this code is directly duplicated from Time_float0.ml, converted enough to get Time_ns to/of_string working *) module Date_and_ofday = struct type t = Int63.t let to_synthetic_span_since_epoch t = Span.of_int63_ns t let of_date_ofday date ofday = let days = Date0.Days.diff (Date0.Days.of_date date) Date0.Days.unix_epoch |> Int63.of_int in let open Int63.O in (days * Span.to_int63_ns Span.day) + Span.to_int63_ns (Ofday.to_span_since_start_of_day ofday) ;; let to_absolute relative ~offset_from_utc = sub_exn (Span.of_int63_ns relative) offset_from_utc ;; let of_absolute absolute ~offset_from_utc = Span.to_int63_ns (add_exn absolute offset_from_utc) ;; let ns_per_day = Span.to_int63_ns Span.day let to_days_from_epoch t = (* note Time_ns represents about 146 years, not enough for [Date.create_exn] to ever raise *) let open Int63.O in let days_from_epoch_approx = t / ns_per_day in (* when [t] is negative the integer division that calculated days_from_epoch_approx will leave us one day short because it truncates (e.g. -100 / 86_400 = 0 and we want -1) -- adjust for that here. *) if t < days_from_epoch_approx * ns_per_day then Int63.pred days_from_epoch_approx else days_from_epoch_approx ;; let ofday_of_days_from_epoch t ~days_from_epoch = let open Int63.O in let days_from_epoch_in_ns = days_from_epoch * ns_per_day in let remainder = t - days_from_epoch_in_ns in Span.of_int63_ns remainder |> Ofday.of_span_since_start_of_day_exn ;; let date_of_days_from_epoch ~days_from_epoch = Int63.to_int_exn days_from_epoch |> Date0.Days.add_days Date0.Days.unix_epoch |> Date0.Days.to_date ;; let to_date t = let days_from_epoch = to_days_from_epoch t in date_of_days_from_epoch ~days_from_epoch ;; let to_ofday t = let days_from_epoch = to_days_from_epoch t in ofday_of_days_from_epoch t ~days_from_epoch ;; end module Zone : sig (* This interface is directly duplicated from Time_intf.Zone, converted enough to get this to work. The problem is has references to Time0_intf.S, which is the functor input interface that Time_ns currently does not satisfy. *) type time = t type t = Zone.t [@@deriving sexp_of] module Index = Zone.Index (* copied functions reexported from Zone *) val utc : t val index_has_prev_clock_shift : t -> Index.t -> bool val index_has_next_clock_shift : t -> Index.t -> bool (* new functions defined below *) val index : t -> time -> Index.t val index_offset_from_utc_exn : t -> Index.t -> time val index_prev_clock_shift_time_exn : t -> Index.t -> time val index_next_clock_shift_time_exn : t -> Index.t -> time val absolute_time_of_date_and_ofday : t -> Date_and_ofday.t -> time val date_and_ofday_of_absolute_time : t -> time -> Date_and_ofday.t val next_clock_shift : t -> strictly_after:time -> (time * Span.t) option val prev_clock_shift : t -> at_or_before:time -> (time * Span.t) option end = struct type time = t include Zone let of_span_in_seconds span_in_seconds = (* NB. no actual rounding or exns can occur here *) Time_in_seconds.Span.to_int63_seconds_round_down_exn span_in_seconds |> Span.of_int63_seconds ;; let of_time_in_seconds time_in_seconds = Time_in_seconds.to_span_since_epoch time_in_seconds (* NB. no actual rounding or exns can occur here *) |> Time_in_seconds.Span.to_int63_seconds_round_down_exn |> Span.of_int63_seconds |> of_span_since_epoch ;; let to_time_in_seconds_round_down_exn time = to_span_since_epoch time |> Span.to_int63_seconds_round_down_exn |> Time_in_seconds.Span.of_int63_seconds |> Time_in_seconds.of_span_since_epoch ;; let to_date_and_ofday_in_seconds_round_down_exn relative = Date_and_ofday.to_synthetic_span_since_epoch relative |> Span.to_int63_seconds_round_down_exn |> Time_in_seconds.Span.of_int63_seconds |> Time_in_seconds.Date_and_ofday.of_synthetic_span_since_epoch ;; let index t time = index t (to_time_in_seconds_round_down_exn time) let index_of_date_and_ofday t relative = index_of_date_and_ofday t (to_date_and_ofday_in_seconds_round_down_exn relative) ;; let index_offset_from_utc_exn t index = of_span_in_seconds (index_offset_from_utc_exn t index) ;; let index_prev_clock_shift_time_exn t index = of_time_in_seconds (index_prev_clock_shift_time_exn t index) ;; let index_next_clock_shift_time_exn t index = of_time_in_seconds (index_next_clock_shift_time_exn t index) ;; let index_prev_clock_shift_amount_exn t index = of_span_in_seconds (index_prev_clock_shift_amount_exn t index) ;; let index_prev_clock_shift t index = match index_has_prev_clock_shift t index with | false -> None | true -> Some ( index_prev_clock_shift_time_exn t index , index_prev_clock_shift_amount_exn t index ) ;; let index_next_clock_shift t index = index_prev_clock_shift t (Index.next index) let prev_clock_shift t ~at_or_before:time = index_prev_clock_shift t (index t time) let next_clock_shift t ~strictly_after:time = index_next_clock_shift t (index t time) let date_and_ofday_of_absolute_time t time = let index = index t time in (* no exn because [index] always returns a valid index *) let offset_from_utc = index_offset_from_utc_exn t index in Date_and_ofday.of_absolute time ~offset_from_utc ;; let absolute_time_of_date_and_ofday t relative = let index = index_of_date_and_ofday t relative in (* no exn because [index_of_date_and_ofday] always returns a valid index *) let offset_from_utc = index_offset_from_utc_exn t index in Date_and_ofday.to_absolute relative ~offset_from_utc ;; end let of_date_ofday ~zone date ofday = let relative = Date_and_ofday.of_date_ofday date ofday in Zone.absolute_time_of_date_and_ofday zone relative ;; let of_date_ofday_precise date ofday ~zone = (* We assume that there will be only one zone shift within a given local day. *) let start_of_day = of_date_ofday ~zone date Ofday.start_of_day in let proposed_time = add start_of_day (Ofday.to_span_since_start_of_day ofday) in match Zone.next_clock_shift zone ~strictly_after:start_of_day with | None -> `Once proposed_time | Some (shift_start, shift_amount) -> let shift_backwards = Span.(shift_amount < zero) in (* start and end of the "problematic region" *) let s, e = if shift_backwards then add shift_start shift_amount, shift_start else shift_start, add shift_start shift_amount in if proposed_time < s then `Once proposed_time else if s <= proposed_time && proposed_time < e then if shift_backwards then `Twice (proposed_time, sub proposed_time shift_amount) else `Never shift_start else `Once (sub proposed_time shift_amount) ;; module Date_cache = struct type nonrec t = { mutable zone : Zone.t ; mutable cache_start_incl : t ; mutable cache_until_excl : t ; mutable effective_day_start : t ; mutable date : Date0.t } end let date_cache : Date_cache.t = { zone = Zone.utc ; cache_start_incl = epoch ; cache_until_excl = epoch ; effective_day_start = epoch ; date = Date0.unix_epoch } ;; let reset_date_cache () = date_cache.zone <- Zone.utc; date_cache.cache_start_incl <- epoch; date_cache.cache_until_excl <- epoch; date_cache.effective_day_start <- epoch; date_cache.date <- Date0.unix_epoch ;; let is_in_cache time ~zone = phys_equal zone date_cache.zone && time >= date_cache.cache_start_incl && time < date_cache.cache_until_excl ;; let set_date_cache time ~zone = match is_in_cache time ~zone with | true -> () | false -> let index = Zone.index zone time in (* no exn because [Zone.index] always returns a valid index *) let offset_from_utc = Zone.index_offset_from_utc_exn zone index in let rel = Date_and_ofday.of_absolute time ~offset_from_utc in let date = Date_and_ofday.to_date rel in let span = Date_and_ofday.to_ofday rel |> Ofday.to_span_since_start_of_day in let effective_day_start = sub (Date_and_ofday.to_absolute rel ~offset_from_utc) span in let effective_day_until = add effective_day_start Span.day in let cache_start_incl = match Zone.index_has_prev_clock_shift zone index with | false -> effective_day_start | true -> effective_day_start |> max (Zone.index_prev_clock_shift_time_exn zone index) in let cache_until_excl = match Zone.index_has_next_clock_shift zone index with | false -> effective_day_until | true -> effective_day_until |> min (Zone.index_next_clock_shift_time_exn zone index) in date_cache.zone <- zone; date_cache.cache_start_incl <- cache_start_incl; date_cache.cache_until_excl <- cache_until_excl; date_cache.effective_day_start <- effective_day_start; date_cache.date <- date ;; let to_date time ~zone = set_date_cache time ~zone; date_cache.date ;; let to_ofday time ~zone = set_date_cache time ~zone; diff time date_cache.effective_day_start |> Ofday.of_span_since_start_of_day_exn ;; let to_date_ofday time ~zone = to_date time ~zone, to_ofday time ~zone (* The correctness of this algorithm (interface, even) depends on the fact that timezone shifts aren't too close together (as in, it can't simultaneously be the case that a timezone shift of X hours occurred less than X hours ago, *and* a timezone shift of Y hours will occur in less than Y hours' time) *) let to_date_ofday_precise time ~zone = let date, ofday = to_date_ofday time ~zone in let clock_shift_after = Zone.next_clock_shift zone ~strictly_after:time in let clock_shift_before_or_at = Zone.prev_clock_shift zone ~at_or_before:time in let also_skipped_earlier amount = (* Using [date] and raising on [None] here is OK on the assumption that clock shifts can't cross date boundaries. This is true in all cases I've ever heard of (and [of_date_ofday_precise] would need revisiting if it turned out to be false) *) match Ofday.sub ofday amount with | Some ofday -> `Also_skipped (date, ofday) | None -> raise_s [%message "Time.to_date_ofday_precise" ~span_since_epoch:(to_span_since_epoch time : Span.t) (zone : Zone.t)] in let ambiguity = (* Edge cases: the instant of transition belongs to the new zone regime. So if the clock moved by an hour exactly one hour ago, there's no ambiguity, because the hour-ago time belongs to the same regime as you, and conversely, if the clock will move by an hour in an hours' time, there *is* ambiguity. Hence [>.] for the first case and [<=.] for the second. *) match clock_shift_before_or_at, clock_shift_after with | Some (start, amount), _ when add start (Span.abs amount) > time -> (* clock shifted recently *) if Span.(amount > zero) then (* clock shifted forward recently: we skipped a time *) also_skipped_earlier amount else ( (* clock shifted back recently: this date/ofday already happened *) assert (Span.(amount < zero)); `Also_at (sub time (Span.abs amount))) | _, Some (start, amount) when sub start (Span.abs amount) <= time -> (* clock is about to shift *) if Span.(amount > zero) then (* clock about to shift forward: no effect *) `Only else ( (* clock about to shift back: this date/ofday will be repeated *) assert (Span.(amount < zero)); `Also_at (add time (Span.abs amount))) | _ -> `Only in date, ofday, ambiguity ;; let convert ~from_tz ~to_tz date ofday = let start_time = of_date_ofday ~zone:from_tz date ofday in to_date_ofday ~zone:to_tz start_time ;; let utc_offset t ~zone = let utc_epoch = Zone.date_and_ofday_of_absolute_time zone t in Span.( - ) (Date_and_ofday.to_synthetic_span_since_epoch utc_epoch) (to_span_since_epoch t) ;; let offset_string time ~zone = let utc_offset = utc_offset time ~zone in let is_utc = Span.( = ) utc_offset Span.zero in if is_utc then "Z" else String.concat [ (if Span.( < ) utc_offset Span.zero then "-" else "+") ; Ofday.to_string_trimmed (Ofday.of_span_since_start_of_day_exn (Span.abs utc_offset)) ] ;; let to_string_abs_parts = let attempt time ~zone = let date, ofday = to_date_ofday time ~zone in let offset_string = offset_string time ~zone in [ Date0.to_string date ; String.concat ~sep:"" [ Ofday.to_string ofday; offset_string ] ] in fun time ~zone -> try attempt time ~zone with | (_ : exn) -> (* If we overflow applying the UTC offset, try again with UTC time. *) attempt time ~zone:Zone.utc ;; let to_string_abs_trimmed time ~zone = let date, ofday = to_date_ofday time ~zone in let offset_string = offset_string time ~zone in String.concat ~sep:" " [ Date0.to_string date; Ofday.to_string_trimmed ofday ^ offset_string ] ;; let to_string_abs time ~zone = String.concat ~sep:" " (to_string_abs_parts ~zone time) let to_string_utc t = to_string_abs t ~zone:Zone.utc let to_string = to_string_utc let to_string_iso8601_basic time ~zone = String.concat ~sep:"T" (to_string_abs_parts ~zone time) ;; let to_string_trimmed t ~zone = let date, sec = to_date_ofday ~zone t in Date0.to_string date ^ " " ^ Ofday.to_string_trimmed sec ;; let to_sec_string t ~zone = let date, sec = to_date_ofday ~zone t in Date0.to_string date ^ " " ^ Ofday.to_sec_string sec ;; let to_sec_string_with_zone t ~zone = to_sec_string t ~zone ^ offset_string t ~zone let to_filename_string t ~zone = let date, ofday = to_date_ofday ~zone t in Date0.to_string date ^ "_" ^ String.tr ~target:':' ~replacement:'-' (String.drop_suffix (Ofday.to_string ofday) 3) ;; let of_filename_string s ~zone = try match String.lsplit2 s ~on:'_' with | None -> failwith "no space in filename string" | Some (date, ofday) -> let date = Date0.of_string date in let ofday = String.tr ~target:'-' ~replacement:':' ofday in let ofday = Ofday.of_string ofday in of_date_ofday date ofday ~zone with | exn -> invalid_argf "Time.of_filename_string (%s): %s" s (Exn.to_string exn) () ;; let of_localized_string ~zone str = try match String.lsplit2 str ~on:' ' with | None -> invalid_arg (sprintf "no space in date_ofday string: %s" str) | Some (date, time) -> let date = Date0.of_string date in let ofday = Ofday.of_string time in of_date_ofday ~zone date ofday with | e -> Exn.reraise e "Time.of_localized_string" ;; let occurrence before_or_after t ~ofday ~zone = let first_guess_date = to_date t ~zone in let first_guess = of_date_ofday ~zone first_guess_date ofday in let cmp, increment = match before_or_after with | `Last_before_or_at -> ( <= ), -1 | `First_after_or_at -> ( >= ), 1 in if cmp first_guess t then first_guess else of_date_ofday ~zone (Date0.add_days first_guess_date increment) ofday ;; let ensure_colon_in_offset offset = let offset_length = String.length offset in if Int.( <= ) offset_length 2 && Char.is_digit offset.[0] && Char.is_digit offset.[offset_length - 1] then offset ^ ":00" else if Char.( = ) offset.[1] ':' || Char.( = ) offset.[2] ':' then offset else if Int.( < ) offset_length 3 || Int.( > ) offset_length 4 then failwithf "invalid offset %s" offset () else String.concat [ String.slice offset 0 (offset_length - 2) ; ":" ; String.slice offset (offset_length - 2) offset_length ] ;; exception Time_ns_of_string of string * Exn.t [@@deriving sexp] let of_string_gen ~default_zone ~find_zone s = try let date, ofday, tz = match String.split s ~on:' ' with | [ day; month; year; ofday ] -> String.concat [ day; " "; month; " "; year ], ofday, None | [ date; ofday; tz ] -> date, ofday, Some tz | [ date; ofday ] -> date, ofday, None | [ s ] -> (match String.rsplit2 ~on:'T' s with | Some (date, ofday) -> date, ofday, None | None -> failwith "no spaces or T found") | _ -> failwith "too many spaces" in let ofday_to_sec od = Span.to_sec (Ofday.to_span_since_start_of_day od) in let ofday, utc_offset = match tz with | Some _ -> ofday, None | None -> if Char.( = ) ofday.[String.length ofday - 1] 'Z' then String.sub ofday ~pos:0 ~len:(String.length ofday - 1), Some 0. else ( match String.lsplit2 ~on:'+' ofday with | Some (l, r) -> l, Some (ofday_to_sec (Ofday.of_string (ensure_colon_in_offset r))) | None -> (match String.lsplit2 ~on:'-' ofday with | Some (l, r) -> l, Some (-1. *. ofday_to_sec (Ofday.of_string (ensure_colon_in_offset r))) | None -> ofday, None)) in let date = Date0.of_string date in let ofday = Ofday.of_string ofday in match tz with | Some tz -> of_date_ofday ~zone:(find_zone tz) date ofday | None -> (match utc_offset with | None -> let zone = default_zone () in of_date_ofday ~zone date ofday | Some utc_offset -> let utc_t = of_date_ofday ~zone:Zone.utc date ofday in sub utc_t (Span.of_sec utc_offset)) with | e -> raise (Time_ns_of_string (s, e)) ;; let of_string_with_utc_offset s = let default_zone () = raise_s [%message "time has no time zone or UTC offset" s] in let find_zone zone_name = failwithf "unable to lookup Zone %s. Try using Core.Time.of_string" zone_name () in of_string_gen ~default_zone ~find_zone s ;; let of_string = of_string_with_utc_offset end include To_and_of_string let min_value_representable = of_span_since_epoch Span.min_value_representable let max_value_representable = of_span_since_epoch Span.max_value_representable (* Legacy definitions based on rounding to the nearest microsecond. *) let min_value = min_value_for_1us_rounding let max_value = max_value_for_1us_rounding let to_time = to_time_float_round_nearest_microsecond let of_time = of_time_float_round_nearest_microsecond module _ = struct open Ppx_module_timer_runtime let () = Duration.format := (module struct let duration_of_span s = s |> Span.to_int63_ns |> Duration.of_nanoseconds let span_of_duration d = d |> Duration.to_nanoseconds |> Span.of_int63_ns let of_string string = string |> Span.of_string |> duration_of_span let to_string_with_same_unit durations = let spans = durations |> List.map ~f:span_of_duration in let unit_of_time = spans |> List.max_elt ~compare:Span.compare |> Option.value_map ~f:Span.to_unit_of_time ~default:Unit_of_time.Nanosecond in spans |> List.map ~f:(Span.to_string_hum ~unit_of_time ~align_decimal:true) ;; end) ;; end module Hash_queue = struct end module Hash_set = struct end module Map = struct end module Option = struct end module Set = struct end module Table = struct end module Zone = struct end let arg_type = `Use_Time_ns_unix let comparator = `Use_Time_ns_unix let get_sexp_zone = `Use_Time_ns_unix let interruptible_pause = `Use_Time_ns_unix let of_date_ofday_zoned = `Use_Time_ns_unix let of_string_abs = `Use_Time_ns_unix let of_string_fix_proto = `Use_Time_ns_unix let pause = `Use_Time_ns_unix let pause_forever = `Use_Time_ns_unix let pp = `Use_Time_ns_unix let set_sexp_zone = `Use_Time_ns_unix let sexp_of_t = `Use_Time_ns_unix let sexp_of_t_abs = `Use_Time_ns_unix let t_of_sexp = `Use_Time_ns_unix let t_of_sexp_abs = `Use_Time_ns_unix let to_date_ofday_zoned = `Use_Time_ns_unix let to_ofday_zoned = `Use_Time_ns_unix let to_string_fix_proto = `Use_Time_ns_unix let validate_bound = `Use_Time_ns_unix let validate_lbound = `Use_Time_ns_unix let validate_ubound = `Use_Time_ns_unix core-0.15.0/core/src/time_ns.mli000066400000000000000000000001011420273305200163730ustar00rootroot00000000000000(** Time module. *) include Time_ns_intf.Time_ns (** @inline *) core-0.15.0/core/src/time_ns_alternate_sexp.ml000066400000000000000000000000641420273305200213300ustar00rootroot00000000000000open! Import include Time_ns include Alternate_sexp core-0.15.0/core/src/time_ns_alternate_sexp.mli000066400000000000000000000003001420273305200214720ustar00rootroot00000000000000(** A [Time_ns] that uses its alternate sexp representation. **) open! Import include module type of struct include Time_ns end include module type of struct include Alternate_sexp end core-0.15.0/core/src/time_ns_intf.ml000066400000000000000000000376611420273305200172670ustar00rootroot00000000000000open! Import open Std_internal module type Span = sig (** [t] is immediate on 64bit boxes and so plays nicely with the GC write barrier. *) type t = private Int63.t [@@deriving hash] include Span_intf.S with type underlying = Int63.t and type t := t val of_sec_with_microsecond_precision : float -> t val of_int_us : int -> t val of_int_ms : int -> t val to_int_us : t -> int val to_int_ms : t -> int val to_int_sec : t -> int (** The minimum representable time span. *) val min_value_representable : t (** The maximum representable time span. *) val max_value_representable : t (** The minimum span that rounds to a [Time.Span.t] with microsecond precision. *) val min_value_for_1us_rounding : t (** The maximum span that rounds to a [Time.Span.t] with microsecond precision. *) val max_value_for_1us_rounding : t (** An alias for [min_value_for_1us_rounding]. *) val min_value : t [@@deprecated "[since 2019-02] use [min_value_representable] or [min_value_for_1us_rounding] \ instead"] (** An alias for [max_value_for_1us_rounding]. *) val max_value : t [@@deprecated "[since 2019-02] use [max_value_representable] or [max_value_for_1us_rounding] \ instead"] (** overflows silently *) val scale_int : t -> int -> t (** overflows silently *) val scale_int63 : t -> Int63.t -> t (** Rounds down, and raises unless denominator is positive. *) val div : t -> t -> Int63.t (** Fast, implemented as the identity function. *) val to_int63_ns : t -> Int63.t (** Fast, implemented as the identity function. *) val of_int63_ns : Int63.t -> t (** Will raise on 32-bit platforms. Consider [to_int63_ns] instead. *) val to_int_ns : t -> int val of_int_ns : int -> t val since_unix_epoch : unit -> t val random : ?state:Random.State.t -> unit -> t (** WARNING!!! [to_span] and [of_span] both round to the nearest 1us. Around 135y magnitudes [to_span] and [of_span] raise. *) val to_span : t -> Span_float.t [@@deprecated "[since 2019-01] use [to_span_float_round_nearest] or \ [to_span_float_round_nearest_microsecond]"] val of_span : Span_float.t -> t [@@deprecated "[since 2019-01] use [of_span_float_round_nearest] or \ [of_span_float_round_nearest_microsecond]"] (** [*_round_nearest] vs [*_round_nearest_microsecond]: If you don't know that you need microsecond precision, use the [*_round_nearest] version. [*_round_nearest_microsecond] is for historical purposes. *) val to_span_float_round_nearest : t -> Span_float.t val to_span_float_round_nearest_microsecond : t -> Span_float.t val of_span_float_round_nearest : Span_float.t -> t val of_span_float_round_nearest_microsecond : Span_float.t -> t (** Note that we expose a sexp format that is not the one exposed in [Core]. *) module Alternate_sexp : sig type nonrec t = t [@@deriving sexp, sexp_grammar] end [@@deprecated "[since 2018-04] use [Span.sexp_of_t] and [Span.t_of_sexp] instead"] val arg_type : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] module Option : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] module Stable : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig val of_parts : Parts.t -> t val to_parts : t -> Parts.t end end module type Ofday = sig module Span : Span (** [t] is immediate on 64bit boxes and so plays nicely with the GC write barrier. *) type t = private Int63.t (** String and sexp output takes the form 'HH:MM:SS.sssssssss'; see {!Core.Ofday_intf} for accepted input. If input includes more than 9 decimal places in seconds, rounds to the nearest nanosecond, with the midpoint rounded up. Allows 60[.sss...] seconds for leap seconds but treats it as exactly 60s regardless of fractional part. *) include Ofday_intf.S with type underlying = Int63.t and type t := t and module Span := Span (** The largest representable value below [start_of_next_day], i.e. one nanosecond before midnight. *) val approximate_end_of_day : t (*_ This is already exported from [Ofday_intf.S], but we re-declare it to add documentation. *) (** [add_exn t span] shifts the time of day [t] by [span]. It raises if the result is not in the same 24-hour day. Daylight savings shifts are not accounted for. *) val add_exn : t -> Span.t -> t (** [sub_exn t span] shifts the time of day [t] back by [span]. It raises if the result is not in the same 24-hour day. Daylight savings shifts are not accounted for. *) val sub_exn : t -> Span.t -> t (** [every span ~start ~stop] returns a sorted list of all [t]s that can be expressed as [start + (i * span)] without overflow, and satisfying [t >= start && t <= stop]. If [span <= Span.zero || start > stop], returns an Error. The result never crosses the midnight boundary. Constructing a list crossing midnight, e.g. every hour from 10pm to 2am, requires multiple calls to [every]. *) val every : Span.t -> start:t -> stop:t -> t list Or_error.t val to_microsecond_string : t -> string val arg_type : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val now : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val of_ofday_float_round_nearest : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val of_ofday_float_round_nearest_microsecond : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val to_ofday_float_round_nearest : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val to_ofday_float_round_nearest_microsecond : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] module Option : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] module Zoned : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] end (** Time represented as an [Int63.t] number of nanoseconds since the epoch. See {!Core.Time_ns} for important user documentation. Internally, arithmetic is not overflow-checked. Instead, overflows are silently ignored as for [int] arithmetic, unless specifically documented otherwise. Conversions may (or may not) raise if prior arithmetic operations overflowed. *) module type Time_ns = sig module Span : Span module Ofday : Ofday with module Span := Span type t = private Int63.t [@@deriving hash, typerep, bin_io] include Comparisons.S with type t := t (** Note that we expose a sexp format that is not the one exposed in [Core]. *) module Alternate_sexp : sig type nonrec t = t [@@deriving compare, equal, hash, sexp, sexp_grammar] include Comparable.S with type t := t end include Time_intf.Shared with type t := t with module Span := Span with module Ofday := Ofday val of_string : string -> t [@@deprecated "[since 2021-04] Use [of_string_with_utc_offset] or [Time_ns_unix.of_string]"] (** [of_string_with_utc_offset] requires its input to have an explicit UTC offset, e.g. [2000-01-01 12:34:56.789012-23], or use the UTC zone, "Z", e.g. [2000-01-01 12:34:56.789012Z]. *) val of_string_with_utc_offset : string -> t val to_string : t -> string [@@deprecated "[since 2021-04] Use [to_string_utc] or [Time_ns_unix.to_string]"] (** [to_string_utc] generates a time string with the UTC zone, "Z", e.g. [2000-01-01 12:34:56.789012Z]. *) val to_string_utc : t -> string (** Unix epoch (1970-01-01 00:00:00 UTC) *) val epoch : t (** The minimum representable time. *) val min_value_representable : t (** The maximum representable time. *) val max_value_representable : t (** The minimum time that rounds to a [Time.t] with microsecond precision. *) val min_value_for_1us_rounding : t (** The maximum time that rounds to a [Time.t] with microsecond precision. *) val max_value_for_1us_rounding : t (** An alias for [min_value_for_1us_rounding]. *) val min_value : t [@@deprecated "[since 2019-02] use [min_value_representable] or [min_value_for_1us_rounding] \ instead"] (** An alias for [max_value_for_1us_rounding]. *) val max_value : t [@@deprecated "[since 2019-02] use [max_value_representable] or [max_value_for_1us_rounding] \ instead"] (** The current time. *) val now : unit -> t (** overflows silently *) val add : t -> Span.t -> t (** As [add]; rather than over/underflowing, clamps the result to the closed interval between [min_value_representable] and [max_value_representable]. *) val add_saturating : t -> Span.t -> t (** As [sub]; rather than over/underflowing, clamps the result to the closed interval between [min_value_representable] and [max_value_representable]. *) val sub_saturating : t -> Span.t -> t (** overflows silently *) val sub : t -> Span.t -> t (** overflows silently *) val next : t -> t (** overflows silently *) val prev : t -> t (** overflows silently *) val diff : t -> t -> Span.t (** overflows silently *) val abs_diff : t -> t -> Span.t val to_span_since_epoch : t -> Span.t val of_span_since_epoch : Span.t -> t val to_int63_ns_since_epoch : t -> Int63.t val of_int63_ns_since_epoch : Int63.t -> t (** Will raise on 32-bit platforms. Consider [to_int63_ns_since_epoch] instead. *) val to_int_ns_since_epoch : t -> int val of_int_ns_since_epoch : int -> t (** [next_multiple ~base ~after ~interval] returns the smallest [time] of the form: {[ time = base + k * interval ]} where [k >= 0] and [time > after]. It is an error if [interval <= 0]. Supplying [~can_equal_after:true] allows the result to satisfy [time >= after]. Overflows silently. *) val next_multiple : ?can_equal_after:bool (** default is [false] *) -> base:t -> after:t -> interval:Span.t -> unit -> t (** [prev_multiple ~base ~before ~interval] returns the largest [time] of the form: {[ time = base + k * interval ]} where [k >= 0] and [time < before]. It is an error if [interval <= 0]. Supplying [~can_equal_before:true] allows the result to satisfy [time <= before]. *) val prev_multiple : ?can_equal_before:bool (** default is [false] *) -> base:t -> before:t -> interval:Span.t -> unit -> t val random : ?state:Random.State.t -> unit -> t val of_time : Time_float.t -> t [@@deprecated "[since 2019-01] use [of_time_float_round_nearest] or \ [of_time_float_round_nearest_microsecond]"] val to_time : t -> Time_float.t [@@deprecated "[since 2019-01] use [to_time_float_round_nearest] or \ [to_time_float_round_nearest_microsecond]"] (** [*_round_nearest] vs [*_round_nearest_microsecond]: If you don't know that you need microsecond precision, use the [*_round_nearest] version. [*_round_nearest_microsecond] is for historical purposes. *) val to_time_float_round_nearest : t -> Time_float.t val to_time_float_round_nearest_microsecond : t -> Time_float.t val of_time_float_round_nearest : Time_float.t -> t val of_time_float_round_nearest_microsecond : Time_float.t -> t module Utc : sig (** [to_date_and_span_since_start_of_day] computes the date and intraday-offset of a time in UTC. It may be slower than [Core.Time_ns.to_date_ofday], as this function does not cache partial results while the latter does. *) val to_date_and_span_since_start_of_day : t -> Date0.t * Span.t (** The inverse of [to_date_and_span_since_start_of_day]. *) val of_date_and_span_since_start_of_day : Date0.t -> Span.t -> t end module Stable : sig module V1 : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] module Option : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] module Alternate_sexp : sig module V1 : sig type t = Alternate_sexp.t [@@deriving bin_io, compare, hash, sexp, sexp_grammar] include Comparator.Stable.V1.S with type t := t and type comparator_witness = Alternate_sexp.comparator_witness include Comparable.Stable.V1.S with type comparable := t with type comparator_witness := comparator_witness end end module Span : sig module V1 : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] module Option : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] module V2 : sig type t = Span.t [@@deriving hash, equal] type nonrec comparator_witness = Span.comparator_witness include Stable_int63able with type t := t with type comparator_witness := comparator_witness include Comparable.Stable.V1.S with type comparable := t with type comparator_witness := comparator_witness include Stringable.S with type t := t end end module Ofday : sig module V1 : Stable_int63able with type t = Ofday.t and type comparator_witness = Ofday.comparator_witness module Option : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] module Zoned : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] end end module Hash_queue : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] module Hash_set : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] module Map : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] module Option : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] module Replace_polymorphic_compare : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] module Set : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] module Table : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] module Zone : sig end [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val arg_type : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val comparator : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val get_sexp_zone : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val interruptible_pause : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val of_date_ofday_zoned : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val of_string_abs : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val of_string_fix_proto : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val pause : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val pause_forever : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val pp : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val set_sexp_zone : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val sexp_of_t : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val sexp_of_t_abs : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val t_of_sexp : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val t_of_sexp_abs : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val to_date_ofday_zoned : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val to_ofday_zoned : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val to_string_fix_proto : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val validate_bound : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val validate_lbound : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] val validate_ubound : [ `Use_Time_ns_unix ] [@@deprecated "[since 2021-03] Use [Time_ns_unix]"] end core-0.15.0/core/src/time_ns_stubs.c000066400000000000000000000027271420273305200172740ustar00rootroot00000000000000#include #include #include #include CAMLprim value core_time_ns_format_tm(struct tm * tm, value v_fmt) { size_t len; char* buf; int buf_len; value v_str; /* 100 * length should be large enough to contain the output of strftime. The longest expansion we know of is "%c" in the km_KH.utf8 locale, which requires 151 bytes. */ buf_len = 100 * caml_string_length(v_fmt); buf = malloc(buf_len); if (!buf) caml_failwith("core_time_ns_format_tm: malloc failed"); len = strftime(buf, buf_len, String_val(v_fmt), tm); if (len == 0) { /* From the man page: "Note that the return value 0 does not necessarily indicate an error; for example, in many locales %p yields an empty string." Given how large our buffer is we just assume that 0 always indicates an empty string. */ v_str = caml_copy_string(""); free(buf); return v_str; } v_str = caml_copy_string(buf); /* [strftime] always null terminates the string */ free(buf); return v_str; } CAMLprim value core_time_ns_format(value t, value v_fmt) { time_t clock; struct tm * tm; clock = (time_t) Double_val(t); /* This [tm] must not be freed. It refers to statically allocated memory and its contents change every time [localtime] is called. */ tm = localtime(&clock); if (tm == NULL) caml_failwith("core_time_ns_format: localtime failed"); return core_time_ns_format_tm(tm, v_fmt); } core-0.15.0/core/src/time_ns_stubs.h000066400000000000000000000001601420273305200172660ustar00rootroot00000000000000#include #include CAMLextern value core_time_ns_format_tm (struct tm * tm, value v); core-0.15.0/core/src/tuple.ml000066400000000000000000000100351420273305200157240ustar00rootroot00000000000000open! Import module type T = sig type t end module Make (T1 : T) (T2 : T) = struct type t = T1.t * T2.t end module T2 = struct type ('a, 'b) t = 'a * 'b [@@deriving sexp, typerep] let create a b = a, b let curry f = (); fun a b -> f (a, b) ;; let uncurry f = (); fun (a, b) -> f a b ;; [%%if flambda_backend] external get1 : ('a, _) t -> 'a = "%field0_immut" external get2 : (_, 'a) t -> 'a = "%field1_immut" [%%else] external get1 : ('a, _) t -> 'a = "%field0" external get2 : (_, 'a) t -> 'a = "%field1" [%%endif] let map (x, y) ~f = f x, f y let map_fst (x, y) ~f = f x, y let map_snd (x, y) ~f = x, f y let map2 (x1, y1) (x2, y2) ~f = f x1 x2, f y1 y2 let compare ~cmp1 ~cmp2 (x, y) (x', y') = match cmp1 x x' with | 0 -> cmp2 y y' | i -> i ;; let equal ~eq1 ~eq2 (x, y) (x', y') = eq1 x x' && eq2 y y' let swap (a, b) = b, a include Comparator.Derived2 (struct type nonrec ('a, 'b) t = ('a, 'b) t [@@deriving sexp_of] let compare cmp1 cmp2 = compare ~cmp1 ~cmp2 end) end module T3 = struct type ('a, 'b, 'c) t = 'a * 'b * 'c [@@deriving sexp, typerep] let create a b c = a, b, c let curry f = (); fun a b c -> f (a, b, c) ;; let uncurry f = (); fun (a, b, c) -> f a b c ;; let map (x, y, z) ~f = f x, f y, f z let map_fst (x, y, z) ~f = f x, y, z let map_snd (x, y, z) ~f = x, f y, z let map_trd (x, y, z) ~f = x, y, f z let map2 (x1, y1, z1) (x2, y2, z2) ~f = f x1 x2, f y1 y2, f z1 z2 [%%if flambda_backend] external get1 : ('a, _, _) t -> 'a = "%field0_immut" external get2 : (_, 'a, _) t -> 'a = "%field1_immut" [%%else] external get1 : ('a, _, _) t -> 'a = "%field0" external get2 : (_, 'a, _) t -> 'a = "%field1" [%%endif] (* There's no %field2....*) let get3 (_, _, a) = a (* lexicographic comparison *) let compare ~cmp1 ~cmp2 ~cmp3 (x, y, z) (x', y', z') = let c1 = cmp1 x x' in if c1 <> 0 then c1 else ( let c2 = cmp2 y y' in if c2 <> 0 then c2 else cmp3 z z') ;; let equal ~eq1 ~eq2 ~eq3 (x, y, z) (x', y', z') = eq1 x x' && eq2 y y' && eq3 z z' end module type Comparable_sexpable = sig type t [@@deriving sexp] include Comparable.S with type t := t end module type Hashable_sexpable = sig type t [@@deriving sexp] include Hashable.S with type t := t end module type Hasher_sexpable = sig type t [@@deriving compare, hash, sexp] end module Sexpable (S1 : Sexpable.S) (S2 : Sexpable.S) = struct type t = S1.t * S2.t [@@deriving sexp] end module Binable (B1 : Binable.S) (B2 : Binable.S) = struct type t = B1.t * B2.t [@@deriving bin_io] end module Comparator (S1 : Comparator.S) (S2 : Comparator.S) = struct include Make (S1) (S2) type comparator_witness = (S1.comparator_witness, S2.comparator_witness) T2.comparator_witness let comparator = T2.comparator S1.comparator S2.comparator end module Comparable_plain (S1 : Comparable.S_plain) (S2 : Comparable.S_plain) = struct module T = struct include Comparator (S1) (S2) let sexp_of_t = comparator.sexp_of_t end include T include Comparable.Make_plain_using_comparator (T) end module Comparable (S1 : Comparable_sexpable) (S2 : Comparable_sexpable) = struct module T = struct include Sexpable (S1) (S2) let compare (s1, s2) (s1', s2') = match S1.compare s1 s1' with | 0 -> S2.compare s2 s2' | x -> x ;; end include T include Comparable.Make (T) end module Hasher (H1 : Hasher_sexpable) (H2 : Hasher_sexpable) = struct module T = struct type t = H1.t * H2.t [@@deriving compare, hash, sexp] end include T include Hashable.Make (T) end module Hasher_sexpable_of_hashable_sexpable (S : Hashable_sexpable) : Hasher_sexpable with type t = S.t = struct include S let hash_fold_t state t = hash_fold_int state (hash t) end module Hashable_t (S1 : Hashable_sexpable) (S2 : Hashable_sexpable) = Hasher (Hasher_sexpable_of_hashable_sexpable (S1)) (Hasher_sexpable_of_hashable_sexpable (S2)) module Hashable = Hashable_t core-0.15.0/core/src/tuple.mli000066400000000000000000000123451420273305200161030ustar00rootroot00000000000000(** Functors and signatures for dealing with modules for tuples. *) open! Import (** Signature for a 2-tuple module *) module T2 : sig type ('a, 'b) t = 'a * 'b [@@deriving sexp, typerep] include Comparator.Derived2 with type ('a, 'b) t := ('a, 'b) t val create : 'a -> 'b -> ('a, 'b) t val curry : (('a, 'b) t -> 'c) -> 'a -> 'b -> 'c val uncurry : ('a -> 'b -> 'c) -> ('a, 'b) t -> 'c val compare : cmp1:('a -> 'a -> int) -> cmp2:('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int val equal : eq1:('a -> 'a -> bool) -> eq2:('b -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t -> bool [%%if flambda_backend] external get1 : ('a, _) t -> 'a = "%field0_immut" external get2 : (_, 'a) t -> 'a = "%field1_immut" [%%else] external get1 : ('a, _) t -> 'a = "%field0" external get2 : (_, 'a) t -> 'a = "%field1" [%%endif] val map : ('a, 'a) t -> f:('a -> 'b) -> ('b, 'b) t val map_fst : ('a, 'b) t -> f:('a -> 'c) -> ('c, 'b) t val map_snd : ('a, 'b) t -> f:('b -> 'c) -> ('a, 'c) t val map2 : ('a, 'a) t -> ('b, 'b) t -> f:('a -> 'b -> 'c) -> ('c, 'c) t val swap : ('a, 'b) t -> ('b, 'a) t end (** Signature for a 3-tuple module *) module T3 : sig type ('a, 'b, 'c) t = 'a * 'b * 'c [@@deriving sexp, typerep] val create : 'a -> 'b -> 'c -> ('a, 'b, 'c) t val curry : (('a, 'b, 'c) t -> 'd) -> 'a -> 'b -> 'c -> 'd val uncurry : ('a -> 'b -> 'c -> 'd) -> ('a, 'b, 'c) t -> 'd val equal : eq1:('a -> 'a -> bool) -> eq2:('b -> 'b -> bool) -> eq3:('c -> 'c -> bool) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> bool val compare : cmp1:('a -> 'a -> int) -> cmp2:('b -> 'b -> int) -> cmp3:('c -> 'c -> int) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> int [%%if flambda_backend] external get1 : ('a, _, _) t -> 'a = "%field0_immut" external get2 : (_, 'a, _) t -> 'a = "%field1_immut" [%%else] external get1 : ('a, _, _) t -> 'a = "%field0" external get2 : (_, 'a, _) t -> 'a = "%field1" [%%endif] val get3 : (_, _, 'a) t -> 'a val map : ('a, 'a, 'a) t -> f:('a -> 'b) -> ('b, 'b, 'b) t val map_fst : ('a, 'b, 'c) t -> f:('a -> 'd) -> ('d, 'b, 'c) t val map_snd : ('a, 'b, 'c) t -> f:('b -> 'd) -> ('a, 'd, 'c) t val map_trd : ('a, 'b, 'c) t -> f:('c -> 'd) -> ('a, 'b, 'd) t val map2 : ('a, 'a, 'a) t -> ('b, 'b, 'b) t -> f:('a -> 'b -> 'c) -> ('c, 'c, 'c) t end (** These functors allow users to write: {[ module Foo = struct include Tuple.Make (String) (Int) include Tuple.Comparator (String) (Int) include Tuple.Comparable (String) (Int) include Tuple.Hashable (String) (Int) include Tuple.Binable (String) (Int) end ]} *) module Make (T1 : sig type t end) (T2 : sig type t end) : sig type t = T1.t * T2.t end module Comparator (S1 : Comparator.S) (S2 : Comparator.S) : Comparator.S with type t = Make(S1)(S2).t module type Comparable_sexpable = sig type t [@@deriving sexp] include Comparable.S with type t := t end module Comparable_plain (S1 : Comparable.S_plain) (S2 : Comparable.S_plain) : sig (*_ This type is introduced because older versions of OCaml do not support destructive substitutions with `type t1 = 'a t2`. *) type comparator_witness = (S1.comparator_witness, S2.comparator_witness) T2.comparator_witness include Comparable.S_plain with type t := Make(S1)(S2).t with type comparator_witness := comparator_witness end module Comparable (S1 : Comparable_sexpable) (S2 : Comparable_sexpable) : Comparable_sexpable with type t := Make(S1)(S2).t module type Hashable_sexpable = sig type t [@@deriving sexp] include Hashable.S with type t := t end (** The difference between [Hashable] and [Hashable_t] functors is that the former's result type doesn't contain type [t] and the latter does. Therefore, [Hashable] can't be used to combine two pairs into 4-tuple. but [Hashable_t] can. On the other hand result of [Hashable_t] cannot be combined with [Comparable]. example: module Four_ints = Tuple.Hashable_t (Tuple.Hashable_t (Int)(Int)) (Tuple.Hashable_t (Int)(Int)) If instead we used [Hashable] compiler would complain that the input to outer functor doesn't have type [t]. On the other hand: module Foo = struct type t = String.t * Int.t include Tuple.Comparable (String) (Int) include Tuple.Hashable (String) (Int) end If we used [Hashable_t] above, the compiler would complain that we have two types [t] defined. Unfortunately, it is not possible to define just one functor that could be used in both cases. *) module Hashable (S1 : Hashable_sexpable) (S2 : Hashable_sexpable) : Hashable_sexpable with type t := Make(S1)(S2).t module Hashable_t (S1 : Hashable_sexpable) (S2 : Hashable_sexpable) : Hashable_sexpable with type t = Make(S1)(S2).t module Sexpable (S1 : Sexpable.S) (S2 : Sexpable.S) : Sexpable.S with type t := Make(S1)(S2).t module Binable (B1 : Binable.S) (B2 : Binable.S) : Binable.S with type t := Make(B1)(B2).t module Hasher (H1 : sig type t [@@deriving compare, hash, sexp] end) (H2 : sig type t [@@deriving compare, hash, sexp] end) : Hashable_sexpable with type t := Make(H1)(H2).t core-0.15.0/core/src/type_equal.ml000066400000000000000000000005431420273305200167460ustar00rootroot00000000000000include Base.Type_equal module Id = struct include Id module Uid = struct module Upstream = Base.Type_equal.Id.Uid include Base.Type_equal.Id.Uid include Comparable.Extend (Upstream) (struct type t = Base.Type_equal.Id.Uid.t [@@deriving sexp] end) include Hashable.Make (Upstream) end end core-0.15.0/core/src/type_equal.mli000066400000000000000000000001651420273305200171170ustar00rootroot00000000000000(** This module extends {{!Base.Type_equal}[Base.Type_equal]}. *) include Type_equal_intf.Type_equal (** @inline *) core-0.15.0/core/src/type_equal_intf.ml000066400000000000000000000010711420273305200177630ustar00rootroot00000000000000(*_ This is just to extend Uid with the standard hashability and binability primitives *) module type Uid = sig include module type of struct include Base.Type_equal.Id.Uid end include Comparable.S with type t := t and type comparator_witness := comparator_witness include Hashable.S with type t := t end module type Id = sig include module type of struct include Base.Type_equal.Id end module Uid : Uid end module type Type_equal = sig (** @inline *) include module type of struct include Base.Type_equal end module Id : Id end core-0.15.0/core/src/type_immediacy.ml000066400000000000000000000311461420273305200176030ustar00rootroot00000000000000(* This module is very much dependent on the runtime representation of values. Should the way the compiler represents various types change, it needs to be reflected in this module, otherwise bad things could happen. Therefore the conversions and representations are tested thoroughly in [../test/test_witness.ml] and [../test/test_conversions.ml] *) open! Import module List = Base.List module Hash_set = Base.Hash_set let sprintf = Printf.sprintf module Key = struct type t = int [@@deriving compare, sexp_of] (* The integers here are the values underlying the polymorphic variants, they already are hashes of constructor names, and hence are expected to be uniformly distributed. *) let hash x = x end module Allowed_ints = struct type t = | None | All | Hash_set of Hash_set.M(Key).t | From_zero_to of int let _invariant = function | None | All | Hash_set _ -> () | From_zero_to n -> assert (n >= 0) ;; let int_is_value t i = match t with | None -> false | All -> true | Hash_set hash_set -> Hash_set.mem hash_set i | From_zero_to n -> 0 <= i && i <= n ;; end module Immediacy = struct type t = | Always | Sometimes | Never | Unknown [@@deriving compare] let equal = [%compare.equal: t] let to_string = function | Always -> "Always" | Sometimes -> "Sometimes" | Never -> "Never" | Unknown -> "Unknown" ;; end open Immediacy module T : sig type 'a t val create : 'a Typename.t -> Immediacy.t -> Allowed_ints.t -> 'a t val create_with_name : string -> Immediacy.t -> Allowed_ints.t -> _ t val immediacy : _ t -> Immediacy.t val allowed_ints : _ t -> Allowed_ints.t val typename : _ t -> string module Never_values : sig val int32 : int32 t val int64 : int64 t val nativeint : nativeint t val float : float t val string : string t val bytes : bytes t val array : _ array t val ref_ : _ ref t val tuple2 : (_ * _) t val tuple3 : (_ * _ * _) t val tuple4 : (_ * _ * _ * _) t val tuple5 : (_ * _ * _ * _ * _) t val function_ : (_ -> _) t end val never : 'a Typename.t -> 'a t val unknown : 'a Typename.t -> 'a t val option : _ t val list : _ t val magic : _ t -> _ t end = struct type t_ = { immediacy : Immediacy.t ; allowed_ints : Allowed_ints.t ; typename : string } type 'a t = t_ let create_with_name typename immediacy allowed_ints = { immediacy; allowed_ints; typename } ;; let create typename immediacy allowed_ints = create_with_name (Typename.name typename) immediacy allowed_ints ;; let immediacy t = t.immediacy let allowed_ints t = t.allowed_ints let typename t = t.typename let magic t = t let never_with_name name = create_with_name name Never None let never typename = create typename Never None let unknown typename = create typename Unknown None let option = create_with_name "option" Sometimes (Allowed_ints.From_zero_to 0) let list = create_with_name "list" Sometimes (Allowed_ints.From_zero_to 0) module Never_values = struct (* int32 is boxed even on 64b platform at the moment. *) let int32 = never typename_of_int32 let int64 = never typename_of_int64 let nativeint = never typename_of_nativeint let float = never typename_of_float let string = never typename_of_string let bytes = never typename_of_bytes let array = never_with_name "array" let ref_ = never_with_name "ref" let tuple2 = never_with_name "tuple2" let tuple3 = never_with_name "tuple3" let tuple4 = never_with_name "tuple4" let tuple5 = never_with_name "tuple5" let function_ = never_with_name "function" end end include T let int = create typename_of_int Always Allowed_ints.All let unit = create typename_of_unit Always (Allowed_ints.From_zero_to 0) let bool = create typename_of_bool Always (Allowed_ints.From_zero_to 1) let char = create typename_of_char Always (Allowed_ints.From_zero_to 255) module Computation_impl = struct type nonrec 'a t = 'a t include Type_generic.Variant_and_record_intf.M (struct type nonrec 'a t = 'a t end) include Never_values let ref_ _ = ref_ let array _ = array let tuple2 _ _ = tuple2 let tuple3 _ _ _ = tuple3 let tuple4 _ _ _ _ = tuple4 let tuple5 _ _ _ _ _ = tuple5 let function_ _ _ = function_ let int = int let char = char let bool = bool let unit = unit let option _ = option let list _ = list (* An [a Lazy.t] might be a boxed closure, so must have immediacy either [Never] or [Sometimes]. An [a Lazy.t] value could be immediate if [a] is immediate. But if [a] is never immediate, then [a Lazy.t] cannot be. *) let lazy_t t = let immediacy = match immediacy t with | Never -> Never | Unknown -> Unknown | Sometimes | Always -> Sometimes in create_with_name "lazy_t" immediacy (allowed_ints t) ;; let possibly_unboxed typename child_type = match immediacy child_type with | Never -> never typename | Unknown | Always | Sometimes -> unknown typename ;; let record r = if Record.length r > 1 then never (Record.typename_of_t r) else ( let (Field the_only_field) = Record.field r 0 in possibly_unboxed (Record.typename_of_t r) (Field.traverse the_only_field)) ;; (* Variants with all constructors having no arguments are always immediate; variants with all constructors having some arguments are never immediate; mixed variants are sometimes immediate. If a variant has a single constructor, and the constructor has an argument, the variant can be unboxed. If unboxed, either explicitly or by default (depending on compiler settings), the representation is simply the argument. Otherwise, the rules above apply normally. *) let variant variant = let no_arg_list, one_arg_list, more_arg_list = Variant.fold variant ~init:([], [], []) ~f:(fun (no, one, more) (Tag t as tag) -> match Tag.arity t with | 0 -> tag :: no, one, more | 1 -> no, tag :: one, more | _ -> no, one, tag :: more) in match no_arg_list, one_arg_list, more_arg_list with | [], [ Tag tag ], [] when not (Variant.is_polymorphic variant) -> possibly_unboxed (Variant.typename_of_t variant) (Tag.traverse tag) | [], [], [] -> (* We don't have an explict way of saying a type is uninhabited. *) unknown (Variant.typename_of_t variant) | [], _ :: _, _ | [], _, _ :: _ -> never (Variant.typename_of_t variant) | _ :: _, _, _ -> let no_arg_count = List.length no_arg_list in let allowed_ints = if not (Variant.is_polymorphic variant) then Allowed_ints.From_zero_to (no_arg_count - 1) else ( let hash_set = Hash_set.create (module Key) ~size:(no_arg_count * 2) in List.iter no_arg_list ~f:(fun (Tag tag) -> match Tag.create tag with | Tag.Const _ -> Hash_set.add hash_set (Tag.ocaml_repr tag) | Tag.Args _ -> assert false); Allowed_ints.Hash_set hash_set) in let immediacy = if List.is_empty one_arg_list && List.is_empty more_arg_list then Always else Sometimes in create (Variant.typename_of_t variant) immediacy allowed_ints ;; let name = "is_immediate" let required = [] module Named = struct module Context = struct type t = unit let create () = () end type nonrec 'a t = 'a t ref (* The default witness - which is created by calling [init] and recovered at any later point by calling [get_wip_computation] - can only be used in a recursive type. Other types that don't use [get_wip_computation] will just evaluate to the actual witness which will replace the initial dummy one. *) let init _ name = ref (create name Sometimes Allowed_ints.None) let get_wip_computation comp = !comp let set_final_computation r t = r := t; t ;; let share _ = true end end module Generic = Type_generic.Make (Computation_impl) let of_typerep typerep = let (`generic t) = Generic.of_typerep typerep in t ;; module For_all_parameters (M : sig val immediacy : Immediacy.t end) = struct let witness typerep1 typerep2 = let t1 = of_typerep typerep1 in let t2 = of_typerep typerep2 in let i1 = immediacy t1 in let i2 = immediacy t2 in if not (Immediacy.equal i1 i2) then failwith (sprintf "type %s is not independent of its arguments" (Typename.name (Typerep.typename_of_t typerep1))) else if not (Immediacy.equal i1 M.immediacy) then failwith (sprintf "type %s does not have desired immediacy: wanted %s but got %s" (Typename.name (Typerep.typename_of_t typerep1)) (Immediacy.to_string M.immediacy) (Immediacy.to_string i1)) else t1 ;; (* always immediate *) let ra = Typerep.Int (* never immediate *) let rn = Typerep.String (* Each of the [For_all_parameters_*] functors works by instantiating the n-ary type with all [Always] types, and then with all [Never] types. If those produce the same immediacy, then we conclude that the n-ary type is independent of its arguments. *) module For_all_parameters_S1 (X : Typerepable.S1) = struct let t = witness (X.typerep_of_t ra) (X.typerep_of_t rn) let witness () = magic t end module For_all_parameters_S2 (X : Typerepable.S2) = struct let t = witness (X.typerep_of_t ra ra) (X.typerep_of_t rn rn) let witness () = magic t end module For_all_parameters_S3 (X : Typerepable.S3) = struct let t = witness (X.typerep_of_t ra ra ra) (X.typerep_of_t rn rn rn) let witness () = magic t end module For_all_parameters_S4 (X : Typerepable.S4) = struct let t = witness (X.typerep_of_t ra ra ra ra) (X.typerep_of_t rn rn rn rn) let witness () = magic t end module For_all_parameters_S5 (X : Typerepable.S5) = struct let t = witness (X.typerep_of_t ra ra ra ra ra) (X.typerep_of_t rn rn rn rn rn) let witness () = magic t end end let int_is_value t int = Allowed_ints.int_is_value (allowed_ints t) int let int_as_value (type a) (t : a t) int = if int_is_value t int then Some (Obj.magic (int : int) : a) else None ;; let int_as_value_exn (type a) (t : a t) int = if int_is_value t int then (Obj.magic (int : int) : a) else failwith (sprintf "Immediate.int_as_value_exn: typename:%S int:%d" (T.typename t) int) ;; let value_as_int_exn (type a) (t : a t) a = if Obj.is_int (Obj.repr a) then (Obj.magic (a : a) : int) else failwith (sprintf "Immediate.value_as_int_exn: typename:%S" (T.typename t)) ;; let value_as_int (type a) (_ : a t) a = if Obj.is_int (Obj.repr a) then Some (Obj.magic (a : a) : int) else None ;; let value_is_int (type a) (_ : a t) a = Obj.is_int (Obj.repr a) module Always = struct type nonrec 'a t = 'a t include For_all_parameters (struct let immediacy = Always end) let of_typerep typerep = let t = of_typerep typerep in match immediacy t with | Always -> Some t | Unknown | Never | Sometimes -> None ;; let of_typerep_exn here typerep = Option.value_exn ~here (of_typerep typerep) let int_as_value = int_as_value let int_as_value_exn = int_as_value_exn let int_is_value = int_is_value let[@inline always] value_as_int (type a) _ a = a |> (Obj.magic : a -> int) let int = int let char = char let bool = bool let unit = unit end module Sometimes = struct type nonrec 'a t = 'a t include For_all_parameters (struct let immediacy = Sometimes end) let of_typerep typerep = let t = of_typerep typerep in match immediacy t with | Sometimes -> Some t | Unknown | Always | Never -> None ;; let of_typerep_exn here typerep = Option.value_exn ~here (of_typerep typerep) let int_as_value = int_as_value let int_as_value_exn = int_as_value_exn let int_is_value = int_is_value let value_as_int = value_as_int let value_as_int_exn = value_as_int_exn let value_is_int = value_is_int let option = option let list = list end module Never = struct type nonrec 'a t = 'a t include For_all_parameters (struct let immediacy = Never end) let of_typerep typerep = let t = of_typerep typerep in match immediacy t with | Never -> Some t | Unknown | Always | Sometimes -> None ;; let of_typerep_exn here typerep = Option.value_exn ~here (of_typerep typerep) include Never_values end type 'a dest = | Always of 'a Always.t | Sometimes of 'a Sometimes.t | Never of 'a Never.t | Unknown let dest t = match immediacy t with | Always -> Always t | Sometimes -> Sometimes t | Never -> Never t | Unknown -> Unknown ;; core-0.15.0/core/src/type_immediacy.mli000066400000000000000000000216541420273305200177570ustar00rootroot00000000000000(** Witnesses that express whether a type's values are always, sometimes, or never immediate. A value is immediate when it is internally represented unboxed, using one word of memory rather than a pointer to a heap-allocated block. Some examples: - All [int] values are by definition immediate, i.e., unboxed, and so [int] is always immediate. - A ['a list] is either [[]], which is internally represented as 0 (immediate), or a non-empty list, which is represented as a pointer to a heap block (boxed), which contains the first element and the pointer to the rest of the list. Therefore ['a list] is sometimes immediate. - All values of type ['a ref] are represented as a pointer to a heap block containing the actual values ['a]. Therefore ['a ref] is never immediate. The witness values can be used to perform safe optimizations such as allowing a more efficient ['a array] blit operations if ['a] is always immediate. These witnesses can also be used to perform safe conversions between immediate values of type ['a] and [int] instead of using [Obj.magic]. {2 Converting between values and ints} Consider an arbitrary type ['a] for which you have built a type-immediacy witness using this interface. Let's call it [w : 'a t]. You can use the two following functions and [w] to cast back and forth values from the type ['a] to the type [int]: {[ val int_as_value : 'a t -> int -> 'a option val value_as_int : 'a t -> 'a -> int option ]} For the rest of this section, we will assume [int_as_value] and [value_as_int] partially applied to [w]. Consider the following cases: {ul {- let [v] be an immediate value. Let [i] be the [int] that internally represents [v]. Then, [value_as_int v] returns [Some i]. We can also recover [v] by using the conversions that go the other way. In particular, [int_as_value i] returns [Some v].}} {ul {- let [v] be a boxed value that cannot be converted to an [int]. [value_as_int v] returns [None] because there does not exist an int s.t. [int_as_value i] evaluates to [Some v].}} {ul {- let [i] be an int that does not represent any value of type ['a] [int_as_value i] returns [None].}} {2 Faster *_exn functions and functions with boolean results} [value_is_int v] is a faster equivalent to [Option.is_some (value_as_int v)]. [value_as_int_exn v] is a faster equivalent to [Option.value_exn (value_as_int v)]. [int_is_value i] is a faster equivalent to [Option.is_some (int_as_value i)]. [int_as_value_exn i] is a faster equivalent to [Option.value_exn (int_as_value i)]. These are lightweight functions that avoid allocating the option. [value_is_int] (resp [int_is_value]) can be used with [value_as_int_exn] (resp [int_as_value_exn]) to avoid both allocation or using a [try with] statement, paying only some small amount of CPU time for calling [value_is_int] (resp [int_is_value]): {[ match value_as_int v with | Some v -> some v | None -> none ]} VS {[ if value_is_int v then some (value_as_int_exn v) else none ]} {2 Example} Consider the following type: {[ type test = | A | B | C of int with typerep ]} Type [test] is sometimes immediate, as [A] is represented as [0], [B] as [1], and [C] is a boxed value. We can construct a witness of type [test Sometimes.t] by using [Sometimes.of_typerep] or [of_typerep] and extracting the witness. Let's call the witness [w] here. We can now use it to safely convert between values of [test] and [int]: [Sometimes.value_as_int w A] evaluates to [Some 0] [Sometimes.value_as_int w B] evaluates to [Some 1] [Sometimes.value_as_int w (C 1)] evaluates to [None] [Sometimes.int_as_value w 0] evaluates to [Some A] [Sometimes.int_as_value w 1] evaluates to [Some B] [Sometimes.int_as_value w n] evaluates to [None] for all other values n Consider this other example: {[ type test = bool with typerep ]} Type [test] is always immediate, since [true] is represented as [1] and [false] as [0]. We can construct a witness of type [test Always.t] by using [Always.of_typerep] or [of_typerep] and extracting the witness. Let's call the witness [w]: [Always.value_as_int w false] evaluates to [Some 0] [Always.value_as_int w true] evaluates to [Some 1] [Always.value_as_int_exn w false] evaluates to [0] [Always.value_as_int_exn w true] evaluates to [1] [Always.int_as_value w 0] evaluates to [Some false] [Always.int_as_value w 1] evaluates to [Some true] [Always.int_as_value w (-1)] evaluates to [None] [Always.int_as_value_exn w 0] evaluates to [false] [Always.int_as_value_exn w 1] evaluates to [true] [Always.int_as_value_exn w (-1)] raises {2 N-ary types that are immediate independently of their type arguments} We also provide [For_all_parameters_S*] functors. Those are useful when one has a type with type parameters, but knows that values of that type will always be immediate (for example) no matter what the actual parameter is. They can use [Always.For_all_parameters_S*] to obtain access to a polymorphic witness. An exception is raised on functor application if such witness cannot be obtained. That happens either because the witness depends on the actual type parameter, or because the type has a different witness (e.g. [Sometimes] instead of [Always]). *) open! Import type 'a t module Always : sig type 'a t val of_typerep : 'a Typerep.t -> 'a t option val of_typerep_exn : Source_code_position.t -> 'a Typerep.t -> 'a t val int_as_value : 'a t -> int -> 'a option val int_as_value_exn : 'a t -> int -> 'a val int_is_value : 'a t -> int -> bool val value_as_int : 'a t -> 'a -> int module For_all_parameters_S1 (X : Typerepable.S1) : sig val witness : unit -> _ X.t t end module For_all_parameters_S2 (X : Typerepable.S2) : sig val witness : unit -> (_, _) X.t t end module For_all_parameters_S3 (X : Typerepable.S3) : sig val witness : unit -> (_, _, _) X.t t end module For_all_parameters_S4 (X : Typerepable.S4) : sig val witness : unit -> (_, _, _, _) X.t t end module For_all_parameters_S5 (X : Typerepable.S5) : sig val witness : unit -> (_, _, _, _, _) X.t t end val int : int t val char : char t val bool : bool t val unit : unit t end module Sometimes : sig type 'a t val of_typerep : 'a Typerep.t -> 'a t option val of_typerep_exn : Source_code_position.t -> 'a Typerep.t -> 'a t val int_as_value : 'a t -> int -> 'a option val int_as_value_exn : 'a t -> int -> 'a val int_is_value : 'a t -> int -> bool val value_as_int : 'a t -> 'a -> int option val value_as_int_exn : 'a t -> 'a -> int val value_is_int : 'a t -> 'a -> bool module For_all_parameters_S1 (X : Typerepable.S1) : sig val witness : unit -> _ X.t t end module For_all_parameters_S2 (X : Typerepable.S2) : sig val witness : unit -> (_, _) X.t t end module For_all_parameters_S3 (X : Typerepable.S3) : sig val witness : unit -> (_, _, _) X.t t end module For_all_parameters_S4 (X : Typerepable.S4) : sig val witness : unit -> (_, _, _, _) X.t t end module For_all_parameters_S5 (X : Typerepable.S5) : sig val witness : unit -> (_, _, _, _, _) X.t t end val option : _ option t val list : _ list t end module Never : sig type 'a t val of_typerep : 'a Typerep.t -> 'a t option val of_typerep_exn : Source_code_position.t -> 'a Typerep.t -> 'a t module For_all_parameters_S1 (X : Typerepable.S1) : sig val witness : unit -> _ X.t t end module For_all_parameters_S2 (X : Typerepable.S2) : sig val witness : unit -> (_, _) X.t t end module For_all_parameters_S3 (X : Typerepable.S3) : sig val witness : unit -> (_, _, _) X.t t end module For_all_parameters_S4 (X : Typerepable.S4) : sig val witness : unit -> (_, _, _, _) X.t t end module For_all_parameters_S5 (X : Typerepable.S5) : sig val witness : unit -> (_, _, _, _, _) X.t t end val int32 : int32 t val int64 : int64 t val nativeint : nativeint t val float : float t val string : string t val bytes : bytes t val array : _ array t val ref_ : _ ref t val tuple2 : (_ * _) t val tuple3 : (_ * _ * _) t val tuple4 : (_ * _ * _ * _) t val tuple5 : (_ * _ * _ * _ * _) t end val of_typerep : 'a Typerep.t -> 'a t type 'a dest = | Always of 'a Always.t | Sometimes of 'a Sometimes.t | Never of 'a Never.t | Unknown val dest : 'a t -> 'a dest val int_as_value : 'a t -> int -> 'a option val int_as_value_exn : 'a t -> int -> 'a val int_is_value : 'a t -> int -> bool val value_as_int : 'a t -> 'a -> int option val value_as_int_exn : 'a t -> 'a -> int val value_is_int : 'a t -> 'a -> bool core-0.15.0/core/src/uniform_array.ml000066400000000000000000000003471420273305200174550ustar00rootroot00000000000000open! Import include Base.Uniform_array include Binable.Of_binable1_without_uuid [@alert "-legacy"] (Array) (struct type nonrec 'a t = 'a t let to_binable = to_array let of_binable = of_array end) core-0.15.0/core/src/uniform_array.mli000066400000000000000000000003741420273305200176260ustar00rootroot00000000000000(** This module extends {{!Base.Uniform_array}[Base.Uniform_array]} with bin_io. *) open! Import type 'a t = 'a Base.Uniform_array.t [@@deriving bin_io, sexp] include module type of struct include Base.Uniform_array end with type 'a t := 'a t core-0.15.0/core/src/union_find.ml000066400000000000000000000064511420273305200167320ustar00rootroot00000000000000(* This code is based on the MLton library set/disjoint.fun, which has the following copyright notice. *) (* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh * Jagannathan, and Stephen Weeks. * * MLton is released under a BSD-style license. * See the file MLton-LICENSE for details. *) open! Import (* {v Root | Inner / .. | .. \ Inner Inner Inner /|\ /|\ /|\ ... ... ... v} We construct the `inverted' tree in the ML representation. The direction of the edges is UPWARDS. Starting with any ['a t] we can step directly to its parent. But we can't (and don't need to) start from the root and step to its children. *) (* [rank] is an upper bound on the depth of any node in the up-tree. Imagine an unlucky sequence of operations in which you create N individual [t]-values and then union them together in such a way that you always pick the root of each tree to union together, so that no path compression takes place. If you don't take care to somehow balance the resulting up-tree, it is possible that you end up with one big long chain of N links, and then calling [representative] on the deepest node takes Theta(N) time. With the balancing scheme of never increasing the rank of a node unnecessarily, it would take O(log N). *) type 'a root = { mutable value : 'a ; mutable rank : int } type 'a t = { mutable node : 'a node } and 'a node = | Inner of 'a t (* [Inner x] is a node whose parent is [x]. *) | Root of 'a root let invariant _ t = let rec loop t depth = match t.node with | Inner t -> loop t (depth + 1) | Root r -> assert (depth <= r.rank) in loop t 0 ;; let create v = { node = Root { value = v; rank = 0 } } (* invariants: [inner.node] = [inner_node] = [Inner t]. [descendants] are the proper descendants of [inner] we've visited. *) let rec compress t ~inner_node ~inner ~descendants = match t.node with | Root r -> (* t is the root of the tree. Re-point all descendants directly to it by setting them to [Inner t]. Note: we don't re-point [inner] as it already points there. *) List.iter descendants ~f:(fun t -> t.node <- inner_node); t, r | Inner t' as node -> compress t' ~inner_node:node ~inner:t ~descendants:(inner :: descendants) ;; let representative t = match t.node with | Root r -> t, r | Inner t' as node -> compress t' ~inner_node:node ~inner:t ~descendants:[] ;; let root t = match t.node with | Root r -> (* avoid tuple allocation in the fast path *) r | _ -> snd (representative t) ;; let rank t = (root t).rank let get t = (root t).value let set t v = (root t).value <- v let same_class t1 t2 = phys_equal (root t1) (root t2) let union t1 t2 = let t1, r1 = representative t1 in let t2, r2 = representative t2 in if phys_equal r1 r2 then () else ( let n1 = r1.rank in let n2 = r2.rank in if n1 < n2 then t1.node <- Inner t2 else ( t2.node <- Inner t1; if n1 = n2 then r1.rank <- r1.rank + 1)) ;; let is_compressed t = invariant ignore t; match t.node with | Root _ -> true | Inner t -> (match t.node with | Root _ -> true | Inner _ -> false) ;; module Private = struct let is_compressed = is_compressed let rank = rank end core-0.15.0/core/src/union_find.mli000066400000000000000000000031671420273305200171040ustar00rootroot00000000000000(** Imperative data structure for representing disjoint sets. Union find is used to implement an equivalence relation on objects, where the equivalence relation can dynamically be coarsened by "union"ing two equivalence classes together. All of the operations are effectively (amortized) constant time. See {{: https://en.wikipedia.org/wiki/Disjoint-set_data_structure} Wikipedia}. This implementation is not thread-safe. *) open! Import (** [type 'a t] is the type of objects, where each object is part of an equivalence class that is associated with a single value of type ['a]. *) type 'a t include Invariant.S1 with type 'a t := 'a t (** [create v] returns a new object in its own equivalence class that has value [v]. *) val create : 'a -> 'a t (** [get t] returns the value of the class of [t]. *) val get : 'a t -> 'a (** [set t v] sets the value of the class of [t] to [v]. *) val set : 'a t -> 'a -> unit (** [same_class t1 t2] returns true iff [t1] and [t2] are in the same equivalence class. *) val same_class : 'a t -> 'a t -> bool (** [union t1 t2] makes the class of [t1] and the class of [t2] be the same (if they are already equal, then nothing changes). The value of the combined class is the value of [t1] or [t2]; it is unspecified which. After [union t1 t2], it will always be the case that [same_class t1 t2]. *) val union : 'a t -> 'a t -> unit (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig val is_compressed : _ t -> bool val rank : _ t -> int end core-0.15.0/core/src/unique_id.ml000066400000000000000000000016671420273305200165700ustar00rootroot00000000000000open! Import open Std_internal open Unique_id_intf module type Id = Id (* Only "make" can cause a context-switch that might lead to a race. Thus we have to check whether the contents of the cell remained unchanged across this call. The subsequent comparison, dereferencing and assignment cannot cause context switches. If the contents of the cell had changed, we will have to try again to obtain a unique id. This is essentially like a spin-lock and is virtually guaranteed to succeed quickly. *) let rec race_free_create_loop cell make = let x = !cell in let new_x = make x in if phys_equal !cell x then ( cell := new_x; x) else race_free_create_loop cell make ;; module Int () = struct include Int let current = ref zero let create () = race_free_create_loop current succ end module Int63 () = struct include Int63 let current = ref zero let create () = race_free_create_loop current succ end core-0.15.0/core/src/unique_id.mli000066400000000000000000000020151420273305200167250ustar00rootroot00000000000000(** Functors for creating modules that mint unique identifiers. *) open! Import open Unique_id_intf module type Id = Id (** An abstract unique identifier based on ordinary OCaml integers. Be careful, this may easily overflow on 32-bit platforms! [Int63] is a safer choice for portability. [Int] is useful when one is passing unique ids to C and needs a guarantee as to their representation. [Int] is always represented as an integer, while [Int63] is either an integer (on 64-bit machines) or a pointer (on 32-bit machines). The generated ids will therefore be fast to generate and not use much memory. If you do not have very stringent requirements on the size, speed, and ordering of your IDs then you should use the UUIDM library instead, which will give you a truly unique id, even amongst different runs and different machines. *) module Int () : Id with type t = private int (** An abstract unique identifier based on 63 bit integers. *) module Int63 () : Id with type t = private Int63.t core-0.15.0/core/src/unique_id_intf.ml000066400000000000000000000012071420273305200175760ustar00rootroot00000000000000(** Signature for use by {{!module:Core.Unique_id}[Unique_id]}. *) open! Import open Std_internal module type Id = sig (** The sexps and strings look like integers. *) type t [@@deriving bin_io, hash, sexp, typerep] (** {b Caveat}: values created with [of_float], [of_sexp], or [of_string] may be equal to previously created values. *) include Comparable.S_binable with type t := t include Hashable.S_binable with type t := t include Intable with type t := t include Stringable with type t := t (** Always returns a value that is not equal to any other value created with [create]. *) val create : unit -> t end core-0.15.0/core/src/unit.ml000066400000000000000000000013631420273305200155560ustar00rootroot00000000000000module Stable = struct open Base.Export open Bin_prot.Std module V1 = struct module T = struct type t = unit [@@deriving bin_io, compare, sexp] end include T include Comparator.Stable.V1.Make (T) let%expect_test _ = print_endline [%bin_digest: t]; [%expect {| 86ba5df747eec837f0b391dd49f33f9e |}] ;; end end open! Import include Identifiable.Extend (Base.Unit) (struct type t = unit [@@deriving bin_io] end) include Base.Unit type t = unit [@@deriving typerep] let quickcheck_generator = Base_quickcheck.Generator.unit let quickcheck_observer = Base_quickcheck.Observer.unit let quickcheck_shrinker = Base_quickcheck.Shrinker.unit module type S = sig end type m = (module S) core-0.15.0/core/src/unit.mli000066400000000000000000000010211420273305200157160ustar00rootroot00000000000000(** Module for the type [unit], extended from {{!Base.Unit}[Base.Unit]}. This is mostly useful for building functor arguments. *) open! Import type t = unit [@@deriving typerep] (** @inline *) include module type of struct include Base.Unit end with type t := t include Identifiable.S with type t := t and type comparator_witness := comparator_witness include Quickcheckable.S with type t := t module type S = sig end type m = (module S) module Stable : sig module V1 : Stable_module_types.S0 with type t = t end core-0.15.0/core/src/unit_of_time.ml000066400000000000000000000002311420273305200172510ustar00rootroot00000000000000open! Import type t = | Nanosecond | Microsecond | Millisecond | Second | Minute | Hour | Day [@@deriving sexp, compare, enumerate, hash] core-0.15.0/core/src/unit_of_time.mli000066400000000000000000000005111420273305200174230ustar00rootroot00000000000000(** Represents a unit of time, e.g., that used by [Time.Span.to_string_hum]. Comparison respects Nanosecond < Microsecond < Millisecond < Second < Minute < Hour < Day. *) open! Import type t = | Nanosecond | Microsecond | Millisecond | Second | Minute | Hour | Day [@@deriving sexp, compare, enumerate, hash] core-0.15.0/core/src/univ_map.ml000066400000000000000000000224021420273305200164120ustar00rootroot00000000000000open! Import open Std_internal include Univ_map_intf module Uid = Type_equal.Id.Uid module Make1 (Key : Key) (Data : sig type ('s, 'a) t [@@deriving sexp_of] end) = struct (* A wrapper for the [Key] module that adds a dynamic check to [Key.type_id]. It's a bug if the user-provided [Key.type_id] gives different type ids on different calls. Because this check should be fairly cheap, we do it dynamically to avoid subtler problems later. Of course, we're not checking truly pathological things like the provided [Key.type_id] only changes the value it returns on every third call... *) module Key = struct type 'a t = 'a Key.t [@@deriving sexp_of] (* test-friendly sexp conversion *) let sexp_of_type_id type_id = [%sexp { name = (Type_equal.Id.name type_id : string) ; uid = ((if am_running_inline_test then Sexp.Atom "" else Type_equal.Id.Uid.sexp_of_t (Type_equal.Id.uid type_id)) : Sexp.t) }] ;; let type_id key = let type_id1 = Key.type_id key in let type_id2 = Key.type_id key in if Type_equal.Id.same type_id1 type_id2 then type_id1 else raise_s [%message "[Key.type_id] must not provide different type ids when called on the same \ input" (key : _ Key.t) (type_id1 : type_id) (type_id2 : type_id)] ;; end type ('s, 'a) data = ('s, 'a) Data.t let name_of_key key = Type_equal.Id.name (Key.type_id key) let uid_of_key key = Type_equal.Id.uid (Key.type_id key) module Packed = struct type 's t = T : 'a Key.t * ('s, 'a) Data.t -> 's t let sexp_of_t sexp_of_a (T (key, data)) = Data.sexp_of_t sexp_of_a (Type_equal.Id.to_sexp (Key.type_id key)) data ;; let type_id_name (T (key, _)) = name_of_key key let type_id_uid (T (key, _)) = uid_of_key key let compare t1 t2 = let c = String.compare (type_id_name t1) (type_id_name t2) in if c <> 0 then c else Uid.compare (type_id_uid t1) (type_id_uid t2) ;; end type 's t = 's Packed.t Uid.Map.t let to_alist t = Map.data t |> List.sort ~compare:Packed.compare let sexp_of_t sexp_of_a t = to_alist t |> List.map ~f:(fun packed -> Packed.type_id_name packed, packed) |> [%sexp_of: (string * a Packed.t) list] ;; let invariant (t : _ t) = Invariant.invariant [%here] t [%sexp_of: _ t] (fun () -> Map.iteri t ~f:(fun ~key ~data -> assert (Uid.equal key (Packed.type_id_uid data)))) ;; let set t ~key ~data = Map.set t ~key:(uid_of_key key) ~data:(Packed.T (key, data)) let mem_by_id t id = Map.mem t id let mem t key = mem_by_id t (uid_of_key key) let remove_by_id t id = Map.remove t id let remove t key = remove_by_id t (uid_of_key key) let empty = Uid.Map.empty let singleton key data = Uid.Map.singleton (uid_of_key key) (Packed.T (key, data)) let is_empty = Map.is_empty let find (type b) t (key : b Key.t) = match Map.find t (uid_of_key key) with | None -> None | Some (Packed.T (key', value)) -> (* cannot raise -- see [invariant] *) let Type_equal.T = Type_equal.Id.same_witness_exn (Key.type_id key) (Key.type_id key') in Some (value : (_, b) Data.t) ;; let find_exn t key = match find t key with | Some data -> data | None -> failwithf "Univ_map.find_exn on unknown key %s" (name_of_key key) () ;; let add t ~key ~data = if mem t key then `Duplicate else `Ok (set t ~key ~data) let add_exn t ~key ~data = match add t ~key ~data with | `Ok t -> t | `Duplicate -> failwithf "Univ_map.add_exn on existing key %s" (name_of_key key) () ;; let change_exn t key ~f:update = match find t key with | Some data -> set t ~key ~data:(update data) | None -> failwithf "Univ_map.change_exn on unknown key %s" (name_of_key key) () ;; let change t key ~f:update = let orig = find t key in let next = update orig in match next with | Some data -> set t ~key ~data | None -> if Option.is_none orig then t else remove t key ;; let update t key ~f = change t key ~f:(fun data -> Some (f data)) let of_alist_exn t = Uid.Map.of_alist_exn (List.map t ~f:(fun p -> Packed.type_id_uid p, p)) ;; end module Make (Key : Key) (Data : sig type 'a t [@@deriving sexp_of] end) = struct module M = Make1 (Key) (struct type (_, 'a) t = 'a Data.t [@@deriving sexp_of] end) type t = unit M.t [@@deriving sexp_of] module Key = Key type 'a data = 'a Data.t let invariant = M.invariant let empty = M.empty let singleton = M.singleton let is_empty = M.is_empty let set = M.set let mem = M.mem let mem_by_id = M.mem_by_id let find = M.find let find_exn = M.find_exn let add = M.add let add_exn = M.add_exn let change = M.change let change_exn = M.change_exn let update = M.update let remove = M.remove let remove_by_id = M.remove_by_id module Packed = struct type t = T : 'a Key.t * 'a Data.t -> t end let to_alist t = List.map (M.to_alist t) ~f:(function M.Packed.T (key, data) -> Packed.T (key, data)) ;; let of_alist_exn t = M.of_alist_exn (List.map t ~f:(function Packed.T (key, data) -> M.Packed.T (key, data))) ;; end module Merge (Key : Key) (Input1_data : Data) (Input2_data : Data) (Output_data : Data) = struct type f = { f : 'a. key:'a Key.t -> [ `Left of 'a Input1_data.t | `Right of 'a Input2_data.t | `Both of 'a Input1_data.t * 'a Input2_data.t ] -> 'a Output_data.t option } module Output = Make (Key) (Output_data) let merge (t1 : Make(Key)(Input1_data).t) (t2 : Make(Key)(Input2_data).t) ~f:{ f } : Make(Key)(Output_data).t = let f ~key merge_result = Option.map (f ~key merge_result) ~f:(fun data -> Output.M.Packed.T (key, data)) in Map.merge t1 t2 ~f:(fun ~key:_ -> function | `Left (T (key, data)) -> f ~key (`Left data) | `Right (T (key, data)) -> f ~key (`Right data) | `Both (T (left_key, left_data), T (right_key, right_data)) -> (* Can't raise due to the invariant *) let Type_equal.T = Type_equal.Id.same_witness_exn (Key.type_id left_key) (Key.type_id right_key) in f ~key:left_key (`Both (left_data, right_data))) ;; end module Merge1 (Key : Key) (Input1_data : Data1) (Input2_data : Data1) (Output_data : Data1) = struct type ('s1, 's2, 's3) f = { f : 'a. key:'a Key.t -> [ `Left of ('s1, 'a) Input1_data.t | `Right of ('s2, 'a) Input2_data.t | `Both of ('s1, 'a) Input1_data.t * ('s2, 'a) Input2_data.t ] -> ('s3, 'a) Output_data.t option } module Output = Make1 (Key) (Output_data) let merge (type s1 s2) (t1 : s1 Make1(Key)(Input1_data).t) (t2 : s2 Make1(Key)(Input2_data).t) ~f:{ f } = let f ~key merge_result = Option.map (f ~key merge_result) ~f:(fun data -> Output.Packed.T (key, data)) in Map.merge t1 t2 ~f:(fun ~key:_ -> function | `Left (T (key, data)) -> f ~key (`Left data) | `Right (T (key, data)) -> f ~key (`Right data) | `Both (T (left_key, left_data), T (right_key, right_data)) -> (* Can't raise due to the invariant *) let Type_equal.T = Type_equal.Id.same_witness_exn (Key.type_id left_key) (Key.type_id right_key) in f ~key:left_key (`Both (left_data, right_data))) ;; end module Type_id_key = struct type 'a t = 'a Type_equal.Id.t [@@deriving sexp_of] let type_id = Fn.id end include ( Make (Type_id_key) (struct type 'a t = 'a [@@deriving sexp_of] end) : S with type 'a data = 'a and module Key := Type_id_key) module Key = Type_equal.Id module With_default = struct module Key = struct type 'a t = { key : 'a Type_equal.Id.t ; default : 'a } let create ~default ~name sexp_of = { default; key = Type_equal.Id.create ~name sexp_of } ;; let id t = t.key end let find t { Key.key; default } = Option.value ~default (find t key) let set t ~key:{ Key.key; default = _ } ~data = set t ~key ~data let change t key ~f:update = set t ~key ~data:(update (find t key)) end module With_fold = struct module Key = struct type ('a, 'b) t = { key : 'b With_default.Key.t ; f : 'b -> 'a -> 'b } let create ~init ~f ~name sexp_of = { f; key = With_default.Key.create ~default:init ~name sexp_of } ;; let id t = With_default.Key.id t.key end let find t { Key.key; f = _ } = With_default.find t key let set t ~key:{ Key.key; f = _ } ~data = With_default.set t ~key ~data let change t { Key.key; f = _ } ~f:update = With_default.change t key ~f:update let add t ~key:{ Key.key; f } ~data = With_default.change t key ~f:(fun acc -> f acc data) ;; end module Multi = struct open With_fold module Key = struct type 'a t = ('a, 'a list) Key.t let create ~name sexp_of = Key.create ~init:[] ~f:(fun xs x -> x :: xs) ~name (List.sexp_of_t sexp_of) ;; let id = With_fold.Key.id end let set = set let find = find let add = add let change = change end core-0.15.0/core/src/univ_map.mli000066400000000000000000000000561420273305200165640ustar00rootroot00000000000000include Univ_map_intf.Univ_map (** @inline *) core-0.15.0/core/src/univ_map_intf.ml000066400000000000000000000145751420273305200174460ustar00rootroot00000000000000(** Universal/heterogeneous maps, useful for storing values of arbitrary type in a single map. In order to recover a value, it must be looked up with exactly the [Key.t] it was stored in. In other words, given different [Key.t]s from the same [string], one will not be able to recover the key stored in the other one. This is similar to [Univ] in spirit. *) open! Import module type Key = sig type 'a t [@@deriving sexp_of] (** For correct behavior of the map, [type_id] must return the same [Type_equal.Id] on different calls on the same input. *) val type_id : 'a t -> 'a Type_equal.Id.t end module type Data = sig type 'a t [@@deriving sexp_of] end module type Data1 = sig type ('s, 'a) t [@@deriving sexp_of] end module type S = sig type t [@@deriving sexp_of] module Key : Key type 'a data include Invariant.S with type t := t val empty : t val singleton : 'a Key.t -> 'a data -> t val is_empty : t -> bool val set : t -> key:'a Key.t -> data:'a data -> t val mem : t -> 'a Key.t -> bool val mem_by_id : t -> Type_equal.Id.Uid.t -> bool val find : t -> 'a Key.t -> 'a data option val find_exn : t -> 'a Key.t -> 'a data val add : t -> key:'a Key.t -> data:'a data -> [ `Ok of t | `Duplicate ] val add_exn : t -> key:'a Key.t -> data:'a data -> t val change : t -> 'a Key.t -> f:('a data option -> 'a data option) -> t val change_exn : t -> 'a Key.t -> f:('a data -> 'a data) -> t val update : t -> 'a Key.t -> f:('a data option -> 'a data) -> t val remove : t -> 'a Key.t -> t val remove_by_id : t -> Type_equal.Id.Uid.t -> t module Packed : sig type t = T : 'a Key.t * 'a data -> t end (** [to_alist t] returns all values in [t], in increasing order of key type-id name. *) val to_alist : t -> Packed.t list val of_alist_exn : Packed.t list -> t end module type S1 = sig (** The ['s] parameter is shared across all values stored in the map. *) type 's t [@@deriving sexp_of] module Key : Key type ('s, 'a) data val invariant : _ t -> unit val empty : _ t val singleton : 'a Key.t -> ('s, 'a) data -> 's t val is_empty : _ t -> bool val set : 's t -> key:'a Key.t -> data:('s, 'a) data -> 's t val mem : _ t -> _ Key.t -> bool val mem_by_id : _ t -> Type_equal.Id.Uid.t -> bool val find : 's t -> 'a Key.t -> ('s, 'a) data option val find_exn : 's t -> 'a Key.t -> ('s, 'a) data val add : 's t -> key:'a Key.t -> data:('s, 'a) data -> [ `Ok of 's t | `Duplicate ] val add_exn : 's t -> key:'a Key.t -> data:('s, 'a) data -> 's t val change : 's t -> 'a Key.t -> f:(('s, 'a) data option -> ('s, 'a) data option) -> 's t val change_exn : 's t -> 'a Key.t -> f:(('s, 'a) data -> ('s, 'a) data) -> 's t val update : 's t -> 'a Key.t -> f:(('s, 'a) data option -> ('s, 'a) data) -> 's t val remove : 's t -> 'a Key.t -> 's t val remove_by_id : 's t -> Type_equal.Id.Uid.t -> 's t module Packed : sig type 's t = T : 'a Key.t * ('s, 'a) data -> 's t end val to_alist : 's t -> 's Packed.t list val of_alist_exn : 's Packed.t list -> 's t end module type Univ_map = sig module type S = S module type S1 = S1 module type Key = Key module type Data = Data module Type_id_key : Key with type 'a t = 'a Type_equal.Id.t include S with type 'a data = 'a and module Key := Type_id_key (** This binding is convenient because existing call sites often refer to [Univ_map.Key.create]. *) module Key = Type_equal.Id module Make (Key : Key) (Data : Data) : S with type 'a data = 'a Data.t and module Key = Key module Make1 (Key : Key) (Data : Data1) : S1 with type ('s, 'a) data = ('s, 'a) Data.t and module Key = Key module Merge (Key : Key) (Input1_data : Data) (Input2_data : Data) (Output_data : Data) : sig type f = { f : 'a. key:'a Key.t -> [ `Left of 'a Input1_data.t | `Right of 'a Input2_data.t | `Both of 'a Input1_data.t * 'a Input2_data.t ] -> 'a Output_data.t option } (** The analogue of the normal [Map.merge] function. *) val merge : Make(Key)(Input1_data).t -> Make(Key)(Input2_data).t -> f:f -> Make(Key)(Output_data).t end module Merge1 (Key : Key) (Input1_data : Data1) (Input2_data : Data1) (Output_data : Data1) : sig type ('s1, 's2, 's3) f = { f : 'a. key:'a Key.t -> [ `Left of ('s1, 'a) Input1_data.t | `Right of ('s2, 'a) Input2_data.t | `Both of ('s1, 'a) Input1_data.t * ('s2, 'a) Input2_data.t ] -> ('s3, 'a) Output_data.t option } (** The analogue of the normal [Map.merge] function. *) val merge : 's1 Make1(Key)(Input1_data).t -> 's2 Make1(Key)(Input2_data).t -> f:('s1, 's2, 's3) f -> 's3 Make1(Key)(Output_data).t end (** keys with associated default values, so that [find] is no longer partial *) module With_default : sig module Key : sig type 'a t val create : default:'a -> name:string -> ('a -> Sexp.t) -> 'a t val id : 'a t -> 'a Type_equal.Id.t end val set : t -> key:'a Key.t -> data:'a -> t val find : t -> 'a Key.t -> 'a val change : t -> 'a Key.t -> f:('a -> 'a) -> t end (** keys that map to an accumulator value with an associated fold operation *) module With_fold : sig module Key : sig type ('a, 'b) t val create : init:'b -> f:('b -> 'a -> 'b) -> name:string -> ('b -> Sexp.t) -> ('a, 'b) t val id : ('a, 'b) t -> 'b Type_equal.Id.t end (** reset the accumulator *) val set : t -> key:('a, 'b) Key.t -> data:'b -> t (** the current accumulator *) val find : t -> ('a, 'b) Key.t -> 'b (** fold value into accumulator *) val add : t -> key:('a, 'b) Key.t -> data:'a -> t (** accumulator update *) val change : t -> ('a, 'b) Key.t -> f:('b -> 'b) -> t end (** list-accumulating keys with a default value of the empty list *) module Multi : sig module Key : sig type 'a t val create : name:string -> ('a -> Sexp.t) -> 'a t val id : 'a t -> 'a list Type_equal.Id.t end val set : t -> key:'a Key.t -> data:'a list -> t val find : t -> 'a Key.t -> 'a list val add : t -> key:'a Key.t -> data:'a -> t val change : t -> 'a Key.t -> f:('a list -> 'a list) -> t end end core-0.15.0/core/src/validated.ml000066400000000000000000000050131420273305200165300ustar00rootroot00000000000000open! Import open Std_internal open Validated_intf module type Raw = Raw type ('raw, 'witness) t = 'raw module type S = S with type ('a, 'b) validated := ('a, 'b) t module type S_bin_io = S_bin_io with type ('a, 'b) validated := ('a, 'b) t module type S_bin_io_compare_hash_sexp = S_bin_io_compare_hash_sexp with type ('a, 'b) validated := ('a, 'b) t let raw t = t module Make (Raw : Raw) = struct type witness type t = Raw.t [@@deriving sexp_of] let validation_failed t error = Error.create "validation failed" (t, error, Raw.here) [%sexp_of: Raw.t * Error.t * Source_code_position.t] ;; let create_exn t = match Validate.result (Raw.validate t) with | Ok () -> t | Error error -> Error.raise (validation_failed t error) ;; let create t = match Validate.result (Raw.validate t) with | Ok () -> Ok t | Error error -> Error (validation_failed t error) ;; let t_of_sexp sexp = create_exn (Raw.t_of_sexp sexp) let raw t = t end module Add_bin_io (Raw : sig type t [@@deriving bin_io] include Raw_bin_io with type t := t end) (Validated : S with type raw := Raw.t) = struct include Binable.Of_binable_without_uuid [@alert "-legacy"] (Raw) (struct type t = Raw.t let of_binable raw = if Raw.validate_binio_deserialization then Validated.create_exn raw else raw ;; let to_binable = Fn.id end) end module Add_compare (Raw : sig type t [@@deriving compare] include Raw with type t := t end) (_ : S with type raw := Raw.t) = struct let compare t1 t2 = [%compare: Raw.t] (raw t1) (raw t2) end module Add_hash (Raw : sig type t [@@deriving hash] include Raw with type t := t end) (Validated : S with type raw := Raw.t) = struct let hash_fold_t state t = Raw.hash_fold_t state (Validated.raw t) let hash t = Raw.hash (Validated.raw t) end module Add_typerep (Raw : sig type t [@@deriving typerep] include Raw with type t := t end) (_ : S with type raw := Raw.t) = struct type t = Raw.t [@@deriving typerep] end module Make_binable (Raw : Raw_bin_io) = struct module T0 = Make (Raw) include T0 include Add_bin_io (Raw) (T0) end module Make_bin_io_compare_hash_sexp (Raw : sig type t [@@deriving compare, hash] include Raw_bin_io with type t := t end) = struct module T = Make_binable (Raw) include T include Add_compare (Raw) (T) include ( Add_hash (Raw) (T) : sig type t [@@deriving hash] end with type t := t) end core-0.15.0/core/src/validated.mli000066400000000000000000000000601420273305200166760ustar00rootroot00000000000000include Validated_intf.Validated (** @inline *) core-0.15.0/core/src/validated_intf.ml000066400000000000000000000102341420273305200175510ustar00rootroot00000000000000(** For making an abstract version of a type that ensures a validation check has passed. Suppose one wants to have a type of positive integers: {[ module Positive_int = Validated.Make (struct type t = int let here = [%here] let validate = Int.validate_positive end) ]} With this, one is certain that any value of type [Positive_int.t] has passed [Int.validate_positive]. One can call [Positive_int.create_exn n] to create a new positive int from an [n], which will of course raise if [n <= 0]. One can call [Positive_int.raw positive_int] to get the [int] from a [Positive_int.t]. *) open! Import module type Raw = sig type t [@@deriving sexp] (** [here] will appear in validation-failure error messages. *) val here : Source_code_position.t val validate : t Validate.check end module type Raw_bin_io = sig type t [@@deriving bin_io] include Raw with type t := t (** [validate_binio_deserialization] controls whether when the binio representation of a value is deserialized, the resulting value is validated. Whether one needs to validate values upon deserialization depends on how serialization is being used. If one only ever serializes/deserializes so that the validation function is the same on both ends, then one need not validate upon deserialization, because only values that already pass the validation function can be serialized. If the validation functions in the serializer and deserializer may be different, e.g. because of two different versions of the code compiled at different times, then it is possible to serialize a value that may fail validation upon deserialization. In that case, having [validate_binio_deserialization = true] is necessary to prevent creating values that don't pass the validation function. *) val validate_binio_deserialization : bool end module type Raw_bin_io_compare_hash_sexp = sig type t [@@deriving compare, hash] include Raw_bin_io with type t := t end module type S = sig type ('raw, 'witness) validated type witness type raw type t = (raw, witness) validated [@@deriving sexp] val create : raw -> t Or_error.t val create_exn : raw -> t val raw : t -> raw end module type S_bin_io = sig include S include sig type t = (raw, witness) validated [@@deriving bin_io] end with type t := t end module type S_bin_io_compare_hash_sexp = sig include S include sig type t = (raw, witness) validated [@@deriving bin_io, compare, hash] end with type t := t end module type Validated = sig type ('raw, 'witness) t = private 'raw val raw : ('raw, _) t -> 'raw module type Raw = Raw module type S = S with type ('a, 'b) validated := ('a, 'b) t module type S_bin_io = S_bin_io with type ('a, 'b) validated := ('a, 'b) t module type S_bin_io_compare_hash_sexp = S_bin_io_compare_hash_sexp with type ('a, 'b) validated := ('a, 'b) t module Make (Raw : Raw) : S with type raw := Raw.t module Make_binable (Raw : Raw_bin_io) : S_bin_io with type raw := Raw.t (** [Make_bin_io_compare_hash_sexp] is useful for stable types. *) module Make_bin_io_compare_hash_sexp (Raw : Raw_bin_io_compare_hash_sexp) : S_bin_io_compare_hash_sexp with type raw := Raw.t module Add_bin_io (Raw : sig type t [@@deriving bin_io] include Raw_bin_io with type t := t end) (Validated : S with type raw := Raw.t) : sig type t [@@deriving bin_io] end with type t := Validated.t module Add_compare (Raw : sig type t [@@deriving compare] include Raw with type t := t end) (Validated : S with type raw := Raw.t) : sig type t [@@deriving compare] end with type t := Validated.t module Add_hash (Raw : sig type t [@@deriving hash] include Raw with type t := t end) (Validated : S with type raw := Raw.t) : sig type t [@@deriving hash] end with type t := Validated.t module Add_typerep (Raw : sig type t [@@deriving typerep] include Raw with type t := t end) (Validated : S with type raw := Raw.t) : sig type t [@@deriving typerep] end with type t := Validated.t end core-0.15.0/core/src/zone.ml000066400000000000000000000527411420273305200155600ustar00rootroot00000000000000(* Functions for parsing time zone database files (zic files). A time zone file consists (conceptually - the representation is more compact) of an ordered list of (Time.t * [local_time_type]) that mark the boundaries (marked from the epoch) at which various time adjustment regimes are in effect. This can also be thought of as breaking down all time past the epoch into ranges with a [local_time_type] that describes the offset from GMT to apply to each range to get local time. *) open Import open Std_internal open! Int.Replace_polymorphic_compare include Zone_intf exception Invalid_file_format of string [@@deriving sexp] module Stable = struct module Full_data = struct module V1 = struct module Index = struct type t = int let next = Int.succ let prev = Int.pred let before_first_transition = -1 (* Some existing clients expect [index >= 0], so we never serialize a negative index. This conversion can be removed if new stable versions are minted. *) let to_external t = max 0 t (* When the index of a time zone with no transitions is converted via to_external, its value becomes 0 even though its transition array is empty (and it should have been -1). When the converted value is changed back to a Zone.t through of_external, returning this value for its index could result in unsafe array accesses to the transition array of the zone (since there is no transition at index 0). Also, it does not make sense to keep the converted index because it is intended to be a mutable value used for caching. So of_external always sets the index to -1, which is a safe value. *) let of_external (_ : t) = -1 include Binable.Of_binable_without_uuid [@alert "-legacy"] (Int) (struct type t = int let to_binable = to_external let of_binable = of_external end) include Sexpable.Of_sexpable (Int) (struct type t = int let to_sexpable = to_external let of_sexpable = of_external end) end module Regime = struct type t = { utc_offset_in_seconds : Int63.Stable.V1.t ; is_dst : bool ; abbrv : string } [@@deriving bin_io, sexp] end (* holds information about when leap seconds should be applied - unused because we are translating based on a epoch system clock (see the Core_zone documentation). *) module Leap_second = struct type t = { time_in_seconds_since_epoch : Int63.Stable.V1.t ; seconds : int } [@@deriving bin_io, sexp] end module Transition = struct type t = { start_time_in_seconds_since_epoch : Int63.Stable.V1.t ; new_regime : Regime.t } [@@deriving bin_io, sexp] end type t = { name : string ; original_filename : string option ; digest : Md5.As_binary_string.t option ; transitions : Transition.t array ; (* caches the index of the last transition we used to make lookups faster *) mutable last_regime_index : Index.t ; default_local_time_type : Regime.t ; leap_seconds : Leap_second.t list } [@@deriving bin_io, sexp] (* this relies on zones with the same name having the same transitions *) let compare t1 t2 = String.compare t1.name t2.name let original_filename zone = zone.original_filename let digest zone = zone.digest module Zone_file : sig val input_tz_file : zonename:string -> filename:string -> t end = struct let bool_of_int i = i <> 0 let input_long_as_int32 = let long = Bytes.create 4 in let int32_of_char chr = Int32.of_int_exn (int_of_char chr) in fun ic -> In_channel.really_input_exn ic ~buf:long ~pos:0 ~len:4; let sb1 = Int32.shift_left (int32_of_char (Bytes.get long 0)) 24 in let sb2 = Int32.shift_left (int32_of_char (Bytes.get long 1)) 16 in let sb3 = Int32.shift_left (int32_of_char (Bytes.get long 2)) 8 in let sb4 = int32_of_char (Bytes.get long 3) in Int32.bit_or (Int32.bit_or sb1 sb2) (Int32.bit_or sb3 sb4) ;; (* Note that this is only safe to use on numbers that will fit into a 31-bit int. UNIX timestamps won't, for example. In our case this is only used to hold small numbers that are never interpreted as timestamps. *) let input_long_as_int ic = Int32.to_int_exn (input_long_as_int32 ic) let input_long_as_int63 ic = Int63.of_int32 (input_long_as_int32 ic) let input_long_long_as_int63 ic = let int63_of_char chr = Int63.of_int_exn (int_of_char chr) in let shift c bits = Int63.shift_left (int63_of_char c) bits in let long_long = Bytes.create 8 in In_channel.really_input_exn ic ~buf:long_long ~pos:0 ~len:8; let result = shift (Bytes.get long_long 0) 56 in let result = Int63.bit_or result (shift (Bytes.get long_long 1) 48) in let result = Int63.bit_or result (shift (Bytes.get long_long 2) 40) in let result = Int63.bit_or result (shift (Bytes.get long_long 3) 32) in let result = Int63.bit_or result (shift (Bytes.get long_long 4) 24) in let result = Int63.bit_or result (shift (Bytes.get long_long 5) 16) in let result = Int63.bit_or result (shift (Bytes.get long_long 6) 8) in let result = Int63.bit_or result (int63_of_char (Bytes.get long_long 7)) in result ;; let input_list ic ~len ~f = let rec loop c lst = if c > 0 then loop (c - 1) (f ic :: lst) else List.rev lst in loop len [] ;; let input_array ic ~len ~f = Array.of_list (input_list ic ~len ~f) let input_regime ic = let utc_offset_in_seconds = input_long_as_int63 ic in let is_dst = bool_of_int (Option.value_exn (In_channel.input_byte ic)) in let abbrv_index = Option.value_exn (In_channel.input_byte ic) in let lt abbrv = { Regime.utc_offset_in_seconds; is_dst; abbrv } in lt, abbrv_index ;; let input_abbreviations ic ~len = let raw_abbrvs = input_list ic ~len ~f:(fun ic -> Option.value_exn (In_channel.input_char ic)) in let buf = Buffer.create len in let _, indexed_abbrvs = List.fold raw_abbrvs ~init:(0, Map.Poly.empty) ~f:(fun (index, abbrvs) c -> match c with | '\000' -> let data = Buffer.contents buf in let next_index = index + String.length data + 1 in let abbrvs = Map.set abbrvs ~key:index ~data in Buffer.clear buf; next_index, abbrvs | c -> Buffer.add_char buf c; index, abbrvs) in if Buffer.length buf <> 0 then raise (Invalid_file_format "missing \000 terminating character in input_abbreviations"); indexed_abbrvs ;; let input_tz_file_gen ~input_transition ~input_leap_second ic = let utc_local_count = input_long_as_int ic in let std_wall_count = input_long_as_int ic in let leap_count = input_long_as_int ic in let transition_count = input_long_as_int ic in let type_count = input_long_as_int ic in let abbrv_char_count = input_long_as_int ic in let transition_times = input_list ic ~f:input_transition ~len:transition_count in let transition_indices = input_list ic ~f:(fun ic -> Option.value_exn (In_channel.input_byte ic)) ~len:transition_count in let regimes = input_list ic ~f:input_regime ~len:type_count in let abbreviations = input_abbreviations ic ~len:abbrv_char_count in let leap_seconds = input_list ic ~f:input_leap_second ~len:leap_count in (* The following two arrays indicate two boolean values per regime that represent a three-value type that would translate to: type transition_type = UTC | Standard | Wall_clock However, these are only used by the system library when handling the case where the TZ variable is set, not to a time zone name, but instead is of the form: TZ = "std offset dst offset, rule" Which is deeply obscure, and almost certainly a mistake to use. This library makes no pretense about handling this case. We continue to read them in for completeness, and because it's possible that we will later discover a case where they are used. *) let _std_wall_indicators = input_array ic ~len:std_wall_count ~f:(fun ic -> bool_of_int (Option.value_exn (In_channel.input_byte ic))) in let _utc_local_indicators = input_array ic ~len:utc_local_count ~f:(fun ic -> bool_of_int (Option.value_exn (In_channel.input_byte ic))) in let regimes = Array.of_list (List.map regimes ~f:(fun (lt, abbrv_index) -> let abbrv = Map.find_exn abbreviations abbrv_index in lt abbrv)) in let raw_transitions = List.map2_exn transition_times transition_indices ~f:(fun time index -> let regime = regimes.(index) in time, regime) in let transitions = let rec make_transitions acc l = match l with | [] -> Array.of_list (List.rev acc) | (start_time_in_seconds_since_epoch, new_regime) :: rest -> make_transitions ({ Transition.start_time_in_seconds_since_epoch; new_regime } :: acc) rest in make_transitions [] raw_transitions in let default_local_time_type = match Array.find regimes ~f:(fun r -> not r.Regime.is_dst) with | None -> regimes.(0) | Some ltt -> ltt in fun name ~original_filename ~digest -> { name ; original_filename = Some original_filename ; digest = Some digest ; transitions ; last_regime_index = Index.before_first_transition ; default_local_time_type ; leap_seconds } ;; let input_leap_second_gen ~input_leap_second ic = let time_in_seconds_since_epoch = input_leap_second ic in let seconds = input_long_as_int ic in { Leap_second.time_in_seconds_since_epoch; seconds } ;; let read_header ic = let magic = let buf = Bytes.create 4 in In_channel.really_input_exn ic ~buf ~pos:0 ~len:4; Bytes.unsafe_to_string ~no_mutation_while_string_reachable:buf in if not (String.equal magic "TZif") then raise (Invalid_file_format "magic characters TZif not present"); let version = match In_channel.input_char ic with | Some '\000' -> `V1 | Some '2' -> `V2 | Some '3' -> `V3 | None -> raise (Invalid_file_format "expected version, found nothing") | Some bad_version -> raise (Invalid_file_format (sprintf "version (%c) is invalid" bad_version)) in (* space reserved for future use in the format *) In_channel.really_input_exn ic ~buf:(Bytes.create 15) ~pos:0 ~len:15; version ;; let input_tz_file_v1 ic = let input_leap_second = input_leap_second_gen ~input_leap_second:input_long_as_int63 in input_tz_file_gen ~input_transition:input_long_as_int63 ~input_leap_second ic ;; (* version 2 timezone files have the format: part 1 - exactly the same as v1 part 2 - same format as v1, except that 8 bytes are used to store transition times and leap seconds part 3 - a newline-encloded, POSIX-TZ-environment-variable-style string for use in handling instants after the last transition time stored in the file (with nothing between the newlines if there is no POSIX representation for such instants) We handle files in this format by parsing the first part exactly as a v1 timezone file and then continuing to parse with 64bit reading functions in the right places. Version 3 timezone files are the same as version 2, except the POSIX-TZ-environment-variable-style string in part 3 may use two minor extensions to the POSIX TZ format (the hours part of its transition times may be signed and range from -167 through 167 instead of the POSIX-required unsigned values from 0 through 24; and DST is in effect all year if it starts January 1 at 00:00 and ends December 31 at 24:00 plus the difference between daylight saving and standard time). As we don't actually do anything with part 3 anyway, we can just read v3 files as v2. *) let input_tz_file_v2_or_v3 ~version ic = let (_ : string -> original_filename:string -> digest:Md5_lib.t -> t) = input_tz_file_v1 ic in (* the header is fully repeated *) assert ([%compare.equal: [ `V1 | `V2 | `V3 ]] (read_header ic) version); let input_leap_second = input_leap_second_gen ~input_leap_second:input_long_long_as_int63 in input_tz_file_gen ~input_transition:input_long_long_as_int63 ~input_leap_second ic ;; let input_tz_file ~zonename ~filename = try protectx (In_channel.create filename) ~finally:In_channel.close ~f:(fun ic -> let make_zone = match read_header ic with | `V1 -> input_tz_file_v1 ic | (`V2 | `V3) as version -> input_tz_file_v2_or_v3 ~version ic in let digest = Md5.digest_file_blocking filename in let r = make_zone zonename ~original_filename:filename ~digest in r) with | Invalid_file_format reason -> raise (Invalid_file_format (sprintf "%s - %s" filename reason)) ;; end let of_utc_offset_explicit_name ~name ~hours:offset = assert (offset >= -24 && offset <= 24); let utc_offset_in_seconds = Int63.of_int (offset * 60 * 60) in { name ; original_filename = None ; digest = None ; transitions = [||] ; last_regime_index = Index.before_first_transition ; default_local_time_type = { Regime.utc_offset_in_seconds; is_dst = false; abbrv = name } ; leap_seconds = [] } ;; let of_utc_offset ~hours:offset = let name = if offset = 0 then "UTC" else sprintf "UTC%s%d" (if offset < 0 then "-" else "+") (abs offset) in of_utc_offset_explicit_name ~name ~hours:offset ;; end end end include Stable.Full_data.V1 let sexp_of_t t = Sexp.Atom t.name let likely_machine_zones = ref [ "America/New_York"; "Europe/London"; "Asia/Hong_Kong"; "America/Chicago" ] ;; let input_tz_file = Zone_file.input_tz_file let utc = of_utc_offset ~hours:0 let name zone = zone.name let reset_transition_cache t = t.last_regime_index <- Index.before_first_transition (* Raises if [index >= Array.length t.transitions] *) let get_regime_exn t index = if index < 0 then t.default_local_time_type else t.transitions.(index).new_regime ;; (* In "absolute mode", a number of seconds is interpreted as an offset of that many seconds from the UNIX epoch, ignoring leap seconds. In "date and ofday mode", you interpret the number of seconds as a number of days in combination with a number of seconds since midnight, which gives you a calendar day and a clock face time. Then you take the time that those represent in some relevant timezone. Of course, if the timezone in question has DST shifts, the date and ofday might represent two or zero times. These times will be interpreted according to either the previous UTC offset or the next one, in a way whose precise details you probably shouldn't depend on. (For the curious, what we do is: compute the "relative time" of the shift according to the new regime, and assign relative times to the old regime or new regime depending on which side of the shift time they occur. Since this amounts to using the old regime when the clocks move forward and the new regime when the clocks move back, it's equivalent to calculating the corresponding Time.t's relative to both the old and the new regime and picking the one that occurs later. Yes, later. I had to draw a diagram to persuade myself that it's that way round, but it is.) *) module Mode = struct type t = | Absolute | Date_and_ofday end let effective_start_time ~mode (x : Transition.t) = let open Int63.O in match (mode : Mode.t) with | Absolute -> x.start_time_in_seconds_since_epoch | Date_and_ofday -> x.start_time_in_seconds_since_epoch + x.new_regime.utc_offset_in_seconds ;; let index_lower_bound_contains_seconds_since_epoch t index ~mode seconds = index < 0 || Int63.( >= ) seconds (effective_start_time ~mode t.transitions.(index)) ;; let index_upper_bound_contains_seconds_since_epoch t index ~mode seconds = index + 1 >= Array.length t.transitions || Int63.( < ) seconds (effective_start_time ~mode t.transitions.(index + 1)) ;; let binary_search_index_of_seconds_since_epoch t ~mode seconds : Index.t = Array.binary_search_segmented t.transitions `Last_on_left ~segment_of:(fun transition -> if Int63.( <= ) (effective_start_time transition ~mode) seconds then `Left else `Right) |> Option.value ~default:Index.before_first_transition ;; let index_of_seconds_since_epoch t ~mode seconds = let index = let index = t.last_regime_index in if not (index_lower_bound_contains_seconds_since_epoch t index ~mode seconds) (* time is before cached index; try previous index *) then ( let index = index - 1 in if not (index_lower_bound_contains_seconds_since_epoch t index ~mode seconds) (* time is before previous index; fall back on binary search *) then binary_search_index_of_seconds_since_epoch t ~mode seconds (* time is before cached index and not before previous, so within previous *) else index) else if not (index_upper_bound_contains_seconds_since_epoch t index ~mode seconds) (* time is after cached index; try next index *) then ( let index = index + 1 in if not (index_upper_bound_contains_seconds_since_epoch t index ~mode seconds) (* time is after next index; fall back on binary search *) then binary_search_index_of_seconds_since_epoch t ~mode seconds (* time is after cached index and not after next, so within next *) else index (* time is within cached index *)) else index in t.last_regime_index <- index; index ;; module Time_in_seconds : sig include Zone_intf.Time_in_seconds end = struct module Span = struct type t = Int63.t let of_int63_seconds = Fn.id let to_int63_seconds_round_down_exn = Fn.id end module Absolute = struct type t = Int63.t let of_span_since_epoch = Fn.id let to_span_since_epoch = Fn.id end module Date_and_ofday = struct type t = Int63.t let of_synthetic_span_since_epoch = Fn.id let to_synthetic_span_since_epoch = Fn.id end include Absolute end let index t time = Time_in_seconds.to_span_since_epoch time |> Time_in_seconds.Span.to_int63_seconds_round_down_exn |> index_of_seconds_since_epoch t ~mode:Absolute ;; let index_of_date_and_ofday t time = Time_in_seconds.Date_and_ofday.to_synthetic_span_since_epoch time |> Time_in_seconds.Span.to_int63_seconds_round_down_exn |> index_of_seconds_since_epoch t ~mode:Date_and_ofday ;; let index_has_prev_clock_shift t index = index >= 0 && index < Array.length t.transitions let index_has_next_clock_shift t index = index_has_prev_clock_shift t (index + 1) let index_prev_clock_shift_time_exn t index = let transition = t.transitions.(index) in transition.start_time_in_seconds_since_epoch |> Time_in_seconds.Span.of_int63_seconds |> Time_in_seconds.of_span_since_epoch ;; let index_next_clock_shift_time_exn t index = index_prev_clock_shift_time_exn t (index + 1) let index_prev_clock_shift_amount_exn t index = let transition = t.transitions.(index) in let after = transition.new_regime in let before = if index = 0 then t.default_local_time_type else t.transitions.(index - 1).new_regime in Int63.( - ) after.utc_offset_in_seconds before.utc_offset_in_seconds |> Time_in_seconds.Span.of_int63_seconds ;; let index_next_clock_shift_amount_exn t index = index_prev_clock_shift_amount_exn t (index + 1) ;; let index_abbreviation_exn t index = let regime = get_regime_exn t index in regime.abbrv ;; let index_offset_from_utc_exn t index = let regime = get_regime_exn t index in Time_in_seconds.Span.of_int63_seconds regime.utc_offset_in_seconds ;; core-0.15.0/core/src/zone.mli000066400000000000000000000000271420273305200157170ustar00rootroot00000000000000include Zone_intf.Zone core-0.15.0/core/src/zone_intf.ml000066400000000000000000000121021420273305200165630ustar00rootroot00000000000000(** Time-zone handling. *) open! Import (** The internal time representation of [Zone.t]. This is a tiny subset of [Time0_intf.S], see that interface for details such as the meaning of [Span] and [Date_and_ofday]. The name of the interface reflects the fact that the interface only gives you access to the seconds of the [t]. But you can use this interface with types that have higher precision than that, hence the rounding implied in the name of [to_int63_seconds_round_down_exn]. *) module type Time_in_seconds = sig module Span : sig type t val of_int63_seconds : Int63.t -> t val to_int63_seconds_round_down_exn : t -> Int63.t end module Date_and_ofday : sig type t val of_synthetic_span_since_epoch : Span.t -> t val to_synthetic_span_since_epoch : t -> Span.t end type t val of_span_since_epoch : Span.t -> t val to_span_since_epoch : t -> Span.t end (** This is the interface of [Zone], but not the interface of [Time.Zone] or [Time_ns.Zone]. For those, look at [Time_intf.Zone] *) module type S = sig (** {1 User-friendly interface} *) (** The type of a time-zone. bin_io and sexp representations of Zone.t are the name of the zone, and not the full data that is read from disk when Zone.find is called. The full Zone.t is reconstructed on the receiving/reading side by reloading the zone file from disk. Any zone name that is accepted by [find] is acceptable in the bin_io and sexp representations. *) type t [@@deriving sexp_of, compare] (** [input_tz_file ~zonename ~filename] read in [filename] and return [t] with [name t] = [zonename] *) val input_tz_file : zonename:string -> filename:string -> t (** [likely_machine_zones] is a list of zone names that will be searched first when trying to determine the machine zone of a box. Setting this to a likely set of zones for your application will speed the very first use of the local timezone. *) val likely_machine_zones : string list ref (** [of_utc_offset offset] returns a timezone with a static UTC offset (given in hours). *) val of_utc_offset : hours:int -> t val of_utc_offset_explicit_name : name:string -> hours:int -> t (** [utc] the UTC time zone. Included for convenience *) val utc : t val name : t -> string (** [original_filename t] return the filename [t] was loaded from (if any) *) val original_filename : t -> string option (** [digest t] return the MD5 digest of the file the t was created from (if any) *) val digest : t -> Md5.t option module Time_in_seconds : Time_in_seconds (** For performance testing only; [reset_transition_cache t] resets an internal cache in [t] used to speed up repeated lookups of the same clock shift transition. *) val reset_transition_cache : t -> unit (** A time zone index refers to a range of times delimited by DST transitions at one or both ends. Every time belongs to exactly one such range. The times of DST transitions themselves belong to the range for which they are the lower bound. *) module Index : sig type t [@@immediate] val next : t -> t val prev : t -> t end (** Gets the index of a time. *) val index : t -> Time_in_seconds.t -> Index.t val index_of_date_and_ofday : t -> Time_in_seconds.Date_and_ofday.t -> Index.t (** Gets the UTC offset of times in a specific range. This can raise if you use an [Index.t] that is out of bounds for this [t]. *) val index_offset_from_utc_exn : t -> Index.t -> Time_in_seconds.Span.t (** [index_abbreviation_exn t index] returns the abbreviation name (such as EDT, EST, JST) of given zone [t] for the range of [index]. This string conversion is one-way only, and cannot reliably be turned back into a [t]. This function reads and writes the zone's cached index. Raises if [index] is out of bounds for [t]. *) val index_abbreviation_exn : t -> Index.t -> string (** Accessors for the DST transitions delimiting the start and end of a range, if any. The [_exn] accessors raise if there is no such transition. These accessors are split up to increase performance and improve allocation; they are intended as a low-level back-end for commonly-used time conversion functions. See [Time.Zone] and [Time_ns.Zone] for higher-level accessors that return an optional tuple for clock shifts in either direction. *) val index_has_prev_clock_shift : t -> Index.t -> bool val index_prev_clock_shift_time_exn : t -> Index.t -> Time_in_seconds.t val index_prev_clock_shift_amount_exn : t -> Index.t -> Time_in_seconds.Span.t val index_has_next_clock_shift : t -> Index.t -> bool val index_next_clock_shift_time_exn : t -> Index.t -> Time_in_seconds.t val index_next_clock_shift_amount_exn : t -> Index.t -> Time_in_seconds.Span.t end module type S_stable = sig type t module Full_data : sig module V1 : Stable_module_types.S0_without_comparator with type t = t end end module type Zone = sig module type S = S module type S_stable = S_stable include S module Stable : S_stable with type t := t end core-0.15.0/core/strftime.js-licence.txt000066400000000000000000000021441420273305200200650ustar00rootroot00000000000000The MIT License (MIT) Copyright © 2016 Sami Samhuri, http://samhuri.net 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. core-0.15.0/core/test-am-running-inline-test/000077500000000000000000000000001420273305200207345ustar00rootroot00000000000000core-0.15.0/core/test-am-running-inline-test/bin/000077500000000000000000000000001420273305200215045ustar00rootroot00000000000000core-0.15.0/core/test-am-running-inline-test/bin/am_running_inline_test.ml000066400000000000000000000000721420273305200265670ustar00rootroot00000000000000open! Core let () = printf "%b\n" am_running_inline_test core-0.15.0/core/test-am-running-inline-test/bin/am_running_inline_test.mli000066400000000000000000000000551420273305200267410ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test-am-running-inline-test/bin/dune000066400000000000000000000001321420273305200223560ustar00rootroot00000000000000(executables (names am_running_inline_test) (libraries core) (preprocess (pps ppx_jane)))core-0.15.0/core/test-am-running-inline-test/dune000066400000000000000000000001511420273305200216070ustar00rootroot00000000000000(library (name core_test_am_running_inline_test) (libraries core core_unix) (preprocess (pps ppx_jane)))core-0.15.0/core/test-am-running-inline-test/test_am_running_inline_test.ml000066400000000000000000000002601420273305200270550ustar00rootroot00000000000000open! Core module Unix = Core_unix let%expect_test _ = Unix.system "bin/am_running_inline_test.exe" |> Unix.Exit_or_signal.or_error |> ok_exn; [%expect {| true |}] ;; core-0.15.0/core/test-am-running-inline-test/test_am_running_inline_test.mli000066400000000000000000000000551420273305200272300ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/000077500000000000000000000000001420273305200144325ustar00rootroot00000000000000core-0.15.0/core/test/bin/000077500000000000000000000000001420273305200152025ustar00rootroot00000000000000core-0.15.0/core/test/bin/avltree_test.ml000066400000000000000000000065011420273305200202370ustar00rootroot00000000000000module Avltree = Base.Avltree open OUnit open Core let test_f t s test_data f = let is_present i = assert (Avltree.mem !t ~compare i); match Avltree.find !t ~compare i with | None -> assert false | Some j -> assert (i = j) in Avltree.invariant !t ~compare; Array.iter test_data ~f:(fun i -> t := f ~set:s ~t ~present:(Set.mem !s i) ~i; Avltree.invariant !t ~compare; Set.iter !s ~f:is_present; Avltree.iter !t ~f:(fun ~key ~data -> assert (Set.mem !s key && key = data)); Avltree.fold !t ~init:() ~f:(fun ~key ~data () -> assert (Set.mem !s key && key = data))) ;; let do_add ~set ~t ~present ~i ~added = (* Set added to be the opposite of the expected value, so we can verify that it in fact does get set and it is set to the right value (as opposed to the value being correct to start with, and we made no write to it.) *) added := present; let res = Avltree.add !t ~replace:true ~compare ~added ~key:i ~data:i in if present then assert (not !added) else assert !added; set := Set.add !set i; res ;; let test_add t s test_data = let added = ref false in test_f t s test_data (fun ~set ~t ~present ~i -> do_add ~set ~t ~present ~i ~added) ;; let do_add_if_not_exists ~set ~t ~present ~i ~added = added := present; let res = Avltree.add !t ~replace:false ~compare ~added ~key:i ~data:(if present then i + 1 else i) in if present then assert (not !added) else assert !added; if not present then set := Set.add !set i; res ;; let test_add_if_not_exists t s test_data = let added = ref false in test_f t s test_data (fun ~set ~t ~present ~i -> do_add_if_not_exists ~set ~t ~present ~i ~added) ;; let do_remove ~set ~t ~present ~i ~removed = removed := not present; let res = Avltree.remove !t ~compare ~removed i in if present then assert !removed else assert (not !removed); set := Set.remove !set i; res ;; let test_remove t s test_data = let removed = ref false in test_f t s test_data (fun ~set ~t ~present ~i -> do_remove ~set ~t ~present ~i ~removed) ;; let test_add_remove t s test_data = let add = ref false in let r = ref false in test_f t s test_data (fun ~set ~t ~present ~i -> if !add then ( add := false; do_add ~set ~t ~present ~i ~added:r) else ( add := true; do_remove ~set ~t ~present ~i ~removed:r)) ;; let test name dset add_remove_dset = let t = ref Avltree.empty in let s = ref Set.Poly.empty in [ ("add_lookup_" ^ name >:: fun () -> test_add t s dset) ; ("add_if_not_exists_lookup_" ^ name >:: fun () -> test_add_if_not_exists t s dset) ; ("add_remove_lookup_" ^ name >:: fun () -> test_add_remove t s add_remove_dset) ; ("remove_lookup_" ^ name >:: fun () -> test_remove t s dset) ] ;; let test = let size = 1000 in let random_data1, random_data2 = let s = Random.State.make_self_init () in ( Array.init size ~f:(fun _ -> Random.State.int s 10000) , Array.init size ~f:(fun _ -> Random.State.int s 10000) ) in let sorted_data = Array.init size ~f:Fn.id in let reverse_sorted_data = let x = Array.copy sorted_data in Array.rev_inplace x; x in "Avltree" >::: test "random" random_data1 random_data2 @ test "sorted" sorted_data random_data2 @ test "reverse_sorted" reverse_sorted_data random_data2 ;; core-0.15.0/core/test/bin/bag_test.ml000066400000000000000000000045711420273305200173330ustar00rootroot00000000000000open OUnit open Core let test = "bag" >::: [ ("foo" >:: fun () -> ("create" @? let b = Bag.create () in Bag.invariant ignore b; assert (Bag.is_empty b); assert (0 = Bag.length b); true); ("add1" @? let b = Bag.create () in let _e1 = Bag.add b 1 in Bag.invariant ignore b; assert (1 = Bag.length b); assert (not (Bag.is_empty b)); true); ("add2" @? let b = Bag.create () in let _e1 = Bag.add b 1 in let _e2 = Bag.add b 2 in Bag.invariant ignore b; assert (2 = Bag.length b); assert (not (Bag.is_empty b)); true); ("remove" @? let b = Bag.create () in Bag.remove b (Bag.add b 1); Bag.invariant ignore b; assert (Bag.is_empty b); true); ("remove2" @? let b = Bag.create () in let e1 = Bag.add b 1 in let _e2 = Bag.add b 2 in Bag.remove b e1; Bag.invariant ignore b; assert (1 = Bag.length b); true); ("add100" @? let b = Bag.create () in let n = 20 in for i = 1 to n do let _e = Bag.add b i in Bag.invariant ignore b done; assert (Bag.length b = n); for _ = 1 to n do Bag.invariant ignore b; match Bag.remove_one b with | None -> assert false | Some _ -> () done; assert (Bag.is_empty b); Bag.invariant ignore b; true); "container" @? let b = Bag.create () in let n = 20 in for i = 1 to n do ignore (Bag.add b i : _ Bag.Elt.t) done; assert (n = Bag.fold b ~init:0 ~f:(fun n _ -> n + 1)); for i = 1 to n do assert (Bag.exists b ~f:(fun i' -> i = i')) done; Bag.iter b ~f:(fun i -> assert (1 <= i && i <= n)); assert (Bag.for_all b ~f:(fun i -> 1 <= i && i <= n)); true) ] ;; core-0.15.0/core/test/bin/blang_test.ml000066400000000000000000000117121420273305200176600ustar00rootroot00000000000000open OUnit open Core open Poly open Blang let to_string t = Sexp.to_string (Blang.sexp_of_t String.sexp_of_t t) let ( === ) b1 b2 = if b1 <> b2 then failwithf "%s <> %s" (to_string b1) (to_string b2) () let same_sexp b1 b2 = let s1 = to_string b1 and s2 = to_string b2 in if s1 <> s2 then failwithf "%s <> %s" s1 s2 () ;; let test = "blang" >::: [ "simplification" >::: [ (***) ("not1" >:: fun () -> not_ true_ === false_) ; ("not2" >:: fun () -> not_ false_ === true_) ; (***) ("and1" >:: fun () -> and_ [] === true_) ; ("and2" >:: fun () -> and_ [ true_ ] === true_) ; ("and3" >:: fun () -> and_ [ true_; base "A" ] === base "A") ; ("and4" >:: fun () -> and_ [ base "A"; true_ ] === base "A") ; ("and5" >:: fun () -> and_ [ base "A"; base "B"; true_ ] === and_ [ base "A"; base "B" ]) ; ("and6" >:: fun () -> and_ [ base "A"; true_; base "B" ] === and_ [ base "A"; base "B" ]) ; ("and7" >:: fun () -> and_ [ true_; base "A"; base "B" ] === and_ [ base "A"; base "B" ]) ; ("and8" >:: fun () -> and_ [ false_ ] === false_) ; ("and9" >:: fun () -> and_ [ false_; base "A" ] === false_) ; ("and10" >:: fun () -> and_ [ base "A"; false_ ] === false_) ; ("and11" >:: fun () -> and_ [ base "A"; base "B"; false_ ] === false_) ; ("and12" >:: fun () -> and_ [ base "A"; false_; base "B" ] === false_) ; ("and13" >:: fun () -> and_ [ false_; base "A"; base "B" ] === false_) ; (***) ("or1" >:: fun () -> or_ [] === false_) ; ("or2" >:: fun () -> or_ [ false_ ] === false_) ; ("or3" >:: fun () -> or_ [ false_; base "A" ] === base "A") ; ("or4" >:: fun () -> or_ [ base "A"; false_ ] === base "A") ; ("or5" >:: fun () -> or_ [ base "A"; base "B"; false_ ] === or_ [ base "A"; base "B" ]) ; ("or6" >:: fun () -> or_ [ base "A"; false_; base "B" ] === or_ [ base "A"; base "B" ]) ; ("or7" >:: fun () -> or_ [ false_; base "A"; base "B" ] === or_ [ base "A"; base "B" ]) ; ("or8" >:: fun () -> or_ [ true_ ] === true_) ; ("or9" >:: fun () -> or_ [ true_; base "A" ] === true_) ; ("or10" >:: fun () -> or_ [ base "A"; true_ ] === true_) ; ("or11" >:: fun () -> or_ [ base "A"; base "B"; true_ ] === true_) ; ("or12" >:: fun () -> or_ [ base "A"; true_; base "B" ] === true_) ; ("or13" >:: fun () -> or_ [ true_; base "A"; base "B" ] === true_) ; (***) ("if1" >:: fun () -> if_ true_ (base "A") (base "B") === base "A") ; ("if2" >:: fun () -> if_ false_ (base "A") (base "B") === base "B") ; ("if3" >:: fun () -> if_ (base "A") true_ (base "B") === or_ [ base "A"; base "B" ]) ; ("if4" >:: fun () -> if_ (base "A") (base "B") false_ === and_ [ base "A"; base "B" ]) ; ("if5" >:: fun () -> if_ (base "A") (base "B") true_ === or_ [ not_ (base "A"); base "B" ]) ; ("if6" >:: fun () -> if_ (base "A") false_ (base "B") === and_ [ not_ (base "A"); base "B" ]) ; (***) ("ifnot1" >:: fun () -> if_ (not_ false_) (base "A") (base "B") === base "A") ; ("ifnot2" >:: fun () -> if_ (not_ true_) (base "A") (base "B") === base "B") ] ; "flattening" >::: [ ("and" >:: fun () -> same_sexp (and_ [ base "A"; and_ [ base "B"; base "C" ] ]) (and_ [ base "A"; base "B"; base "C" ])) ; ("or" >:: fun () -> same_sexp (or_ [ base "A"; or_ [ base "B"; base "C" ] ]) (or_ [ base "A"; base "B"; base "C" ])) ] ; "substitution" >::: [ ("base" >:: fun () -> bind (base "A") ~f:(fun x -> and_ [ base x; base x ]) === and_ [ base "A"; base "A" ]) ; ("and" >:: fun () -> bind (and_ [ base "A"; base "B" ]) ~f:(fun x -> or_ [ base x; base x ]) === and_ [ or_ [ base "A"; base "A" ]; or_ [ base "B"; base "B" ] ]) ] ; ("values" >:: fun () -> let blang1 = and_ [ if_ (and_ []) (base "this") (base "that") ; or_ [ if_ (not_ (and_ [])) (base "something") (base "other") ; base "yet another thing" ] ] in let values = Blang.values blang1 in if [ "this"; "other"; "yet another thing" ] <> values then failwithf "Got: %s" (String.concat ~sep:"," values) ()) ] ;; core-0.15.0/core/test/bin/common_test.ml000066400000000000000000000036511420273305200200700ustar00rootroot00000000000000open OUnit open Core open Poly let test = "common" >::: [ ("% and /%" >:: fun () -> let gen_int_pair () = Quickcheck_deprecated.uig (), abs (Quickcheck_deprecated.uig ()) in let modulus_invariant (a, b) = let r = a % b in let q = a /% b in r >= 0 && a = (q * b) + r in Quickcheck_deprecated.laws_exn "modulus invariant" 1000 gen_int_pair modulus_invariant) ; ("memoize" >:: fun () -> let f x = x * x in let memo_f = Memo.general f in Quickcheck_deprecated.laws_exn "memoize" 1000 Quickcheck_deprecated.uig (fun i -> f i = memo_f i)) ; ("nan" >:: fun () -> "fmin1" @? Float.is_nan (Float.min 1. Float.nan); "fmin2" @? Float.is_nan (Float.min Float.nan 0.); "fmin3" @? Float.is_nan (Float.min Float.nan Float.nan); "fmax1" @? Float.is_nan (Float.max 1. Float.nan); "fmax2" @? Float.is_nan (Float.max Float.nan 0.); "fmax3" @? Float.is_nan (Float.max Float.nan Float.nan); "fmin_inan1" @? (1. = Float.min_inan 1. Float.nan); "fmin_inan2" @? (0. = Float.min_inan Float.nan 0.); "fmin_inan3" @? Float.is_nan (Float.min_inan Float.nan Float.nan); "fmax_inan1" @? (1. = Float.max_inan 1. Float.nan); "fmax_inan2" @? (0. = Float.max_inan Float.nan 0.); "fmax_inan3" @? Float.is_nan (Float.max_inan Float.nan Float.nan)) ; ("round" >:: fun () -> "zero" @? (Float.iround_exn ~dir:`Nearest 0.2 = 0); "negative zero" @? (Float.iround_exn ~dir:`Nearest (-0.2) = 0); "positive" @? (Float.iround_exn ~dir:`Nearest 3.4 = 3); "negative" @? (Float.iround_exn ~dir:`Nearest (-3.4) = -3)) ] ;; core-0.15.0/core/test/bin/comparable_test.ml000066400000000000000000000116441420273305200207060ustar00rootroot00000000000000open OUnit open Core open struct module Time = Time_unix end module F (M : sig type t include Comparable.S with type t := t val one : t val two : t val three : t end) : sig val test : OUnit.test end = struct open M let equal = M.( = ) let ( = ) = Bool.equal let test = let foreach f = f one; f two; f three in "comparable" >:: fun () -> foreach (fun a -> foreach (fun b -> assert (equal (min a b) (min b a)); assert (equal (max a b) (max b a)); assert (a < b = Int.( < ) (compare a b) 0); assert (equal a b = Int.equal (compare a b) 0); assert (a > b = Int.( > ) (compare a b) 0); assert (a < b = Int.( < ) (ascending a b) 0); assert (equal a b = Int.equal (ascending a b) 0); assert (a > b = Int.( > ) (ascending a b) 0); assert (a > b = Int.( < ) (descending a b) 0); assert (equal a b = Int.( = ) (descending a b) 0); assert (a < b = Int.( > ) (descending a b) 0); assert (a > b = (b < a)); assert (a >= b = (b <= a)); assert (a < b = not (a >= b)); assert (a > b = not (a <= b)); assert (equal a b = not (a <> b)); assert (a >= b = (a > b || equal a b)); assert (a <= b = (a < b || equal a b)))); assert (equal one one); assert (equal two two); assert (equal three three); assert (not (one < one)); assert (one < two); assert (one < three); assert (not (two < one)); assert (not (two < two)); assert (two < three); assert (not (three < one)); assert (not (three < two)); assert (not (three < three)); assert (equal (max one one) one); assert (equal (max one two) two); assert (equal (max one three) three); assert (equal (max two two) two); assert (equal (max two three) three); assert (equal (max three three) three); assert (equal (min one one) one); assert (equal (min one two) one); assert (equal (min one three) one); assert (equal (min two two) two); assert (equal (min two three) two); assert (equal (min three three) three) ;; end module Float = F (struct include Float let one = 1.0 let two = 2.0 let three = 3.0 end) module String = F (struct include String let one = "a" let two = "b" let three = "c" end) module Span = F (struct include Time.Span let one = of_sec (-1.0) let two = zero let three = of_sec 1.0 end) module Ofday = F (struct include Time.Ofday let one = of_span_since_start_of_day_exn (Time.Span.of_sec 1.) let two = of_span_since_start_of_day_exn (Time.Span.of_sec 2.) let three = of_span_since_start_of_day_exn (Time.Span.of_sec 3.) end) module Date = F (struct include Date let zone = force Time.Zone.local let one = Time.now () let two = Time.add one (Time.Span.of_hr 30.0) let three = Time.add two (Time.Span.of_hr 30.0) let one = Time.to_date one ~zone let two = Time.to_date two ~zone let three = Time.to_date three ~zone end) module Time = F (struct include Time let one = Time.now () let two = Time.add one (sec 1.) let three = Time.add two (sec 1.) end) module Int32 = F (struct include Int32 let one = Int32.one let two = 2l let three = 3l end) module Int64 = F (struct include Int64 let one = Int64.one let two = 2L let three = 3L end) module Nativeint = F (struct include Nativeint let one = of_int 1 let two = of_int 2 let three = of_int 3 end) module Int' = F (struct type t = Int.t include Comparable.Make (Int) let one = 1 let two = 2 let three = 3 end) module Int'' = F (struct type t = int include Comparable.Inherit (Int) (struct include Int let component x = x end) let one = 1 let two = 2 let three = 3 end) module Int = F (struct include Int let one = 1 let two = 2 let three = 3 end) let lexicographic_test = "lexicographic" >:: fun () -> "1 0" @? (Comparable.lexicographic [ compare ] 1 1 = 0); "1 -1" @? (Comparable.lexicographic [ compare ] 1 2 = -1); "1 1" @? (Comparable.lexicographic [ compare ] 2 1 = 1); let cmp = Array.to_list (Array.init 3 ~f:(fun i a b -> compare a.(i) b.(i))) in "3 0" @? (Comparable.lexicographic cmp [| 1; 2; 3; 4 |] [| 1; 2; 3; 9 |] = 0); "3 -1" @? (Comparable.lexicographic cmp [| 1; 2; 3; 4 |] [| 1; 2; 4; 9 |] = -1); "3 1" @? (Comparable.lexicographic cmp [| 1; 2; 3; 4 |] [| 1; 1; 4; 9 |] = 1) ;; let test = TestList [ Float.test ; String.test ; Float.test ; Span.test ; Ofday.test ; Date.test ; Time.test ; Int.test ; Int32.test ; Int64.test ; Nativeint.test ; Int'.test ; Int''.test ; lexicographic_test ] ;; core-0.15.0/core/test/bin/container_test.ml000066400000000000000000000017261420273305200205630ustar00rootroot00000000000000open Core open Poly module Test_S1 (M : sig include Container.S1 val of_list : 'a list -> 'a t end) : sig val test : unit -> unit end = struct let lists = List.init 10 ~f:(fun i -> List.init i ~f:Fn.id) let test () = List.iter lists ~f:(fun l -> let m = M.of_list l in assert (M.length m = List.length l); assert (M.is_empty m = List.is_empty l); let is_l_unsorted l' = l = List.sort l' ~compare:Int.compare in assert (is_l_unsorted (M.fold m ~init:[] ~f:(fun ac x -> x :: ac))); assert (is_l_unsorted (M.to_list m)); let r = ref [] in M.iter m ~f:(fun x -> r := x :: !r); assert (is_l_unsorted !r); assert (is_l_unsorted (Array.to_list (M.to_array m))); List.iter l ~f:(fun x -> assert (M.exists m ~f:(fun x' -> x = x'))); assert (M.for_all m ~f:(fun x -> List.exists l ~f:(fun x' -> x = x'))); List.iter l ~f:(fun x -> assert (Some x = M.find m ~f:(fun x' -> x = x')))) ;; end core-0.15.0/core/test/bin/core_array_test.ml000066400000000000000000000123301420273305200207200ustar00rootroot00000000000000open OUnit open Core open Poly open Array let ar1 = [| 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 |] let ( =|= ) list array = list = Array.to_list array let test = "core_array" >::: [ ("slice" >:: fun () -> "all" @? (slice ar1 0 0 = ar1); "ordinary" @? (slice ar1 1 3 = [| 2; 3 |]); "neg1" @? (slice ar1 0 (-1) = [| 1; 2; 3; 4; 5; 6; 7; 8; 9 |]); "neg2" @? (slice ar1 (-1) 0 = [| 10 |]); "neg3" @? (slice ar1 (-5) (-4) = [| 6 |])) ; ("nget" >:: fun () -> "neg" @? (nget ar1 (-3) = 8); "pos" @? (nget ar1 3 = ar1.(3)); "invalid" @? try ignore (nget ar1 (-100) : int); false with | Invalid_argument _ -> true | _ -> false) ; ("filter_opt" >:: fun () -> "none" @? (filter_opt [| None; None; None |] = [||]); "single" @? (filter_opt [| None; Some 3; None |] = [| 3 |]); "singlef" @? (filter_opt [| None; Some 3.; None |] = [| 3. |]); "double" @? (filter_opt [| None; Some 3; Some 4 |] = [| 3; 4 |])) ; ("swap" >:: fun () -> let array = [| 0; 1; 2; 3 |] in "same" @? (swap array 0 0; array = [| 0; 1; 2; 3 |]); "different" @? (swap array 0 3; array = [| 3; 1; 2; 0 |])) ; ("exists" >:: fun () -> let list = List.init ~f:(fun _ -> Random.int 1000) 1000 in let array = Array.of_list list in "list1" @? (List.exists ~f:(( = ) 1) list = Array.exists ~f:(( = ) 1) array); "list2" @? (List.exists ~f:(( = ) 2) list = Array.exists ~f:(( = ) 2) array); "list3" @? (List.exists ~f:(( = ) 3) list = Array.exists ~f:(( = ) 3) array); "list4" @? (List.exists ~f:(( = ) 4) list = Array.exists ~f:(( = ) 4) array)) ; ("for_all" >:: fun () -> let list = Quickcheck_deprecated.lg (fun () -> Random.int 1000) ~size_gen:(fun _ -> 1000) () in let array = Array.of_list list in "list1" @? (List.for_all ~f:(( <> ) 1) list = Array.for_all ~f:(( <> ) 1) array); "list2" @? (List.for_all ~f:(( <> ) 2) list = Array.for_all ~f:(( <> ) 2) array); "list3" @? (List.for_all ~f:(( <> ) 3) list = Array.for_all ~f:(( <> ) 3) array); "list4" @? (List.for_all ~f:(( <> ) 4) list = Array.for_all ~f:(( <> ) 4) array) ) ; ("mem" >:: fun () -> let list = Quickcheck_deprecated.lg (fun () -> Random.int 1000) ~size_gen:(fun _ -> 1000) () in let array = Array.of_list list in let equal = Core.Int.equal in "list1" @? (List.mem list 1 ~equal = Array.mem array 1 ~equal); "list2" @? (List.mem list 2 ~equal = Array.mem array 2 ~equal); "list3" @? (List.mem list 3 ~equal = Array.mem array 3 ~equal); "list4" @? (List.mem list 4 ~equal = Array.mem array 4 ~equal)) ; ("rev" >:: fun () -> let ordered_list = List.init 100 ~f:(fun i -> i) in let empty_list = [] in let one_list = [ 0 ] in ("ordered" @? let ordered_array = Array.of_list ordered_list in Array.rev_inplace ordered_array; List.rev ordered_list =|= ordered_array); ("empty" @? let empty_array = Array.of_list empty_list in Array.rev_inplace empty_array; List.rev empty_list =|= empty_array); "one" @? let one_array = Array.of_list one_list in Array.rev_inplace one_array; List.rev one_list =|= one_array) ; ("map_inplace" >:: fun () -> let random_list = Quickcheck_deprecated.lg (fun () -> Random.int 1000) ~size_gen:(fun _ -> 1000) () in let empty_list = [] in let one_list = [ 0 ] in let f i = i * i in ("random" @? let random_array = Array.of_list random_list in Array.map_inplace ~f random_array; List.map ~f random_list =|= random_array); ("empty" @? let empty_array = Array.of_list empty_list in Array.map_inplace ~f empty_array; List.map ~f empty_list =|= empty_array); "one" @? let one_array = Array.of_list one_list in Array.map_inplace ~f one_array; List.map ~f one_list =|= one_array) ; ("cartesian_product" >:: fun () -> "empty1" @? is_empty (cartesian_product [||] [||]); "empty2" @? is_empty (cartesian_product [||] [| 13 |]); "empty3" @? is_empty (cartesian_product [| 13 |] [||]); "simple" @? (cartesian_product [| 1; 2; 3 |] [| "a"; "b" |] = [| 1, "a"; 1, "b"; 2, "a"; 2, "b"; 3, "a"; 3, "b" |])) ] ;; core-0.15.0/core/test/bin/core_char_test.ml000066400000000000000000000005171420273305200205230ustar00rootroot00000000000000open Core open Poly open OUnit let of_string_test () = Char.of_string "c" = 'c' && Result.is_error (Result.try_with (fun () -> Char.of_string "")) && Result.is_error (Result.try_with (fun () -> Char.of_string "too long")) ;; let test = "core_char" >::: [ ("to_string_hum" >:: fun () -> "of_string" @? of_string_test ()) ] ;; core-0.15.0/core/test/bin/core_filename_test.ml000066400000000000000000000011661420273305200213670ustar00rootroot00000000000000open OUnit open Core open Poly let concat_test p1 p2 res = sprintf "%s ^/ %s" p1 p2 @? if p1 ^/ p2 = res then true else ( eprintf "%s ^/ %s = %s (expected %s)" p1 p2 (p1 ^/ p2) res; false) ;; let test = "core_filename" >::: [ ("concat" >:: fun () -> List.iter ~f:(fun (p1, p2, expected) -> concat_test p1 p2 expected) [ "a/", "/b", "a/b" ; "a", "./b", "a/b" ; "a", ".", "a/." ; "a", "/", "a/" ; "a/.", "./", "a/" ; "a///././/./.", ".///././/././/b", "a/b" ]) ] ;; core-0.15.0/core/test/bin/core_int_test.ml000066400000000000000000000014641420273305200204020ustar00rootroot00000000000000open Core open OUnit let esc_test i = int_of_string (Int.to_string_hum i) = i let bound = 2 lsl 10 let rand state = let rec aux acc cnt = if cnt = 0 then acc else ( let bit = if Random.State.bool state then 1 else 0 in aux ((2 * acc) + bit) (cnt - 1)) in let aval = aux 1 (Random.State.int state (Sys.word_size_in_bits - 3)) in if Random.State.bool state then -aval else aval ;; (* Random with a distribution favouring small ones*) let test = "core_int" >::: [ ("to_string_hum" >:: fun () -> let state = Random.State.make [| 7; 4; 2 |] in "random" @? (List.init ~f:(fun _ -> rand state) 10_000 |> List.for_all ~f:esc_test); "max_int" @? esc_test Int.max_value; "min_int" @? esc_test Int.min_value) ] ;; core-0.15.0/core/test/bin/core_map_test.ml000066400000000000000000000126641420273305200203710ustar00rootroot00000000000000open OUnit open Core open Poly module StringMap = Map.Make (String) let m1 = StringMap.of_alist_exn [ "a", 1; "b", 2; "c", 3; "d", 4 ] let m2 = StringMap.of_alist_exn [ "a", 1; "c", -3; "d", 4; "e", 5 ] let test = "core_fmap" >::: [ ("merge1" >:: fun () -> let f ~key:_ = function | `Left _ | `Right _ -> None | `Both (x, y) -> Some (x + y) in "eq1" @? StringMap.equal ( = ) (StringMap.merge ~f m1 m2) (StringMap.of_alist_exn [ "a", 2; "c", 0; "d", 8 ]); "eq2" @? StringMap.equal ( = ) (StringMap.merge ~f m2 m1) (StringMap.of_alist_exn [ "a", 2; "c", 0; "d", 8 ])) ; ("merge2" >:: fun () -> let f ~key:_ = function | `Left x -> Some x | `Right _ -> None | `Both (x, y) -> Some (x + y) in "eq" @? StringMap.equal ( = ) (StringMap.merge ~f m1 m2) (StringMap.of_alist_exn [ "a", 2; "b", 2; "c", 0; "d", 8 ])) ; ("merge3" >:: fun () -> let f ~key:_ = function | `Left x | `Right x -> Some x | `Both (x, y) -> Some (x + y) in "eq1" @? StringMap.equal ( = ) (StringMap.merge ~f m1 m2) (StringMap.of_alist_exn [ "a", 2; "b", 2; "c", 0; "d", 8; "e", 5 ]); "eq2" @? StringMap.equal ( = ) (StringMap.merge ~f m2 m1) (StringMap.of_alist_exn [ "a", 2; "b", 2; "c", 0; "d", 8; "e", 5 ])) ; ("merge3" >:: fun () -> let f ~key:_ = function | `Left x | `Right x -> Some x | `Both (x, y) -> Some (x + y) in "eq1" @? StringMap.equal ( = ) (StringMap.merge ~f m1 StringMap.empty) m1; "eq2" @? StringMap.equal ( = ) (StringMap.merge ~f StringMap.empty m1) m1) ; ("sexp" >:: fun () -> let s = "((a 1) (b 2) (c 3) (d 4))" in let m1' = StringMap.t_of_sexp int_of_sexp (Sexp.of_string s) in "of_sexp1" @? StringMap.equal ( = ) m1' m1; let s_dup = "((a 1) (b 2) (a 3) (d 4))" in let s_dup = Sexp.of_string s_dup in try ignore (StringMap.t_of_sexp int_of_sexp s_dup : _ StringMap.t); assert false with | _ -> ()) ; ("bin_io" >:: fun () -> let max_n = 20 in let bstr = Bigstring.create ((2 * max_n) + 1) in for n = 0 to max_n do let m1 = Int.Map.of_alist_exn (List.init n ~f:(fun x -> x, succ x)) in let pos = Int.Map.bin_write_t Int.bin_write_t bstr ~pos:0 m1 in "pos" @? (pos = (2 * n) + 1); let pos_ref = ref 0 in let m2 = Int.Map.bin_read_t Int.bin_read_t bstr ~pos_ref in "pos_ref" @? (!pos_ref = (2 * n) + 1); "equal" @? Int.Map.equal Int.equal m1 m2; if n >= 2 then ( bstr.{1} <- 'x'; bstr.{3} <- 'x'; pos_ref := 0; let dup_check = try ignore (Int.Map.bin_read_t Int.bin_read_t bstr ~pos_ref : Int.t Int.Map.t); false with | Failure _ -> !pos_ref = (2 * n) + 1 in "dup_check" @? dup_check) done) ; ("of_alist" >:: fun () -> let a = [ "a", 1; "b", 2; "c", 3; "d", 4 ] in let m = match StringMap.of_alist a with | `Ok x -> x | `Duplicate_key _ -> failwith "argh" in "1" @? (StringMap.find_exn m "a" = 1 && StringMap.find_exn m "d" = 4); let a_dup = [ "a", 1; "b", 2; "c", 3; "b", 4; "e", 5 ] in ("2" @? match StringMap.of_alist a_dup with | `Ok _ -> false | `Duplicate_key x -> x = "b"); "3" @? (List.sort ~compare:Poly.ascending (StringMap.to_alist (StringMap.of_alist_exn a)) = List.sort ~compare:Poly.ascending a); try ignore (StringMap.of_alist_exn a_dup : _ StringMap.t); assert false with | _ -> ()) ; ("for_all/exists" >:: fun () -> let m = StringMap.of_alist_exn [ "a", 1; "b", 2; "c", 3; "d", 4 ] in "1" @? StringMap.for_all ~f:(fun x -> x > 0) m; "2" @? not (StringMap.for_all ~f:(fun x -> x % 2 = 0) m); "3" @? StringMap.exists ~f:(fun x -> x % 2 = 0) m; "4" @? not (StringMap.exists ~f:(fun x -> x < 0) m); ("short circuit forall" @? let sum = ref 0 in ignore (StringMap.for_all m ~f:(fun x -> sum := !sum + x; x <> 1) : bool); !sum = 1); "short circuit exists" @? let sum = ref 0 in ignore (StringMap.exists m ~f:(fun x -> sum := !sum + x; x = 1) : bool); !sum = 1) ] ;; core-0.15.0/core/test/bin/core_queue_test.ml000066400000000000000000000045121420273305200207310ustar00rootroot00000000000000open OUnit open Core open Poly open Queue let test = "queue" >::: [ ("create" >:: fun () -> let t = create () in assert (is_empty t)) ; ("container" >:: fun () -> let module T = Container_test.Test_S1 (Queue) in T.test ()) ; ("enqueue" >:: fun () -> let t = create () in enqueue t 1; enqueue t 2; enqueue t 3; assert (to_list t = [ 1; 2; 3 ]); assert (peek t = Some 1); assert (dequeue t = Some 1); assert (to_list t = [ 2; 3 ]); assert (peek t = Some 2); assert (dequeue_exn t = 2); assert (to_list t = [ 3 ]); assert (peek_exn t = 3); assert (dequeue t = Some 3); assert (to_list t = []); assert (peek t = None); assert (dequeue t = None)) ; ("clear" >:: fun () -> for i = 0 to 5 do let t = of_list (List.init i ~f:Fn.id) in clear t; assert (is_empty t) done) ; ("copy" >:: fun () -> let t = of_list [ 1; 2; 3 ] in let t' = copy t in ignore (dequeue t : _ option); assert (to_list t = [ 2; 3 ]); assert (to_list t' = [ 1; 2; 3 ]); clear t'; assert (to_list t = [ 2; 3 ]); assert (to_list t' = [])) ; ("blit_transfer" >:: fun () -> for i1 = 0 to 3 do let l1 = List.init i1 ~f:Fn.id in for i2 = 0 to 3 do let l2 = List.init i2 ~f:Fn.id in let t1 = of_list l1 in let t2 = of_list l2 in blit_transfer ~src:t1 ~dst:t2 (); assert (is_empty t1); assert (to_list t2 = l2 @ l1) done done) ; ("filter_inplace" >:: fun () -> let t = of_list [ 1; 2; 3; 4; 5; 6; 7 ] in filter_inplace t ~f:(fun n -> n mod 2 = 0); assert (to_list t = [ 2; 4; 6 ]); assert (for_all t ~f:(fun n -> n mod 2 = 0)); assert (exists t ~f:(fun n -> n = 4 || n = 6)); filter_inplace t ~f:(fun n -> n mod 2 <> 0); assert (to_list t = [])) ] ;; core-0.15.0/core/test/bin/core_set_test.ml000066400000000000000000000043771420273305200204110ustar00rootroot00000000000000open OUnit open Core module String_set = Set.Make (String) let s1 = String_set.of_list [ "a"; "b"; "c"; "d" ] (*let m2 = Map.of_alist ["a",1; "c",-3; "d",4; "e",5]*) type int_set = int Set.Poly.t [@@deriving bin_io] module String_set_comp = struct include Int.Replace_polymorphic_compare type string_set_comp = Int.t Set.Poly.t [@@deriving compare] let test () = let compare = compare_string_set_comp in assert (compare (Set.Poly.of_list []) (Set.Poly.of_list []) = 0); assert (compare (Set.Poly.of_list [ 0 ]) (Set.Poly.of_list []) <> 0); assert (compare (Set.Poly.of_list [ 3; 2; 1 ]) (Set.Poly.of_list [ 1; 2; 3 ]) = 0); assert ( compare (Set.Poly.of_list [ 0; 1; 2; 3 ]) (Set.Poly.of_list [ 1; 1; 2; 3 ]) <> 0) ;; end let test = "core_fset" >::: [ ("sexp" >:: fun () -> let s = "(a b c d)" in let s1' = String_set.t_of_sexp (Sexp.of_string s) in "of_sexp1" @? String_set.equal s1' s1; let s_dup = "(a b a d)" in let s_dup = Sexp.of_string s_dup in assert_raises (Sexplib.Conv.Of_sexp_error (Failure "Set.t_of_sexp: duplicate element in set", sexp_of_string "a")) (fun () -> String_set.t_of_sexp s_dup)) ; ("bin_io" >:: fun () -> let max_n = 20 in let bstr = Bigstring.create (max_n + 1) in for n = 0 to max_n do let s1 = Set.Poly.of_array (Array.init n ~f:succ) in let pos = bin_write_int_set bstr ~pos:0 s1 in "pos" @? (pos = n + 1); let pos_ref = ref 0 in let s2 = bin_read_int_set bstr ~pos_ref in "pos_ref" @? (!pos_ref = n + 1); "equal" @? Set.equal s1 s2; if n >= 2 then ( bstr.{1} <- 'x'; bstr.{2} <- 'x'; pos_ref := 0; let dup_check = try ignore (bin_read_int_set bstr ~pos_ref : Int.t Set.Poly.t); false with | Failure _ -> n + 1 = !pos_ref in "dup_check" @? dup_check) done) ; "with_compare" >:: String_set_comp.test ] ;; core-0.15.0/core/test/bin/core_string_test.ml000066400000000000000000000245771420273305200211300ustar00rootroot00000000000000open Core open Poly open OUnit module S = String let str1 = "1234567890" let test = "core_string" >::: [ ("slice" >:: fun () -> "all" @? (S.slice str1 0 0 = str1); "ordinary" @? (S.slice str1 1 3 = "23"); "neg1" @? (S.slice str1 0 (-1) = "123456789"); "neg2" @? (S.slice str1 (-1) 0 = "0"); "neg3" @? (S.slice str1 (-5) (-4) = "6")) ; ("nget" >:: fun () -> "neg" @? (S.nget str1 (-3) = '8'); "pos" @? (S.nget str1 3 = str1.[3]); "invalid" @? try ignore (S.nget str1 (-100) : char); false with | Invalid_argument _ -> true | _ -> false) ; ("lsplit2_exn" >:: fun () -> ("none" @? try ignore (S.lsplit2_exn str1 ~on:' ' : string * string); false with | Not_found_s _ | Caml.Not_found -> true | _ -> false); "some1" @? (S.lsplit2_exn str1 ~on:'5' = ("1234", "67890")); "some2" @? (S.lsplit2_exn "123.456.789" ~on:'.' = ("123", "456.789"))) ; ("lsplit2" >:: fun () -> "none" @? (S.lsplit2 str1 ~on:' ' = None); "some1" @? (S.lsplit2 str1 ~on:'5' = Some ("1234", "67890")); "some2" @? (S.lsplit2 "123.456.789" ~on:'.' = Some ("123", "456.789"))) ; ("rsplit2_exn" >:: fun () -> ("none" @? try ignore (S.rsplit2_exn str1 ~on:' ' : string * string); false with | Not_found_s _ | Caml.Not_found -> true | _ -> false); "some1" @? (S.rsplit2_exn str1 ~on:'5' = ("1234", "67890")); "some2" @? (S.rsplit2_exn "123.456.789" ~on:'.' = ("123.456", "789"))) ; ("rsplit2" >:: fun () -> "none" @? (S.rsplit2 str1 ~on:' ' = None); "some1" @? (S.rsplit2 str1 ~on:'5' = Some ("1234", "67890")); "some2" @? (S.rsplit2 "123.456.789" ~on:'.' = Some ("123.456", "789"))) ; ("strip" >:: fun () -> "both ends" @? (S.strip " 123 " = "123"); "all white" @? (S.strip "\n\t \n" = ""); "no white" @? (S.strip "as \t\ndf" = "as \t\ndf"); "just left" @? (S.strip " a" = "a"); "just right" @? (S.strip "a " = "a")) ; ("lstrip" >:: fun () -> "left" @? (S.lstrip " \t\r\n123 \t\n" = "123 \t\n"); "all white" @? (S.lstrip " \t \n\n\r " = ""); "no white on the left" @? (S.lstrip "foo Bar \n " = "foo Bar \n ")) ; ("rstrip" >:: fun () -> "right" @? (S.rstrip " \t\r\n123 \t\n\r" = " \t\r\n123"); "all white" @? (S.rstrip " \t \n\n\r " = ""); "no white on the right" @? (S.rstrip " \n foo Bar" = " \n foo Bar")) ; ("map" >:: fun () -> "empty" @? (S.map ~f:(fun x -> x) "" = ""); "1" @? (S.map ~f:(function | 'a' -> 'b' | 'b' -> 'a' | x -> x) "faboo" = "fbaoo")) ; ("split" >:: fun () -> "empty" @? (S.split "" ~on:'c' = [ "" ]); "1" @? (S.split "c" ~on:'c' = [ ""; "" ]); "end" @? (S.split "fooc" ~on:'c' = [ "foo"; "" ]); "begin" @? (S.split "cfoo" ~on:'c' = [ ""; "foo" ]); "beginend" @? (S.split "cfooc" ~on:'c' = [ ""; "foo"; "" ]); "consecutive_delims" @? (S.split "bocci ball" ~on:'c' = [ "bo"; ""; "i ball" ])) ; ("split_on_chars" >:: fun () -> "empty" @? (S.split_on_chars "" ~on:[ 'c' ] = [ "" ]); "1" @? (S.split_on_chars "c" ~on:[ 'c' ] = [ ""; "" ]); "1-grouped" @? (S.split_on_chars "chr" ~on:[ 'h'; 'c'; 'r' ] = [ ""; ""; ""; "" ]); "end" @? (S.split_on_chars "fooc" ~on:[ 'c' ] = [ "foo"; "" ]); "end-grouped" @? (S.split_on_chars "fooc" ~on:[ 'c'; 'o' ] = [ "f"; ""; ""; "" ]); "begin" @? (S.split_on_chars "cfoo" ~on:[ 'c' ] = [ ""; "foo" ]); "begin-grouped" @? (S.split_on_chars "cfoo" ~on:[ 'c'; 'f' ] = [ ""; ""; "oo" ]); "consecutive_delims" @? (S.split_on_chars "bocci ball" ~on:[ 'c' ] = [ "bo"; ""; "i ball" ]); "consecutive_delims-grouped" @? (S.split_on_chars "bocci ball" ~on:[ 'c'; ' '; 'i' ] = [ "bo"; ""; ""; ""; "ball" ])) ; ("fold" >:: fun () -> let to_list s = S.fold ~f:(fun acc c -> c :: acc) ~init:[] s in "empty" @? (to_list "" = []); "singleton" @? (to_list "H" = [ 'H' ]); "simple" @? (to_list "Hello" = [ 'o'; 'l'; 'l'; 'e'; 'H' ])) ; ("is_suffix" >:: fun () -> "empty" @? (S.is_suffix "" ~suffix:"a" = false); "empty_empty_suffix" @? (S.is_suffix "" ~suffix:"" = true); "simple_empty_suffix" @? (S.is_suffix "Foo" ~suffix:"" = true); "singleton" @? (S.is_suffix "H" ~suffix:"H" = true); "simple" @? (S.is_suffix "Hello" ~suffix:"lo" = true); "simplefalse" @? (S.is_suffix "HelloFoo" ~suffix:"lo" = false)) ; ("is_prefix" >:: fun () -> "empty" @? (S.is_prefix "" ~prefix:"a" = false); "empty_empty_prefix" @? (S.is_prefix "" ~prefix:"" = true); "simple_empty_prefix" @? (S.is_prefix "Foo" ~prefix:"" = true); "singleton" @? (S.is_prefix "H" ~prefix:"H" = true); "simple" @? (S.is_prefix "Hello" ~prefix:"He" = true); "simplefalse" @? (S.is_prefix "HelloFoo" ~prefix:"lo" = false)) ; ("concat_array" >:: fun () -> "empty" @? (S.concat_array ~sep:":" [||] = ""); "empty singleton" @? (S.concat_array ~sep:":" [| "" |] = ""); "singleton" @? (S.concat_array ~sep:":" [| "Hello" |] = "Hello"); "Words" @? (S.concat_array ~sep:" " [| "Hello"; "World"; "!" |] = "Hello World !") ) ; ("suffix" >:: fun () -> let base = "0123456789" in let test len res = sprintf "%d" len @? (S.suffix base len = res) in test 0 ""; test 1 "9"; test 2 "89"; test 10 base; test 20 base; assert_raises ~msg:"-1" (Invalid_argument "suffix expecting nonnegative argument") (fun () -> test (-1) "")) ; ("prefix" >:: fun () -> let base = "0123456789" in let test len res = sprintf "%d" len @? (S.prefix base len = res) in test 0 ""; test 1 "0"; test 2 "01"; test 10 base; test 20 base; assert_raises ~msg:"-1" (Invalid_argument "prefix expecting nonnegative argument") (fun () -> test (-1) "")) ; ("drop_suffix" >:: fun () -> let base = "0123456789" in let test len res = sprintf "%d" len @? (S.drop_suffix base len = res) in test 0 base; test 1 "012345678"; test 2 "01234567"; test 10 ""; test 20 ""; assert_raises ~msg:"-1" (Invalid_argument "drop_suffix expecting nonnegative argument") (fun () -> test (-1) "")) ; ("drop_prefix" >:: fun () -> let base = "0123456789" in let test len res = sprintf "%d" len @? (S.drop_prefix base len = res) in test 0 base; test 1 "123456789"; test 2 "23456789"; test 10 ""; test 20 ""; assert_raises ~msg:"-1" (Invalid_argument "drop_prefix expecting nonnegative argument") (fun () -> test (-1) "")) ; ("chop_suffix_exn" >:: fun () -> "simple" @? (S.chop_suffix_exn str1 ~suffix:"7890" = "123456"); "end" @? (S.chop_suffix_exn str1 ~suffix:"" = "1234567890"); assert_raises ~msg:"not a suffix" (Invalid_argument "String.chop_suffix_exn \"1234567890\" \"abc\"") (fun () -> S.chop_suffix_exn str1 ~suffix:"abc")) ; ("chop_prefix_exn" >:: fun () -> "simple" @? (S.chop_prefix_exn str1 ~prefix:"123" = "4567890"); "end" @? (S.chop_prefix_exn str1 ~prefix:"" = "1234567890"); assert_raises ~msg:"not a prefix" (Invalid_argument "String.chop_prefix_exn \"1234567890\" \"abc\"") (fun () -> S.chop_prefix_exn str1 ~prefix:"abc")) ; ("chop_suffix" >:: fun () -> "simple" @? (S.chop_suffix str1 ~suffix:"7890" = Some "123456"); "end" @? (S.chop_suffix str1 ~suffix:"" = Some "1234567890"); "not a suffix" @? (S.chop_suffix str1 ~suffix:"abc" = None)) ; ("chop_prefix" >:: fun () -> "simple" @? (S.chop_prefix str1 ~prefix:"123" = Some "4567890"); "end" @? (S.chop_prefix str1 ~prefix:"" = Some "1234567890"); "not a prefix" @? (S.chop_prefix str1 ~prefix:"abc" = None)) ; ("to_list_and_to_list_rev" >:: fun () -> let seaweed = "bladderwrack" in assert ( S.to_list seaweed = [ 'b'; 'l'; 'a'; 'd'; 'd'; 'e'; 'r'; 'w'; 'r'; 'a'; 'c'; 'k' ]); assert ( S.to_list_rev seaweed = [ 'k'; 'c'; 'a'; 'r'; 'w'; 'r'; 'e'; 'd'; 'd'; 'a'; 'l'; 'b' ]); let empty = "" in assert (S.to_list empty = []); assert (S.to_list_rev empty = [])) ; "mem" >::: [ ("default" >:: fun () -> let test t c b = sprintf "%c in %s = %b" c t b @? (S.mem t c = b) in (let t = "abc" in test t 'a' true; test t 'b' true; test t 'c' true; test t 'x' false); (let t = "ab" in test t 'a' true; test t 'b' true; test t 'x' false); (let t = "a" in test t 'a' true; test t 'x' false); let t = "" in test t 'x' false) ] ] ;; core-0.15.0/core/test/bin/doubly_linked_test.ml000066400000000000000000001131241420273305200214210ustar00rootroot00000000000000open OUnit open Core open Poly module type S = sig val name : string module Elt : sig type 'a t val value : 'a t -> 'a val equal : 'a t -> 'a t -> bool val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t end type 'a t include Container.S1 with type 'a t := 'a t include Invariant.S1 with type 'a t := 'a t include Sexpable.S1 with type 'a t := 'a t val create : unit -> 'a t val of_list : 'a list -> 'a t val equal : 'a t -> 'a t -> bool val is_first : 'a t -> 'a Elt.t -> bool val is_last : 'a t -> 'a Elt.t -> bool val first_elt : 'a t -> 'a Elt.t option val last_elt : 'a t -> 'a Elt.t option val first : 'a t -> 'a option val last : 'a t -> 'a option val next : 'a t -> 'a Elt.t -> 'a Elt.t option val prev : 'a t -> 'a Elt.t -> 'a Elt.t option val insert_before : 'a t -> 'a Elt.t -> 'a -> 'a Elt.t val insert_after : 'a t -> 'a Elt.t -> 'a -> 'a Elt.t val insert_first : 'a t -> 'a -> 'a Elt.t val insert_last : 'a t -> 'a -> 'a Elt.t val remove : 'a t -> 'a Elt.t -> unit val remove_first : 'a t -> 'a option val remove_last : 'a t -> 'a option val find_elt : 'a t -> f:('a -> bool) -> 'a Elt.t option val clear : 'a t -> unit val copy : 'a t -> 'a t val transfer : src:'a t -> dst:'a t -> unit val filter_inplace : 'a t -> f:('a -> bool) -> unit end module Hero : S = struct let name = "hero" include Doubly_linked end module Foil : S = struct let name = "foil" type 'a t = { mutable elts : 'a elt list ; mutable num_readers : int } and 'a elt = { value : 'a ; mutable root : 'a t } module Elt = struct type 'a t = 'a elt let equal (t1 : _ t) t2 = phys_equal t1 t2 let value t = t.value let sexp_of_t sexp_of_a t = sexp_of_a t.value end let to_list t = List.map ~f:Elt.value t.elts let of_list xs = let t = { elts = []; num_readers = 0 } in t.elts <- List.map xs ~f:(fun x -> { value = x; root = t }); t ;; let length t = List.length (to_list t) let is_empty t = List.is_empty (to_list t) let to_array t = List.to_array (to_list t) let read_wrap t f = t.num_readers <- t.num_readers + 1; Exn.protect ~f ~finally:(fun () -> t.num_readers <- t.num_readers - 1) ;; let for_all t ~f = read_wrap t (fun () -> List.for_all (to_list t) ~f) let exists t ~f = read_wrap t (fun () -> List.exists (to_list t) ~f) let find t ~f = read_wrap t (fun () -> List.find (to_list t) ~f) let find_map t ~f = read_wrap t (fun () -> List.find_map (to_list t) ~f) let iter t ~f = read_wrap t (fun () -> List.iter (to_list t) ~f) let fold t ~init ~f = read_wrap t (fun () -> List.fold (to_list t) ~init ~f) let count t ~f = read_wrap t (fun () -> List.count (to_list t) ~f) let sum m t ~f = read_wrap t (fun () -> List.sum m (to_list t) ~f) let mem t a ~equal = read_wrap t (fun () -> List.mem (to_list t) a ~equal) let min_elt t ~compare = read_wrap t (fun () -> List.min_elt ~compare (to_list t)) let max_elt t ~compare = read_wrap t (fun () -> List.max_elt ~compare (to_list t)) let fold_result t ~init ~f = read_wrap t (fun () -> List.fold_result (to_list t) ~init ~f) ;; let fold_until t ~init ~f = read_wrap t (fun () -> List.fold_until (to_list t) ~init ~f) let sexp_of_t sexp_of_a t = List.sexp_of_t sexp_of_a (to_list t) let t_of_sexp a_of_sexp s = of_list (List.t_of_sexp a_of_sexp s) let invariant _ _ = () let equal t1 t2 = phys_equal t1 t2 let create () = of_list [] let assert_no_pending_readers t = assert (t.num_readers = 0) let filter_inplace t ~f = assert_no_pending_readers t; t.elts <- List.filter t.elts ~f:(fun e -> f e.value) ;; let copy t = of_list (to_list t) let clear t = assert_no_pending_readers t; let dummy = create () in List.iter t.elts ~f:(fun e -> e.root <- dummy); t.elts <- [] ;; let find_elt t ~f = List.find t.elts ~f:(fun elt -> f elt.value) let first_elt t = List.hd t.elts let last_elt t = List.last t.elts let is_last t e = assert (equal t e.root); match last_elt t with | None -> assert false | Some e' -> Elt.equal e e' ;; let is_first t e = assert (equal t e.root); match first_elt t with | None -> assert false | Some e' -> Elt.equal e e' ;; let first t = Option.map ~f:Elt.value (first_elt t) let last t = Option.map ~f:Elt.value (last_elt t) type 'a zipper = { before : 'a elt list ; cursor : 'a elt ; after : 'a elt list } let elts_to_zipper = function | [] -> None | hd :: tl -> Some { before = []; cursor = hd; after = tl } ;; let elts_of_zipper z = List.rev_append z.before (z.cursor :: z.after) let search z e = let rec loop ({ before; cursor = this; after } as z) = if Elt.equal e this then Some z else ( match after with | [] -> None | next :: rest -> loop { before = this :: before; cursor = next; after = rest }) in loop z ;; let search_to t e = assert (equal t e.root); match elts_to_zipper t.elts with | None -> failwith "wrong list" | Some z -> (match search z e with | None -> failwith "wrong list" | Some z -> z) ;; let neighbor before_or_after t e = let z = search_to t e in let side = match before_or_after with | `Before -> z.before | `After -> z.after in List.hd side ;; let next t e = neighbor `After t e let prev t e = neighbor `Before t e let insert_neighbor before_or_after t e x = let z = search_to t e in let new_elt = { value = x; root = t } in let z = match before_or_after with | `Before -> { z with before = new_elt :: z.before } | `After -> { z with after = new_elt :: z.after } in assert_no_pending_readers t; t.elts <- elts_of_zipper z; new_elt ;; let insert_before t elt x = insert_neighbor `Before t elt x let insert_after t elt x = insert_neighbor `After t elt x let insert_first t x = assert_no_pending_readers t; let new_elt = { value = x; root = t } in t.elts <- new_elt :: t.elts; new_elt ;; let insert_last t x = assert_no_pending_readers t; let new_elt = { value = x; root = t } in t.elts <- t.elts @ [ new_elt ]; new_elt ;; let remove t e = let z = search_to t e in assert_no_pending_readers t; e.root <- create (); t.elts <- (match z.before with | [] -> z.after | hd :: tl -> elts_of_zipper { z with before = tl; cursor = hd }) ;; let remove_first t = Option.map (first_elt t) ~f:(fun elt -> remove t elt; Elt.value elt) ;; let remove_last t = Option.map (last_elt t) ~f:(fun elt -> remove t elt; Elt.value elt) ;; let transfer ~src ~dst = assert (not (equal src dst)); List.iter src.elts ~f:(fun e -> e.root <- dst); dst.elts <- dst.elts @ src.elts; src.elts <- [] ;; end exception Both_raised module Both : S = struct module M : sig type ('a1, 'a2) m val ( *@ ) : ('a1 -> 'b1, 'a2 -> 'b2) m -> ('a1, 'a2) m -> ('b1, 'b2) m val pure : 'a -> ('a, 'a) m val pair : 'a -> 'b -> ('a, 'b) m val opt_obs : ('a option, 'b option) m -> ('a, 'b) m option (* observe option *) val obs : ('a, 'a) m -> 'a (* observe *) end = struct type ('a, 'b) m = ('a, exn) Result.t * ('b, exn) Result.t let app f x = match f with | Error e -> Error e | Ok f -> (match x with | Error e -> Error e | Ok x -> (try Ok (f x) with | e -> Error e)) ;; let ( *@ ) (f, g) (x, y) = app f x, app g y let pair x y = Ok x, Ok y let pure x = pair x x let force = function | Ok x, Ok y -> x, y | Error _, Error _ -> raise Both_raised | Error _, Ok _ -> failwith "hero failure =/= foil success" | Ok _, Error _ -> failwith "hero success =/= foil failure" ;; let obs t = let x, y = force t in assert (x = y); x ;; let opt_obs t = match force t with | Some x, Some y -> Some (Ok x, Ok y) | None, None -> None | Some _, None -> failwith "hero some =/= foil none" | None, Some _ -> failwith "hero none =/= foil some" ;; end open M let name = "both" type 'a t = ('a Hero.t, 'a Foil.t) m module Elt = struct type 'a t = ('a Hero.Elt.t, 'a Foil.Elt.t) m let value t = obs (pair Hero.Elt.value Foil.Elt.value *@ t) let sexp_of_t sexp_of_a t = obs (pair Hero.Elt.sexp_of_t Foil.Elt.sexp_of_t *@ pure sexp_of_a *@ t) ;; let equal t1 t2 = obs (pair Hero.Elt.equal Foil.Elt.equal *@ t1 *@ t2) end let sexp_of_t sexp_of_a t = obs (pair Hero.sexp_of_t Foil.sexp_of_t *@ pure sexp_of_a *@ t) ;; let t_of_sexp a_of_sexp s = pair Hero.t_of_sexp Foil.t_of_sexp *@ pure a_of_sexp *@ pure s ;; let exists t ~f = obs (pair (Hero.exists ~f) (Foil.exists ~f) *@ t) let mem t a ~equal = obs (pair (fun h -> Hero.mem h a ~equal) (fun f -> Foil.mem f a ~equal) *@ t) ;; let find_map t ~f = obs (pair (Hero.find_map ~f) (Foil.find_map ~f) *@ t) let find t ~f = obs (pair (Hero.find ~f) (Foil.find ~f) *@ t) let for_all t ~f = obs (pair (Hero.for_all ~f) (Foil.for_all ~f) *@ t) let is_empty t = obs (pair Hero.is_empty Foil.is_empty *@ t) let length t = obs (pair Hero.length Foil.length *@ t) let of_list xs = pair Hero.of_list Foil.of_list *@ pure xs let to_list t = obs (pair Hero.to_list Foil.to_list *@ t) let to_array t = obs (pair Hero.to_array Foil.to_array *@ t) let min_elt t ~compare = obs (pair (Hero.min_elt ~compare) (Foil.min_elt ~compare) *@ t) let max_elt t ~compare = obs (pair (Hero.max_elt ~compare) (Foil.max_elt ~compare) *@ t) (* punt: so as not to duplicate any effects in passed-in functions *) let fold _ = failwith "unimplemented" let fold_result _ = failwith "unimplemented" let fold_until _ = failwith "unimplemented" let iter _ = failwith "unimplemented" let count _ = failwith "unimplemented" let sum _ = failwith "unimplemented" let invariant f t = obs (pair (Hero.invariant f) (Foil.invariant f) *@ t) let create () = pair Hero.create Foil.create *@ pure () let equal t1 t2 = obs (pair Hero.equal Foil.equal *@ t1 *@ t2) let is_first t elt = obs (pair Hero.is_first Foil.is_first *@ t *@ elt) let is_last t elt = obs (pair Hero.is_last Foil.is_last *@ t *@ elt) let first_elt t = opt_obs (pair Hero.first_elt Foil.first_elt *@ t) let last_elt t = opt_obs (pair Hero.last_elt Foil.last_elt *@ t) let first t = obs (pair Hero.first Foil.first *@ t) let last t = obs (pair Hero.last Foil.last *@ t) let next t elt = opt_obs (pair Hero.next Foil.next *@ t *@ elt) let prev t elt = opt_obs (pair Hero.prev Foil.prev *@ t *@ elt) let insert_before t elt v = pair Hero.insert_before Foil.insert_before *@ t *@ elt *@ pure v ;; let insert_after t elt v = pair Hero.insert_after Foil.insert_after *@ t *@ elt *@ pure v ;; let insert_first t v = pair Hero.insert_first Foil.insert_first *@ t *@ pure v let insert_last t v = pair Hero.insert_last Foil.insert_last *@ t *@ pure v let remove t elt = obs (pair Hero.remove Foil.remove *@ t *@ elt) let remove_first t = obs (pair Hero.remove_first Foil.remove_first *@ t) let remove_last t = obs (pair Hero.remove_last Foil.remove_last *@ t) let clear t = obs (pair Hero.clear Foil.clear *@ t) let copy t = pair Hero.copy Foil.copy *@ t let find_elt t ~f = opt_obs (pair (Hero.find_elt ~f) (Foil.find_elt ~f) *@ t) let filter_inplace t ~f = obs (pair (Hero.filter_inplace ~f) (Foil.filter_inplace ~f) *@ t) ;; let transfer ~src ~dst = obs (pair (fun src dst -> Hero.transfer ~src ~dst) (fun src dst -> Foil.transfer ~src ~dst) *@ src *@ dst) ;; end module Make_test (X : S) = struct open X exception Finished let assert_raises f = try f (); raise Finished with | Finished -> assert false | _ -> () ;; module Help = struct let of_sexp s = t_of_sexp Int.t_of_sexp (Sexp.of_string s) let even n = n mod 2 = 0 end let test = X.name >::: [ ("empty" >:: fun () -> let t = create () in assert (length t = 0); assert (is_empty t); assert (first_elt t = None); assert (last_elt t = None); assert (first t = None); assert (last t = None); assert (remove_first t = None); assert (remove_last t = None); assert (to_list t = [])) ; ("single" >:: fun () -> let t = create () in let elt = insert_first t 13 in assert (length t = 1); assert (not (is_empty t)); assert (first t = Some 13); assert (last t = Some 13); assert (to_list t = [ 13 ]); assert (is_first t elt); assert (is_last t elt)) ; ("pair" >:: fun () -> let t = create () in let elt2 = insert_first t 14 in let elt1 = insert_first t 13 in assert (length t = 2); assert (not (is_empty t)); assert true; assert (first t = Some 13); assert (last t = Some 14); assert (to_list t = [ 13; 14 ]); assert (is_first t elt1); assert (is_last t elt2)) ; ("container" >:: fun () -> let module T = Container_test.Test_S1 (X) in T.test ()) ; ("of_list" >:: fun () -> for i = 0 to 5 do let l = List.init i ~f:Fn.id in let t = of_list l in assert (l = to_list t) done) ; ("clear" >:: fun () -> for i = 0 to 5 do let t = of_list (List.init i ~f:Fn.id) in clear t; assert (is_empty t) done) ; ("transfer" >:: fun () -> for i1 = 0 to 3 do let l1 = List.init i1 ~f:Fn.id in for i2 = 0 to 3 do let l2 = List.init i2 ~f:Fn.id in let t1 = of_list l1 in let t2 = of_list l2 in transfer ~src:t1 ~dst:t2; assert (is_empty t1); assert (to_list t2 = l2 @ l1) done done) ; ("transfer2" >:: fun () -> let l1 = create () in let e = insert_first l1 9 in let l2 = create () in transfer ~src:l1 ~dst:l2; remove l2 e; assert (is_empty l1); assert (is_empty l2)) ; ("insert-remove" >:: fun () -> let t = create () in let is_elts elts = assert (to_list t = List.map elts ~f:Elt.value); let rec loop elt elts = match elt, elts with | None, [] -> () | Some elt, elt' :: elts -> assert (Elt.equal elt elt'); loop (next t elt) elts | _ -> assert false in loop (first_elt t) elts; (match elts with | [] -> () | elt :: elts -> assert (prev t elt = None); assert (is_first t elt); assert (Option.equal Elt.equal (first_elt t) (Some elt)); List.iter elts ~f:(fun elt -> assert (not (is_first t elt))); ignore (List.fold elts ~init:elt ~f:(fun prev elt -> assert (Option.equal Elt.equal (X.prev t elt) (Some prev)); elt) : _ Elt.t)); match List.rev elts with | [] -> () | elt :: elts -> assert (next t elt = None); assert (is_last t elt); assert (Option.equal Elt.equal (last_elt t) (Some elt)); List.iter elts ~f:(fun elt -> assert (not (is_last t elt))); ignore (List.fold elts ~init:elt ~f:(fun next elt -> assert (Option.equal Elt.equal (X.next t elt) (Some next)); elt) : _ Elt.t) in let elt1 = insert_first t () in is_elts [ elt1 ]; let elt2 = insert_first t () in is_elts [ elt2; elt1 ]; let elt3 = insert_last t () in is_elts [ elt2; elt1; elt3 ]; remove t elt1; is_elts [ elt2; elt3 ]; let elt4 = insert_after t elt2 () in is_elts [ elt2; elt4; elt3 ]; let elt5 = insert_before t elt2 () in is_elts [ elt5; elt2; elt4; elt3 ]; ignore (remove_last t : _ option); is_elts [ elt5; elt2; elt4 ]; ignore (remove_first t : _ option); is_elts [ elt2; elt4 ]; ignore (remove_first t : _ option); is_elts [ elt4 ]; ignore (remove_first t : _ option); is_elts []) ; ("filter-inplace" >:: fun () -> let t = create () in let r1 = ref 0 in let r2 = ref 1 in let r3 = ref 2 in let i x = ignore (insert_first t x : _ Elt.t) in i r1; i r2; i r3; assert (length t = 3); filter_inplace t ~f:(fun r -> not (phys_equal r r2)); assert (length t = 2); let len = fold t ~init:0 ~f:(fun acc x -> assert (not (phys_equal x r2)); acc + 1) in assert (len = length t)) ; ("wrong-list-1" >:: fun () -> let t1 = create () in let t2 = create () in let e1 = insert_first t1 0 in try remove t2 e1; assert false with | _ -> ()) ; ("wrong-list-2" >:: fun () -> let t4 = create () in let t5 = t_of_sexp Int.t_of_sexp (Sexp.of_string "(1 2)") in match last_elt t5 with | None -> assert false | Some e6 -> (try ignore (prev t4 e6 : _ Elt.t option); raise Exit with | Exit -> assert false | _ -> ())) ; ("transfer-self" >:: fun () -> let l2 = of_list [] in try transfer ~src:l2 ~dst:l2; raise Exit with | Exit -> assert false | _ -> ()) ; "write-lock" >::: [ ("remove" >:: fun () -> let xs = [ 1; 2; 3 ] in let t = of_list xs in let e = Option.value_exn (first_elt t) in iter t ~f:(fun _ -> assert_raises (fun () -> ignore (remove_first t : _ option))); assert (to_list t = xs); iter t ~f:(fun _ -> assert_raises (fun () -> ignore (remove_last t : _ option))); assert (to_list t = xs); iter t ~f:(fun _ -> assert_raises (fun () -> remove t e)); assert (to_list t = xs)) ; ("insert" >:: fun () -> let xs = [ 1; 2; 3 ] in let t = of_list xs in let e = Option.value_exn (first_elt t) in iter t ~f:(fun _ -> assert_raises (fun () -> ignore (insert_first t 4 : _ Elt.t))); assert (to_list t = xs); iter t ~f:(fun _ -> assert_raises (fun () -> ignore (insert_last t 5 : _ Elt.t))); assert (to_list t = xs); iter t ~f:(fun _ -> assert_raises (fun () -> ignore (insert_before t e 6 : _ Elt.t))); assert (to_list t = xs); iter t ~f:(fun _ -> assert_raises (fun () -> ignore (insert_after t e 7 : _ Elt.t))); assert (to_list t = xs)) ] ; ("transfer2" >:: fun () -> let open Help in let src = of_sexp "(1)" in ignore src; let elt = insert_last src 4 in ignore elt; let dst = of_sexp "(1 2 3 4)" in ignore dst; transfer ~src ~dst; ignore (next dst elt : _ Elt.t option); ()) ; ("counterexample1" >:: fun () -> let open Help in let l = of_sexp "(1)" in let e = insert_first l 2 in invariant ignore l; assert (Option.is_some (remove_first l)); assert_raises (fun () -> ignore (is_last l e : bool)); ()) ; ("counterexample2" >:: fun () -> let l = of_list [ 1 ] in let e = insert_first l 3 in invariant ignore l; remove l e; invariant ignore l; assert (Option.is_some (first_elt l))) ; ("counterexample3" >:: fun () -> let open Help in let l1 = of_sexp "(1 2 3)" in let l2 = copy l1 in transfer ~src:l2 ~dst:l1; invariant ignore l1) ; ("counterexample4" >:: fun () -> let open Help in let l1 = of_sexp "(1 2 3 4)" in assert (length l1 = 4); ignore (insert_last l1 4 : _ Elt.t); assert (length l1 = 5); let l2 = of_list [ 1; 2; 3 ] in assert (length l2 = 3); transfer ~src:l1 ~dst:l2; match length l1, length l2 with | 0, 8 -> () | len1, len2 -> failwithf "%s: len1 = %d =/= 0; len2 = %d =/= 8" X.name len1 len2 ()) ] ;; end module Bisimulation = struct module Random = struct let prng = Random.State.make [| 3 ; 1 ; 4 ; 1 ; 5 ; 9 ; 2 ; 6 ; 5 ; 3 ; 5 ; 8 ; 9 ; 7 ; 9 ; 3 ; 2 ; 3 ; 8 ; 4 ; 6 ; 2 ; 6 ; 4 ; 3 ; 3 ; 8 ; 3 ; 2 ; 7 ; 9 ; 5 ; 0 ; 2 ; 8 ; 8 ; 4 ; 1 ; 9 ; 7 ; 1 ; 6 ; 9 ; 3 ; 9 ; 9 ; 3 ; 7 ; 5 ; 1 ; 0 ; 5 ; 8 ; 2 ; 0 ; 9 ; 7 ; 4 ; 9 ; 4 ; 4 ; 5 ; 9 ; 2 ; 3 ; 0 ; 7 ; 8 ; 1 ; 6 ; 4 ; 0 ; 6 ; 2 ; 8 ; 6 ; 2 ; 0 ; 8 ; 9 ; 9 ; 8 ; 6 ; 2 ; 8 ; 0 ; 3 ; 4 ; 8 ; 2 ; 5 ; 3 ; 4 ; 2 ; 1 ; 1 ; 7 ; 0 ; 6 ; 7 ; 9 ; 8 ; 2 ; 1 ; 4 ; 8 ; 0 ; 8 ; 6 ; 5 ; 1 ; 3 ; 2 ; 8 ; 2 ; 3 ; 0 ; 6 ; 6 ; 4 ; 7 ; 0 ; 9 ; 3 ; 8 ; 4 ; 4 ; 6 ; 0 ; 9 ; 5 ; 5 ; 0 ; 5 ; 8 ; 2 ; 2 ; 3 ; 1 ; 7 ; 2 ; 5 ; 3 ; 5 ; 9 ; 4 ; 0 ; 8 ; 1 ; 2 ; 8 ; 4 ; 8 ; 1 ; 1 ; 1 ; 7 ; 4 ; 5 ; 0 ; 2 ; 8 ; 4 ; 1 ; 0 ; 2 ; 7 ; 0 ; 1 ; 9 ; 3 ; 8 ; 5 ; 2 ; 1 ; 1 ; 0 ; 5 ; 5 ; 5 ; 9 ; 6 ; 4 ; 4 ; 6 ; 2 ; 2 ; 9 ; 4 ; 8 ; 9 ; 5 ; 4 ; 9 ; 3 ; 0 ; 3 ; 8 ; 1 ; 9 ; 6 ; 4 ; 4 ; 2 ; 8 ; 8 ; 1 ; 0 ; 9 ; 7 ; 5 ; 6 ; 6 ; 5 ; 9 ; 3 ; 3 ; 4 ; 4 ; 6 ; 1 ; 2 ; 8 ; 4 ; 7 ; 5 ; 6 ; 4 ; 8 ; 2 ; 3 ; 3 ; 7 ; 8 ; 6 ; 7 ; 8 ; 3 ; 1 ; 6 ; 5 ; 2 ; 7 ; 1 ; 2 ; 0 ; 1 ; 9 ; 0 ; 9 ; 1 ; 4 ; 5 ; 6 ; 4 ; 8 ; 5 ; 6 ; 6 ; 9 ; 2 ; 3 ; 4 ; 6 ; 0 ; 3 ; 4 ; 8 ; 6 ; 1 ; 0 ; 4 ; 5 ; 4 ; 3 ; 2 ; 6 ; 6 ; 4 ; 8 ; 2 ; 1 ; 3 ; 3 ; 9 ; 3 ; 6 ; 0 ; 7 ; 2 ; 6 ; 0 ; 2 ; 4 ; 9 ; 1 ; 4 ; 1 ; 2 ; 7 ; 3 ; 7 ; 2 ; 4 ; 5 ; 8 ; 7 ; 0 ; 0 ; 6 ; 6 ; 0 ; 6 ; 3 ; 1 ; 5 ; 5 ; 8 ; 8 ; 1 ; 7 ; 4 ; 8 ; 8 ; 1 ; 5 ; 2 ; 0 ; 9 ; 2 ; 0 ; 9 ; 6 ; 2 ; 8 ; 2 ; 9 ; 2 ; 5 ; 4 ; 0 ; 9 ; 1 ; 7 ; 1 ; 5 ; 3 ; 6 ; 4 ; 3 ; 6 ; 7 ; 8 ; 9 ; 2 ; 5 ; 9 ; 0 ; 3 ; 6 ; 0 ; 0 ; 1 ; 1 ; 3 ; 3 ; 0 ; 5 ; 3 ; 0 ; 5 ; 4 ; 8 ; 8 ; 2 ; 0 ; 4 ; 6 ; 6 ; 5 ; 2 ; 1 ; 3 ; 8 ; 4 ; 1 ; 4 ; 6 ; 9 ; 5 ; 1 ; 9 ; 4 ; 1 ; 5 ; 1 ; 1 ; 6 ; 0 ; 9 ; 4 ; 3 ; 3 ; 0 ; 5 ; 7 ; 2 ; 7 ; 0 ; 3 ; 6 ; 5 ; 7 ; 5 ; 9 ; 5 ; 9 ; 1 ; 9 ; 5 ; 3 ; 0 ; 9 ; 2 ; 1 ; 8 ; 6 ; 1 ; 1 ; 7 ; 3 ; 8 ; 1 ; 9 ; 3 ; 2 ; 6 ; 1 ; 1 ; 7 ; 9 ; 3 ; 1 ; 0 ; 5 ; 1 ; 1 ; 8 ; 5 ; 4 ; 8 ; 0 ; 7 ; 4 ; 4 ; 6 ; 2 ; 3 ; 7 ; 9 ; 9 ; 6 ; 2 ; 7 ; 4 ; 9 ; 5 ; 6 ; 7 ; 3 ; 5 ; 1 ; 8 ; 8 ; 5 ; 7 ; 5 ; 2 ; 7 ; 2 ; 4 ; 8 ; 9 ; 1 ; 2 ; 2 ; 7 ; 9 ; 3 ; 8 ; 1 ; 8 ; 3 ; 0 ; 1 ; 1 ; 9 ; 4 ; 9 ; 1 ; 2 ; 9 ; 8 ; 3 ; 3 ; 6 ; 7 ; 3 ; 3 ; 6 ; 2 ; 4 ; 4 ; 0 ; 6 ; 5 ; 6 ; 6 ; 4 ; 3 ; 0 ; 8 ; 6 ; 0 |] ;; let int n = Random.State.int prng n let bool () = Random.State.bool prng end module Uid = Unique_id.Int () type v = int [@@deriving sexp] type l = Uid.t * v Both.t type e = Uid.t * v Both.Elt.t let sexp_of_l (id, _) = Sexp.Atom ("l" ^ Uid.to_string id) let sexp_of_e (id, _) = Sexp.Atom ("e" ^ Uid.to_string id) type p = | Even | Odd [@@deriving sexp_of] module F = struct type t = | Clear of l | Copy of l | Create | Elt_equal of e * e | Elt_sexp of e | Elt_value of e | Equal of l * l | Exists of l * p | Filter_inplace of l * p | Find_elt of l * p | Find of l * p | First_elt of l | First of l | For_all of l * p | Insert_after of l * e * v | Insert_before of l * e * v | Insert_first of l * v | Insert_last of l * v | Invariant of l | Is_empty of l | Is_first of l * e | Is_last of l * e | Last_elt of l | Last of l | Length of l | Next of l * e | Of_list of v list | Of_sexp of Sexp.t | Prev of l * e | Remove_first of l | Remove_last of l | Remove of l * e | To_array of l | To_list of l | To_sexp of l | Transfer of l * l [@@deriving sexp_of, variants] end open F type f = F.t [@@deriving sexp_of] type env = { ls : (Uid.t, l) Hashtbl.t ; es : (Uid.t, e) Hashtbl.t } let values = List.range 1 6 let lists = List.map (List.range 0 6) ~f:(fun n -> List.take values n) let sexps = List.map lists ~f:(List.sexp_of_t Int.sexp_of_t) let values = List.to_array values let lists = List.to_array lists let sexps = List.to_array sexps exception Skip [@@deriving sexp] let array_rand arr = try Array.random_element_exn arr with | _ -> raise Skip ;; (* sometimes we try to select from a not-yet-non-empty array *) let hashtbl_rand h = let arr = List.to_array (Hashtbl.to_alist h) in snd (array_rand arr) ;; let rand_p _env = if Random.bool () then Even else Odd let rand_v _env = array_rand values let rand_vs _env = array_rand lists let rand_s _env = array_rand sexps let rand_e env = hashtbl_rand env.es let rand_l env = hashtbl_rand env.ls let rand_f = let tbl = lazy (let count = ref 0 in let h = Hashtbl.Poly.create ~size:50 () in let v of_env _ = Hashtbl.set h ~key: (incr count; !count) ~data:of_env in Variants.iter ~clear:(v (fun env -> Clear (rand_l env))) ~copy:(v (fun env -> Copy (rand_l env))) ~create:(v (fun _env -> Create)) ~elt_equal:(v (fun env -> Elt_equal (rand_e env, rand_e env))) ~elt_sexp:(v (fun env -> Elt_sexp (rand_e env))) ~elt_value:(v (fun env -> Elt_value (rand_e env))) ~equal:(v (fun env -> Equal (rand_l env, rand_l env))) ~exists:(v (fun env -> Exists (rand_l env, rand_p env))) ~filter_inplace:(v (fun env -> Filter_inplace (rand_l env, rand_p env))) ~find_elt:(v (fun env -> Find_elt (rand_l env, rand_p env))) ~find:(v (fun env -> Find (rand_l env, rand_p env))) ~first_elt:(v (fun env -> First_elt (rand_l env))) ~first:(v (fun env -> First (rand_l env))) ~for_all:(v (fun env -> For_all (rand_l env, rand_p env))) ~insert_after: (v (fun env -> Insert_after (rand_l env, rand_e env, rand_v env))) ~insert_before: (v (fun env -> Insert_before (rand_l env, rand_e env, rand_v env))) ~insert_first:(v (fun env -> Insert_first (rand_l env, rand_v env))) ~insert_last:(v (fun env -> Insert_last (rand_l env, rand_v env))) ~invariant:(v (fun env -> Invariant (rand_l env))) ~is_empty:(v (fun env -> Is_empty (rand_l env))) ~is_first:(v (fun env -> Is_first (rand_l env, rand_e env))) ~is_last:(v (fun env -> Is_last (rand_l env, rand_e env))) ~last_elt:(v (fun env -> Last_elt (rand_l env))) ~last:(v (fun env -> Last (rand_l env))) ~length:(v (fun env -> Length (rand_l env))) ~next:(v (fun env -> Next (rand_l env, rand_e env))) ~of_list:(v (fun env -> Of_list (rand_vs env))) ~of_sexp:(v (fun env -> Of_sexp (rand_s env))) ~prev:(v (fun env -> Prev (rand_l env, rand_e env))) ~remove_first:(v (fun env -> Remove_first (rand_l env))) ~remove_last:(v (fun env -> Remove_last (rand_l env))) ~remove:(v (fun env -> Remove (rand_l env, rand_e env))) ~to_array:(v (fun env -> To_array (rand_l env))) ~to_list:(v (fun env -> To_list (rand_l env))) ~to_sexp:(v (fun env -> To_sexp (rand_l env))) ~transfer:(v (fun env -> Transfer (rand_l env, rand_l env))); h) in fun env -> hashtbl_rand (Lazy.force tbl) env ;; exception Traced of Sexp.t * [ `Operation of f | `New_elt of e | `New_list of l ] list [@@deriving sexp] let simulate nsteps = let env = { ls = Hashtbl.Poly.create ~size:50 (); es = Hashtbl.Poly.create ~size:50 () } in let add h v = let id = Uid.create () in Hashtbl.set h ~key:id ~data:(id, v); id in let trace = Queue.create () in let add_list l = Queue.enqueue trace (`New_list (add env.ls l, l)) in let add_elt e = Queue.enqueue trace (`New_elt (add env.es e, e)) in let add_elt_opt = function | None -> () | Some e -> add_elt e in let pred = function | Even -> fun n -> n mod 0 = 0 | Odd -> fun n -> n mod 0 = 1 in try for _ = 1 to nsteps do try let f = rand_f env in Queue.enqueue trace (`Operation f); match f with | Clear l -> Both.clear (snd l) | Copy l -> add_list (Both.copy (snd l)) | Create -> add_list (Both.create ()) | Elt_equal (e1, e2) -> ignore (Both.Elt.equal (snd e1) (snd e2) : bool) | Elt_sexp e -> ignore (Both.Elt.sexp_of_t sexp_of_v (snd e) : Sexp.t) | Elt_value e -> ignore (Both.Elt.value (snd e) : _) | Equal (t1, t2) -> ignore (Both.equal (snd t1) (snd t2) : bool) | Exists (t, p) -> ignore (Both.exists (snd t) ~f:(pred p) : bool) | Filter_inplace (t, p) -> Both.filter_inplace (snd t) ~f:(pred p) | For_all (t, p) -> ignore (Both.for_all (snd t) ~f:(pred p) : bool) | Find_elt (t, p) -> add_elt_opt (Both.find_elt (snd t) ~f:(pred p)) | Find (t, p) -> ignore (Both.find (snd t) ~f:(pred p) : _ option) | First_elt t -> add_elt_opt (Both.first_elt (snd t)) | First t -> ignore (Both.first (snd t) : _ option) | Insert_after (t, e, v) -> add_elt (Both.insert_after (snd t) (snd e) v) | Insert_before (t, e, v) -> add_elt (Both.insert_before (snd t) (snd e) v) | Insert_first (t, v) -> add_elt (Both.insert_first (snd t) v) | Insert_last (t, v) -> add_elt (Both.insert_last (snd t) v) | Invariant t -> Both.invariant ignore (snd t) | Is_empty t -> ignore (Both.is_empty (snd t) : bool) | Is_first (t, e) -> ignore (Both.is_first (snd t) (snd e) : bool) | Is_last (t, e) -> ignore (Both.is_last (snd t) (snd e) : bool) | Last_elt t -> add_elt_opt (Both.last_elt (snd t)) | Last t -> ignore (Both.last (snd t) : _ option) | Length t -> ignore (Both.length (snd t) : int) | Next (t, e) -> ignore (Both.next (snd t) (snd e) : _ Both.Elt.t option) | Prev (t, e) -> ignore (Both.prev (snd t) (snd e) : _ Both.Elt.t option) | Of_list vs -> add_list (Both.of_list vs) | Remove_first t -> ignore (Both.remove_first (snd t) : _ option) | Remove_last t -> ignore (Both.remove_last (snd t) : _ option) | Remove (t, e) -> Both.remove (snd t) (snd e) | To_sexp t -> ignore (Both.sexp_of_t sexp_of_v (snd t) : Sexp.t) | To_array t -> ignore (Both.to_array (snd t) : _ array) | Of_sexp s -> add_list (Both.t_of_sexp v_of_sexp s) | To_list t -> ignore (Both.to_list (snd t) : _ list) | Transfer (t1, t2) -> Both.transfer ~src:(snd t1) ~dst:(snd t2) with | Both_raised | Skip -> () done with | e -> raise (Traced (Exn.sexp_of_t e, Queue.to_list trace)) ;; let test = "bisimulation" >:: fun () -> for _ = 1 to 100_000 do simulate 10 done ;; end module Hero_test = Make_test (Hero) module Foil_test = Make_test (Foil) let test = "doubly_linked" >::: [ Hero_test.test ; Foil_test.test ; Bisimulation.test (* uncomment this once it passes *) ] ;; core-0.15.0/core/test/bin/dune000066400000000000000000000011201420273305200160520ustar00rootroot00000000000000(alias (name runtest) (deps float_test.exe) (action (bash ./float_test.exe))) (alias (name runtest) (deps test_runner.exe) (action (bash ./test_runner.exe))) (alias (name runtest) (deps just_raise.exe just_raise.expected-output uncaught_exception_test.sh) (action (bash ./uncaught_exception_test.sh))) (executables (names float_test just_raise test_runner) (libraries bin_prot core_kernel.caml_threads core_unix.command_unix core oUnit ppx_inline_test.runtime-lib quickcheck_deprecated sexplib core_unix.time_unix variantslib core_kernel.version_util) (preprocess (pps ppx_jane)))core-0.15.0/core/test/bin/fdeque_test.ml000066400000000000000000000054411420273305200200500ustar00rootroot00000000000000open Core open Poly open OUnit open Fdeque let lpush l q = List.fold ~init:q ~f:enqueue_back l let inv = invariant ignore let test = "fdeque" >::: [ ("basic" >:: fun () -> let q0 = lpush [ 1; 2; 3; 4; 5 ] empty in let _, q1 = dequeue_front_exn q0 in let _, q2 = dequeue_front_exn q1 in let q3 = enqueue_back q2 0 in inv q0; inv q1; inv q2; inv q3; "len0" @? (length q0 = 5); "len1" @? (length q1 = 4); "len2" @? (length q2 = 3); "len3" @? (length q3 = 4); "q0" @? (to_list q0 = [ 1; 2; 3; 4; 5 ]); "q1" @? (to_list q1 = [ 2; 3; 4; 5 ]); "q2" @? (to_list q2 = [ 3; 4; 5 ]); "q3" @? (to_list q3 = [ 3; 4; 5; 0 ]); "peek_front_exn3" @? (peek_front_exn q3 = 3); "peek_back_exn3" @? (peek_back_exn q3 = 0); "drop_front_exn" @? (to_list (drop_front_exn q0) = to_list q1); "notempty3" @? not (is_empty q3); "empty3" @? is_empty (drop_front_exn (drop_front_exn (drop_front_exn (drop_front_exn q3)))); "misc" @? (to_list (lpush [ 2; 3 ] (drop_front_exn (drop_front_exn (drop_front_exn (drop_front_exn q3))))) = [ 2; 3 ])) ; ("invariants and list bisimulation" >:: fun () -> let rec drop_last = function | [] -> assert false | [ _ ] -> [] | x :: l -> x :: drop_last l in ignore (List.fold (List.range 0 1000) ~init:(empty, []) ~f:(fun (q, l) i -> let q, l = match Random.int 9 with | 0 | 1 -> enqueue_back q i, l @ [ i ] | 2 | 3 -> enqueue_front q i, [ i ] @ l | 4 -> (match dequeue_front q with | None -> q, l | Some (_, q) -> q, List.tl_exn l) | 5 -> (match drop_front_exn q with | q -> q, List.tl_exn l | exception _ -> q, l) | 6 -> (match dequeue_back q with | None -> q, l | Some (_, q) -> q, drop_last l) | 7 -> (match drop_back_exn q with | q -> q, drop_last l | exception _ -> q, l) | 8 -> rev q, List.rev l | _ -> q, l in inv q; assert (List.equal Int.equal l (to_list q)); q, l) : int t * int list)) ] ;; core-0.15.0/core/test/bin/float_test.ml000066400000000000000000000033051420273305200177010ustar00rootroot00000000000000open Core let nobox name f = let message = "Float_test.nobox " ^ name in List.iter (List.range (-19) 19) ~f:(fun e -> let scale = 10. ** float e in for _ = 0 to 14_000 do let t = [| Random.float scale -. (scale /. 2.) |] in if Version_util.x_library_inlining then ( match let minor_before = Gc.minor_words () in let major_before = Gc.major_words () in let result = f t in let minor_after = Gc.minor_words () in let major_after = Gc.major_words () in ( `minor (minor_after - minor_before) , `major (major_after - major_before) , `result result ) with (* When the result doesn't fit, [f] will raise. In that case, we allow allocation, so we don't check anything here. *) | exception _ -> () | `minor minor, `major major, `result result -> let _message = message ^ " -> " ^ Int.to_string result in [%test_result: int] ~message minor ~expect:0; [%test_result: int] ~message major ~expect:0) done) ;; (* We have to carefully allow the compiler to unbox t.(0) to test that each function doesn't force it to re-box the float. We need the extra fun per function to allow the compiler to inline each one separately around t.(0). *) let () = List.iter ~f:(fun (name, t) -> nobox name t) [ ("iround_down_exn", fun t -> Float.iround_down_exn t.(0)) ; ("iround_nearest_exn", fun t -> Float.iround_nearest_exn t.(0)) ; ("iround_up_exn", fun t -> Float.iround_up_exn t.(0)) ; ("iround_towards_zero_exn", fun t -> Float.iround_towards_zero_exn t.(0)) ; ("Caml.int_of_float", fun t -> Caml.int_of_float t.(0)) ] ;; core-0.15.0/core/test/bin/float_test_ounit.ml000066400000000000000000000006721420273305200211230ustar00rootroot00000000000000open OUnit open Core let terse_test = "terse_test" >:: fun () -> let test number expected = assert_equal ~printer:Fn.id expected (Float.Terse.to_string number); let sexp = Float.Terse.sexp_of_t number in assert_equal ~printer:Fn.id expected (Sexp.to_string sexp) in test 0.0123456789 "0.012345679"; test 0.012345 "0.012345"; test 123456789.123 "1.2345679E+08" ;; let test = TestList [ terse_test ] core-0.15.0/core/test/bin/int_conversions_test.ml000066400000000000000000000115361420273305200220230ustar00rootroot00000000000000open OUnit open Core open Poly let () = List.iter [ "1", "1" ; "12", "12" ; "123", "123" ; "1234", "1_234" ; "12345", "12_345" ; "123456", "123_456" ; "1234567", "1_234_567" ; "+1", "+1" ; "+12", "+12" ; "+123", "+123" ; "+1234", "+1_234" ; "+12345", "+12_345" ; "+123456", "+123_456" ; "+1234567", "+1_234_567" ; "-1", "-1" ; "-12", "-12" ; "-123", "-123" ; "-1234", "-1_234" ; "-12345", "-12_345" ; "-123456", "-123_456" ; "-1234567", "-1_234_567" ] ~f:(fun (input, expected) -> let got = try Int_conversions.insert_underscores input with | exn -> failwithf "input = %s exn = %s" input (Exn.to_string exn) () in if got <> expected then failwithf "input = %s got = %s expected = %s" input got expected ()) ;; module Examples (I : Int_intf.S) = struct open I let two = one + one let examples = [ min_value ; min_value + one ; min_value + two ; min_value / two ; neg two ; neg one ; zero ; one ; two ; max_value / two ; max_value - two ; max_value - one ; max_value ] ;; end module Inverses (X : Int_intf.S) (Y : Int_intf.S) (Conv : sig val x_to_y : X.t -> Y.t val y_to_x : Y.t -> X.t option end) = struct open Conv let xs = let module E = Examples (X) in E.examples ;; let ys = let module E = Examples (Y) in E.examples ;; let out_of_range y = assert (y >= x_to_y X.max_value || y <= x_to_y X.min_value) let test = "int_conversions" >:: fun () -> List.iter xs ~f:(fun x -> let y = x_to_y x in match y_to_x y with | Some x' -> assert (x = x') | None -> out_of_range y); List.iter ys ~f:(fun y -> match y_to_x y with | Some x -> assert (x_to_y x = y) | None -> out_of_range y) ;; end module Inverses' (X : Int_intf.S) (Y : Int_intf.S) (Conv : sig val x_to_y : X.t -> Y.t option val y_to_x : Y.t -> X.t option end) = struct open Conv let xs = let module E = Examples (X) in E.examples ;; let ys = let module E = Examples (Y) in E.examples ;; let get = function | Some z -> z | None -> failwith "Out_of_range" ;; let y_to_x_exn y = get (y_to_x y) let x_to_y_exn x = get (x_to_y x) let x_out_of_range x = assert (x >= y_to_x_exn Y.max_value || x <= y_to_x_exn Y.min_value) ;; let y_out_of_range y = assert (y >= x_to_y_exn X.max_value || y <= x_to_y_exn X.min_value) ;; let test = "int_conversions" >:: fun () -> List.iter xs ~f:(fun x -> match x_to_y x with | None -> x_out_of_range x | Some y -> (match y_to_x y with | Some x' -> assert (x = x') | None -> y_out_of_range y)); List.iter ys ~f:(fun y -> match y_to_x y with | Some x -> assert (x_to_y_exn x = y) | None -> y_out_of_range y) ;; end module Ii6 = Inverses (Int) (Int64) (struct let x_to_y = Int.to_int64 let y_to_x = Int.of_int64 end) module Ii6' = Inverses (Int) (Int64) (struct let x_to_y = Int64.of_int let y_to_x = Int64.to_int end) module Iin = Inverses (Int) (Nativeint) (struct let x_to_y = Int.to_nativeint let y_to_x = Int.of_nativeint end) module Iin' = Inverses (Int) (Nativeint) (struct let x_to_y = Nativeint.of_int let y_to_x = Nativeint.to_int end) module I36 = Inverses (Int32) (Int64) (struct let x_to_y = Int32.to_int64 let y_to_x = Int32.of_int64 end) module I36' = Inverses (Int32) (Int64) (struct let x_to_y = Int64.of_int32 let y_to_x = Int64.to_int32 end) module I3n = Inverses (Int32) (Nativeint) (struct let x_to_y = Int32.to_nativeint let y_to_x = Int32.of_nativeint end) module I3n' = Inverses (Int32) (Nativeint) (struct let x_to_y = Nativeint.of_int32 let y_to_x = Nativeint.to_int32 end) module In6 = Inverses (Nativeint) (Int64) (struct let x_to_y = Int64.of_nativeint let y_to_x = Int64.to_nativeint end) module In6' = Inverses (Nativeint) (Int64) (struct let x_to_y = Nativeint.to_int64 let y_to_x = Nativeint.of_int64 end) module Ii3 = Inverses' (Int) (Int32) (struct let x_to_y = Int.to_int32 let y_to_x = Int.of_int32 end) module Ii3' = Inverses' (Int) (Int32) (struct let x_to_y = Int32.of_int let y_to_x = Int32.to_int end) let test = TestList [ Ii6.test ; Ii6'.test ; Iin.test ; Iin'.test ; I36.test ; I36'.test ; I3n.test ; I3n'.test ; In6.test ; In6'.test ; Ii3.test ; Ii3'.test ] ;; core-0.15.0/core/test/bin/just_raise.expected-output000066400000000000000000000002141420273305200224300ustar00rootroot00000000000000Uncaught exception: (just_raise.ml.E 42) Raised at Bin_prefix_float_test__Just_raise in file "just_raise.ml", line 5, characters 9-21 core-0.15.0/core/test/bin/just_raise.ml000066400000000000000000000001101420273305200176740ustar00rootroot00000000000000open! Core exception E of int [@@deriving sexp] let () = raise (E 42) core-0.15.0/core/test/bin/manual/000077500000000000000000000000001420273305200164575ustar00rootroot00000000000000core-0.15.0/core/test/bin/manual/backtrace.ml000066400000000000000000000003031420273305200207240ustar00rootroot00000000000000open Core let f n = if n = 2 then ( Printf.eprintf "%s%!" (Backtrace.to_string (Backtrace.get ())) ) else Printf.printf "foo\n%!" let g () = List.iter [1; 2; 3] ~f let () = g () core-0.15.0/core/test/bin/manual/dune000066400000000000000000000001141420273305200173310ustar00rootroot00000000000000(executables (names backtrace) (libraries core) (preprocess (pps ppx_jane)))core-0.15.0/core/test/bin/pMap_test.ml000066400000000000000000000100321420273305200174640ustar00rootroot00000000000000open OUnit open Core open Poly module Map = Map.Poly let m1 = Map.of_alist_exn [ "a", 1; "b", 2; "c", 3; "d", 4 ] let m2 = Map.of_alist_exn [ "a", 1; "c", -3; "d", 4; "e", 5 ] let test = "pMap" >::: [ ("merge1" >:: fun () -> let f ~key:_ = function | `Left _ | `Right _ -> None | `Both (x, y) -> Some (x + y) in "eq1" @? Map.equal ( = ) (Map.merge ~f m1 m2) (Map.of_alist_exn [ "a", 2; "c", 0; "d", 8 ]); "eq2" @? Map.equal ( = ) (Map.merge ~f m2 m1) (Map.of_alist_exn [ "a", 2; "c", 0; "d", 8 ])) ; ("merge2" >:: fun () -> let f ~key:_ = function | `Left x -> Some x | `Right _ -> None | `Both (x, y) -> Some (x + y) in "eq" @? Map.equal ( = ) (Map.merge ~f m1 m2) (Map.of_alist_exn [ "a", 2; "b", 2; "c", 0; "d", 8 ])) ; ("merge3" >:: fun () -> let f ~key:_ = function | `Left x | `Right x -> Some x | `Both (x, y) -> Some (x + y) in "eq1" @? Map.equal ( = ) (Map.merge ~f m1 m2) (Map.of_alist_exn [ "a", 2; "b", 2; "c", 0; "d", 8; "e", 5 ]); "eq2" @? Map.equal ( = ) (Map.merge ~f m2 m1) (Map.of_alist_exn [ "a", 2; "b", 2; "c", 0; "d", 8; "e", 5 ])) ; ("merge3" >:: fun () -> let f ~key:_ = function | `Left x | `Right x -> Some x | `Both (x, y) -> Some (x + y) in "eq1" @? Map.equal ( = ) (Map.merge ~f m1 Map.empty) m1; "eq2" @? Map.equal ( = ) (Map.merge ~f Map.empty m1) m1) ; ("sexp" >:: fun () -> let s = "((a 1) (b 2) (c 3) (d 4))" in let m1' = Map.t_of_sexp string_of_sexp int_of_sexp (Sexp.of_string s) in "of_sexp1" @? Map.equal ( = ) m1' m1; let s_dup = "((a 1) (b 2) (a 3) (d 4))" in let s_dup = Sexp.of_string s_dup in try ignore (Map.t_of_sexp string_of_sexp int_of_sexp s_dup : _ Map.t); assert false with | _ -> ()) ; ("of_alist" >:: fun () -> let a = [ "a", 1; "b", 2; "c", 3; "d", 4 ] in let m = match Map.of_alist a with | `Ok x -> x | `Duplicate_key _ -> failwith "argh" in "1" @? (Map.find_exn m "a" = 1 && Map.find_exn m "d" = 4); let a_dup = [ "a", 1; "b", 2; "c", 3; "b", 4; "e", 5 ] in ("2" @? match Map.of_alist a_dup with | `Ok _ -> false | `Duplicate_key x -> x = "b"); "3" @? (Map.to_alist (Map.of_alist_exn a) = List.sort ~compare:Poly.ascending a); try ignore (Map.of_alist_exn a_dup : _ Map.t); assert false with | _ -> ()) ; ("for_all/exists" >:: fun () -> let m = Map.of_alist_exn [ "a", 1; "b", 2; "c", 3; "d", 4 ] in "1" @? Map.for_all ~f:(fun x -> x > 0) m; "2" @? not (Map.for_all ~f:(fun x -> x % 2 = 0) m); "3" @? Map.exists ~f:(fun x -> x % 2 = 0) m; "4" @? not (Map.exists ~f:(fun x -> x < 0) m); ("short circuit forall" @? let sum = ref 0 in ignore (Map.for_all m ~f:(fun x -> sum := !sum + x; x <> 1) : bool); !sum = 1); "short circuit exists" @? let sum = ref 0 in ignore (Map.exists m ~f:(fun x -> sum := !sum + x; x = 1) : bool); !sum = 1) ] ;; core-0.15.0/core/test/bin/pSet_test.ml000066400000000000000000000012371420273305200175110ustar00rootroot00000000000000open OUnit open Core let s1 = Set.Poly.of_list [ "a"; "b"; "c"; "d" ] (*let m2 = Map.of_alist ["a",1; "c",-3; "d",4; "e",5]*) let test = "pSet" >::: [ ("sexp" >:: fun () -> let s = "(a b c d)" in let s1' = Set.Poly.t_of_sexp string_of_sexp (Sexp.of_string s) in "of_sexp1" @? Set.equal s1' s1; let s_dup = "(a b a d)" in let s_dup = Sexp.of_string s_dup in assert_raises (Sexplib.Conv.Of_sexp_error (Failure "Set.t_of_sexp: duplicate element in set", sexp_of_string "a")) (fun () -> Set.Poly.t_of_sexp string_of_sexp s_dup)) ] ;; core-0.15.0/core/test/bin/permissions.mlt000066400000000000000000000103661420273305200203010ustar00rootroot00000000000000open Core (* Can't assign arbitrary types to ref *) type foo let r = Ref.Permissioned.create 0 (* This is to force the [Core]'s cmi to be loaded so that error messages below look nicer with OCaml 4.08. *) module type M = module type of Core let r' : (int, foo) Ref.Permissioned.t = r [%%expect {| Line _, characters _-_: Error: This expression has type (int, [< 'b perms ] as 'a) Ref.Permissioned.t but an expression was expected of type (int, foo) Ref.Permissioned.t Type 'a = [< `Read | `Who_can_write of 'b ] is not compatible with type foo |}] (* Can't set a ref if some version has been made immutable *) let r = Ref.Permissioned.create 0 let r_immutable : (int, immutable) Ref.Permissioned.t = r let () = Ref.Permissioned.set r 1 [%%expect {| Line _, characters _-_: Error: This expression has type * (glob) but an expression was expected of type * (glob) Type Perms.nobody perms = [ `Read | `Who_can_write of Perms.nobody ] is not compatible with type 'a = [> `Who_can_write of Perms.me ] Types for tag `Who_can_write are incompatible |}] (* Can't make a ref immutable if it's been set *) let r = Ref.Permissioned.create 0 let () = Ref.Permissioned.set r 1 let r_immutable : (int, immutable) Ref.Permissioned.t = r [%%expect {| Line _, characters _-_: Error: This expression has type * (glob) but an expression was expected of type (int, immutable) Ref.Permissioned.t Type 'a = [< `Read | `Who_can_write of Perms.me > `Who_can_write ] is not compatible with type immutable = [ `Read | `Who_can_write of Perms.nobody ] Types for tag `Who_can_write are incompatible |}] (* The following tests are not tests of things that we don't want to compile. They document reasons why we didn't use constraints in the usage of the new permission types, and if they ever start compiling, we might want to revisit them. *) (* Constraints don't work with included signatures, part 1 *) module type Container = sig type ('a, -'perm) t val iter : ('a, [> read ]) t -> f:('a -> unit) -> unit end type ('a, -'perm) t constraint 'perm = [< _ perms ] module type Foo = Container with type ('a, 'perm) t := ('a, 'perm) t [%%expect {| Line _, characters _-_: Error: In this `with' constraint, the new definition of t does not match its original definition in the constrained signature: Type declarations do not match: type ('a, 'b) t = ('a, 'b) t constraint 'b = \[< `Read | `Who_can_write of .* \] (regexp) is not included in type ('a, -'perm) t Their constraints differ. *: Expected declaration (glob) *: Actual declaration (glob) |}] (* Constraints don't work with included signatures, part 2 *) module type Container = sig type ('a, -'perm) t constraint 'perm = [< _ perms ] val iter : ('a, [> read ]) t -> f:('a -> unit) -> unit end type ('a, -'perm) t constraint 'perm = [< _ perms ] module type Foo = Container with type ('a, 'perm) t := ('a, 'perm) t [%%expect {| Line _, characters _-_: Error: In this `with' constraint, the new definition of t does not match its original definition in the constrained signature: Type declarations do not match: type ('a, 'b) t = ('a, 'b) t constraint 'b = \[< `Read | `Who_can_write of .* \] (regexp) is not included in type ('a, -'b) t constraint 'b = [< 'c perms ] Their constraints differ. *: Expected declaration (glob) *: Actual declaration (glob) |}] (* Constraints don't work with type aliases, part 1 *) type -'perm t constraint 'perm = [< _ perms ] type 'perm alias = 'perm t [%%expect {| Line _, characters _-_: Error: Constraints are not satisfied in this type. Type \[< `Read | `Who_can_write of .* \] t (regexp) should be an instance of \[< .* Core.perms \] t (regexp) |}] (* Constraints don't work with type aliases, part 2 *) type -'perm t constraint 'perm = [< _ perms ] type 'perm alias = 'perm t constraint 'perm = [< _ perms ] [%%expect {| Line _, characters _-_: Error: Constraints are not satisfied in this type. Type \[< `Read | `Who_can_write of .* \] t (regexp) should be an instance of \[< .* Core.perms \] t (regexp) |}] core-0.15.0/core/test/bin/test-type-distinctions.mlt000066400000000000000000000013071420273305200223670ustar00rootroot00000000000000(* -*- tuareg -*- *) open Core let () = let added = ref false in let tree = Avltree.add Avltree.empty ~key:0 ~data:(`A "Hello, world!") ~compare ~added ~replace:true in let x : (int, [ `A of string ]) Avltree.t = tree in let y = Avltree.add tree ~key:0 ~data:(`B 0) ~compare ~added ~replace:true in ignore (y : (_, _) Avltree.t); match Avltree.find x 0 ~compare with | None -> assert false | Some (`A str) -> print_string str ;; (* BOOM! *) [%%expect {| Line _, characters _-_: Error: This expression has type [> `B of int ] but an expression was expected of type [ `A of string ] The second variant type does not allow tag(s) `B |}] core-0.15.0/core/test/bin/test-validated.mlt000066400000000000000000000017461420273305200206420ustar00rootroot00000000000000open! Core module Positive_int = Validated.Make (struct type t = int [@@deriving sexp] let here = [%here] let validate t = if Int.( > ) t 0 then Validate.pass else Validate.fail "must be positive" ;; end) module Negative_int = Validated.Make (struct type t = int [@@deriving sexp] let here = [%here] let validate t = if Int.( < ) t 0 then Validate.pass else Validate.fail "must be negative" ;; end) let (_ : (Positive_int.t, Negative_int.t) Type_equal.t) = T [%%expect {| Line _, characters _-_: Error: This expression has type (Positive_int.t, Positive_int.t) Type_equal.t but an expression was expected of type (Positive_int.t, Negative_int.t) Type_equal.t Type Positive_int.t = (int, Positive_int.witness) Validated.t is not compatible with type Negative_int.t = (int, Negative_int.witness) Validated.t Type Positive_int.witness is not compatible with type Negative_int.witness |}] core-0.15.0/core/test/bin/test.ml000066400000000000000000000021511420273305200165120ustar00rootroot00000000000000open OUnit let rec flatten_list acc = function | [] -> acc | (TestCase _ as r) :: rest -> flatten_list (r :: acc) rest | TestList l :: rest -> let acc = flatten_list acc l in flatten_list acc rest | TestLabel (lbl, test) :: rest -> flatten_list (TestLabel (lbl, flatten test) :: acc) rest and flatten = function | TestCase _ as res -> res | TestLabel (s, test) -> TestLabel (s, flatten test) | TestList l -> TestList (List.rev (flatten_list [] l)) ;; let all () = flatten (TestList [ Avltree_test.test ; Bag_test.test ; Blang_test.test ; Common_test.test ; Comparable_test.test ; Doubly_linked_test.test ; Float_test_ounit.test ; Fdeque_test.test ; Int_conversions_test.test ; Core_char_test.test ; Core_int_test.test ; Core_array_test.test ; Core_filename_test.test ; Core_map_test.test ; Core_set_test.test ; Core_queue_test.test ; Core_string_test.test ; PMap_test.test ; PSet_test.test ; Union_find_test.test ; Validate_test.test ]) ;; core-0.15.0/core/test/bin/test_runner.ml000066400000000000000000000020231420273305200201010ustar00rootroot00000000000000open Core open OUnit let rec count acc = function | TestCase _ -> acc + 1 | TestLabel (_, test) -> count acc test | TestList l -> List.fold_left l ~f:count ~init:acc ;; let count_pa_ounit = function | TestList l -> List.fold_left l ~f:(fun (pa_ounit, total) test -> match test with | TestLabel (s, tst) when String.is_suffix ~suffix:".ml" s -> let cnt = count 0 tst in pa_ounit + cnt, total + cnt | test -> pa_ounit, count total test) ~init:(0, 0) | v -> 0, count 0 v ;; let main () = let cnt_ounit = ( "-cnt" , Arg.Unit (fun () -> let pa_ounit, total = count_pa_ounit (Test.all ()) in Printf.printf "converted: %i total: %i\n%!" pa_ounit total; exit 0) , " Count how many of the tests were converted to pa_ounit (for informational \ purposes only)" ) in ignore (run_test_tt_main ~arg_specs:[ cnt_ounit ] (Test.all ()) : OUnit.test_result list) ;; let () = Exn.handle_uncaught ~exit:true main core-0.15.0/core/test/bin/uncaught_exception_test.sh000077500000000000000000000001211420273305200224660ustar00rootroot00000000000000#!/bin/bash diff -u just_raise.expected-output <(./just_raise.exe 2>&1) exit $? core-0.15.0/core/test/bin/union_find_test.ml000066400000000000000000000020701420273305200207220ustar00rootroot00000000000000open OUnit open Core open Union_find let test = "union_find" >::: [ ("all" >:: fun () -> let t1 = create 13 in assert (get t1 = 13); set t1 15; assert (get t1 = 15); assert (same_class t1 t1); let t2 = create 17 in assert (not (same_class t1 t2)); union t1 t2; assert (same_class t1 t1); assert (same_class t1 t2); assert (same_class t2 t2); assert (get t1 = get t2); assert (get t1 = 15 || get t1 = 17); let t3 = create 19 in union t1 t3; let t4 = create 21 in assert (not (same_class t3 t4)); union t1 t4; assert (same_class t3 t4)) ; ("zzz" >:: fun () -> let u1 = create () in let u2 = create () in let u3 = create () in let u4 = create () in union u1 u2; union u3 u4; union u2 u4; assert (same_class u1 u3)) ] ;; core-0.15.0/core/test/bin/validate_test.ml000066400000000000000000000102721420273305200203660ustar00rootroot00000000000000open Core open Poly open OUnit module V = Validate let test = "validate" >::: [ ("basic" >:: fun () -> ("bounds" @? let res = V.name_list "foo" [ V.name "ok" (Int.validate_bound ~min:(Incl 0) ~max:(Incl 100) 5) ; V.name "incl_lower" (Int.validate_bound ~min:(Incl 0) ~max:(Incl 100) (-1)) ; V.name "incl_lower" (Int.validate_bound ~min:(Incl 0) ~max:(Incl 100) 0) ; V.name "incl_upper" (Int.validate_bound ~min:(Incl 0) ~max:(Incl 100) 101) ; V.name "incl_upper" (Int.validate_bound ~min:(Incl 0) ~max:(Incl 100) 100) ; V.name "excl_lower" (Int.validate_bound ~min:(Excl 0) ~max:(Excl 100) 0) ; V.name "excl_upper" (Int.validate_bound ~min:(Excl 0) ~max:(Excl 100) 100) ; V.name "excl_lower" (Int.validate_bound ~min:(Excl 0) ~max:(Excl 100) 1) ; V.name "excl_upper" (Int.validate_bound ~min:(Excl 0) ~max:(Excl 100) 99) ] in let expected = [ "(foo.incl_lower \"value -1 < bound 0\")" ; "(foo.incl_upper \"value 101 > bound 100\")" ; "(foo.excl_lower \"value 0 <= bound 0\")" ; "(foo.excl_upper \"value 100 >= bound 100\")" ] in List.sort ~compare:Poly.ascending (V.errors res) = List.sort ~compare:Poly.ascending expected); ("inf/nan" @? let res = V.name_list "bar" [ V.name "ok" (Float.validate_bound ~min:(Incl 0.) ~max:(Incl 100.) 5.) ; V.name "nan" (Float.validate_bound ~min:(Incl 0.) ~max:(Incl 100.) Float.nan) ; V.name "inf" (Float.validate_bound ~min:(Incl 0.) ~max:(Incl 100.) Float.infinity) ] in let expected = [ "(bar.nan \"value is NaN\")"; "(bar.inf \"value is infinite\")" ] in List.sort ~compare:Poly.ascending (V.errors res) = List.sort ~compare:Poly.ascending expected); ("nesting" @? let res = V.name_list "nesting" [ V.name "ok" (Float.validate_bound ~min:(Incl 0.) ~max:(Incl 100.) 5.) ; V.name "top" (Float.validate_ordinary Float.nan) ; V.name_list "sub0" [ V.name "sub1" (Float.validate_ordinary Float.nan) ; V.name "sub2" (Float.validate_ordinary Float.nan) ; V.name_list "sub3" [ V.name "sub4" (Float.validate_ordinary Float.nan) ; V.name "sub5" (Float.validate_ordinary Float.nan) ] ] ] in let expected = [ "(nesting.top \"value is NaN\")" ; "(nesting.sub0.sub1 \"value is NaN\")" ; "(nesting.sub0.sub2 \"value is NaN\")" ; "(nesting.sub0.sub3.sub4 \"value is NaN\")" ; "(nesting.sub0.sub3.sub5 \"value is NaN\")" ] in List.sort ~compare:Poly.ascending (V.errors res) = List.sort ~compare:Poly.ascending expected); "empty" @? let res = V.name_list "" [ V.name "ok1" (Float.validate_bound ~min:(Incl 0.) ~max:(Incl 100.) 5.) ; V.name "ok2" (Float.validate_bound ~min:(Incl 0.) ~max:(Incl 100.) 6.) ; V.name_list "sub" [ V.name "ok3" (Float.validate_bound ~min:(Incl 0.) ~max:(Incl 100.) 22.) ; V.name "ok4" (Float.validate_bound ~min:(Incl 0.) ~max:(Incl 100.) 36.) ] ] in let expected = [] in List.sort ~compare:Poly.ascending (V.errors res) = List.sort ~compare:Poly.ascending expected) ] ;; core-0.15.0/core/test/src/000077500000000000000000000000001420273305200152215ustar00rootroot00000000000000core-0.15.0/core/test/src/binable_and_sexpable_unit_tests.ml000066400000000000000000000114131420273305200241350ustar00rootroot00000000000000open! Core module Sexpable = Sexpable.Stable module Binable = Binable.Stable let%test_module _ = (module struct let old_style = !Sexp.of_int_style let () = Sexp.of_int_style := `No_underscores let int_tests = [ ~-1, "-1", "\002-1"; 0, "0", "\0010"; 1, "1", "\0011" ] @ if Sys.word_size_in_bits = 64 then [ Int.min_value, "-4611686018427387904", "\020-4611686018427387904" ; Int.min_value / 2, "-2305843009213693952", "\020-2305843009213693952" ; Int.max_value / 2, "2305843009213693951", "\0192305843009213693951" ; Int.max_value, "4611686018427387903", "\0194611686018427387903" ] else [] ;; (* S0 *) module _ = Stable_unit_test.Make (struct module T = struct type t = int [@@deriving compare] include Sexpable.Of_sexpable.V1 (String) (struct type t = int let to_sexpable = string_of_int let of_sexpable = int_of_string end) include Binable.Of_binable.V1 [@alert "-legacy"] (String) (struct type t = int let to_binable = string_of_int let of_binable = int_of_string end) end type t = T.t [@@deriving bin_io, compare, sexp] let equal a b = Int.( = ) 0 ([%compare: t] a b) let tests = int_tests end) module _ = Stable_unit_test.Make (struct module T = struct type 'a t = 'a option [@@deriving compare] include Sexpable.Of_sexpable1.V1 (List) (struct type 'a t = 'a option let to_sexpable = Option.to_list let of_sexpable = List.hd end) include Binable.Of_binable1.V1 [@alert "-legacy"] (List) (struct type 'a t = 'a option let to_binable = Option.to_list let of_binable = List.hd end) end type t = int T.t [@@deriving bin_io, compare, sexp] let equal a b = Int.( = ) 0 ([%compare: t] a b) let tests = [ None, "()", "\000" ; Some 1, "(1)", "\001\001" ; Some 1_000, "(1000)", "\001\254\232\003" ; Some ~-1, "(-1)", "\001\255\255" ] ;; end) module _ = Stable_unit_test.Make (struct module T = struct type ('a, 'b) t = ('a, 'b) Either.Stable.V1.t [@@deriving compare] module Format = struct type ('a, 'b) t = | Left of 'a | Right of 'b [@@deriving bin_io, sexp] let of_t = function | First x -> Left x | Second x -> Right x ;; let to_t = function | Left x -> First x | Right x -> Second x ;; end include Sexpable.Of_sexpable2.V1 (Format) (struct type nonrec ('a, 'b) t = ('a, 'b) t let to_sexpable = Format.of_t let of_sexpable = Format.to_t end) include Binable.Of_binable2.V1 [@alert "-legacy"] (Format) (struct type nonrec ('a, 'b) t = ('a, 'b) t let to_binable = Format.of_t let of_binable = Format.to_t end) end type t = (int, string) T.t [@@deriving bin_io, compare, sexp] let equal a b = Int.( = ) 0 ([%compare: t] a b) let tests = [ First 1, "(Left 1)", "\000\001" ; First 0, "(Left 0)", "\000\000" ; Second "", "(Right \"\")", "\001\000" ; Second "second", "(Right second)", "\001\006second" ] @ if Sys.word_size_in_bits = 64 then [ ( First Int.min_value , "(Left -4611686018427387904)" , "\000\252\000\000\000\000\000\000\000\192" ) ] else [] ;; end) (* Of_stringable *) module _ = Stable_unit_test.Make (struct type t = int include Sexpable.Of_stringable.V1 (Int) include Binable.Of_stringable.V1 [@alert "-legacy"] (Int) let equal = Poly.( = ) let tests = int_tests end) module _ = struct module T = struct type t = int [@@deriving bin_io, sexp] end include Sexpable.To_stringable.V1 (T) let%test_unit _ = List.iter int_tests ~f:(fun (t, s, _) -> [%test_eq: int] t (of_string s); [%test_eq: string] (to_string t) s) ;; end let () = Sexp.of_int_style := old_style end) ;; core-0.15.0/core/test/src/binable_and_sexpable_unit_tests.mli000066400000000000000000000000551420273305200243060ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/bool_tests.ml000066400000000000000000000040411420273305200177270ustar00rootroot00000000000000open! Core open Expect_test_helpers_core let%test_module "[of_string_hum]" = (module struct let variations_of_string string = String.Set.of_list [ string ; String.lowercase string ; String.uppercase string ; String.capitalize (String.lowercase string) ; String.uncapitalize (String.uppercase string) ; String.lowercase (String.prefix string 1) ; String.uppercase (String.prefix string 1) ] ;; let%expect_test "success" = let test string ~expect = (* skip memoized allocation *) ignore (Or_error.try_with (fun () -> Bool.of_string_hum string) : bool Or_error.t); Set.iter (variations_of_string string) ~f:(fun string -> match require_no_allocation [%here] (fun () -> Bool.of_string_hum string) with | actual -> require_equal [%here] (module Bool) actual expect | exception exn -> print_cr [%here] [%message "raised" (string : string) (exn : exn)]) in List.iter ~f:(test ~expect:true) [ "true"; "yes"; "1" ]; [%expect {| |}]; List.iter ~f:(test ~expect:false) [ "false"; "no"; "0" ]; [%expect {| |}] ;; let%expect_test "failure" = (* print the exception once *) require_does_raise [%here] (fun () -> Bool.of_string_hum ""); [%expect {| ("Bool.of_string_hum: invalid input" (input "") (expected_case_insensitive (0 1 f false n no t true y yes))) |}]; let test string = Set.iter (variations_of_string string) ~f:(fun string -> (* the single-character prefixes might work, so we skip them *) if String.length string > 1 then ( match Bool.of_string_hum string with | bool -> print_cr [%here] [%message "did not raise" (string : string) (bool : bool)] | exception _ -> ())) in List.iter ~f:test [ "abc"; "tru"; "truth"; "fals"; "falsey"; "0x0"; "01"; "123" ]; [%expect {| |}] ;; end) ;; core-0.15.0/core/test/src/bool_tests.mli000066400000000000000000000000551420273305200201010ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/core_gc_unit_tests.ml000066400000000000000000000076531420273305200214500ustar00rootroot00000000000000open! Core open! Gc let%test_module ("gc" [@tags "no-js"]) = (module struct (* The idea underlying this test is that minor_words does not allocate any memory. Hence the subsequent call to quick_stat should report exactly the same number. Also: 1) This test may fail if the float is so large that it cannot fit in a 64bit int. 2) We run this in a loop because the each call to [quick_stat] allocates minor_data and this number should be picked up by [minor_words] *) let%test_unit _ = for _ = 1 to 1000 do let mw1 = minor_words () in let st = quick_stat () in let mw2 = Float.iround_towards_zero_exn st.Stat.minor_words in assert (mw1 = mw2) done ;; (* The point of doing a [minor] in the tests below is that [st] is still live and will be promoted during the minor GC, thereby changing both the promoted words and the major words in each iteration of the loop *) let%test_unit _ = for _ = 1 to 1000 do let mw1 = major_words () in let st = quick_stat () in minor (); let mw2 = Float.iround_towards_zero_exn st.Stat.major_words in assert (mw1 = mw2) done ;; let%test_unit _ = for _ = 1 to 1000 do let mw1 = promoted_words () in let st = quick_stat () in minor (); let mw2 = Float.iround_towards_zero_exn st.Stat.promoted_words in assert (mw1 = mw2) done ;; let%test_unit _ = assert (major_words () + minor_words () = major_plus_minor_words ()) let stat_eq func projection = (* In the stub the record is allocated after getting the stats, so we must ensure [func] is called first. *) let x = func () in let y = projection (quick_stat ()) in x = y ;; let%test_unit _ = for _ = 1 to 1000 do assert (stat_eq minor_collections Stat.minor_collections); minor (); assert (stat_eq minor_collections Stat.minor_collections) done ;; let%test_unit _ = for _ = 1 to 250 do assert (stat_eq major_collections Stat.major_collections); major (); assert (stat_eq major_collections Stat.major_collections) done ;; let%test_unit _ = for _ = 1 to 250 do assert (stat_eq compactions Stat.compactions); compact (); assert (stat_eq compactions Stat.compactions) done ;; let%test_unit _ = let check () = assert (stat_eq heap_chunks Stat.heap_chunks); assert (stat_eq heap_words Stat.heap_words); assert (stat_eq top_heap_words Stat.top_heap_words) in check (); let r = ref [] in let n = heap_chunks () in while not (heap_chunks () > n) do check (); r := Bytes.create 128 :: !r done; (* Don't let flambda2 drop r, producing an infinite loop *) let _ = (Sys.opaque_identity !r : bytes list) in check () ;; let%test "is_zero_alloc does not allocate" = let open Gc.For_testing in is_zero_alloc (fun () -> ignore (is_zero_alloc Fn.id : bool)) ;; end) ;; let%test_unit _ = let r = ref () in let weak = Caml.Weak.create 1 in Caml.Weak.set weak 0 (Some r); Caml.Gc.compact (); assert ( match Caml.Weak.get weak 0 with | None -> false | Some _ -> true); keep_alive (r, r) ;; let%expect_test "stat diff" = let before = Gc.stat () in let after = { before with minor_words = before.minor_words +. 100. ; compactions = before.compactions + 7 } in print_s [%sexp (Gc.Stat.diff after before : Gc.Stat.t)]; [%expect {| ((minor_words 100) (promoted_words 0) (major_words 0) (minor_collections 0) (major_collections 0) (heap_words 0) (heap_chunks 0) (live_words 0) (live_blocks 0) (free_words 0) (free_blocks 0) (largest_free 0) (fragments 0) (compactions 7) (top_heap_words 0) (stack_size 0) (forced_major_collections 0)) |}] ;; core-0.15.0/core/test/src/core_gc_unit_tests.mli000066400000000000000000000000551420273305200216060ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/core_int63_unit_tests.ml000066400000000000000000000154361420273305200220200ustar00rootroot00000000000000open Core module Make_tests (Int : Base.Int.S) : sig end = struct open Int let p1 = of_int64_exn 1L let p2 = of_int64_exn 2L let p3 = of_int64_exn 3L let p10 = of_int64_exn 10L let n1 = of_int64_exn (-1L) let n2 = of_int64_exn (-2L) let n3 = of_int64_exn (-3L) let n10 = of_int64_exn (-10L) let%test_unit _ = [%test_eq: int64] (to_int64 (p2 + p2)) 4L let%test_unit _ = [%test_eq: int64] (to_int64 (max_value + p1)) (to_int64 min_value) let%test_unit _ = [%test_eq: int64] (to_int64 (max_value + max_value)) (-2L) let%test_unit _ = [%test_eq: int64] (to_int64 (p2 - p2)) 0L let%test_unit _ = [%test_eq: int64] (to_int64 (min_value - one)) (to_int64 max_value) let%test_unit _ = [%test_eq: int64] (to_int64 (min_value - min_value)) 0L let%test_unit _ = [%test_eq: int64] (to_int64 (p2 * p2)) 4L let%test_unit _ = [%test_eq: int64] (to_int64 (max_value * p2)) (-2L) let%test_unit _ = [%test_eq: int64] (to_int64 (min_value * p2)) 0L let%test_unit _ = [%test_eq: int64] (to_int64 (max_value * max_value)) 1L let%test_unit _ = [%test_eq: int64] (to_int64 (min_value * min_value)) 0L let%test_unit _ = [%test_eq: int64] (to_int64 (p10 / p2)) 5L let%test_unit _ = [%test_eq: int64] (to_int64 (n10 / p2)) (-5L) let%test_unit _ = [%test_eq: int64] (to_int64 (n10 / n2)) 5L let%test_unit _ = [%test_eq: int64] (to_int64 (min_value / n1)) (to_int64 min_value) let%test_unit _ = [%test_eq: int64] (to_int64 (min_value / n2)) 2305843009213693952L let%test_unit _ = [%test_eq: int64] (to_int64 (rem p3 p2)) 1L let%test_unit _ = [%test_eq: int64] (to_int64 (rem n3 p2)) (-1L) let%test_unit _ = [%test_eq: int64] (to_int64 (rem p3 n2)) 1L let%test_unit _ = [%test_eq: int64] (to_int64 (rem max_value min_value)) (to_int64 max_value) ;; let%test_unit _ = [%test_eq: int64] (to_int64 (rem min_value max_value)) (-1L) let%test_unit _ = [%test_eq: int64] (to_int64 (abs min_value)) (to_int64 min_value) let%test_unit _ = [%test_eq: int64] (to_int64 (abs (min_value + p1))) (to_int64 max_value) ;; let%test_unit _ = [%test_eq: int64] (to_int64 (bit_not n1)) 0L let%test_unit _ = [%test_eq: int64] (to_int64 (bit_not zero)) (-1L) let%test_unit _ = [%test_eq: int64] (to_int64 (bit_and p1 p1)) 1L let%test_unit _ = [%test_eq: int64] (to_int64 (bit_and p1 p2)) 0L let%test_unit _ = [%test_eq: int64] (to_int64 (bit_xor p1 p1)) 0L let%test_unit _ = [%test_eq: int64] (to_int64 (bit_xor p1 p3)) 2L let%test_unit _ = [%test_eq: int64] (to_int64 (bit_or p1 p1)) 1L let%test_unit _ = [%test_eq: int64] (to_int64 (bit_or p1 p3)) 3L let%test_unit _ = [%test_eq: int64] (to_int64 (pow n2 (of_int64_exn 61L))) (-2305843009213693952L) ;; let%test_unit _ = [%test_eq: int64] (to_int64 (pow p2 (of_int64_exn 61L))) 2305843009213693952L ;; let%test_unit _ = [%test_eq: int64] (to_int64 (pow p10 (of_int64_exn 15L))) 1000000000000000L ;; let assert_raise f = try ignore (f () : t); false with | _ -> true ;; let%test _ = assert_raise (fun () -> pow p2 (of_int64_exn 62L)) let%test _ = assert_raise (fun () -> pow n2 (of_int64_exn 62L)) let%test_unit _ = [%test_eq: t] (of_string "0x4000") (of_int64_exn 0x4000L) let%test_unit _ = [%test_eq: t] (of_string "0x4000_0000_0000_0000") min_value let%test_unit _ = [%test_eq: t] (of_string "-0x4000_0000_0000_0000") min_value let%test_unit _ = [%test_eq: t] (of_string "0x3fff_ffff_ffff_ffff") max_value let%test_unit _ = [%test_eq: t] (of_string "-0x3fff_ffff_ffff_ffff") (min_value + one) let%test_unit _ = [%test_eq: t] (of_string "0o777777777777777777777") (neg one) let%test _ = assert_raise (fun () -> of_string "0xffff_ffff_ffff_ffff") let%test _ = assert_raise (fun () -> of_string (Int64.to_string 0x7fff_ffff_ffff_ffffL)) let%test _ = assert_raise (fun () -> of_string "0o1111111111111111111111") let%test_unit _ = [%test_result: int] (popcount zero) ~expect:0 let%test_unit _ = [%test_result: int] (popcount one) ~expect:1 let%test_unit _ = [%test_result: int] (popcount minus_one) ~expect:63 let%test_unit _ = [%test_result: int] (popcount max_value) ~expect:62 let%test_unit _ = [%test_result: int] (popcount min_value) ~expect:1 let%test_unit _ = [%test_result: string] (Hex.to_string max_value) ~expect:"0x3fffffffffffffff" ;; let%test_unit _ = [%test_result: string] (Hex.to_string (max_value - one)) ~expect:"0x3ffffffffffffffe" ;; let%test_unit _ = [%test_result: string] (Hex.to_string min_value) ~expect:"-0x4000000000000000" ;; let%test_unit _ = [%test_result: string] (Hex.to_string (min_value + one)) ~expect:"-0x3fffffffffffffff" ;; let%test_unit _ = [%test_result: string] (Hex.to_string zero) ~expect:"0x0" let%test_unit _ = [%test_result: string] (Hex.to_string one) ~expect:"0x1" let%test_unit _ = [%test_result: string] (Hex.to_string (neg one)) ~expect:"-0x1" let%test_unit _ = [%test_result: t] (Hex.of_string "0x3fffffffffffffff") ~expect:max_value ;; let%test_unit _ = [%test_result: t] (Hex.of_string "0x3ffffffffffffffe") ~expect:(max_value - one) ;; let%test_unit _ = [%test_result: t] (Hex.of_string "-0x4000000000000000") ~expect:min_value ;; let%test_unit _ = [%test_result: t] (Hex.of_string "-0x3fffffffffffffff") ~expect:(min_value + one) ;; let%test_unit _ = [%test_result: t] (Hex.of_string "0x0") ~expect:zero let%test_unit _ = [%test_result: t] (Hex.of_string "0x1") ~expect:one let%test_unit _ = [%test_result: t] (Hex.of_string "-0x1") ~expect:(neg one) let%test_unit _ = if Core.Int.( = ) Sys.word_size_in_bits 64 then [%test_result: t] (of_string "0u4611686018427387904") ~expect:min_value ;; end let%test_module "Int63_emul" = (module Make_tests (Base.Int63.Private.Emul)) let%test_module "Int63_maybe_native" = (module Make_tests (Int63)) module Make_tests_bin_io (B : sig type t = Int63.t [@@deriving bin_io] end) : sig end = struct let test int63 str = let open Int63 in let s = B.bin_size_t int63 in let bs = Bigstring.create s in let _pos = B.bin_write_t bs ~pos:0 int63 in let str_2 = Bigstring.to_string bs in let bs_2 = Bigstring.of_string str in let int63_2 = B.bin_read_t bs_2 ~pos_ref:(ref 0) in [%test_eq: string] str str_2; [%test_eq: t] int63 int63_2 ;; let%test_unit _ = let open Int63 in test min_value "\252\000\000\000\000\000\000\000\192"; test max_value "\252\255\255\255\255\255\255\255?"; test zero "\000"; test one "\001"; test (neg one) "\255\255" ;; let%test _ = let open Bin_prot.Shape in Poly.( = ) (eval_to_digest_string B.bin_shape_t) (eval_to_digest_string bin_shape_int63) ;; end let%test_module "Int63_bin_io_maybe_native" = (module Make_tests_bin_io (Int63)) let%test_module "Int63_bin_io_maybe_native_stable" = (module Make_tests_bin_io (Int63.Stable.V1)) ;; core-0.15.0/core/test/src/core_int63_unit_tests.mli000066400000000000000000000000551420273305200221600ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/core_list_unit_tests.ml000066400000000000000000000731671420273305200220350ustar00rootroot00000000000000open! Core open! List module Shrinker = Quickcheck.Shrinker let%test_module "shrinker" = (module struct let t0 = Shrinker.create (fun v -> if Poly.( = ) 0 v then Sequence.empty else Sequence.singleton 0) ;; let test_list = [ 1; 2; 3 ] let expect = [ [ 2; 3 ]; [ 0; 2; 3 ]; [ 1; 3 ]; [ 1; 0; 3 ]; [ 1; 2 ]; [ 1; 2; 0 ] ] |> List.sort ~compare:[%compare: int list] ;; let rec recursive_list = 1 :: 5 :: recursive_list let%test_unit "shrinker produces expected outputs" = let shrunk = Shrinker.shrink (quickcheck_shrinker t0) test_list |> Sequence.to_list |> List.sort ~compare:[%compare: int list] in [%test_result: int list list] ~expect shrunk ;; let%test_unit "shrinker on infinite lists produces values" = let shrunk = Shrinker.shrink (quickcheck_shrinker t0) recursive_list in let result_length = Sequence.take shrunk 5 |> Sequence.to_list |> List.length in [%test_result: int] ~expect:5 result_length ;; end) ;; let%test_module "random" = (module struct module G = Quickcheck.Generator module type T = sig type t [@@deriving sexp_of] include Quickcheckable with type t := t include Comparable with type t := t val module_name : string end module type Math = sig type t include T with type t := t include Container.Summable with type t := t end module Make (T : T) (Math : Math) = struct open T open G.Monad_infix module Q = Quickcheck.Configure (struct include Quickcheck let default_trial_count = 1_000 let default_sizes = Sequence.cycle_list_exn (List.range 0 10 ~stop:`inclusive) let default_seed = `Deterministic (sprintf "%s values with %s operators." (String.capitalize T.module_name) (String.capitalize Math.module_name)) ;; end) let%test_unit "duplicates" = Q.test_distinct_values (List.quickcheck_generator quickcheck_generator) ~trials:1_000 ~distinct_values:500 ~sexp_of:[%sexp_of: t list] ~compare:[%compare: t list] ;; let%test_unit "mem true" = Q.test ~sexp_of:[%sexp_of: t * t list] (List.gen_non_empty quickcheck_generator >>= fun list -> G.of_list list >>| fun elt_of_list -> elt_of_list, list) ~f:(fun (elt_of_list, list) -> [%test_result: bool] (List.mem list elt_of_list ~equal) ~expect:true) ;; let%test_unit "mem false" = Q.test ~sexp_of:[%sexp_of: t * t list] (quickcheck_generator >>= fun x -> let not_x_gen = G.filter quickcheck_generator ~f:(fun y -> y <> x) in List.quickcheck_generator not_x_gen >>| fun list_of_not_x -> x, list_of_not_x) ~f:(fun (x, list_of_not_x) -> [%test_result: bool] (List.mem list_of_not_x x ~equal) ~expect:false) ;; let%test_unit "len" = Q.test ~sexp_of:[%sexp_of: int * t list] (G.small_non_negative_int >>= fun len -> List.gen_with_length len quickcheck_generator >>| fun list -> len, list) ~f:(fun (len, list) -> [%test_result: int] (List.length list) ~expect:len) ;; let%test_unit "is_empty true" = Q.test ~sexp_of:[%sexp_of: t list] (G.singleton []) ~f:(fun empty -> [%test_result: bool] (List.is_empty empty) ~expect:true) ;; let%test_unit "is_empty false" = Q.test ~sexp_of:[%sexp_of: t list] (G.tuple2 quickcheck_generator (List.quickcheck_generator quickcheck_generator) >>| fun (x, list) -> x :: list) ~f:(fun non_empty -> [%test_result: bool] (List.is_empty non_empty) ~expect:false) ;; let%test_unit "iter" = Q.test ~sexp_of:[%sexp_of: t list] (List.quickcheck_generator quickcheck_generator) ~f:(fun list -> let q = Queue.create () in List.iter list ~f:(Queue.enqueue q); [%test_result: t list] (Queue.to_list q) ~expect:list) ;; let%test_unit "sum vs fold" = Q.test ~sexp_of:[%sexp_of: t list * (t -> Math.t)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer Math.quickcheck_generator)) ~f:(fun (list, f) -> [%test_eq: Math.t] (List.fold list ~init:Math.zero ~f:(fun m x -> Math.( + ) m (f x))) (List.sum (module Math) list ~f)) ;; let%test_unit "for_all vs exists" = Q.test ~sexp_of:[%sexp_of: t list * (t -> bool)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer Bool.quickcheck_generator)) ~f:(fun (list, f) -> [%test_eq: bool] (List.for_all list ~f) (not (List.exists list ~f:(Fn.non f)))) ;; let%test_unit "exists vs mem" = Q.test ~sexp_of:[%sexp_of: t * t list] (G.tuple2 quickcheck_generator (List.quickcheck_generator quickcheck_generator)) ~f:(fun (x, list) -> [%test_eq: bool] (List.exists list ~f:(fun y -> equal x y)) (List.mem list x ~equal)) ;; let%test_unit "exists vs find" = Q.test ~sexp_of:[%sexp_of: t list * (t -> bool)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer Bool.quickcheck_generator)) ~f:(fun (list, f) -> [%test_eq: bool] (List.exists list ~f) (Option.is_some (List.find list ~f))) ;; let%test_unit "count vs length/filter" = Q.test ~sexp_of:[%sexp_of: t list * (t -> bool)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer Bool.quickcheck_generator)) ~f:(fun (list, f) -> [%test_eq: int] (List.count list ~f) (List.length (List.filter list ~f))) ;; let%test_unit "find vs find_map" = Q.test ~sexp_of:[%sexp_of: t list * (t -> bool)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer Bool.quickcheck_generator)) ~f:(fun (list, f) -> [%test_eq: t option] (List.find list ~f) (List.find_map list ~f:(fun x -> if f x then Some x else None))) ;; let%test_unit "to_list" = Q.test ~sexp_of:[%sexp_of: t list] (List.quickcheck_generator quickcheck_generator) ~f:(fun list -> [%test_result: t list] (List.to_list list) ~expect:list) ;; let%test_unit "to_array + Array.to_list" = Q.test ~sexp_of:[%sexp_of: t list] (List.quickcheck_generator quickcheck_generator) ~f:(fun list -> [%test_result: t list] (Array.to_list (List.to_array list)) ~expect:list) ;; let%test_unit "max_elt vs min_elt" = Q.test ~sexp_of:[%sexp_of: t list * (t -> t -> int)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.compare_fn quickcheck_observer)) ~f:(fun (list, cmp) -> [%test_eq: t option] (List.min_elt list ~compare:cmp) (List.max_elt list ~compare:(fun x y -> cmp y x))) ;; let%test_unit "return" = Q.test ~sexp_of:[%sexp_of: t] quickcheck_generator ~f:(fun x -> [%test_result: t list] (List.return x) ~expect:[ x ]) ;; let%test_unit "map vs bind" = Q.test ~sexp_of:[%sexp_of: t list * (t -> t)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer quickcheck_generator)) ~f:(fun (list, f) -> [%test_eq: t list] (List.map list ~f) (List.bind list ~f:(fun x -> [ f x ]))) ;; let%test_unit "monad left identity" = Q.test ~sexp_of:[%sexp_of: t * (t -> t list)] (G.tuple2 quickcheck_generator (G.fn quickcheck_observer (List.quickcheck_generator quickcheck_generator))) ~f:(fun (x, f) -> [%test_eq: t list] (List.bind (List.return x) ~f) (f x)) ;; let%test_unit "monad right identity" = Q.test ~sexp_of:[%sexp_of: t list] (List.quickcheck_generator quickcheck_generator) ~f:(fun list -> [%test_result: t list] (List.bind list ~f:List.return) ~expect:list) ;; let%test_unit ("monad associativity" [@tags "no-js"]) = Q.test ~sexp_of:[%sexp_of: t list * (t -> t list) * (t -> t list)] (G.tuple3 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer (List.quickcheck_generator quickcheck_generator)) (G.fn quickcheck_observer (List.quickcheck_generator quickcheck_generator))) ~f:(fun (list, f, g) -> [%test_eq: t list] (List.bind (List.bind list ~f) ~f:g) (List.bind list ~f:(fun x -> List.bind (f x) ~f:g))) ;; let%test_unit "join" = Q.test ~sexp_of:[%sexp_of: t list list] (List.quickcheck_generator (List.quickcheck_generator quickcheck_generator)) ~f:(fun list -> [%test_eq: t list] (List.join list) (List.bind list ~f:Fn.id)) ;; let%test_unit "ignore" = Q.test ~sexp_of:[%sexp_of: t list] (List.quickcheck_generator quickcheck_generator) ~f:(fun list -> [%test_eq: unit list] (List.ignore_m list) (List.map list ~f:ignore)) ;; let%test_unit "of_list + to_list" = Q.test ~sexp_of:[%sexp_of: t list] (List.quickcheck_generator quickcheck_generator) ~f:(fun list -> [%test_result: t list] (List.of_list list) ~expect:list) ;; let%test_unit "nth vs nth_exn" = Q.test ~sexp_of:[%sexp_of: int * t list] (G.tuple2 G.small_non_negative_int (List.quickcheck_generator quickcheck_generator)) ~f:(fun (i, list) -> [%test_eq: t option] (List.nth list i) (Option.try_with (fun () -> List.nth_exn list i))) ;; let%test_unit "init + nth_exn" = Q.test ~sexp_of:[%sexp_of: int * int * (int -> t)] (G.small_non_negative_int >>= fun size -> let size = size + 1 in G.tuple3 (G.return size) (Int.gen_incl 0 (size - 1)) (G.fn Int.quickcheck_observer quickcheck_generator)) ~f:(fun (size, i, f) -> [%test_result: t] (List.nth_exn (List.init size ~f) i) ~expect:(f i)) ;; let%test_unit "rev^2" = Q.test ~sexp_of:[%sexp_of: t list] (List.quickcheck_generator quickcheck_generator) ~f:(fun list -> [%test_result: t list] (List.rev (List.rev list)) ~expect:list) ;; let%test_unit "rev_append vs rev + append" = Q.test ~sexp_of:[%sexp_of: t list * t list] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (List.quickcheck_generator quickcheck_generator)) ~f:(fun (list1, list2) -> [%test_eq: t list] (List.rev_append list1 list2) (List.append (List.rev list1) list2)) ;; let%test_unit "unordered_append vs append" = Q.test ~sexp_of:[%sexp_of: t list * t list * t] (G.tuple3 (List.quickcheck_generator quickcheck_generator) (List.quickcheck_generator quickcheck_generator) quickcheck_generator) ~f:(fun (list1, list2, x) -> [%test_eq: bool] (List.mem (List.append list1 list2) x ~equal) (List.mem (List.unordered_append list1 list2) x ~equal)) ;; let%test_unit "rev_map vs map + rev" = Q.test ~sexp_of:[%sexp_of: t list * (t -> t)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer quickcheck_generator)) ~f:(fun (list, f) -> [%test_eq: t list] (List.rev_map list ~f) (List.rev (List.map list ~f))) ;; let%test_unit "fold vs fold_left" = Q.test ~sexp_of:[%sexp_of: t list * t * (t -> t -> t)] (G.tuple3 (List.quickcheck_generator quickcheck_generator) quickcheck_generator (G.fn2 quickcheck_observer quickcheck_observer quickcheck_generator)) ~f:(fun (list, init, f) -> [%test_eq: t] (List.fold list ~init ~f) (List.fold_left list ~init ~f)) ;; let%test_unit "unzip + iter2_exn vs iter" = Q.test ~sexp_of:[%sexp_of: (t * t) list * (t -> t -> t)] (G.tuple2 (List.quickcheck_generator (G.tuple2 quickcheck_generator quickcheck_generator)) (G.fn2 quickcheck_observer quickcheck_observer quickcheck_generator)) ~f:(fun (pair_list, f) -> [%test_eq: t list] (let q = Queue.create () in let list1, list2 = List.unzip pair_list in List.iter2_exn list1 list2 ~f:(fun x y -> Queue.enqueue q (f x y)); Queue.to_list q) (let q = Queue.create () in List.iter pair_list ~f:(fun (x, y) -> Queue.enqueue q (f x y)); Queue.to_list q)) ;; let%test_unit "rev_map2_exn vs rev + map2_exn" = Q.test ~sexp_of:[%sexp_of: (t * t) list * (t -> t -> t)] (G.tuple2 (List.quickcheck_generator (G.tuple2 quickcheck_generator quickcheck_generator)) (G.fn2 quickcheck_observer quickcheck_observer quickcheck_generator)) ~f:(fun (pair_list, f) -> let list1, list2 = List.unzip pair_list in [%test_eq: t list] (List.rev_map2_exn list1 list2 ~f) (List.rev (List.map2_exn list1 list2 ~f))) ;; let%test_unit "unzip + fold2_exn + fold" = Q.test ~sexp_of:[%sexp_of: (t * t) list * t * (t -> t -> t -> t)] (G.tuple3 (List.quickcheck_generator (G.tuple2 quickcheck_generator quickcheck_generator)) quickcheck_generator (G.fn3 quickcheck_observer quickcheck_observer quickcheck_observer quickcheck_generator)) ~f:(fun (pair_list, init, f) -> let list1, list2 = List.unzip pair_list in [%test_eq: t] (List.fold2_exn list1 list2 ~init ~f) (List.fold (List.zip_exn list1 list2) ~init ~f:(fun acc (x, y) -> f acc x y))) ;; let%test_unit "unzip + for_all2_exn vs for_all" = Q.test ~sexp_of:[%sexp_of: (t * t) list * (t -> t -> bool)] (G.tuple2 (List.quickcheck_generator (G.tuple2 quickcheck_generator quickcheck_generator)) (G.fn2 quickcheck_observer quickcheck_observer Bool.quickcheck_generator)) ~f:(fun (pair_list, f) -> [%test_eq: bool] (let list1, list2 = List.unzip pair_list in List.for_all2_exn list1 list2 ~f) (List.for_all pair_list ~f:(fun (x, y) -> f x y))) ;; let%test_unit "unzip + exists2_exn vs exists" = Q.test ~sexp_of:[%sexp_of: (t * t) list * (t -> t -> bool)] (G.tuple2 (List.quickcheck_generator (G.tuple2 quickcheck_generator quickcheck_generator)) (G.fn2 quickcheck_observer quickcheck_observer Bool.quickcheck_generator)) ~f:(fun (pair_list, f) -> [%test_eq: bool] (let list1, list2 = List.unzip pair_list in List.exists2_exn list1 list2 ~f) (List.exists pair_list ~f:(fun (x, y) -> f x y))) ;; let%test_unit "filter vs for_all" = Q.test ~sexp_of:[%sexp_of: t list * (t -> bool)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer Bool.quickcheck_generator)) ~f:(fun (list, f) -> [%test_result: bool] (List.for_all ~f (List.filter ~f list)) ~expect:true) ;; let%test_unit "filter true" = Q.test ~sexp_of:[%sexp_of: t list] (List.quickcheck_generator quickcheck_generator) ~f:(fun list -> [%test_result: t list] (List.filter list ~f:(const true)) ~expect:list) ;; let%test_unit "filter vs rev_filter" = Q.test ~sexp_of:[%sexp_of: t list * (t -> bool)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer Bool.quickcheck_generator)) ~f:(fun (list, f) -> [%test_eq: t list] (List.rev (List.filter list ~f)) (List.rev_filter list ~f)) ;; let%test_unit "filteri vs filter" = Q.test ~sexp_of:[%sexp_of: t list * (t -> bool)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer Bool.quickcheck_generator)) ~f:(fun (list, f) -> [%test_eq: t list] (List.filter list ~f) (List.filteri list ~f:(fun _ x -> f x))) ;; let%test_unit "partition_map vs filter_map" = let partition_of_variant = function | `A a -> First a | `B b -> Second b in Q.test ~sexp_of:[%sexp_of: t list * (t -> (t, t) Either.t)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer (G.variant2 quickcheck_generator quickcheck_generator >>| partition_of_variant))) ~f:(fun (list, f) -> [%test_eq: t list * t list] (List.partition_map list ~f) ( List.filter_map list ~f:(fun x -> match f x with | First x -> Some x | Second _ -> None) , List.filter_map list ~f:(fun x -> match f x with | First _ -> None | Second x -> Some x) )) ;; let%test_unit "partition3_map vs filter_map" = let partition_of_variant = function | `A a -> `Fst a | `B b -> `Snd b | `C c -> `Trd c in Q.test ~sexp_of:[%sexp_of: t list * (t -> [ `Fst of t | `Snd of t | `Trd of t ])] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer (G.variant3 quickcheck_generator quickcheck_generator quickcheck_generator >>| partition_of_variant))) ~f:(fun (list, f) -> [%test_eq: t list * t list * t list] (List.partition3_map list ~f) ( List.filter_map list ~f:(fun x -> match f x with | `Fst x -> Some x | `Snd _ -> None | `Trd _ -> None) , List.filter_map list ~f:(fun x -> match f x with | `Fst _ -> None | `Snd x -> Some x | `Trd _ -> None) , List.filter_map list ~f:(fun x -> match f x with | `Fst _ -> None | `Snd _ -> None | `Trd x -> Some x) )) ;; let%test_unit "partition_tf vs partition_map" = Q.test ~sexp_of:[%sexp_of: t list * (t -> bool)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer Bool.quickcheck_generator)) ~f:(fun (list, f) -> [%test_eq: t list * t list] (List.partition_tf list ~f) (List.partition_map list ~f:(fun x -> if f x then First x else Second x))) ;; let%test_unit "append + split_n" = Q.test ~sexp_of:[%sexp_of: t list * t list] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (List.quickcheck_generator quickcheck_generator)) ~f:(fun (list1, list2) -> [%test_result: t list * t list] (List.split_n (List.append list1 list2) (List.length list1)) ~expect:(list1, list2)) ;; let%test_unit "sort vs stable_sort" = Q.test ~sexp_of:[%sexp_of: t list * (t -> t -> int)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.compare_fn quickcheck_observer)) ~f:(fun (list, cmp) -> (* When comparing [t] using [cmp], [sort] and [stable_sort] should be indistinguishable. *) let compare = cmp in [%test_eq: t list] (List.sort list ~compare:cmp) (List.stable_sort list ~compare:cmp)) ;; let%test_unit "stable_sort + merge vs append + stable_sort" = Q.test ~sexp_of:[%sexp_of: t list * t list * (t -> t -> int)] (G.tuple3 (List.quickcheck_generator quickcheck_generator) (List.quickcheck_generator quickcheck_generator) (G.compare_fn quickcheck_observer)) ~f:(fun (list1, list2, cmp) -> [%test_eq: t list] (List.merge ~compare:cmp (List.stable_sort ~compare:cmp list1) (List.stable_sort ~compare:cmp list2)) (List.stable_sort ~compare:cmp (List.append list1 list2))) ;; let%test_unit "hd vs hd_exn" = Q.test ~sexp_of:[%sexp_of: t list] (List.quickcheck_generator quickcheck_generator) ~f:(fun list -> [%test_eq: t option] (List.hd list) (Option.try_with (fun () -> List.hd_exn list))) ;; let%test_unit "tl vs tl_exn" = Q.test ~sexp_of:[%sexp_of: t list] (List.quickcheck_generator quickcheck_generator) ~f:(fun list -> [%test_eq: t list option] (List.tl list) (Option.try_with (fun () -> List.tl_exn list))) ;; let%test_unit "find vs find_exn" = Q.test ~sexp_of:[%sexp_of: t list * (t -> bool)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer Bool.quickcheck_generator)) ~f:(fun (list, f) -> [%test_eq: t option] (List.find list ~f) (Option.try_with (fun () -> List.find_exn list ~f))) ;; let%test_unit "find vs findi" = Q.test ~sexp_of:[%sexp_of: t list * (t -> bool)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer Bool.quickcheck_generator)) ~f:(fun (list, f) -> [%test_eq: t option] (List.find list ~f) (Option.map ~f:snd (List.findi list ~f:(fun _ x -> f x)))) ;; let%test_unit "append + rev" = Q.test ~sexp_of:[%sexp_of: t list * t list] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (List.quickcheck_generator quickcheck_generator)) ~f:(fun (list1, list2) -> [%test_eq: t list] (List.rev (List.append list1 list2)) (List.append (List.rev list2) (List.rev list1))) ;; let%test_unit "append associativity" = Q.test ~sexp_of:[%sexp_of: t list * t list * t list] (G.tuple3 (List.quickcheck_generator quickcheck_generator) (List.quickcheck_generator quickcheck_generator) (List.quickcheck_generator quickcheck_generator)) ~f:(fun (list1, list2, list3) -> [%test_eq: t list] (List.append list1 (List.append list2 list3)) (List.append (List.append list1 list2) list3)) ;; let%test_unit "map + rev vs rev + map" = Q.test ~sexp_of:[%sexp_of: t list * (t -> t)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer quickcheck_generator)) ~f:(fun (list, f) -> [%test_eq: t list] (List.rev (List.map list ~f)) (List.map (List.rev list) ~f)) ;; let%test_unit "map + append vs append + map" = Q.test ~sexp_of:[%sexp_of: t list * t list * (t -> t)] (G.tuple3 (List.quickcheck_generator quickcheck_generator) (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer quickcheck_generator)) ~f:(fun (list1, list2, f) -> [%test_eq: t list] (List.append (List.map list1 ~f) (List.map list2 ~f)) (List.map (List.append list1 list2) ~f)) ;; let%test_unit "map vs concat_map" = Q.test ~sexp_of:[%sexp_of: t list * (t -> t)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer quickcheck_generator)) ~f:(fun (list, f) -> [%test_eq: t list] (List.map list ~f) (List.concat_map list ~f:(fun x -> [ f x ]))) ;; let%test_unit "concat_mapi vs concat_map" = Q.test ~sexp_of:[%sexp_of: t list * (t -> t list)] (G.tuple2 (List.quickcheck_generator quickcheck_generator) (G.fn quickcheck_observer (List.quickcheck_generator quickcheck_generator))) ~f:(fun (list, f) -> [%test_eq: t list] (List.concat_map list ~f) (List.concat_mapi list ~f:(fun _ x -> f x))) ;; let%test_unit "unzip + map2_exn vs map" = Q.test ~sexp_of:[%sexp_of: (t * t) list * (t -> t -> t)] (G.tuple2 (List.quickcheck_generator (G.tuple2 quickcheck_generator quickcheck_generator)) (G.fn2 quickcheck_observer quickcheck_observer quickcheck_generator)) ~f:(fun (pair_list, f) -> [%test_eq: t list] (let list1, list2 = List.unzip pair_list in List.map2_exn list1 list2 ~f) (List.map pair_list ~f:(fun (x, y) -> f x y))) ;; let%test_unit "unzip + map3_exn vs map" = Q.test ~sexp_of:[%sexp_of: (t * (t * t)) list * (t -> t -> t -> t)] (G.tuple2 (List.quickcheck_generator (G.tuple2 quickcheck_generator (G.tuple2 quickcheck_generator quickcheck_generator))) (G.fn3 quickcheck_observer quickcheck_observer quickcheck_observer quickcheck_generator)) ~f:(fun (triple_list, f) -> [%test_eq: t list] (let list1, pair_list = List.unzip triple_list in let list2, list3 = List.unzip pair_list in List.map3_exn list1 list2 list3 ~f) (List.map triple_list ~f:(fun (x, (y, z)) -> f x y z))) ;; let%test_unit "rev + map3_exn vs rev_map3_exn" = Q.test ~sexp_of:[%sexp_of: (t * (t * t)) list * (t -> t -> t -> t)] (G.tuple2 (List.quickcheck_generator (G.tuple2 quickcheck_generator (G.tuple2 quickcheck_generator quickcheck_generator))) (G.fn3 quickcheck_observer quickcheck_observer quickcheck_observer quickcheck_generator)) ~f:(fun (triple_list, f) -> let list1, pair_list = List.unzip triple_list in let list2, list3 = List.unzip pair_list in [%test_eq: t list] (List.rev_map3_exn list1 list2 list3 ~f) (List.rev (List.map3_exn list1 list2 list3 ~f))) ;; end module String' = struct include String let module_name = "String" end module Int' = struct include Int let module_name = "Int" end let%test_module "string w/ int" = (module Make (String') (Int')) let%test_unit "List.fold_right doesn't allocate on empty lists" = let initial_words = Gc.minor_words () in let (_ : int) = List.fold_right [] ~f:( + ) ~init:0 in let allocated = Gc.minor_words () - initial_words in [%test_result: int] allocated ~expect:0 ;; end) ;; let%test_module "compare does not allocate" = (module struct let test_compare_alloc a b = let minor_words = Gc.minor_words () in ignore (List.compare Int.compare a b : int); Int.equal minor_words (Gc.minor_words ()) ;; let%test _ = test_compare_alloc [] [] let%test _ = test_compare_alloc [] [ 0 ] let%test _ = test_compare_alloc [ 1 ] [] let%test _ = test_compare_alloc [ 2 ] [ 2 ] let%test _ = test_compare_alloc [ 1; 2; 3 ] [ 4 ] let%test _ = test_compare_alloc [ 4 ] [ 1; 2; 3 ] end) ;; let%test_module "equal does not allocate" = (module struct let test_equal_alloc a b = let minor_words = Gc.minor_words () in ignore (List.equal Int.equal a b : bool); Int.equal minor_words (Gc.minor_words ()) ;; let%test _ = test_equal_alloc [] [] let%test _ = test_equal_alloc [] [ 0 ] let%test _ = test_equal_alloc [ 1 ] [] let%test _ = test_equal_alloc [ 2 ] [ 2 ] let%test _ = test_equal_alloc [ 1; 2; 3 ] [ 4 ] let%test _ = test_equal_alloc [ 4 ] [ 1; 2; 3 ] end) ;; core-0.15.0/core/test/src/core_list_unit_tests.mli000066400000000000000000000000551420273305200221700ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/core_map_unit_tests.ml000066400000000000000000002353751420273305200216400ustar00rootroot00000000000000(* This module defines a functor, [Unit_tests], that does unit tests on a generic map, and then instantiates that functor to create unit tests for [Map], [Map.Poly], and [Int.Map]. *) module Caml_map = Map open! Core module With_comparator = Map_intf.With_comparator module With_first_class_module = Map_intf.With_first_class_module module Without_comparator = Map_intf.Without_comparator module Unit_tests (Key : sig type 'a t [@@deriving sexp, compare, hash] val of_int : int -> int t val to_int : int t -> int end) (Map : sig type ('a, 'b, 'c) t_ type ('a, 'b, 'c) tree type ('a, 'b, 'c) create_options include Map_intf.Creators_generic with type ('a, 'b, 'c) t := ('a, 'b, 'c) t_ with type ('a, 'b, 'c) tree := ('a, 'b, 'c) tree with type 'a key := 'a Key.t with type ('a, 'b, 'c) options := ('a, 'b, 'c) create_options val simplify_creator : (int, Int.comparator_witness, 'c) create_options -> 'c type ('a, 'b, 'c) access_options include Map_intf.Accessors_generic with type ('a, 'b, 'c) t := ('a, 'b, 'c) t_ with type ('a, 'b, 'c) tree := ('a, 'b, 'c) tree with type 'a key := 'a Key.t with type 'a cmp := 'a cmp with type ('a, 'b, 'c) options := ('a, 'b, 'c) access_options val simplify_accessor : (int, Int.comparator_witness, 'c) access_options -> 'c val kind : [ `Map | `Tree ] end) : Map_intf.Creators_and_accessors_generic = (* The result signature doesn't actually mean anything -- the values are required so that implementors are reminded to add a unit test for each one. *) struct module Map = struct include Map let set x = simplify_accessor set x let add_multi x = simplify_accessor add_multi x let find_multi x = simplify_accessor find_multi x let remove_multi x = simplify_accessor remove_multi x let change x = simplify_accessor change x let update x = simplify_accessor update x let find x = simplify_accessor find x let find_exn x = simplify_accessor find_exn x let invariants x = simplify_accessor invariants x let remove x = simplify_accessor remove x let mem x = simplify_accessor mem x let filter x = simplify_accessor filter x let filteri x = simplify_accessor filteri x let filter_keys x = simplify_accessor filter_keys x let filter_map x = simplify_accessor filter_map x let filter_mapi x = simplify_accessor filter_mapi x let partition_mapi x = simplify_accessor partition_mapi x let partition_map x = simplify_accessor partition_map x let partitioni_tf x = simplify_accessor partitioni_tf x let partition_tf x = simplify_accessor partition_tf x let combine_errors x = simplify_accessor combine_errors x let compare_direct x = simplify_accessor compare_direct x let equal x = simplify_accessor equal x let iter2 x = simplify_accessor iter2 x let fold2 x = simplify_accessor fold2 x let symmetric_diff x = simplify_accessor symmetric_diff x let fold_symmetric_diff x = simplify_accessor fold_symmetric_diff x let merge x = simplify_accessor merge x let merge_skewed x = simplify_accessor merge_skewed x let split x = simplify_accessor split x let subrange x = simplify_accessor subrange x let fold_range_inclusive x = simplify_accessor fold_range_inclusive x let range_to_alist x = simplify_accessor range_to_alist x let closest_key x = simplify_accessor closest_key x let rank x = simplify_accessor rank x let quickcheck_shrinker x = simplify_accessor quickcheck_shrinker x let key_set x = simplify_accessor key_set x let to_sequence ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to x = simplify_accessor to_sequence ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to x ;; let binary_search t ~compare how v = simplify_accessor binary_search t ~compare how v let binary_search_segmented t ~segment_of how = simplify_accessor binary_search_segmented t ~segment_of how ;; let binary_search_subrange t ~compare ~lower_bound ~upper_bound = simplify_accessor binary_search_subrange t ~compare ~lower_bound ~upper_bound ;; let append ~lower_part ~upper_part = simplify_accessor append ~lower_part ~upper_part let empty () = simplify_creator empty let singleton x = simplify_creator singleton x let of_sorted_array_unchecked x = simplify_creator of_sorted_array_unchecked x let of_sorted_array x = simplify_creator of_sorted_array x let of_increasing_iterator_unchecked ~len ~f = simplify_creator of_increasing_iterator_unchecked ~len ~f ;; let of_increasing_sequence seq = simplify_creator of_increasing_sequence seq let of_alist x = simplify_creator of_alist x let of_alist_or_error x = simplify_creator of_alist_or_error x let of_alist_exn x = simplify_creator of_alist_exn x let of_hashtbl_exn x = simplify_creator of_hashtbl_exn x let of_alist_multi x = simplify_creator of_alist_multi x let of_alist_fold x = simplify_creator of_alist_fold x let of_alist_reduce x = simplify_creator of_alist_reduce x let of_iteri ~iteri = simplify_creator of_iteri ~iteri let of_iteri_exn ~iteri = simplify_creator of_iteri_exn ~iteri let of_tree x = simplify_creator of_tree x let of_sequence x = simplify_creator of_sequence x let of_sequence_or_error x = simplify_creator of_sequence_or_error x let of_sequence_exn x = simplify_creator of_sequence_exn x let of_sequence_multi x = simplify_creator of_sequence_multi x let of_sequence_fold x = simplify_creator of_sequence_fold x let of_sequence_reduce x = simplify_creator of_sequence_reduce x let map_keys_exn x = simplify_creator map_keys_exn x let quickcheck_generator x = simplify_creator quickcheck_generator x type ('a, 'b) t = ('a, 'b, Int.comparator_witness) t_ let sexp_of_t sexp_of_a sexp_of_b t = [%sexp (to_alist t : (a Key.t * b) list)] let compare (type a b) compare_a compare_b t1 t2 = [%compare: (a Key.t * b) list] (to_alist t1) (to_alist t2) ;; end type ('a, 'b, 'c) t = Unit_test_follows type ('a, 'b, 'c) tree = ('a, 'b, 'c) t type 'a key type ('a, 'b, 'c) options = ('a, 'b, 'c) Without_comparator.t type 'cmp cmp module Key = struct open Key let of_int = of_int let to_int = to_int module T = struct type t = int Key.t [@@deriving sexp, hash] let compare t t' = Poly.compare (to_int t) (to_int t') end include T include Comparable.Make (T) let to_string t = Sexp.to_string (sexp_of_t t) let sample = of_int 0 let samples = List.init 10 ~f:(fun i -> of_int (i + 1)) |> List.dedup_and_sort ~compare |> List.sort ~compare ;; let min = List.hd_exn samples let max = List.hd_exn (List.rev samples) let mid = List.nth_exn samples (List.length samples / 2) let pred t = of_int (to_int t - 1) let succ t = of_int (to_int t + 1) let quickcheck_generator = Quickcheck.Generator.map Int.quickcheck_generator ~f:of_int let quickcheck_observer = Quickcheck.Observer.unmap Int.quickcheck_observer ~f:to_int end module Caml_map = Caml_map.Make (Key) let random_alist keys = List.rev (List.fold keys ~init:[] ~f:(fun l key -> (key, Random.int 1000) :: l)) ;; let random_map keys = List.fold (random_alist keys) ~init:(Map.empty ()) ~f:(fun map (key, data) -> Map.set ~key ~data map) ;; let caml_map_of_alist alist = List.fold alist ~init:Caml_map.empty ~f:(fun map (key, data) -> Caml_map.add key data map) ;; let alist_equal ~data_equal l1 l2 = List.equal (fun (k1, d1) (k2, d2) -> Key.equal k1 k2 && data_equal d1 d2) l1 l2 ;; let caml_map_to_alist map = List.rev (Caml_map.fold (fun key data l -> (key, data) :: l) map []) ;; (* relies on correctness of Map.to_alist *) let equal_maps ~data_equal ~caml_map map = Map.length map = Caml_map.cardinal caml_map && alist_equal ~data_equal (Map.to_alist map) (caml_map_to_alist caml_map) ;; let add _ = assert false let add_exn _ = assert false let set _ = assert false let remove _ = assert false let find _ = assert false let mem _ = assert false let iter _ = assert false let iteri _ = assert false let iter_keys _ = assert false let map _ = assert false let mapi _ = assert false let fold _ = assert false let equal _ = assert false let compare_direct _ = assert false (* runs a series of random tests on a map of the input type and a Caml map to see if they have the same behavior *) let%test _ = let rec loop n ~prev_caml_map ~caml_map ~prev_core_map ~core_map = if n = 0 then equal_maps ~data_equal:( = ) ~caml_map core_map else ( let remove key = Caml_map.remove key caml_map, Map.remove core_map key in let add key = let data = Random.int 1000 in Caml_map.add key data caml_map, Map.set ~key ~data core_map in let caml_choose caml_map = try Some (Caml_map.choose caml_map) with | _ -> None in let add_or_remove ~prefer = match caml_choose caml_map, prefer with | None, _ -> add Key.sample | Some (key, _), `Remove -> remove key | Some (key, _), `Add -> (match List.find Key.samples ~f:(fun key -> not (Caml_map.mem key caml_map)) with | Some key -> add key | None -> remove key) in let old_values = caml_map, core_map in let new_caml_map, new_core_map = match Random.int 8 with | 0 -> add_or_remove ~prefer:`Add | 1 -> add_or_remove ~prefer:`Remove | 2 -> (match caml_choose caml_map with | None -> assert (Map.is_empty core_map); assert (Map.length core_map = 0) | Some (key, data) -> assert (Caml_map.find key caml_map = data); assert (not (Map.is_empty core_map)); assert (Map.length core_map = Caml_map.cardinal caml_map); assert (Map.mem core_map key); assert ([%equal: int option] (Map.find core_map key) (Some data))); old_values | 3 -> let target = let sum = ref 0 in Caml_map.iter (fun _ data -> sum := !sum + data) caml_map; !sum in let actual = let sum = ref 0 in Map.iter ~f:(fun data -> sum := !sum + data) core_map; !sum in let actual2 = let sum = ref 0 in Map.iteri ~f:(fun ~key:_ ~data -> sum := !sum + data) core_map; !sum in assert (target = actual && actual = actual2); old_values | 4 -> let target = let sum = ref 0 in Caml_map.iter (fun key _ -> sum := !sum + Key.to_int key) caml_map; !sum in let actual = let sum = ref 0 in Map.iter_keys ~f:(fun key -> sum := !sum + Key.to_int key) core_map; !sum in assert (target = actual); old_values | 5 -> let caml_map = Caml_map.mapi (fun key data -> key, data) caml_map in let core_map = Map.mapi ~f:(fun ~key ~data -> key, data) core_map in let increment = Random.int 1000 in let caml_map = Caml_map.map (fun (_, n) -> n + increment) caml_map in let core_map = Map.map ~f:(fun (_, n) -> n + increment) core_map in assert (equal_maps ~data_equal:( = ) ~caml_map core_map); old_values | 6 -> let caml_alist = Caml_map.fold (fun key data acc -> (key, data) :: acc) caml_map [] in let core_alist = Map.fold ~f:(fun ~key ~data acc -> (key, data) :: acc) core_map ~init:[] in assert (alist_equal ~data_equal:( = ) caml_alist core_alist); old_values | 7 -> let unchanged = Caml_map.equal ( = ) prev_caml_map caml_map in assert ([%equal: bool] unchanged (Map.equal ( = ) prev_core_map core_map)); assert ( [%equal: bool] unchanged (Map.compare_direct Int.compare prev_core_map core_map = 0)); old_values | _ -> assert false in loop (n - 1) ~prev_caml_map:caml_map ~caml_map:new_caml_map ~prev_core_map:core_map ~core_map:new_core_map) in loop 10000 ~prev_caml_map:Caml_map.empty ~caml_map:Caml_map.empty ~prev_core_map:(Map.empty ()) ~core_map:(Map.empty ()) ;; let iter2 _ = assert false let%test_unit _ = let test l1 l2 expected = let map_of_alist l = Map.of_alist_exn (List.map l ~f:(fun (k, v) -> Key.of_int k, v)) in let result = ref [] in Map.iter2 (map_of_alist l1) (map_of_alist l2) ~f:(fun ~key ~data -> result := (key, data) :: !result); let result = List.rev_map !result ~f:(fun (k, v) -> Key.to_int k, v) in assert ( [%equal: (int * [ `Both of int * int | `Left of int | `Right of int ]) list] result expected) in test [] [] []; test [ 0, 10 ] [] [ 0, `Left 10 ]; test [] [ 0, 10 ] [ 0, `Right 10 ]; test [ 0, 10 ] [ 0, 11 ] [ 0, `Both (10, 11) ]; test [ 0, 10; 3, 13; 4, 14; 6, 16 ] [ 1, 11; 3, 13; 4, 14; 5, 15 ] [ 0, `Left 10 ; 1, `Right 11 ; 3, `Both (13, 13) ; 4, `Both (14, 14) ; 5, `Right 15 ; 6, `Left 16 ] ;; let fold2 _ = assert false let%test_unit _ = let test l1 l2 expected = let map_of_alist l = Map.of_alist_exn (List.map l ~f:(fun (k, v) -> Key.of_int k, v)) in let result = Map.fold2 (map_of_alist l1) (map_of_alist l2) ~init:[] ~f:(fun ~key ~data acc -> (key, data) :: acc) in let result = List.rev_map result ~f:(fun (k, v) -> Key.to_int k, v) in assert ( [%equal: (int * [ `Both of int * int | `Left of int | `Right of int ]) list] result expected) in test [] [] []; test [ 0, 10 ] [] [ 0, `Left 10 ]; test [] [ 0, 10 ] [ 0, `Right 10 ]; test [ 0, 10 ] [ 0, 11 ] [ 0, `Both (10, 11) ]; test [ 0, 10; 3, 13; 4, 14; 6, 16 ] [ 1, 11; 3, 13; 4, 14; 5, 15 ] [ 0, `Left 10 ; 1, `Right 11 ; 3, `Both (13, 13) ; 4, `Both (14, 14) ; 5, `Right 15 ; 6, `Left 16 ] ;; let empty = Unit_test_follows let%test _ = equal_maps ~data_equal:( = ) ~caml_map:Caml_map.empty (Map.empty ()) let singleton _ = assert false let%test _ = equal_maps ~data_equal:( = ) ~caml_map:(Caml_map.add Key.sample 0 Caml_map.empty) (Map.singleton Key.sample 0) ;; let of_sorted_array _ = assert false (* test detection of invalid input *) let%test _ = Map.of_sorted_array [| Key.of_int 0, 0; Key.of_int 0, 0 |] |> Result.is_error ;; let%test _ = Map.of_sorted_array [| Key.of_int 1, 0; Key.of_int 0, 0; Key.of_int 1, 0 |] |> Result.is_error ;; let of_sorted_array_unchecked _ = assert false (* test it gets same result as [Map.of_alist] *) let%test _ = let alist = List.sort (random_alist Key.samples) ~compare:(fun (k1, _) (k2, _) -> Key.compare k1 k2) in let array = Array.of_list alist in let array_rev = Array.of_list (List.rev alist) in let map_of_alist = Map.of_alist_exn alist in let map_of_array = Map.of_sorted_array_unchecked array in let map_of_rev_array = Map.of_sorted_array_unchecked array_rev in let map_of_sequence = Sequence.of_list alist |> Map.of_increasing_sequence |> Or_error.ok_exn in let map_equal = Map.equal Int.equal in map_equal map_of_alist map_of_array && map_equal map_of_alist map_of_rev_array && map_equal map_of_alist map_of_sequence ;; let invariants _ = assert false (* Test constructed AVL tree is valid *) let%test_unit _ = for n = 0 to 100 do let alist = List.init n ~f:(fun i -> Key.of_int i, i) in assert (List.permute alist |> Map.of_alist_exn |> Map.invariants); assert (Array.of_list alist |> Map.of_sorted_array_unchecked |> Map.invariants); assert ( List.rev alist |> Array.of_list |> Map.of_sorted_array_unchecked |> Map.invariants); assert ( Sequence.of_list alist |> Map.of_increasing_sequence |> Or_error.ok_exn |> Map.invariants) done ;; let of_increasing_iterator_unchecked ~len:_ = assert false let _ = Map.of_increasing_iterator_unchecked (* already tested in the array functions *) let of_alist _ = assert false let%test _ = let alist = random_alist Key.samples in match Map.of_alist alist with | `Duplicate_key _ -> false | `Ok map -> alist_equal ~data_equal:( = ) (Map.to_alist map) alist ;; let%test _ = match Map.of_alist [] with | `Ok map -> [%equal: (Key.t * _) list] (Map.to_alist map) [] | `Duplicate_key _ -> false ;; let%test _ = match Map.of_alist [ Key.sample, 0; Key.sample, 1 ] with | `Ok _ -> false | `Duplicate_key _ -> true ;; let of_alist_or_error _ = assert false let%test _ = Result.is_error (Map.of_alist_or_error [ Key.sample, 0; Key.sample, 1 ]) let%test _ = Result.is_ok (Map.of_alist_or_error (List.map Key.samples ~f:(fun key -> key, Key.to_int key))) ;; let of_alist_exn _ = assert false let%test _ = try ignore (Map.of_alist_exn [ Key.sample, 0; Key.sample, 1 ] : _ Map.t_); false with | _ -> true ;; let%test _ = try ignore (Map.of_hashtbl_exn (List.map Key.samples ~f:(fun key -> key, Key.to_int key) |> Hashtbl.Poly.of_alist_exn) : _ Map.t_); true with | _ -> false ;; let%test _ = let hashtbl_with_dup = let bogus_hashable : Key.t Hashtbl.Hashable.t = let i = ref 0 in { hash = (fun _ -> incr i; !i) ; compare = (fun _ _ -> 1) ; sexp_of_t = Key.sexp_of_t } in Hashtbl.Using_hashable.of_alist_exn ~hashable:bogus_hashable [ Key.sample, 0; Key.sample, 1 ] in try ignore (Map.of_hashtbl_exn hashtbl_with_dup : _ Map.t_); false with | _ -> true ;; let of_hashtbl_exn _ = assert false let of_alist_fold _ = assert false let of_alist_reduce _ = assert false let%test_unit _ = let filtered = List.filter Key.samples ~f:(fun key -> not (Key.equal key Key.sample)) in let alist = random_alist filtered in let caml_map = Caml_map.add Key.sample 6 (caml_map_of_alist alist) in let alist' = ((Key.sample, 1) :: (Key.sample, 2) :: alist) @ [ Key.sample, 3 ] in let core_map_fold = Map.of_alist_fold ~init:0 ~f:( + ) alist' in let core_map_reduce = Map.of_alist_reduce ~f:( + ) alist' in assert (equal_maps ~data_equal:( = ) ~caml_map core_map_fold); assert (equal_maps ~data_equal:( = ) ~caml_map core_map_reduce) ;; let of_alist_multi _ = assert false let%test _ = equal_maps ~data_equal:[%equal: int list] ~caml_map:(Caml_map.add Key.sample [ 0; 1 ] Caml_map.empty) (Map.of_alist_multi [ Key.sample, 0; Key.sample, 1 ]) ;; let of_iteri ~iteri:_ = assert false let of_iteri_exn ~iteri:_ = assert false let alist_iteri alist ~f = List.iter alist ~f:(fun (key, data) -> f ~key ~data) let%test _ = let alist = random_alist Key.samples in match Map.of_iteri ~iteri:(alist_iteri alist) with | `Duplicate_key _ -> false | `Ok map -> alist_equal ~data_equal:( = ) (Map.to_alist map) alist ;; let%test _ = match Map.of_iteri ~iteri:(alist_iteri [ Key.sample, 0; Key.sample, 1 ]) with | `Ok _ -> false | `Duplicate_key _ -> true ;; let%test_unit _ = let alist = random_alist Key.samples in ignore (Map.of_iteri_exn ~iteri:(alist_iteri alist) : _ Map.t_) ;; let%test _ = try ignore (Map.of_iteri_exn ~iteri:(alist_iteri [ Key.sample, 0; Key.sample, 1 ]) : _ Map.t_); false with | _ -> true ;; let of_increasing_sequence _ = assert false let%test "of_increasing_sequence: vs of_alist_or_error" = let alist = random_alist Key.samples in let increasing_alist = List.sort alist ~compare:(Comparable.lift ~f:fst Key.compare) |> List.remove_consecutive_duplicates ~equal:(Comparable.lift ~f:fst Key.equal) in let duplicates_alist = match increasing_alist with | [] -> failwith "empty alist in test" | x :: xs -> x :: x :: xs in let decreasing_alist = List.rev increasing_alist in (match Map.of_increasing_sequence (Sequence.of_list duplicates_alist) with | Error _ -> () | Ok _ -> failwith "of_increasing_sequence: expected to fail with duplicate key"); (match Map.of_increasing_sequence (Sequence.of_list decreasing_alist) with | Error _ -> () | Ok _ -> failwith "of_increasing_sequence: expected to fail with non-increasing key"); match Map.of_increasing_sequence (Sequence.of_list increasing_alist) with | Error _ -> failwith "of_increasing_sequence: expected to get a map back" | Ok map -> Map.equal Int.equal map (Map.of_alist_exn increasing_alist) ;; (* Sequence constructors check against the alist ones *) let of_sequence_fold _ = assert false let of_sequence_reduce _ = assert false let%test_unit _ = let filtered = List.filter Key.samples ~f:(fun key -> not (Key.equal key Key.sample)) in let alist = [ Key.sample, 1; Key.sample, 2 ] @ random_alist filtered @ [ Key.sample, 3 ] in let alist_fold = Map.of_alist_fold ~init:0 ~f:( + ) alist in let alist_reduce = Map.of_alist_reduce ~f:( + ) alist in let sequence_fold = Map.of_sequence_fold ~init:0 ~f:( + ) (Sequence.of_list alist) in let sequence_reduce = Map.of_sequence_reduce ~f:( + ) (Sequence.of_list alist) in assert (Map.equal Int.equal alist_fold sequence_fold); assert (Map.equal Int.equal alist_reduce sequence_reduce) ;; let of_sequence _ = assert false let%test _ = let input = random_alist Key.samples in let alist = Map.of_alist input in let sequence = Map.of_sequence (Sequence.of_list input) in match alist, sequence with | `Duplicate_key alist_key, `Duplicate_key sequence_key -> Key.equal alist_key sequence_key | `Ok alist_map, `Ok sequence_map -> Map.equal Int.equal alist_map sequence_map | _, _ -> false ;; let of_sequence_or_error _ = assert false let of_sequence_exn _ = assert false let%test_unit _ = let input = random_alist Key.samples in let alist_exn = Option.try_with (fun () -> Map.of_alist_exn input) in let alist_or_error = Result.ok (Map.of_alist_or_error input) in let sequence_exn = Option.try_with (fun () -> Map.of_sequence_exn (Sequence.of_list input)) in let sequence_or_error = Result.ok (Map.of_sequence_or_error (Sequence.of_list input)) in assert (Option.equal (Map.equal Int.equal) alist_exn sequence_exn); assert (Option.equal (Map.equal Int.equal) alist_or_error sequence_or_error) ;; let of_sequence_multi _ = assert false let%test _ = let filtered = List.filter Key.samples ~f:(fun key -> not (Key.equal key Key.sample)) in let input = ((Key.sample, 1) :: (Key.sample, 2) :: random_alist filtered) @ [ Key.sample, 3 ] in let alist = Map.of_alist_multi input in let sequence = Map.of_sequence_multi (Sequence.of_list input) in Map.equal (List.equal Int.equal) alist sequence ;; let is_empty _ = assert false let%test _ = Map.is_empty (Map.empty ()) let%test _ = not (Map.is_empty (Map.singleton Key.sample 0)) let%test _ = not (Map.is_empty (random_map Key.samples)) let of_tree _ = assert false let to_tree _ = assert false let%test _ = Map.is_empty (Map.of_tree (Map.to_tree (Map.empty ()))) let%test _ = let map = random_map Key.samples in alist_equal ~data_equal:( = ) (Map.to_alist map) (Map.to_alist (Map.of_tree (Map.to_tree map))) ;; let add_multi _ = assert false let%test _ = let m1 = Map.add_multi (Map.empty ()) ~key:Key.sample ~data:0 in let m2 = Map.add_multi m1 ~key:Key.sample ~data:1 in equal_maps ~data_equal:[%equal: int list] m2 ~caml_map:(Caml_map.add Key.sample [ 1; 0 ] Caml_map.empty) ;; let find_multi _ = assert false let%test _ = let m1 = Map.add_multi (Map.empty ()) ~key:Key.sample ~data:0 in let m2 = Map.add_multi m1 ~key:Key.sample ~data:1 in List.equal Int.equal (Map.find_multi m2 Key.sample) (Caml_map.find Key.sample (Caml_map.add Key.sample [ 1; 0 ] Caml_map.empty)) ;; let remove_multi _ = assert false let%test _ = let m1 = Map.set (Map.empty ()) ~key:Key.sample ~data:[ 1; 2; 3 ] in let m2 = Map.remove_multi m1 Key.sample in let m3 = Map.remove_multi m2 Key.sample in let m4 = Map.remove_multi m3 Key.sample in let m5 = Map.remove_multi m4 Key.sample in let equal_maps = equal_maps ~data_equal:[%equal: int list] in equal_maps m2 ~caml_map:(Caml_map.add Key.sample [ 2; 3 ] Caml_map.empty) && equal_maps m3 ~caml_map:(Caml_map.add Key.sample [ 3 ] Caml_map.empty) && equal_maps m4 ~caml_map:Caml_map.empty && equal_maps m5 ~caml_map:Caml_map.empty ;; let change _ = assert false let update _ = assert false let%test _ = let m1 = Map.remove (random_map Key.samples) Key.sample in let f = function | Some x -> Some (x + 1) | None -> Some 0 in let m2 = Map.change m1 Key.sample ~f in let m3 = Map.change m2 Key.sample ~f in match Map.find m3 Key.sample with | Some 1 -> true | _ -> false ;; let%test _ = let m1 = Map.remove (random_map Key.samples) Key.sample in let f = function | Some x -> x + 1 | None -> 0 in let m2 = Map.update m1 Key.sample ~f in let m3 = Map.update m2 Key.sample ~f in match Map.find m3 Key.sample with | Some 1 -> true | _ -> false ;; let%test _ = let m1 = Map.set (random_map Key.samples) ~key:Key.sample ~data:0 in let m2 = Map.change m1 Key.sample ~f:(function | Some _ -> None | None -> Some 0) in match Map.find m2 Key.sample with | None -> true | Some _ -> false ;; let find_exn _ = assert false let%test _ = try ignore (Map.find_exn (Map.empty ()) Key.sample : int); false with | Not_found_s _ | Caml.Not_found -> true ;; let%test _ = [%equal: int list] (Map.find_multi (Map.empty ()) Key.sample) [] let fold_right _ = assert false let%test _ = let f ~key ~data acc = (key, data) :: acc in let map = random_map Key.samples in let alist = Map.fold map ~init:[] ~f in let right_alist = List.rev (Map.fold_right map ~init:[] ~f) in alist_equal ~data_equal:( = ) right_alist alist ;; let filter _ = assert false let%test _ = let caml_map = Caml_map.add Key.sample (-1) Caml_map.empty in let core_map = Map.filter (Map.set (random_map Key.samples) ~key:Key.sample ~data:(-1)) ~f:(fun data -> data = -1) in equal_maps ~data_equal:( = ) ~caml_map core_map ;; let filteri _ = assert false let%test _ = let caml_map = Caml_map.add Key.sample 0 Caml_map.empty in let core_map = Map.filteri (Map.set (random_map Key.samples) ~key:Key.sample ~data:0) ~f:(fun ~key ~data -> Key.equal key Key.sample && data = 0) in equal_maps ~data_equal:( = ) ~caml_map core_map ;; let filter_keys _ = assert false let%test _ = let caml_map = Caml_map.add Key.sample 0 Caml_map.empty in let core_map = Map.filter_keys (Map.set (random_map Key.samples) ~key:Key.sample ~data:0) ~f:(fun key -> Key.equal key Key.sample) in equal_maps ~data_equal:( = ) ~caml_map core_map ;; let filter_map _ = assert false let%test _ = let alist = random_alist Key.samples in let core_map = Map.set (Map.of_alist_exn alist) ~key:Key.sample ~data:(-1) in let core_map = Map.filter_map core_map ~f:(fun x -> if x >= 0 then Some (x + 1) else None) in let caml_map = Caml_map.remove Key.sample (caml_map_of_alist alist) in let caml_map = Caml_map.map (fun x -> x + 1) caml_map in equal_maps ~data_equal:( = ) ~caml_map core_map ;; let filter_mapi _ = assert false let%test _ = let base_map = Map.set (random_map Key.samples) ~key:Key.sample ~data:0 in let m1 = Map.filter_mapi base_map ~f:(fun ~key ~data -> if Key.equal key Key.sample && data = 0 then None else Some (data + 1)) in let m2 = Map.map (Map.remove base_map Key.sample) ~f:(fun x -> x + 1) in Map.equal ( = ) m1 m2 ;; let partition_mapi _ = assert false module Some_keys = struct let k1 = Key.of_int 1 let k2 = Key.of_int 2 let k3 = Key.of_int 3 let k4 = Key.of_int 4 end let%test _ = let open Some_keys in let m0 = Map.of_alist_exn [ k1, "a"; k2, "2"; k3, "d"; k4, "5" ] in let m1, m2 = Map.partition_mapi m0 ~f:(fun ~key ~data -> match Int.of_string data with | n -> First n | exception _ -> Second (data ^ Int.to_string (Key.to_int key))) in Map.equal Int.equal m1 (Map.of_alist_exn [ k2, 2; k4, 5 ]) && Map.equal String.equal m2 (Map.of_alist_exn [ k1, "a1"; k3, "d3" ]) ;; let partition_map _ = assert false let%test _ = let open Some_keys in let m0 = Map.of_alist_exn [ k1, "a"; k2, "2"; k3, "d"; k4, "5" ] in let m1, m2 = Map.partition_map m0 ~f:(fun data -> match Int.of_string data with | n -> First n | exception _ -> Second data) in Map.equal Int.equal m1 (Map.of_alist_exn [ k2, 2; k4, 5 ]) && Map.equal String.equal m2 (Map.of_alist_exn [ k1, "a"; k3, "d" ]) ;; let partitioni_tf _ = assert false let%test _ = let open Some_keys in let m0 = Map.of_alist_exn [ k1, "a"; k2, "2"; k3, "d"; k4, "5" ] in let m1, m2 = Map.partitioni_tf m0 ~f:(fun ~key ~data -> match Int.of_string data with | n -> n = Key.to_int key | exception _ -> false) in Map.equal String.equal m1 (Map.of_alist_exn [ k2, "2" ]) && Map.equal String.equal m2 (Map.of_alist_exn [ k1, "a"; k3, "d"; k4, "5" ]) ;; let partition_tf _ = assert false let%test _ = let open Some_keys in let m0 = Map.of_alist_exn [ k1, "a"; k2, "2"; k3, "d"; k4, "5" ] in let m1, m2 = Map.partition_tf m0 ~f:(fun data -> match Int.of_string data with | _ -> true | exception _ -> false) in Map.equal String.equal m1 (Map.of_alist_exn [ k2, "2"; k4, "5" ]) && Map.equal String.equal m2 (Map.of_alist_exn [ k1, "a"; k3, "d" ]) ;; let combine_errors _ = assert false let%test _ = let open Some_keys in let m_ok = Map.of_alist_exn [ k1, Ok "a"; k2, Ok "2"; k3, Ok "d"; k4, Ok "5" ] in let ok_m = Map.combine_errors m_ok in let m_err = Map.of_alist_exn [ k1, Ok "a"; k2, error_s (Atom "2"); k3, Ok "d"; k4, error_s (Atom "5") ] in let err_m = Map.combine_errors m_err in Or_error.equal (Map.equal String.equal) ok_m (Ok (Map.of_alist_exn [ k1, "a"; k2, "2"; k3, "d"; k4, "5" ])) && Or_error.is_error err_m ;; let keys _ = assert false let data _ = assert false let to_alist ?key_order:_ _ = assert false let%test _ = let map = Map.of_alist_exn (random_alist Key.samples) in let map_keys = Map.keys map in let sorted_keys = List.sort map_keys ~compare:Key.compare in List.equal Key.equal map_keys sorted_keys ;; let%test_unit _ = let base_alist = random_alist Key.samples in let map = Map.of_alist_exn base_alist in let map_keys = Map.keys map in let all_keys = List.sort ~compare:Key.compare Key.samples in let map_data = Map.data map in let map_alist = Map.to_alist map in assert (List.equal Key.equal map_keys all_keys); assert (alist_equal ~data_equal:( = ) map_alist base_alist); assert (alist_equal ~data_equal:( = ) (List.zip_exn map_keys map_data) base_alist); let map_alist_increasing = Map.to_alist ~key_order:`Increasing map in let map_alist_decreasing = Map.to_alist ~key_order:`Decreasing map in assert (alist_equal ~data_equal:( = ) map_alist map_alist_increasing); assert (alist_equal ~data_equal:( = ) (List.rev map_alist) map_alist_decreasing) ;; let symmetric_diff _ = assert false let fold_symmetric_diff _ = assert false type sym_diffs_t = (Key.t, int) Base.Map.Symmetric_diff_element.t list [@@deriving compare, sexp_of] let symmetric_diff_to_list m1 m2 = Sequence.to_list (Map.symmetric_diff m1 m2 ~data_equal:( = )) ;; let fold_symmetric_diff_to_list m1 m2 = Map.fold_symmetric_diff m1 m2 ~data_equal:( = ) ~init:[] ~f:(fun acc d -> d :: acc) |> List.rev ;; let test_symmetric_diffs here m1 m2 expect = [%test_result: sym_diffs_t] (symmetric_diff_to_list m1 m2) ~expect ~here:[ [%here]; here ]; [%test_result: sym_diffs_t] (fold_symmetric_diff_to_list m1 m2) ~expect ~here:[ [%here]; here ]; true ;; let%test _ = let m1 = random_map Key.samples in test_symmetric_diffs [%here] m1 m1 [] ;; let%test _ = let key = Key.of_int 7 in let m1 = Map.empty () in let m1 = Map.set m1 ~key:(Key.of_int 1) ~data:1 in let m2 = Map.set m1 ~key ~data:2_000 in test_symmetric_diffs [%here] m1 m2 [ key, `Right 2_000 ] ;; let%test _ = let m1 = random_map Key.samples in let m2 = List.fold (Map.to_alist m1) ~init:(Map.empty ()) ~f:(fun m (k, d) -> Map.set m ~key:k ~data:d) in test_symmetric_diffs [%here] m1 m2 [] ;; let%test _ = let key = Key.of_int 20 in let m1 = random_map Key.samples in let m2 = Map.set m1 ~key ~data:2_000 in test_symmetric_diffs [%here] m1 m2 [ key, `Right 2_000 ] ;; let%test _ = let key = Key.of_int 5 in let m1 = random_map Key.samples in let m2 = Map.remove m1 key in test_symmetric_diffs [%here] m1 m2 [ key, `Left (Map.find_exn m1 key) ] ;; let assert_change map key to_ = Map.update map key ~f:(function | None -> assert false | Some v -> assert (v <> to_); to_) ;; let%test _ = let key = Key.of_int 7 in let m1 = random_map Key.samples in let m2 = assert_change m1 key 2_000 in test_symmetric_diffs [%here] m1 m2 [ key, `Unequal (Map.find_exn m1 key, 2000) ] ;; let%test _ = let key = Key.of_int 3 in let key' = Key.of_int 4 in let m1 = random_map Key.samples in let m2 = assert_change m1 key 1_000 in let m2 = assert_change m2 key' 2_000 in test_symmetric_diffs [%here] m1 m2 [ key, `Unequal (Map.find_exn m1 key, 1000) ; key', `Unequal (Map.find_exn m1 key', 2000) ] ;; let int_sym_diff_len m1 m2 = Int.Map.symmetric_diff m1 m2 ~data_equal:Int.equal |> Sequence.length ;; let fold_sym_diff_len m1 m2 = Int.Map.fold_symmetric_diff m1 m2 ~data_equal:Int.equal ~init:0 ~f:(fun acc _ -> Int.succ acc) ;; let%test _ = let map1 = Int.Map.empty in let map2 = Int.Map.of_alist_exn [ 1, 1; 2, 2; 3, 3; 4, 4; 5, 5 ] in int_sym_diff_len map1 map2 = 5 && fold_sym_diff_len map1 map2 = 5 ;; let%test _ = let map1 = Int.Map.of_alist_exn [ 1, 1; 2, 2; 3, 3; 4, 4; 5, 5 ] in let map2 = Int.Map.empty in int_sym_diff_len map1 map2 = 5 && fold_sym_diff_len map1 map2 = 5 ;; let%test _ = let map1 = Int.Map.of_alist_exn [ 1, 1; 2, 2 ] in let map2 = List.fold [ 3, 3; 4, 4; 5, 5 ] ~init:map1 ~f:(fun acc (key, data) -> Int.Map.set acc ~key ~data) in int_sym_diff_len map1 map2 = 3 && fold_sym_diff_len map1 map2 = 3 ;; let%test _ = let map2 = Int.Map.of_alist_exn [ 1, 1; 2, 2 ] in let map1 = List.fold [ 3, 3; 4, 4; 5, 5 ] ~init:map2 ~f:(fun acc (key, data) -> Int.Map.set acc ~key ~data) in int_sym_diff_len map1 map2 = 3 && fold_sym_diff_len map1 map2 = 3 ;; let merge _ = assert false let%test _ = let map = random_map Key.samples in let added_to_self = Map.merge map map ~f:(fun ~key:_ -> function | `Left _ | `Right _ -> assert false | `Both (x1, x2) -> Some (x1 + x2)) in let doubled = Map.map map ~f:(fun x -> x * 2) in Map.equal ( = ) added_to_self doubled ;; let%test _ = let map = random_map Key.samples in let map' = Map.merge map (Map.empty ()) ~f:(fun ~key:_ x -> match x with | `Right _ | `Both _ -> assert false | `Left x -> Some x) in Map.equal ( = ) map map' ;; let%test _ = let map = random_map Key.samples in let map' = Map.merge (Map.empty ()) map ~f:(fun ~key:_ x -> match x with | `Left _ | `Both _ -> assert false | `Right x -> Some x) in Map.equal ( = ) map map' ;; let%test _ = let map = random_map Key.samples in let map' = Map.merge map map ~f:(fun ~key:_ x -> match x with | `Left _ | `Right _ -> assert false | `Both _ -> None) in Map.is_empty map' ;; let%test_unit _ = let test l1 l2 expected = let map_of_alist l = Map.of_alist_exn (List.map l ~f:(fun (k, v) -> Key.of_int k, v)) in let result = Map.merge (map_of_alist l1) (map_of_alist l2) ~f:(fun ~key data -> let _key = key in match data with | `Left l -> if l < 0 then None else Some data | `Right r -> if r < 0 then None else Some data | `Both (l, r) -> if l + r < 0 then None else Some data) in let result = Map.to_alist result in let result = List.map result ~f:(fun (k, v) -> Key.to_int k, v) in assert ( [%equal: (int * [ `Both of int * int | `Left of int | `Right of int ]) list] result expected) in test [] [] []; test [ 0, 10 ] [] [ 0, `Left 10 ]; test [] [ 0, 10 ] [ 0, `Right 10 ]; test [ 0, 10 ] [ 0, 11 ] [ 0, `Both (10, 11) ]; test [ 0, 10; 3, 13; 4, 14; 6, 16 ] [ 1, 11; 3, 13; 4, 14; 5, 15 ] [ 0, `Left 10 ; 1, `Right 11 ; 3, `Both (13, 13) ; 4, `Both (14, 14) ; 5, `Right 15 ; 6, `Left 16 ]; test [ 0, -10; 3, 13; 4, 14; 6, 16 ] [ 1, 11; 3, 13; 4, -15; 5, -15 ] [ 1, `Right 11; 3, `Both (13, 13); 6, `Left 16 ] ;; let merge_skewed _ = assert false let%test_module _ = (module struct let make_alist = List.map ~f:(fun (k, v) -> Key.of_int k, v) let%test_unit _ = let test l1 l2 expect = let map_of_alist l = Map.of_alist_exn (make_alist l) in let result = Map.merge_skewed (map_of_alist l1) (map_of_alist l2) ~combine:(fun ~key:_ -> Int.max) |> Map.to_alist ~key_order:`Increasing in [%test_result: (Key.t * int) list] result ~expect:(make_alist expect) in test [] [] []; test [ 0, 10 ] [] [ 0, 10 ]; test [] [ 0, 10 ] [ 0, 10 ]; test [ 0, 10 ] [ 0, 11 ] [ 0, 11 ]; test [ 0, 11 ] [ 0, 10 ] [ 0, 11 ]; test [ 0, 10; 3, 13; 4, 14; 6, 16 ] [ 1, 11; 3, 13; 4, 14; 5, 15 ] [ 0, 10; 1, 11; 3, 13; 4, 14; 5, 15; 6, 16 ] ;; let%test_unit _ = let test l1 l2 expect = let map_of_alist l = Map.of_alist_exn (make_alist l) in let result = Map.merge_skewed (map_of_alist l1) (map_of_alist l2) ~combine:(fun ~key:_ n1 n2 -> n1 - n2) |> Map.to_alist ~key_order:`Increasing in [%test_result: (Key.t * int) list] result ~expect:(make_alist expect) in test [ 1, 2 ] [ 1, 1 ] [ 1, 1 ]; test [ 1, 1 ] [ 1, 2 ] [ 1, -1 ]; (* test arguments that differ in length *) test [ 1, 1; 2, 2 ] [ 1, 0 ] [ 1, 1; 2, 2 ]; test [ 1, 0 ] [ 1, 1; 2, 2 ] [ 1, -1; 2, 2 ] ;; end) ;; let min_and_max_keys ~init keys = List.fold keys ~init:(init, init) ~f:(fun (min, max) key -> ( (if Key.compare key min < 0 then key else min) , if Key.compare key max > 0 then key else max )) ;; let min_elt _ = assert false let min_elt_exn _ = assert false let max_elt _ = assert false let max_elt_exn _ = assert false let%test_unit _ = let min_key, max_key = min_and_max_keys ~init:Key.sample Key.samples in let map = random_map (Key.sample :: Key.samples) in let min_key_element = Map.find_exn map min_key in let max_key_element = Map.find_exn map max_key in assert ([%equal: Key.t * int] (Map.max_elt_exn map) (max_key, max_key_element)); assert ( [%equal: (Key.t * int) option] (Map.max_elt map) (Some (max_key, max_key_element))); assert ([%equal: Key.t * int] (Map.min_elt_exn map) (min_key, min_key_element)); assert ( [%equal: (Key.t * int) option] (Map.min_elt map) (Some (min_key, min_key_element))) ;; let%test _ = [%equal: (Key.t * int) option] (Map.min_elt (Map.empty ())) None let%test _ = [%equal: (Key.t * int) option] (Map.max_elt (Map.empty ())) None let%test _ = try ignore (Map.min_elt_exn (Map.empty ()) : _); false with | _ -> true ;; let%test _ = try ignore (Map.max_elt_exn (Map.empty ()) : _); false with | _ -> true ;; let for_all _ = assert false let exists _ = assert false let count _ = assert false let for_alli _ = assert false let existsi _ = assert false let counti _ = assert false let%test _ = Map.for_all (Map.empty ()) ~f:(fun _ -> assert false) let%test _ = not (Map.exists (Map.empty ()) ~f:(fun _ -> assert false)) let%test _ = Map.count (Map.empty ()) ~f:(fun _ -> assert false) = 0 let%test _ = Map.for_alli (Map.empty ()) ~f:(fun ~key:_ ~data:_ -> assert false) let%test _ = not (Map.existsi (Map.empty ()) ~f:(fun ~key:_ ~data:_ -> assert false)) let%test _ = Map.counti (Map.empty ()) ~f:(fun ~key:_ ~data:_ -> assert false) = 0 let%test_unit _ = let pos x = x >= 0 in let neg x = x < 0 in let poskd ~key:_ ~data:x = x >= 0 in let negkd ~key:_ ~data:x = x < 0 in let base_map = random_map Key.samples in let with_negative = Map.set base_map ~key:Key.sample ~data:(-1) in assert (Map.for_all base_map ~f:pos); assert (not (Map.for_all with_negative ~f:pos)); assert (not (Map.exists base_map ~f:neg)); assert (Map.exists with_negative ~f:neg); assert (Map.count base_map ~f:pos = Map.length base_map); assert (Map.count with_negative ~f:pos = Map.length base_map); assert (Map.count base_map ~f:neg = 0); assert (Map.count with_negative ~f:neg = 1); assert (Map.for_alli base_map ~f:poskd); assert (not (Map.for_alli with_negative ~f:poskd)); assert (not (Map.existsi base_map ~f:negkd)); assert (Map.existsi with_negative ~f:negkd); assert (Map.counti base_map ~f:poskd = Map.length base_map); assert (Map.counti with_negative ~f:poskd = Map.length base_map); assert (Map.counti base_map ~f:negkd = 0); assert (Map.counti with_negative ~f:negkd = 1) ;; let iteri_until _ = assert false let%expect_test "iteri_until" = let test list = let map = list |> List.mapi ~f:(fun i n -> Key.of_int i, n) |> Map.of_alist_exn in Map.iteri_until map ~f:(fun ~key ~data -> let key = Key.to_int key in print_s [%message (key : int) (data : int)]; if key > data then Stop else Continue) |> [%sexp_of: Core.Map.Finished_or_unfinished.t] |> print_s in test [ 3; 1; 4; 1; 5; 9; 2; 6; 5 ]; [%expect {| ((key 0) (data 3)) ((key 1) (data 1)) ((key 2) (data 4)) ((key 3) (data 1)) Unfinished |}]; test [ 1; 4; 9; 16; 25; 36; 49; 64 ]; [%expect {| ((key 0) (data 1)) ((key 1) (data 4)) ((key 2) (data 9)) ((key 3) (data 16)) ((key 4) (data 25)) ((key 5) (data 36)) ((key 6) (data 49)) ((key 7) (data 64)) Finished |}] ;; let fold_until _ = assert false let%expect_test "fold_until" = let test list = let map = List.mapi list ~f:(fun i n -> Key.of_int i, n) |> Map.of_alist_exn in Map.fold_until map ~init:0 ~f:(fun ~key ~data acc -> let key = Key.to_int key in print_s [%message (key : int) (data : int)]; if key > data then Stop acc else Continue (acc + key)) ~finish:Fn.id |> [%sexp_of: int] |> print_s in test [ 3; 1; 4; 1; 5; 9; 2; 6; 5 ]; [%expect {| ((key 0) (data 3)) ((key 1) (data 1)) ((key 2) (data 4)) ((key 3) (data 1)) 3 |}]; test [ 1; 4; 9; 16; 25; 36; 49; 64 ]; [%expect {| ((key 0) (data 1)) ((key 1) (data 4)) ((key 2) (data 9)) ((key 3) (data 16)) ((key 4) (data 25)) ((key 5) (data 36)) ((key 6) (data 49)) ((key 7) (data 64)) 28 |}] ;; let to_sequence ?order:_ ?keys_greater_or_equal_to:_ ?keys_less_or_equal_to:_ _ = assert false ;; let%test_module "to_sequence" = (module struct let m = random_map Key.samples let ( <=> ) observed expected = [%test_eq: (Key.t * int) list] (Sequence.to_list observed) expected ;; let limit_keys min max = List.filter ~f:(fun (key, _) -> Key.( >= ) key min && Key.( <= ) key max) ;; let%test_unit _ = Map.to_sequence ~order:`Increasing_key m <=> Map.to_alist m let%test_unit _ = Map.to_sequence ~order:`Decreasing_key m <=> List.rev (Map.to_alist m) ;; let%test_unit _ = Map.to_sequence ~order:`Increasing_key ~keys_greater_or_equal_to:Key.mid m <=> limit_keys Key.mid Key.max (Map.to_alist m) ;; let%test_unit _ = let keys_greater_or_equal_to, keys_less_or_equal_to = Key.mid, Key.pred Key.max in Map.to_sequence m ~order:`Increasing_key ~keys_greater_or_equal_to ~keys_less_or_equal_to <=> limit_keys keys_greater_or_equal_to keys_less_or_equal_to (Map.to_alist m) ;; let%test_unit _ = Map.to_sequence m ~order:`Increasing_key ~keys_less_or_equal_to:Key.mid <=> limit_keys Key.min Key.mid (Map.to_alist m) ;; let%test_unit _ = Map.to_sequence ~order:`Decreasing_key ~keys_less_or_equal_to:Key.mid m <=> limit_keys Key.min Key.mid (List.rev (Map.to_alist m)) ;; let%test_unit _ = let keys_greater_or_equal_to, keys_less_or_equal_to = Key.succ Key.min, Key.mid in Map.to_sequence m ~order:`Decreasing_key ~keys_greater_or_equal_to ~keys_less_or_equal_to <=> limit_keys keys_greater_or_equal_to keys_less_or_equal_to (List.rev (Map.to_alist m)) ;; let%test_unit _ = Map.to_sequence m ~order:`Decreasing_key ~keys_greater_or_equal_to:Key.mid <=> limit_keys Key.mid Key.max (List.rev (Map.to_alist m)) ;; let%test_unit _ = Map.to_sequence ~order:`Increasing_key (Map.empty ()) <=> [] let%test_unit _ = Map.to_sequence ~order:`Decreasing_key (Map.empty ()) <=> [] let%test_unit _ = Map.to_sequence ~order:`Increasing_key ~keys_greater_or_equal_to:(Key.succ Key.max) m <=> [] ;; let%test_unit _ = Map.to_sequence ~order:`Decreasing_key ~keys_less_or_equal_to:(Key.pred Key.min) m <=> [] ;; let%test_unit _ = Map.to_sequence ~order:`Increasing_key ~keys_less_or_equal_to:Key.min ~keys_greater_or_equal_to:Key.max m <=> [] ;; end) ;; let map_keys _ = assert false let map_keys_exn _ = assert false let%test_module "map_keys" = (module struct let to_alist map = List.map (Map.to_alist map) ~f:(fun (x, y) -> Key.to_int x, y) let of_alist alist = Map.of_alist_exn (List.map alist ~f:(fun (x, y) -> Key.of_int x, y)) ;; let map012 = of_alist [ 0, "one"; 1, "two"; 2, "three" ] let map123 = of_alist [ 1, "one"; 2, "two"; 3, "three" ] let ( <=> ) actual expect = [%test_result: (int * string) list] (to_alist actual) ~expect:(to_alist expect) ;; let%test_unit _ = Map.map_keys_exn map012 ~f:Key.succ <=> map123 let%test _ = does_raise (fun () -> Map.map_keys_exn map123 ~f:(fun _ -> Key.sample)) end) ;; let binary_search_subrange _ ~compare:_ ~lower_bound:_ ~upper_bound:_ = assert false let%test_module "binary_search_subrange" = (module struct (* Strategy is to generate maps keyed by integer, and compare various prefixes of the binary representation. *) module Key_int = struct type t = int [@@deriving quickcheck, sexp_of] let length = 8 (* small but allows a few lengths of prefix *) let quickcheck_generator = Int.gen_uniform_incl 0 ((1 lsl length) - 1) end module Prefix_length = struct type t = int [@@deriving quickcheck, sexp] let quickcheck_generator = Int.gen_uniform_incl 0 Key_int.length end module Key = struct include Key let quickcheck_generator = Quickcheck.Generator.map Key_int.quickcheck_generator ~f:of_int ;; let quickcheck_observer = Quickcheck.Observer.unmap Key_int.quickcheck_observer ~f:to_int ;; let quickcheck_shrinker = Quickcheck.Shrinker.map Key_int.quickcheck_shrinker ~f:of_int ~f_inverse:to_int ;; end module Int_map = struct type t = (int, int) Map.t [@@deriving sexp_of] let quickcheck_generator = Map.quickcheck_generator Key.quickcheck_generator Int.quickcheck_generator ;; let quickcheck_observer = Map.quickcheck_observer Key.quickcheck_observer Int.quickcheck_observer ;; let quickcheck_shrinker = Map.quickcheck_shrinker Key.quickcheck_shrinker Int.quickcheck_shrinker ;; end type t = { map : Int_map.t ; prefix_length : Prefix_length.t ; lower_bound : Key_int.t Maybe_bound.t ; upper_bound : Key_int.t Maybe_bound.t } [@@deriving quickcheck, sexp_of] let suffix_length_of ~prefix_length = Key_int.length - prefix_length let compare_prefix ~prefix_length ~key ~data:_ bound = let prefix_of x = x asr suffix_length_of ~prefix_length in Comparable.lift Int.compare ~f:prefix_of (Key.to_int key) bound ;; let f { map; prefix_length; lower_bound; upper_bound } = Map.binary_search_subrange map ~compare:(compare_prefix ~prefix_length) ~lower_bound ~upper_bound |> Map.to_alist ;; let reference_f { map; prefix_length; lower_bound; upper_bound } = let satisfies_lower_bound (key, data) = match lower_bound with | Unbounded -> true | Incl bound -> compare_prefix ~prefix_length ~key ~data bound >= 0 | Excl bound -> compare_prefix ~prefix_length ~key ~data bound > 0 in let satisfies_upper_bound (key, data) = match upper_bound with | Unbounded -> true | Incl bound -> compare_prefix ~prefix_length ~key ~data bound <= 0 | Excl bound -> compare_prefix ~prefix_length ~key ~data bound < 0 in Map.to_sequence map |> Sequence.filter ~f:satisfies_lower_bound |> Sequence.filter ~f:satisfies_upper_bound |> Sequence.to_list ;; let%expect_test _ = Expect_test_helpers_base.quickcheck [%here] quickcheck_generator ~f:(fun input -> Expect_test_helpers_base.require_equal [%here] (module struct type t = (Key.t * int) list [@@deriving equal, sexp_of] end) (f input) (reference_f input)) ~sexp_of:sexp_of_t ~shrinker:quickcheck_shrinker; [%expect {| |}] ;; end) ;; let length _ = assert false (* Length has to be updated correctly by many operations, which should be tested here. Some basic operations are already tested above. *) let%test_module "length" = (module struct let sample_map = random_map Key.samples let k1 = List.nth_exn (Map.keys sample_map) 0 let k2 = List.nth_exn (Map.keys sample_map) 1 let k3 = List.nth_exn (Map.keys sample_map) 2 let k4 = List.nth_exn (Map.keys sample_map) 3 let%test "change" = let m = Map.set ~key:Key.sample ~data:1 (Map.empty ()) in assert (Map.length m = 1); let m = Map.change m Key.sample ~f:Fn.id in let caml_map = Caml_map.add Key.sample 1 Caml_map.empty in assert (equal_maps ~data_equal:( = ) m ~caml_map); let m = Map.change (Map.empty ()) Key.sample ~f:(Fn.const (Some 1)) in assert (Map.length m = 1); let m = Map.change m Key.sample ~f:(Fn.const (Some 1)) in assert (Map.length m = 1); let m = Map.change m Key.sample ~f:(Fn.const None) in Map.length m = 0 ;; let%test "update" = let m = Map.set ~key:Key.sample ~data:1 (Map.empty ()) in assert (Map.length m = 1); let m = Map.update (Map.empty ()) Key.sample ~f:(Fn.const 1) in assert (Map.length m = 1); let m = Map.update m Key.sample ~f:(Fn.const 1) in Map.length m = 1 ;; let%test "filteri" = let m' = Map.filteri sample_map ~f:(fun ~key:x ~data:_ -> Key.( <> ) x k1 && Key.( <> ) x k2) in let m'' = Map.remove (Map.remove sample_map k1) k2 in assert (Map.length m' = Map.length m''); Map.length m' = Map.length sample_map - 2 ;; let%test "of_alist_exn and of_alist_fold" = let expected_length = List.length Key.samples in let dup x = x, x in let m = Map.of_alist_exn (List.map Key.samples ~f:dup) in assert (Map.length m = List.length Key.samples); let alist = List.map (Key.samples @ Key.samples) ~f:dup in let m = Map.of_alist_fold alist ~init:Key.sample ~f:(fun x _ -> x) in Map.length m = expected_length ;; let%test "merge" = let m1 = Map.of_alist_exn [ k1, 1 ] in let m2 = Map.of_alist_exn [ k2, 2 ] in let m' = Map.merge m1 m2 ~f:(fun ~key:_ -> function | `Both _ -> assert false | `Left x | `Right x -> Some x) in assert (Map.length m' = 2); let m3 = Map.of_alist_exn [ k1, 2 ] in let m' = Map.merge m1 m3 ~f:(fun ~key:_ -> function | `Both (x, _) -> Some x | `Left _ | `Right _ -> assert false) in assert (Map.length m' = 1); let m' = Map.merge m1 m3 ~f:(fun ~key:_ -> function | `Both (_, _) -> None | `Left _ | `Right _ -> assert false) in assert (Map.length m' = 0); let m4 = Map.of_alist_exn [ k1, 1; k2, 2; k3, 3 ] in let m5 = Map.of_alist_exn [ k3, 99; k4, 4 ] in let m' = Map.merge m4 m5 ~f:(fun ~key:_ -> function | `Both (x, _) -> Some x | `Left x | `Right x -> Some x) in Map.length m' = 4 ;; end) ;; let fold_range_inclusive _ = assert false let range_to_alist _ = assert false let closest_key _ = assert false let nth _ = assert false let nth_exn _ = assert false let rank _ = assert false let%test_unit _ = let map = random_map (Key.sample :: Key.samples) in let min_key, max_key = min_and_max_keys ~init:Key.sample Key.samples in let after_min, before_max = List.fold Key.samples ~init:(max_key, min_key) ~f:(fun (near_min, near_max) key -> ( (if Key.compare key min_key > 0 && Key.compare key near_min < 0 then key else near_min) , if Key.compare key max_key < 0 && Key.compare key near_max > 0 then key else near_max )) in let keys_between ~min ~max = Map.fold_range_inclusive map ~min ~max ~f:(fun ~key:_ ~data:_ n -> n + 1) ~init:0 in let length = Map.length map in (* fold_range_inclusive *) (* The two [Key.(>)] assertions below verify that the intervals in the two assertions following them are indeed empty.*) assert (Key.( > ) before_max min_key); assert (Key.( > ) max_key min_key); assert (keys_between ~min:before_max ~max:min_key = 0); assert (keys_between ~min:max_key ~max:min_key = 0); assert (keys_between ~min:min_key ~max:max_key = length); assert (keys_between ~min:after_min ~max:before_max = length - 2); (* closest_key *) let prev_key t k = Map.closest_key t `Less_than k in let next_key t k = Map.closest_key t `Greater_than k in assert ([%equal: (Key.t * int) option] (prev_key map min_key) None); assert ([%equal: (Key.t * int) option] (next_key map max_key) None); let optional_key_equal key = function | None -> false | Some (key', _) -> Key.equal key key' in assert (optional_key_equal min_key (prev_key map after_min)); assert (optional_key_equal max_key (next_key map before_max)); assert (optional_key_equal min_key (Map.closest_key map `Less_or_equal_to min_key)); assert (optional_key_equal min_key (Map.closest_key map `Greater_or_equal_to min_key)); assert (optional_key_equal max_key (Map.closest_key map `Less_or_equal_to max_key)); assert (optional_key_equal max_key (Map.closest_key map `Greater_or_equal_to max_key)); assert (optional_key_equal after_min (Map.closest_key map `Less_or_equal_to after_min)); assert ( optional_key_equal after_min (Map.closest_key map `Greater_or_equal_to after_min)); assert ( optional_key_equal before_max (Map.closest_key map `Less_or_equal_to before_max)); assert ( optional_key_equal before_max (Map.closest_key map `Greater_or_equal_to before_max)); (let map_with_hole_after_min = Map.remove map after_min in assert (optional_key_equal min_key (prev_key map_with_hole_after_min after_min)); assert ( optional_key_equal min_key (Map.closest_key map_with_hole_after_min `Less_or_equal_to after_min)); let map_with_hole_before_max = Map.remove map before_max in assert (optional_key_equal max_key (next_key map_with_hole_before_max before_max)); assert ( optional_key_equal max_key (Map.closest_key map_with_hole_before_max `Greater_or_equal_to before_max))); (* range_to_alist *) assert ( alist_equal ~data_equal:( = ) (Map.range_to_alist ~min:min_key ~max:max_key map) (Map.to_alist map)); assert ( alist_equal ~data_equal:( = ) (Map.range_to_alist ~min:after_min ~max:before_max map) (Map.to_alist (Map.remove (Map.remove map min_key) max_key))); (* rank *) assert ([%equal: int option] (Map.rank map min_key) (Some 0)); assert ([%equal: int option] (Map.rank map after_min) (Some 1)); assert ([%equal: int option] (Map.rank map before_max) (Some (length - 2))); assert ([%equal: int option] (Map.rank map max_key) (Some (length - 1))); assert ([%equal: int option] (Map.rank (Map.remove map Key.sample) Key.sample) None); (* nth *) assert ( alist_equal ~data_equal:( = ) (Map.to_alist map) (List.init (Map.length map) ~f:(Map.nth map) |> List.filter_opt)); assert (Option.is_none (Map.nth map (-1))); assert (Option.is_none (Map.nth map (Map.length map))) ;; let _ = Map.nth_exn (* same testing as nth *) let split _ = assert false let%test_unit _ = let check here map pivot = let l, maybe, r = Map.split map pivot in assert (Map.invariants l); assert (Map.invariants r); Map.iteri l ~f:(fun ~key ~data:_ -> assert (Key.( < ) key pivot)); Map.iteri r ~f:(fun ~key ~data:_ -> assert (Key.( > ) key pivot)); [%test_eq: (Key.t * int) option] ~here:[ here ] (Option.map ~f:(fun d -> pivot, d) (Map.find map pivot)) maybe; [%test_eq: int] ~here:[ here ] (Map.length map) (Map.length l + Map.length r + Option.length maybe) in let map = random_map Key.samples in check [%here] map Key.min; check [%here] map Key.max; check [%here] map Key.mid; let map = Map.remove map Key.mid in check [%here] map Key.mid ;; let subrange _ = assert false let%test_unit "subrange" = let check here map ~lower_bound ~upper_bound = let res = Map.subrange map ~lower_bound ~upper_bound in assert (Map.invariants res); let subrange_computed_naively = try Map.fold map ~init:(Map.empty ()) ~f:(fun ~key ~data acc -> if Maybe_bound.interval_contains_exn key ~lower:lower_bound ~upper:upper_bound ~compare:Key.compare then Map.set acc ~key ~data else acc) with | _ -> Map.empty () in [%test_result: (int, int) Map.t] ~here:[ here; [%here] ] ~expect:subrange_computed_naively res in let map = random_map Key.samples in check [%here] map ~lower_bound:Unbounded ~upper_bound:Unbounded; check [%here] map ~lower_bound:(Incl Key.min) ~upper_bound:(Incl Key.max); check [%here] map ~lower_bound:(Excl Key.min) ~upper_bound:(Incl Key.max); check [%here] map ~lower_bound:(Incl Key.min) ~upper_bound:(Excl Key.max); check [%here] map ~lower_bound:(Excl Key.min) ~upper_bound:(Excl Key.max); check [%here] map ~lower_bound:(Excl Key.min) ~upper_bound:Unbounded; check [%here] map ~lower_bound:(Incl Key.max) ~upper_bound:(Excl Key.min); check [%here] map ~lower_bound:(Incl Key.min) ~upper_bound:(Excl Key.mid); check [%here] map ~lower_bound:(Incl Key.min) ~upper_bound:(Incl Key.mid); let map = Map.remove map Key.mid in check [%here] map ~lower_bound:(Incl Key.min) ~upper_bound:(Excl Key.mid); check [%here] map ~lower_bound:(Incl Key.min) ~upper_bound:(Incl Key.mid); let lmid = Key.(of_int ((to_int min + to_int mid) / 2)) and rmid = Key.(of_int ((to_int mid + to_int max) / 2)) in check [%here] map ~lower_bound:(Incl lmid) ~upper_bound:(Incl rmid); check [%here] map ~lower_bound:(Incl lmid) ~upper_bound:(Excl rmid); check [%here] map ~lower_bound:(Excl lmid) ~upper_bound:(Incl rmid); check [%here] map ~lower_bound:(Excl lmid) ~upper_bound:(Excl rmid) ;; let append ~lower_part:_ ~upper_part:_ = assert false let%test_unit "append" = let check whole lower_part upper_part = match Map.append ~lower_part ~upper_part with | `Ok whole2 -> assert (Map.invariants whole2); assert ( 0 = Map.compare Int.compare (fun x y -> if phys_equal x y then 0 else 1) whole2 whole) | `Overlapping_key_ranges -> failwith "expected Ok" in let check_fail lower_part upper_part = match Map.append ~lower_part ~upper_part with | `Ok _ -> failwith "expected Error" | `Overlapping_key_ranges -> () in let map = random_map Key.samples in let mid_value = Map.find map Key.mid |> Option.value_exn in let map_without_mid = Map.remove map Key.mid in let lower_part, _, upper_part = Map.split map_without_mid Key.mid in check map_without_mid lower_part upper_part; check_fail upper_part lower_part; check_fail (Map.set lower_part ~key:Key.mid ~data:mid_value) (Map.set upper_part ~key:Key.mid ~data:mid_value); let check_via_alist lower_part upper_part = match Map.append ~lower_part ~upper_part with | `Ok whole_map -> assert (Map.invariants whole_map); let expected_whole_map = Map.of_alist_exn (List.append (Map.to_alist lower_part) (Map.to_alist upper_part)) and compare = Map.compare Int.compare (fun x y -> if phys_equal x y then 0 else 1) in assert (compare expected_whole_map whole_map = 0) | `Overlapping_key_ranges -> let lower_part_max = Key.to_int (fst (Map.max_elt_exn lower_part)) and upper_part_min = Key.to_int (fst (Map.min_elt_exn upper_part)) in assert (Int.compare lower_part_max upper_part_min >= 0) in let examples = List.map ~f:(fun l -> Map.of_alist_exn (List.map ~f:(Tuple2.map_fst ~f:Key.of_int) l)) [ [ 1, 1; 2, 2; 3, 3 ] ; [ 3, 3; 4, 4; 5, 5 ] ; [ 6, 6 ] ; [ 1, 1; 6, 6 ] ; [ 1, 1; 2, 2 ] ] in List.Let_syntax.( let%map l = examples and r = examples in l, r) |> List.iter ~f:(fun (l, r) -> check_via_alist l r) ;; let%test _ = [%equal: (Key.t * int) option] (Map.closest_key (Map.empty ()) `Greater_or_equal_to Key.sample) None ;; let%test _ = [%equal: (Key.t * int) option] (Map.closest_key (Map.empty ()) `Greater_than Key.sample) None ;; let%test _ = [%equal: (Key.t * int) option] (Map.closest_key (Map.empty ()) `Less_or_equal_to Key.sample) None ;; let%test _ = [%equal: (Key.t * int) option] (Map.closest_key (Map.empty ()) `Less_than Key.sample) None ;; let binary_search _ = assert false let binary_search_segmented _ = assert false let%test_module "binary_search" = (module struct let small_map = Map.of_alist_exn (List.map ~f:(Tuple2.map_fst ~f:Key.of_int) [ 1, 1; 2, 2; 3, 3 ]) ;; let compare_key ~key ~data:_ k = Int.compare (Key.to_int key) k let%test _ = [%equal: (Key.t * int) option] (Map.binary_search (Map.empty ()) ~compare:compare_key `First_equal_to 1) None ;; let%test _ = [%equal: (Key.t * int) option] (Map.binary_search small_map ~compare:compare_key `First_equal_to 2) (Some (Key.of_int 2, 2)) ;; let%test _ = [%equal: (Key.t * int) option] (Map.binary_search small_map ~compare:compare_key `First_greater_than_or_equal_to 2) (Some (Key.of_int 2, 2)) ;; let%test _ = [%equal: (Key.t * int) option] (Map.binary_search small_map ~compare:compare_key `First_strictly_greater_than 3) None ;; let%test _ = [%equal: (Key.t * int) option] (Map.binary_search_segmented (Map.empty ()) ~segment_of:(fun ~key:_ ~data:_ -> assert false) `First_on_right) None ;; let%test _ = [%equal: (Key.t * int) option] (Map.binary_search_segmented small_map ~segment_of:(fun ~key ~data:_ -> if Key.to_int key < 3 then `Left else `Right) `First_on_right) (Some (Key.of_int 3, 3)) ;; let%test _ = [%equal: (Key.t * int) option] (Map.binary_search_segmented small_map ~segment_of:(fun ~key ~data:_ -> if Key.to_int key < 3 then `Left else `Right) `Last_on_left) (Some (Key.of_int 2, 2)) ;; let%test _ = [%equal: (Key.t * int) option] (Map.binary_search_segmented small_map ~segment_of:(fun ~key ~data:_ -> if Key.to_int key > 3 then `Right else `Left) `First_on_right) None ;; end) ;; let validate ~name:_ _ = assert false let%test_unit _ = let validate expect map = expect (Validate.result (Map.validate ~name:Key.to_string (Validate.of_error (fun i -> if i mod 2 = 0 then Ok () else error "must be even" i [%sexp_of: int])) map)) in let is_ok = Result.is_ok in let is_error = Result.is_error in assert (validate is_ok (Map.empty ())); assert (validate is_ok (Map.of_alist_exn [ Key.of_int 0, 0 ])); assert (validate is_error (Map.of_alist_exn [ Key.of_int 0, 1 ])); assert (validate is_ok (Map.of_alist_exn [ Key.of_int 0, 0; Key.of_int 1, 0 ])); assert (validate is_error (Map.of_alist_exn [ Key.of_int 0, 0; Key.of_int 1, 1 ])) ;; let validatei ~name:_ _ = assert false let%test_unit _ = let checki (key, data) = if Key.to_int key mod 2 = 0 && data mod 2 = 0 then Ok () else error_s [%message "key and data must be even" (key : Key.t) (data : int)] in let validatei expect map = expect (Validate.result (Map.validatei ~name:Key.to_string (Validate.of_error checki) map)) in let is_ok = Result.is_ok in let is_error = Result.is_error in assert (validatei is_ok (Map.empty ())); assert (validatei is_ok (Map.of_alist_exn [ Key.of_int 0, 0 ])); assert (validatei is_error (Map.of_alist_exn [ Key.of_int 0, 1 ])); assert (validatei is_error (Map.of_alist_exn [ Key.of_int 1, 0 ])); assert (validatei is_ok (Map.of_alist_exn [ Key.of_int 0, 0; Key.of_int 2, 0 ])); assert (validatei is_error (Map.of_alist_exn [ Key.of_int 0, 0; Key.of_int 1, 1 ])); assert (validatei is_error (Map.of_alist_exn [ Key.of_int 0, 0; Key.of_int 2, 1 ])); assert (validatei is_error (Map.of_alist_exn [ Key.of_int 0, 0; Key.of_int 1, 2 ])) ;; (* Ensure polymorphic equality raises for maps. *) let%test_unit _ = match Map.kind with | `Tree -> () | `Map -> let ts = [ Map.empty (); Map.of_alist_exn [ Key.sample, 13 ] ] in List.iter ts ~f:(fun t1 -> List.iter ts ~f:(fun t2 -> assert (Exn.does_raise (fun () -> Poly.equal t1 t2)))) ;; let key_set _ = assert false let%test_unit _ = assert (Set.is_empty (Map.key_set (Map.empty ()))) let%test_unit _ = let m = Map.of_alist_exn (List.map ~f:(Tuple2.map_fst ~f:Key.of_int) [ 1, 1; 2, 2; 3, 3 ]) in let s = Map.key_set m in assert (Set.length s = Map.length m); Map.iteri m ~f:(fun ~key ~data -> assert (Key.to_int key = data)); assert ([%equal: Key.t list] (Set.to_list s) (Map.keys m)) ;; let of_key_set _ = assert false let%test_unit _ = assert (Map.is_empty (Map.of_key_set (Map.key_set (Map.empty ())) ~f:Key.to_int)) ;; let%test_unit _ = let m = Map.of_alist_exn (List.map ~f:(Tuple2.map_fst ~f:Key.of_int) [ 1, 1; 2, 2; 3, 3 ]) in let key_set = Map.key_set m in assert (Map.equal Int.equal (Map.of_key_set key_set ~f:Key.to_int) m) ;; let quickcheck_generator _ _ = assert false let%test_module _ = (module struct open Quickcheck let sexp_of = [%sexp_of: (int, char) Map.t] let compare = Map.compare_direct Char.compare let quickcheck_generator = Map.quickcheck_generator Key.quickcheck_generator Char.quickcheck_generator ;; let can_generate f = test_can_generate quickcheck_generator ~sexp_of ~f let%test_unit _ = test_distinct_values quickcheck_generator ~sexp_of ~compare ~trials:1_000 ~distinct_values:500 ;; let%test_unit _ = can_generate (fun t -> Map.is_empty t) let%test_unit _ = can_generate (fun t -> Map.length t = 1) let%test_unit _ = can_generate (fun t -> Map.length t = 2) let%test_unit _ = can_generate (fun t -> Map.length t >= 3) let%test_unit _ = can_generate (fun t -> Map.existsi t ~f:(fun ~key ~data:_ -> Key.to_int key >= 0)) ;; let%test_unit _ = can_generate (fun t -> Map.existsi t ~f:(fun ~key ~data:_ -> Key.to_int key < 0)) ;; end) ;; let quickcheck_observer _ _ = assert false let%test_module _ = (module struct open Quickcheck module Int_char_map = struct type t = (int, char) Map.t [@@deriving sexp_of, compare] let hash_fold_t hash t = [%hash_fold: (Key.t * char) list] hash (Map.to_alist t) let hash t = hash_fold_t (Hash.alloc ()) t |> Hash.get_hash_value end module F = Fn_for_testing.Make (Int_char_map) (Int) (struct let examples = [] :: List.mapi Key.samples ~f:(fun i key -> key, Char.of_int_exn i) :: List.mapi Key.samples ~f:(fun i key -> [ key, Char.of_int_exn i ]) |> List.map ~f:Map.of_alist_exn ;; end) let sexp_of = [%sexp_of: F.t] let compare = [%compare: F.t] let quickcheck_generator = (* memoizing these functions makes [test_no_duplicates] run much faster *) let hashable = Hashtbl_intf.Hashable.of_key (module Int_char_map) in Generator.( fn (Map.quickcheck_observer Key.quickcheck_observer Char.quickcheck_observer) Int.quickcheck_generator |> map ~f:(fun f -> Memo.general f ~hashable)) ;; let can_generate ?trials f = test_can_generate quickcheck_generator ?trials ~sexp_of ~f ;; let%test_unit (_ [@tags "no-js"]) = test_distinct_values quickcheck_generator ~sexp_of ~compare ~trials:1_000 ~distinct_values:500 ;; let%test_unit _ = can_generate (fun f -> f (Map.singleton (Key.of_int 0) 'a') <> f (Map.empty ())) ;; let%test_unit _ = can_generate (fun f -> f (Map.singleton (Key.of_int 0) 'a') <> f (Map.singleton (Key.of_int 1) 'a')) ;; let%test_unit _ = can_generate (fun f -> f (Map.singleton (Key.of_int 0) 'a') <> f (Map.singleton (Key.of_int 0) 'b')) ;; end) ;; let quickcheck_shrinker _ _ = assert false let%test_module _ = (module struct open Quickcheck let key_shrinker = Shrinker.create (fun t -> let n = Key.to_int t in if Int.( <= ) n 0 then Sequence.empty else Sequence.singleton (Key.of_int (Int.pred n))) ;; let quickcheck_shrinker = Map.quickcheck_shrinker key_shrinker String.quickcheck_shrinker ;; let normalize_alist alist = List.sort alist ~compare:(fun (k1, _) (k2, _) -> Int.compare k1 k2) ;; let normalize_alists alists = List.map alists ~f:normalize_alist |> List.sort ~compare:[%compare: (int * string) list] ;; let map_of_alist alist = List.map alist ~f:(fun (k, v) -> Key.of_int k, v) |> Map.of_alist_exn ;; let alist_of_map t = Map.to_alist t |> List.map ~f:(fun (k, v) -> Key.to_int k, v) let test alist shrunk_alists = [%test_result: (int * string) list list] (map_of_alist alist |> Shrinker.shrink quickcheck_shrinker |> Sequence.to_list |> List.map ~f:alist_of_map |> normalize_alists) ~expect:(normalize_alists shrunk_alists) ;; let%test_unit _ = test [] [] let%test_unit _ = test [ 0, "" ] [ [] ] let%test_unit _ = test [ 1, "" ] [ []; [ 0, "" ] ] let%test_unit _ = test [ 0, "a" ] [ []; [ 0, "" ] ] let%test_unit _ = test [ 1, "a" ] [ []; [ 0, "a" ]; [ 1, "" ] ] let%test_unit _ = test [ 0, "a"; 1, "b" ] [ [ 0, "a" ]; [ 1, "b" ]; [ 0, ""; 1, "b" ]; [ 0, "a"; 1, "" ] ] ;; end) ;; end module Key_int = struct type 'a t = int [@@deriving sexp, compare, hash] let of_int = Fn.id let to_int = Fn.id end module Key_poly = struct type 'a t = 'a [@@deriving sexp, compare, hash] let of_int = Fn.id let to_int = Fn.id end module Create_options_with_comparator = struct type ('a, 'b, 'c) create_options = ('a, 'b, 'c) With_comparator.t let simplify_creator f = f ~comparator:Int.comparator end module Create_options_without_comparator = struct type ('a, 'b, 'c) create_options = ('a, 'b, 'c) Without_comparator.t let simplify_creator = Fn.id end module Create_options_with_first_class_module = struct type ('a, 'b, 'c) create_options = ('a, 'b, 'c) With_first_class_module.t let simplify_creator f = f (module Int : Comparator.S with type t = _ and type comparator_witness = _) ;; end module Access_options_without_comparator = struct type ('a, 'b, 'c) access_options = ('a, 'b, 'c) Without_comparator.t let simplify_accessor = Fn.id end module Access_options_with_comparator = struct type ('a, 'b, 'c) access_options = ('a, 'b, 'c) With_comparator.t let simplify_accessor f = f ~comparator:Int.comparator end let%test_module "Map" = (module Unit_tests (Key_poly) (struct include Map type ('a, 'b, 'c) t_ = ('a, 'b, 'c) t type ('a, 'b, 'c) tree = ('a, 'b, 'c) Tree.t type 'cmp cmp = 'cmp include Create_options_with_first_class_module include Access_options_without_comparator let kind = `Map end)) ;; let%test_module "Map.Poly" = (module Unit_tests (Key_poly) (struct include Map.Poly type ('a, 'b, 'c) t_ = ('a, 'b) t type ('a, 'b, 'c) tree = ('a, 'b) Tree.t type 'cmp cmp = comparator_witness include Create_options_without_comparator include Access_options_without_comparator let kind = `Map end)) ;; let%test_module "Int.Map" = (module Unit_tests (Key_int) (struct include Int.Map module Tree = Map.Make_tree (Int.Map.Key) type ('a, 'b, 'c) t_ = 'b t type ('a, 'b, 'c) tree = 'b Tree.t type 'cmp cmp = Int.comparator_witness include Create_options_without_comparator include Access_options_without_comparator let kind = `Map end)) ;; let%test_module "Map.Tree" = (module Unit_tests (Key_poly) (struct include Map.Tree type ('a, 'b, 'c) t_ = ('a, 'b, 'c) t type ('a, 'b, 'c) tree = ('a, 'b, 'c) t type 'cmp cmp = 'cmp include Create_options_with_comparator include Access_options_with_comparator let kind = `Tree end)) ;; let%test_module "Map.Poly.Tree" = (module Unit_tests (Key_poly) (struct include Map.Poly.Tree type ('a, 'b, 'c) t_ = ('a, 'b) t type ('a, 'b, 'c) tree = ('a, 'b) t type 'cmp cmp = comparator_witness include Create_options_without_comparator include Access_options_without_comparator let kind = `Tree end)) ;; let%test_module "Int.Map.Tree" = (module Unit_tests (Key_int) (struct include Map.Make_tree (Int.Map.Key) type ('a, 'b, 'c) t_ = 'b t type ('a, 'b, 'c) tree = 'b t type 'cmp cmp = Int.comparator_witness include Create_options_without_comparator include Access_options_without_comparator let kind = `Tree end)) ;; let%test_unit _ = Core.Map.find_or_error (Int.Map.singleton 1 ()) 1 |> Or_error.ok_exn let%expect_test _ = Core.Map.find_or_error Int.Map.empty 1 |> printf !"%{sexp: unit Or_error.t}"; [%expect {| (Error ("key not found" 1)) |}] ;; let%expect_test _ = Core.Map.find_or_error Map.Poly.empty 1 |> printf !"%{sexp: unit Or_error.t}"; [%expect {| (Error ("key not found" _)) |}] ;; core-0.15.0/core/test/src/core_map_unit_tests.mli000066400000000000000000000000561420273305200217730ustar00rootroot00000000000000(* Unit test interface intentionally blank *) core-0.15.0/core/test/src/core_set_unit_tests.ml000066400000000000000000001054651420273305200216520ustar00rootroot00000000000000open! Core module Merge_to_sequence_element = Set_intf.Merge_to_sequence_element module With_comparator = Set_intf.With_comparator module Without_comparator = Set_intf.Without_comparator module With_first_class_module = Set_intf.With_first_class_module let%test_module _ = (module struct let ( = ) = Poly.( = ) let%test _ = Set.Poly.stable_dedup_list [] = [] let%test _ = Set.Poly.stable_dedup_list [ 5; 5; 5; 5; 5 ] = [ 5 ] let%test _ = Set.Poly.stable_dedup_list [ 5; 9; 3; 5; 2; 2 ] = [ 5; 9; 3; 2 ] end) ;; module Unit_tests (Elt : sig type 'a t [@@deriving sexp, hash] val of_int : int -> int t val to_int : int t -> int end) (Set : sig type ('a, 'b) t_ type ('a, 'b) set type ('a, 'b) tree type ('a, 'b) named type ('a, 'b, 'c) create_options include Set_intf.Creators_generic with type ('a, 'b) t := ('a, 'b) t_ with type ('a, 'b) set := ('a, 'b) set with type ('a, 'b) tree := ('a, 'b) tree with type 'a elt := 'a Elt.t with type ('a, 'b, 'c) options := ('a, 'b, 'c) create_options val simplify_creator : (int, Int.comparator_witness, 'c) create_options -> 'c type ('a, 'b, 'c) access_options include Set_intf.Accessors_generic with type ('a, 'b) t := ('a, 'b) t_ with type ('a, 'b) tree := ('a, 'b) tree with type 'a elt := 'a Elt.t with type ('a, 'b) named := ('a, 'b) named with type ('a, 'b, 'c) options := ('a, 'b, 'c) access_options with type 'cmp cmp := 'cmp cmp val create_named : ('a, 'b) t_ -> name:string -> ('a, 'b) named val simplify_accessor : (int, Int.comparator_witness, 'c) access_options -> 'c val kind : [ `Set | `Tree ] val is_poly : bool end) : Set_intf.Creators_and_accessors_generic = struct module Set = struct include Set let add = simplify_accessor add let remove = simplify_accessor remove let mem = simplify_accessor mem (* let filter = simplify_accessor filter *) let compare_direct = simplify_accessor compare_direct let equal = simplify_accessor equal let inter = simplify_accessor inter let union = simplify_accessor union let is_subset = simplify_accessor is_subset let are_disjoint = simplify_accessor are_disjoint module Named = struct let is_subset = simplify_accessor Set.Named.is_subset let equal = simplify_accessor Set.Named.equal end let iter2 = simplify_accessor iter2 let invariants = simplify_accessor invariants let to_map = simplify_accessor to_map let quickcheck_shrinker = simplify_accessor quickcheck_shrinker let to_list = to_list let to_array = to_array let to_sequence ?order ?greater_or_equal_to ?less_or_equal_to x = simplify_accessor to_sequence ?order ?greater_or_equal_to ?less_or_equal_to x ;; let binary_search = simplify_accessor binary_search let binary_search_segmented = simplify_accessor binary_search_segmented let merge_to_sequence ?order ?greater_or_equal_to ?less_or_equal_to x y = simplify_accessor merge_to_sequence ?order ?greater_or_equal_to ?less_or_equal_to x y ;; let empty () = simplify_creator empty let singleton = simplify_creator singleton let of_list = simplify_creator of_list let of_sequence = simplify_creator of_sequence let of_hash_set = simplify_creator of_hash_set let of_hashtbl_keys = simplify_creator of_hashtbl_keys let of_sorted_array = simplify_creator of_sorted_array let of_sorted_array_unchecked = simplify_creator of_sorted_array_unchecked (* let of_tree = simplify_creator of_tree *) let quickcheck_generator = simplify_creator quickcheck_generator let symmetric_diff = simplify_accessor symmetric_diff let split = simplify_accessor split let diff = simplify_accessor diff let sexp_of_t_ t = [%sexp_of: int Elt.t list] (to_list t) type t = (int, Int.comparator_witness) t_ let sexp_of_t = sexp_of_t_ let compare = compare_direct end type ('a, 'b) t = Unit_test_follows type ('a, 'b) tree = ('a, 'b) t type ('a, 'b) set = ('a, 'b) t type 'a elt type ('a, 'b, 'c) options = ('a, 'b, 'c) Without_comparator.t type 'a cmp module Elt = struct open Elt let of_int = of_int let to_int = to_int let quickcheck_generator = let open Quickcheck.Generator in Int.quickcheck_generator >>| of_int ;; let quickcheck_observer = Quickcheck.Observer.unmap Int.quickcheck_observer ~f:to_int module T = struct type t = int Elt.t [@@deriving sexp, hash] let compare t t' = Poly.compare (to_int t) (to_int t') let hash t = Hashtbl.hash (to_int t) end include T include Comparable.Make (T) include Hashable.Make (T) let samples = List.dedup_and_sort ~compare (List.init 10 ~f:(fun i -> of_int (i + 1))) let absent = of_int 0 let present = of_int 1 let () = assert (List.mem ~equal samples present) let () = assert (not (List.mem ~equal samples absent)) end let set_empty = Set.empty () let set_nonempty = Set.of_list Elt.samples let gen_set = let open Quickcheck.Generator in List.quickcheck_generator Elt.quickcheck_generator >>| Set.of_list ;; let add _ = assert false let of_list _ = assert false let of_sequence _ = assert false let of_hash_set _ = assert false let of_hashtbl_keys _ = assert false let mem _ = assert false let%test _ = List.for_all Elt.samples ~f:(fun e -> Set.mem set_nonempty e) let is_empty _ = assert false let%test _ = Set.is_empty set_empty let%test _ = not (Set.is_empty set_nonempty) let%test _ = let set' = List.fold Elt.samples ~init:(Set.empty ()) ~f:Set.add in Set.equal set_nonempty set' ;; type ('a, 'cmp) named = int let inter _ = assert false let%test _ = Set.is_empty (Set.inter set_empty set_nonempty) let%test _ = Set.is_empty (Set.inter set_nonempty set_empty) let%test _ = let single = Set.singleton Elt.absent in Set.equal single (Set.inter single (Set.add set_nonempty Elt.absent)) ;; let%test _ = Set.equal set_nonempty (Set.inter set_nonempty set_nonempty) let%test_unit "inter = all members of s1 that are members of s2" = Quickcheck.test (Quickcheck.Generator.tuple2 gen_set gen_set) ~sexp_of:[%sexp_of: Set.t * Set.t] ~f:(fun (s1, s2) -> [%test_result: Set.t] (Set.inter s1 s2) ~expect: (Set.fold s1 ~init:(Set.empty ()) ~f:(fun inter elt -> if Set.mem s2 elt then Set.add inter elt else inter))) ;; let is_subset _ ~of_:_ = assert false let%test _ = Set.is_subset set_empty ~of_:set_nonempty let%test _ = not (Set.is_subset set_nonempty ~of_:set_empty) let%test _ = Set.is_subset set_nonempty ~of_:set_nonempty let%test _ = Set.is_subset set_empty ~of_:set_empty let%test _ = not (Set.is_subset set_nonempty ~of_:(Set.singleton Elt.present)) let%test_unit "is_subset = all members of subset are members of superset" = Quickcheck.test (Quickcheck.Generator.tuple2 gen_set gen_set) ~sexp_of:[%sexp_of: Set.t * Set.t] ~f:(fun (superset, subset) -> [%test_result: bool] (Set.is_subset subset ~of_:superset) ~expect:(Set.for_all subset ~f:(Set.mem superset))) ;; let are_disjoint _ _ = assert false let%test_unit "are_disjoint = is_empty inter" = Quickcheck.test (Quickcheck.Generator.tuple2 gen_set gen_set) ~sexp_of:[%sexp_of: Set.t * Set.t] ~f:(fun (s1, s2) -> [%test_result: bool] (Set.are_disjoint s1 s2) ~expect:(Set.is_empty (Set.inter s1 s2))) ;; module Named = struct let is_subset _ ~of_:_ = assert false let%expect_test "validate_subset" = let map1 = Set.create_named ~name:"the empty set" set_empty in let map2 = Set.create_named ~name:"the set of integers from 1 to 10" set_nonempty in print_s [%sexp (Set.Named.is_subset map2 ~of_:map1 : unit Or_error.t)]; if Set.is_poly then [%expect {| (Error ("the set of integers from 1 to 10 is not a subset of the empty set" (invalid_elements (_ _ _ _ _ _ _ _ _ _)))) |}] else [%expect {| (Error ("the set of integers from 1 to 10 is not a subset of the empty set" (invalid_elements (1 2 3 4 5 6 7 8 9 10)))) |}]; print_s [%sexp (Set.Named.is_subset map1 ~of_:map2 : unit Or_error.t)]; [%expect {| (Ok ()) |}] ;; let equal _ _ = assert false let%expect_test "validate_subset" = let map1 = Set.create_named ~name:"the set of integers from 1 to 10" set_nonempty in (let map2 = Set.create_named ~name:"the set of integers from 10 to 19" (Set.of_list (List.init 10 ~f:(fun i -> Elt.of_int (i + 10)))) in print_s [%sexp (Set.Named.equal map1 map2 : unit Or_error.t)]; if Set.is_poly then [%expect {| (Error (("the set of integers from 1 to 10 is not a subset of the set of integers from 10 to 19" (invalid_elements (_ _ _ _ _ _ _ _ _))) ("the set of integers from 10 to 19 is not a subset of the set of integers from 1 to 10" (invalid_elements (_ _ _ _ _ _ _ _ _))))) |}] else [%expect {| (Error (("the set of integers from 1 to 10 is not a subset of the set of integers from 10 to 19" (invalid_elements (1 2 3 4 5 6 7 8 9))) ("the set of integers from 10 to 19 is not a subset of the set of integers from 1 to 10" (invalid_elements (11 12 13 14 15 16 17 18 19))))) |}]); print_s [%sexp (Set.Named.equal map1 map1 : unit Or_error.t)]; [%expect {| (Ok ()) |}] ;; end let to_list _ = assert false let%test _ = let elts = Set.to_list set_nonempty in List.for_all elts ~f:(fun elt -> Set.mem set_nonempty elt) ;; let rec is_list_ordered_ascending xs = match xs with | [] | [ _ ] -> true | a :: b :: xs' -> Elt.compare a b < 0 && is_list_ordered_ascending (b :: xs') ;; let%test _ = is_list_ordered_ascending (Set.to_list set_nonempty) let to_array _ = assert false let%test _ = let a = Set.to_array set_nonempty in List.equal Elt.equal (Array.to_list a) (Set.to_list set_nonempty) ;; let to_sequence ?order:_ ?greater_or_equal_to:_ ?less_or_equal_to:_ _ : _ Sequence.t = assert false ;; let%test_module "to_sequence" = (module struct let ( <=> ) observed expected = [%test_eq: Elt.t list] (Sequence.to_list observed) expected ;; let m = set_nonempty (* Calibration: make sure [m] contains elements less than 4, greater than 8, and between these two. Otherwise the tests aren't testing what we want. *) let%test _ = let l = Set.to_list m in List.exists l ~f:(fun x -> Elt.(x < of_int 4)) && List.exists l ~f:(fun x -> Elt.(x >= of_int 4) && Elt.(x <= of_int 8)) && List.exists l ~f:(fun x -> Elt.(x > of_int 8)) ;; let%test_unit _ = Set.to_sequence ~order:`Increasing m <=> Set.to_list m let%test_unit _ = Set.to_sequence ~order:`Decreasing m <=> List.rev (Set.to_list m) let%test_unit _ = Set.to_sequence ~order:`Increasing ~greater_or_equal_to:(Elt.of_int 4) m <=> List.filter ~f:(fun x -> Elt.(x >= of_int 4)) (Set.to_list m) ;; let%test_unit _ = Set.to_sequence m ~order:`Increasing ~greater_or_equal_to:(Elt.of_int 4) ~less_or_equal_to:(Elt.of_int 8) <=> List.filter ~f:(fun x -> Elt.(x >= of_int 4) && Elt.(x <= of_int 8)) (Set.to_list m) ;; let%test_unit _ = Set.to_sequence ~order:`Decreasing ~less_or_equal_to:(Elt.of_int 4) m <=> List.filter ~f:(fun x -> Elt.(x <= of_int 4)) (List.rev (Set.to_list m)) ;; let%test_unit _ = Set.to_sequence m ~order:`Decreasing ~less_or_equal_to:(Elt.of_int 8) ~greater_or_equal_to:(Elt.of_int 4) <=> List.filter ~f:(fun x -> Elt.(x <= of_int 8) && Elt.(x >= of_int 4)) (List.rev (Set.to_list m)) ;; let%test_unit _ = Set.to_sequence ~order:`Increasing (Set.empty ()) <=> [] let%test_unit _ = Set.to_sequence ~order:`Decreasing (Set.empty ()) <=> [] let%test_unit _ = Set.to_sequence ~order:`Increasing ~greater_or_equal_to:(Elt.of_int 11) m <=> [] ;; let%test_unit _ = Set.to_sequence ~order:`Decreasing ~less_or_equal_to:(Elt.of_int ~-1) m <=> [] ;; end) ;; let binary_search _ = assert false let binary_search_segmented _ = assert false let%test_module "binary_search" = (module struct let small_set = Set.of_list (List.map ~f:Elt.of_int [ 1; 2; 3 ]) let compare_elt elt v = Int.compare (Elt.to_int elt) v let%test _ = [%equal: Elt.t option] (Set.binary_search (Set.empty ()) ~compare:compare_elt `First_equal_to 1) None ;; let%test _ = [%equal: Elt.t option] (Set.binary_search small_set ~compare:compare_elt `First_equal_to 2) (Some (Elt.of_int 2)) ;; let%test _ = [%equal: Elt.t option] (Set.binary_search small_set ~compare:compare_elt `First_greater_than_or_equal_to 2) (Some (Elt.of_int 2)) ;; let%test _ = [%equal: Elt.t option] (Set.binary_search small_set ~compare:compare_elt `First_strictly_greater_than 3) None ;; let%test _ = [%equal: Elt.t option] (Set.binary_search_segmented (Set.empty ()) ~segment_of:(fun _ -> assert false) `First_on_right) None ;; let%test _ = [%equal: Elt.t option] (Set.binary_search_segmented small_set ~segment_of:(fun elt -> if Elt.to_int elt < 3 then `Left else `Right) `First_on_right) (Some (Elt.of_int 3)) ;; let%test _ = [%equal: Elt.t option] (Set.binary_search_segmented small_set ~segment_of:(fun elt -> if Elt.to_int elt < 3 then `Left else `Right) `Last_on_left) (Some (Elt.of_int 2)) ;; let%test _ = [%equal: Elt.t option] (Set.binary_search_segmented small_set ~segment_of:(fun elt -> if Elt.to_int elt > 3 then `Right else `Left) `First_on_right) None ;; end) ;; let merge_to_sequence ?order:_ ?greater_or_equal_to:_ ?less_or_equal_to:_ _ _ : _ Sequence.t = assert false ;; let%test_module "merge_to_sequence Quickcheck" = (module struct open Quickcheck module Merge_to_sequence_args = struct type t = { order : [ `Increasing | `Decreasing ] option ; greater_or_equal_to : Elt.t option ; less_or_equal_to : Elt.t option ; x : (int, Int.comparator_witness) Set.t_ ; y : (int, Int.comparator_witness) Set.t_ } let quickcheck_generator = let open Generator.Monad_infix in let int_set_gen = Generator.small_non_negative_int >>= fun size -> List.gen_with_length size Int.quickcheck_generator >>| fun ints -> Set.of_list (List.map ints ~f:Elt.of_int) in Generator.tuple5 (Option.quickcheck_generator (Generator.of_list [ `Increasing; `Decreasing ])) (Option.quickcheck_generator (Int.quickcheck_generator >>| Elt.of_int)) (Option.quickcheck_generator (Int.quickcheck_generator >>| Elt.of_int)) int_set_gen int_set_gen >>| fun (order, greater_or_equal_to, less_or_equal_to, x, y) -> { order; greater_or_equal_to; less_or_equal_to; x; y } ;; end let%test_unit "merge_to_sequence = symmetric diff + inter" = Quickcheck.test Merge_to_sequence_args.quickcheck_generator ~f:(fun { order; greater_or_equal_to; less_or_equal_to; x; y } -> let open Set_intf.Merge_to_sequence_element in let value = function | Left x | Right x | Both (x, _) -> Elt.to_int x in let expect = List.concat [ List.map ~f:(fun x -> Both (x, x)) (Set.to_list (Set.inter x y)) ; List.map ~f:(fun x -> Left x) (Set.to_list (Set.diff x y)) ; List.map ~f:(fun x -> Right x) (Set.to_list (Set.diff y x)) ] in let expect = Option.fold greater_or_equal_to ~init:expect ~f:(fun elts min -> let min = Elt.to_int min in List.filter elts ~f:(fun x -> Int.( >= ) (value x) min)) in let expect = Option.fold less_or_equal_to ~init:expect ~f:(fun elts max -> let max = Elt.to_int max in List.filter elts ~f:(fun x -> Int.( <= ) (value x) max)) in let expect = match order with | None | Some `Increasing -> List.sort expect ~compare:(fun a b -> Int.compare (value a) (value b)) | Some `Decreasing -> List.sort expect ~compare:(fun a b -> Int.compare (value b) (value a)) in [%test_result: (Elt.t, Elt.t) Merge_to_sequence_element.t list] (Sequence.to_list (Set.merge_to_sequence ?order ?greater_or_equal_to ?less_or_equal_to x y)) ~expect) ;; end) ;; let of_sorted_array _ = assert false let of_sorted_array_unchecked _ = assert false let of_increasing_iterator_unchecked ~len:_ = assert false let _ = of_increasing_iterator_unchecked (* tested in of_sorted_array *) let%test _ = Set.of_sorted_array [||] |> Result.is_ok let%test _ = Set.of_sorted_array [| Elt.of_int 0 |] |> Result.is_ok let%test _ = Set.of_sorted_array [| Elt.of_int 0; Elt.of_int 0 |] |> Result.is_error let%test _ = Set.of_sorted_array [| Elt.of_int 1; Elt.of_int 0; Elt.of_int 1 |] |> Result.is_error ;; let%test _ = let list = List.init 100 ~f:Elt.of_int in let array = Array.of_list list in let hash_set = Elt.Hash_set.of_list list in let hashtbl = Elt.Table.of_alist_exn (List.map list ~f:(fun e -> e, e)) in let rev_array = Array.of_list (List.rev list) in let sequence = Sequence.of_list list in let set = Set.of_list list in Set.length set = List.length list && Set.equal set (Set.of_sorted_array_unchecked array) && Set.equal set (Set.of_sorted_array_unchecked rev_array) && Set.equal set (Set.of_hash_set hash_set) && Set.equal set (Set.of_hashtbl_keys hashtbl) && Set.equal set (Set.of_sequence sequence) ;; let invariants _ = assert false let%test_unit _ = for n = 0 to 100 do let list = List.init n ~f:Elt.of_int in assert (List.permute list |> Set.of_list |> Set.invariants); assert (Array.of_list list |> Set.of_sorted_array_unchecked |> Set.invariants); assert ( List.rev list |> Array.of_list |> Set.of_sorted_array_unchecked |> Set.invariants) done ;; let iter2 _ = assert false let%test_unit _ = let test l1 l2 expected = let result = ref [] in let set_of_list l = Set.of_list (List.map l ~f:Elt.of_int) in Set.iter2 (set_of_list l1) (set_of_list l2) ~f:(fun a -> result := a :: !result); let result = List.rev_map !result ~f:(function | `Left a -> `Left (Elt.to_int a) | `Right a -> `Right (Elt.to_int a) | `Both (a, b) -> `Both (Elt.to_int a, Elt.to_int b)) in assert ( [%equal: [ `Both of int * int | `Left of int | `Right of int ] list] result expected) in test [] [] []; test [ 0 ] [] [ `Left 0 ]; test [] [ 0 ] [ `Right 0 ]; test [ 0; 1; 3; 4 ] [ 3; 4; 5; 6 ] [ `Left 0; `Left 1; `Both (3, 3); `Both (4, 4); `Right 5; `Right 6 ] ;; (* Ensure polymorphic equality raises for sets. *) let%test_unit _ = match Set.kind with | `Tree -> () | `Set -> let ts = [ Set.empty (); Set.of_list [ Elt.of_int 13 ] ] in List.iter ts ~f:(fun t1 -> List.iter ts ~f:(fun t2 -> assert (Exn.does_raise (fun () -> Poly.equal t1 t2)))) ;; let to_map _ = assert false let%test_unit _ = assert (Map.is_empty (Set.to_map set_empty ~f:Elt.to_int)) let%test_unit _ = let s = set_nonempty in let m = Set.to_map s ~f:Elt.to_int in assert (Set.length s = Map.length m); Map.iteri m ~f:(fun ~key ~data -> assert (Elt.to_int key = data)); assert ([%equal: Elt.t list] (Set.to_list s) (Map.keys m)) ;; let of_map_keys _ = assert false let%test_unit _ = assert (Set.is_empty (Set.of_map_keys (Set.to_map set_empty ~f:Elt.to_int))) ;; let%test_unit _ = assert ( Set.equal (Set.of_map_keys (Set.to_map set_nonempty ~f:Elt.to_int)) set_nonempty) ;; let symmetric_diff _ = assert false let%test_unit "symmetric diff quick" = let symmetric_diff_set s1 s2 = Set.symmetric_diff s1 s2 |> Sequence.to_list |> List.map ~f:(function First elt | Second elt -> elt) |> Set.of_list in (* Textbook definition of symmetric difference: *) let symmetric_diff_spec s1 s2 = Set.diff (Set.union s1 s2) (Set.inter s1 s2) in Quickcheck.test ~seed:(`Deterministic "core set symmetric diff") (Quickcheck.Generator.tuple2 gen_set gen_set) ~sexp_of:[%sexp_of: Set.t_ * Set.t_] ~f:(fun (s1, s2) -> let expect = symmetric_diff_spec s1 s2 in let actual = symmetric_diff_set s1 s2 in assert (Set.equal actual expect)) ;; let%test _ = let m1 = set_nonempty in [%equal: (Elt.t, Elt.t) Either.t list] (Sequence.to_list (Set.symmetric_diff m1 m1)) [] ;; let%test _ = let elt = Elt.of_int 7 in let m1 = Set.empty () in let m1 = Set.add m1 (Elt.of_int 1) in let m2 = Set.add m1 elt in [%equal: (Elt.t, Elt.t) Either.t list] (Sequence.to_list (Set.symmetric_diff m1 m2)) [ Second elt ] ;; let%test _ = let m1 = set_nonempty in let m2 = List.fold (Set.to_list m1) ~init:(Set.empty ()) ~f:(fun m k -> Set.add m k) in [%equal: (Elt.t, Elt.t) Either.t list] (Sequence.to_list (Set.symmetric_diff m1 m2)) [] ;; let%test _ = let elt = Elt.of_int 20 in let m1 = set_nonempty in let m2 = Set.add m1 elt in [%equal: (Elt.t, Elt.t) Either.t list] (Sequence.to_list (Set.symmetric_diff m1 m2)) [ Second elt ] ;; let%test _ = let elt = Elt.of_int 5 in let m1 = set_nonempty in let m2 = Set.remove m1 elt in [%equal: (Elt.t, Elt.t) Either.t list] (Sequence.to_list (Set.symmetric_diff m1 m2)) [ First elt ] ;; let set_of_int_list l = Set.of_list (List.map ~f:Elt.of_int l) let%test _ = let map1 = Set.empty () in let map2 = set_of_int_list [ 1; 2; 3; 4; 5 ] in let diff = Set.symmetric_diff map1 map2 in Sequence.length diff = 5 ;; let%test _ = let map1 = set_of_int_list [ 1; 2; 3; 4; 5 ] in let map2 = Set.empty () in let diff = Set.symmetric_diff map1 map2 in Sequence.length diff = 5 ;; let%test _ = let map1 = set_of_int_list [ 1; 2 ] in let map2 = List.fold [ 3; 4; 5 ] ~init:map1 ~f:(fun acc elt -> Set.add acc (Elt.of_int elt)) in let diff = Set.symmetric_diff map1 map2 in Sequence.length diff = 3 ;; let%test _ = let map2 = set_of_int_list [ 1; 2 ] in let map1 = List.fold [ 3; 4; 5 ] ~init:map2 ~f:(fun acc elt -> Set.add acc (Elt.of_int elt)) in let diff = Set.symmetric_diff map1 map2 in Sequence.length diff = 3 ;; let split _ = assert false module Simple_int_set = struct type t = int list [@@deriving compare, sexp] let init i = List.init i ~f:Fn.id let split t i = let l = List.filter t ~f:(Int.( > ) i) in let r = List.filter t ~f:(Int.( < ) i) in let x = if List.mem t i ~equal:Int.( = ) then Some (Elt.of_int i) else None in l, x, r ;; let to_set = set_of_int_list end let%test_unit _ = let n = 16 in let t = set_of_int_list (List.init n ~f:Fn.id) in let t' = Simple_int_set.init n in let check i = let l, x, r = Set.split t (Elt.of_int i) in let l', x', r' = Simple_int_set.split t' i in assert (Set.equal l (Simple_int_set.to_set l')); [%test_eq: Elt.t option] x x'; assert (Set.equal r (Simple_int_set.to_set r')) in for i = 0 to n - 1 do check i done ;; let quickcheck_generator _ = assert false let%test_module _ = (module struct open Quickcheck let sexp_of = [%sexp_of: Set.t] let compare = [%compare: Set.t] let quickcheck_generator = Set.quickcheck_generator Elt.quickcheck_generator let can_generate f = test_can_generate quickcheck_generator ~sexp_of ~f let%test_unit _ = test_distinct_values quickcheck_generator ~sexp_of ~compare ~trials:1_000 ~distinct_values:500 ;; let%test_unit _ = can_generate (fun t -> Set.is_empty t) let%test_unit _ = can_generate (fun t -> Set.length t = 1) let%test_unit _ = can_generate (fun t -> Set.length t = 2) let%test_unit _ = can_generate (fun t -> Set.length t >= 3) let%test_unit _ = can_generate (fun t -> Set.exists t ~f:(fun elt -> Elt.to_int elt >= 0)) ;; let%test_unit _ = can_generate (fun t -> Set.exists t ~f:(fun elt -> Elt.to_int elt < 0)) ;; end) ;; let quickcheck_observer _ = assert false let%test_module _ = (module struct open Quickcheck module Set' = struct include Set let hash_fold_t hash t = [%hash_fold: Elt.t list] hash (to_list t) let hash t = hash_fold_t (Hash.alloc ()) t |> Hash.get_hash_value end module F = Fn_for_testing.Make (Set') (Int) (struct let examples = [] :: Elt.samples :: List.map Elt.samples ~f:(fun x -> [ x ]) |> List.map ~f:Set.of_list ;; end) let sexp_of = [%sexp_of: F.t] let compare = [%compare: F.t] let quickcheck_generator = (* memoizing these functions makes [test_no_duplicates] run much faster *) let hashable = Hashtbl_intf.Hashable.of_key (module Set') in Generator.( fn (Set.quickcheck_observer Elt.quickcheck_observer) Int.quickcheck_generator |> map ~f:(fun f -> Memo.general f ~hashable)) ;; let can_generate f = test_can_generate quickcheck_generator ~sexp_of ~f let%test_unit (_ [@tags "no-js"]) = test_distinct_values quickcheck_generator ~sexp_of ~compare ~trials:1_000 ~distinct_values:500 ;; let%test_unit _ = can_generate (fun f -> f (Set.singleton (Elt.of_int 0)) <> f (Set.empty ())) ;; let%test_unit _ = can_generate (fun f -> f (Set.singleton (Elt.of_int 0)) <> f (Set.singleton (Elt.of_int 1))) ;; let%test_unit _ = can_generate (fun f -> f (Set.singleton (Elt.of_int 0)) <> f (Set.of_list [ Elt.of_int 0; Elt.of_int 1 ])) ;; end) ;; let quickcheck_shrinker _ = assert false let%test_module _ = (module struct open Quickcheck let elt_test_shrinker = Shrinker.create (fun t -> let n = Elt.to_int t in if n <= 0 then Sequence.empty else Sequence.singleton (Elt.of_int (n - 1))) ;; let quickcheck_shrinker = Set.quickcheck_shrinker elt_test_shrinker let normalize_list list = List.sort list ~compare:[%compare: int] let normalize_lists lists = List.map lists ~f:normalize_list |> List.sort ~compare:[%compare: int list] ;; let set_of_list list = List.map list ~f:Elt.of_int |> Set.of_list let list_of_set set = Set.to_list set |> List.map ~f:Elt.to_int let test list shrunk_lists = [%test_result: int list list] (set_of_list list |> Shrinker.shrink quickcheck_shrinker |> Sequence.to_list |> List.map ~f:list_of_set |> normalize_lists) ~expect:(normalize_lists shrunk_lists) ;; let%test_unit _ = test [] [] let%test_unit _ = test [ 0 ] [ [] ] let%test_unit _ = test [ 1 ] [ []; [ 0 ] ] let%test_unit _ = test [ 0; 1 ] [ [ 0 ]; [ 1 ] ] end) ;; let to_tree _ = assert false let remove_index _ = assert false let nth _ = assert false let find_exn _ = assert false let group_by _ = assert false let choose_exn _ = assert false let choose _ = assert false let max_elt_exn _ = assert false let max_elt _ = assert false let min_elt_exn _ = assert false let min_elt _ = assert false let elements _ = assert false let partition_tf _ = assert false let filter _ = assert false let fold_right _ = assert false let fold_until _ = assert false let equal _ = assert false let compare_direct _ = assert false let diff _ = assert false let union _ = assert false let remove _ = assert false let find_map _ = assert false let find _ = assert false let count _ = assert false let sum _ = assert false let for_all _ = assert false let exists _ = assert false let fold _ = assert false let iter _ = assert false let length _ = assert false let of_tree _ = assert false let filter_map _ = assert false let map _ = assert false let stable_dedup_list _ = assert false let of_array _ = assert false let union_list _ = assert false let singleton _ = assert false let fold_result _ = assert false let empty = Unit_test_follows end module Elt_int = struct type 'a t = int [@@deriving sexp, hash] let of_int = Fn.id let to_int = Fn.id end module Elt_poly = struct type 'a t = 'a [@@deriving sexp, hash] let of_int = Fn.id let to_int = Fn.id end module Create_options_with_comparator = struct type ('a, 'b, 'c) create_options = ('a, 'b, 'c) With_comparator.t let simplify_creator f = f ~comparator:Int.comparator end module Create_options_with_first_class_module = struct type ('a, 'b, 'c) create_options = ('a, 'b, 'c) With_first_class_module.t let simplify_creator f = f (module Int : Comparator.S with type t = _ and type comparator_witness = _) ;; end module Create_options_without_comparator = struct type ('a, 'b, 'c) create_options = ('a, 'b, 'c) Without_comparator.t let simplify_creator = Fn.id end module Access_options_without_comparator = struct type ('a, 'b, 'c) access_options = ('a, 'b, 'c) Without_comparator.t let simplify_accessor = Fn.id end module Access_options_with_comparator = struct type ('a, 'b, 'c) access_options = ('a, 'b, 'c) With_comparator.t let simplify_accessor f = f ~comparator:Int.comparator end let create_named set ~name = { Set.Named.set; name } let create_named_tree tree ~name = { Set.Tree.Named.tree; name } let%test_module "Set" = (module Unit_tests (Elt_poly) (struct include Set type ('a, 'b) t_ = ('a, 'b) t type ('a, 'b) set = ('a, 'b) t type ('a, 'b) tree = ('a, 'b) Tree.t type 'a cmp = 'a type ('a, 'b) named = ('a, 'b) Set.Named.t include Create_options_with_first_class_module include Access_options_without_comparator let create_named = create_named let kind = `Set let is_poly = false end)) ;; let%test_module "Set.Poly" = (module Unit_tests (Elt_poly) (struct include Set.Poly type ('a, 'b) set = ('a, 'b) Set.t type ('a, 'b) t_ = 'a t type ('a, 'b) tree = 'a Tree.t type 'a cmp = Comparator.Poly.comparator_witness type ('a, 'b) named = 'a Set.Poly.named include Create_options_without_comparator include Access_options_without_comparator let create_named = create_named let kind = `Set let is_poly = true end)) ;; let%test_module "Int.Set" = (module Unit_tests (Elt_int) (struct include Int.Set module Tree = Set.Make_tree (Int.Set.Elt) type ('a, 'b) set = ('a, 'b) Set.t type ('a, 'b) t_ = t type ('a, 'b) tree = Tree.t type 'a cmp = Int.comparator_witness type ('a, 'b) named = Int.Set.named include Create_options_without_comparator include Access_options_without_comparator let create_named = create_named let kind = `Set let is_poly = false end)) ;; let%test_module "Set.Tree" = (module Unit_tests (Elt_poly) (struct include Set.Tree type ('a, 'b) set = ('a, 'b) Set.Tree.t type ('a, 'b) t_ = ('a, 'b) t type ('a, 'b) tree = ('a, 'b) t type ('a, 'b) named = ('a, 'b) Set.Tree.Named.t type 'a cmp = 'a include Create_options_with_comparator include Access_options_with_comparator let create_named = create_named_tree let kind = `Tree let is_poly = false end)) ;; let%test_module "Set.Poly.Tree" = (module Unit_tests (Elt_poly) (struct include Set.Poly.Tree type ('a, 'b) set = 'a Set.Poly.Tree.t type ('a, 'b) t_ = 'a t type ('a, 'b) tree = 'a t type ('a, 'b) named = 'a Set.Poly.Tree.named type 'a cmp = Comparator.Poly.comparator_witness include Create_options_without_comparator include Access_options_without_comparator let create_named = create_named_tree let kind = `Tree let is_poly = true end)) ;; let%test_module "Int.Set.Tree" = (module Unit_tests (Elt_int) (struct include Set.Make_tree (Int.Set.Elt) type ('a, 'b) set = ('a, 'b) Set.Tree.t type ('a, 'b) t_ = t type ('a, 'b) tree = t type nonrec ('a, 'b) named = named type 'a cmp = Int.comparator_witness include Create_options_without_comparator include Access_options_without_comparator let create_named = create_named_tree let kind = `Tree let is_poly = false end)) ;; let%expect_test _ = let open Expect_test_helpers_core in print_and_check_stable_type [%here] (module struct type t = Set.M(Int).t [@@deriving bin_io, compare, sexp] end) (List.map ~f:(Set.of_list (module Int)) [ []; [ 1 ]; [ 1; 2 ]; [ 1; 2; 3 ] ]); [%expect {| (bin_shape_digest 3564446b0bfa871d8c3ebf31ab342fe7) ((sexp ()) (bin_io "\000")) ((sexp (1)) (bin_io "\001\001")) ((sexp (1 2)) (bin_io "\002\001\002")) ((sexp (1 2 3)) (bin_io "\003\001\002\003")) |}] ;; core-0.15.0/core/test/src/core_set_unit_tests.mli000066400000000000000000000000561420273305200220110ustar00rootroot00000000000000(* Unit test interface intentionally blank *) core-0.15.0/core/test/src/core_string_unit_tests.ml000066400000000000000000000054041420273305200223550ustar00rootroot00000000000000open! Core let%test_unit "String.exists doesn't allocate" = let initial_words = Gc.minor_words () in assert (String.exists "FOOBAR" ~f:Char.is_uppercase); assert (not (String.exists "FOOBAR" ~f:Char.is_lowercase)); let allocated = Gc.minor_words () - initial_words in [%test_result: int] allocated ~expect:0 ;; let%test_unit "String.for_all doesn't allocate" = let initial_words = Gc.minor_words () in assert (String.for_all "FOOBAR" ~f:Char.is_uppercase); assert (not (String.for_all "FOOBAR" ~f:Char.is_lowercase)); let allocated = Gc.minor_words () - initial_words in [%test_result: int] allocated ~expect:0 ;; let%test_unit "String.is_suffix doesn't allocate" = let initial_words = Gc.minor_words () in assert (String.is_suffix "FOOBAR" ~suffix:"BAR"); assert (not (String.is_suffix "FOOBAR" ~suffix:"BUZ")); let allocated = Gc.minor_words () - initial_words in [%test_result: int] allocated ~expect:0 ;; let%test_unit "String.is_prefix doesn't allocate" = let initial_words = Gc.minor_words () in assert (String.is_prefix "FOOBAR" ~prefix:"FOO"); assert (not (String.is_prefix "FOOBAR" ~prefix:"FUZ")); let allocated = Gc.minor_words () - initial_words in [%test_result: int] allocated ~expect:0 ;; let%test_unit "String.Caseless.compare is consistent with String.compare of lowercase" = let quickcheck_generator = Quickcheck.Generator.tuple2 String.quickcheck_generator String.quickcheck_generator in let sexp_of = [%sexp_of: string * string] in (* make sure we can generate strings that are identical *) Quickcheck.test_can_generate quickcheck_generator ~sexp_of ~f:(fun (x, y) -> String.equal x y); (* make sure we can generate strings that are the only the same after case folding *) Quickcheck.test_can_generate quickcheck_generator ~sexp_of ~f:(fun (x, y) -> String.equal (String.lowercase x) (String.lowercase y) && not (String.equal x y)); (* make sure we can generate a prefix of the other string, after case folding *) Quickcheck.test_can_generate quickcheck_generator ~sexp_of ~f:(fun (x, y) -> String.is_prefix (String.lowercase x) ~prefix:(String.lowercase y) && (not (String.equal (String.lowercase x) (String.lowercase y))) && not (String.is_prefix x ~prefix:y)); (* ... and in the other direction *) Quickcheck.test_can_generate quickcheck_generator ~sexp_of ~f:(fun (x, y) -> String.is_prefix (String.lowercase y) ~prefix:(String.lowercase x) && (not (String.equal (String.lowercase y) (String.lowercase x))) && not (String.is_prefix y ~prefix:x)); (* now make sure our comparisons work *) Quickcheck.test quickcheck_generator ~sexp_of ~f:(fun (x, y) -> [%test_result: int] (String.Caseless.compare x y) ~expect:(String.compare (String.lowercase x) (String.lowercase y))) ;; core-0.15.0/core/test/src/core_string_unit_tests.mli000066400000000000000000000000551420273305200225230ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/deprecation.mlt000066400000000000000000000003021420273305200202270ustar00rootroot00000000000000module M : sig val x : unit [@@deprecated "[since 2016-07]"] end = struct let x = () end let _ = M.x [%%expect {| Line _, characters _-_: Error (alert deprecated): M.x [since 2016-07] |}] core-0.15.0/core/test/src/digit_string_helpers_tests.ml000066400000000000000000000736111420273305200232150ustar00rootroot00000000000000open! Core open Core_private.Digit_string_helpers open Import let%test_unit "max_int63_with" = [%test_result: Int63.t] (max_int63_with ~digits:11 : Int63.t) ~expect:(Int63.of_string (String.init 11 ~f:(fun _ -> '9'))) ;; let%expect_test "divide_and_round_up" = let test numerator denominator = let numerator = Int63.of_int numerator in let denominator = Int63.of_int denominator in let quotient = Unsafe.divide_and_round_up ~numerator ~denominator in printf !"%{Int63#hum} / %{Int63#hum} = %{Int63#hum}\n" numerator denominator quotient in for numerator = -10 to 10 do test numerator 4 done; [%expect {| -10 / 4 = -2 -9 / 4 = -2 -8 / 4 = -2 -7 / 4 = -1 -6 / 4 = -1 -5 / 4 = -1 -4 / 4 = -1 -3 / 4 = 0 -2 / 4 = 0 -1 / 4 = 0 0 / 4 = 0 1 / 4 = 1 2 / 4 = 1 3 / 4 = 1 4 / 4 = 1 5 / 4 = 2 6 / 4 = 2 7 / 4 = 2 8 / 4 = 2 9 / 4 = 3 10 / 4 = 3 |}] ;; let int63_ten = Int63.of_int 10 let rec digits_of int63 = if Int63.( < ) int63 int63_ten then 1 else Int.succ (digits_of (Int63.( / ) int63 int63_ten)) ;; let max_int63_digits = (* subtract one because int63 cannot encode all values with as many digits as [max_value] *) digits_of Int63.max_value - 1 ;; let%expect_test "max_int63_digits" = print_s [%sexp (max_int63_digits : int)]; [%expect {| 18 |}] ;; let max_with ~digits = Int63.pred (Int63.pow int63_ten (Int63.of_int digits)) let test_write_int63 ~digits ?(verbose = true) ?(align = digits) write_int63 = let print_endline = if verbose then print_endline ?hide_positions:None else ignore in let require_does_raise here f = (* uses above print_endline, so if verbose is false, prints nothing on exn *) match f () with | _ -> require_does_raise here ignore | exception exn -> print_endline (Exn.to_string exn) in let max = max_with ~digits in print_endline "Expecting success:"; (* show resulting strings at boundary values *) let show int63 = let bytes = Bytes.make digits '!' in write_int63 bytes ~pos:0 int63; printf !"%*Ld -> %S\n" align (Int63.to_int64 int63) (Bytes.to_string bytes) in show Int63.zero; show max; (* test success behavior for lots of correct values *) let expect_success_exn int63 = let bytes = Bytes.make (1 + digits + 1) '!' in write_int63 bytes ~pos:1 int63; [%test_result: string] (Bytes.to_string bytes) ~expect:(sprintf "!%0*Ld!" digits (Int63.to_int64 int63)) in require_does_not_raise [%here] (fun () -> Quickcheck.test (Int63.gen_log_uniform_incl Int63.zero max) ~examples:[ Int63.zero; max ] ~sexp_of:Int63.sexp_of_t ~f:expect_success_exn); (* test failure cases *) print_endline ""; print_endline "Expecting failure:"; require_does_raise [%here] (fun () -> write_int63 (Bytes.make 0 '?') ~pos:0 Int63.zero); require_does_raise [%here] (fun () -> write_int63 (Bytes.make digits '?') ~pos:(-1) Int63.zero); require_does_raise [%here] (fun () -> write_int63 (Bytes.make digits '?') ~pos:1 Int63.zero); require_does_raise [%here] (fun () -> write_int63 (Bytes.make digits '?') ~pos:0 Int63.minus_one); require_does_raise [%here] (fun () -> write_int63 (Bytes.make digits '?') ~pos:0 (Int63.succ max)) ;; let test_write_int write_int ~digits = let write bytes ~pos int63 = write_int bytes ~pos (Int63.to_int_exn int63) in test_write_int63 write ~digits ;; let%expect_test "write_1_digit_int" = test_write_int write_1_digit_int ~digits:1; [%expect {| Expecting success: 0 -> "0" 9 -> "9" Expecting failure: (Invalid_argument "Digit_string_helpers.write_1_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.write_1_digit_int: pos=-1 out of range for string of length 1") (Invalid_argument "Digit_string_helpers.write_1_digit_int: pos=1 out of range for string of length 1") (Invalid_argument "Digit_string_helpers.write_1_digit_int: -1 out of range [0, 9]") (Invalid_argument "Digit_string_helpers.write_1_digit_int: 10 out of range [0, 9]") |}] ;; let%expect_test "write_2_digit_int" = test_write_int write_2_digit_int ~digits:2; [%expect {| Expecting success: 0 -> "00" 99 -> "99" Expecting failure: (Invalid_argument "Digit_string_helpers.write_2_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.write_2_digit_int: pos=-1 out of range for string of length 2") (Invalid_argument "Digit_string_helpers.write_2_digit_int: 2 digits do not fit at pos 1 in string of length 2") (Invalid_argument "Digit_string_helpers.write_2_digit_int: -1 out of range [0, 99]") (Invalid_argument "Digit_string_helpers.write_2_digit_int: 100 out of range [0, 99]") |}] ;; let%expect_test "write_3_digit_int" = test_write_int write_3_digit_int ~digits:3; [%expect {| Expecting success: 0 -> "000" 999 -> "999" Expecting failure: (Invalid_argument "Digit_string_helpers.write_3_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.write_3_digit_int: pos=-1 out of range for string of length 3") (Invalid_argument "Digit_string_helpers.write_3_digit_int: 3 digits do not fit at pos 1 in string of length 3") (Invalid_argument "Digit_string_helpers.write_3_digit_int: -1 out of range [0, 999]") (Invalid_argument "Digit_string_helpers.write_3_digit_int: 1000 out of range [0, 999]") |}] ;; let%expect_test "write_4_digit_int" = test_write_int write_4_digit_int ~digits:4; [%expect {| Expecting success: 0 -> "0000" 9999 -> "9999" Expecting failure: (Invalid_argument "Digit_string_helpers.write_4_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.write_4_digit_int: pos=-1 out of range for string of length 4") (Invalid_argument "Digit_string_helpers.write_4_digit_int: 4 digits do not fit at pos 1 in string of length 4") (Invalid_argument "Digit_string_helpers.write_4_digit_int: -1 out of range [0, 9999]") (Invalid_argument "Digit_string_helpers.write_4_digit_int: 10000 out of range [0, 9999]") |}] ;; let%expect_test "write_5_digit_int" = test_write_int write_5_digit_int ~digits:5; [%expect {| Expecting success: 0 -> "00000" 99999 -> "99999" Expecting failure: (Invalid_argument "Digit_string_helpers.write_5_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.write_5_digit_int: pos=-1 out of range for string of length 5") (Invalid_argument "Digit_string_helpers.write_5_digit_int: 5 digits do not fit at pos 1 in string of length 5") (Invalid_argument "Digit_string_helpers.write_5_digit_int: -1 out of range [0, 99999]") (Invalid_argument "Digit_string_helpers.write_5_digit_int: 100000 out of range [0, 99999]") |}] ;; let%expect_test "write_6_digit_int" = test_write_int write_6_digit_int ~digits:6; [%expect {| Expecting success: 0 -> "000000" 999999 -> "999999" Expecting failure: (Invalid_argument "Digit_string_helpers.write_6_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.write_6_digit_int: pos=-1 out of range for string of length 6") (Invalid_argument "Digit_string_helpers.write_6_digit_int: 6 digits do not fit at pos 1 in string of length 6") (Invalid_argument "Digit_string_helpers.write_6_digit_int: -1 out of range [0, 999999]") (Invalid_argument "Digit_string_helpers.write_6_digit_int: 1000000 out of range [0, 999999]") |}] ;; let%expect_test "write_7_digit_int" = test_write_int write_7_digit_int ~digits:7; [%expect {| Expecting success: 0 -> "0000000" 9999999 -> "9999999" Expecting failure: (Invalid_argument "Digit_string_helpers.write_7_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.write_7_digit_int: pos=-1 out of range for string of length 7") (Invalid_argument "Digit_string_helpers.write_7_digit_int: 7 digits do not fit at pos 1 in string of length 7") (Invalid_argument "Digit_string_helpers.write_7_digit_int: -1 out of range [0, 9999999]") (Invalid_argument "Digit_string_helpers.write_7_digit_int: 10000000 out of range [0, 9999999]") |}] ;; let%expect_test "write_8_digit_int" = test_write_int write_8_digit_int ~digits:8; [%expect {| Expecting success: 0 -> "00000000" 99999999 -> "99999999" Expecting failure: (Invalid_argument "Digit_string_helpers.write_8_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.write_8_digit_int: pos=-1 out of range for string of length 8") (Invalid_argument "Digit_string_helpers.write_8_digit_int: 8 digits do not fit at pos 1 in string of length 8") (Invalid_argument "Digit_string_helpers.write_8_digit_int: -1 out of range [0, 99999999]") (Invalid_argument "Digit_string_helpers.write_8_digit_int: 100000000 out of range [0, 99999999]") |}] ;; let%expect_test "write_9_digit_int" = test_write_int write_9_digit_int ~digits:9; [%expect {| Expecting success: 0 -> "000000000" 999999999 -> "999999999" Expecting failure: (Invalid_argument "Digit_string_helpers.write_9_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.write_9_digit_int: pos=-1 out of range for string of length 9") (Invalid_argument "Digit_string_helpers.write_9_digit_int: 9 digits do not fit at pos 1 in string of length 9") (Invalid_argument "Digit_string_helpers.write_9_digit_int: -1 out of range [0, 999999999]") (Invalid_argument "Digit_string_helpers.write_9_digit_int: 1000000000 out of range [0, 999999999]") |}] ;; let%expect_test "write_int63" = for digits = 1 to max_int63_digits do require_does_not_raise [%here] (fun () -> test_write_int63 ~verbose:(digits = max_int63_digits) ~align:max_int63_digits ~digits (write_int63 ~digits)) done; [%expect {| 0 -> "0" 9 -> "9" 0 -> "00" 99 -> "99" 0 -> "000" 999 -> "999" 0 -> "0000" 9999 -> "9999" 0 -> "00000" 99999 -> "99999" 0 -> "000000" 999999 -> "999999" 0 -> "0000000" 9999999 -> "9999999" 0 -> "00000000" 99999999 -> "99999999" 0 -> "000000000" 999999999 -> "999999999" 0 -> "0000000000" 9999999999 -> "9999999999" 0 -> "00000000000" 99999999999 -> "99999999999" 0 -> "000000000000" 999999999999 -> "999999999999" 0 -> "0000000000000" 9999999999999 -> "9999999999999" 0 -> "00000000000000" 99999999999999 -> "99999999999999" 0 -> "000000000000000" 999999999999999 -> "999999999999999" 0 -> "0000000000000000" 9999999999999999 -> "9999999999999999" 0 -> "00000000000000000" 99999999999999999 -> "99999999999999999" Expecting success: 0 -> "000000000000000000" 999999999999999999 -> "999999999999999999" Expecting failure: (Invalid_argument "Digit_string_helpers.write_int63: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.write_int63: pos=-1 out of range for string of length 18") (Invalid_argument "Digit_string_helpers.write_int63: 18 digits do not fit at pos 1 in string of length 18") (Invalid_argument "Digit_string_helpers.write_int63: -1 out of range [0, 999999999999999999]") (Invalid_argument "Digit_string_helpers.write_int63: 1000000000000000000 out of range [0, 999999999999999999]") |}]; (* write more digits than Int63.max_value fills *) let bytes = Bytes.make 50 '_' in write_int63 bytes ~pos:10 ~digits:30 Int63.max_value; print_s [%sexp (bytes : Bytes.t)]; [%expect {| __________000000000004611686018427387903__________ |}] ;; let test_read_int63 ?(verbose = true) read_int63 ~digits = let print_endline = if verbose then print_endline ?hide_positions:None else ignore in let require_does_raise here f = match f () with | _ -> require_does_raise here ignore | exception exn -> print_endline (Exn.to_string exn) in let max = max_with ~digits in print_endline "Expecting success:"; (* show resulting strings at boundary values *) let show int63 = let string = sprintf "%0*Ld" digits (Int63.to_int64 int63) in let parsed = read_int63 string ~pos:0 in printf !"%*S -> %{Int63}\n" (max_int63_digits + 2) string parsed in show Int63.zero; show max; (* test success behavior for lots of correct values *) let expect_success_exn int63 = let string = sprintf "!%0*Ld!" digits (Int63.to_int64 int63) in let parsed = read_int63 string ~pos:1 in [%test_result: Int63.t] parsed ~expect:int63 in require_does_not_raise [%here] (fun () -> Quickcheck.test (Int63.gen_log_uniform_incl Int63.zero max) ~examples:[ Int63.zero; max ] ~sexp_of:Int63.sexp_of_t ~f:expect_success_exn); (* test failure cases *) print_endline ""; print_endline "Expecting failure:"; require_does_raise [%here] (fun () -> read_int63 "" ~pos:0); require_does_raise [%here] (fun () -> read_int63 (sprintf "%0*Ld" digits 0L) ~pos:(-1)); require_does_raise [%here] (fun () -> read_int63 (sprintf "%0*Ld" digits 0L) ~pos:1); require_does_raise [%here] (fun () -> read_int63 (String.make digits '!') ~pos:0) ;; let test_read_int read_int ~digits = let read string ~pos = Int63.of_int (read_int string ~pos) in test_read_int63 read ~digits ;; let%expect_test "read_1_digit_int" = test_read_int read_1_digit_int ~digits:1; [%expect {| Expecting success: "0" -> 0 "9" -> 9 Expecting failure: (Invalid_argument "Digit_string_helpers.read_1_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.read_1_digit_int: pos=-1 out of range for string of length 1") (Invalid_argument "Digit_string_helpers.read_1_digit_int: pos=1 out of range for string of length 1") (Failure "Char.get_digit_exn '!': not a digit") |}] ;; let%expect_test "read_2_digit_int" = test_read_int read_2_digit_int ~digits:2; [%expect {| Expecting success: "00" -> 0 "99" -> 99 Expecting failure: (Invalid_argument "Digit_string_helpers.read_2_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.read_2_digit_int: pos=-1 out of range for string of length 2") (Invalid_argument "Digit_string_helpers.read_2_digit_int: 2 digits do not fit at pos 1 in string of length 2") (Failure "Char.get_digit_exn '!': not a digit") |}] ;; let%expect_test "read_3_digit_int" = test_read_int read_3_digit_int ~digits:3; [%expect {| Expecting success: "000" -> 0 "999" -> 999 Expecting failure: (Invalid_argument "Digit_string_helpers.read_3_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.read_3_digit_int: pos=-1 out of range for string of length 3") (Invalid_argument "Digit_string_helpers.read_3_digit_int: 3 digits do not fit at pos 1 in string of length 3") (Failure "Char.get_digit_exn '!': not a digit") |}] ;; let%expect_test "read_4_digit_int" = test_read_int read_4_digit_int ~digits:4; [%expect {| Expecting success: "0000" -> 0 "9999" -> 9999 Expecting failure: (Invalid_argument "Digit_string_helpers.read_4_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.read_4_digit_int: pos=-1 out of range for string of length 4") (Invalid_argument "Digit_string_helpers.read_4_digit_int: 4 digits do not fit at pos 1 in string of length 4") (Failure "Char.get_digit_exn '!': not a digit") |}] ;; let%expect_test "read_5_digit_int" = test_read_int read_5_digit_int ~digits:5; [%expect {| Expecting success: "00000" -> 0 "99999" -> 99999 Expecting failure: (Invalid_argument "Digit_string_helpers.read_5_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.read_5_digit_int: pos=-1 out of range for string of length 5") (Invalid_argument "Digit_string_helpers.read_5_digit_int: 5 digits do not fit at pos 1 in string of length 5") (Failure "Char.get_digit_exn '!': not a digit") |}] ;; let%expect_test "read_6_digit_int" = test_read_int read_6_digit_int ~digits:6; [%expect {| Expecting success: "000000" -> 0 "999999" -> 999999 Expecting failure: (Invalid_argument "Digit_string_helpers.read_6_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.read_6_digit_int: pos=-1 out of range for string of length 6") (Invalid_argument "Digit_string_helpers.read_6_digit_int: 6 digits do not fit at pos 1 in string of length 6") (Failure "Char.get_digit_exn '!': not a digit") |}] ;; let%expect_test "read_7_digit_int" = test_read_int read_7_digit_int ~digits:7; [%expect {| Expecting success: "0000000" -> 0 "9999999" -> 9999999 Expecting failure: (Invalid_argument "Digit_string_helpers.read_7_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.read_7_digit_int: pos=-1 out of range for string of length 7") (Invalid_argument "Digit_string_helpers.read_7_digit_int: 7 digits do not fit at pos 1 in string of length 7") (Failure "Char.get_digit_exn '!': not a digit") |}] ;; let%expect_test "read_8_digit_int" = test_read_int read_8_digit_int ~digits:8; [%expect {| Expecting success: "00000000" -> 0 "99999999" -> 99999999 Expecting failure: (Invalid_argument "Digit_string_helpers.read_8_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.read_8_digit_int: pos=-1 out of range for string of length 8") (Invalid_argument "Digit_string_helpers.read_8_digit_int: 8 digits do not fit at pos 1 in string of length 8") (Failure "Char.get_digit_exn '!': not a digit") |}] ;; let%expect_test "read_9_digit_int" = test_read_int read_9_digit_int ~digits:9; [%expect {| Expecting success: "000000000" -> 0 "999999999" -> 999999999 Expecting failure: (Invalid_argument "Digit_string_helpers.read_9_digit_int: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.read_9_digit_int: pos=-1 out of range for string of length 9") (Invalid_argument "Digit_string_helpers.read_9_digit_int: 9 digits do not fit at pos 1 in string of length 9") (Failure "Char.get_digit_exn '!': not a digit") |}] ;; let%expect_test "read_int63" = for digits = 1 to max_int63_digits do require_does_not_raise [%here] (fun () -> test_read_int63 ~verbose:(digits = max_int63_digits) ~digits (read_int63 ~digits)) done; [%expect {| "0" -> 0 "9" -> 9 "00" -> 0 "99" -> 99 "000" -> 0 "999" -> 999 "0000" -> 0 "9999" -> 9999 "00000" -> 0 "99999" -> 99999 "000000" -> 0 "999999" -> 999999 "0000000" -> 0 "9999999" -> 9999999 "00000000" -> 0 "99999999" -> 99999999 "000000000" -> 0 "999999999" -> 999999999 "0000000000" -> 0 "9999999999" -> 9999999999 "00000000000" -> 0 "99999999999" -> 99999999999 "000000000000" -> 0 "999999999999" -> 999999999999 "0000000000000" -> 0 "9999999999999" -> 9999999999999 "00000000000000" -> 0 "99999999999999" -> 99999999999999 "000000000000000" -> 0 "999999999999999" -> 999999999999999 "0000000000000000" -> 0 "9999999999999999" -> 9999999999999999 "00000000000000000" -> 0 "99999999999999999" -> 99999999999999999 Expecting success: "000000000000000000" -> 0 "999999999999999999" -> 999999999999999999 Expecting failure: (Invalid_argument "Digit_string_helpers.read_int63: pos=0 out of range for string of length 0") (Invalid_argument "Digit_string_helpers.read_int63: pos=-1 out of range for string of length 18") (Invalid_argument "Digit_string_helpers.read_int63: 18 digits do not fit at pos 1 in string of length 18") (Failure "Char.get_digit_exn '!': not a digit") |}]; (* read more digits than Int63 can represent *) let string = String.make 50 '0' in let int63 = read_int63 string ~pos:10 ~digits:30 in print_s [%sexp (int63 : Int63.t)]; require_equal [%here] (module Int63) int63 Int63.zero; [%expect {| 0 |}]; (* read Int63.max_value without overflowing *) let string = sprintf "%010d%030Ld%010d" 0 (Int63.to_int64 Int63.max_value) 0 in let int63 = read_int63 string ~pos:10 ~digits:30 in print_s [%sexp (int63 : Int63.t)]; require_equal [%here] (module Int63) int63 Int63.max_value; [%expect {| 4_611_686_018_427_387_903 |}]; (* raise on overflow *) let string = String.make 50 '9' in require_does_raise [%here] (fun () -> read_int63 string ~pos:10 ~digits:30); [%expect {| (Invalid_argument "Digit_string_helpers.read_int63: overflow reading int63") |}] ;; let require_no_allocation_if_64_bit_and_if_does_not_raise here f = match Base.Word_size.word_size with | W32 -> f () | W64 -> (match f () with | exception _ -> f () | _ -> require_no_allocation here f) ;; let%expect_test "read_int63_decimal" = let read string ~pos ~decimals ~scale ~round_ties ~allow_underscore = require_no_allocation_if_64_bit_and_if_does_not_raise [%here] (fun () -> read_int63_decimal string ~pos ~decimals ~scale ~round_ties ~allow_underscore) in let test_read_at string ~pos ~decimals ~scale ~round_ties = let permissive = read string ~pos ~decimals ~scale ~round_ties ~allow_underscore:true in let restricted = Or_error.try_with (fun () -> read string ~pos ~decimals ~scale ~round_ties ~allow_underscore:false) in let has_underscore = String.mem (String.sub string ~pos ~len:decimals) '_' in (match restricted with | Ok restricted -> if has_underscore then print_cr [%here] [%message "ignored '_'" ~_:(restricted : Int63.t)] else require_equal [%here] (module Int63) permissive restricted | Error error -> if has_underscore then () else print_cr [%here] [%message "failed" ~_:(error : Error.t)]); permissive in let test_read string ~decimals ~scale ~round_ties = let pos_0 = test_read_at string ~pos:0 ~decimals ~scale ~round_ties in let pos_1 = test_read_at ("!" ^ string ^ "!") ~pos:1 ~decimals ~scale ~round_ties in require_equal [%here] (module Int63) pos_0 pos_1; pos_0 in let test63 string ~scale = let decimals = String.length string in let round_pos_inf = test_read string ~decimals ~scale ~round_ties:Toward_positive_infinity in let round_neg_inf = test_read string ~decimals ~scale ~round_ties:Toward_negative_infinity in if Int63.equal round_pos_inf round_neg_inf then print_s [%sexp (round_pos_inf : Int63.t)] else print_s [%message (round_pos_inf : Int63.t) (round_neg_inf : Int63.t)] in let test string ~scale = let scale = Int63.of_int scale in test63 string ~scale in test ~scale:1 ""; test ~scale:1 "_"; test ~scale:1 "0"; [%expect {| 0 0 0 |}]; test ~scale:1 "5"; test ~scale:1 "500000"; [%expect {| ((round_pos_inf 1) (round_neg_inf 0)) ((round_pos_inf 1) (round_neg_inf 0)) |}]; test ~scale:1 "500001"; [%expect {| 1 |}]; test ~scale:1 "499999"; [%expect {| 0 |}]; test ~scale:7 "07142857142857142857142857142857142857142857142857"; test ~scale:7 "071428571428571428571428571428571428571428571428572"; [%expect {| 0 1 |}]; test ~scale:60_000 "0"; [%expect {| 0 |}]; test ~scale:60_000 "5"; [%expect {| 30_000 |}]; test ~scale:60_000 "333_333_333_333"; test ~scale:60_000 "333333333333"; [%expect {| 20_000 20_000 |}]; test ~scale:60_000 "333_341_666"; test ~scale:60_000 "333_341_667"; [%expect {| 20_000 20_001 |}]; test ~scale:60_000 "666_674_999"; test ~scale:60_000 "666_675_000"; test ~scale:60_000 "666_675"; test ~scale:60_000 "666_675_001"; [%expect {| 40_000 ((round_pos_inf 40_001) (round_neg_inf 40_000)) ((round_pos_inf 40_001) (round_neg_inf 40_000)) 40_001 |}]; test ~scale:60_000 "111_111_111_111"; test ~scale:60_000 "111_111_111"; test ~scale:60_000 "111_111"; test ~scale:60_000 "111"; [%expect {| 6_667 6_667 6_667 6_660 |}]; test ~scale:1_000 "5"; test ~scale:1_000 "05"; test ~scale:1_000 "005"; test ~scale:1_000 "000_5"; test ~scale:1_000 "000_05"; [%expect {| 500 50 5 ((round_pos_inf 1) (round_neg_inf 0)) 0 |}]; test ~scale:1_000 "5"; test ~scale:1_000 "95"; test ~scale:1_000 "995"; test ~scale:1_000 "999_5"; test ~scale:1_000 "999_95"; [%expect {| 500 950 995 ((round_pos_inf 1_000) (round_neg_inf 999)) 1_000 |}]; (* Tests values close to overflow: 100000000000000000 ~= Int63.max_value / 46 *) let big_power_of_ten = Int63.of_string "100000000000000000" in print_s [%sexp (Int63.( / ) Int63.max_value big_power_of_ten : Int63.t)]; [%expect {| 46 |}]; test63 ~scale:big_power_of_ten "1"; test63 ~scale:big_power_of_ten "2"; test63 ~scale:big_power_of_ten "3"; test63 ~scale:big_power_of_ten "4"; test63 ~scale:big_power_of_ten "5"; test63 ~scale:big_power_of_ten "6"; test63 ~scale:big_power_of_ten "7"; test63 ~scale:big_power_of_ten "8"; test63 ~scale:big_power_of_ten "9"; test63 ~scale:big_power_of_ten "987654321011122235"; [%expect {| 10_000_000_000_000_000 20_000_000_000_000_000 30_000_000_000_000_000 40_000_000_000_000_000 50_000_000_000_000_000 60_000_000_000_000_000 70_000_000_000_000_000 80_000_000_000_000_000 90_000_000_000_000_000 ((round_pos_inf 98_765_432_101_112_224) (round_neg_inf 98_765_432_101_112_223)) |}]; (* Tests values close to overflow: 230584300921369395 = Int63.max_value / 20 *) let maximum_scale = Int63.( / ) Int63.max_value (Int63.of_int 20) in print_s [%sexp (maximum_scale : Int63.t)]; [%expect {| 230_584_300_921_369_395 |}]; test63 ~scale:maximum_scale ""; test63 ~scale:maximum_scale "5"; test63 ~scale:maximum_scale "9"; test63 ~scale:maximum_scale "99"; test63 ~scale:maximum_scale "999999999"; test63 ~scale:maximum_scale "99999999999999999"; test63 ~scale:maximum_scale "999999999999999999"; [%expect {| 0 ((round_pos_inf 115_292_150_460_684_698) (round_neg_inf 115_292_150_460_684_697)) ((round_pos_inf 207_525_870_829_232_456) (round_neg_inf 207_525_870_829_232_455)) 228_278_457_912_155_701 230_584_300_690_785_094 230_584_300_921_369_393 230_584_300_921_369_395 |}]; let test_failure ?(pos = 0) ?decimals ?(scale = Int63.of_int 60_000) ?(round_ties = Round.Toward_positive_infinity) ?(allow_underscore = true) string = let decimals = Option.value decimals ~default:(String.length string - pos) in require_does_raise [%here] (fun () : Int63.t -> read_int63_decimal string ~pos ~decimals ~scale ~round_ties ~allow_underscore) in test_failure "not a decimal string at all"; [%expect {| (Invalid_argument "Digit_string_helpers.read_int63_decimal: invalid decimal character") |}]; test_failure "000_000" ~allow_underscore:false; [%expect {| (Invalid_argument "Digit_string_helpers.read_int63_decimal: invalid decimal character") |}]; test_failure "0" ~pos:(-1); [%expect {| (Invalid_argument "Digit_string_helpers.read_int63_decimal: pos=-1 out of range for string of length 1") |}]; test_failure "0" ~pos:100 ~decimals:0; [%expect {| (Invalid_argument "Digit_string_helpers.read_int63_decimal: pos=100 out of range for string of length 1") |}]; test_failure "0" ~decimals:(-1); [%expect {| (Invalid_argument "Digit_string_helpers.read_int63_decimal: decimals=-1 is negative") |}]; test_failure "0" ~decimals:100; [%expect {| (Invalid_argument "Digit_string_helpers.read_int63_decimal: 100 digits do not fit at pos 0 in string of length 1") |}]; test_failure "0" ~scale:Int63.zero; [%expect {| (Invalid_argument "Digit_string_helpers.read_int63_decimal: scale=0 out of range [1, 230584300921369395]") |}]; test_failure "0" ~scale:(Int63.of_string "1000000000000000000"); [%expect {| (Invalid_argument "Digit_string_helpers.read_int63_decimal: scale=1000000000000000000 out of range [1, 230584300921369395]") |}]; test_failure "0" ~scale:Int63.max_value; [%expect {| (Invalid_argument "Digit_string_helpers.read_int63_decimal: scale=4611686018427387903 out of range [1, 230584300921369395]") |}] ;; core-0.15.0/core/test/src/digit_string_helpers_tests.mli000066400000000000000000000000401420273305200233500ustar00rootroot00000000000000(*_ intentionally left blank *) core-0.15.0/core/test/src/dune000066400000000000000000000003401420273305200160740ustar00rootroot00000000000000(library (name core_test) (libraries base_test_helpers core expect_test_helpers_core core_kernel.fheap core_kernel.version_util sexp_grammar_validation) (preprocessor_deps ../../src/config.h) (preprocess (pps ppx_jane)))core-0.15.0/core/test/src/error_unit_tests.ml000066400000000000000000000003511420273305200211640ustar00rootroot00000000000000open! Core let%test_unit "[raise_s sexp] raises an exn whose [sexp_of_t] is [sexp]" = let sexp = [%sexp "foo"] in try Nothing.unreachable_code (Error.raise_s sexp) with | exn -> assert (phys_equal [%sexp (exn : exn)] sexp) ;; core-0.15.0/core/test/src/error_unit_tests.mli000066400000000000000000000000551420273305200213360ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/export_base_buffer.mlt000066400000000000000000000072771420273305200216200ustar00rootroot00000000000000open! Core module Buffer_is_from_base : module type of struct include Base.Buffer end = Buffer [%%expect] module Buffer_is_from_caml : module type of struct include Caml.Buffer end = Buffer [%%expect {| Line _, characters _-_: Error: Signature mismatch: ... The value `add_int64_le' is required but not provided File "buffer.mli", line 291, characters 0-37: Expected declaration The value `add_int64_be' is required but not provided File "buffer.mli", line 285, characters 0-37: Expected declaration The value `add_int64_ne' is required but not provided File "buffer.mli", line 279, characters 0-38: Expected declaration The value `add_int32_le' is required but not provided File "buffer.mli", line 273, characters 0-37: Expected declaration The value `add_int32_be' is required but not provided File "buffer.mli", line 267, characters 0-37: Expected declaration The value `add_int32_ne' is required but not provided File "buffer.mli", line 261, characters 0-37: Expected declaration The value `add_int16_le' is required but not provided File "buffer.mli", line 255, characters 0-35: Expected declaration The value `add_int16_be' is required but not provided File "buffer.mli", line 249, characters 0-35: Expected declaration The value `add_int16_ne' is required but not provided File "buffer.mli", line 243, characters 0-35: Expected declaration The value `add_uint16_le' is required but not provided File "buffer.mli", line 237, characters 0-36: Expected declaration The value `add_uint16_be' is required but not provided File "buffer.mli", line 231, characters 0-36: Expected declaration The value `add_uint16_ne' is required but not provided File "buffer.mli", line 225, characters 0-36: Expected declaration The value `add_int8' is required but not provided File "buffer.mli", line 219, characters 0-31: Expected declaration The value `add_uint8' is required but not provided File "buffer.mli", line 213, characters 0-32: Expected declaration The value `of_seq' is required but not provided File "buffer.mli", line 189, characters 0-28: Expected declaration The value `add_seq' is required but not provided File "buffer.mli", line 185, characters 0-37: Expected declaration The value `to_seqi' is required but not provided File "buffer.mli", line 180, characters 0-37: Expected declaration The value `to_seq' is required but not provided File "buffer.mli", line 175, characters 0-28: Expected declaration The value `truncate' is required but not provided File "buffer.mli", line 167, characters 0-31: Expected declaration The value `output_buffer' is required but not provided File "buffer.mli", line 163, characters 0-44: Expected declaration The value `add_channel' is required but not provided File "buffer.mli", line 156, characters 0-48: Expected declaration The value `add_substitute' is required but not provided File "buffer.mli", line 136, characters 0-62: Expected declaration The value `add_utf_16be_uchar' is required but not provided File "buffer.mli", line 113, characters 0-45: Expected declaration The value `add_utf_16le_uchar' is required but not provided File "buffer.mli", line 106, characters 0-45: Expected declaration The value `add_utf_8_uchar' is required but not provided File "buffer.mli", line 100, characters 0-42: Expected declaration The value `to_bytes' is required but not provided File "buffer.mli", line 58, characters 0-25: Expected declaration |}] core-0.15.0/core/test/src/fn_for_testing.ml000066400000000000000000000007641420273305200205700ustar00rootroot00000000000000open Core module type S = sig type t [@@deriving sexp_of, compare] end module type Examples = sig type t val examples : t list end module Make (Input : S) (Output : S) (Examples : Examples with type t := Input.t) = struct open Examples type t = Input.t -> Output.t let to_alist f = List.map examples ~f:(fun x -> x, f x) let compare t1 t2 = [%compare: (Input.t * Output.t) list] (to_alist t1) (to_alist t2) let sexp_of_t t = [%sexp (to_alist t : (Input.t * Output.t) list)] end core-0.15.0/core/test/src/fn_for_testing.mli000066400000000000000000000010571420273305200207350ustar00rootroot00000000000000open! Core module type S = sig type t [@@deriving sexp_of, compare] end module type Examples = sig type t val examples : t list end (** Provides [sexp_of, compare] for function types. Both work by first converting functions to a [(Input.t, Output.t) List.Assoc.t] using [Examples.examples] as the inputs. The resulting sexps and comparisons will only be complete with respect to the given [Examples.examples]. *) module Make (Input : S) (Output : S) (Examples : Examples with type t := Input.t) : S with type t = Input.t -> Output.t core-0.15.0/core/test/src/fqueue_tests.ml000066400000000000000000000006561420273305200202760ustar00rootroot00000000000000open Core let%test_unit "Fqueue round trip via list" = Quickcheck.test (List.quickcheck_generator Int.quickcheck_generator) ~sexp_of:[%sexp_of: int list] ~f:(fun a -> let b = Fqueue.of_list a in let c = Fqueue.to_list b in let d = Fqueue.of_list c in [%test_result: int list] ~expect:a c; [%test_result: int Fqueue.t] ~expect:b d) ~examples:[ []; [ 1 ]; [ 1; 2 ]; [ 1; 2; 3 ] ] ;; core-0.15.0/core/test/src/hashtbl_unit_tests.ml000066400000000000000000002424261420273305200214730ustar00rootroot00000000000000open! Core include Hashtbl_unit_tests_intf (* Demonstrate that [Hashtbl_for_testing] contains all the parts of [Hashtbl_intf.Hashtbl] that need to be tested. *) module _ (Hashtbl : Hashtbl_intf.Hashtbl) = struct let%test_module "tests are exhaustive" = (module ( struct (* Include [Hashtbl_for_testing]. *) include ( Hashtbl : Hashtbl_for_testing with type ('a, 'b) t = ('a, 'b) Hashtbl.t) (* Now add what remains from [Hashtbl_intf.Hashtbl]. *) (* type definition *) type 'a key = 'a (* module type aliases *) module type For_deriving = Hashtbl.For_deriving module type Key = Hashtbl.Key module type Key_binable = Hashtbl.Key_binable module type Key_plain = Hashtbl.Key_plain module type S = Hashtbl.S module type S_binable = Hashtbl.S_binable module type S_plain = Hashtbl.S_plain (* module aliases *) module Hashable = Hashtbl.Hashable module M = Hashtbl.M module Make = Hashtbl.Make module Make_binable = Hashtbl.Make_binable module Make_binable_with_hashable = Hashtbl.Make_binable_with_hashable module Make_plain = Hashtbl.Make_plain module Make_plain_with_hashable = Hashtbl.Make_plain_with_hashable module Make_with_hashable = Hashtbl.Make_with_hashable module Merge_into_action = Hashtbl.Merge_into_action module Poly = Hashtbl.Poly module Using_hashable = Hashtbl.Using_hashable (* exports for deriving via [Hashtbl.M(_)] *) include (Hashtbl : For_deriving with type ('a, 'b) t := ('a, 'b) t) (* hash function accessors, not interesting to test *) let hash = Hashtbl.hash let hash_param = Hashtbl.hash_param let hashable = Hashtbl.hashable let hashable_s = Hashtbl.hashable_s end : Hashtbl_intf.Hashtbl)) ;; end module Make_quickcheck_comparison_to_Map (Hashtbl : Hashtbl_for_testing) = struct let%test_module "quickcheck comparison to Map" = (module ( struct module Qc = Quickcheck module Gen = Qc.Generator open Gen.Monad_infix module type Creators_with_quickcheck_generators = sig include Hashtbl_intf.Creators with type ('a, 'b) t := ('a, 'b) Hashtbl.t with type 'a key := 'a with type ('a, 'b, 'c) create_options := ( 'a , 'b , 'c ) Hashtbl_intf.create_options_with_first_class_module module For_tests : sig type ('key, 'data) constructor [@@deriving sexp_of] type ('key, 'data) multi_constructor [@@deriving sexp_of] val empty_constructor : (_, _) constructor val constructor_gen : 'key Gen.t -> 'data Gen.t -> compare_keys:('key -> 'key -> int) -> ('key, 'data) constructor Gen.t val multi_constructor_gen : 'key Gen.t -> 'data Gen.t -> compare_keys:('key -> 'key -> int) -> ('key, 'data) multi_constructor Gen.t val map_and_table : 'key Base.Hashtbl.Key.t -> (module Comparator.S with type t = 'key and type comparator_witness = 'cmp) -> ('key, 'data) constructor -> ('key, 'data, 'cmp) Map.t * ('key, 'data) Hashtbl.t val map_and_table_multi : 'key Base.Hashtbl.Key.t -> (module Comparator.S with type t = 'key and type comparator_witness = 'cmp) -> ('key, 'data) multi_constructor -> ('key, 'data list, 'cmp) Map.t * ('key, 'data list) Hashtbl.t end end module type Accessors_with_unit_tests = sig include Hashtbl_intf.Accessors with type ('a, 'b) t := ('a, 'b) Hashtbl.t with type 'a key := 'a include Hashtbl_intf.Multi with type ('a, 'b) t := ('a, 'b) Hashtbl.t with type 'a key := 'a val invariant : 'a Invariant.t -> 'b Invariant.t -> ('a, 'b) Hashtbl.t Invariant.t end include ( struct let alist_gen key_gen data_gen ~unique_keys = match unique_keys with | None -> List.quickcheck_generator (Gen.tuple2 key_gen data_gen) | Some compare -> List.quickcheck_generator key_gen >>= fun keys -> let keys = List.dedup_and_sort keys ~compare in List.gen_with_length (List.length keys) data_gen >>| fun data -> List.zip_exn keys data ;; let create ?growth_allowed ?size m () = Hashtbl.create ?growth_allowed ?size m ;; let create_gen () = Gen.singleton `Create let of_alist = Hashtbl.of_alist let of_alist_exn = Hashtbl.of_alist_exn let of_alist_or_error = Hashtbl.of_alist_or_error let of_alist_report_all_dups = Hashtbl.of_alist_report_all_dups let of_alist_gen key_gen data_gen ~compare_keys = alist_gen key_gen data_gen ~unique_keys:(Some compare_keys) >>| fun alist -> `Of_alist alist ;; let of_alist_multi = Hashtbl.of_alist_multi let of_alist_multi_gen key_gen data_gen = alist_gen key_gen data_gen ~unique_keys:None >>| fun alist -> `Of_alist_multi alist ;; let create_with_key = Hashtbl.create_with_key let create_with_key_exn = Hashtbl.create_with_key_exn let create_with_key_or_error = Hashtbl.create_with_key_or_error let create_with_key_gen key_gen data_gen ~compare_keys = alist_gen key_gen data_gen ~unique_keys:(Some compare_keys) >>| fun alist -> `Create_with_key alist ;; let create_mapped = Hashtbl.create_mapped let create_mapped_gen key_gen data_gen ~compare_keys = alist_gen key_gen data_gen ~unique_keys:(Some compare_keys) >>| fun alist -> `Create_mapped alist ;; let group = Hashtbl.group let group_gen key_gen data_gen = alist_gen key_gen data_gen ~unique_keys:None >>| fun alist -> `Group alist ;; module For_tests = struct type ('key, 'data) constructor = [ `Create | `Of_alist of ('key * 'data) list | `Create_mapped of ('key * 'data) list | `Create_with_key of ('key * 'data) list ] [@@deriving sexp_of] type ('key, 'data) multi_constructor = [ ('key, 'data list) constructor | `Of_alist_multi of ('key * 'data) list | `Group of ('key * 'data) list ] [@@deriving sexp_of] let empty_constructor = `Create let constructor_gen key_gen data_gen ~compare_keys = Gen.union [ create_gen () ; of_alist_gen key_gen data_gen ~compare_keys ; create_mapped_gen key_gen data_gen ~compare_keys ; create_with_key_gen key_gen data_gen ~compare_keys ] ;; let multi_constructor_gen key_gen data_gen ~compare_keys = Gen.union [ constructor_gen key_gen (List.quickcheck_generator data_gen) ~compare_keys ; of_alist_multi_gen key_gen data_gen ; group_gen key_gen data_gen ] ;; let map_and_table m_hash m_map = function | `Create -> Map.empty m_map, Hashtbl.create m_hash | `Of_alist alist -> Map.of_alist_exn m_map alist, Hashtbl.of_alist_exn m_hash alist | `Create_with_key alist -> ( Map.of_alist_exn m_map alist , Hashtbl.create_with_key_exn m_hash alist ~get_key:fst |> Hashtbl.map ~f:snd ) | `Create_mapped alist -> ( Map.of_alist_exn m_map alist , Hashtbl.create_mapped m_hash alist ~get_key:fst ~get_data:snd |> (function | `Ok table -> table | `Duplicate_keys _ -> assert false) ) ;; let map_and_table_multi m_hash m_map = function | `Of_alist_multi alist -> ( Map.of_alist_multi m_map (List.rev alist) , Hashtbl.of_alist_multi m_hash alist ) | `Group alist -> ( Map.of_alist_reduce m_map ~f:( @ ) (List.map alist ~f:(fun (key, data) -> key, [ data ])) , Hashtbl.group m_hash alist ~combine:( @ ) ~get_key:fst ~get_data:(Fn.compose List.return snd) ) | (`Create | `Of_alist _ | `Create_with_key _ | `Create_mapped _) as c -> map_and_table m_hash m_map c ;; end end : Creators_with_quickcheck_generators) let create ?growth_allowed ?size m = create ?growth_allowed ?size m () include ( struct module For_tests = struct open For_tests let is_even n = n land 1 = 0 module Key = struct include String let quickcheck_generator = Gen.small_non_negative_int >>| sprintf "s%d" ;; let to_bool t = is_empty t || is_even (Char.to_int (get t (length t - 1))) ;; end module Data = struct include Int let quickcheck_generator = Gen.small_non_negative_int let to_bool = is_even (* Here, [succ] is useful for testing [filter_map] *) let to_option t = if is_even t then Some (succ t) else None let to_partition t = if is_even t then First (succ t) else Second (pred t) ;; end module Key_and_data = struct let to_bool ~key ~data = Bool.equal (Key.to_bool key) (Data.to_bool data) ;; let to_data ~key ~data = if Key.to_bool key then succ data else pred data ;; let to_data_option ~key ~data = if Key.to_bool key then Some data else Data.to_option data ;; let to_data_partition ~key ~data = if Key.to_bool key then First (succ data) else Second (pred data) ;; let merge ~key x = if Key.to_bool key then None else ( match x with | `Left data -> Some (Data.succ data) | `Right data -> Some (Data.pred data) | `Both (x, y) -> Some (x - y)) ;; end let comparator = Key.comparator let compare_keys = Key.compare type nonrec constructor = (Key.t, Data.t) constructor [@@deriving sexp_of] type nonrec multi_constructor = (Key.t, Data.t) multi_constructor [@@deriving sexp_of] let empty_constructor = For_tests.empty_constructor let constructor_gen = constructor_gen Key.quickcheck_generator Data.quickcheck_generator ~compare_keys ;; let multi_constructor_gen = multi_constructor_gen Key.quickcheck_generator Data.quickcheck_generator ~compare_keys ;; let map_and_table = map_and_table (module Key) (module Key) let map_and_table_multi = map_and_table_multi (module Key) (module Key) ;; let to_map t = Hashtbl.to_alist t |> Map.Using_comparator.of_alist_exn ~comparator ;; end open For_tests let invariant = Hashtbl.invariant (* This test is mostly validating constructors, making sure all of them satisfy [invariant] and that we have correctly constructed corresponding hash tables and maps. *) let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in Hashtbl.invariant ignore ignore t; [%test_result: Data.t Key.Map.t] (to_map t) ~expect:map) ;; let%test_unit _ = Qc.test multi_constructor_gen ~sexp_of:[%sexp_of: multi_constructor] ~f:(fun multi_constructor -> let map, t = map_and_table_multi multi_constructor in Hashtbl.invariant ignore ignore t; [%test_result: Data.t list Key.Map.t] (to_map t) ~expect:map) ;; let sexp_of_key = Hashtbl.sexp_of_key let%test_unit _ = Qc.test (Gen.tuple2 constructor_gen Key.quickcheck_generator) ~sexp_of:[%sexp_of: constructor * Key.t] ~f:(fun (constructor, key) -> let _, t = map_and_table constructor in [%test_result: Sexp.t] (Hashtbl.sexp_of_key t key) ~expect:([%sexp_of: Key.t] key)) ;; let clear = Hashtbl.clear let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let _, t = map_and_table constructor in Hashtbl.clear t; Hashtbl.invariant ignore ignore t; [%test_result: Data.t Key.Map.t] (to_map t) ~expect:Key.Map.empty) ;; let copy = Hashtbl.copy let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in let t_copy = Hashtbl.copy t in Hashtbl.clear t; Hashtbl.invariant ignore ignore t_copy; [%test_result: Data.t Key.Map.t] (to_map t_copy) ~expect:map) ;; let fold = Hashtbl.fold let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: Data.t Key.Map.t] (Hashtbl.fold t ~init:Key.Map.empty ~f:(fun ~key ~data map -> Map.set map ~key ~data)) ~expect:map) ;; let iter = Hashtbl.iter let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in let datas = ref [] in Hashtbl.iter t ~f:(fun data -> datas := data :: !datas); [%test_result: Data.t list] (List.sort !datas ~compare:Data.compare) ~expect:(List.sort (Map.data map) ~compare:Data.compare)) ;; let iteri = Hashtbl.iteri let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in let t_copy = Hashtbl.create (module Key) in Hashtbl.iteri t ~f:(fun ~key ~data -> Hashtbl.add_exn t_copy ~key ~data); [%test_result: Data.t Key.Map.t] (to_map t_copy) ~expect:map) ;; let iter_keys = Hashtbl.iter_keys let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in let keys = ref [] in Hashtbl.iter_keys t ~f:(fun key -> keys := key :: !keys); [%test_result: Key.t list] (List.sort !keys ~compare:Key.compare) ~expect:(List.sort (Map.keys map) ~compare:Key.compare)) ;; let exists = Hashtbl.exists let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: bool] (Hashtbl.exists t ~f:Data.to_bool) ~expect:(Map.exists map ~f:Data.to_bool)) ;; let existsi = Hashtbl.existsi let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: bool] (Hashtbl.existsi t ~f:Key_and_data.to_bool) ~expect:(Map.existsi map ~f:Key_and_data.to_bool)) ;; let for_all = Hashtbl.for_all let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: bool] (Hashtbl.for_all t ~f:Data.to_bool) ~expect:(Map.for_all map ~f:Data.to_bool)) ;; let for_alli = Hashtbl.for_alli let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: bool] (Hashtbl.for_alli t ~f:Key_and_data.to_bool) ~expect:(Map.for_alli map ~f:Key_and_data.to_bool)) ;; let count = Hashtbl.count let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: int] (Hashtbl.count t ~f:Data.to_bool) ~expect:(Map.count map ~f:Data.to_bool)) ;; let counti = Hashtbl.counti let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: int] (Hashtbl.counti t ~f:Key_and_data.to_bool) ~expect:(Map.counti map ~f:Key_and_data.to_bool)) ;; let length = Hashtbl.length let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: int] (Hashtbl.length t) ~expect:(Map.length map)) ;; let is_empty = Hashtbl.is_empty let%test_unit _ = Qc.test constructor_gen ~examples:[ empty_constructor ] ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: bool] (Hashtbl.is_empty t) ~expect:(Map.is_empty map)) ;; let mem = Hashtbl.mem let%test_unit _ = Qc.test (Gen.tuple2 constructor_gen Key.quickcheck_generator) ~sexp_of:[%sexp_of: constructor * Key.t] ~f:(fun (constructor, key) -> let map, t = map_and_table constructor in [%test_result: bool] (Hashtbl.mem t key) ~expect:(Map.mem map key)) ;; let remove = Hashtbl.remove let%test_unit _ = Qc.test (Gen.tuple2 constructor_gen Key.quickcheck_generator) ~sexp_of:[%sexp_of: constructor * Key.t] ~f:(fun (constructor, key) -> let map, t = map_and_table constructor in Hashtbl.remove t key; [%test_result: Data.t Key.Map.t] (to_map t) ~expect:(Map.remove map key)) ;; let set = Hashtbl.set let%test_unit _ = Qc.test (Gen.tuple3 constructor_gen Key.quickcheck_generator Data.quickcheck_generator) ~sexp_of:[%sexp_of: constructor * Key.t * Data.t] ~f:(fun (constructor, key, data) -> let map, t = map_and_table constructor in Hashtbl.set t ~key ~data; [%test_result: Data.t Key.Map.t] (to_map t) ~expect:(Map.set map ~key ~data)) ;; let add = Hashtbl.add let add_exn = Hashtbl.add_exn let%test_unit _ = let f (name, add) = Qc.test (Gen.tuple3 constructor_gen Key.quickcheck_generator Data.quickcheck_generator) ~sexp_of:[%sexp_of: constructor * Key.t * Data.t] ~f:(fun (constructor, key, data) -> let map, t = map_and_table constructor in let expect = match add t ~key ~data with | `Ok -> Map.set map ~key ~data | `Duplicate -> map in [%test_result: Data.t Key.Map.t] (to_map t) ~expect ~message:name) in let add_exn t ~key ~data = match add_exn t ~key ~data with | () -> `Ok | exception _ -> `Duplicate in List.iter ~f [ "add", add; "add_exn", add_exn ] ;; let change = Hashtbl.change let%test_unit _ = Qc.test (Gen.tuple3 constructor_gen Key.quickcheck_generator (Option.quickcheck_generator Data.quickcheck_generator)) ~sexp_of:[%sexp_of: constructor * Key.t * Data.t option] ~f:(fun (constructor, key, data_opt) -> let map, t = map_and_table constructor in Hashtbl.change t key ~f:(fun original -> [%test_result: Data.t option] original ~expect:(Map.find map key); data_opt); [%test_result: Data.t Key.Map.t] (to_map t) ~expect:(Map.change map key ~f:(fun _ -> data_opt))) ;; let choose = Hashtbl.choose let choose_exn = Hashtbl.choose_exn let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: bool] (is_some (choose t)) ~expect:(not (Map.is_empty map)); [%test_result: bool] (Exn.does_raise (fun () -> choose_exn t)) ~expect:(Map.is_empty map)) ;; let update = Hashtbl.update let%test_unit _ = Qc.test (Gen.tuple3 constructor_gen Key.quickcheck_generator Data.quickcheck_generator) ~sexp_of:[%sexp_of: constructor * Key.t * Data.t] ~f:(fun (constructor, key, data) -> let map, t = map_and_table constructor in Hashtbl.update t key ~f:(fun original -> [%test_result: Data.t option] original ~expect:(Map.find map key); data); [%test_result: Data.t Key.Map.t] (to_map t) ~expect:(Map.update map key ~f:(fun _ -> data))) ;; let update_and_return = Hashtbl.update_and_return let%test_unit _ = Qc.test (Gen.tuple3 constructor_gen Key.quickcheck_generator Data.quickcheck_generator) ~sexp_of:[%sexp_of: constructor * Key.t * Data.t] ~f:(fun (constructor, key, data) -> let map, t = map_and_table constructor in let result = Hashtbl.update_and_return t key ~f:(fun original -> [%test_result: Data.t option] original ~expect:(Map.find map key); data) in [%test_result: Data.t Key.Map.t * Data.t] (to_map t, result) ~expect: (let map = Map.update map key ~f:(fun _ -> data) in map, Map.find_exn map key)) ;; let add_multi = Hashtbl.add_multi let%test_unit _ = Qc.test (Gen.tuple3 multi_constructor_gen Key.quickcheck_generator Data.quickcheck_generator) ~sexp_of:[%sexp_of: multi_constructor * Key.t * Data.t] ~f:(fun (multi_constructor, key, data) -> let map, t = map_and_table_multi multi_constructor in Hashtbl.add_multi t ~key ~data; [%test_result: Data.t list Key.Map.t] (to_map t) ~expect:(Map.add_multi map ~key ~data)) ;; let remove_multi = Hashtbl.remove_multi let%test_unit _ = Qc.test (Gen.tuple2 multi_constructor_gen Key.quickcheck_generator) ~sexp_of:[%sexp_of: multi_constructor * Key.t] ~f:(fun (multi_constructor, key) -> let map, t = map_and_table_multi multi_constructor in Hashtbl.remove_multi t key; [%test_result: Data.t list Key.Map.t] (to_map t) ~expect:(Map.remove_multi map key)) ;; let find_multi = Hashtbl.find_multi let%test_unit _ = Qc.test (Gen.tuple2 multi_constructor_gen Key.quickcheck_generator) ~sexp_of:[%sexp_of: multi_constructor * Key.t] ~f:(fun (multi_constructor, key) -> let map, t = map_and_table_multi multi_constructor in [%test_result: Data.t list] (Hashtbl.find_multi t key) ~expect:(Map.find_multi map key)) ;; let map = Hashtbl.map let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: Data.t Key.Map.t] (to_map (Hashtbl.map t ~f:Data.succ)) ~expect:(Map.map map ~f:Data.succ)) ;; let mapi = Hashtbl.mapi let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: Data.t Key.Map.t] (to_map (Hashtbl.mapi t ~f:Key_and_data.to_data)) ~expect:(Map.mapi map ~f:Key_and_data.to_data)) ;; let map_inplace = Hashtbl.map_inplace let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in Hashtbl.map_inplace t ~f:Data.succ; [%test_result: Data.t Key.Map.t] (to_map t) ~expect:(Map.map map ~f:Data.succ)) ;; let mapi_inplace = Hashtbl.mapi_inplace let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in Hashtbl.mapi_inplace t ~f:Key_and_data.to_data; [%test_result: Data.t Key.Map.t] (to_map t) ~expect:(Map.mapi map ~f:Key_and_data.to_data)) ;; let filter_keys = Hashtbl.filter_keys let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: Data.t Key.Map.t] (to_map (Hashtbl.filter_keys t ~f:Key.to_bool)) ~expect:(Map.filter_keys map ~f:Key.to_bool)) ;; let filter = Hashtbl.filter let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: Data.t Key.Map.t] (to_map (Hashtbl.filter t ~f:Data.to_bool)) ~expect:(Map.filter map ~f:Data.to_bool)) ;; let filteri = Hashtbl.filteri let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: Data.t Key.Map.t] (to_map (Hashtbl.filteri t ~f:Key_and_data.to_bool)) ~expect:(Map.filteri map ~f:Key_and_data.to_bool)) ;; let filter_map = Hashtbl.filter_map let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: Data.t Key.Map.t] (to_map (Hashtbl.filter_map t ~f:Data.to_option)) ~expect:(Map.filter_map map ~f:Data.to_option)) ;; let filter_mapi = Hashtbl.filter_mapi let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: Data.t Key.Map.t] (to_map (Hashtbl.filter_mapi t ~f:Key_and_data.to_data_option)) ~expect:(Map.filter_mapi map ~f:Key_and_data.to_data_option)) ;; let filter_inplace = Hashtbl.filter_inplace let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in Hashtbl.filter_inplace t ~f:Data.to_bool; [%test_result: Data.t Key.Map.t] (to_map t) ~expect: (Map.filteri map ~f:(fun ~key:_ ~data -> Data.to_bool data))) ;; let filteri_inplace = Hashtbl.filteri_inplace let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in Hashtbl.filteri_inplace t ~f:Key_and_data.to_bool; [%test_result: Data.t Key.Map.t] (to_map t) ~expect:(Map.filteri map ~f:Key_and_data.to_bool)) ;; let filter_map_inplace = Hashtbl.filter_map_inplace let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in Hashtbl.filter_map_inplace t ~f:Data.to_option; [%test_result: Data.t Key.Map.t] (to_map t) ~expect:(Map.filter_map map ~f:Data.to_option)) ;; let filter_mapi_inplace = Hashtbl.filter_mapi_inplace let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in Hashtbl.filter_mapi_inplace t ~f:Key_and_data.to_data_option; [%test_result: Data.t Key.Map.t] (to_map t) ~expect:(Map.filter_mapi map ~f:Key_and_data.to_data_option)) ;; let filter_keys_inplace = Hashtbl.filter_keys_inplace let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in Hashtbl.filter_keys_inplace t ~f:Key.to_bool; [%test_result: Data.t Key.Map.t] (to_map t) ~expect: (Map.filteri map ~f:(fun ~key ~data:_ -> Key.to_bool key))) ;; let partition_map = Hashtbl.partition_map let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: Data.t Key.Map.t * Data.t Key.Map.t] (let a, b = Hashtbl.partition_map t ~f:Data.to_partition in to_map a, to_map b) ~expect:(Map.partition_map map ~f:Data.to_partition)) ;; let partition_mapi = Hashtbl.partition_mapi let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: Data.t Key.Map.t * Data.t Key.Map.t] (let a, b = Hashtbl.partition_mapi t ~f:Key_and_data.to_data_partition in to_map a, to_map b) ~expect: (Map.partition_mapi map ~f:Key_and_data.to_data_partition)) ;; let partition_tf = Hashtbl.partition_tf let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: Data.t Key.Map.t * Data.t Key.Map.t] (let a, b = Hashtbl.partition_tf t ~f:Data.to_bool in to_map a, to_map b) ~expect:(Map.partition_tf map ~f:Data.to_bool)) ;; let partitioni_tf = Hashtbl.partitioni_tf let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: Data.t Key.Map.t * Data.t Key.Map.t] (let a, b = Hashtbl.partitioni_tf t ~f:Key_and_data.to_bool in to_map a, to_map b) ~expect:(Map.partitioni_tf map ~f:Key_and_data.to_bool)) ;; let find_or_add = Hashtbl.find_or_add let findi_or_add = Hashtbl.findi_or_add let%test_unit _ = Qc.test (Gen.tuple3 constructor_gen Key.quickcheck_generator Data.quickcheck_generator) ~sexp_of:[%sexp_of: constructor * Key.t * Data.t] ~f:(fun (constructor, key, data) -> let map, t = map_and_table constructor in [%test_result: Data.t] (find_or_add t key ~default:(fun () -> data)) ~expect:(Map.find map key |> Option.value ~default:data); [%test_result: Data.t Key.Map.t] (to_map t) ~expect: (if Map.mem map key then map else Map.set map ~key ~data)) ;; let find = Hashtbl.find let find_exn = Hashtbl.find_exn let%test_unit _ = let f (name, find) = Qc.test (Gen.tuple2 constructor_gen Key.quickcheck_generator) ~sexp_of:[%sexp_of: constructor * Key.t] ~f:(fun (constructor, key) -> let map, t = map_and_table constructor in [%test_result: Data.t option] (find t key) ~expect:(Map.find map key) ~message:name) in let find_exn t key = match find_exn t key with | data -> Some data | exception _ -> None in List.iter ~f [ "find", find; "find_exn", find_exn ] ;; let find_and_call = Hashtbl.find_and_call let findi_and_call = Hashtbl.findi_and_call let find_and_call1 = Hashtbl.find_and_call1 let findi_and_call1 = Hashtbl.findi_and_call1 let find_and_call2 = Hashtbl.find_and_call2 let findi_and_call2 = Hashtbl.findi_and_call2 let%test_unit _ = Qc.test (Gen.tuple4 constructor_gen Key.quickcheck_generator Int.quickcheck_generator String.quickcheck_generator) ~sexp_of:[%sexp_of: constructor * Key.t * int * string] ~f:(fun (constructor, key, a, b) -> let map, t = map_and_table constructor in [%test_result: (Data.t, Key.t) Either.t] (Hashtbl.find_and_call t key ~if_found:Either.first ~if_not_found:Either.second) ~expect: (match Map.find map key with | Some data -> First data | None -> Second key); [%test_result: (Key.t * Data.t, Key.t) Either.t] (Hashtbl.findi_and_call t key ~if_found:(fun ~key ~data -> Either.first (key, data)) ~if_not_found:Either.second) ~expect: (match Map.find map key with | Some data -> First (key, data) | None -> Second key); [%test_result: (Data.t, Key.t) Either.t * int] (Hashtbl.find_and_call1 t key ~a ~if_found:(fun data a -> Either.first data, a) ~if_not_found:(fun key a -> Either.second key, a)) ~expect: (match Map.find map key with | Some data -> First data, a | None -> Second key, a); [%test_result: (Key.t * Data.t, Key.t) Either.t * int] (Hashtbl.findi_and_call1 t key ~a ~if_found:(fun ~key ~data a -> Either.first (key, data), a) ~if_not_found:(fun key a -> Either.second key, a)) ~expect: (match Map.find map key with | Some data -> First (key, data), a | None -> Second key, a); [%test_result: (Data.t, Key.t) Either.t * int * string] (Hashtbl.find_and_call2 t key ~a ~b ~if_found:(fun data a b -> Either.first data, a, b) ~if_not_found:(fun key a b -> Either.second key, a, b)) ~expect: (match Map.find map key with | Some data -> First data, a, b | None -> Second key, a, b); [%test_result: (Key.t * Data.t, Key.t) Either.t * int * string] (Hashtbl.findi_and_call2 t key ~a ~b ~if_found:(fun ~key ~data a b -> Either.first (key, data), a, b) ~if_not_found:(fun key a b -> Either.second key, a, b)) ~expect: (match Map.find map key with | Some data -> First (key, data), a, b | None -> Second key, a, b)) ;; let find_and_remove = Hashtbl.find_and_remove let%test_unit _ = Qc.test (Gen.tuple2 constructor_gen Key.quickcheck_generator) ~sexp_of:[%sexp_of: constructor * Key.t] ~f:(fun (constructor, key) -> let map, t = map_and_table constructor in [%test_result: Data.t option] (Hashtbl.find_and_remove t key) ~expect:(Map.find map key); [%test_result: Data.t Key.Map.t] (to_map t) ~expect:(Map.remove map key)) ;; let merge = Hashtbl.merge let%test_unit _ = Qc.test (Gen.tuple2 constructor_gen constructor_gen) ~sexp_of:[%sexp_of: constructor * constructor] ~f:(fun (constructor1, constructor2) -> let map1, t1 = map_and_table constructor1 in let map2, t2 = map_and_table constructor2 in [%test_result: Data.t Key.Map.t] (to_map (Hashtbl.merge t1 t2 ~f:Key_and_data.merge)) ~expect:(Map.merge map1 map2 ~f:Key_and_data.merge)) ;; let merge_into = Hashtbl.merge_into let%test_unit _ = Qc.test (Gen.tuple2 constructor_gen constructor_gen) ~sexp_of:[%sexp_of: constructor * constructor] ~f:(fun (constructor1, constructor2) -> let map1, t1 = map_and_table constructor1 in let map2, t2 = map_and_table constructor2 in let f ~key data2 data1_opt : _ Hashtbl_intf.Merge_into_action.t = match Key_and_data.merge ~key (match data1_opt with | Some data1 -> `Both (data1, data2) | None -> `Right data2) with | None -> Remove | Some x -> Set_to x in Hashtbl.merge_into ~dst:t1 ~src:t2 ~f; [%test_result: Data.t Key.Map.t] (to_map t1) ~expect: (Map.fold map2 ~init:map1 ~f:(fun ~key ~data:data2 map1 -> Map.change map1 key ~f:(fun data1_opt -> match f ~key data2 data1_opt with | Set_to x -> Some x | Remove -> None)))) ;; let equal = Hashtbl.equal let%test_unit _ = Qc.test (Gen.tuple2 constructor_gen constructor_gen) ~sexp_of:[%sexp_of: constructor * constructor] ~f:(fun (constructor1, constructor2) -> let map1, t1 = map_and_table constructor1 in let map2, t2 = map_and_table constructor2 in [%test_result: bool] (Hashtbl.equal Data.equal t1 t2) ~expect:(Map.equal Data.equal map1 map2)) ;; let similar = Hashtbl.similar let%test_unit _ = Qc.test (Gen.tuple2 constructor_gen constructor_gen) ~sexp_of:[%sexp_of: constructor * constructor] ~f:(fun (constructor1, constructor2) -> let map1, t1 = map_and_table constructor1 in let map2, t2 = map_and_table constructor2 in [%test_result: bool] (Hashtbl.similar Data.equal t1 t2) ~expect:(Map.equal Data.equal map1 map2)) ;; let keys = Hashtbl.keys let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: Key.t list] (keys t |> List.sort ~compare:Key.compare) ~expect:(Map.keys map |> List.sort ~compare:Key.compare)) ;; let data = Hashtbl.data let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: Data.t list] (data t |> List.sort ~compare:Data.compare) ~expect:(Map.data map |> List.sort ~compare:Data.compare)) ;; let to_alist = Hashtbl.to_alist let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in [%test_result: (Key.t * Data.t) list] (to_alist t |> List.sort ~compare:[%compare: Key.t * Data.t]) ~expect: (Map.to_alist map |> List.sort ~compare:[%compare: Key.t * Data.t])) ;; let validate = Hashtbl.validate let%test_unit _ = Qc.test constructor_gen ~sexp_of:[%sexp_of: constructor] ~f:(fun constructor -> let map, t = map_and_table constructor in let name = Key.to_string in let check_data data = if Data.to_bool data then Validate.pass else Validate.fail "data" in [%test_result: bool] (Result.is_ok (Validate.result (Hashtbl.validate ~name check_data t))) ~expect:(Map.for_all map ~f:Data.to_bool)) ;; let incr = Hashtbl.incr let%test_unit _ = Qc.test (Gen.tuple3 constructor_gen Key.quickcheck_generator Data.quickcheck_generator) ~sexp_of:[%sexp_of: constructor * Key.t * Data.t] ~f:(fun (constructor, key, by) -> let map, t = map_and_table constructor in Hashtbl.incr t key ~by; [%test_result: Data.t Key.Map.t] (to_map t) ~expect: (Map.update map key ~f:(fun opt -> Option.value opt ~default:0 + by))) ;; let decr = Hashtbl.decr let%test_unit _ = Qc.test (Gen.tuple3 constructor_gen Key.quickcheck_generator Data.quickcheck_generator) ~sexp_of:[%sexp_of: constructor * Key.t * Data.t] ~f:(fun (constructor, key, by) -> let map, t = map_and_table constructor in Hashtbl.decr t key ~by; [%test_result: Data.t Key.Map.t] (to_map t) ~expect: (Map.update map key ~f:(fun opt -> Option.value opt ~default:0 - by))) ;; end : Accessors_with_unit_tests) (* not particularly interesting to test *) let sexp_of_t = Hashtbl.sexp_of_t end : Hashtbl_for_testing with type ('a, 'b) t := ('a, 'b) Hashtbl.t)) ;; end module Make_mutation_in_callbacks (Hashtbl : Hashtbl_for_testing) = struct let%test_module "mutation in callbacks" = (module ( struct module Test = struct exception Note of (string, Sexp.t) List.Assoc.t * exn [@@deriving sexp] let note str value sexp_of_value thunk = try thunk () with | Note (alist, exn) -> raise (Note ((str, sexp_of_value value) :: alist, exn)) | exn -> raise (Note ([ str, sexp_of_value value ], exn)) ;; let for_each str sexp_of_value values f = List.iter values ~f:(fun value -> note str value sexp_of_value (fun () -> f value)) ;; let size = 16 let key_funs = [ (fun i -> i); (fun i -> i + size); (fun i -> i * size) ] ;; let multi_funs = [ (fun _ -> []); (fun i -> [ i ]); (fun i -> List.init i ~f:Fn.id) ] ;; let sample_keys = List.concat_map key_funs ~f:(fun f -> [ f 1; f 2; f 3 ]) ;; let sample_data = [ 100; 200; 300 ] let sexp_of_key = [%sexp_of: int] let sexp_of_data = [%sexp_of: int] let make_table ~key_of_index ~data_of_index = List.init size ~f:(fun i -> key_of_index i, data_of_index i) |> Hashtbl.of_alist_exn (module Int) ;; let makers = List.map key_funs ~f:(fun key_of_index -> let maker () = make_table ~key_of_index ~data_of_index:Fn.id in maker) ;; let multi_makers = List.concat_map key_funs ~f:(fun key_of_index -> List.concat_map multi_funs ~f:(fun data_of_index -> [ (fun () -> make_table ~key_of_index ~data_of_index) ])) ;; let sexp_of_maker make = make () |> Hashtbl.to_alist |> [%sexp_of: (int * int) list] ;; let sexp_of_multi_maker make = make () |> Hashtbl.to_alist |> [%sexp_of: (int * int list) list] ;; let bools = [ true; false ] let option values = None :: List.map values ~f:(fun value -> Some value) ;; let first_or_second values = List.concat_map values ~f:(fun value -> [ First value; Second value ]) ;; let default_mutate t = Hashtbl.clear t let make_caller test_result = let caller t f = Hashtbl.map t ~f |> Hashtbl.to_alist in let callback x = x in caller, callback, test_result ;; let mono_caller () = make_caller [%test_result: (int * int) list] let multi_caller () = make_caller [%test_result: (int * int list) list] let inside_iter t f = with_return (fun r -> Hashtbl.iteri t ~f:(fun ~key:_ ~data:_ -> r.return (f ())); assert false) ;; type 'a test_result = ?here:Lexing.position list -> ?message:string -> ?equal:('a -> 'a -> bool) -> expect:'a -> 'a -> unit let mutation_after_callback_does_not_raise (type a) ~make ~caller ~callback ~mutate ~test_result = let (_ : a test_result) = test_result in let t = make () in let (_ : a) = caller t callback in mutate t ;; let mutation_after_callback_inside_iter_does_not_raise (type a) ~make ~caller ~callback ~mutate ~test_result = let (_ : a test_result) = test_result in let t = make () in let (_ : a Or_error.t) = Or_error.try_with (fun () -> inside_iter t (fun () -> caller t callback)) in mutate t ;; let mutation_after_iter_inside_callback_does_not_raise (type a) ~make ~caller ~callback ~mutate ~test_result = let (_ : a test_result) = test_result in let t = make () in let (_ : a Or_error.t) = Or_error.try_with (fun () -> caller t (fun x -> inside_iter t (fun () -> callback x))) in mutate t ;; let mutation_after_raising_callback_does_not_raise (type a) ~make ~caller ~callback:_ ~mutate ~test_result = let (_ : a test_result) = test_result in let t = make () in let (_ : a Or_error.t) = Or_error.try_with (fun () -> caller t (fun _ -> assert false)) in mutate t ;; let mutation_inside_callback_is_consistent ~make ~caller ~callback ~mutate ~test_result = match let t = make () in Or_error.try_with (fun () -> caller t (fun x -> mutate t; callback x)) with | Error _ -> () | Ok actual -> let expect = let t = make () in caller t callback in test_result ?here:None ?message:None ?equal:None ~expect actual ;; let mutation_inside_callback_inside_iter_is_consistent ~make ~caller ~callback ~mutate ~test_result = match let t = make () in Or_error.try_with (fun () -> inside_iter t (fun () -> caller t (fun x -> mutate t; callback x))) with | Error _ -> () | Ok actual -> let expect = let t = make () in inside_iter t (fun () -> caller t callback) in test_result ?here:None ?message:None ?equal:None ~expect actual ;; let mutation_inside_iter_inside_callback_is_consistent ~make ~caller ~callback ~mutate ~test_result = match let t = make () in Or_error.try_with (fun () -> caller t (fun x -> inside_iter t (fun () -> mutate t; callback x))) with | Error _ -> () | Ok actual -> let expect = let t = make () in caller t (fun x -> inside_iter t (fun () -> callback x)) in test_result ?here:None ?message:None ?equal:None ~expect actual ;; let mutation_inside_iter_after_callback_is_consistent ~make ~caller ~callback ~mutate ~test_result = match let t = make () in Or_error.try_with (fun () -> inside_iter t (fun () -> let x = caller t callback in mutate t; x)) with | Error _ -> () | Ok actual -> let expect = let t = make () in inside_iter t (fun () -> caller t callback) in test_result ?here:None ?message:None ?equal:None ~expect actual ;; let mutation_inside_callback_after_iter_is_consistent ~make ~caller ~callback ~mutate ~test_result = match let t = make () in Or_error.try_with (fun () -> caller t (fun x -> inside_iter t (fun () -> ()); mutate t; callback x)) with | Error _ -> () | Ok actual -> let expect = let t = make () in caller t (fun x -> inside_iter t (fun () -> ()); callback x) in test_result ?here:None ?message:None ?equal:None ~expect actual ;; let test_cases = [ ( "mutation_inside_callback_is_consistent" , mutation_inside_callback_is_consistent ) ; ( "mutation_after_callback_does_not_raise" , mutation_after_callback_does_not_raise ) ; ( "mutation_after_raising_callback_does_not_raise" , mutation_after_raising_callback_does_not_raise ) ; ( "mutation_inside_callback_inside_iter_is_consistent" , mutation_inside_callback_inside_iter_is_consistent ) ; ( "mutation_inside_iter_inside_callback_is_consistent" , mutation_inside_iter_inside_callback_is_consistent ) ; ( "mutation_inside_iter_after_callback_is_consistent" , mutation_inside_iter_after_callback_is_consistent ) ; ( "mutation_inside_callback_after_iter_is_consistent" , mutation_inside_callback_after_iter_is_consistent ) ; ( "mutation_after_callback_inside_iter_does_not_raise" , mutation_after_callback_inside_iter_does_not_raise ) ; ( "mutation_after_iter_inside_callback_does_not_raise" , mutation_after_iter_inside_callback_does_not_raise ) ] ;; let sexp_of_test_case (name, _) = Sexp.Atom name let test name ~make ~caller ~callback ~mutate ~test_result = for_each "test case" sexp_of_test_case test_cases (fun (_, f) -> note "test kind" name [%sexp_of: string] (fun () -> f ~make ~caller ~callback ~mutate ~test_result)) ;; let test_mutate mutate = let caller, callback, test_result = mono_caller () in for_each "table to mutate" sexp_of_maker makers (fun make -> test "mutator" ~make ~caller ~callback ~mutate ~test_result) ;; let test_mutate_multi mutate = let caller, callback, test_result = multi_caller () in for_each "table to mutate" sexp_of_multi_maker multi_makers (fun make -> test "mutator" ~make ~caller ~callback ~mutate ~test_result) ;; let test_caller ~callback ~test_result caller = let mutate = default_mutate in for_each "table to mutate" sexp_of_maker makers (fun make -> test "caller" ~make ~caller ~callback ~mutate ~test_result) ;; let test_mutate_2ts mutate = for_each "table not mutated" sexp_of_maker makers (fun make -> test_mutate (fun t1 -> let t2 = make () in mutate t1 t2); test_mutate (fun t2 -> let t1 = make () in mutate t1 t2)) ;; let test_caller_2ts ~callback ~test_result caller = for_each "table not mutated" sexp_of_maker makers (fun make -> test_caller ~callback ~test_result (fun t1 f -> caller t1 (make ()) f); test_caller ~callback ~test_result (fun t2 f -> caller (make ()) t2 f)) ;; let test_caller_2fs f1 f2 ~test_result caller = test_caller ~callback:f1 ~test_result (fun t f1 -> caller t f1 f2); test_caller ~callback:f2 ~test_result (fun t f2 -> caller t f1 f2) ;; type ('a, 'b) merge_data = [ `Left of 'a | `Right of 'b | `Both of 'a * 'b ] [@@deriving sexp, compare] end open Test (* functions that both mutate and accept callbacks *) let find_or_add = Hashtbl.find_or_add let findi_or_add = Hashtbl.findi_or_add let%test_unit "find_or_add" = for_each "key" sexp_of_key sample_keys (fun key -> for_each "data" sexp_of_data sample_data (fun data -> test_mutate (fun t -> Hashtbl.find_or_add t key ~default:(fun () -> data) |> (ignore : int -> unit)); let callback () = data in let test_result = [%test_result: int] in test_caller ~callback ~test_result (fun t f -> Hashtbl.find_or_add t key ~default:f))) ;; let change = Hashtbl.change let update = Hashtbl.update let update_and_return = Hashtbl.update_and_return let%test_unit "change" = for_each "key" sexp_of_key sample_keys (fun key -> for_each "f result" [%sexp_of: data option] (option sample_data) (fun opt -> test_mutate (fun t -> Hashtbl.change t key ~f:(fun _ -> opt)); let callback _ = opt in let test_result = [%test_result: int option] in test_caller ~callback ~test_result (fun t f -> Hashtbl.change t key ~f; Hashtbl.find t key))) ;; let%test_unit "update" = for_each "key" sexp_of_key sample_keys (fun key -> for_each "f result" [%sexp_of: data] sample_data (fun data -> test_mutate (fun t -> Hashtbl.update t key ~f:(fun _ -> data)); let callback _ = data in let test_result = [%test_result: int option] in test_caller ~callback ~test_result (fun t f -> Hashtbl.update t key ~f; Hashtbl.find t key))) ;; let%test_unit "update_and_return" = for_each "key" sexp_of_key sample_keys (fun key -> for_each "f result" [%sexp_of: data] sample_data (fun data -> test_mutate (fun t -> ignore (Hashtbl.update_and_return t key ~f:(fun _ -> data) : _)); let callback _ = data in let test_result = [%test_result: int option] in test_caller ~callback ~test_result (fun t f -> Some (Hashtbl.update_and_return t key ~f)))) ;; let merge_into = Hashtbl.merge_into let%test_unit "merge_into" = for_each "f result" [%sexp_of: data option] (option sample_data) (fun opt -> let action : _ Hashtbl_intf.Merge_into_action.t = match opt with | None -> Remove | Some x -> Set_to x in test_mutate_2ts (fun dst src -> Hashtbl.merge_into ~dst ~src ~f:(fun ~key:_ _ _ -> action)); let callback _ = action in let test_result = [%test_result: (int * int) list] in test_caller_2ts ~callback ~test_result (fun src dst f -> Hashtbl.merge_into ~dst ~src ~f:(fun ~key a b -> f (key, a, b)); Hashtbl.to_alist dst)) ;; let filter_inplace = Hashtbl.filter_inplace let%test_unit "filter_inplace" = for_each "f result" [%sexp_of: bool] bools (fun bool -> test_mutate (fun t -> Hashtbl.filter_inplace t ~f:(fun _ -> bool)); let callback _ = bool in let test_result = [%test_result: (int * int) list] in test_caller ~callback ~test_result (fun t f -> Hashtbl.filter_inplace t ~f; Hashtbl.to_alist t)) ;; let filteri_inplace = Hashtbl.filteri_inplace let%test_unit "filteri_inplace" = for_each "f result" [%sexp_of: bool] bools (fun bool -> test_mutate (fun t -> Hashtbl.filteri_inplace t ~f:(fun ~key:_ ~data:_ -> bool)); let callback _ = bool in let test_result = [%test_result: (int * int) list] in test_caller ~callback ~test_result (fun t f -> Hashtbl.filteri_inplace t ~f:(fun ~key ~data -> f (key, data)); Hashtbl.to_alist t)) ;; let filter_keys_inplace = Hashtbl.filter_keys_inplace let%test_unit "filter_keys_inplace" = for_each "f result" [%sexp_of: bool] bools (fun bool -> test_mutate (fun t -> Hashtbl.filter_keys_inplace t ~f:(fun _ -> bool)); let callback _ = bool in let test_result = [%test_result: (int * int) list] in test_caller ~callback ~test_result (fun t f -> Hashtbl.filter_keys_inplace t ~f; Hashtbl.to_alist t)) ;; let map_inplace = Hashtbl.map_inplace let%test_unit "map_inplace" = for_each "f result" [%sexp_of: int] sample_data (fun data -> test_mutate (fun t -> Hashtbl.map_inplace t ~f:(fun _ -> data)); let callback _ = data in let test_result = [%test_result: (int * int) list] in test_caller ~callback ~test_result (fun t f -> Hashtbl.map_inplace t ~f; Hashtbl.to_alist t)) ;; let mapi_inplace = Hashtbl.mapi_inplace let%test_unit "mapi_inplace" = for_each "f result" [%sexp_of: int] sample_data (fun data -> test_mutate (fun t -> Hashtbl.mapi_inplace t ~f:(fun ~key:_ ~data:_ -> data)); let callback _ = data in let test_result = [%test_result: (int * int) list] in test_caller ~callback ~test_result (fun t f -> Hashtbl.mapi_inplace t ~f:(fun ~key ~data -> f (key, data)); Hashtbl.to_alist t)) ;; let filter_map_inplace = Hashtbl.filter_map_inplace let%test_unit "filter_map_inplace" = for_each "f result" [%sexp_of: int option] (option sample_data) (fun opt -> test_mutate (fun t -> Hashtbl.filter_map_inplace t ~f:(fun _ -> opt)); let callback _ = opt in let test_result = [%test_result: (int * int) list] in test_caller ~callback ~test_result (fun t f -> Hashtbl.filter_map_inplace t ~f; Hashtbl.to_alist t)) ;; let filter_mapi_inplace = Hashtbl.filter_mapi_inplace let%test_unit "filter_mapi_inplace" = for_each "f result" [%sexp_of: int option] (option sample_data) (fun opt -> test_mutate (fun t -> Hashtbl.filter_mapi_inplace t ~f:(fun ~key:_ ~data:_ -> opt)); let callback _ = opt in let test_result = [%test_result: (int * int) list] in test_caller ~callback ~test_result (fun t f -> Hashtbl.filter_mapi_inplace t ~f:(fun ~key ~data -> f (key, data)); Hashtbl.to_alist t)) ;; (* functions that mutate *) let set = Hashtbl.set let%test_unit "set" = for_each "key" sexp_of_key sample_keys (fun key -> for_each "data" sexp_of_data sample_data (fun data -> test_mutate (fun t -> Hashtbl.set t ~key ~data))) ;; let add = Hashtbl.add let add_exn = Hashtbl.add_exn let%test_unit "add" = for_each "key" sexp_of_key sample_keys (fun key -> for_each "data" sexp_of_data sample_data (fun data -> test_mutate (fun t -> Hashtbl.add t ~key ~data |> (ignore : [ `Ok | `Duplicate ] -> unit)))) ;; let remove = Hashtbl.remove let%test_unit "remove" = for_each "key" sexp_of_key sample_keys (fun key -> test_mutate (fun t -> Hashtbl.remove t key)) ;; let find_and_remove = Hashtbl.find_and_remove let%test_unit "find_and_remove" = for_each "key" sexp_of_key sample_keys (fun key -> test_mutate (fun t -> Hashtbl.find_and_remove t key |> (ignore : int option -> unit))) ;; let incr = Hashtbl.incr let%test_unit "incr" = for_each "key" sexp_of_key sample_keys (fun key -> test_mutate (fun t -> Hashtbl.incr t key)) ;; let decr = Hashtbl.decr let%test_unit "decr" = for_each "key" sexp_of_key sample_keys (fun key -> test_mutate (fun t -> Hashtbl.decr t key)) ;; let add_multi = Hashtbl.add_multi let%test_unit "add_multi" = for_each "key" sexp_of_key sample_keys (fun key -> for_each "data" sexp_of_data sample_data (fun data -> test_mutate_multi (fun t -> Hashtbl.add_multi t ~key ~data))) ;; let remove_multi = Hashtbl.remove_multi let%test_unit "remove_multi" = for_each "key" sexp_of_key sample_keys (fun key -> test_mutate_multi (fun t -> Hashtbl.remove_multi t key)) ;; let clear = Hashtbl.clear let%test_unit "clear" = test_mutate (fun t -> Hashtbl.clear t) (* functions that take callbacks *) let find_and_call = Hashtbl.find_and_call let findi_and_call = Hashtbl.findi_and_call let find_and_call1 = Hashtbl.find_and_call1 let findi_and_call1 = Hashtbl.findi_and_call1 let find_and_call2 = Hashtbl.find_and_call2 let findi_and_call2 = Hashtbl.findi_and_call2 let%test_unit "find_and_call" = for_each "key" sexp_of_key sample_keys (fun key -> let found x = `Found x in let not_found x = `Not_found x in let test_result = [%test_result: [ `Found of int | `Not_found of int ]] in test_caller_2fs found not_found ~test_result (fun t if_found if_not_found -> Hashtbl.find_and_call t key ~if_found ~if_not_found)) ;; let fold = Hashtbl.fold let%test_unit "fold" = let callback (a, b, c) = (a, b) :: c in let test_result = [%test_result: (int * int) list] in test_caller ~callback ~test_result (fun t f -> Hashtbl.fold t ~init:[] ~f:(fun ~key ~data acc -> f (key, data, acc))) ;; let iter = Hashtbl.iter let%test_unit "iter" = let callback a = a in let test_result = [%test_result: int Queue.t] in test_caller ~callback ~test_result (fun t f -> let queue = Queue.create () in Hashtbl.iter t ~f:(fun data -> Queue.enqueue queue (f data)); queue) ;; let iter_keys = Hashtbl.iter_keys let%test_unit "iter_keys" = let callback a = a in let test_result = [%test_result: int Queue.t] in test_caller ~callback ~test_result (fun t f -> let queue = Queue.create () in Hashtbl.iter_keys t ~f:(fun key -> Queue.enqueue queue (f key)); queue) ;; let iteri = Hashtbl.iteri let%test_unit "iteri" = let callback (a, b) = a, b in let test_result = [%test_result: (int * int) Queue.t] in test_caller ~callback ~test_result (fun t f -> let queue = Queue.create () in Hashtbl.iteri t ~f:(fun ~key ~data -> Queue.enqueue queue (f (key, data))); queue) ;; let map = Hashtbl.map let%test_unit "map" = let callback a = a in let test_result = [%test_result: (int * int) list] in test_caller ~callback ~test_result (fun t f -> Hashtbl.map t ~f |> Hashtbl.to_alist) ;; let mapi = Hashtbl.mapi let%test_unit "mapi" = let callback (a, b) = a, b in let test_result = [%test_result: (int * (int * int)) list] in test_caller ~callback ~test_result (fun t f -> Hashtbl.mapi t ~f:(fun ~key ~data -> f (key, data)) |> Hashtbl.to_alist) ;; let filter_keys = Hashtbl.filter_keys let%test_unit "filter_keys" = for_each "f result" [%sexp_of: bool] bools (fun bool -> let callback _ = bool in let test_result = [%test_result: (int * int) list] in test_caller ~callback ~test_result (fun t f -> Hashtbl.filter_keys t ~f |> Hashtbl.to_alist)) ;; let filter = Hashtbl.filter let%test_unit "filter" = for_each "f result" [%sexp_of: bool] bools (fun bool -> let callback _ = bool in let test_result = [%test_result: (int * int) list] in test_caller ~callback ~test_result (fun t f -> Hashtbl.filter t ~f |> Hashtbl.to_alist)) ;; let filteri = Hashtbl.filteri let%test_unit "filteri" = for_each "f result" [%sexp_of: bool] bools (fun bool -> let callback _ = bool in let test_result = [%test_result: (int * int) list] in test_caller ~callback ~test_result (fun t f -> Hashtbl.filteri t ~f:(fun ~key ~data -> f (key, data)) |> Hashtbl.to_alist)) ;; let filter_map = Hashtbl.filter_map let%test_unit "filter_map" = for_each "f result" [%sexp_of: data option] (option sample_data) (fun opt -> let callback _ = opt in let test_result = [%test_result: (int * int) list] in test_caller ~callback ~test_result (fun t f -> Hashtbl.filter_map t ~f |> Hashtbl.to_alist)) ;; let filter_mapi = Hashtbl.filter_mapi let%test_unit "filter_mapi" = for_each "f result" [%sexp_of: data option] (option sample_data) (fun opt -> let callback _ = opt in let test_result = [%test_result: (int * int) list] in test_caller ~callback ~test_result (fun t f -> Hashtbl.filter_mapi t ~f:(fun ~key ~data -> f (key, data)) |> Hashtbl.to_alist)) ;; let partition_tf = Hashtbl.partition_tf let%test_unit "partition_tf" = for_each "f result" [%sexp_of: bool] bools (fun bool -> let callback _ = bool in let test_result = [%test_result: (int * int) list * (int * int) list] in test_caller ~callback ~test_result (fun t f -> let t1, t2 = Hashtbl.partition_tf t ~f in Hashtbl.to_alist t1, Hashtbl.to_alist t2)) ;; let partitioni_tf = Hashtbl.partitioni_tf let%test_unit "partitioni_tf" = for_each "f result" [%sexp_of: bool] bools (fun bool -> let callback _ = bool in let test_result = [%test_result: (int * int) list * (int * int) list] in test_caller ~callback ~test_result (fun t f -> let t1, t2 = Hashtbl.partitioni_tf t ~f:(fun ~key ~data -> f (key, data)) in Hashtbl.to_alist t1, Hashtbl.to_alist t2)) ;; let partition_map = Hashtbl.partition_map let%test_unit "partition_map" = for_each "f result" [%sexp_of: (data, data) Either.t] (first_or_second sample_data) (fun x -> let callback _ = x in let test_result = [%test_result: (int * int) list * (int * int) list] in test_caller ~callback ~test_result (fun t f -> let t1, t2 = Hashtbl.partition_map t ~f in Hashtbl.to_alist t1, Hashtbl.to_alist t2)) ;; let partition_mapi = Hashtbl.partition_mapi let%test_unit "partition_mapi" = for_each "f result" [%sexp_of: (data, data) Either.t] (first_or_second sample_data) (fun x -> let callback _ = x in let test_result = [%test_result: (int * int) list * (int * int) list] in test_caller ~callback ~test_result (fun t f -> let t1, t2 = Hashtbl.partition_mapi t ~f:(fun ~key ~data -> f (key, data)) in Hashtbl.to_alist t1, Hashtbl.to_alist t2)) ;; let existsi = Hashtbl.existsi let%test_unit "existsi" = for_each "f result" [%sexp_of: bool] bools (fun bool -> let callback _ = bool in let test_result = [%test_result: bool] in test_caller ~callback ~test_result (fun t f -> Hashtbl.existsi t ~f:(fun ~key ~data -> f (key, data)))) ;; let exists = Hashtbl.exists let%test_unit "exists" = for_each "f result" [%sexp_of: bool] bools (fun bool -> let callback _ = bool in let test_result = [%test_result: bool] in test_caller ~callback ~test_result (fun t f -> Hashtbl.exists t ~f)) ;; let for_alli = Hashtbl.for_alli let%test_unit "for_alli" = for_each "f result" [%sexp_of: bool] bools (fun bool -> let callback _ = bool in let test_result = [%test_result: bool] in test_caller ~callback ~test_result (fun t f -> Hashtbl.for_alli t ~f:(fun ~key ~data -> f (key, data)))) ;; let for_all = Hashtbl.for_all let%test_unit "for_all" = for_each "f result" [%sexp_of: bool] bools (fun bool -> let callback _ = bool in let test_result = [%test_result: bool] in test_caller ~callback ~test_result (fun t f -> Hashtbl.for_all t ~f)) ;; let count = Hashtbl.count let%test_unit "count" = for_each "f result" [%sexp_of: bool] bools (fun bool -> let callback _ = bool in let test_result = [%test_result: int] in test_caller ~callback ~test_result (fun t f -> Hashtbl.count t ~f)) ;; let counti = Hashtbl.counti let%test_unit "counti" = for_each "f result" [%sexp_of: bool] bools (fun bool -> let callback _ = bool in let test_result = [%test_result: int] in test_caller ~callback ~test_result (fun t f -> Hashtbl.counti t ~f:(fun ~key ~data -> f (key, data)))) ;; let merge = Hashtbl.merge let%test_unit "merge" = let callback (key, data) = Some (key, data) in let test_result = [%test_result: (int * (int * (int, int) merge_data)) list] in test_caller_2ts ~callback ~test_result (fun t1 t2 f -> Hashtbl.merge t1 t2 ~f:(fun ~key data -> f (key, data)) |> Hashtbl.to_alist) ;; let equal = Hashtbl.equal let similar = Hashtbl.similar let%test_unit "equal" = for_each "f result" [%sexp_of: bool] bools (fun bool -> let callback _ = bool in let test_result = [%test_result: bool] in test_caller_2ts ~callback ~test_result (fun t1 t2 f -> Hashtbl.equal (fun a b -> f (a, b)) t1 t2)) ;; let sexp_of_t = Hashtbl.sexp_of_t let%test_unit "sexp_of_t" = let test_result = [%test_result: Sexp.t] in test_caller_2fs [%sexp_of: int] [%sexp_of: int] ~test_result (fun t sexp_of_key sexp_of_data -> Hashtbl.sexp_of_t sexp_of_key sexp_of_data t) ;; let invariant = Hashtbl.invariant let%test_unit "invariant" = let test_result = [%test_result: int Queue.t * int Queue.t] in test_caller_2fs ignore ignore ~test_result (fun t f_key f_data -> let keys = Queue.create () in let data = Queue.create () in Hashtbl.invariant (fun k -> Queue.enqueue keys k; f_key k) (fun d -> Queue.enqueue data d; f_data d) t; keys, data) ;; (* we do not test [validate], which should never raise externally, but which may go from pass to fail if the callback mutates, so it does not fit the normal criteria used by tests above *) let validate = Hashtbl.validate (* non-functions, and functions that neither mutate nor have callbacks *) let choose = Hashtbl.choose let choose_exn = Hashtbl.choose_exn let create = Hashtbl.create let create_mapped = Hashtbl.create_mapped let create_with_key = Hashtbl.create_with_key let create_with_key_exn = Hashtbl.create_with_key_exn let create_with_key_or_error = Hashtbl.create_with_key_or_error let group = Hashtbl.group let of_alist = Hashtbl.of_alist let of_alist_exn = Hashtbl.of_alist_exn let of_alist_multi = Hashtbl.of_alist_multi let of_alist_or_error = Hashtbl.of_alist_or_error let of_alist_report_all_dups = Hashtbl.of_alist_report_all_dups let sexp_of_key = Hashtbl.sexp_of_key let copy = Hashtbl.copy let keys = Hashtbl.keys let data = Hashtbl.data let length = Hashtbl.length let is_empty = Hashtbl.is_empty let mem = Hashtbl.mem let find = Hashtbl.find let find_exn = Hashtbl.find_exn let find_multi = Hashtbl.find_multi let to_alist = Hashtbl.to_alist end : Hashtbl_for_testing with type ('a, 'b) t := ('a, 'b) Hashtbl.t)) ;; end module Make (Hashtbl : Hashtbl_for_testing) = struct include Make_quickcheck_comparison_to_Map (Hashtbl) include Make_mutation_in_callbacks (Hashtbl) end let%test_module _ = (module Make (Hashtbl)) open! Hashtbl let%test_unit _ = (* [sexp_of_t] output is sorted by key *) let module Table = Make (struct type t = int [@@deriving bin_io, compare, sexp] let hash (x : t) = if x >= 0 then x else ~-x end) in let t = Table.create () in for key = -10 to 10 do Table.add_exn t ~key ~data:() done; List.iter [ [%sexp_of: unit Table.t]; [%sexp_of: (int, unit) t] ] ~f:(fun sexp_of_t -> let list = t |> [%sexp_of: t] |> [%of_sexp: (int * unit) list] in assert (List.is_sorted list ~compare:(fun (i1, _) (i2, _) -> i1 - i2))) ;; (* Make sure we follow the conventional type signature for [equal]. *) let%test_unit _ = ignore ([%equal: string Int.Table.t] : string Int.Table.t -> string Int.Table.t -> bool) ;; core-0.15.0/core/test/src/hashtbl_unit_tests.mli000066400000000000000000000001021420273305200216230ustar00rootroot00000000000000include Hashtbl_unit_tests_intf.Hashtbl_unit_tests (** @inline *) core-0.15.0/core/test/src/hashtbl_unit_tests_intf.ml000066400000000000000000000021241420273305200225000ustar00rootroot00000000000000open! Core (** A subset of [Hashtbl_intf.Hashtbl]. Leaves out definitions that we do not need to test and that some implementations may not provide. *) module type Hashtbl_for_testing = sig type ('a, 'b) t [@@deriving sexp_of] include Hashtbl_intf.Creators with type ('a, 'b) t := ('a, 'b) t with type 'a key := 'a with type ('a, 'b, 'c) create_options := ('a, 'b, 'c) Hashtbl_intf.create_options_with_first_class_module (* [Creators] gives us a different create than [Hashtbl_intf.Hashtbl] does *) val create : ?growth_allowed:bool -> ?size:int -> 'a Base.Hashtbl.Key.t -> ('a, 'b) t include Hashtbl_intf.Accessors with type ('a, 'b) t := ('a, 'b) t with type 'a key := 'a include Hashtbl_intf.Multi with type ('a, 'b) t := ('a, 'b) t with type 'a key := 'a val invariant : 'a Invariant.t -> 'b Invariant.t -> ('a, 'b) t Invariant.t end module type Hashtbl_unit_tests = sig module type Hashtbl_for_testing = Hashtbl_for_testing (** Wrap this in a [let%test_module] to ensure the tests get run *) module Make (Hashtbl : Hashtbl_for_testing) : sig end end core-0.15.0/core/test/src/import.ml000066400000000000000000000002661420273305200170710ustar00rootroot00000000000000open! Core include Expect_test_helpers_core module Test_container = Base_test_helpers.Test_container module Variant = Variantslib.Variant let () = Sexp.of_int_style := `Underscores core-0.15.0/core/test/src/info_unit_tests.ml000066400000000000000000000035171420273305200207750ustar00rootroot00000000000000open! Core let%test_unit "[create_s sexp] produces an info whose [sexp_of_t] is [sexp]" = let sexp = [%sexp "foo"] in assert (phys_equal [%sexp (Info.create_s sexp : Info.t)] sexp) ;; let%test_module "Info.Stable.V2" = (module Stable_unit_test.Make (struct include Info.Stable.V2 let equal t t' = compare t t' = 0 let tests = let here = { Source_code_position.pos_fname = "test.ml" ; pos_lnum = 1 ; pos_bol = 2 ; pos_cnum = 3 } in let info0 = Info.of_string "test" in let info1 = Info.create ~here "test" 0.5 Float.sexp_of_t in [ info0, "test", "\001\004test" ; ( info1 , "(test 0.5 test.ml:1:1)" , "\004\004test\000\0030.5\001\007test.ml\001\002\003" ) ; ( Info.tag info1 ~tag:"tag" , "(tag(test 0.5 test.ml:1:1))" , "\005\003tag\004\004test\000\0030.5\001\007test.ml\001\002\003" ) ; ( Info.tag_arg info1 "tag" 1.8 Float.sexp_of_t , "(tag 1.8(test 0.5 test.ml:1:1))" , "\006\003tag\000\0031.8\004\004test\000\0030.5\001\007test.ml\001\002\003" ) ; ( Info.of_list [ info0; info1 ] , "(test(test 0.5 test.ml:1:1))" , "\007\000\002\001\004test\004\004test\000\0030.5\001\007test.ml\001\002\003" ) ; ( Info.of_thunk (fun () -> failwith "Error") , "(Could_not_construct(Failure Error))" , "\000\001\002\000\007Failure\000\005Error" ) ; ( Info.of_exn (Failure "Error") , "(Failure Error)" , "\002\001\002\000\007Failure\000\005Error" ) ; ( Info.of_exn (Failure "Error") ~backtrace:(`This "backtrace") , "((Failure Error)backtrace)" , "\b\003\001\002\000\007Failure\000\005Error\tbacktrace" ) ] ;; end)) ;; core-0.15.0/core/test/src/info_unit_tests.mli000066400000000000000000000000331420273305200211340ustar00rootroot00000000000000(*_ Deliberately empty. *) core-0.15.0/core/test/src/linked_queue_tests.ml000066400000000000000000000011671420273305200214540ustar00rootroot00000000000000open Core open Linked_queue let%test_module _ = (module struct let m = let module M = struct type 'a u = 'a t [@@deriving bin_io] type t = int u [@@deriving bin_io] end in (module M : Binable.S with type t = M.t) ;; let test list = let t = of_list list in let bigstring = Binable.to_bigstring m t in let list' = to_list (Binable.of_bigstring m bigstring) in [%compare.equal: int list] list list' ;; let%test _ = test [] let%test _ = test [ 1 ] let%test _ = test [ 1; 2; 3 ] let%test _ = test (List.init 10_000 ~f:Fn.id) end) ;; core-0.15.0/core/test/src/linked_queue_tests.mli000066400000000000000000000000401420273305200216120ustar00rootroot00000000000000(*_ intentionally left blank *) core-0.15.0/core/test/src/memo_argument.mlt000066400000000000000000000036721420273305200206060ustar00rootroot00000000000000#verbose true open! Core let add a b = printf "Invoked add\n"; a + b ;; [%%expect {| val add : int -> int -> int = |}] (* Note that the [general] call is rather error prone; it's easy to call it in a way that looks benign, but actually does no useful work. Here is one innocent mistake, where the function in question is curried. (The type gives you a hint that something is funny, but it's equal to [int -> int -> int], so it can still be misused.) *) let add_memo_bad = Memo.general add [%%expect {| val add_memo_bad : (int, int -> int) Memo.fn = |}] (* If we call add_memo_bad a couple of times, we'll see that no memoization occurs. *) let _ = (add_memo_bad 1 2 : int) [%%expect {| - : int = 3 Invoked add |}] let _ = (add_memo_bad 1 2 : int) [%%expect {| - : int = 3 Invoked add |}] (* To properly memoize a multi-argument function, tuple up the arguments. *) let add_memo_tupled = let add (x, y) = add x y in Memo.general add ;; [%%expect {| val add_memo_tupled : (int * int, int) Memo.fn = |}] let add_memo x y = add_memo_tupled (x, y) [%%expect {| val add_memo : int -> int -> int = |}] let _ = (add_memo 3 4 : int) [%%expect {| - : int = 7 Invoked add |}] let _ = (add_memo 3 4 : int) [%%expect {| - : int = 7 |}] let _ = (add_memo 3 5 : int) [%%expect {| - : int = 8 Invoked add |}] (* But take care to avoid another mistake: supplying the argument when trying to memoize will cause the memoized function to be recreated on each call, so again no memoization occurs. *) let add_memo_tupled_bad (x, y) = let add (x, y) = add x y in Memo.general add (x, y) ;; [%%expect {| val add_memo_tupled_bad : int * int -> int = |}] let add_memo_bad x y = add_memo_tupled_bad (x, y) [%%expect {| val add_memo_bad : int -> int -> int = |}] let _ = (add_memo_bad 1 2 : int) [%%expect {| - : int = 3 Invoked add |}] let _ = (add_memo_bad 1 2 : int) [%%expect {| - : int = 3 Invoked add |}] core-0.15.0/core/test/src/or_error_unit_tests.ml000066400000000000000000000066071420273305200216760ustar00rootroot00000000000000open! Core open Or_error let%test_unit "[error_s] produces a value with the expected [sexp_of_t]" = let sexp = [%sexp "foo"] in match [%sexp (error_s sexp : _ t)] with | List [ Atom "Error"; sexp2 ] -> assert (phys_equal sexp sexp2) | _ -> assert false ;; let%test _ = Result.is_error (filter_ok_at_least_one []) let%test_unit _ = for i = 1 to 10 do assert ( [%compare.equal: unit list t] (filter_ok_at_least_one (List.init i ~f:(fun _ -> Ok ()))) (Ok (List.init i ~f:(fun _ -> ())))) done ;; let%test _ = let a = Error.of_string "a" and b = Error.of_string "b" in match filter_ok_at_least_one [ Ok 1; Error a; Ok 2; Error b ] with | Ok x -> [%equal: int list] x [ 1; 2 ] | Error _ -> false ;; let%test _ = let a = Error.of_string "a" and b = Error.of_string "b" in match filter_ok_at_least_one [ Error a; Error b ] with | Ok _ -> false | Error e -> String.( = ) (Error.to_string_hum e) (Error.to_string_hum (Error.of_list [ a; b ])) ;; let%test _ = Result.is_error (find_ok []) let%test _ = let a = Error.of_string "a" and b = Error.of_string "b" in match find_ok [ Error a; Ok 1; Error b ] with | Ok x -> x = 1 | Error _ -> false ;; let%test _ = let a = Error.of_string "a" and b = Error.of_string "b" in match find_ok [ Error a; Error b; Ok 2; Ok 3 ] with | Ok x -> x = 2 | Error _ -> false ;; let%test _ = let a = Error.of_string "a" and b = Error.of_string "b" in match find_ok [ Error a; Error b ] with | Ok _ -> false | Error e -> String.( = ) (Error.to_string_hum e) (Error.to_string_hum (Error.of_list [ a; b ])) ;; let%test _ = Result.is_error (find_map_ok ~f:(fun _ -> assert false) []) let%test _ = try let (_ : _ t) = find_map_ok ~f:(fun _ -> raise (Failure "abc")) [ 1 ] in false with | Failure "abc" -> true | _ -> false ;; let%test _ = let a = Error.of_string "a" and b = Error.of_string "b" in match find_map_ok ~f:Fn.id [ Error a; Ok 1; Error b ] with | Ok x -> x = 1 | Error _ -> false ;; let%test _ = let a = Error.of_string "a" and b = Error.of_string "b" in match find_map_ok ~f:Fn.id [ Error a; Error b; Ok 2; Ok 3 ] with | Ok x -> x = 2 | Error _ -> false ;; let%test _ = let a = Error.of_string "a" and b = Error.of_string "b" in match find_map_ok ~f:Fn.id [ Error a; Error b ] with | Ok _ -> false | Error e -> String.( = ) (Error.to_string_hum e) (Error.to_string_hum (Error.of_list [ a; b ])) ;; let%expect_test "[Expect_test_config]" = let open Let_syntax in let hearts = "hearts" in let%bind map = String.Map.of_alist_or_error [ hearts, 1; "diamonds", 2; "clubs", 3; "spades", 4 ] in print_s [%sexp (map : int String.Map.t)]; let%bind () = [%expect {| ((clubs 3) (diamonds 2) (hearts 1) (spades 4)) |}] in let%bind hearts_value = Map.find_or_error map hearts in print_s [%sexp (hearts_value : int)]; [%expect {| 1 |}] ;; module Expect_test_config = Expect_test_config_with_unit_expect let%expect_test "[Expect_test_config_with_unit_expect]" = let open Let_syntax in let hearts = "hearts" in let%bind map = String.Map.of_alist_or_error [ hearts, 1; "diamonds", 2; "clubs", 3; "spades", 4 ] in print_s [%sexp (map : int String.Map.t)]; [%expect {| ((clubs 3) (diamonds 2) (hearts 1) (spades 4)) |}]; let%bind hearts_value = Map.find_or_error map hearts in print_s [%sexp (hearts_value : int)]; [%expect {| 1 |}]; return () ;; core-0.15.0/core/test/src/or_error_unit_tests.mli000066400000000000000000000000551420273305200220360ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/quickcheck_unit_tests.ml000066400000000000000000000737771420273305200221730ustar00rootroot00000000000000open! Core open Poly open! Expect_test_helpers_core open! Quickcheck let%expect_test ("Quickcheck.Let_syntax" [@tags "64-bits-only"]) = let open Quickcheck.Let_syntax in let quickcheck_generator = [%map_open let triple = tuple3 Bool.quickcheck_generator Char.quickcheck_generator Float.quickcheck_generator and choice = variant2 String.quickcheck_generator Int.quickcheck_generator in [%sexp (triple : bool * char * float), (choice : [ `A of string | `B of int ])]] in Quickcheck.iter quickcheck_generator ~trials:10 ~f:print_s; [%expect {| ((false r -3.950862943457765E-284) (A "")) ((true R -3.3813765048980713) (B 15_568_213_580)) ((false C -624423578.84277344) (B 24_202_329_494_286)) ((false Y -1.0281888693571091) (A "")) ((true "\206" 1.1222031873105373E-250) (A cnU)) ((false 8 -1.43279037293961E-322) (B -115_610_275)) ((true B 14980.765357503886) (A "tq\210H7LQ")) ((false 4 -4.94065645841247E-324) (A "")) ((false X -287262765.50439453) (A "yP\000xv\134uV\197")) ((true q -8.6367588215150434E-19) (A A)) |}] ;; let%expect_test "ppx_quickcheck" = let module M = struct (* include some top-level type names like [int] and some module-exported type names like [Option.t] *) type t = | A | B of int list * Unit.t Option.t | C of { x : float } | D of int Map.M(String).t | E of Set.M(String).t [@@deriving compare, quickcheck, sexp_of] end in List.iter ~f:(fun predicate -> Quickcheck.test_can_generate M.quickcheck_generator ~f:predicate) [ (function | M.A -> true | _ -> false) ; (function | M.B _ -> true | _ -> false) ; (function | M.C _ -> true | _ -> false) ; (function | M.D _ -> true | _ -> false) ; (function | M.E _ -> true | _ -> false) ]; [%expect {| |}] ;; module Test (S : sig val default_seed : Quickcheck.seed end) : sig end = struct let int_middle_bits = match Word_size.word_size with | W64 -> Int.of_string "0x0000_ffff_ffff_0000" | W32 -> Int.of_string "0x00ff_ff00" ;; module Q = Quickcheck.Configure (struct include Quickcheck include S end) open Q module G = Quickcheck.Generator module O = Quickcheck.Observer let memo k = let hashable = Hashtbl_intf.Hashable.of_key k in let memoize f = Memo.general f ~hashable in fun quickcheck_generator -> G.map quickcheck_generator ~f:memoize ;; let%test_module "examples" = (module struct let example = "some silly string that is unlikely to be generated randomly" let example_occurs ~examples = let occurs = ref false in test String.quickcheck_generator ~examples ~f:(fun str -> if String.equal str example then occurs := true); !occurs ;; let%test_unit _ = [%test_result: bool] (example_occurs ~examples:[]) ~expect:false let%test_unit _ = [%test_result: bool] (example_occurs ~examples:[ example ]) ~expect:true ;; end) ;; let%test_module "duplicates" = (module struct let quickcheck_generator = G.map Int.quickcheck_generator ~f:ignore let sexp_of = Unit.sexp_of_t let compare = Unit.compare let%test_unit _ = assert ( Exn.does_raise (fun () -> test_distinct_values quickcheck_generator ~sexp_of ~compare ~trials:1_000 ~distinct_values:2)) ;; let%test_unit _ = test_distinct_values quickcheck_generator ~sexp_of ~compare ~trials:1_000 ~distinct_values:1 ;; end) ;; let%test_module "unit" = (module struct let sexp_of = Unit.sexp_of_t let quickcheck_generator = Unit.quickcheck_generator let can_generate f = test_can_generate quickcheck_generator ~sexp_of ~f let%test_unit _ = can_generate (fun () -> true) end) ;; let%test_module "bool" = (module struct let sexp_of = Bool.sexp_of_t let quickcheck_generator = Bool.quickcheck_generator let can_generate f = test_can_generate quickcheck_generator ~sexp_of ~f let%test_unit _ = can_generate (fun x -> x = true) let%test_unit _ = can_generate (fun x -> x = false) end) ;; let%test_module "int" = (module struct let sexp_of = Int.Hex.sexp_of_t let compare = Int.compare let quickcheck_generator = Int.quickcheck_generator let can_generate f = test_can_generate quickcheck_generator ~sexp_of ~f let%test_unit _ = test_distinct_values quickcheck_generator ~sexp_of ~compare ~trials:1_000 ~distinct_values:500 ;; let%test_unit _ = can_generate (fun x -> Int.popcount x < Int.num_bits / 2) let%test_unit _ = can_generate (fun x -> Int.popcount x > Int.num_bits / 2) let%test_unit _ = for i = 0 to Int.num_bits - 1 do can_generate (fun x -> x land (1 lsl i) = 0) done ;; let%test_unit _ = for i = 0 to Int.num_bits - 1 do can_generate (fun x -> x land (1 lsl i) <> 0) done ;; end) ;; let%test_module "float" = (module struct let bits_compare x y = Int64.compare (Int64.bits_of_float x) (Int64.bits_of_float y) let bits_equal x y = bits_compare x y = 0 let sexp_of = Float.sexp_of_t let compare = bits_compare let quickcheck_generator = Float.quickcheck_generator let can_generate f = test_can_generate quickcheck_generator ~sexp_of ~f let has_class x c = match Float.classify x, (c : Float.Class.t) with | Infinite, Infinite | Nan, Nan | Normal, Normal | Subnormal, Subnormal | Zero, Zero -> true | _ -> false ;; let%test_unit _ = test_distinct_values quickcheck_generator ~sexp_of ~compare ~trials:1_000 ~distinct_values:500 ;; let%test_unit _ = can_generate (fun x -> has_class x Infinite) let%test_unit _ = can_generate (fun x -> has_class x Nan) let%test_unit _ = can_generate (fun x -> has_class x Normal) let%test_unit _ = can_generate (fun x -> has_class x Subnormal) let%test_unit _ = can_generate (fun x -> has_class x Zero) let%test_unit _ = can_generate (fun x -> Float.( < ) x 0.) let%test_unit _ = can_generate (fun x -> Float.( > ) x 0.) let%test_unit _ = can_generate (fun x -> Float.( = ) x 0. && bits_equal x 0.) let%test_unit _ = can_generate (fun x -> Float.( = ) x 0. && not (bits_equal x 0.)) let%test_unit _ = can_generate (fun x -> Float.( = ) x Float.neg_infinity) let%test_unit _ = test_can_generate ~sexp_of Float.gen_without_nan ~f:(fun f -> Float.equal f Float.infinity) ;; let%test_unit _ = test_can_generate ~sexp_of Float.gen_without_nan ~f:(fun f -> Float.equal f Float.neg_infinity) ;; let%test_unit _ = test_can_generate ~sexp_of Float.gen_without_nan ~f:(fun f -> Float.is_finite f) ;; let%test_unit _ = test ~sexp_of Float.gen_without_nan ~f:(fun f -> assert (not (Float.is_nan f))) ;; let%test_unit _ = test_can_generate Float.gen_finite ~f:(fun f -> Float.equal (f +. 1.0) f) ;; let%test_unit _ = test_can_generate Float.gen_finite ~f:(fun f -> (not (Float.equal f 0.)) && Float.equal (f +. 1.0) 1.0) ;; let%test_unit _ = test ~sexp_of Float.gen_finite ~f:(fun f -> assert (not (Float.is_nan f))) ;; let%test_unit _ = test ~sexp_of Float.gen_finite ~f:(fun f -> assert (not (Float.is_inf f))) ;; let%test_unit _ = test ~sexp_of Float.gen_positive ~f:(fun f -> assert (f > 0.)) let%test_unit _ = test_can_generate ~sexp_of Float.gen_positive ~f:(fun x -> has_class x Subnormal) ;; let%test_unit _ = test_can_generate ~sexp_of Float.gen_positive ~f:(fun x -> has_class x Normal) ;; let%test_unit _ = test ~sexp_of Float.gen_negative ~f:(fun f -> assert (f < 0.)) let%test_unit _ = test_can_generate ~sexp_of Float.gen_negative ~f:(fun x -> has_class x Subnormal) ;; let%test_unit _ = test_can_generate ~sexp_of Float.gen_negative ~f:(fun x -> has_class x Normal) ;; let%test_unit _ = test ~sexp_of (Float.gen_uniform_excl (-1.) 1.) ~f:(fun f -> assert (f > -1. && f < 1.)) ;; let%test_unit _ = test_can_generate ~sexp_of (Float.gen_uniform_excl (-1.) 1.) ~f:(fun f -> f < 0.) ;; let%test_unit _ = test_can_generate ~sexp_of (Float.gen_uniform_excl (-1.) 1.) ~f:(fun f -> f > 0.) ;; end) ;; let%test_module "string" = (module struct let sexp_of = String.sexp_of_t let compare = String.compare let quickcheck_generator = String.quickcheck_generator let can_generate f = test_can_generate quickcheck_generator ~sexp_of ~f let%test_unit _ = test_distinct_values quickcheck_generator ~sexp_of ~compare ~trials:1_000 ~distinct_values:500 ;; let%test_unit _ = can_generate (fun x -> String.length x = 0) let%test_unit _ = can_generate (fun x -> String.length x = 1) let%test_unit _ = can_generate (fun x -> String.length x = 2) let%test_unit _ = can_generate (fun x -> String.length x > 2) let%test_unit _ = can_generate (fun x -> String.uppercase x <> x) let%test_unit _ = can_generate (fun x -> String.lowercase x <> x) let%test_unit _ = can_generate (fun x -> match Int.of_string x with | _ -> true | exception _ -> false) ;; end) ;; let%test_module "char" = (module struct let sexp_of = Char.sexp_of_t let quickcheck_generator = Char.quickcheck_generator let can_generate f = test_can_generate quickcheck_generator ~sexp_of ~f let%test_unit _ = can_generate Char.is_digit let%test_unit _ = can_generate Char.is_lowercase let%test_unit _ = can_generate Char.is_uppercase let%test_unit _ = can_generate Char.is_print let%test_unit _ = can_generate Char.is_whitespace let%test_unit _ = can_generate (fun c -> (not (Char.is_digit c)) && (not (Char.is_lowercase c)) && (not (Char.is_uppercase c)) && (not (Char.is_print c)) && not (Char.is_whitespace c)) ;; let test_coverage quickcheck_generator ~f = let all = Char.Set.of_list Char.all in (* repeat to make sure changing random seed doesn't affect the outcome *) for _ = 1 to 10 do let expect = Set.filter all ~f in let actual = let set = ref Char.Set.empty in with_return (fun return -> Sequence.iter (Quickcheck.random_sequence quickcheck_generator) ~f:(fun t -> set := Set.add !set t; if Set.equal !set expect then return.return ())); !set in [%test_result: Char.Set.t] actual ~expect done ;; (* exported generators: *) let%test_unit "default" = test_coverage Char.quickcheck_generator ~f:(fun _ -> true) let%test_unit "digit" = test_coverage Char.gen_digit ~f:Char.is_digit let%test_unit "lowercase" = test_coverage Char.gen_lowercase ~f:Char.is_lowercase let%test_unit "uppercase" = test_coverage Char.gen_uppercase ~f:Char.is_uppercase let%test_unit "alpha" = test_coverage Char.gen_alpha ~f:Char.is_alpha let%test_unit "alphanum" = test_coverage Char.gen_alphanum ~f:Char.is_alphanum let%test_unit "print" = test_coverage Char.gen_print ~f:Char.is_print let%test_unit "whitespace" = test_coverage Char.gen_whitespace ~f:Char.is_whitespace end) ;; let%test_module "tuple2" = (module struct let sexp_of = [%sexp_of: char * char] let compare = [%compare: char * char] let quickcheck_generator = G.tuple2 Char.quickcheck_generator Char.quickcheck_generator ;; let can_generate ?trials f = test_can_generate quickcheck_generator ~sexp_of ~f ?trials ;; let%test_unit _ = test_distinct_values quickcheck_generator ~sexp_of ~compare ~trials:1_000 ~distinct_values:500 ;; let%test_unit _ = can_generate (fun (x, y) -> Char.( = ) x y) ~trials:2_000 let%test_unit _ = can_generate (fun (x, y) -> Char.( < ) x y) let%test_unit _ = can_generate (fun (x, y) -> Char.( > ) x y) end) ;; let%test_module "option" = (module struct let sexp_of = [%sexp_of: Int.Hex.t option] let compare = [%compare: int option] let quickcheck_generator = Option.quickcheck_generator Int.quickcheck_generator let can_generate f = test_can_generate quickcheck_generator ~sexp_of ~f let%test_unit _ = test_distinct_values (G.filter quickcheck_generator ~f:Option.is_some) ~sexp_of ~compare ~trials:1_000 ~distinct_values:500 ;; let%test_unit _ = can_generate Option.is_none let%test_unit _ = can_generate Option.is_some end) ;; let%test_module "function" = (module struct module F = Fn_for_testing.Make (Int) (Int) (struct let examples = [ Int.min_value ; Int.bit_not int_middle_bits ; -2 ; -1 ; 0 ; 1 ; 2 ; int_middle_bits ; Int.max_value ] ;; end) let sexp_of = [%sexp_of: F.t] let compare = [%compare: F.t] let quickcheck_generator = (* memoizing these functions makes [test_no_duplicates] run much faster *) G.(fn Int.quickcheck_observer Int.quickcheck_generator) |> memo (module Int) ;; let can_generate f = test_can_generate quickcheck_generator ~sexp_of ~f let%test_unit _ = test_distinct_values quickcheck_generator ~sexp_of ~compare ~trials:1_000 ~distinct_values:500 ;; let%test_unit _ = can_generate (fun f -> f 0 < f (-1)) let%test_unit _ = can_generate (fun f -> f 0 > f (-1)) let%test_unit _ = can_generate (fun f -> f 1 < f 0) let%test_unit _ = can_generate (fun f -> f 1 > f 0) let%test_unit _ = can_generate (fun f -> f 2 < f 1) let%test_unit _ = can_generate (fun f -> f 2 > f 1) let%test_unit _ = can_generate (fun f -> f (-1) <> f 0 && f 0 <> f 1 && f 1 <> f (-1)) ;; let%test_unit _ = can_generate (fun f -> f int_middle_bits <> f 0) end) ;; let%test_module "higher-order function" = (module struct (* [First_order] defines a flat representation for [int -> int] functions that has [sexp_of] and [compare], but which can map to functions and use [Observer.fn] on below. *) module First_order = struct type t = | Id | Neg | Abs | Succ | Pred [@@deriving sexp_of, compare, enumerate, hash] let apply = function | Id -> Fn.id | Neg -> Int.neg | Abs -> Int.abs | Succ -> Int.succ | Pred -> Int.pred ;; end module Higher_order = Fn_for_testing.Make (First_order) (Int) (struct let examples = First_order.all end) let sexp_of = [%sexp_of: Higher_order.t] let compare = [%compare: Higher_order.t] let quickcheck_generator = (* memoizing these functions makes [test_no_duplicates] run much faster *) G.( fn O.( fn Int.quickcheck_generator Int.quickcheck_observer |> unmap ~f:First_order.apply) Int.quickcheck_generator) |> memo (module First_order) ;; let can_generate f = test_can_generate quickcheck_generator ~f ~sexp_of let%test_unit _ = test_distinct_values quickcheck_generator ~sexp_of ~compare ~trials:1_000 ~distinct_values:500 ;; let%test_unit _ = can_generate (fun f -> f Succ = f Pred) let%test_unit _ = can_generate (fun f -> f Succ > f Pred) let%test_unit _ = can_generate (fun f -> f Succ < f Pred) let%test_unit _ = can_generate (fun f -> f Neg <> f Abs) let%test_unit _ = can_generate (fun f -> f Neg <> f Id) let%test_unit _ = can_generate (fun f -> f Abs <> f Id) let%test_unit _ = can_generate (fun f -> let x = f Id in let y = f Neg in let z = f Abs in x <> y && y <> z && z <> x) ;; end) ;; let%test_module "list" = (module struct let sexp_of = [%sexp_of: char list] let compare = [%compare: char list] let quickcheck_generator = List.quickcheck_generator Char.quickcheck_generator let can_generate f = test_can_generate quickcheck_generator ~sexp_of ~f let%test_unit _ = test_distinct_values quickcheck_generator ~sexp_of ~compare ~trials:1_000 ~distinct_values:500 ;; let%test_unit _ = can_generate List.is_empty let%test_unit _ = can_generate (function | [ _ ] -> true | _ -> false) ;; let%test_unit _ = can_generate (function | [ x; y ] -> Char.( < ) x y | _ -> false) ;; let%test_unit _ = can_generate (function | [ x; y ] -> Char.( > ) x y | _ -> false) ;; let%test_unit _ = can_generate (fun list -> List.length list > 2 && List.is_sorted_strictly list ~compare:Char.compare) ;; let%test_unit _ = can_generate (fun list -> List.length list > 2 && List.is_sorted_strictly (List.rev list) ~compare:Char.compare) ;; end) ;; let%test_module "sexp" = (module struct let sexp_of = [%sexp_of: Sexp.t] let compare = [%compare: Sexp.t] let quickcheck_generator = Sexp.quickcheck_generator let can_generate f = test_can_generate quickcheck_generator ~sexp_of ~f let%test_unit _ = test_distinct_values quickcheck_generator ~sexp_of ~compare ~trials:1_000 ~distinct_values:500 ;; let%test_unit _ = can_generate (function | Sexp.Atom _ -> true | _ -> false) ;; let%test_unit _ = can_generate (function | Sexp.List _ -> true | _ -> false) ;; let%test_unit _ = can_generate (function | Sexp.Atom "" -> true | _ -> false) ;; let%test_unit _ = can_generate (function | Sexp.List [] -> true | _ -> false) ;; let%test_unit _ = can_generate (function | Sexp.List [ _ ] -> true | _ -> false) ;; let%test_unit _ = can_generate (function | Sexp.List [ _; _ ] -> true | _ -> false) ;; let%test_unit _ = can_generate (function | Sexp.List [ _; _; _ ] -> true | _ -> false) ;; let%test_unit _ = can_generate (function | Sexp.Atom _ -> false | Sexp.List list -> let is_atom = function | Sexp.Atom _ -> true | Sexp.List _ -> false in List.length list >= 2 && List.for_all list ~f:is_atom) ;; end) ;; let%test_module "function on recursive data" = (module struct module Bool_list = struct type t = bool list [@@deriving sexp_of, compare, hash] end module F = Fn_for_testing.Make (Bool_list) (Char) (struct let examples = [ [] ; [ true ] ; [ false ] ; [ true; true ] ; [ true; false ] ; [ false; true ] ; [ false; false ] ; [ true; true; true ] ; [ true; true; false ] ; [ true; true; true; true ] ; [ true; true; true; false ] ] ;; end) let sexp_of = [%sexp_of: F.t] let compare = [%compare: F.t] let quickcheck_generator = (* memoizing these functions makes [test_no_duplicates] run much faster *) G.( fn (List.quickcheck_observer Bool.quickcheck_observer) Char.quickcheck_generator) |> memo (module Bool_list) ;; let can_generate f = test_can_generate quickcheck_generator ~sexp_of ~f let%test_unit _ = test_distinct_values quickcheck_generator ~sexp_of ~compare ~trials:1_000 ~distinct_values:500 ;; let%test_unit _ = can_generate (fun f -> f [] <> f [ true ]) let%test_unit _ = can_generate (fun f -> f [] <> f [ false ]) let%test_unit _ = can_generate (fun f -> f [ true ] <> f [ false ]) let%test_unit _ = can_generate (fun f -> f [ true; true ] <> f [ true; false ]) let%test_unit _ = can_generate (fun f -> f [ true; true; true ] <> f [ true; true; false ]) ;; end) ;; let%test_module "deep recursion" = (module struct let test length = test ~trials:1 (List.gen_with_length length Char.quickcheck_generator) ~f:(fun input -> [%test_result: int] (List.length input) ~expect:length) ;; let%test_unit "used to cause a stack overflow" = test 100_000 end) ;; end let%test_module _ = (module Test (Quickcheck)) let%test_module _ = (module Test (struct let default_seed = `Deterministic "foo" end)) ;; let%test_module _ = (module Test (struct let default_seed = `Deterministic "bar" end)) ;; (* let%test_module _ = (module Test (struct let default_seed = `Deterministic "baz" end)) * let%test_module _ = (module Test (struct let default_seed = `Deterministic "quux" end)) * let%test_module _ = (module Test (struct let default_seed = `Deterministic "zanzibar" end)) * let%test_module _ = (module Test (struct let default_seed = `Deterministic "lorem ipsum" end)) *) module _ = struct open Shrinker module Test_data = struct let singleton equal min = create (fun v -> if equal min v then Sequence.empty else Sequence.singleton min) ;; let%test_module "singleton" = (module struct let t = singleton Poly.( = ) 42 let%test_unit "singleton produces values" = let shrunk = shrink t 2 |> Sequence.to_list in let expect = [ 42 ] in [%test_result: int list] ~expect shrunk ;; let%test_unit "singleton doesn't produce the input" = let shrunk = shrink t 42 |> Sequence.to_list in let expect = [] in [%test_result: int list] ~expect shrunk ;; end) ;; let t0 = singleton Poly.( = ) 0 let t1 = singleton Poly.( = ) 1 let t2 = singleton Poly.( = ) 2 let t3 = singleton Poly.( = ) 3 let t4 = singleton Poly.( = ) 4 let t5 = singleton Poly.( = ) 5 end let%test_module "tuple shrinkers" = (module struct open Test_data let%test_unit "tuple2 shrinker" = let sort = List.sort ~compare:[%compare: int * int] in let expect = [ 0, 5; 5, 1 ] |> sort in let results = shrink (tuple2 t0 t1) (5, 5) |> Sequence.to_list |> sort in [%test_result: (int * int) list] ~expect results ;; let%test_unit "tuple3 shrinker" = let sort = List.sort ~compare:[%compare: int * int * int] in let expect = [ 0, 5, 5; 5, 1, 5; 5, 5, 2 ] |> sort in let results = shrink (tuple3 t0 t1 t2) (5, 5, 5) |> Sequence.to_list |> sort in [%test_result: (int * int * int) list] results ~expect ;; let%test_unit "tuple4 shrinker" = let sort = List.sort ~compare:[%compare: int * int * int * int] in let expect = [ 0, 5, 5, 5; 5, 1, 5, 5; 5, 5, 2, 5; 5, 5, 5, 3 ] |> sort in let results = shrink (tuple4 t0 t1 t2 t3) (5, 5, 5, 5) |> Sequence.to_list |> sort in [%test_result: (int * int * int * int) list] results ~expect ;; let%test_unit "tuple5 shrinker" = let sort = List.sort ~compare:[%compare: int * int * int * int * int] in let expect = [ 0, 5, 5, 5, 5; 5, 1, 5, 5, 5; 5, 5, 2, 5, 5; 5, 5, 5, 3, 5; 5, 5, 5, 5, 4 ] |> sort in let results = shrink (tuple5 t0 t1 t2 t3 t4) (5, 5, 5, 5, 5) |> Sequence.to_list |> sort in [%test_result: (int * int * int * int * int) list] results ~expect ;; let%test_unit "tuple6 shrinker" = let sort = List.sort ~compare:[%compare: int * int * int * int * int * int] in let expect = [ 0, 9, 9, 9, 9, 9 ; 9, 1, 9, 9, 9, 9 ; 9, 9, 2, 9, 9, 9 ; 9, 9, 9, 3, 9, 9 ; 9, 9, 9, 9, 4, 9 ; 9, 9, 9, 9, 9, 5 ] |> sort in let results = shrink (tuple6 t0 t1 t2 t3 t4 t5) (9, 9, 9, 9, 9, 9) |> Sequence.to_list |> sort in [%test_result: (int * int * int * int * int * int) list] results ~expect ;; end) ;; let%test_module "variant shrinkers" = (module struct open Test_data type var2 = [ `A of int | `B of int ] [@@deriving sexp, compare] type var3 = [ `A of int | `B of int | `C of int ] [@@deriving sexp, compare] type var4 = [ `A of int | `B of int | `C of int | `D of int ] [@@deriving sexp, compare] type var5 = [ `A of int | `B of int | `C of int | `D of int | `E of int ] [@@deriving sexp, compare] type var6 = [ `A of int | `B of int | `C of int | `D of int | `E of int | `F of int ] [@@deriving sexp, compare] let%test_unit "variant2 shrinker" = let t = variant2 t0 t1 in let shrunk_a = shrink t (`A 1) |> Sequence.to_list in [%test_result: var2 list] ~expect:[ `A 0 ] shrunk_a; let shrunk_b = shrink t (`B 0) |> Sequence.to_list in [%test_result: var2 list] ~expect:[ `B 1 ] shrunk_b ;; let%test_unit "variant3 shrinker" = let t = variant3 t0 t1 t2 in let shrunk_a = shrink t (`A 1) |> Sequence.to_list in [%test_result: var3 list] ~expect:[ `A 0 ] shrunk_a; let shrunk_b = shrink t (`B 0) |> Sequence.to_list in [%test_result: var3 list] ~expect:[ `B 1 ] shrunk_b; let shrunk_c = shrink t (`C 1) |> Sequence.to_list in [%test_result: var3 list] ~expect:[ `C 2 ] shrunk_c ;; let%test_unit "variant4 shrinker" = let t = variant4 t0 t1 t2 t3 in let shrunk_a = shrink t (`A 1) |> Sequence.to_list in [%test_result: var4 list] ~expect:[ `A 0 ] shrunk_a; let shrunk_b = shrink t (`B 0) |> Sequence.to_list in [%test_result: var4 list] ~expect:[ `B 1 ] shrunk_b; let shrunk_c = shrink t (`C 1) |> Sequence.to_list in [%test_result: var4 list] ~expect:[ `C 2 ] shrunk_c; let shrunk_d = shrink t (`D 1) |> Sequence.to_list in [%test_result: var4 list] ~expect:[ `D 3 ] shrunk_d ;; let%test_unit "variant5 shrinker" = let t = variant5 t0 t1 t2 t3 t4 in let shrunk_a = shrink t (`A 1) |> Sequence.to_list in [%test_result: var5 list] ~expect:[ `A 0 ] shrunk_a; let shrunk_b = shrink t (`B 0) |> Sequence.to_list in [%test_result: var5 list] ~expect:[ `B 1 ] shrunk_b; let shrunk_c = shrink t (`C 1) |> Sequence.to_list in [%test_result: var5 list] ~expect:[ `C 2 ] shrunk_c; let shrunk_d = shrink t (`D 1) |> Sequence.to_list in [%test_result: var5 list] ~expect:[ `D 3 ] shrunk_d; let shrunk_e = shrink t (`E 1) |> Sequence.to_list in [%test_result: var5 list] ~expect:[ `E 4 ] shrunk_e ;; let%test_unit "variant6 shrinker" = let t = variant6 t0 t1 t2 t3 t4 t5 in let shrunk_a = shrink t (`A 1) |> Sequence.to_list in [%test_result: var6 list] ~expect:[ `A 0 ] shrunk_a; let shrunk_b = shrink t (`B 0) |> Sequence.to_list in [%test_result: var6 list] ~expect:[ `B 1 ] shrunk_b; let shrunk_c = shrink t (`C 1) |> Sequence.to_list in [%test_result: var6 list] ~expect:[ `C 2 ] shrunk_c; let shrunk_d = shrink t (`D 1) |> Sequence.to_list in [%test_result: var6 list] ~expect:[ `D 3 ] shrunk_d; let shrunk_e = shrink t (`E 1) |> Sequence.to_list in [%test_result: var6 list] ~expect:[ `E 4 ] shrunk_e; let shrunk_f = shrink t (`F 1) |> Sequence.to_list in [%test_result: var6 list] ~expect:[ `F 5 ] shrunk_f ;; end) ;; let%test_module "list shrinkers" = (module struct let t0 = Shrinker.create (fun v -> if Poly.( = ) 0 v then Sequence.empty else Sequence.singleton 0) ;; let test_list = [ 1; 2; 3 ] let expect = [ [ 2; 3 ]; [ 0; 2; 3 ]; [ 1; 3 ]; [ 1; 0; 3 ]; [ 1; 2 ]; [ 1; 2; 0 ] ] |> List.sort ~compare:[%compare: int list] ;; let%test_unit "shrinker produces expected outputs" = let shrunk = Shrinker.shrink (List.quickcheck_shrinker t0) test_list |> Sequence.to_list |> List.sort ~compare:[%compare: int list] in [%test_result: int list list] ~expect shrunk ;; let rec recursive_list = 1 :: 5 :: recursive_list let%test_unit "shrinker on infinite lists produces values" = let shrunk = Shrinker.shrink (List.quickcheck_shrinker t0) recursive_list in let result_length = Sequence.take shrunk 5 |> Sequence.to_list |> List.length in [%test_result: int] ~expect:5 result_length ;; end) ;; end core-0.15.0/core/test/src/quickcheck_unit_tests.mli000066400000000000000000000000551420273305200223170ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/sample_time_zone_file000066400000000000000000000066771420273305200215150ustar00rootroot00000000000000TZif2랦pŸºë` †p¡šÍ`¢eâp£ƒéà¤j®p¥5§`¦SÊð§‰`¨3¬ð¨þ¥àªŽðªÞ‡à«ópð¬¾ià­ÓRð®žK௳4ð°~-౜Qp²gJ`³|3p´G,`µ\p¶'`·;÷p¸ð`¹Ùp¹æÒ`»õð»Æ´`¼ä×ð½¯Ðà¾Ä¹ð¿²àÀ¤›ðÁo”à„}ðÃOvàÄd_ðÅ/XàÆM|pÇ:àÈ-^pÈøW`Ê @pÊØ9`ˈðpÒ#ôpÒ`ûàÓuäðÔ@ÝàÕUÆðÖ ¿à×5¨ðØ¡àÙŠðÙàƒàÚþ§pÛÀeàÜÞ‰pÝ©‚`Þ¾kp߉d`àžMpáiF`â~/pãI(`ä^påW.àæG-ðç7àè'ðéòàêñðêöÔàëæÓðìÖ¶àíƵðî¿Ó`ï¯ÒpðŸµ`ñ´pò—`óo–pô_y`õOxpö?[`÷/Zpø(wàùÐp?›bà@o²pA„`BO”pCda`D/vpEDC`Eó¨ðG-_àGÓŠðI AàI³lðJí#àKœ‰pLÖ@`M|kpN¶"`O\MpP–`QÐp?›bà@o²pA„`BO”pCda`D/vpEDC`Eó¨ðG-_àGÓŠðI AàI³lðJí#àKœ‰pLÖ@`M|kpN¶"`O\MpP–`Q [%sexp_of: int]) ~expect:(Atom "1_234"); r := `No_underscores; [%test_result: Sexp.t] (1234 |> [%sexp_of: int]) ~expect:(Atom "1234"); r := old ;; let%test_unit "print_s is provided by Core" = assert (phys_equal print_s Core.print_s) let%expect_test "print_s default" = print_s [%sexp (List.init 30 ~f:Fn.id : int list)]; [%expect {| (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29) |}] ;; let%expect_test "print_s mach" = print_s ~mach:() [%sexp (List.init 30 ~f:Fn.id : int list)]; [%expect {| (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29) |}] ;; core-0.15.0/core/test/src/std_unit_tests.mli000066400000000000000000000000551420273305200207770ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_am_running_inline_test.ml000066400000000000000000000005131420273305200233430ustar00rootroot00000000000000open! Core open! Expect_test_helpers_core let%expect_test "[am_running_inline_test]" = print_s [%message (am_running_inline_test : bool)]; [%expect {| (am_running_inline_test true) |}] ;; let%expect_test "[am_running_test]" = print_s [%message (am_running_test : bool)]; [%expect {| (am_running_test true) |}] ;; core-0.15.0/core/test/src/test_am_running_inline_test.mli000066400000000000000000000000551420273305200235150ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_am_running_inline_test.mlt000066400000000000000000000003311420273305200235250ustar00rootroot00000000000000open! Core let () = print_s [%message (am_running_inline_test : bool)] [%%expect {| (am_running_inline_test false) |}] let () = print_s [%message (am_running_test : bool)] [%%expect {| (am_running_test false) |}] core-0.15.0/core/test/src/test_bag.ml000066400000000000000000000003611420273305200173430ustar00rootroot00000000000000open! Core open! Import include Base_test_helpers.Test_container.Test_S1 (Bag) let%expect_test "[iter] does not allocate" = let t = Bag.create () in Bag.add_unit t (); require_no_allocation [%here] (fun () -> Bag.iter t ~f:ignore) ;; core-0.15.0/core/test/src/test_bag.mli000066400000000000000000000000551420273305200175140ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_bigstring.ml000066400000000000000000000213561420273305200206110ustar00rootroot00000000000000open! Core open Poly open! Bigstring let%test_module "concat" = (module struct let test ?sep list = [%test_result: t] (concat ?sep:(Option.map sep ~f:of_string) (List.map list ~f:of_string)) ~expect:(of_string (String.concat ?sep list)) ;; let%test_unit _ = test [] let%test_unit _ = test [ "" ] let%test_unit _ = test [ "foo" ] let%test_unit _ = test [ "foo"; "bar" ] let%test_unit _ = test [ "foo"; "bar"; "baz" ] let%test_unit _ = test ~sep:"," [] let%test_unit _ = test ~sep:"," [ "" ] let%test_unit _ = test ~sep:"," [ "foo" ] let%test_unit _ = test ~sep:"," [ "foo"; "bar" ] let%test_unit _ = test ~sep:"," [ "foo"; "bar"; "baz" ] let%test_unit _ = test ~sep:",.?" [ "Strings"; "of"; "different"; "lengths." ] end) ;; let%test_unit (_ [@tags "64-bits-only"]) = let check s = [%test_eq: int] ([%hash: t_frozen] (of_string s)) ([%hash: string] s) in List.iter ~f:check [ "" ; "a" ; "ab" ; "abc" ; "abcd" ; "string hashing for bigstrings is the same as for standard strings" ] ;; let%test_unit _ = let check s = [%test_eq: int] (Hash.run [%hash_fold: t_frozen] (of_string s)) (Hash.run [%hash_fold: string] s) in List.iter ~f:check [ "" ; "a" ; "ab" ; "abc" ; "abcd" ; "string hashing for bigstrings is the same as for standard strings" ] ;; let%test_module "comparison" = (module struct let sign n = if n < 0 then ~-1 else if n > 0 then 1 else 0 let check t1 t2 int = let bool = match int with | 0 -> true | _ -> false in [%test_result: int] (sign (compare t1 t2)) ~expect:int; [%test_result: bool] (equal t1 t2) ~expect:bool ;; let%test_unit _ = let t = of_string "cat" in check t t 0 ;; let%test_unit _ = check (of_string "cat") (of_string "cat") 0 let%test_unit _ = check (of_string "cat") (of_string "cab") 1 let%test_unit _ = check (of_string "cat") (of_string "caz") ~-1 let%test_unit _ = check (of_string "cat") (of_string "c") 1 let%test_unit _ = check (of_string "c") (of_string "cat") ~-1 let%test_unit _ = check (of_string "cat") (of_string "dog") ~-1 let%test_unit _ = check (of_string "dog") (of_string "cat") 1 end) ;; let%test_module _ = (module struct let make_t ~size input = (* We hardcode the size here to catch problems if [Bin_prot.Utils.size_header_length] ever changes. *) let t = create (String.length input + 8) in ignore (Bin_prot.Write.bin_write_int_64bit t ~pos:0 size : int); List.iteri (String.to_list input) ~f:(fun i c -> set t (i + 8) c); t ;; let test (type a) ~size input ?pos ?len reader sexp_of_a compare_a ~expect = let result = match read_bin_prot_verbose_errors (make_t ~size input) ?pos ?len reader with | `Ok (x, _bytes_read) -> `Ok x | `Not_enough_data -> `Not_enough_data | `Invalid_data _ -> `Invalid_data in [%test_result: [ `Ok of a | `Not_enough_data | `Invalid_data ]] result ~expect ;; let test_int ?pos ?len ~size input ~expect = test ~size input ?pos ?len Int.bin_reader_t Int.sexp_of_t Int.compare ~expect ;; let test_string ?pos ?len ~size input ~expect = test ~size input ?pos ?len String.bin_reader_t String.sexp_of_t String.compare ~expect ;; (* Keep in mind that the string bin-prot representation is itself prefixed with a length, so strings under the length-prefixed bin-prot protocol end up with two lengths at the front. *) let%test_unit _ = test_int ~size:1 "\042" ~expect:(`Ok 42) let%test_unit _ = test_int ~size:1 "\042suffix" ~expect:(`Ok 42) let%test_unit _ = test_string ~size:4 "\003foo" ~expect:(`Ok "foo") let%test_unit _ = test_string ~size:4 "\003foo" ~len:12 ~expect:(`Ok "foo") let%test "pos <> 0" = let t = "prefix" ^ to_string (make_t ~size:4 "\003foo") ^ "suffix" |> of_string in read_bin_prot_verbose_errors t ~pos:6 String.bin_reader_t = `Ok ("foo", 18) ;; let%test_unit "negative size" = test_string ~size:(-1) "\003foo" ~expect:`Invalid_data let%test_unit "wrong size" = test_string ~size:3 "\003foo" ~expect:`Invalid_data let%test_unit "bad bin-prot" = test_string ~size:4 "\007foo" ~expect:`Invalid_data let%test_unit "len too short" = test_string ~size:4 "\003foo" ~len:3 ~expect:`Not_enough_data ;; let%test "no header" = let t = of_string "\003foo" in read_bin_prot_verbose_errors t String.bin_reader_t = `Not_enough_data ;; end) ;; let%test_module _ = (module struct let test ?pos writer v ~expect = let size = writer.Bin_prot.Type_class.size v + 8 in let t = create size in ignore (write_bin_prot t ?pos writer v : int); [%test_result: string] (to_string t) ~expect ;; let%test_unit _ = test String.bin_writer_t "foo" ~expect:"\004\000\000\000\000\000\000\000\003foo" ;; let%test_unit _ = test Int.bin_writer_t 123 ~expect:"\001\000\000\000\000\000\000\000\123" ;; let%test_unit _ = test (Or_error.bin_writer_t Unit.bin_writer_t) (Or_error.error_string "test") ~expect:"\007\000\000\000\000\000\000\000\001\001\004test" ;; end) ;; let%test_unit _ = List.iter [ 0, 0; 1, 1; 0x7fff, 32767; 0xffff, -1; 0x8000, -32768 ] ~f:(fun (i, expect) -> assert (i >= 0); [%test_result: int] ~expect (Private.sign_extend_16 i)) ;; let%test_module "memcmp" = (module struct let empty = Bigstring.create 0 let b1 = Bigstring.of_string "abcd" let b2 = Bigstring.of_string "jkcd" let%test_unit "out of bounds raises" = assert ( try ignore (Bigstring.memcmp empty ~pos1:1 b1 ~pos2:1 ~len:0 : int); false with | _ -> true); assert ( try ignore (Bigstring.memcmp empty ~pos1:1 b1 ~pos2:1 ~len:1 : int); false with | _ -> true); assert ( try ignore (Bigstring.memcmp b1 ~pos1:0 b1 ~pos2:0 ~len:5 : int); false with | _ -> true); assert ( try ignore (Bigstring.memcmp b1 ~pos1:0 b1 ~pos2:5 ~len:0 : int); false with | _ -> true); assert ( try ignore (Bigstring.memcmp b1 ~pos1:0 b1 ~pos2:4 ~len:2 : int); false with | _ -> true) ;; let%test_unit "identical buffers are equal" = assert (Bigstring.memcmp empty ~pos1:0 empty ~pos2:0 ~len:0 = 0); assert (Bigstring.memcmp b1 ~pos1:0 b1 ~pos2:0 ~len:(Bigstring.length b1) = 0) ;; let%test_unit "prefix of identical buffers are equal" = assert (Bigstring.memcmp b1 ~pos1:0 b1 ~pos2:0 ~len:(Bigstring.length b1 - 1) = 0) ;; let%test_unit "suffix of identical buffers are equal" = assert (Bigstring.memcmp b1 ~pos1:1 b1 ~pos2:1 ~len:(Bigstring.length b1 - 1) = 0) ;; let%test_unit "memcmp agrees with compare" = assert ( Bigstring.memcmp b1 ~pos1:0 b2 ~pos2:0 ~len:(Bigstring.length b1) = Bigstring.compare b1 b2); assert ( Bigstring.memcmp b2 ~pos1:0 b1 ~pos2:0 ~len:(Bigstring.length b1) = Bigstring.compare b2 b1) ;; end) ;; let%test_module "memset" = (module struct let empty = Bigstring.create 0 let%test_unit "out of bounds raises" = let b1 = Bigstring.of_string "abcd" in assert ( try Bigstring.memset empty ~pos:0 ~len:1 'a'; false with | _ -> true); assert ( try Bigstring.memset b1 ~pos:1 ~len:4 'a'; false with | _ -> true); assert ( try Bigstring.memset b1 ~pos:8 ~len:0 'a'; false with | _ -> true) ;; let%test_unit "total memset works" = let b1 = Bigstring.of_string "abcd" in let b2 = Bigstring.of_string "AAAA" in Bigstring.memset b1 ~pos:0 ~len:(Bigstring.length b1) 'A'; assert (Bigstring.memcmp b1 ~pos1:0 b2 ~pos2:0 ~len:4 = 0) ;; let%test_unit "partial memset works" = let b1 = Bigstring.of_string "abcd" in let b2 = Bigstring.of_string "aAAd" in Bigstring.memset b1 ~pos:1 ~len:2 'A'; assert (Bigstring.memcmp b1 ~pos1:0 b2 ~pos2:0 ~len:4 = 0) ;; end) ;; let%test_module "stability" = (module struct let%expect_test "t" = print_endline [%bin_digest: Bigstring.Stable.V1.t]; [%expect "e2d261c6c291b94bf6aa68ec2b08cb00"] ;; (* Should we assert these are the same? *) let%expect_test "t_frozen" = print_endline [%bin_digest: Bigstring.Stable.V1.t_frozen]; [%expect "e2d261c6c291b94bf6aa68ec2b08cb00"] ;; end) ;; core-0.15.0/core/test/src/test_bigstring.mli000066400000000000000000000000551420273305200207530ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_bigstring_safe_accessors.ml000066400000000000000000000770261420273305200236610ustar00rootroot00000000000000open Core let generic_mk_set_and_print_for_test ~to_string ~set ~get buf = Staged.stage (fun ~test_name ~pos n -> try set buf ~pos n; printf "%s: %s\n" test_name (to_string (get buf ~pos)) with | e -> printf !"%s: %{Exn}\n" test_name e) ;; let mk_set_and_print_for_test = generic_mk_set_and_print_for_test ~to_string:string_of_int let generic_test_get ~to_string get buf ~pos = try printf "%s\n" (to_string (get buf ~pos)) with | e -> printf !"%{Exn}\n" e ;; let test_get = generic_test_get ~to_string:Int.to_string let%expect_test "set_int8_exn" = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_int8_exn ~get:Bigstring.get_int8 buf |> Staged.unstage in set_and_print ~test_name:"ok pos" ~pos:1 127; [%expect {| ok pos: 127 |}]; set_and_print ~test_name:"ok neg" ~pos:1 (-128); [%expect {| ok neg: -128 |}]; set_and_print ~test_name:"too large" ~pos:1 128; [%expect {| too large: (Invalid_argument "Bigstring.set_int8_exn: 128 is not a valid (signed) 8-bit integer") |}]; set_and_print ~test_name:"too small" ~pos:1 (-129); [%expect {| too small: (Invalid_argument "Bigstring.set_int8_exn: -129 is not a valid (signed) 8-bit integer") |}]; set_and_print ~test_name:"out of bounds" ~pos:16 64; [%expect {| out of bounds: (Invalid_argument "index out of bounds") |}] ;; let%expect_test "get_int8 oob" = let buf = Bigstring.init 1 ~f:(fun _ -> ' ') in test_get Bigstring.get_int8 buf ~pos:1; [%expect {| (Invalid_argument "index out of bounds") |}] ;; let%expect_test "set_uint8_exn" = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 15 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_uint8_exn ~get:Bigstring.get_uint8 buf |> Staged.unstage in set_and_print ~test_name:"ok" ~pos 0xFF; [%expect {| ok: 255 |}]; set_and_print ~test_name:"too large" ~pos 0x100; [%expect {| too large: (Invalid_argument "Bigstring.set_uint8_exn: 256 is not a valid unsigned 8-bit integer") |}]; set_and_print ~test_name:"too small" ~pos (-1); [%expect {| too small: (Invalid_argument "Bigstring.set_uint8_exn: -1 is not a valid unsigned 8-bit integer") |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "index out of bounds") |}] ;; let%expect_test "get_int16_le oob" = let buf = Bigstring.init 2 ~f:(fun _ -> ' ') in test_get Bigstring.get_int16_le buf ~pos:1; [%expect {| (Invalid_argument "Bigstring.get_16: length(bstr) < pos + len") |}] ;; let%expect_test "get_int16_be oob" = let buf = Bigstring.init 2 ~f:(fun _ -> ' ') in test_get Bigstring.get_int16_be buf ~pos:1; [%expect {| (Invalid_argument "Bigstring.get_16: length(bstr) < pos + len") |}] ;; let%expect_test "set_int16_le_exn" = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 14 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_int16_le_exn ~get:Bigstring.get_int16_le buf |> Staged.unstage in set_and_print ~test_name:"ok pos" ~pos 32767; [%expect {| ok pos: 32767 |}]; printf "@pos: 0x%x\n" (Bigstring.get_uint8 buf ~pos); printf "@pos + 1: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 1)); [%expect {| @pos: 0xff @pos + 1: 0x7f |}]; set_and_print ~test_name:"ok neg" ~pos (-32768); [%expect {| ok neg: -32768 |}]; set_and_print ~test_name:"too large" ~pos 32768; [%expect {| too large: (Invalid_argument "Bigstring.write_int16: 32768 is not a valid (signed) 16-bit integer") |}]; set_and_print ~test_name:"too small" ~pos (-32769); [%expect {| too small: (Invalid_argument "Bigstring.write_int16: -32769 is not a valid (signed) 16-bit integer") |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_16: length(bstr) < pos + len") |}] ;; let%expect_test "set_int16_be_exn" = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 14 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_int16_be_exn ~get:Bigstring.get_int16_be buf |> Staged.unstage in set_and_print ~test_name:"ok pos" ~pos 32767; [%expect {| ok pos: 32767 |}]; printf "@pos: 0x%x\n" (Bigstring.get_uint8 buf ~pos); printf "@pos + 1: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 1)); [%expect {| @pos: 0x7f @pos + 1: 0xff |}]; set_and_print ~test_name:"ok neg" ~pos (-32768); [%expect {| ok neg: -32768 |}]; set_and_print ~test_name:"too large" ~pos 32768; [%expect {| too large: (Invalid_argument "Bigstring.write_int16: 32768 is not a valid (signed) 16-bit integer") |}]; set_and_print ~test_name:"too small" ~pos (-32769); [%expect {| too small: (Invalid_argument "Bigstring.write_int16: -32769 is not a valid (signed) 16-bit integer") |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_16: length(bstr) < pos + len") |}] ;; let%expect_test "set_uint16_le_exn" = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 14 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_uint16_le_exn ~get:Bigstring.get_uint16_le buf |> Staged.unstage in set_and_print ~test_name:"ok" ~pos 0xFFFF; [%expect {| ok: 65535 |}]; set_and_print ~test_name:"endianness check" ~pos 51966; printf "@pos: 0x%x\n" (Bigstring.get_uint8 buf ~pos); printf "@pos + 1: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 1)); [%expect {| endianness check: 51966 @pos: 0xfe @pos + 1: 0xca |}]; set_and_print ~test_name:"too large" ~pos 0x1_0000; [%expect {| too large: (Invalid_argument "Bigstring.write_uint16: 65536 is not a valid unsigned 16-bit integer") |}]; set_and_print ~test_name:"too small" ~pos (-1); [%expect {| too small: (Invalid_argument "Bigstring.write_uint16: -1 is not a valid unsigned 16-bit integer") |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_16: length(bstr) < pos + len") |}] ;; let%expect_test "set_uint16_be_exn" = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 14 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_uint16_be_exn ~get:Bigstring.get_uint16_be buf |> Staged.unstage in set_and_print ~test_name:"ok" ~pos 0xFFFF; [%expect {| ok: 65535 |}]; set_and_print ~test_name:"endianness check" ~pos 51966; printf "@pos: 0x%x\n" (Bigstring.get_uint8 buf ~pos); printf "@pos + 1: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 1)); [%expect {| endianness check: 51966 @pos: 0xca @pos + 1: 0xfe |}]; set_and_print ~test_name:"too large" ~pos 0x1_0000; [%expect {| too large: (Invalid_argument "Bigstring.write_uint16: 65536 is not a valid unsigned 16-bit integer") |}]; set_and_print ~test_name:"too small" ~pos (-1); [%expect {| too small: (Invalid_argument "Bigstring.write_uint16: -1 is not a valid unsigned 16-bit integer") |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_16: length(bstr) < pos + len") |}] ;; let%expect_test "get_uint16_le oob" = let buf = Bigstring.init 2 ~f:(fun _ -> ' ') in test_get Bigstring.get_uint16_le buf ~pos:1; [%expect {| (Invalid_argument "Bigstring.get_16: length(bstr) < pos + len") |}] ;; let%expect_test "get_uint16_be oob" = let buf = Bigstring.init 2 ~f:(fun _ -> ' ') in test_get Bigstring.get_uint16_be buf ~pos:1; [%expect {| (Invalid_argument "Bigstring.get_16: length(bstr) < pos + len") |}] ;; (* There's a slightly different code path here on 32-bit, so let's test it *) let%expect_test "set_int32_le_exn 32-bit" = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 12 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_int32_le_exn ~get:Bigstring.get_int32_le buf |> Staged.unstage in set_and_print ~test_name:"ok pos" ~pos 1073741823; [%expect {| ok pos: 1073741823 |}]; set_and_print ~test_name:"ok neg" ~pos (-1073741824); [%expect {| ok neg: -1073741824 |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_32: length(bstr) < pos + len") |}] ;; let%expect_test "set_int32_be_exn 32-bit" = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 12 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_int32_be_exn ~get:Bigstring.get_int32_be buf |> Staged.unstage in set_and_print ~test_name:"ok pos" ~pos 1073741823; [%expect {| ok pos: 1073741823 |}]; set_and_print ~test_name:"ok neg" ~pos (-1073741824); [%expect {| ok neg: -1073741824 |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_32: length(bstr) < pos + len") |}] ;; let%expect_test ("set_int32_le_exn" [@tags "64-bits-only"]) = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 12 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_int32_le_exn ~get:Bigstring.get_int32_le buf |> Staged.unstage in set_and_print ~test_name:"ok pos" ~pos ((1 lsl 31) - 1); [%expect {| ok pos: 2147483647 |}]; set_and_print ~test_name:"ok neg" ~pos (-1 lsl 31); [%expect {| ok neg: -2147483648 |}]; set_and_print ~test_name:"endianness check" ~pos 0x1AFEDEAD; printf "@pos: 0x%x\n" (Bigstring.get_uint8 buf ~pos); printf "@pos + 1: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 1)); printf "@pos + 2: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 2)); printf "@pos + 3: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 3)); [%expect {| endianness check: 452910765 @pos: 0xad @pos + 1: 0xde @pos + 2: 0xfe @pos + 3: 0x1a |}]; set_and_print ~test_name:"too large" ~pos (1 lsl 31); [%expect {| too large: (Invalid_argument "Bigstring.write_int32_int: 2147483648 is not a valid (signed) 32-bit integer") |}]; set_and_print ~test_name:"too small" ~pos ((-1 lsl 31) - 1); [%expect {| too small: (Invalid_argument "Bigstring.write_int32_int: -2147483649 is not a valid (signed) 32-bit integer") |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_32: length(bstr) < pos + len") |}] ;; let%expect_test ("set_int32_be" [@tags "64-bits-only"]) = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 12 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_int32_be_exn ~get:Bigstring.get_int32_be buf |> Staged.unstage in set_and_print ~test_name:"ok pos" ~pos ((1 lsl 31) - 1); [%expect {| ok pos: 2147483647 |}]; set_and_print ~test_name:"ok neg" ~pos (-1 lsl 31); [%expect {| ok neg: -2147483648 |}]; set_and_print ~test_name:"endianness check" ~pos 0x1AFEDEAD; printf "@pos: 0x%x\n" (Bigstring.get_uint8 buf ~pos); printf "@pos + 1: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 1)); printf "@pos + 2: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 2)); printf "@pos + 3: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 3)); [%expect {| endianness check: 452910765 @pos: 0x1a @pos + 1: 0xfe @pos + 2: 0xde @pos + 3: 0xad |}]; set_and_print ~test_name:"too large" ~pos (1 lsl 31); [%expect {| too large: (Invalid_argument "Bigstring.write_int32_int: 2147483648 is not a valid (signed) 32-bit integer") |}]; set_and_print ~test_name:"too small" ~pos ((-1 lsl 31) - 1); [%expect {| too small: (Invalid_argument "Bigstring.write_int32_int: -2147483649 is not a valid (signed) 32-bit integer") |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_32: length(bstr) < pos + len") |}] ;; let%expect_test "set_uint32_le_exn 32-bit" = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 12 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_uint32_le_exn ~get:Bigstring.get_uint32_le buf |> Staged.unstage in set_and_print ~test_name:"ok" ~pos 1073741823; [%expect {| ok: 1073741823 |}]; set_and_print ~test_name:"too small" ~pos (-1); [%expect {| too small: (Invalid_argument "Bigstring.set_uint32_le_exn: -1 is not a valid unsigned 32-bit integer") |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_32: length(bstr) < pos + len") |}] ;; let%expect_test "get_int32_le oob" = let buf = Bigstring.init 4 ~f:(fun _ -> ' ') in test_get Bigstring.get_int32_le buf ~pos:1; [%expect {| (Invalid_argument "Bigstring.get_32: length(bstr) < pos + len") |}] ;; let%expect_test "get_int32_be oob" = let buf = Bigstring.init 4 ~f:(fun _ -> ' ') in test_get Bigstring.get_int32_be buf ~pos:1; [%expect {| (Invalid_argument "Bigstring.get_32: length(bstr) < pos + len") |}] ;; let%expect_test "set_uint32_be_exn 32-bit" = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 12 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_uint32_be_exn ~get:Bigstring.get_uint32_be buf |> Staged.unstage in set_and_print ~test_name:"ok" ~pos 1073741823; [%expect {| ok: 1073741823 |}]; set_and_print ~test_name:"too small" ~pos (-1); [%expect {| too small: (Invalid_argument "Bigstring.set_uint32_be_exn: -1 is not a valid unsigned 32-bit integer") |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_32: length(bstr) < pos + len") |}] ;; let%expect_test ("set_uint32_le_exn" [@tags "64-bits-only"]) = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 12 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_uint32_le_exn ~get:Bigstring.get_uint32_le buf |> Staged.unstage in set_and_print ~test_name:"ok" ~pos ((1 lsl 32) - 1); [%expect {| ok: 4294967295 |}]; set_and_print ~test_name:"endianness check" ~pos ((0xCAFE lsl 16) lor 0xDEAD); printf "@pos: 0x%x\n" (Bigstring.get_uint8 buf ~pos); printf "@pos + 1: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 1)); printf "@pos + 2: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 2)); printf "@pos + 3: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 3)); [%expect {| endianness check: 3405700781 @pos: 0xad @pos + 1: 0xde @pos + 2: 0xfe @pos + 3: 0xca |}]; set_and_print ~test_name:"too large" ~pos (1 lsl 32); [%expect {| too large: (Invalid_argument "Bigstring.set_uint32_le_exn: 4294967296 is not a valid unsigned 32-bit integer") |}]; set_and_print ~test_name:"too small" ~pos (-1); [%expect {| too small: (Invalid_argument "Bigstring.set_uint32_le_exn: -1 is not a valid unsigned 32-bit integer") |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_32: length(bstr) < pos + len") |}] ;; let%expect_test ("set_uint32_be_exn" [@tags "64-bits-only"]) = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 12 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_uint32_be_exn ~get:Bigstring.get_uint32_be buf |> Staged.unstage in set_and_print ~test_name:"ok" ~pos ((1 lsl 32) - 1); [%expect {| ok: 4294967295 |}]; set_and_print ~test_name:"endianness check" ~pos ((0xCAFE lsl 16) lor 0xDEAD); printf "@pos: 0x%x\n" (Bigstring.get_uint8 buf ~pos); printf "@pos + 1: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 1)); printf "@pos + 2: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 2)); printf "@pos + 3: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 3)); [%expect {| endianness check: 3405700781 @pos: 0xca @pos + 1: 0xfe @pos + 2: 0xde @pos + 3: 0xad |}]; set_and_print ~test_name:"too large" ~pos (1 lsl 32); [%expect {| too large: (Invalid_argument "Bigstring.set_uint32_be_exn: 4294967296 is not a valid unsigned 32-bit integer") |}]; set_and_print ~test_name:"too small" ~pos (-1); [%expect {| too small: (Invalid_argument "Bigstring.set_uint32_be_exn: -1 is not a valid unsigned 32-bit integer") |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_32: length(bstr) < pos + len") |}] ;; let%expect_test "get_uint32_le oob" = let buf = Bigstring.init 4 ~f:(fun _ -> ' ') in test_get Bigstring.get_uint32_le buf ~pos:1; [%expect {| (Invalid_argument "Bigstring.get_32: length(bstr) < pos + len") |}] ;; let%expect_test "get_uint32_be oob" = let buf = Bigstring.init 4 ~f:(fun _ -> ' ') in test_get Bigstring.get_uint32_be buf ~pos:1; [%expect {| (Invalid_argument "Bigstring.get_32: length(bstr) < pos + len") |}] ;; let%expect_test "set_int32_t_le" = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 12 in let set_and_print = generic_mk_set_and_print_for_test ~set:Bigstring.set_int32_t_le ~get:Bigstring.get_int32_t_le buf ~to_string:Int32.to_string |> Staged.unstage in set_and_print ~test_name:"ok pos" ~pos 0x7FFF_FFFFl; [%expect {| ok pos: 2147483647 |}]; set_and_print ~test_name:"ok neg" ~pos 0x8000_0000l; [%expect {| ok neg: -2147483648 |}]; set_and_print ~test_name:"endianness check" ~pos 0xCAFEDEADl; printf "@pos: 0x%x\n" (Bigstring.get_uint8 buf ~pos); printf "@pos + 1: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 1)); printf "@pos + 2: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 2)); printf "@pos + 3: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 3)); [%expect {| endianness check: -889266515 @pos: 0xad @pos + 1: 0xde @pos + 2: 0xfe @pos + 3: 0xca |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64l; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_32: length(bstr) < pos + len") |}] ;; let%expect_test "set_int32_t_be" = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 12 in let set_and_print = generic_mk_set_and_print_for_test ~set:Bigstring.set_int32_t_be ~get:Bigstring.get_int32_t_be buf ~to_string:Int32.to_string |> Staged.unstage in set_and_print ~test_name:"ok pos" ~pos 0x7FFF_FFFFl; [%expect {| ok pos: 2147483647 |}]; set_and_print ~test_name:"ok neg" ~pos 0x8000_0000l; [%expect {| ok neg: -2147483648 |}]; set_and_print ~test_name:"endianness check" ~pos 0xCAFEDEADl; printf "@pos: 0x%x\n" (Bigstring.get_uint8 buf ~pos); printf "@pos + 1: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 1)); printf "@pos + 2: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 2)); printf "@pos + 3: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 3)); [%expect {| endianness check: -889266515 @pos: 0xca @pos + 1: 0xfe @pos + 2: 0xde @pos + 3: 0xad |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64l; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_32: length(bstr) < pos + len") |}] ;; let%expect_test "get_uint32_le oob" = let buf = Bigstring.init 4 ~f:(fun _ -> ' ') in generic_test_get ~to_string:Int32.to_string Bigstring.get_int32_t_le buf ~pos:1; [%expect {| (Invalid_argument "Bigstring.get_32: length(bstr) < pos + len") |}] ;; let%expect_test "get_uint32_be oob" = let buf = Bigstring.init 4 ~f:(fun _ -> ' ') in generic_test_get ~to_string:Int32.to_string Bigstring.get_int32_t_be buf ~pos:1; [%expect {| (Invalid_argument "Bigstring.get_32: length(bstr) < pos + len") |}] ;; let%expect_test ("set_int64_le" [@tags "64-bits-only"]) = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 8 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_int64_le ~get:Bigstring.get_int64_le_exn buf |> Staged.unstage in set_and_print ~test_name:"ok pos" ~pos ((1 lsl 62) - 1); [%expect {| ok pos: 4611686018427387903 |}]; set_and_print ~test_name:"ok neg" ~pos (-1 lsl 62); [%expect {| ok neg: -4611686018427387904 |}]; set_and_print ~test_name:"endianness check" ~pos ((0x1AFE lsl 48) lor (0xBABE lsl 32) lor (0xDEAD lsl 16) lor 0xBEEF); printf "@pos: 0x%x\n" (Bigstring.get_uint8 buf ~pos); printf "@pos + 1: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 1)); printf "@pos + 2: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 2)); printf "@pos + 3: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 3)); printf "@pos + 4: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 4)); printf "@pos + 5: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 5)); printf "@pos + 6: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 6)); printf "@pos + 7: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 7)); [%expect {| endianness check: 1945197418013114095 @pos: 0xef @pos + 1: 0xbe @pos + 2: 0xad @pos + 3: 0xde @pos + 4: 0xbe @pos + 5: 0xba @pos + 6: 0xfe @pos + 7: 0x1a |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_64: length(bstr) < pos + len") |}] ;; let%expect_test ("set_int64_be" [@tags "64-bits-only"]) = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 8 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_int64_be ~get:Bigstring.get_int64_be_exn buf |> Staged.unstage in set_and_print ~test_name:"ok pos" ~pos ((1 lsl 62) - 1); [%expect {| ok pos: 4611686018427387903 |}]; set_and_print ~test_name:"ok neg" ~pos (-1 lsl 62); [%expect {| ok neg: -4611686018427387904 |}]; set_and_print ~test_name:"endianness check" ~pos ((0x1AFE lsl 48) lor (0xBABE lsl 32) lor (0xDEAD lsl 16) lor 0xBEEF); printf "@pos: 0x%x\n" (Bigstring.get_uint8 buf ~pos); printf "@pos + 1: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 1)); printf "@pos + 2: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 2)); printf "@pos + 3: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 3)); printf "@pos + 4: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 4)); printf "@pos + 5: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 5)); printf "@pos + 6: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 6)); printf "@pos + 7: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 7)); [%expect {| endianness check: 1945197418013114095 @pos: 0x1a @pos + 1: 0xfe @pos + 2: 0xba @pos + 3: 0xbe @pos + 4: 0xde @pos + 5: 0xad @pos + 6: 0xbe @pos + 7: 0xef |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_64: length(bstr) < pos + len") |}] ;; let%expect_test "get_int64_le_exn oob" = let buf = Bigstring.init 8 ~f:(fun _ -> ' ') in test_get Bigstring.get_int64_le_exn buf ~pos:1; [%expect {| (Invalid_argument "Bigstring.get_64: length(bstr) < pos + len") |}] ;; let%expect_test "get_int64_be_exn oob" = let buf = Bigstring.init 8 ~f:(fun _ -> ' ') in test_get Bigstring.get_int64_be_exn buf ~pos:1; [%expect {| (Invalid_argument "Bigstring.get_64: length(bstr) < pos + len") |}] ;; let%expect_test "get_int64_le_trunc oob" = let buf = Bigstring.init 4 ~f:(fun _ -> ' ') in test_get Bigstring.get_int64_le_trunc buf ~pos:1; [%expect {| (Invalid_argument "Bigstring.get_64: length(bstr) < pos + len") |}] ;; let%expect_test "get_int64_be_trunc oob" = let buf = Bigstring.init 4 ~f:(fun _ -> ' ') in test_get Bigstring.get_int64_be_trunc buf ~pos:1; [%expect {| (Invalid_argument "Bigstring.get_64: length(bstr) < pos + len") |}] ;; let%expect_test "get_int64_le_exn raises" = let buf = Bigstring.init 8 ~f:(fun _ -> ' ') in Bigstring.set_int64_t_le buf ~pos:0 0x8000000000000000L; test_get Bigstring.get_int64_le_exn buf ~pos:0; [%expect {| (Failure "unsafe_read_int64: value cannot be represented unboxed!") |}] ;; let%expect_test "get_int64_be_exn raises" = let buf = Bigstring.init 8 ~f:(fun _ -> ' ') in Bigstring.set_int64_t_be buf ~pos:0 0x8000000000000000L; test_get Bigstring.get_int64_be_exn buf ~pos:0; [%expect {| (Failure "unsafe_read_int64: value cannot be represented unboxed!") |}] ;; let%expect_test "get_int64_le_trunc truncates" = let buf = Bigstring.init 8 ~f:(fun _ -> ' ') in Bigstring.set_int64_t_le buf ~pos:0 0x8000000000000000L; test_get Bigstring.get_int64_le_trunc buf ~pos:0; [%expect {| 0 |}] ;; let%expect_test "get_int64_be_trunc truncates" = let buf = Bigstring.init 8 ~f:(fun _ -> ' ') in Bigstring.set_int64_t_be buf ~pos:0 0x8000000000000000L; test_get Bigstring.get_int64_be_trunc buf ~pos:0; [%expect {| 0 |}] ;; let%expect_test ("set_uint64_le_exn" [@tags "64-bits-only"]) = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 8 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_uint64_le_exn ~get:Bigstring.get_uint64_le_exn buf |> Staged.unstage in set_and_print ~test_name:"ok" ~pos ((1 lsl 62) - 1); [%expect {| ok: 4611686018427387903 |}]; set_and_print ~test_name:"endianness check" ~pos ((0x1AFE lsl 48) lor (0xBABE lsl 32) lor (0xDEAD lsl 16) lor 0xBEEF); printf "@pos: 0x%x\n" (Bigstring.get_uint8 buf ~pos); printf "@pos + 1: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 1)); printf "@pos + 2: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 2)); printf "@pos + 3: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 3)); printf "@pos + 4: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 4)); printf "@pos + 5: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 5)); printf "@pos + 6: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 6)); printf "@pos + 7: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 7)); [%expect {| endianness check: 1945197418013114095 @pos: 0xef @pos + 1: 0xbe @pos + 2: 0xad @pos + 3: 0xde @pos + 4: 0xbe @pos + 5: 0xba @pos + 6: 0xfe @pos + 7: 0x1a |}]; set_and_print ~test_name:"too small" ~pos (-1); [%expect {| too small: (Invalid_argument "Bigstring.set_uint64_le_exn: -1 is not a valid unsigned 64-bit integer") |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_64: length(bstr) < pos + len") |}] ;; let%expect_test ("set_uint64_be_exn" [@tags "64-bits-only"]) = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 8 in let set_and_print = mk_set_and_print_for_test ~set:Bigstring.set_uint64_be_exn ~get:Bigstring.get_uint64_be_exn buf |> Staged.unstage in set_and_print ~test_name:"ok" ~pos ((1 lsl 62) - 1); [%expect {| ok: 4611686018427387903 |}]; set_and_print ~test_name:"endianness check" ~pos ((0x1AFE lsl 48) lor (0xBABE lsl 32) lor (0xDEAD lsl 16) lor 0xBEEF); printf "@pos: 0x%x\n" (Bigstring.get_uint8 buf ~pos); printf "@pos + 1: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 1)); printf "@pos + 2: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 2)); printf "@pos + 3: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 3)); printf "@pos + 4: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 4)); printf "@pos + 5: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 5)); printf "@pos + 6: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 6)); printf "@pos + 7: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 7)); [%expect {| endianness check: 1945197418013114095 @pos: 0x1a @pos + 1: 0xfe @pos + 2: 0xba @pos + 3: 0xbe @pos + 4: 0xde @pos + 5: 0xad @pos + 6: 0xbe @pos + 7: 0xef |}]; set_and_print ~test_name:"too small" ~pos (-1); [%expect {| too small: (Invalid_argument "Bigstring.set_uint64_be_exn: -1 is not a valid unsigned 64-bit integer") |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_64: length(bstr) < pos + len") |}] ;; let%expect_test "set_int64_t_le" = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 8 in let set_and_print = generic_mk_set_and_print_for_test ~set:Bigstring.set_int64_t_le ~get:Bigstring.get_int64_t_le buf ~to_string:Int64.to_string |> Staged.unstage in set_and_print ~test_name:"ok pos" ~pos 0x7FFF_FFFF_FFFF_FFFFL; [%expect {| ok pos: 9223372036854775807 |}]; set_and_print ~test_name:"ok neg" ~pos 0x8000_0000_0000_0000L; [%expect {| ok neg: -9223372036854775808 |}]; set_and_print ~test_name:"endianness check" ~pos 0xCAFEBABEDEADBEEFL; printf "@pos: 0x%x\n" (Bigstring.get_uint8 buf ~pos); printf "@pos + 1: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 1)); printf "@pos + 2: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 2)); printf "@pos + 3: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 3)); printf "@pos + 4: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 4)); printf "@pos + 5: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 5)); printf "@pos + 6: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 6)); printf "@pos + 7: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 7)); [%expect {| endianness check: -3819410105021120785 @pos: 0xef @pos + 1: 0xbe @pos + 2: 0xad @pos + 3: 0xde @pos + 4: 0xbe @pos + 5: 0xba @pos + 6: 0xfe @pos + 7: 0xca |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64L; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_64: length(bstr) < pos + len") |}] ;; let%expect_test "set_int64_t_be" = let buf = Bigstring.init 16 ~f:(fun _ -> ' ') in let pos = 8 in let set_and_print = generic_mk_set_and_print_for_test ~set:Bigstring.set_int64_t_be ~get:Bigstring.get_int64_t_be buf ~to_string:Int64.to_string |> Staged.unstage in set_and_print ~test_name:"ok pos" ~pos 0x7FFF_FFFF_FFFF_FFFFL; [%expect {| ok pos: 9223372036854775807 |}]; set_and_print ~test_name:"ok neg" ~pos 0x8000_0000_0000_0000L; [%expect {| ok neg: -9223372036854775808 |}]; set_and_print ~test_name:"endianness check" ~pos 0xCAFEBABEDEADBEEFL; printf "@pos: 0x%x\n" (Bigstring.get_uint8 buf ~pos); printf "@pos + 1: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 1)); printf "@pos + 2: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 2)); printf "@pos + 3: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 3)); printf "@pos + 4: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 4)); printf "@pos + 5: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 5)); printf "@pos + 6: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 6)); printf "@pos + 7: 0x%x\n" (Bigstring.get_uint8 buf ~pos:(pos + 7)); [%expect {| endianness check: -3819410105021120785 @pos: 0xca @pos + 1: 0xfe @pos + 2: 0xba @pos + 3: 0xbe @pos + 4: 0xde @pos + 5: 0xad @pos + 6: 0xbe @pos + 7: 0xef |}]; set_and_print ~test_name:"out of bounds" ~pos:(pos + 1) 64L; [%expect {| out of bounds: (Invalid_argument "Bigstring.set_64: length(bstr) < pos + len") |}] ;; let%expect_test "get_int64_t_le oob" = let buf = Bigstring.init 8 ~f:(fun _ -> ' ') in generic_test_get ~to_string:Int64.to_string Bigstring.get_int64_t_le buf ~pos:1; [%expect {| (Invalid_argument "Bigstring.get_64: length(bstr) < pos + len") |}] ;; let%expect_test "get_int64_t_be oob" = let buf = Bigstring.init 8 ~f:(fun _ -> ' ') in generic_test_get ~to_string:Int64.to_string Bigstring.get_int64_t_be buf ~pos:1; [%expect {| (Invalid_argument "Bigstring.get_64: length(bstr) < pos + len") |}] ;; core-0.15.0/core/test/src/test_bigstring_safe_accessors.mli000066400000000000000000000000001420273305200240040ustar00rootroot00000000000000core-0.15.0/core/test/src/test_bigstring_unsafe_accessors.ml000066400000000000000000000131031420273305200242060ustar00rootroot00000000000000open! Core open Poly open! Bigstring let buf = create 256 let test_accessor ~buf to_str ~fget ~fset vals = List.foldi ~init:true vals ~f:(fun i passing x -> fset buf ~pos:0 x; let y = fget buf ~pos:0 in if x <> y then eprintf "Value %d: expected %s, got %s\n" i (to_str x) (to_str y); x = y && passing) ;; let%test _ = test_accessor ~buf Int.to_string ~fget:unsafe_get_int16_le ~fset:unsafe_set_int16_le [ -32768; -1; 0; 1; 32767 ] ;; let%test _ = test_accessor ~buf Int.to_string ~fget:unsafe_get_uint16_le ~fset:unsafe_set_uint16_le [ 0; 1; 65535 ] ;; let%test _ = test_accessor ~buf Int.to_string ~fget:unsafe_get_int16_be ~fset:unsafe_set_int16_be [ -32768; -1; 0; 1; 32767 ] ;; let%test _ = test_accessor ~buf Int.to_string ~fget:unsafe_get_uint16_be ~fset:unsafe_set_uint16_be [ 0; 1; 65535 ] ;; let%test (_ [@tags "64-bits-only"]) = test_accessor ~buf Int.to_string ~fget:unsafe_get_int32_le ~fset:unsafe_set_int32_le [ Int64.to_int_exn (-2147483648L); -1; 0; 1; Int64.to_int_exn 2147483647L ] ;; let%test (_ [@tags "64-bits-only"]) = test_accessor ~buf Int.to_string ~fget:unsafe_get_int32_be ~fset:unsafe_set_int32_be [ Int64.to_int_exn (-2147483648L); -1; 0; 1; Int64.to_int_exn 2147483647L ] ;; let%test (_ [@tags "64-bits-only"]) = test_accessor ~buf Int.to_string ~fget:unsafe_get_int64_le_exn ~fset:unsafe_set_int64_le [ Int64.to_int_exn (-2147483648L); -1; 0; 1; Int64.to_int_exn 2147483647L ] ;; let%test (_ [@tags "64-bits-only"]) = test_accessor ~buf Int.to_string ~fget:unsafe_get_int64_be_exn ~fset:unsafe_set_int64_be [ Int64.to_int_exn (-0x4000_0000_0000_0000L) ; Int64.to_int_exn (-2147483648L) ; -1 ; 0 ; 1 ; Int64.to_int_exn 2147483647L ; Int64.to_int_exn 0x3fff_ffff_ffff_ffffL ] ;; let%test (_ [@tags "64-bits-only"]) = List.for_all [ unsafe_get_uint64_be_exn, unsafe_set_uint64_be ; unsafe_get_uint64_le_exn, unsafe_set_uint64_le ] ~f:(fun (fget, fset) -> test_accessor ~buf Int.to_string ~fget ~fset ([ 0L; 1L; 0xffff_ffffL; 0x3fff_ffff_ffff_ffffL ] |> List.map ~f:Int64.to_int_exn)) ;; let%test_unit _ = List.iter [ "\x40\x00\x00\x00\x00\x00\x00\x00" ; "\x80\x00\x00\x00\x00\x00\x00\x00" ; "\xA0\x00\x00\x00\x00\x00\x00\x00" ; "\xF0\x00\x00\x00\x00\x00\x00\x00" ; "\x4F\xFF\xFF\xFF\xFF\xFF\xFF\xFF" ; "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF" ] ~f:(fun string -> assert ( Exn.does_raise (fun () -> unsafe_get_uint64_be_exn ~pos:0 (of_string string))); assert ( Exn.does_raise (fun () -> unsafe_get_uint64_le_exn ~pos:0 (of_string (String.rev string))))) ;; let%test _ = test_accessor ~buf Int64.to_string ~fget:unsafe_get_int64_t_le ~fset:unsafe_set_int64_t_le [ -0x8000_0000_0000_0000L ; -0x789A_BCDE_F012_3456L ; -0xFFL ; Int64.minus_one ; Int64.zero ; Int64.one ; 0x789A_BCDE_F012_3456L ; 0x7FFF_FFFF_FFFF_FFFFL ] ;; let%test _ = test_accessor ~buf Int64.to_string ~fget:unsafe_get_int64_t_be ~fset:unsafe_set_int64_t_be [ -0x8000_0000_0000_0000L ; -0x789A_BCDE_F012_3456L ; -0xFFL ; Int64.minus_one ; Int64.zero ; Int64.one ; 0x789A_BCDE_F012_3456L ; 0x7FFF_FFFF_FFFF_FFFFL ] ;; let%test _ = test_accessor ~buf Int64.to_string ~fget:unsafe_get_int64_t_be ~fset:unsafe_set_int64_t_be [ -0x8000_0000_0000_0000L ; -0x789A_BCDE_F012_3456L ; -0xFFL ; Int64.minus_one ; Int64.zero ; Int64.one ; 0x789A_BCDE_F012_3456L ; 0x7FFF_FFFF_FFFF_FFFFL ] ;; (* Test 63/64-bit precision boundary. Seen on a data stream the constant 0x4000_0000_0000_0000 is supposed to represent a 64-bit positive integer (2^62). Whilst this bit pattern does fit in an OCaml [int] on a 64-bit machine, it is the representation of a negative number ([Int.min_value]), and in particular is not the representation of 2^62. It is thus suitable for this test. *) let test_int64 get_exn get_trunc set_t double_check_set = List.iter [ 0x4000_0000_0000_0000L ; Int64.succ (Int64.of_int Int.max_value) ; Int64.pred (Int64.of_int Int.min_value) ; Int64.min_value ; Int64.max_value ; Int64.succ Int64.min_value ; Int64.pred Int64.max_value ] ~f:(fun too_big -> let trunc = Int.of_int64_trunc too_big in try set_t buf ~pos:0 too_big; [%test_result: int64] ~expect:too_big (double_check_set buf ~pos:0); let test_get name got = [%test_pred: string Or_error.t] is_error ~message:name (Or_error.map ~f:(fun i -> sprintf "%d = 0x%x" i i) got) in let got_exn = Or_error.try_with (fun () -> get_exn buf ~pos:0) in test_get "get_exn" got_exn; [%test_result: int] ~message:"get_trunc" ~expect:trunc (get_trunc buf ~pos:0) with | e -> failwiths ~here:[%here] "test_int64" ( sprintf "too_big = %LdL = 0x%LxL" too_big too_big , sprintf "trunc = %d = 0x%x" trunc trunc , e ) [%sexp_of: string * string * exn]) ;; let%test_unit "unsafe_get_int64_le" = test_int64 unsafe_get_int64_le_exn unsafe_get_int64_le_trunc unsafe_set_int64_t_le unsafe_get_int64_t_le ;; let%test_unit "unsafe_get_int64_be" = test_int64 unsafe_get_int64_be_exn unsafe_get_int64_be_trunc unsafe_set_int64_t_be unsafe_get_int64_t_be ;; core-0.15.0/core/test/src/test_bigstring_unsafe_accessors.mli000066400000000000000000000000551420273305200243610ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_bigstring_unsafe_destroy.ml000066400000000000000000000052271420273305200237220ustar00rootroot00000000000000open Core let%test "[unsafe_destroy] destroy after destroy" = let bs = Bigstring.create 100 in let () = Bigstring.unsafe_destroy bs in Exn.does_raise (fun () -> Bigstring.unsafe_destroy bs) ;; let%expect_test "[unsafe_destroy_and_resize]" = let bigstring_6 = Bigstring.of_string "ABCDEF" in bigstring_6.{5} <- '.'; printf "%s" (Bigstring.to_string bigstring_6); [%expect {| ABCDE. |}]; let bigstring_1 = Bigstring.unsafe_destroy_and_resize bigstring_6 ~len:1 in printf "%d" (Bigstring.length bigstring_6); [%expect {| 0 |}]; (try bigstring_6.{1} <- 'F' with | e -> printf !"%{Exn}\n" e); [%expect {| (Invalid_argument "index out of bounds") |}]; printf "%d" (Bigstring.length bigstring_1); [%expect {| 1 |}]; printf "%s" (Bigstring.to_string bigstring_1); [%expect {| A |}]; (try bigstring_1.{1} <- 'F' with | e -> printf !"%{Exn}\n" e); [%expect {| (Invalid_argument "index out of bounds") |}]; bigstring_1.{0} <- 'X'; let bigstring_3 = Bigstring.unsafe_destroy_and_resize bigstring_1 ~len:3 in printf "%d" (Bigstring.length bigstring_1); [%expect {| 0 |}]; printf "%d" (Bigstring.length bigstring_3); [%expect {| 3 |}]; Bigstring.From_string.blito () ~src:"YZ" ~dst:bigstring_3 ~dst_pos:1; printf "%s" (Bigstring.to_string bigstring_3); [%expect {| XYZ |}]; (try bigstring_3.{5} <- 'F' with | e -> printf !"%{Exn}\n" e); [%expect {| (Invalid_argument "index out of bounds") |}] ;; let%expect_test ("[unsafe_destroy_and_resize], proxy failure" [@tags "no-js"]) = let bigstring = Bigstring.create 5 in printf "%d" (Bigstring.length bigstring); [%expect {| 5 |}]; let bigstring = Bigstring.unsafe_destroy_and_resize bigstring ~len:10 in printf "%d" (Bigstring.length bigstring); [%expect {| 10 |}]; let _shared = Bigstring.sub_shared bigstring in (try let (_ : Bigstring.t_frozen) = Bigstring.unsafe_destroy_and_resize bigstring ~len:5 in () with | e -> printf !"%{Exn}\n" e); [%expect {| (Failure "bigstring_realloc: bigstring has proxy") |}] ;; let%test "[unsafe_destroy_and_resize] destroy after destroy" = let bs = Bigstring.create 100 in let _bs' = Bigstring.unsafe_destroy_and_resize bs ~len:100 in Exn.does_raise (fun () -> Bigstring.unsafe_destroy bs) ;; let%test_unit "[unsafe_destroy_and_resize] no double-free on finalise" = let old_gc = Gc.get () in let new_gc = { old_gc with Gc.Control.minor_heap_size = 1; Gc.Control.space_overhead = 1 } in Gc.set new_gc; let rec loop i = let bs = Bigstring.create 1000 in let _bs' = Bigstring.unsafe_destroy_and_resize bs ~len:1000 in if i > 0 then loop (i - 1) else () in loop 1_000_000; Gc.set old_gc ;; core-0.15.0/core/test/src/test_bigstring_unsafe_destroy.mli000066400000000000000000000000001420273305200240530ustar00rootroot00000000000000core-0.15.0/core/test/src/test_binable.ml000066400000000000000000000045201420273305200202070ustar00rootroot00000000000000open! Core open! Import open! Binable let%test_unit _ = let module M = struct type t = int [@@deriving bin_io] end in let m = (module M : S with type t = int) in List.iter [ Int.min_value; Int.min_value / 2; -1; 0; 1; Int.max_value / 2; Int.max_value ] ~f:(fun i -> let check name of_x to_x = let i' = of_x m (to_x m i) in if i <> i' then Error.failwiths ~here:[%here] (Printf.sprintf "Binable.{of,to}_%s failure" name) (i, `Round_tripped_to i') [%sexp_of: int * [ `Round_tripped_to of int ]] in check "string" of_string to_string; check "bigstring" of_bigstring to_bigstring) ;; let%test_unit "Of_sexpable" = let module M = struct type t = int include Of_sexpable_without_uuid [@alert "-legacy"] (struct type t = int [@@deriving sexp] end) end in let m = (module M : S with type t = M.t) in List.iter [ Int.min_value; -1; 0; 1; Int.max_value ] ~f:(fun int -> [%test_result: int] ~expect:int (of_string m (to_string m int))) ;; let%expect_test "of_bigstring fails if the buffer is too long or too short" = let good_bigstring = to_bigstring (module String) "test value" in print_endline (Bigstring.Hexdump.to_string_hum good_bigstring); [%expect {| 00000000 0a 74 65 73 74 20 76 61 6c 75 65 |.test value| |}]; print_endline (of_bigstring (module String) good_bigstring); [%expect {| test value |}]; (* if the bigstring is too short, the [bin_read_t] function will raise: *) let shorter_bigstring = Bigstring.sub_shared ~len:10 good_bigstring in require_does_raise [%here] (fun () -> of_bigstring (module String) shorter_bigstring); [%expect {| (Bin_prot__Common.Buffer_short) |}]; (* if the bigstring is too long, the [bin_read_t] function will not consume all of it, and [of_bigstring] will raise. *) let longer_bigstring = Bigstring.create 30 in Bigstring.memset longer_bigstring ~pos:0 ~len:30 '\xff'; Bigstring.blit ~src:good_bigstring ~src_pos:0 ~dst:longer_bigstring ~dst_pos:0 ~len:(Bigstring.length good_bigstring); require_does_raise [%here] (fun () -> of_bigstring (module String) longer_bigstring); [%expect {| ("bin_read_t did not consume the entire buffer" (consumed 11) (bigstring_length 30)) |}] ;; core-0.15.0/core/test/src/test_binable.mli000066400000000000000000000000551420273305200203570ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_blang.ml000066400000000000000000000452511420273305200177040ustar00rootroot00000000000000open! Core open Poly open! Import open! Blang let andalso = O.( && ) let orelse = O.( || ) let%test_module "Stable.V1" = (module Stable_unit_test.Make (struct type t = string Stable.V1.t [@@deriving sexp, bin_io] let equal = Poly.( = ) let test_blang = if_ (base "foo") (not_ (or_ [ base "bara"; base "barb" ])) (not_ (and_ [ base "baza"; base "bazb" ])) ;; let test_sexp = "(if foo (not (or bara barb)) (not (and baza bazb)))" let test_bin = "\005\006\003foo\004\003\006\004bara\006\004barb\004\002\006\004baza\006\004bazb" ;; let tests = [ test_blang, test_sexp, test_bin; true_, "true", "\000"; false_, "false", "\001" ] ;; end)) ;; let%test_module "auto-simplification" = (module struct let a, b, c = base 1, base 2, base 3 let ( = ) a b = invariant a; invariant b; Poly.( = ) a b ;; let%test _ = not_ true_ = false_ let%test _ = not_ false_ = true_ let%test _ = not_ (not_ a) = a let%test _ = andalso true_ b = b let%test _ = andalso a true_ = a let%test _ = andalso false_ b = false_ let%test _ = andalso a false_ = false_ let%test _ = orelse false_ b = b let%test _ = orelse a false_ = a let%test _ = orelse true_ b = true_ let%test _ = orelse a true_ = true_ let%test _ = if_ true_ b c = b let%test _ = if_ false_ b c = c let%test _ = if_ a true_ c = orelse a c let%test _ = if_ a b false_ = andalso a b let%test _ = if_ a b true_ = if_ (not_ a) true_ b (* b/c (if a b c) = (if (not a) c b) *) let%test _ = if_ a b true_ = orelse (not_ a) b let%test _ = if_ a false_ c = if_ (not_ a) c false_ (* b/c (if a b c) = (if (not a) c b) *) let%test _ = if_ a false_ c = andalso (not_ a) c let%test_module "n-ary-and-or" = (module struct let%test _ = and_ [ a; b; c ] = andalso (andalso a b) c let%test _ = or_ [ a; b; c ] = orelse (orelse a b) c let test_and ts = and_ ts = List.fold ts ~init:true_ ~f:andalso let test_or ts = or_ ts = List.fold ts ~init:false_ ~f:orelse let%test _ = test_or [] let%test _ = test_or [ a ] let%test _ = test_or [ true_ ] let%test _ = test_or [ false_ ] let%test _ = test_or [ a; true_; b ] let%test _ = test_or [ a; false_; b ] let%test _ = test_and [] let%test _ = test_and [ a ] let%test _ = test_and [ true_ ] let%test _ = test_and [ false_ ] let%test _ = test_and [ a; true_; b ] let%test _ = test_and [ a; false_; b ] end) ;; end) ;; let%test _ = [ 1; 2; 3; 4; 5; 6; 7 ] = values (and_ [ or_ [ base 1; base 2 ] ; base 3 ; true_ ; if_ (base 4) (base 5) (base 6) ; not_ (base 7) ]) ;; let%test _ = gather_conjuncts (base 1) = [ base 1 ] let%test _ = gather_conjuncts (and_ []) = [] let%test _ = gather_conjuncts (and_ [ base 1 ]) = [ base 1 ] let%test _ = gather_conjuncts (and_ [ base 1; base 2 ]) = [ base 1; base 2 ] let%test _ = gather_conjuncts (and_ [ base 1; base 2; base 3 ]) = [ base 1; base 2; base 3 ] ;; let%test _ = gather_conjuncts (and_ [ and_ [ and_ [ base 1; base 2 ]; base 3 ] ; and_ [ or_ [ base 4; base 5 ]; and_ [ base 6; base 7 ] ] ]) = [ base 1; base 2; base 3; or_ [ base 4; base 5 ]; base 6; base 7 ] ;; let%test _ = gather_disjuncts (base 1) = [ base 1 ] let%test _ = gather_disjuncts (or_ []) = [] let%test _ = gather_disjuncts (or_ [ base 1 ]) = [ base 1 ] let%test _ = gather_disjuncts (or_ [ base 1; base 2 ]) = [ base 1; base 2 ] let%test _ = gather_disjuncts (or_ [ base 1; base 2; base 3 ]) = [ base 1; base 2; base 3 ] ;; let%test _ = gather_disjuncts (or_ [ or_ [ or_ [ base 1; base 2 ]; base 3 ] ; or_ [ and_ [ base 4; base 5 ]; or_ [ base 6; base 7 ] ] ]) = [ base 1; base 2; base 3; and_ [ base 4; base 5 ]; base 6; base 7 ] ;; let%test_module "bind short-circuiting" = (module struct let test expected_visits expr = let visited = ref [] in let f var = visited := var :: !visited; false_ in match bind expr ~f with | True -> List.equal Int.equal expected_visits (List.rev !visited) | _ -> false ;; let%test _ = test [ 0 ] (or_ [ not_ (base 0); base 1 ]) let%test _ = test [ 0; 1 ] (not_ (and_ [ not_ (base 0); base 1; base 2 ])) let%test _ = test [ 0; 2 ] (if_ (base 0) (base 1) (not_ (base 2))) end) ;; let%test_module "laws" = (module struct type base = | A | B | C [@@deriving sexp_of] type 'a base_fun = base -> 'a let sexp_of_base_fun sexp_of_a (f : 'a base_fun) = Sexp.List [ Sexp.Atom "function" ; Sexp.List [ Sexp.Atom "A"; Sexp.Atom "->"; sexp_of_a (f A) ] ; Sexp.List [ Sexp.Atom "B"; Sexp.Atom "->"; sexp_of_a (f B) ] ; Sexp.List [ Sexp.Atom "C"; Sexp.Atom "->"; sexp_of_a (f C) ] ] ;; module Gen = struct (* all random values are generated from a fixed PRNG seed so that unit tests are deterministic *) let prng = Random.State.make (String.to_list "31bb128c352e2569228fbacc590e937a29a8bb8fc4bfe7126504ce3dc400be7f401fa6f5be5dba38" |> Array.of_list |> Array.map ~f:Char.to_int) ;; let bool () = Random.State.bool prng let element arr = arr.(Random.State.int prng (Array.length arr)) let gen_blang gen_base = let atomic = [| (fun () -> constant (bool ())); (fun () -> base (gen_base ())) |] in let composite = [| (fun rand -> not_ (rand ())) ; (fun rand -> andalso (rand ()) (rand ())) ; (fun rand -> orelse (rand ()) (rand ())) ; (fun rand -> if_ (rand ()) (rand ()) (rand ())) |] in let rec aux ~depth = if depth <= 1 then element atomic () else element composite (fun () -> aux ~depth:(depth - 1)) in aux ;; let gen_base = let bases = [| A; B; C |] in fun () -> element bases ;; let gen_base_fun codomain () = let a_val = element codomain in let b_val = element codomain in let c_val = element codomain in function | A -> a_val | B -> b_val | C -> c_val ;; let t () = gen_blang gen_base ~depth:5 let f = gen_base_fun [| true; false |] let g = gen_base_fun [| `Unknown; `Known true; `Known false |] let tf () = t (), f () let tg () = t (), g () end let law gen sexp_of run = for _ = 0 to 100 do let arg = gen () in if not (run arg) then failwith (Sexp.to_string (sexp_of arg)) done ;; let forall_t = law Gen.t [%sexp_of: base t] let forall_tf = law Gen.tf [%sexp_of: base t * bool base_fun] let forall_tg = law Gen.tg [%sexp_of: base t * [ `Known of bool | `Unknown ] base_fun] let%test_unit _ = forall_t (fun t -> specialize t (fun _ -> `Unknown) = t) let%test_unit _ = forall_tf (fun (t, f) -> specialize t (fun x -> `Known (f x)) = constant (eval t f)) ;; let%test_unit _ = forall_tg (fun (t, g) -> List.for_all (values (specialize t g)) ~f:(fun x -> g x = `Unknown)) ;; let%test_unit _ = forall_tg (fun (t, g) -> (* an arbitrary [f] such that [f x = b] whenever [g x = `Known b] *) let f = let rand_fval x = match g x with | `Known b -> b | `Unknown -> Gen.bool () in let a_val = rand_fval A in let b_val = rand_fval B in let c_val = rand_fval C in function | A -> a_val | B -> b_val | C -> c_val in eval t f = eval (specialize t g) f) ;; let%test_module "eval_set" = (module struct type base_set = | Odd | Even | Greater_than of int | Smaller_than of int [@@deriving sexp_of] let size = 10 let universe = lazy (List.init size ~f:Fn.id |> Int.Set.of_list) let gen_base = let bases = [| Odd; Even; Greater_than (size / 2); Smaller_than (size / 2) |] in fun () -> Gen.element bases ;; let t () = Gen.gen_blang gen_base ~depth:5 let set_of_base = Memo.general (fun t -> Int.Set.filter (force universe) ~f:(fun e -> match t with | Odd -> e mod 2 = 1 | Even -> e mod 2 = 0 | Greater_than x -> e > x | Smaller_than x -> e < x)) ;; let run expression = let expect = Set.filter (force universe) ~f:(fun e -> eval expression (fun base -> Int.Set.mem (set_of_base base) e)) in try [%test_result: Int.Set.t] ~expect (eval_set ~universe set_of_base expression) with | exn -> failwiths ~here:[%here] "fail on expression" (expression, exn) [%sexp_of: base_set t * Exn.t] ;; let%test_unit _ = for _ = 0 to 100 do run (t ()) done ;; end) ;; end) ;; let%expect_test "no-alloc-eval" = let blang = if_ (base "foo") (not_ (or_ [ base "bara"; base "barb" ])) (not_ (and_ [ base "baza"; base "bazb" ])) in require_no_allocation [%here] (fun () -> let result = eval blang (fun _ -> false) in ignore (result : bool)); [%expect {| |}] ;; let%expect_test "quickcheck generator obeys invariants" = Quickcheck.test ~shrinker:[%quickcheck.shrinker: bool Blang.t] ~sexp_of:[%sexp_of: bool Blang.t] [%quickcheck.generator: bool Blang.t] ~f:Blang.invariant; [%expect {| |}] ;; let%expect_test "validate sexp grammar" = require_ok [%here] (Sexp_grammar_validation.validate_grammar (module struct type t = unit Blang.t [@@deriving quickcheck, sexp, sexp_grammar] end)); [%expect {| (Recursive (Tycon blang ((List Empty))) (( (tycon blang) (tyvars (a)) (grammar (Union ((Tyvar a) (Variant ((case_sensitivity Case_insensitive) (clauses ((No_tag ((name true) (clause_kind Atom_clause))) (No_tag ((name false) (clause_kind Atom_clause))) (No_tag ((name if) (clause_kind (List_clause (args (Cons (Tycon blang ((Tyvar a))) (Cons (Tycon blang ((Tyvar a))) (Cons (Tycon blang ((Tyvar a))) Empty)))))))) (No_tag ((name and) (clause_kind (List_clause (args (Many (Tycon blang ((Tyvar a))))))))) (No_tag ((name or) (clause_kind (List_clause (args (Many (Tycon blang ((Tyvar a))))))))) (No_tag ((name not) (clause_kind (List_clause (args (Cons (Tycon blang ((Tyvar a))) Empty)))))))))))))))) |}] ;; module _ = struct let a, b, c, d = base "a", base "b", base "c", base "d" let print l = let blang = and_ l in print_s [%message "standard" ~_:(blang : string t)]; print_s [%message "raw" ~_:(blang : string Raw.t)] ;; let%expect_test _ = print [ a ]; [%expect {| (standard a) (raw (Base a)) |}] ;; let%expect_test _ = print [ a; b ]; [%expect {| (standard (and a b)) (raw ( And (Base a) (Base b))) |}] ;; let%expect_test _ = print [ a; b; c ]; [%expect {| (standard (and a b c)) (raw ( And (Base a) (And (Base b) (Base c)))) |}] ;; let%expect_test _ = print [ a; b; c; d ]; [%expect {| (standard (and a b c d)) (raw ( And (Base a) (And (Base b) (And (Base c) (Base d))))) |}] ;; let%expect_test "arbitrary nesting" = let b = base in let p x = print [ and_ [ b "a"; b "b" ] ; and_ [ and_ [ b "c"; b "d"; and_ [ x; b "e"; and_ [ b "f" ] ]; b "g" ]; b "h" ] ] in p true_; [%expect {| (standard (and a b c d e f g h)) (raw ( And (Base a) (And (Base b) (And (Base c) (And (Base d) (And (Base e) (And (Base f) (And (Base g) (Base h))))))))) |}]; p false_; [%expect {| (standard false) (raw False) |}] ;; end module _ = struct let a, b, c, d = base "a", base "b", base "c", base "d" let print l = let blang = or_ l in print_s [%message "standard" ~_:(blang : string t)]; print_s [%message "raw" ~_:(blang : string Raw.t)] ;; let%expect_test _ = print [ a ]; [%expect {| (standard a) (raw (Base a)) |}] ;; let%expect_test _ = print [ a; b ]; [%expect {| (standard (or a b)) (raw ( Or (Base a) (Base b))) |}] ;; let%expect_test _ = print [ a; b; c ]; [%expect {| (standard (or a b c)) (raw ( Or (Base a) (Or (Base b) (Base c)))) |}] ;; let%expect_test _ = print [ a; b; c; d ]; [%expect {| (standard (or a b c d)) (raw ( Or (Base a) (Or (Base b) (Or (Base c) (Base d))))) |}] ;; let%expect_test "arbitrary nesting" = let b = base in let p x = print [ or_ [ b "a"; b "b" ] ; or_ [ or_ [ b "c"; b "d"; or_ [ x; b "e"; or_ [ b "f" ] ]; b "g" ]; b "h" ] ] in p true_; [%expect {| (standard true) (raw True) |}]; p false_; [%expect {| (standard (or a b c d e f g h)) (raw ( Or (Base a) (Or (Base b) (Or (Base c) (Or (Base d) (Or (Base e) (Or (Base f) (Or (Base g) (Base h))))))))) |}] ;; end (* annotate with module type to enforce that we test all exports *) module _ : Monadic with module M := Monad.Ident = struct open struct (* define helpers without exporting them *) module Monadic = For_monad (Monad.Ident) module Small_int = struct type t = (int[@quickcheck.generator Quickcheck.Generator.small_non_negative_int]) [@@deriving equal, quickcheck, sexp_of] end module Small_int_blang = struct type t = Small_int.t Blang.t [@@deriving equal, quickcheck, sexp_of] end module Trace = struct type 'a t = { value : 'a ; work : int list } [@@deriving equal, sexp_of] (* record calls to [f] to test short-circuiting *) let run op t ~f = let history = Queue.create () in let f x = Queue.enqueue history x; f x in let value = op t ~f in let work = (* order of calls can differ, so long as we do the same overall work *) history |> Queue.to_list |> List.sort ~compare:Int.compare in { value; work } ;; end let test (type a) m t op1 op2 ~f = let (module Value : Expect_test_helpers_base.With_equal with type t = a) = m in let module Value_with_trace = struct type t = Value.t Trace.t [@@deriving equal, sexp_of] end in require_equal [%here] (module Value_with_trace) (Trace.run op1 t ~f) (Trace.run op2 t ~f) ;; end (* Test [For_monad (Ident)] functions against the same exports from [Blang]. *) let map = Monadic.map let%expect_test "map" = quickcheck_m [%here] (module Small_int_blang) ~f:(fun t -> test (module Small_int_blang) t Blang.map Monadic.map ~f:Int.succ); [%expect {| |}] ;; let bind = Monadic.bind let%expect_test "bind" = quickcheck_m [%here] (module struct type t = Small_int_blang.t * Small_int_blang.t list [@@deriving quickcheck, sexp_of] end) ~f:(fun (t, list) -> (* derive [f] from first-order input that can be shown in sexps *) let f n = n |> List.nth list |> Option.value ~default:(Blang.base n) in test (module Small_int_blang) t Blang.bind Monadic.bind ~f); [%expect {| |}] ;; let eval = Monadic.eval let%expect_test "eval" = quickcheck_m [%here] (module struct type t = Small_int_blang.t * Small_int.t [@@deriving quickcheck, sexp_of] end) ~f:(fun (t, x) -> (* derive [f] from first-order input that can be shown in sexps *) let f n = n > x in test (module Bool) t (fun t ~f -> Blang.eval t f) Monadic.eval ~f); [%expect {| |}] ;; end type 'a eval_benchmark = { blang : 'a t ; f : 'a -> bool } module _ = struct let bench ~less_than:upper_bound_exclusive ~len = let blang = and_ (List.init len ~f:(fun i -> base i)) in let gt i = Int.( < ) i upper_bound_exclusive in { blang; f = gt } ;; let%bench_fun "and_ false first item in short list" = let { blang; f } = bench ~less_than:0 ~len:2 in fun () -> eval blang f ;; let%bench_fun "and_ false first item in long list" = let { blang; f } = bench ~less_than:0 ~len:100 in fun () -> eval blang f ;; let%bench_fun "and_ false last item in short list" = let { blang; f } = bench ~less_than:1 ~len:2 in fun () -> eval blang f ;; let%bench_fun "and_ false last item in long list" = let { blang; f } = bench ~less_than:99 ~len:100 in fun () -> eval blang f ;; end module _ = struct let bench ~equal ~len = let blang = or_ (List.init len ~f:(fun i -> base i)) in let eq i = Int.equal equal i in { blang; f = eq } ;; let%bench_fun "or_ true first item in short list" = let { blang; f } = bench ~equal:0 ~len:2 in fun () -> eval blang f ;; let%bench_fun "or_ true first item in long list" = let { blang; f } = bench ~equal:0 ~len:100 in fun () -> eval blang f ;; let%bench_fun "or_ true last item in short list" = let { blang; f } = bench ~equal:1 ~len:2 in fun () -> eval blang f ;; let%bench_fun "or_ true last item in long list" = let { blang; f } = bench ~equal:99 ~len:100 in fun () -> eval blang f ;; end core-0.15.0/core/test/src/test_blang.mli000066400000000000000000000000551420273305200200460ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_bounded_index.ml000066400000000000000000000027461420273305200214320ustar00rootroot00000000000000open! Core open! Import open! Bounded_index let%test_module "V1" = (module Stable_unit_test.Make (struct module M = Make (struct let label = "index" let module_name = "Test_bounded_index" end) type t = M.Stable.V1.t [@@deriving sexp, bin_io, compare] let equal x y = compare x y = 0 let make index min max = M.create index ~min ~max let tests = [ make 0 0 0, "(index 0 of 0 to 0)", "\000\000\000" ; make 0 0 1, "(index 0 of 0 to 1)", "\000\000\001" ; make 1 0 1, "(index 1 of 0 to 1)", "\001\000\001" ; make 0 0 2, "(index 0 of 0 to 2)", "\000\000\002" ; make 1 0 2, "(index 1 of 0 to 2)", "\001\000\002" ; make 2 0 2, "(index 2 of 0 to 2)", "\002\000\002" ; make 1 1 1, "(index 1 of 1 to 1)", "\001\001\001" ; make 1 1 2, "(index 1 of 1 to 2)", "\001\001\002" ; make 2 1 2, "(index 2 of 1 to 2)", "\002\001\002" ; make 1 1 3, "(index 1 of 1 to 3)", "\001\001\003" ; make 2 1 3, "(index 2 of 1 to 3)", "\002\001\003" ; make 3 1 3, "(index 3 of 1 to 3)", "\003\001\003" ; ( make 499_999_999 0 999_999_999 , "(index 499_999_999 of 0 to 999_999_999)" , "\253\255\100\205\029\000\253\255\201\154\059" ) ; ( make 500_000_000 1 1_000_000_000 , "(index 500_000_000 of 1 to 1_000_000_000)" , "\253\000\101\205\029\001\253\000\202\154\059" ) ] ;; end)) ;; core-0.15.0/core/test/src/test_bounded_index.mli000066400000000000000000000000551420273305200215720ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_byte_units.ml000066400000000000000000000450421420273305200210040ustar00rootroot00000000000000open! Core open! Import open! Byte_units let bytes_per_word = Float.of_int (Int.( / ) (Word_size.num_bits Word_size.word_size) 8) let kbyte = 1024. let%expect_test ("Byte_units.to_string_hum" [@tags "64-bits-only"]) = print_string (Byte_units.to_string_hum (Byte_units.of_bytes_int 1000)); [%expect {| 1000B |}]; print_string (Byte_units.to_string_hum (Byte_units.of_bytes_int 1500)); [%expect {| 1.46484K |}] ;; let%test_module "{of,to}_string" = (module struct let f input expected_output = let observed_output = to_string_hum (of_string input) in let result = String.equal expected_output observed_output in if not result then eprintf "\n%s -> %s != %s\n%!" input expected_output observed_output; result ;; let%test _ = f "3B" "3B" let%test _ = f "3w" (sprintf "%gB" (3.0 *. bytes_per_word)) let%test _ = f "3K" "3K" let%test _ = f "3M" "3M" let%test _ = f "3G" "3G" end) ;; let examples = [ Byte_units.zero ; Byte_units.of_bytes_int 1 ; Byte_units.of_bytes_int 10 ; Byte_units.of_bytes_int 100 ; Byte_units.of_bytes_int 1000 ; Byte_units.of_bytes_int 10000 ; Byte_units.of_bytes_int 100000 ; Byte_units.of_bytes_int 1000000 ; Byte_units.of_kilobytes 0.1 ; Byte_units.of_kilobytes 1. ; Byte_units.of_kilobytes 1.1 ; Byte_units.of_kilobytes 10. ; Byte_units.of_kilobytes 100. ; Byte_units.of_megabytes 1. ; Byte_units.of_megabytes 10. ; Byte_units.of_megabytes 100. ; Byte_units.of_gigabytes 1. ; Byte_units.of_gigabytes 10. ; Byte_units.of_gigabytes 100. ; Byte_units.of_terabytes 1. ; Byte_units.of_terabytes 10. ; Byte_units.of_terabytes 100. ; Byte_units.of_petabytes 1. ; Byte_units.of_petabytes 10. ; Byte_units.of_petabytes 100. ; Byte_units.of_exabytes 1. ; Byte_units.of_bytes_int (-1) ; Byte_units.of_bytes_int (-10000) ; Byte_units.of_bytes_int (-10000000) ] ;; let%expect_test "[List.sum] to ensure [Byte_units] satisfies [Container_intf.Summable]" = print_s [%sexp (List.sum (module Byte_units) examples ~f:Fn.id : t)]; [%expect {| 1.19025e+09G |}] ;; let print_all_byte_units fmt = List.iter examples ~f:(fun n -> printf !"%{sexp:Byte_units.Stable.V2.t} -> %s\n" n (sprintf fmt n)) ;; let%expect_test ("Byte_units.to_string" [@tags "no-js"]) = (* disabling test in javascript as it has subtly different rounding breaking this test. See https://github.com/ocsigen/js_of_ocaml/issues/796. *) print_all_byte_units !"%{Byte_units}"; [%expect {| (Bytes 0) -> 0B (Bytes 1) -> 1B (Bytes 10) -> 10B (Bytes 100) -> 100B (Bytes 1_000) -> 1000B (Bytes 10_000) -> 9.76562K (Bytes 100_000) -> 97.6562K (Bytes 1_000_000) -> 976.562K (Bytes 102) -> 102B (Bytes 1_024) -> 1K (Bytes 1_126) -> 1.09961K (Bytes 10_240) -> 10K (Bytes 102_400) -> 100K (Bytes 1_048_576) -> 1M (Bytes 10_485_760) -> 10M (Bytes 104_857_600) -> 100M (Bytes 1_073_741_824) -> 1G (Bytes 10_737_418_240) -> 10G (Bytes 107_374_182_400) -> 100G (Bytes 1_099_511_627_776) -> 1024G (Bytes 10_995_116_277_760) -> 10240G (Bytes 109_951_162_777_600) -> 102400G (Bytes 1_125_899_906_842_624) -> 1.04858e+06G (Bytes 11_258_999_068_426_240) -> 1.04858e+07G (Bytes 112_589_990_684_262_400) -> 1.04858e+08G (Bytes 1_152_921_504_606_846_976) -> 1.07374e+09G (Bytes -1) -> -1B (Bytes -10_000) -> -9.76562K (Bytes -10_000_000) -> -9.53674M |}] ;; let%expect_test "Byte_units.to_string_short" = print_all_byte_units !"%{Byte_units.Short}"; [%expect {| (Bytes 0) -> 0B (Bytes 1) -> 1B (Bytes 10) -> 10B (Bytes 100) -> 100B (Bytes 1_000) -> 1000B (Bytes 10_000) -> 9.77K (Bytes 100_000) -> 97.7K (Bytes 1_000_000) -> 977K (Bytes 102) -> 102B (Bytes 1_024) -> 1.00K (Bytes 1_126) -> 1.10K (Bytes 10_240) -> 10.0K (Bytes 102_400) -> 100K (Bytes 1_048_576) -> 1.00M (Bytes 10_485_760) -> 10.0M (Bytes 104_857_600) -> 100M (Bytes 1_073_741_824) -> 1.00G (Bytes 10_737_418_240) -> 10.0G (Bytes 107_374_182_400) -> 100G (Bytes 1_099_511_627_776) -> 1.00T (Bytes 10_995_116_277_760) -> 10.0T (Bytes 109_951_162_777_600) -> 100T (Bytes 1_125_899_906_842_624) -> 1.00P (Bytes 11_258_999_068_426_240) -> 10.0P (Bytes 112_589_990_684_262_400) -> 100P (Bytes 1_152_921_504_606_846_976) -> 1.00E (Bytes -1) -> -1B (Bytes -10_000) -> -9.77K (Bytes -10_000_000) -> -9.54M |}] ;; let%expect_test ("Byte_units.sexp_of_t" [@tags "no-js"]) = (* disabling test in javascript as it has subtly different rounding breaking this test. See https://github.com/ocsigen/js_of_ocaml/issues/796. *) print_all_byte_units !"%{sexp:Byte_units.t}"; [%expect {| (Bytes 0) -> 0B (Bytes 1) -> 1B (Bytes 10) -> 10B (Bytes 100) -> 100B (Bytes 1_000) -> 1000B (Bytes 10_000) -> 9.76562K (Bytes 100_000) -> 97.6562K (Bytes 1_000_000) -> 976.562K (Bytes 102) -> 102B (Bytes 1_024) -> 1K (Bytes 1_126) -> 1.09961K (Bytes 10_240) -> 10K (Bytes 102_400) -> 100K (Bytes 1_048_576) -> 1M (Bytes 10_485_760) -> 10M (Bytes 104_857_600) -> 100M (Bytes 1_073_741_824) -> 1G (Bytes 10_737_418_240) -> 10G (Bytes 107_374_182_400) -> 100G (Bytes 1_099_511_627_776) -> 1024G (Bytes 10_995_116_277_760) -> 10240G (Bytes 109_951_162_777_600) -> 102400G (Bytes 1_125_899_906_842_624) -> 1.04858e+06G (Bytes 11_258_999_068_426_240) -> 1.04858e+07G (Bytes 112_589_990_684_262_400) -> 1.04858e+08G (Bytes 1_152_921_504_606_846_976) -> 1.07374e+09G (Bytes -1) -> -1B (Bytes -10_000) -> -9.76562K (Bytes -10_000_000) -> -9.53674M |}] ;; let%expect_test "Byte_units.Stable.V1.sexp_of_t" = print_all_byte_units !"%{sexp:Byte_units.Stable.V1.t}"; [%expect {| (Bytes 0) -> (Bytes 0) (Bytes 1) -> (Bytes 1) (Bytes 10) -> (Bytes 10) (Bytes 100) -> (Bytes 100) (Bytes 1_000) -> (Bytes 1000) (Bytes 10_000) -> (Kilobytes 9.765625) (Bytes 100_000) -> (Kilobytes 97.65625) (Bytes 1_000_000) -> (Kilobytes 976.5625) (Bytes 102) -> (Bytes 102) (Bytes 1_024) -> (Kilobytes 1) (Bytes 1_126) -> (Kilobytes 1.099609375) (Bytes 10_240) -> (Kilobytes 10) (Bytes 102_400) -> (Kilobytes 100) (Bytes 1_048_576) -> (Megabytes 1) (Bytes 10_485_760) -> (Megabytes 10) (Bytes 104_857_600) -> (Megabytes 100) (Bytes 1_073_741_824) -> (Gigabytes 1) (Bytes 10_737_418_240) -> (Gigabytes 10) (Bytes 107_374_182_400) -> (Gigabytes 100) (Bytes 1_099_511_627_776) -> (Gigabytes 1024) (Bytes 10_995_116_277_760) -> (Gigabytes 10240) (Bytes 109_951_162_777_600) -> (Gigabytes 102400) (Bytes 1_125_899_906_842_624) -> (Gigabytes 1048576) (Bytes 11_258_999_068_426_240) -> (Gigabytes 10485760) (Bytes 112_589_990_684_262_400) -> (Gigabytes 104857600) (Bytes 1_152_921_504_606_846_976) -> (Gigabytes 1073741824) (Bytes -1) -> (Bytes -1) (Bytes -10_000) -> (Kilobytes -9.765625) (Bytes -10_000_000) -> (Megabytes -9.5367431640625) |}] ;; let%expect_test "Byte_units.Stable.V2.sexp_of_t" = print_all_byte_units !"%{sexp:Byte_units.Stable.V2.t}"; [%expect {| (Bytes 0) -> (Bytes 0) (Bytes 1) -> (Bytes 1) (Bytes 10) -> (Bytes 10) (Bytes 100) -> (Bytes 100) (Bytes 1_000) -> (Bytes 1_000) (Bytes 10_000) -> (Bytes 10_000) (Bytes 100_000) -> (Bytes 100_000) (Bytes 1_000_000) -> (Bytes 1_000_000) (Bytes 102) -> (Bytes 102) (Bytes 1_024) -> (Bytes 1_024) (Bytes 1_126) -> (Bytes 1_126) (Bytes 10_240) -> (Bytes 10_240) (Bytes 102_400) -> (Bytes 102_400) (Bytes 1_048_576) -> (Bytes 1_048_576) (Bytes 10_485_760) -> (Bytes 10_485_760) (Bytes 104_857_600) -> (Bytes 104_857_600) (Bytes 1_073_741_824) -> (Bytes 1_073_741_824) (Bytes 10_737_418_240) -> (Bytes 10_737_418_240) (Bytes 107_374_182_400) -> (Bytes 107_374_182_400) (Bytes 1_099_511_627_776) -> (Bytes 1_099_511_627_776) (Bytes 10_995_116_277_760) -> (Bytes 10_995_116_277_760) (Bytes 109_951_162_777_600) -> (Bytes 109_951_162_777_600) (Bytes 1_125_899_906_842_624) -> (Bytes 1_125_899_906_842_624) (Bytes 11_258_999_068_426_240) -> (Bytes 11_258_999_068_426_240) (Bytes 112_589_990_684_262_400) -> (Bytes 112_589_990_684_262_400) (Bytes 1_152_921_504_606_846_976) -> (Bytes 1_152_921_504_606_846_976) (Bytes -1) -> (Bytes -1) (Bytes -10_000) -> (Bytes -10_000) (Bytes -10_000_000) -> (Bytes -10_000_000) |}] ;; let print_all_of_string of_string = List.iter ~f:(fun str -> match of_string str with | t -> printf !"%s -> %{sexp:Byte_units.Stable.V2.t}\n" str t | exception exn -> printf !"%s -> ERROR %{Exn}\n" str exn) ;; let print_all_of_sexp of_sexp = print_all_of_string (fun str -> Sexp.of_string_conv_exn str of_sexp) ;; let%expect_test "Byte_units.of_string" = print_all_of_string Byte_units.of_string [ "1b"; "100000b"; "0.1k"; "1k"; "1.1k"; "1m"; "10g"; "100t"; "10p"; "1e" ]; [%expect {| 1b -> (Bytes 1) 100000b -> (Bytes 100_000) 0.1k -> (Bytes 102) 1k -> (Bytes 1_024) 1.1k -> (Bytes 1_126) 1m -> (Bytes 1_048_576) 10g -> (Bytes 10_737_418_240) 100t -> (Bytes 109_951_162_777_600) 10p -> (Bytes 11_258_999_068_426_240) 1e -> (Bytes 1_152_921_504_606_846_976) |}] ;; let%expect_test "Byte_units.Stable.V1.t_of_sexp" = print_all_of_sexp Byte_units.Stable.V1.t_of_sexp [ "1b" ; "100b" ; "1.5k" ; "12m" ; "123g" ; "1.234t" ; "0.5p" ; "1.9e" ; "(Bytes 1)" ; "(Bytes 10.1)" ; "(Kilobytes 1.1)" ; "(Kilobytes 10)" ; "(Megabytes 100)" ; "(Gigabytes 1000)" ]; [%expect {| 1b -> (Bytes 1) 100b -> (Bytes 100) 1.5k -> (Bytes 1_536) 12m -> (Bytes 12_582_912) 123g -> (Bytes 132_070_244_352) 1.234t -> (Bytes 1_356_797_348_675) 0.5p -> (Bytes 562_949_953_421_312) 1.9e -> (Bytes 2_190_550_858_753_009_152) (Bytes 1) -> (Bytes 1) (Bytes 10.1) -> (Bytes 10) (Kilobytes 1.1) -> (Bytes 1_126) (Kilobytes 10) -> (Bytes 10_240) (Megabytes 100) -> (Bytes 104_857_600) (Gigabytes 1000) -> (Bytes 1_073_741_824_000) |}] ;; let%expect_test "Byte_units.Stable.V2.t_of_sexp" = print_all_of_sexp Byte_units.Stable.V2.t_of_sexp [ "(Bytes 1)"; "(Bytes 10)"; "(Bytes 100)" ]; [%expect {| (Bytes 1) -> (Bytes 1) (Bytes 10) -> (Bytes 10) (Bytes 100) -> (Bytes 100) |}] ;; let%expect_test "Byte_units.Stable.V1" = print_and_check_stable_type [%here] (module Byte_units.Stable.V1) examples; [%expect {| (bin_shape_digest 1fd923acb2dd9c5d401ad5b08b1d40cd) ((sexp (Bytes 0)) (bin_io "\000\000\000\000\000\000\000\000")) ((sexp (Bytes 1)) (bin_io "\000\000\000\000\000\000\240?")) ((sexp (Bytes 10)) (bin_io "\000\000\000\000\000\000$@")) ((sexp (Bytes 100)) (bin_io "\000\000\000\000\000\000Y@")) ((sexp (Bytes 1000)) (bin_io "\000\000\000\000\000@\143@")) ((sexp (Kilobytes 9.765625)) (bin_io "\000\000\000\000\000\136\195@")) ((sexp (Kilobytes 97.65625)) (bin_io "\000\000\000\000\000j\248@")) ((sexp (Kilobytes 976.5625)) (bin_io "\000\000\000\000\128\132.A")) ((sexp (Bytes 102)) (bin_io "\000\000\000\000\000\128Y@")) ((sexp (Kilobytes 1)) (bin_io "\000\000\000\000\000\000\144@")) ((sexp (Kilobytes 1.099609375)) (bin_io "\000\000\000\000\000\152\145@")) ((sexp (Kilobytes 10)) (bin_io "\000\000\000\000\000\000\196@")) ((sexp (Kilobytes 100)) (bin_io "\000\000\000\000\000\000\249@")) ((sexp (Megabytes 1)) (bin_io "\000\000\000\000\000\0000A")) ((sexp (Megabytes 10)) (bin_io "\000\000\000\000\000\000dA")) ((sexp (Megabytes 100)) (bin_io "\000\000\000\000\000\000\153A")) ((sexp (Gigabytes 1)) (bin_io "\000\000\000\000\000\000\208A")) ((sexp (Gigabytes 10)) (bin_io "\000\000\000\000\000\000\004B")) ((sexp (Gigabytes 100)) (bin_io "\000\000\000\000\000\0009B")) ((sexp (Gigabytes 1024)) (bin_io "\000\000\000\000\000\000pB")) ((sexp (Gigabytes 10240)) (bin_io "\000\000\000\000\000\000\164B")) ((sexp (Gigabytes 102400)) (bin_io "\000\000\000\000\000\000\217B")) ((sexp (Gigabytes 1048576)) (bin_io "\000\000\000\000\000\000\016C")) ((sexp (Gigabytes 10485760)) (bin_io "\000\000\000\000\000\000DC")) ((sexp (Gigabytes 104857600)) (bin_io "\000\000\000\000\000\000yC")) ((sexp (Gigabytes 1073741824)) (bin_io "\000\000\000\000\000\000\176C")) ((sexp (Bytes -1)) (bin_io "\000\000\000\000\000\000\240\191")) ((sexp (Kilobytes -9.765625)) (bin_io "\000\000\000\000\000\136\195\192")) ((sexp (Megabytes -9.5367431640625)) (bin_io "\000\000\000\000\208\018c\193")) |}] ;; let%expect_test "Byte_units.Stable.V2" = print_and_check_stable_type [%here] (module Byte_units.Stable.V2) examples; [%expect {| (bin_shape_digest 2b528f4b22f08e28876ffe0239315ac2) ((sexp (Bytes 0)) (bin_io "\000")) ((sexp (Bytes 1)) (bin_io "\001")) ((sexp (Bytes 10)) (bin_io "\n")) ((sexp (Bytes 100)) (bin_io d)) ((sexp (Bytes 1_000)) (bin_io "\254\232\003")) ((sexp (Bytes 10_000)) (bin_io "\254\016'")) ((sexp (Bytes 100_000)) (bin_io "\253\160\134\001\000")) ((sexp (Bytes 1_000_000)) (bin_io "\253@B\015\000")) ((sexp (Bytes 102)) (bin_io f)) ((sexp (Bytes 1_024)) (bin_io "\254\000\004")) ((sexp (Bytes 1_126)) (bin_io "\254f\004")) ((sexp (Bytes 10_240)) (bin_io "\254\000(")) ((sexp (Bytes 102_400)) (bin_io "\253\000\144\001\000")) ((sexp (Bytes 1_048_576)) (bin_io "\253\000\000\016\000")) ((sexp (Bytes 10_485_760)) (bin_io "\253\000\000\160\000")) ((sexp (Bytes 104_857_600)) (bin_io "\253\000\000@\006")) ((sexp (Bytes 1_073_741_824)) (bin_io "\253\000\000\000@")) ((sexp (Bytes 10_737_418_240)) (bin_io "\252\000\000\000\128\002\000\000\000")) ((sexp (Bytes 107_374_182_400)) (bin_io "\252\000\000\000\000\025\000\000\000")) ((sexp (Bytes 1_099_511_627_776)) (bin_io "\252\000\000\000\000\000\001\000\000")) ((sexp (Bytes 10_995_116_277_760)) (bin_io "\252\000\000\000\000\000\n\000\000")) ((sexp (Bytes 109_951_162_777_600)) (bin_io "\252\000\000\000\000\000d\000\000")) ((sexp (Bytes 1_125_899_906_842_624)) (bin_io "\252\000\000\000\000\000\000\004\000")) ((sexp (Bytes 11_258_999_068_426_240)) (bin_io "\252\000\000\000\000\000\000(\000")) ((sexp (Bytes 112_589_990_684_262_400)) (bin_io "\252\000\000\000\000\000\000\144\001")) ((sexp (Bytes 1_152_921_504_606_846_976)) (bin_io "\252\000\000\000\000\000\000\000\016")) ((sexp (Bytes -1)) (bin_io "\255\255")) ((sexp (Bytes -10_000)) (bin_io "\254\240\216")) ((sexp (Bytes -10_000_000)) (bin_io "\253\128ig\255")) |}] ;; (** Helper to ensure that our conversion functions round trip. *) let ensure_round_trippable (type via) (to_ : Byte_units.t -> via) (from : via -> Byte_units.t) ~tolerance = let equal a b = let open Float.Robustly_comparable in match tolerance with | `Zero -> [%compare.equal: Byte_units.t] a b | `Epsilon -> let a = Byte_units.bytes_float a in let b = Byte_units.bytes_float b in (b <=. a +. Float.one_ulp `Up a || b -. Float.one_ulp `Down b <=. a) && (a <=. b +. Float.one_ulp `Up b || a -. Float.one_ulp `Down a <=. b) | `Three_dp -> let a = Byte_units.bytes_float a in let b = Byte_units.bytes_float b in (a <=. b *. 1.005 || a *. 0.995 <=. b) && (b <=. a *. 1.005 || b *. 0.995 <=. a) in Int63.gen_log_uniform_incl Int63.zero Int63.max_value |> Quickcheck.Generator.map ~f:Byte_units.of_bytes_int63 |> Quickcheck.test ~f:(fun t -> [%test_eq: Byte_units.Stable.V2.t] ~equal t (from (to_ t))) ;; (** Quick check to excercise various round-trip relations *) let%test_unit "Byte_units.to_string / Byte_units.of_string" = ensure_round_trippable Byte_units.to_string Byte_units.of_string ~tolerance:`Epsilon ;; let%test_unit "Byte_units.to_string_hum / Byte_units.of_string" = ensure_round_trippable Byte_units.to_string_hum Byte_units.of_string ~tolerance:`Epsilon ;; let%test_unit "Byte_units.to_string_short / Byte_units.of_string" = ensure_round_trippable Byte_units.Short.to_string Byte_units.of_string ~tolerance:`Three_dp ;; let%test_unit "Byte_units.to_string / Byte_units.Stable.V1.t_of_sexp" = ensure_round_trippable Byte_units.to_string (Fn.flip Sexp.of_string_conv_exn Byte_units.Stable.V1.t_of_sexp) ~tolerance:`Epsilon ;; let%test_unit "Byte_units.to_string_hum / Byte_units.Stable.V1.t_of_sexp" = ensure_round_trippable Byte_units.to_string_hum (Fn.flip Sexp.of_string_conv_exn Byte_units.Stable.V1.t_of_sexp) ~tolerance:`Epsilon ;; let%test_unit "Byte_units.to_string_short / Byte_units.Stable.V1.t_of_sexp" = ensure_round_trippable Byte_units.Short.to_string (Fn.flip Sexp.of_string_conv_exn Byte_units.Stable.V1.t_of_sexp) ~tolerance:`Three_dp ;; let%test_unit "Byte_units.to_string / Byte_units.Stable.V2.t_of_sexp" = ensure_round_trippable Byte_units.to_string (Fn.flip Sexp.of_string_conv_exn Byte_units.Stable.V2.t_of_sexp) ~tolerance:`Epsilon ;; let%test_unit "Byte_units.to_string_hum / Byte_units.Stable.V2.t_of_sexp" = ensure_round_trippable Byte_units.to_string_hum (Fn.flip Sexp.of_string_conv_exn Byte_units.Stable.V2.t_of_sexp) ~tolerance:`Epsilon ;; let%test_unit "Byte_units.to_string_short / Byte_units.Stable.V2.t_of_sexp" = ensure_round_trippable Byte_units.Short.to_string (Fn.flip Sexp.of_string_conv_exn Byte_units.Stable.V2.t_of_sexp) ~tolerance:`Three_dp ;; let%test_unit "Byte_units.sexp_of_t / Byte_units.Stable.V1.t_of_sexp" = ensure_round_trippable Byte_units.sexp_of_t Byte_units.Stable.V1.t_of_sexp ~tolerance:`Epsilon ;; let%test_unit "Byte_units.sexp_of_t / Byte_units.Stable.V2.t_of_sexp" = ensure_round_trippable Byte_units.sexp_of_t Byte_units.Stable.V2.t_of_sexp ~tolerance:`Epsilon ;; let%test_unit "Byte_units.Stable.V1.sexp_of_t / Byte_units.Stable.V1.t_of_sexp" = ensure_round_trippable Byte_units.Stable.V1.sexp_of_t Byte_units.Stable.V1.t_of_sexp ~tolerance:`Epsilon ;; let%test_unit "Byte_units.Stable.V1.sexp_of_t / Byte_units.Stable.V2.t_of_sexp" = ensure_round_trippable Byte_units.Stable.V1.sexp_of_t Byte_units.Stable.V2.t_of_sexp ~tolerance:`Epsilon ;; let%test_unit "Byte_units.Stable.V2.sexp_of_t / Byte_units.Stable.V1.t_of_sexp" = ensure_round_trippable Byte_units.Stable.V2.sexp_of_t Byte_units.Stable.V1.t_of_sexp ~tolerance:`Epsilon ;; let%test_unit "Byte_units.Stable.V2.sexp_of_t / Byte_units.Stable.V2.t_of_sexp" = ensure_round_trippable Byte_units.Stable.V2.sexp_of_t Byte_units.Stable.V2.t_of_sexp ~tolerance:`Zero ;; core-0.15.0/core/test/src/test_char.ml000066400000000000000000000007631420273305200175350ustar00rootroot00000000000000open! Core open! Import open! Char let%test_module "Caseless Comparable" = (module struct let%test _ = Int.equal (Base.Map.find_exn (Caseless.Map.of_alist_exn [ 'a', 4; 'b', 5 ]) 'A') 4 ;; let%test _ = Base.Set.mem (Caseless.Set.of_list [ 'a'; 'b' ]) 'A' let%test _ = Int.equal (Base.Set.length (Caseless.Set.of_list [ 'a'; 'A' ])) 1 end) ;; let%test_module "Caseless Hash" = (module struct let%test _ = Int.equal (Caseless.hash 'a') (Caseless.hash 'A') end) ;; core-0.15.0/core/test/src/test_char.mli000066400000000000000000000000551420273305200177000ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_command_shape.ml000066400000000000000000000074611420273305200214200ustar00rootroot00000000000000open! Core open! Command.Shape module Entry = struct type t = { name_length : int ; doc_length : int ; aliases : string list } let create ?(aliases = []) name_length doc_length = { name_length; doc_length; aliases } let generate_string ~spaces length = List.init length ~f:(fun x -> if x % 10 = 0 && spaces then ' ' else 'a') |> String.of_char_list ;; let to_flag_info ~idx { name_length; doc_length; aliases } = let prefix = sprintf "%d-" idx in let name_suffix_length = name_length - String.length prefix in let name = generate_string name_suffix_length ~spaces:false in let doc = generate_string doc_length ~spaces:true in { Flag_info.name = prefix ^ name; doc; aliases } ;; end let display entries = List.mapi entries ~f:(fun idx entry -> Entry.to_flag_info entry ~idx) |> Flag_help_display.to_string |> print_endline ;; let%expect_test "somewhat typical flag arrangement" = display [ Entry.create 7 10 ; Entry.create 17 100 ~aliases:[ "hi" ] ; Entry.create 27 30 ; Entry.create 37 40 ]; [%expect {| 0-aaaaa . aaaaaaaaa 1-aaaaaaaaaaaaaaa, hi . aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa 2-aaaaaaaaaaaaaaaaaaaaaaaaa . aaaaaaaaa aaaaaaaaa aaaaaaaaa 3-aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa . aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa |}] ;; let%expect_test "one flag with lots of doc" = display [ Entry.create 26 400 ; Entry.create 3 5 ; Entry.create 15 50 ~aliases:[ "something1"; "alias2" ] ]; [%expect {| 0-aaaaaaaaaaaaaaaaaaaaaaaa . aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa 1-a . aaaa 2-aaaaaaaaaaaaa, something1, alias2 . aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa |}] ;; let%expect_test "only one long flag" = display [ Entry.create 66 400 ; Entry.create 3 5 ~aliases:[ "an-alias"; "another-alias" ] ; Entry.create 4 50 ]; [%expect {| 0-aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa . aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa 1-a, an-alias, another-alias . aaaa 2-aa . aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa aaaaaaaaa |}] ;; let%expect_test "some have docs some don't" = display [ Entry.create 20 5 ; Entry.create 10 0 ~aliases:[ "an-alias"; "another-alias" ] ; Entry.create 12 0 ; Entry.create 3 20 ]; [%expect {| 0-aaaaaaaaaaaaaaaaaa . aaaa 1-aaaaaaaa, an-alias, another-alias 2-aaaaaaaaaa . 3-a . aaaaaaaaa aaaaaaaaa |}] ;; core-0.15.0/core/test/src/test_command_shape.mli000066400000000000000000000000551420273305200215610ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_date.ml000066400000000000000000000477221420273305200175430ustar00rootroot00000000000000open! Core open! Import open! Date open! Date.Private let%expect_test _ = print_and_check_container_sexps [%here] (module Date) [ Date.of_string "1955-11-12" ; Date.of_string "1985-10-26" ; Date.of_string "2015-10-21" ]; [%expect {| (Set (1955-11-12 1985-10-26 2015-10-21)) (Map ( (1955-11-12 0) (1985-10-26 1) (2015-10-21 2))) (Hash_set (1955-11-12 1985-10-26 2015-10-21)) (Table ( (1955-11-12 0) (1985-10-26 1) (2015-10-21 2))) |}] ;; let%expect_test "Date.V1" = let examples = [ Date.create_exn ~y:1066 ~m:Oct ~d:16 ; Date.create_exn ~y:1955 ~m:Nov ~d:5 ; Date.create_exn ~y:2012 ~m:Apr ~d:19 ] in print_and_check_stable_type [%here] (module Date.Stable.V1) examples; [%expect {| (bin_shape_digest 47681bb034560d96024e1b2eca0d98ca) ((sexp 1066-10-16) (bin_io "\254*\004\t\016")) ((sexp 1955-11-05) (bin_io "\254\163\007\n\005")) ((sexp 2012-04-19) (bin_io "\254\220\007\003\019")) |}]; List.iter examples ~f:(fun date -> let int = Date.Stable.V1.to_int date in print_s [%sexp (date : Date.Stable.V1.t), (int : int)]; let round_trip = Date.Stable.V1.of_int_exn int in require_compare_equal [%here] (module Date.Stable.V1) date round_trip); [%expect {| (1066-10-16 69_863_952) (1955-11-05 128_125_701) (2012-04-19 131_859_475) |}]; require_does_raise [%here] (fun () -> Date.Stable.V1.of_int_exn 0); [%expect {| (Failure "Month.of_int_exn 0") |}] ;; let%expect_test "Date.V1.Set" = print_and_check_stable_type [%here] (module Date.Stable.V1.Set) [ Date.Set.empty ; Date.Set.singleton (Date.create_exn ~y:1066 ~m:Oct ~d:16) ; Date.Set.of_list [ Date.create_exn ~y:1955 ~m:Nov ~d:5; Date.create_exn ~y:2012 ~m:Apr ~d:19 ] ; Date.Set.of_list [ Date.create_exn ~y:1066 ~m:Oct ~d:16 ; Date.create_exn ~y:1955 ~m:Nov ~d:5 ; Date.create_exn ~y:2012 ~m:Apr ~d:19 ] ]; [%expect {| (bin_shape_digest ccde15fc17afce11a067d80e40cb1e8d) ((sexp ()) (bin_io "\000")) ((sexp (1066-10-16)) (bin_io "\001\254*\004\t\016")) ((sexp (1955-11-05 2012-04-19)) (bin_io "\002\254\163\007\n\005\254\220\007\003\019")) ((sexp (1066-10-16 1955-11-05 2012-04-19)) (bin_io "\003\254*\004\t\016\254\163\007\n\005\254\220\007\003\019")) |}] ;; let%expect_test "Date.V1.Map" = let module T = struct type t = string Date.Stable.V1.Map.t [@@deriving bin_io, compare, sexp] end in print_and_check_stable_type [%here] (module T) [ Date.Map.empty ; Date.Map.singleton (Date.create_exn ~y:1066 ~m:Oct ~d:16) "not the Battle of Hastings" ; Date.Map.of_alist_exn [ Date.create_exn ~y:1955 ~m:Nov ~d:5, "flux capacitor" ; Date.create_exn ~y:2012 ~m:Apr ~d:19, "a Thursday" ] ; Date.Map.of_alist_exn [ Date.create_exn ~y:1066 ~m:Oct ~d:16, "not the Battle of Hastings" ; Date.create_exn ~y:1955 ~m:Nov ~d:5, "flux capacitor" ; Date.create_exn ~y:2012 ~m:Apr ~d:19, "a Thursday" ] ]; [%expect {| (bin_shape_digest a0aa3c6d1173d784fbd03980ac5d0be5) ((sexp ()) (bin_io "\000")) ((sexp ((1066-10-16 "not the Battle of Hastings"))) (bin_io "\001\254*\004\t\016\026not the Battle of Hastings")) ((sexp ( (1955-11-05 "flux capacitor") (2012-04-19 "a Thursday"))) (bin_io "\002\254\163\007\n\005\014flux capacitor\254\220\007\003\019\na Thursday")) ((sexp ( (1066-10-16 "not the Battle of Hastings") (1955-11-05 "flux capacitor") (2012-04-19 "a Thursday"))) (bin_io "\003\254*\004\t\016\026not the Battle of Hastings\254\163\007\n\005\014flux capacitor\254\220\007\003\019\na Thursday")) |}] ;; let%expect_test "Date.Option.V1" = let date_examples = [ Date.create_exn ~y:1066 ~m:Oct ~d:16 ; Date.create_exn ~y:1955 ~m:Nov ~d:5 ; Date.create_exn ~y:2012 ~m:Apr ~d:19 ] in let date_opt_examples = Date.Option.none :: List.map date_examples ~f:Date.Option.some in print_and_check_stable_type [%here] (module Date.Stable.Option.V1) date_opt_examples; [%expect {| (bin_shape_digest aff59493f3c14f005635a016cd36c44b) ((sexp ()) (bin_io "\000")) ((sexp (1066-10-16)) (bin_io "\253\016\n*\004")) ((sexp (1955-11-05)) (bin_io "\253\005\011\163\007")) ((sexp (2012-04-19)) (bin_io "\253\019\004\220\007")) |}] ;; let%expect_test "create_exn doesn't allocate" = let y, m, d = Sys.opaque_identity (1999, Month.Dec, 31) in require_no_allocation [%here] (fun () -> ignore (Sys.opaque_identity (Date.create_exn ~y ~m ~d) : Date.t)); [%expect {| |}] ;; let%test_unit "creation and destruction" = let test y m d = let t = Date.create_exn ~y ~m ~d in [%test_result: int] ~expect:y (Date.year t); [%test_result: Month.t] ~expect:m (Date.month t); [%test_result: int] ~expect:d (Date.day t) in test 2014 Month.Sep 24; test 9999 Month.Dec 31 ;; let%expect_test "add_years" = let test string = let date = Date.of_string string in for years = -4 to 4 do let date_plus_years = Date.add_years date years in printf !"%{Date} + %2d years = %{Date}\n" date years date_plus_years done in (* non-leap day *) test "2013-10-07"; [%expect {| 2013-10-07 + -4 years = 2009-10-07 2013-10-07 + -3 years = 2010-10-07 2013-10-07 + -2 years = 2011-10-07 2013-10-07 + -1 years = 2012-10-07 2013-10-07 + 0 years = 2013-10-07 2013-10-07 + 1 years = 2014-10-07 2013-10-07 + 2 years = 2015-10-07 2013-10-07 + 3 years = 2016-10-07 2013-10-07 + 4 years = 2017-10-07 |}]; (* leap day maps to Feb 28 on non-leap years (and 400-year century behaves properly) *) test "2004-02-29"; [%expect {| 2004-02-29 + -4 years = 2000-02-29 2004-02-29 + -3 years = 2001-02-28 2004-02-29 + -2 years = 2002-02-28 2004-02-29 + -1 years = 2003-02-28 2004-02-29 + 0 years = 2004-02-29 2004-02-29 + 1 years = 2005-02-28 2004-02-29 + 2 years = 2006-02-28 2004-02-29 + 3 years = 2007-02-28 2004-02-29 + 4 years = 2008-02-29 |}]; (* non-leap year century behaves properly *) test "1904-02-29"; [%expect {| 1904-02-29 + -4 years = 1900-02-28 1904-02-29 + -3 years = 1901-02-28 1904-02-29 + -2 years = 1902-02-28 1904-02-29 + -1 years = 1903-02-28 1904-02-29 + 0 years = 1904-02-29 1904-02-29 + 1 years = 1905-02-28 1904-02-29 + 2 years = 1906-02-28 1904-02-29 + 3 years = 1907-02-28 1904-02-29 + 4 years = 1908-02-29 |}] ;; let%test_module "week_number and week_number_and_year" = (module struct let%test_unit _ = [%test_result: int] (ordinal_date (create_exn ~y:2014 ~m:Jan ~d:1)) ~expect:1 ;; let%test_unit _ = [%test_result: int] (ordinal_date (create_exn ~y:2014 ~m:Dec ~d:31)) ~expect:365 ;; let%test_unit _ = [%test_result: int] (ordinal_date (create_exn ~y:2014 ~m:Feb ~d:28)) ~expect:59 ;; let test_week_number_and_year y m d ~expect = [%test_result: int] (week_number (create_exn ~y ~m ~d)) ~expect:(fst expect); [%test_result: int * int] (week_number_and_year (create_exn ~y ~m ~d)) ~expect ;; let%test_unit _ = test_week_number_and_year 2014 Jan 1 ~expect:(1, 2014) let%test_unit _ = test_week_number_and_year 2014 Dec 31 ~expect:(1, 2015) let%test_unit _ = test_week_number_and_year 2010 Jan 1 ~expect:(53, 2009) let%test_unit _ = test_week_number_and_year 2017 Jan 1 ~expect:(52, 2016) let%test_unit _ = test_week_number_and_year 2014 Jan 10 ~expect:(2, 2014) let%test_unit _ = test_week_number_and_year 2012 Jan 1 ~expect:(52, 2011) let%test_unit _ = test_week_number_and_year 2012 Dec 31 ~expect:(1, 2013) end) ;; let%test_module "diff_weekdays" = (module struct let c y m d = create_exn ~y ~m ~d let%test "2014 Jan 1 is a Wednesday" = Day_of_week.( = ) (day_of_week (c 2014 Jan 1)) Day_of_week.Wed ;; let ( = ) = Int.( = ) (* future minus Wednesday *) let%test _ = diff_weekdays (c 2014 Jan 1) (c 2014 Jan 1) = 0 let%test _ = diff_weekdays (c 2014 Jan 2) (c 2014 Jan 1) = 1 let%test _ = diff_weekdays (c 2014 Jan 3) (c 2014 Jan 1) = 2 let%test _ = diff_weekdays (c 2014 Jan 4) (c 2014 Jan 1) = 3 let%test _ = diff_weekdays (c 2014 Jan 5) (c 2014 Jan 1) = 3 let%test _ = diff_weekdays (c 2014 Jan 6) (c 2014 Jan 1) = 3 let%test _ = diff_weekdays (c 2014 Jan 7) (c 2014 Jan 1) = 4 let%test _ = diff_weekdays (c 2014 Jan 8) (c 2014 Jan 1) = 5 let%test _ = diff_weekdays (c 2014 Jan 9) (c 2014 Jan 1) = 6 let%test _ = diff_weekdays (c 2014 Jan 10) (c 2014 Jan 1) = 7 let%test _ = diff_weekdays (c 2014 Jan 11) (c 2014 Jan 1) = 8 let%test _ = diff_weekdays (c 2014 Jan 12) (c 2014 Jan 1) = 8 let%test _ = diff_weekdays (c 2014 Jan 13) (c 2014 Jan 1) = 8 let%test _ = diff_weekdays (c 2014 Jan 14) (c 2014 Jan 1) = 9 (* Wednesday minus future *) let%test _ = diff_weekdays (c 2014 Jan 1) (c 2014 Jan 2) = -1 let%test _ = diff_weekdays (c 2014 Jan 1) (c 2014 Jan 3) = -2 let%test _ = diff_weekdays (c 2014 Jan 1) (c 2014 Jan 4) = -3 let%test _ = diff_weekdays (c 2014 Jan 1) (c 2014 Jan 5) = -3 let%test _ = diff_weekdays (c 2014 Jan 1) (c 2014 Jan 6) = -3 let%test _ = diff_weekdays (c 2014 Jan 1) (c 2014 Jan 7) = -4 let%test _ = diff_weekdays (c 2014 Jan 1) (c 2014 Jan 8) = -5 let%test _ = diff_weekdays (c 2014 Jan 1) (c 2014 Jan 9) = -6 (* diff_weekend_days *) let%test _ = diff_weekend_days (c 2014 Jan 1) (c 2014 Jan 1) = 0 let%test _ = diff_weekend_days (c 2014 Jan 2) (c 2014 Jan 1) = 0 let%test _ = diff_weekend_days (c 2014 Jan 3) (c 2014 Jan 1) = 0 let%test _ = diff_weekend_days (c 2014 Jan 4) (c 2014 Jan 1) = 0 let%test _ = diff_weekend_days (c 2014 Jan 5) (c 2014 Jan 1) = 1 let%test _ = diff_weekend_days (c 2014 Jan 6) (c 2014 Jan 1) = 2 let%test _ = diff_weekend_days (c 2014 Jan 7) (c 2014 Jan 1) = 2 let%test _ = diff_weekend_days (c 2014 Jan 8) (c 2014 Jan 1) = 2 let%test _ = diff_weekend_days (c 2014 Jan 9) (c 2014 Jan 1) = 2 let%test _ = diff_weekend_days (c 2014 Jan 10) (c 2014 Jan 1) = 2 let%test _ = diff_weekend_days (c 2014 Jan 11) (c 2014 Jan 1) = 2 let%test _ = diff_weekend_days (c 2014 Jan 12) (c 2014 Jan 1) = 3 let%test _ = diff_weekend_days (c 2014 Jan 13) (c 2014 Jan 1) = 4 let%test _ = diff_weekend_days (c 2014 Jan 14) (c 2014 Jan 1) = 4 end) ;; let%test_module "adding weekdays and business days" = (module struct let test alist day_of_week date_string = let date = Date.of_string date_string in require_equal [%here] (module Day_of_week) day_of_week (Date.day_of_week date); List.iter alist ~f:(fun (name, round_and_add) -> let list = List.map [ -2; -1; 0; 1; 2 ] ~f:(fun increment -> let date = round_and_add date increment in let day_of_week = Date.day_of_week date in increment, day_of_week, date) in print_s [%sexp (name : string), (list : (int * Day_of_week.t * Date.t) list)]) ;; let%expect_test "weekdays" = let open Day_of_week in let test = test [ "add_weekdays_rounding_backward", add_weekdays_rounding_backward ; "add_weekdays_rounding_forward", add_weekdays_rounding_forward ] in (* Friday *) test Fri "2019-05-03"; [%expect {| (add_weekdays_rounding_backward ( (-2 WED 2019-05-01) (-1 THU 2019-05-02) (0 FRI 2019-05-03) (1 MON 2019-05-06) (2 TUE 2019-05-07))) (add_weekdays_rounding_forward ( (-2 WED 2019-05-01) (-1 THU 2019-05-02) (0 FRI 2019-05-03) (1 MON 2019-05-06) (2 TUE 2019-05-07))) |}]; (* Saturday, Sunday: both round back to Friday or forward to Monday *) List.iter [ Sat, "2019-05-04"; Sun, "2019-05-05" ] ~f:(fun (day_of_week, date_string) -> test day_of_week date_string; [%expect {| (add_weekdays_rounding_backward ( (-2 WED 2019-05-01) (-1 THU 2019-05-02) (0 FRI 2019-05-03) (1 MON 2019-05-06) (2 TUE 2019-05-07))) (add_weekdays_rounding_forward ( (-2 THU 2019-05-02) (-1 FRI 2019-05-03) (0 MON 2019-05-06) (1 TUE 2019-05-07) (2 WED 2019-05-08))) |}]); (* Monday *) test Mon "2019-05-06"; [%expect {| (add_weekdays_rounding_backward ( (-2 THU 2019-05-02) (-1 FRI 2019-05-03) (0 MON 2019-05-06) (1 TUE 2019-05-07) (2 WED 2019-05-08))) (add_weekdays_rounding_forward ( (-2 THU 2019-05-02) (-1 FRI 2019-05-03) (0 MON 2019-05-06) (1 TUE 2019-05-07) (2 WED 2019-05-08))) |}] ;; let%expect_test "business days" = let open Day_of_week in let test = let is_holiday = Date.equal (Date.of_string "2019-05-06") in test [ ( "add_business_days_rounding_backward" , add_business_days_rounding_backward ~is_holiday ) ; ( "add_business_days_rounding_forward" , add_business_days_rounding_forward ~is_holiday ) ] in (* Friday *) test Fri "2019-05-03"; [%expect {| (add_business_days_rounding_backward ( (-2 WED 2019-05-01) (-1 THU 2019-05-02) (0 FRI 2019-05-03) (1 TUE 2019-05-07) (2 WED 2019-05-08))) (add_business_days_rounding_forward ( (-2 WED 2019-05-01) (-1 THU 2019-05-02) (0 FRI 2019-05-03) (1 TUE 2019-05-07) (2 WED 2019-05-08))) |}]; (* Saturday, Sunday, Monday: all round back to Friday or forward to Tuesday *) List.iter [ Sat, "2019-05-04"; Sun, "2019-05-05"; Mon, "2019-05-06" ] ~f:(fun (day_of_week, date_string) -> test day_of_week date_string; [%expect {| (add_business_days_rounding_backward ( (-2 WED 2019-05-01) (-1 THU 2019-05-02) (0 FRI 2019-05-03) (1 TUE 2019-05-07) (2 WED 2019-05-08))) (add_business_days_rounding_forward ( (-2 THU 2019-05-02) (-1 FRI 2019-05-03) (0 TUE 2019-05-07) (1 WED 2019-05-08) (2 THU 2019-05-09))) |}]); (* Tuesday *) test Tue "2019-05-07"; [%expect {| (add_business_days_rounding_backward ( (-2 THU 2019-05-02) (-1 FRI 2019-05-03) (0 TUE 2019-05-07) (1 WED 2019-05-08) (2 THU 2019-05-09))) (add_business_days_rounding_forward ( (-2 THU 2019-05-02) (-1 FRI 2019-05-03) (0 TUE 2019-05-07) (1 WED 2019-05-08) (2 THU 2019-05-09))) |}] ;; end) ;; let%test_module "ordinal_date" = (module struct (* check the ordinal date tables we found on wikipedia... *) let check_table year ordinal_date_table = let days_of_year = dates_between ~min:(create_exn ~y:year ~m:Month.Jan ~d:01) ~max:(create_exn ~y:year ~m:Month.Dec ~d:31) in [%test_result: int] (List.length days_of_year) ~expect:(if is_leap_year ~year then 366 else 365); let months = List.group days_of_year ~break:(fun d d' -> Month.( <> ) (month d) (month d')) in let sum = List.foldi months ~init:0 ~f:(fun index sum month -> [%test_result: int] sum ~expect:ordinal_date_table.(index); sum + List.length month) in [%test_result: int] sum ~expect:(List.length days_of_year) ;; let%test_unit _ = check_table 2015 non_leap_year_table let%test_unit _ = check_table 2000 leap_year_table end) ;; let%test_module "weekdays_between" = (module struct let c y m d = create_exn ~y ~m ~d (* systematic test of consistency between [weekdays_between] and [diff_weekdays] *) let dates = [ c 2014 Jan 1 ; c 2014 Jan 2 ; c 2014 Jan 3 ; c 2014 Jan 4 ; c 2014 Jan 5 ; c 2014 Jan 6 ; c 2014 Jan 7 ; c 2014 Feb 15 ; c 2014 Feb 16 ; c 2014 Feb 17 ; c 2014 Feb 18 ; c 2014 Feb 19 ; c 2014 Feb 20 ; c 2014 Feb 21 ] ;; let ( = ) = Int.( = ) let%test_unit _ = List.iter dates ~f:(fun date1 -> List.iter dates ~f:(fun date2 -> if date1 <= date2 then assert ( List.length (weekdays_between ~min:date1 ~max:(add_days date2 (-1))) = diff_weekdays date2 date1))) ;; end) ;; let%test_module "first_strictly_after" = (module struct let mon1 = create_exn ~y:2013 ~m:Month.Apr ~d:1 let tue1 = create_exn ~y:2013 ~m:Month.Apr ~d:2 let wed1 = create_exn ~y:2013 ~m:Month.Apr ~d:3 let thu1 = create_exn ~y:2013 ~m:Month.Apr ~d:4 let fri1 = create_exn ~y:2013 ~m:Month.Apr ~d:5 let sat1 = create_exn ~y:2013 ~m:Month.Apr ~d:6 let sun1 = create_exn ~y:2013 ~m:Month.Apr ~d:7 let mon2 = create_exn ~y:2013 ~m:Month.Apr ~d:8 let tue2 = create_exn ~y:2013 ~m:Month.Apr ~d:9 let%test _ = equal (first_strictly_after tue1 ~on:Day_of_week.Mon) mon2 let%test _ = equal (first_strictly_after tue1 ~on:Day_of_week.Tue) tue2 let%test _ = equal (first_strictly_after tue1 ~on:Day_of_week.Wed) wed1 let%test _ = equal (first_strictly_after tue1 ~on:Day_of_week.Thu) thu1 let%test _ = equal (first_strictly_after tue1 ~on:Day_of_week.Fri) fri1 let%test _ = equal (first_strictly_after tue1 ~on:Day_of_week.Sat) sat1 let%test _ = equal (first_strictly_after tue1 ~on:Day_of_week.Sun) sun1 let%test _ = equal (first_strictly_after mon1 ~on:Day_of_week.Mon) mon2 let%test _ = equal (first_strictly_after mon1 ~on:Day_of_week.Tue) tue1 let%test _ = equal (first_strictly_after mon1 ~on:Day_of_week.Wed) wed1 let%test _ = equal (first_strictly_after mon1 ~on:Day_of_week.Thu) thu1 let%test _ = equal (first_strictly_after mon1 ~on:Day_of_week.Fri) fri1 let%test _ = equal (first_strictly_after mon1 ~on:Day_of_week.Sat) sat1 let%test _ = equal (first_strictly_after mon1 ~on:Day_of_week.Sun) sun1 end) ;; let%test_unit _ = Quickcheck.test_can_generate quickcheck_generator ~sexp_of:sexp_of_t ~f:(fun t -> t = of_string "1900-01-01") ;; let%test_unit _ = Quickcheck.test_can_generate quickcheck_generator ~sexp_of:sexp_of_t ~f:(fun t -> t = of_string "2100-01-01") ;; let%test_unit _ = Quickcheck.test_can_generate quickcheck_generator ~sexp_of:sexp_of_t ~f:(fun t -> of_string "1900-01-01" < t && t < of_string "2100-01-01") ;; let%test_unit _ = Quickcheck.test_distinct_values quickcheck_generator ~sexp_of:sexp_of_t ~compare ~trials:1_000 ~distinct_values:500 ;; let%test_unit _ = Quickcheck.test_can_generate Date.Option.quickcheck_generator ~sexp_of:Date.Option.sexp_of_t ~f:(fun t -> Date.Option.equal t Date.Option.none) ;; let%test_unit _ = Quickcheck.test_can_generate Date.Option.quickcheck_generator ~sexp_of:Date.Option.sexp_of_t ~f:(fun t -> Date.Option.equal t (Date.Option.some (Date.of_string "1900-01-01"))) ;; let%test_unit _ = Quickcheck.test_can_generate Date.Option.quickcheck_generator ~sexp_of:Date.Option.sexp_of_t ~f:(fun t -> Date.Option.equal t (Date.Option.some (Date.of_string "2100-01-01"))) ;; let%test_unit _ = Quickcheck.test_can_generate Date.Option.quickcheck_generator ~sexp_of:Date.Option.sexp_of_t ~f:(fun t -> Date.Option.between t ~low:(Date.Option.some (Date.of_string "1900-01-01")) ~high:(Date.Option.some (Date.of_string "2100-01-01"))) ;; let%test_unit _ = Quickcheck.test_distinct_values Date.Option.quickcheck_generator ~sexp_of:Date.Option.sexp_of_t ~compare:Date.Option.compare ~trials:1_000 ~distinct_values:100 ;; core-0.15.0/core/test/src/test_date.mli000066400000000000000000000000551420273305200177000ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_day_of_week.ml000066400000000000000000000020111420273305200210600ustar00rootroot00000000000000open! Core open! Import open! Day_of_week let num_days_in_week = 7 let%test_module "Day_of_week.V1" = (module Stable_unit_test.Make (struct include Stable.V1 let equal = [%compare.equal: t] let tests = [ Sun, "SUN", "\000" ; Mon, "MON", "\001" ; Tue, "TUE", "\002" ; Wed, "WED", "\003" ; Thu, "THU", "\004" ; Fri, "FRI", "\005" ; Sat, "SAT", "\006" ] ;; end)) ;; let%test _ = List.is_sorted all ~compare let%test "to_string_long output parses with of_string" = List.for_all all ~f:(fun d -> d = (to_string_long d |> of_string)) ;; let%test _ = Int.(num_days ~from:Mon ~to_:Tue = 1) let%test _ = Int.(num_days ~from:Tue ~to_:Mon = 6) let%test "num_days is inverse to shift" = let all_days = [ Sun; Mon; Tue; Wed; Thu; Fri; Sat ] in List.for_all (List.cartesian_product all_days all_days) ~f:(fun (from, to_) -> let i = num_days ~from ~to_ in Int.(0 <= i && i < num_days_in_week) && shift from i = to_) ;; core-0.15.0/core/test/src/test_day_of_week.mli000066400000000000000000000000551420273305200212370ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_deque.ml000066400000000000000000000202311420273305200177130ustar00rootroot00000000000000open! Core open! Import open! Deque let%test_unit _ = ignore (create ~initial_length:0 () : _ t) let%test _ = length (create ()) = 0 let%test_module _ = (module struct let binary_search = binary_search ~compare:Int.compare let t = of_array [| 1; 2; 3; 4 |] let%test _ = [%equal: int option] (binary_search t `First_equal_to 2) (Some 1) let%test _ = [%equal: int option] (binary_search t `First_equal_to 5) None let%test _ = [%equal: int option] (binary_search t `First_equal_to 0) None let%test _ = [%equal: int option] (binary_search t ~pos:2 `First_equal_to 2) None let%test _ = [%equal: int option] (binary_search t ~pos:2 `First_equal_to 3) (Some 2) let (_ : int option) = dequeue_front t let (_ : int option) = dequeue_front t let%test _ = [%equal: int option] (binary_search t `First_equal_to 2) None let%test _ = [%equal: int option] (binary_search t `First_equal_to 3) (Some 2) let%test _ = [%equal: int option] (binary_search t `First_equal_to 5) None let%test _ = [%equal: int option] (binary_search t `First_equal_to 0) None let%test _ = [%equal: int option] (binary_search t ~pos:2 `First_equal_to 2) None let%test _ = [%equal: int option] (binary_search t ~pos:2 `First_equal_to 3) (Some 2) end) ;; let%test_module _ = (module struct let%test_unit _ = let q = create () in let bin_alpha _ = assert false in let pos_ref = ref 0 in assert (Int.( = ) (length q) 0); let bigstring = Bigstring.create (bin_size_t bin_alpha q) in ignore (bin_write_t bin_alpha bigstring ~pos:0 q : int); let q' = bin_read_t bin_alpha bigstring ~pos_ref in assert (Int.( = ) (length q') 0) ;; module type Deque_intf = sig type 'a t val create : unit -> 'a t val enqueue : 'a t -> [ `back | `front ] -> 'a -> unit val dequeue : 'a t -> [ `back | `front ] -> 'a option val to_array : 'a t -> 'a array val clear : 'a t -> unit val length : 'a t -> int val iter : 'a t -> f:('a -> unit) -> unit val fold' : 'a t -> [ `front_to_back | `back_to_front ] -> init:'b -> f:('b -> 'a -> 'b) -> 'b end module That_dequeue : Deque_intf = struct type 'a t = 'a Doubly_linked.t let create = Doubly_linked.create let enqueue t back_or_front v = match back_or_front with | `back -> ignore (Doubly_linked.insert_last t v : _ Doubly_linked.Elt.t) | `front -> ignore (Doubly_linked.insert_first t v : _ Doubly_linked.Elt.t) ;; let dequeue t back_or_front = match back_or_front with | `back -> Doubly_linked.remove_last t | `front -> Doubly_linked.remove_first t ;; let fold' t dir ~init ~f = match dir with | `front_to_back -> Doubly_linked.fold t ~init ~f | `back_to_front -> Doubly_linked.fold_right t ~init ~f:(fun x acc -> f acc x) ;; let to_array = Doubly_linked.to_array let clear = Doubly_linked.clear let iter = Doubly_linked.iter let length = Doubly_linked.length end module This_dequeue : Deque_intf = struct type nonrec 'a t = 'a t let create () = create () let enqueue = enqueue let dequeue = dequeue let to_array = to_array let clear = clear let length = length let iter = iter let fold' = fold' end let enqueue (t_a, t_b) back_or_front v = let start_a = This_dequeue.to_array t_a in let start_b = That_dequeue.to_array t_b in This_dequeue.enqueue t_a back_or_front v; That_dequeue.enqueue t_b back_or_front v; let end_a = This_dequeue.to_array t_a in let end_b = That_dequeue.to_array t_b in if not ([%equal: int array] end_a end_b) then failwithf "enqueue transition failure of: %s -> %s vs. %s -> %s" (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t start_a)) (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t end_a)) (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t start_b)) (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t end_b)) () ;; let dequeue (t_a, t_b) back_or_front = let start_a = This_dequeue.to_array t_a in let start_b = That_dequeue.to_array t_b in let a, b = This_dequeue.dequeue t_a back_or_front, That_dequeue.dequeue t_b back_or_front in let end_a = This_dequeue.to_array t_a in let end_b = That_dequeue.to_array t_b in if (not ([%equal: int option] a b)) || not ([%equal: int array] end_a end_b) then failwithf "error in dequeue: %s (%s -> %s) <> %s (%s -> %s)" (Option.value ~default:"None" (Option.map a ~f:Int.to_string)) (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t start_a)) (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t end_a)) (Option.value ~default:"None" (Option.map b ~f:Int.to_string)) (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t start_b)) (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t end_b)) () ;; let clear (t_a, t_b) = This_dequeue.clear t_a; That_dequeue.clear t_b ;; let create () = let t_a = This_dequeue.create () in let t_b = That_dequeue.create () in t_a, t_b ;; let this_to_string this_t = Sexp.to_string ([%sexp_of: int array] (This_dequeue.to_array this_t)) ;; let that_to_string that_t = Sexp.to_string ([%sexp_of: int array] (That_dequeue.to_array that_t)) ;; let fold_check (t_a, t_b) dir = let make_list fold t = fold t dir ~init:[] ~f:(fun acc x -> x :: acc) in let this_l = make_list This_dequeue.fold' t_a in let that_l = make_list That_dequeue.fold' t_b in if not ([%equal: int list] this_l that_l) then failwithf "error in fold: %s (from %s) <> %s (from %s)" (Sexp.to_string ([%sexp_of: int list] this_l)) (this_to_string t_a) (Sexp.to_string ([%sexp_of: int list] that_l)) (that_to_string t_b) () ;; let iter_check (t_a, t_b) = let make_rev_list iter t = let r = ref [] in iter t ~f:(fun x -> r := x :: !r); !r in let this_l = make_rev_list This_dequeue.iter t_a in let that_l = make_rev_list That_dequeue.iter t_b in if not ([%equal: int list] this_l that_l) then failwithf "error in iter: %s (from %s) <> %s (from %s)" (Sexp.to_string ([%sexp_of: int list] this_l)) (this_to_string t_a) (Sexp.to_string ([%sexp_of: int list] that_l)) (that_to_string t_b) () ;; let length_check (t_a, t_b) = let this_len = This_dequeue.length t_a in let that_len = That_dequeue.length t_b in if this_len <> that_len then failwithf "error in length: %i (for %s) <> %i (for %s)" this_len (this_to_string t_a) that_len (that_to_string t_b) () ;; let test () = let t = create () in let rec loop ops = if ops = 0 then ( let t_a, t_b = t in let arr_a = This_dequeue.to_array t_a in let arr_b = That_dequeue.to_array t_b in if not ([%equal: int array] arr_a arr_b) then failwithf "dequeue final states not equal: %s vs. %s" (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t arr_a)) (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t arr_b)) ()) else ( let r = Random.int 110 in if r < 20 then enqueue t `front (Random.int 10_000) else if r < 40 then enqueue t `back (Random.int 10_000) else if r < 50 then dequeue t `front else if r < 60 then dequeue t `back else if r < 70 then clear t else if r < 80 then fold_check t `front_to_back else if r < 90 then fold_check t `back_to_front else if r < 100 then iter_check t else length_check t; loop (ops - 1)) in loop 1_000 ;; let%test_unit _ = test () end) ;; core-0.15.0/core/test/src/test_deque.mli000066400000000000000000000000551420273305200200660ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_deriving_hash.ml000066400000000000000000000007121420273305200214240ustar00rootroot00000000000000open! Core open! Import module M1 = struct module T = struct type t = T of string end include T include Deriving_hash.Of_deriving_hash (String) (struct include T let to_repr (T s) = s end) end module M2 = struct type t = M1.t [@@deriving hash] end let%expect_test (_ [@tags "64-bits-only"]) = let s = "foo" in print_s [%sexp (String.hash s = M2.hash (T s) : bool)]; [%expect {| true |}] ;; core-0.15.0/core/test/src/test_deriving_hash.mli000066400000000000000000000000551420273305200215750ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_deriving_structures.ml000066400000000000000000000007101420273305200227220ustar00rootroot00000000000000open Core (* We just want to make sure all of this compiles. *) module Set_tests = struct type t = Set.M(Int).t [@@deriving compare, hash, sexp] end module Map_tests = struct type t0 = float Map.M(Int).t [@@deriving compare, hash, sexp] type 'a t1 = 'a Map.M(Bool).t [@@deriving compare, hash, sexp] end module Hashtbl_tests = struct type t0 = float Hashtbl.M(Int).t [@@deriving sexp] type 'a t1 = 'a Hashtbl.M(Bool).t [@@deriving sexp] end core-0.15.0/core/test/src/test_doubly_linked.ml000066400000000000000000000315731420273305200214470ustar00rootroot00000000000000open! Core open! Import open! Doubly_linked include Test_container.Test_S1 (Doubly_linked) let%test_unit _ = List.iter [ []; [ 1 ]; [ 2; 3 ] ] ~f:(fun l -> let sum = ref 0 in iter_elt (of_list l) ~f:(fun elt -> sum := !sum + Elt.value elt); assert (!sum = List.fold l ~init:0 ~f:( + ))) ;; module type Testable = sig type t [@@deriving compare, sexp_of] end let expect_test (type a) (module M : Testable with type t = a) t (expect : M.t list) = [%test_result: M.t list] (to_list t) ~expect ;; let expect_test_int = expect_test (module Int) let%test_module "move/set functions" = (module struct let n = 5 let test k expected = let t = create () in let a = Array.init n ~f:(fun i -> insert_last t i) in k t a; invariant ignore t; assert (length t = n); expect_test_int t expected ;; let%test_unit _ = test (fun _ _ -> ()) [ 0; 1; 2; 3; 4 ] let%test_unit _ = test (fun t a -> move_to_front t a.(4)) [ 4; 0; 1; 2; 3 ] let%test_unit _ = test (fun t a -> move_to_front t a.(3)) [ 3; 0; 1; 2; 4 ] let%test_unit _ = test (fun t a -> move_to_front t a.(2)) [ 2; 0; 1; 3; 4 ] let%test_unit _ = test (fun t a -> move_to_front t a.(1)) [ 1; 0; 2; 3; 4 ] let%test_unit _ = test (fun t a -> move_to_front t a.(0)) [ 0; 1; 2; 3; 4 ] let%test_unit _ = test (fun t a -> move_to_back t a.(0)) [ 1; 2; 3; 4; 0 ] let%test_unit _ = test (fun t a -> move_to_back t a.(1)) [ 0; 2; 3; 4; 1 ] let%test_unit _ = test (fun t a -> move_to_back t a.(2)) [ 0; 1; 3; 4; 2 ] let%test_unit _ = test (fun t a -> move_to_back t a.(3)) [ 0; 1; 2; 4; 3 ] let%test_unit _ = test (fun t a -> move_to_back t a.(4)) [ 0; 1; 2; 3; 4 ] let%test_unit _ = test (fun t a -> move_before t a.(2) ~anchor:a.(1)) [ 0; 2; 1; 3; 4 ] ;; let%test_unit _ = test (fun t a -> move_before t a.(2) ~anchor:a.(0)) [ 2; 0; 1; 3; 4 ] ;; let%test_unit _ = test (fun t a -> move_before t a.(1) ~anchor:a.(0)) [ 1; 0; 2; 3; 4 ] ;; let%test_unit _ = test (fun t a -> move_before t a.(0) ~anchor:a.(2)) [ 1; 0; 2; 3; 4 ] ;; let%test_unit _ = test (fun t a -> move_before t a.(0) ~anchor:a.(1)) [ 0; 1; 2; 3; 4 ] ;; let%test_unit _ = test (fun t a -> move_before t a.(3) ~anchor:a.(2)) [ 0; 1; 3; 2; 4 ] ;; let%test_unit _ = test (fun t a -> move_before t a.(2) ~anchor:a.(3)) [ 0; 1; 2; 3; 4 ] ;; let%test_unit _ = test (fun t a -> move_after t a.(1) ~anchor:a.(3)) [ 0; 2; 3; 1; 4 ] let%test_unit _ = test (fun t a -> move_after t a.(0) ~anchor:a.(2)) [ 1; 2; 0; 3; 4 ] let%test_unit _ = test (fun t a -> move_after t a.(1) ~anchor:a.(4)) [ 0; 2; 3; 4; 1 ] let%test_unit _ = test (fun t a -> move_after t a.(3) ~anchor:a.(2)) [ 0; 1; 2; 3; 4 ] let%test_unit _ = test (fun t a -> move_after t a.(2) ~anchor:a.(3)) [ 0; 1; 3; 2; 4 ] let%test_unit _ = test (fun _ a -> Elt.set a.(0) 5) [ 5; 1; 2; 3; 4 ] let%test_unit _ = test (fun _ a -> Elt.set a.(2) 6) [ 0; 1; 6; 3; 4 ] let%test_unit _ = test (fun _ a -> Elt.set a.(4) 7) [ 0; 1; 2; 3; 7 ] let%test_unit _ = test (fun _ a -> Elt.set a.(0) 5; Elt.set a.(4) 6; Elt.set a.(0) 7) [ 7; 1; 2; 3; 6 ] ;; end) ;; let%test_module "map functions" = (module struct let test (type a) (module M : Testable with type t = a) ~n k (expected : a list) = let t = create () in for i = 0 to n - 1 do insert_last t (i * 10) |> (ignore : int Elt.t -> unit) done; let new_t = k t in invariant ignore t; invariant ignore new_t; assert (length t = n); expect_test (module M) new_t expected ;; let test_int = test (module Int) ~n:5 let test_string = test (module String) ~n:5 let%test_unit _ = test_int (map ~f:(( + ) 1)) [ 1; 11; 21; 31; 41 ] let%test_unit _ = test_string (map ~f:Int.to_string) [ "0"; "10"; "20"; "30"; "40" ] let%test_unit _ = test_int (mapi ~f:( * )) [ 0; 10; 40; 90; 160 ] let%test_unit _ = test_string (mapi ~f:(fun i x -> Int.to_string i ^ "_" ^ Int.to_string x)) [ "0_0"; "1_10"; "2_20"; "3_30"; "4_40" ] ;; let%test_unit _ = test_int (filter ~f:(fun x -> x > 15)) [ 20; 30; 40 ] let%test_unit _ = test_int (filteri ~f:(fun _ x -> x > 15)) [ 20; 30; 40 ] let%test_unit _ = test_int (filteri ~f:(fun i _ -> i < 3)) [ 0; 10; 20 ] let%test_unit _ = test_int (filter_map ~f:(fun v -> Option.some_if (v < 25) (v + 1))) [ 1; 11; 21 ] ;; let%test_unit _ = test_string (filter_mapi ~f:(fun i v -> Option.some_if (i % 2 = 0) (Int.to_string v))) [ "0"; "20"; "40" ] ;; let%test_unit _ = test (module String) ~n:0 (map ~f:Int.to_string) [] let%test_unit _ = test (module String) ~n:1 (map ~f:Int.to_string) [ "0" ] let%test_unit _ = test (module String) ~n:0 (mapi ~f:(fun i _ -> Int.to_string i)) [] let%test_unit _ = test (module String) ~n:1 (mapi ~f:(fun i _ -> Int.to_string i)) [ "0" ] ;; end) ;; let%test_module "inplace functions" = (module struct let n = 5 let test k expected = let t = create () in for i = 0 to n - 1 do insert_last t (i * 10) |> (ignore : int Elt.t -> unit) done; k t; invariant ignore t; expect_test_int t expected ;; let%test_unit _ = test (map_inplace ~f:(( + ) 1)) [ 1; 11; 21; 31; 41 ] let%test_unit _ = test (mapi_inplace ~f:( * )) [ 0; 10; 40; 90; 160 ] let%test_unit _ = test (filter_inplace ~f:(fun x -> x > 15)) [ 20; 30; 40 ] let%test_unit _ = test (filteri_inplace ~f:(fun _ x -> x > 15)) [ 20; 30; 40 ] let%test_unit _ = test (filteri_inplace ~f:(fun i _ -> i < 3)) [ 0; 10; 20 ] let%test_unit _ = test (filter_map_inplace ~f:(fun v -> Option.some_if (v < 25) (v + 1))) [ 1; 11; 21 ] ;; let%test_unit _ = test (filter_mapi_inplace ~f:(fun i v -> Option.some_if (i % 2 = 0) (v + 1))) [ 1; 21; 41 ] ;; end) ;; let%test_module "partition functions" = (module struct let test (type a b) (module M1 : Testable with type t = a) (module M2 : Testable with type t = b) ~n k (expected1 : a list) (expected2 : b list) = let t = create () in for i = 0 to n - 1 do insert_last t (i * 10) |> (ignore : int Elt.t -> unit) done; let t1, t2 = k t in invariant ignore t; invariant ignore t1; invariant ignore t2; assert (length t = n); expect_test (module M1) t1 expected1; expect_test (module M2) t2 expected2 ;; let test_int_int = test (module Int) (module Int) ~n:5 let test_int_string = test (module Int) (module String) ~n:5 let%test_unit _ = test_int_int (partition_tf ~f:(fun v -> v / 10 % 2 = 0)) [ 0; 20; 40 ] [ 10; 30 ] ;; let%test_unit _ = test_int_int (partitioni_tf ~f:(fun _ v -> v / 10 % 2 = 0)) [ 0; 20; 40 ] [ 10; 30 ] ;; let%test_unit _ = test_int_int (partitioni_tf ~f:(fun i _ -> i % 2 = 1)) [ 10; 30 ] [ 0; 20; 40 ] ;; let%test_unit _ = let fst = [ 1; 21; 41 ] in let snd = [ "10"; "30" ] in let f v = if v / 10 % 2 = 0 then First (v + 1) else Second (Int.to_string v) in test_int_string (partition_map ~f) fst snd; test_int_string (partition_mapi ~f:(fun _ x -> f x)) fst snd ;; let%test_unit _ = test_int_string (partition_mapi ~f:(fun i v -> if i % 2 = 1 then First (v + 1) else Second (Int.to_string v))) [ 11; 31 ] [ "0"; "20"; "40" ] ;; end) ;; let create_default () = let t = create () in for i = 0 to 4 do insert_last t (i * 10) |> (ignore : int Elt.t -> unit) done; t ;; let%test_unit "findi_elt" = let result = findi_elt (create_default ()) ~f:(fun i v -> i % 2 = 0 && v > 20) in match result with | None -> assert false | Some (i, elt) -> assert (i = 4 && Elt.value elt = 40) ;; let%test_unit "findi_elt" = let result = findi_elt (create_default ()) ~f:(fun i _ -> i > 10) in assert ([%equal: _ option] result None) ;; let%expect_test "[iter] does not allocate" = let t = create () in ignore (insert_first t () : _ Elt.t); require_no_allocation [%here] (fun () -> iter t ~f:ignore) ;; let%expect_test "iteri" = iteri (create_default ()) ~f:(fun i v -> printf "f %d %d\n" i v); [%expect {| f 0 0 f 1 10 f 2 20 f 3 30 f 4 40 |}] ;; let%expect_test "iteri_elt" = iteri_elt (create_default ()) ~f:(fun i elt -> printf "f %d %d\n" i (Elt.value elt)); [%expect {| f 0 0 f 1 10 f 2 20 f 3 30 f 4 40 |}] ;; let%expect_test "foldi" = foldi (create_default ()) ~init:0 ~f:(fun i acc v -> printf "f %d %d %d\n" i acc v; acc + i) |> printf "result: %d"; [%expect {| f 0 0 0 f 1 0 10 f 2 1 20 f 3 3 30 f 4 6 40 result: 10 |}] ;; let%expect_test "foldi_elt" = foldi_elt (create_default ()) ~init:0 ~f:(fun i acc elt -> printf "f %d %d %d\n" i acc (Elt.value elt); acc + i) |> printf "result: %d"; [%expect {| f 0 0 0 f 1 0 10 f 2 1 20 f 3 3 30 f 4 6 40 result: 10 |}] ;; let%expect_test "fold_right_elt" = fold_right_elt (create_default ()) ~init:0 ~f:(fun elt acc -> printf "f %d %d\n" (Elt.value elt) acc; acc + 1) |> printf "result: %d"; [%expect {| f 40 0 f 30 1 f 20 2 f 10 3 f 0 4 result: 5 |}] ;; let%test _ = compare Int.compare (create ()) (create ()) = 0 let%test _ = compare Int.compare (create_default ()) (create_default ()) = 0 let%test _ = compare Int.compare (create_default ()) (create ()) > 0 let%test _ = compare Int.compare (create ()) (create_default ()) < 0 let%test _ = compare Int.compare (of_list [ 1; 2; 3 ]) (of_list [ 1; 2; 4 ]) < 0 let%test _ = compare Int.compare (of_list [ 1; 3; 2 ]) (of_list [ 1; 2; 3 ]) > 0 let%test _ = compare Int.compare (of_list [ 1; 2; 5 ]) (of_list [ 1; 2; 3; 4 ]) > 0 let%test _ = [%equal: int list] (to_list (of_list [])) [] let%test _ = [%equal: int list] (to_list (of_list [ 1; 2; 3 ])) [ 1; 2; 3 ] let%test _ = [%equal: int array] (to_array (of_array [||])) [||] let%test _ = [%equal: int array] (to_array (of_array [| 1; 2; 3 |])) [| 1; 2; 3 |] let%test_unit _ = invariant (fun (_ : int) -> ()) (of_list []); invariant (fun (_ : int) -> ()) (of_list [ 1; 2; 3 ]); invariant (fun (_ : int) -> ()) (of_array [||]); invariant (fun (_ : int) -> ()) (of_array [| 1; 2; 3 |]) ;; let%test _ = let t1 = create () in let t2 = create () in let elt = insert_first t1 15 in try remove t2 elt; false with | _ -> true ;; let%test _ = let t1 = create () in let t2 = create () in let elt = insert_first t1 14 in let (_ : int Elt.t) = insert_first t2 13 in try remove t2 elt; false with | _ -> true ;; let%test_unit "mem_elt" = let t1 = create () in let a = insert_first t1 'a' in let b = insert_first t1 'b' in [%test_result: bool] (mem_elt t1 a) ~expect:true; [%test_result: bool] (mem_elt t1 b) ~expect:true; let t2 = create () in let b2 = insert_first t2 'b' in [%test_result: bool] (mem_elt t2 b2) ~expect:true; [%test_result: bool] (mem_elt t1 b2) ~expect:false; remove t1 a; [%test_result: bool] (mem_elt t1 a) ~expect:false; [%test_result: bool] (mem_elt t1 b) ~expect:true; remove t1 b; [%test_result: bool] (mem_elt t1 a) ~expect:false; [%test_result: bool] (mem_elt t1 b) ~expect:false ;; let%test_module "unchecked_iter" = (module struct let b = of_list [ 0; 1; 2; 3; 4 ] let element b n = Option.value_exn (find_elt b ~f:(fun value -> value = n)) let remove b n = remove b (element b n) let insert_after b n_find n_add = ignore (insert_after b (element b n_find) n_add : int Elt.t) ;; let to_list f = let r = ref [] in let b = copy b in unchecked_iter b ~f:(fun n -> r := n :: !r; f b n); List.rev !r ;; let%test _ = [%equal: int list] (to_list (fun _ _ -> ())) [ 0; 1; 2; 3; 4 ] let%test _ = [%equal: int list] (to_list (fun b x -> if x = 0 then remove b 1)) [ 0; 2; 3; 4 ] ;; let%test _ = [%equal: int list] (to_list (fun b x -> if x = 1 then remove b 0)) [ 0; 1; 2; 3; 4 ] ;; let%test _ = [%equal: int list] (to_list (fun b x -> if x = 2 then remove b 1)) [ 0; 1; 2; 3; 4 ] ;; let%test _ = [%equal: int list] (to_list (fun b x -> if x = 2 then ( remove b 4; remove b 3))) [ 0; 1; 2 ] ;; let%test _ = [%equal: int list] (to_list (fun b x -> if x = 2 then insert_after b 1 5)) [ 0; 1; 2; 3; 4 ] ;; let%test _ = [%equal: int list] (to_list (fun b x -> if x = 2 then insert_after b 2 5)) [ 0; 1; 2; 5; 3; 4 ] ;; let%test _ = [%equal: int list] (to_list (fun b x -> if x = 2 then insert_after b 3 5)) [ 0; 1; 2; 3; 5; 4 ] ;; end) ;; core-0.15.0/core/test/src/test_doubly_linked.mli000066400000000000000000000000551420273305200216070ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_ephemeron.ml000066400000000000000000000051251420273305200205770ustar00rootroot00000000000000open! Core open! Expect_test_helpers_core open! Ephemeron type heap_block = int ref Heap_block.t [@@deriving sexp_of] let heap_block i = ref i |> Heap_block.create_exn let print t = print_s [%message "" ~key:(get_key t : heap_block option) ~data:(get_data t : heap_block option)] ;; let%expect_test "data isn't nulled by [set_key None]" [@tags "no-js"] = let t = create () in let data = heap_block 14 in set_data t (Some data); set_key t (Some (heap_block 13)); set_key t None; print t; [%expect {| ((key ()) (data (14))) |}]; print_s [%message (data : heap_block)]; [%expect {| (data 14) |}]; ;; let%expect_test "\ data is nulled when the key becomes unreachable, even if the data is reachable" [@tags "no-js"] = let t = create () in let data = heap_block 14 in set_data t (Some data); Gc.compact (); print t; [%expect {| ((key ()) (data (14))) |}]; set_key t (Some (heap_block 13)); Gc.compact (); print t; [%expect {| ((key ()) (data ())) |}]; print_s [%message (data : heap_block)]; [%expect {| (data 14) |}]; ;; let%expect_test "data is kept alive by the key" [@tags "no-js"] = let t = create () in print t; [%expect {| ((key ()) (data ())) |}]; let key = heap_block 13 in set_key t (Some key); print t; [%expect {| ((key (13)) (data ())) |}]; let data = heap_block 14 in set_data t (Some data); print t; [%expect {| ((key (13)) (data (14))) |}]; Gc.compact (); print t; [%expect {| ((key (13)) (data (14))) |}]; print_s [%message (data : heap_block)]; [%expect {| (data 14) |}]; (* No more references to [data], but it still is kept alive by [t] while [key] is alive. *) Gc.compact (); print t; [%expect {| ((key (13)) (data (14))) |}]; print_s [%message (key : heap_block)]; (* No more references to [key], so both fields in [t] are nulled. *) [%expect {| (key 13) |}]; Gc.compact (); print t; [%expect {| ((key ()) (data ())) |}]; ;; let%expect_test "finalizers and clearing" [@tags "no-js"] = let t = create () in let key = heap_block 14 in let data = heap_block 13 in set_key t (Some key); set_data t (Some data); Gc.Expert.add_finalizer key (fun _ -> print_s [%message "finalized key" ]); Gc.Expert.add_finalizer data (fun _ -> print_s [%message "finalized data"]); Gc.compact (); [%expect {| "finalized data" "finalized key" |}]; print t; [%expect {| ((key (14)) (data (13))) |}]; Gc.compact (); print t; [%expect {| ((key ()) (data ())) |}]; ;; core-0.15.0/core/test/src/test_ephemeron.mli000066400000000000000000000000551420273305200207450ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_fdeque.ml000066400000000000000000000044011420273305200200620ustar00rootroot00000000000000open! Core open! Import open! Fdeque let%test_unit _ = let open Front_to_back in [%test_result: int list] ~expect:[ 1; 2; 3 ] (to_list (of_list [ 1; 2; 3 ])) ;; let%test_unit _ = let open Back_to_front in [%test_result: int list] ~expect:[ 1; 2; 3 ] (to_list (of_list [ 1; 2; 3 ])) ;; let%test_unit _ = [%test_result: int list] ~expect:[ 1; 2; 3; 4 ] (bind (of_list [ [ 1; 2 ]; [ 3; 4 ] ]) ~f:of_list |> to_list) ;; let%test_unit _ = [%test_result: int list] ~expect:[ 2; 3; 4; 5 ] (map (of_list [ 1; 2; 3; 4 ]) ~f:succ |> to_list) ;; let%test_unit _ = let open Stable.V1 in [%test_result: int list] ~expect:[ 1; 2; 3 ] (to_list (t_of_sexp Int.t_of_sexp (sexp_of_t Int.sexp_of_t (of_list [ 1; 2; 3 ])))) ;; module type Sequence_testable = sig val of_sequence : 'a Sequence.t -> 'a t val to_sequence : 'a t -> 'a Sequence.t val of_list : 'a list -> 'a t val to_list : 'a t -> 'a list end let%test_unit "to_sequence & of_sequence round-trip" = let example = Front_to_back.of_list [ 1; 2; 3; 4 ] in let property (module M : Sequence_testable) = [%test_result: int t] ~expect:example (M.of_sequence (M.to_sequence example)) in property (module Front_to_back); property (module Back_to_front) ;; let%test_unit "{to,of}_sequence & {to,of}_list agree" = let example = [ 1; 2; 3; 4 ] in let property (module M : Sequence_testable) = [%test_result: int t] ~expect:(M.of_list example) (M.of_sequence (Sequence.of_list example)); let example = M.of_list example in [%test_result: int list] ~expect:(M.to_list example) (Sequence.to_list (M.to_sequence example)) in property (module Front_to_back); property (module Back_to_front) ;; let%test_unit "Arbitrary_order doesn't drop elements" = let example = [ 1; 2; 3; 4 ] in let expect = List.fold example ~init:Int.Map.empty ~f:(fun acc key -> Map.update acc key ~f:(fun existing -> 1 + Option.value ~default:0 existing)) in let arbitrary_order_elements = example |> of_list |> Arbitrary_order.to_sequence |> Sequence.fold ~init:Int.Map.empty ~f:(fun acc key -> Map.update acc key ~f:(fun existing -> 1 + Option.value ~default:0 existing)) in [%test_result: int Int.Map.t] ~expect arbitrary_order_elements ;; core-0.15.0/core/test/src/test_fdeque.mli000066400000000000000000000000551420273305200202340ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_filename.ml000066400000000000000000000107621420273305200204000ustar00rootroot00000000000000open! Core open! Import open! Filename open Poly let%test _ = split_extension "/foo/my_file" = ("/foo/my_file", None) let%test _ = split_extension "/foo/my_file.txt" = ("/foo/my_file", Some "txt") let%test _ = split_extension "/foo/my_file.1.txt" = ("/foo/my_file.1", Some "txt") let%test _ = split_extension "/home/c.falls/my_file" = ("/home/c.falls/my_file", None) let%test _ = split_extension "/home/c.falls/my_file.txt" = ("/home/c.falls/my_file", Some "txt") ;; let%test _ = split_extension "/home/c.falls/my_file.1.txt" = ("/home/c.falls/my_file.1", Some "txt") ;; let%test _ = split_extension "my_file" = ("my_file", None) let%test _ = split_extension "my_file.txt" = ("my_file", Some "txt") let%test _ = split_extension "my_file.1.txt" = ("my_file.1", Some "txt") let%test _ = split_extension "/my_file" = ("/my_file", None) let%test _ = split_extension "/my_file.txt" = ("/my_file", Some "txt") let%test _ = split_extension "/my_file.1.txt" = ("/my_file.1", Some "txt") let%test_unit _ = List.iter ~f:(fun (path, pieces) -> [%test_result: string] ~expect:path (of_parts pieces); [%test_result: string list] ~expect:pieces (parts path)) [ "/tmp/foo/bar/baz", [ "/"; "tmp"; "foo"; "bar"; "baz" ] ; ".", [ "." ] ; "/", [ "/" ] ; "./foo", [ "."; "foo" ] ] ;; let%test _ = parts "/tmp/foo/bar/baz/" = [ "/"; "tmp"; "foo"; "bar"; "baz" ] let%test _ = parts "//tmp//foo//bar" = [ "/"; "tmp"; "foo"; "bar" ] let%test _ = parts "" = [ "." ] let%test _ = parts "./" = [ "." ] let%test _ = parts "./." = [ "." ] let%test _ = parts "././." = [ "."; "." ] let%test _ = parts "foo" = [ "."; "foo" ] let%test _ = parts "./foo/" = [ "."; "foo" ] let%test _ = parts "./foo/." = [ "."; "foo"; "." ] let%test _ = of_parts [ "."; "."; "." ] = "././." (* Assert type equality. *) let _f (x : int Filename.Map.t) : int String.Map.t = x let%expect_test "V1" = let examples = [ "/foo/my_file.1.txt" ; "/home/c.falls/my_file.1.txt" ; "/tmp/foo/bar/baz" ; "//tmp//foo//bar" ; "././." ] in print_and_check_stable_type [%here] (module Stable.V1) examples; [%expect {| (bin_shape_digest d9a8da25d5656b016fb4dbdc2e4197fb) ((sexp /foo/my_file.1.txt) (bin_io "\018/foo/my_file.1.txt")) ((sexp /home/c.falls/my_file.1.txt) (bin_io "\027/home/c.falls/my_file.1.txt")) ((sexp /tmp/foo/bar/baz) (bin_io "\016/tmp/foo/bar/baz")) ((sexp //tmp//foo//bar) (bin_io "\015//tmp//foo//bar")) ((sexp ././.) (bin_io "\005././.")) |}] ;; (* Assert type equality between stable and unstable map types *) let _f (x : int Filename.Map.t) : int Stable.V1.Map.t = x let%expect_test "to_absolute_exn" = let to_absolute = to_absolute_exn ~relative_to:"/a/b/c" in print_s [%message (to_absolute "/already/absolute") (to_absolute "./relative") (to_absolute "../relative") (to_absolute "implicitly-relative")]; [%expect {| (/already/absolute /a/b/c/relative /a/b/c/../relative /a/b/c/implicitly-relative) |}]; Expect_test_helpers_core.show_raise (fun () -> to_absolute_exn ~relative_to:"./a/relative/path" "foo"); [%expect {| (raised ( Failure "Filename.to_absolute_exn called with a [relative_to] that is a relative path: ./a/relative/path")) |}] ;; let require_should_raise thunk = match thunk () with | exception exn -> print_s [%sexp "raised:", (exn : Exn.t)] | _ -> assert false ;; let%expect_test "of_absolute_exn" = let relative_to x = of_absolute_exn "/a/b/c" ~relative_to:x in assert (relative_to "/" = "a/b/c"); assert (relative_to "/a" = "b/c"); assert (relative_to "/a/" = "b/c"); assert (relative_to "/a/b" = "c"); assert (relative_to "/a/b/" = "c"); assert (relative_to "/a/b/c" = "."); assert (relative_to "/a/b/c/" = "."); assert (relative_to "/a/b/d" = "../c"); assert (relative_to "/a/b/d/" = "../c"); assert (relative_to "/a/d" = "../b/c"); assert (relative_to "/a/d/" = "../b/c"); assert (relative_to "/a/d/e" = "../../b/c"); [%expect {| |}]; (* raises if either argument is a relative path *) require_should_raise (fun () -> of_absolute_exn "/a/b/c" ~relative_to:"./d/e/f"); [%expect {| (raised: ( "Filename.of_absolute_exn: [~relative_to] must be an absolute path" (relative_to ./d/e/f))) |}]; require_should_raise (fun () -> of_absolute_exn "./a/b/c" ~relative_to:"/d/e/f"); [%expect {| (raised: ( "Filename.of_absolute_exn: first argument must be an absolute path" (first_arg ./a/b/c))) |}] ;; core-0.15.0/core/test/src/test_filename.mli000066400000000000000000000000551420273305200205430ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_float.ml000066400000000000000000000271061420273305200177250ustar00rootroot00000000000000open! Core open Poly open! Import let%expect_test "[Pervasives.float_of_string] supports underscores" = print_endline (Caml.string_of_float (Caml.float_of_string "1_234.567_8")); [%expect {| 1234.5678 |}] ;; let%expect_test "[Sexp.of_float_style] is respected by the various names for [float]" = let f = 1234.5678 in let print () = print_s [%sexp (f : float)]; print_s [%sexp (f : Float.t)]; print_s [%sexp (f : Core.Core_stable.float)] in print (); [%expect {| 1234.5678 1234.5678 1234.5678 |}]; Ref.set_temporarily Sexp.of_float_style `Underscores ~f:print; [%expect {| 1_234.5678 1_234.5678 1_234.5678 |}] ;; let%expect_test "[Sexp.of_float_style = `Underscores]" = let check f = let sexp style = Ref.set_temporarily Sexp.of_float_style style ~f:(fun () -> [%sexp (f : float)]) in print_s [%sexp (sexp `No_underscores : Sexp.t), (sexp `Underscores : Sexp.t)]; if not (Float.is_nan f) then require [%here] (Float.equal f (sexp `Underscores |> [%of_sexp: Float.t])) in List.iter [ 0. ; Float.min_positive_subnormal_value ; Float.min_positive_normal_value ; 1E-7 ; 1. ; 12. ; 123. ; 1234. ; 12345. ; 1234E100 ; Float.max_value ; Float.nan ] ~f:(fun f -> check f; check (-.f)); [%expect {| (0 0) (-0 -0) (4.94065645841247E-324 4.94065645841247E-324) (-4.94065645841247E-324 -4.94065645841247E-324) (2.2250738585072014E-308 2.2250738585072014E-308) (-2.2250738585072014E-308 -2.2250738585072014E-308) (1E-07 1E-07) (-1E-07 -1E-07) (1 1) (-1 -1) (12 12) (-12 -12) (123 123) (-123 -123) (1234 1_234) (-1234 -1_234) (12345 12_345) (-12345 -12_345) (1.234E+103 1.234E+103) (-1.234E+103 -1.234E+103) (INF INF) (-INF -INF) (NAN NAN) ({-,}NAN {-,}NAN) (glob) |}] ;; let%test_unit "round_nearest_half_to_even quickcheck" = Quickcheck.test ~trials:200 (Int.gen_incl (-100_000_000) 100_000_000) ~f:(fun i -> let x = float i /. 10. in let y = Float.round_nearest_half_to_even x in let f = Float.round_nearest x in let is_tie = Int.( % ) i 10 = 5 in assert ( (is_tie && Float.mod_float y 2. = 0. && Float.abs (y -. x) = 0.5) || ((not is_tie) && y = f)); let x' = Float.one_ulp `Up x in let x'' = Float.one_ulp `Down x in assert (Float.round_nearest_half_to_even x' = Float.round_nearest x'); assert (Float.round_nearest_half_to_even x'' = Float.round_nearest x'')) ;; let%expect_test "robust_sign" = let test n = print_s [%sexp (Float.robust_sign n : Sign.t)] in test 1e-6; [%expect "Pos"]; test 1e-8; [%expect "Zero"]; test (-1e-6); [%expect "Neg"]; test (-1e-8); [%expect "Zero"]; test (-0.); [%expect "Zero"]; test 0.; [%expect "Zero"]; test Float.neg_infinity; [%expect "Neg"]; (* preserve this old behavior of [sign] *) test Float.nan; [%expect "Zero"] ;; (* Make sure float comparison didn't accidentally get redefined using [compare]. *) let%test _ = not (Float.( < ) Float.nan 0.) (* When we put a similar in base/test, it doesn't behave the same, and undesirable versions of [Float.is_positive] that allocate when we put the test here don't allocate when we put the test there. So, we put the test here. *) let%expect_test (_ [@tags "64-bits-only", "x-library-inlining-sensitive"]) = let a = [| 1. |] in (* a.(0) is unboxed *) let one = 1. in (* [one] is boxed *) ignore (require_no_allocation [%here] (fun () -> Float.( > ) a.(0) 0.) : bool); [%expect {| |}]; ignore (require_no_allocation [%here] (fun () -> Float.compare a.(0) 0. > 0) : bool); [%expect {| |}]; ignore (require_no_allocation [%here] (fun () -> Float.is_positive a.(0)) : bool); [%expect {| |}]; ignore (require_no_allocation [%here] (fun () -> Float.is_positive one) : bool); [%expect {| |}] ;; let%test_module "round_significant" = (module struct let round_significant = Float.round_significant let%test_unit "key values" = [%test_result: float] (round_significant ~significant_digits:3 0.0045678) ~expect:0.00457; [%test_result: float] (round_significant ~significant_digits:3 123456.) ~expect:123000.; [%test_result: float] (round_significant ~significant_digits:3 0.) ~expect:0.; [%test_result: float] (round_significant ~significant_digits:3 Float.nan) ~expect:Float.nan; [%test_result: float] (round_significant ~significant_digits:3 Float.infinity) ~expect:Float.infinity; [%test_result: float] (round_significant ~significant_digits:3 Float.neg_infinity) ~expect:Float.neg_infinity; [%test_result: float] (round_significant ~significant_digits:1 (-5.85884163457842E+100)) ~expect:(-6E+100); [%test_result: float] (round_significant ~significant_digits:16 (-129361178280336660.)) ~expect:(-129361178280336700.); (* An example where it appears like we don't round to even (since the argument is under-represented as a float). *) [%test_result: float] (round_significant ~significant_digits:11 4.36083208835) ~expect:4.3608320883 ;; let%test_unit ("round_significant vs sprintf quickcheck 1" [@tags "64-bits-only"]) = for significant_digits = 1 to 16 do let open Quickcheck in test Float.gen_without_nan ~trials:10_000 ~sexp_of:(fun float -> [%message "" (float : float) (significant_digits : int)]) ~f:(fun x -> let s = sprintf "%.*g" significant_digits x |> Float.of_string in assert ( s = round_significant ~significant_digits x || s = round_significant ~significant_digits (Float.one_ulp `Up x) || s = round_significant ~significant_digits (Float.one_ulp `Down x))) done ;; let%test_unit ("round_significant vs sprintf quickcheck 2" [@tags "64-bits-only"]) = (* this test is much more likely to exercise cases when we're off by an ulp *) let num_digits_gen = Int.gen_incl 1 18 in let digits_gen num_digits = let x = Int63.(pow (of_int 10) (of_int num_digits) - of_int 1) in Int63.gen_incl Int63.(~-x) x in let scale_gen = Int.gen_incl (-20) 20 in let sf_gen = Int.gen_incl 1 18 in Quickcheck.test ~trials:1000 (Quickcheck.Generator.tuple3 (Quickcheck.Generator.bind num_digits_gen ~f:digits_gen) scale_gen sf_gen) ~f:(fun (digits, scale, sf) -> let x = if scale > 0 then Int63.to_float digits *. (10. ** float scale) else Int63.to_float digits /. (10. ** float (-scale)) in let r = round_significant ~significant_digits:sf x in let r1 = round_significant ~significant_digits:sf (Float.one_ulp `Up x) in let r2 = round_significant ~significant_digits:sf (Float.one_ulp `Down x) in let s = sprintf "%.*g" sf x |> Float.of_string in assert (s = r || s = r1 || s = r2)) ;; let%test "0 significant digits" = Exn.does_raise (fun () -> ignore (round_significant ~significant_digits:0 1.3 : float)) ;; end) ;; let%test_module "round_decimal" = (module struct let round_decimal = Float.round_decimal let%test_unit "key values" = [%test_result: float] (round_decimal ~decimal_digits:3 0.0045678) ~expect:0.005; [%test_result: float] (round_decimal ~decimal_digits:0 0.0045678) ~expect:0.; [%test_result: float] (round_decimal ~decimal_digits:0 1.0045678) ~expect:1.; [%test_result: float] (round_decimal ~decimal_digits:3 123456.) ~expect:123456.; [%test_result: float] (round_decimal ~decimal_digits:(-3) 123456.) ~expect:123000.; [%test_result: float] (round_decimal ~decimal_digits:3 0.) ~expect:0.; [%test_result: float] (round_decimal ~decimal_digits:3 Float.nan) ~expect:Float.nan; [%test_result: float] (round_decimal ~decimal_digits:3 Float.infinity) ~expect:Float.infinity; [%test_result: float] (round_decimal ~decimal_digits:3 Float.neg_infinity) ~expect:Float.neg_infinity; [%test_result: float] (round_decimal ~decimal_digits:(-100) (-5.85884163457842E+100)) ~expect:(-6E+100); [%test_result: float] (round_decimal ~decimal_digits:0 (-129361178280336660.)) ~expect:(-129361178280336660.); [%test_result: float] (round_decimal ~decimal_digits:(-2) (-129361178280336660.)) ~expect:(-129361178280336700.); [%test_result: float] (round_decimal ~decimal_digits:10 4.36083208835) ~expect:4.3608320883 ;; let%test_unit ("round_decimal vs sprintf quickcheck 1" [@tags "64-bits-only"]) = for decimal_digits = 1 to 16 do let open Quickcheck in test Float.gen_without_nan ~trials:10_000 ~sexp_of:(fun float -> [%message "" (float : float) (decimal_digits : int)]) ~f:(fun x -> let s = sprintf "%.*f" decimal_digits x |> Float.of_string in assert ( s = round_decimal ~decimal_digits x || s = round_decimal ~decimal_digits (Float.one_ulp `Up x) || s = round_decimal ~decimal_digits (Float.one_ulp `Down x))) done ;; end) ;; open! Float let test_class quickcheck_generator expect = Quickcheck.test quickcheck_generator ~f:(fun float -> let actual = classify float in if not (Int.equal (Class.compare actual expect) 0) then raise_s [%message "generator produced float in wrong class" (float : t) (expect : Class.t) (actual : Class.t)]) ;; let%test_unit _ = test_class gen_zero Zero let%test_unit _ = test_class gen_subnormal Subnormal let%test_unit _ = test_class gen_normal Normal let%test_unit _ = test_class gen_infinite Infinite let%test_unit _ = test_class gen_nan Nan (* Additional tests of Base.Float requiring the Gc module *) let%test (_ [@tags "64-bits-only"]) = let before = Gc.minor_words () in assert (Int63.equal (int63_round_nearest_exn 0.8) (Int63.of_int_exn 1)); let after = Gc.minor_words () in Int.equal before after ;; let%test_unit "Float.validate_positive doesn't allocate on success" = let initial_words = Gc.minor_words () in let (_ : Validate.t) = validate_positive 1. in let allocated = Int.( - ) (Gc.minor_words ()) initial_words in [%test_result: int] allocated ~expect:0 ;; let%test_module _ = (module struct let check v expect = match Validate.result v, expect with | Ok (), `Ok | Error _, `Error -> () | r, expect -> raise_s [%message "mismatch" (r : unit Or_error.t) (expect : [ `Ok | `Error ])] ;; let%test_unit _ = check (validate_lbound ~min:(Incl 0.) nan) `Error let%test_unit _ = check (validate_lbound ~min:(Incl 0.) infinity) `Error let%test_unit _ = check (validate_lbound ~min:(Incl 0.) neg_infinity) `Error let%test_unit _ = check (validate_lbound ~min:(Incl 0.) (-1.)) `Error let%test_unit _ = check (validate_lbound ~min:(Incl 0.) 0.) `Ok let%test_unit _ = check (validate_lbound ~min:(Incl 0.) 1.) `Ok let%test_unit _ = check (validate_ubound ~max:(Incl 0.) nan) `Error let%test_unit _ = check (validate_ubound ~max:(Incl 0.) infinity) `Error let%test_unit _ = check (validate_ubound ~max:(Incl 0.) neg_infinity) `Error let%test_unit _ = check (validate_ubound ~max:(Incl 0.) (-1.)) `Ok let%test_unit _ = check (validate_ubound ~max:(Incl 0.) 0.) `Ok let%test_unit _ = check (validate_ubound ~max:(Incl 0.) 1.) `Error end) ;; core-0.15.0/core/test/src/test_float.mli000066400000000000000000000000551420273305200200700ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_hash_queue.ml000066400000000000000000000236701420273305200207510ustar00rootroot00000000000000open! Core open! Import open! Hash_queue module Hq_arg = struct include String let hash (x : t) = Hashtbl.hash x let sexp_of_t = Sexplib.Conv.sexp_of_string end module Hq = Hash_queue.Make (Hq_arg) let%test_unit _ = let hq = Hq.create () in let inv () = Hq.invariant hq in (* tests over empty queue *) inv (); assert (Hq.is_empty hq); assert (Option.is_none (Hq.dequeue_front hq)); assert ( try ignore (Hq.dequeue_front_exn hq : int); false with | _ -> true); assert (Option.is_none (Hq.dequeue_front_with_key hq)); assert ( try ignore (Hq.dequeue_front_with_key_exn hq : string * int); false with | _ -> true); Hq.dequeue_all hq ~f:(fun _ -> assert false); assert (Poly.( = ) (Hq.remove hq "foobar") `No_such_key); assert ( try Hq.remove_exn hq "foobar"; false with | _ -> true); assert (Poly.( = ) (Hq.replace hq "foobar" 0) `No_such_key); assert ( try Hq.replace_exn hq "foobar" 0; false with | _ -> true); assert (List.is_empty (Hq.foldi hq ~init:[] ~f:(fun ac ~key:_ ~data:_ -> () :: ac))); assert (List.is_empty (Hq.fold hq ~init:[] ~f:(fun ac _ -> () :: ac))); Hq.iteri hq ~f:(fun ~key:_ ~data:_ -> assert false); (* test with 10 elems *) let n = 10 in for i = 1 to n do assert (Poly.( = ) (Hq.enqueue_back hq (string_of_int i) i) `Ok); inv () done; assert (Hq.length hq = n); assert ( [%equal: (string * int) list] (List.rev (Hq.foldi hq ~init:[] ~f:(fun ac ~key ~data -> (key, data) :: ac))) (List.init n ~f:(fun i -> let i = i + 1 in string_of_int i, i))); assert ( [%equal: int list] (List.rev (Hq.fold hq ~init:[] ~f:(fun ac data -> data :: ac))) (List.init n ~f:(fun i -> i + 1))); Hq.iteri hq ~f:(fun ~key ~data -> assert (String.( = ) key (string_of_int data))); (* test removing the first element from the queue *) let sum = ref 0 in Hq.iter hq ~f:(fun x -> sum := !sum + x); assert (!sum = n * (n + 1) / 2); assert (Hq.mem hq "1"); ignore (Hq.dequeue_front hq : int option); inv (); assert (not (Hq.mem hq "1")); assert (Hq.length hq = n - 1); (* remove the last *) assert (Poly.( = ) (Hq.remove hq (string_of_int n)) `Ok); (* double remove *) assert (Poly.( = ) (Hq.remove hq (string_of_int n)) `No_such_key); inv (); assert (Hq.length hq = n - 2); (* remove everything *) let num = ref 0 in Hq.dequeue_all hq ~f:(fun _ -> num := !num + 1); inv (); assert (!num = n - 2); assert (Hq.is_empty hq); inv (); Hq.clear hq; assert (Hq.is_empty hq); (* add 100 *) for i = 1 to 100 do assert (Poly.( = ) (Hq.enqueue_back hq (string_of_int i) i) `Ok) done; (* double booking *) assert (Poly.( = ) (Hq.enqueue_back hq "42" 42) `Key_already_present); assert ( try Hq.enqueue_back_exn hq "42" 42; false with | _ -> true); assert (Poly.( = ) (Hq.replace hq "1" 42) `Ok); assert ([%equal: int option] (Hq.lookup hq "1") (Some 42)); assert (Hq.lookup_exn hq "1" = 42); assert ([%equal: (string * int) option] (Hq.dequeue_front_with_key hq) (Some ("1", 42))); assert (Poly.( = ) (Hq.replace hq "1" 42) `No_such_key); assert ( try Hq.replace_exn hq "1" 42; false with | _ -> true); assert ([%equal: int option] (Hq.lookup hq "1") None); assert ( try ignore (Hq.lookup_exn hq "1" : int); false with | Not_found_s _ | Caml.Not_found -> true | _ -> false); Hq.clear hq; assert (Hq.is_empty hq); let add i = Hq.enqueue_back_exn hq (Int.to_string i) i in List.iter [ 1; 2; 3 ] ~f:add; assert ([%equal: string list] [ "1"; "2"; "3" ] (Hq.keys hq)); (try Hq.iter hq ~f:(fun _ -> add 13); assert false with | _ -> ()); (try Hq.iter hq ~f:(fun _ -> ignore (Hq.remove hq "foo" : [ `No_such_key | `Ok ])); assert false with | _ -> ()); [%test_result: int] (Hq.lookup_and_move_to_back_exn hq "2") ~expect:2; [%test_result: string * int] (Hq.dequeue_front_with_key_exn hq) ~expect:("1", 1); [%test_result: string * int] (Hq.dequeue_front_with_key_exn hq) ~expect:("3", 3); [%test_result: string * int] (Hq.dequeue_front_with_key_exn hq) ~expect:("2", 2); [%test_result: (string * int) option] (Hq.dequeue_front_with_key hq) ~expect:None ;; let%expect_test "enqueue_front, enqueue_front_exn" = let open Expect_test_helpers_core in let hq = Hq.create () in let ok_exn = function | `Key_already_present -> raise_s [%message "Key already present"] | `Ok -> () in for i = 1 to 10 do Hq.enqueue_front hq (Int.to_string i) i |> ok_exn done; print_s [%sexp (Hq.to_list hq : int list)]; [%expect {| (10 9 8 7 6 5 4 3 2 1) |}]; let hq_rev = Hq.create () in for i = 1 to 10 do Hq.enqueue_back hq_rev (Int.to_string i) i |> ok_exn done; print_s [%sexp (Hq.to_list hq_rev : int list)]; [%expect {| (1 2 3 4 5 6 7 8 9 10) |}]; (* Test the _exn version *) let hq2 = Hq.create () in let n = 10 in for i = 1 to n do Hq.enqueue_front_exn hq2 (string_of_int i) i done; require [%here] ([%compare.equal: int list] (Hq.to_list hq2) (Hq.to_list hq)) ;; let test_enqueue_fn (back_or_front : [ `back | `front ]) enqueue_fn = let hq, hq' = Hq.create (), Hq.create () in let n = 10 in for i = 1 to n do assert (Poly.( = ) (Hq.enqueue hq back_or_front (string_of_int i) i) `Ok); assert (Poly.( = ) (enqueue_fn hq' (string_of_int i) i) `Ok) done; [%test_result: int list] (Hq.to_list hq) ~expect:(Hq.to_list hq'); (* make sure they both return [`Key_already_present] *) [%test_result: [ `Key_already_present | `Ok ]] (Hq.enqueue hq back_or_front (string_of_int 5) 5) ~expect:`Key_already_present; [%test_result: [ `Key_already_present | `Ok ]] (enqueue_fn hq' (string_of_int 5) 5) ~expect:`Key_already_present ;; let%expect_test "enqueue t `back := enqueue_back" = test_enqueue_fn `back Hq.enqueue_back let%expect_test "enqueue t `front := enqueue_front" = test_enqueue_fn `front Hq.enqueue_front ;; let%expect_test "lookup_and_move_to_back_exn" = let hq = Hq.create () in let n = 10 in for i = 1 to n do Hq.enqueue_back_exn hq (string_of_int i) i done; print_s [%sexp (Hq.to_list hq : int list)]; [%expect {| (1 2 3 4 5 6 7 8 9 10) |}]; print_s [%sexp (Hq.lookup_and_move_to_back_exn hq "5" : int)]; [%expect {| 5 |}]; print_s [%sexp (Hq.to_list hq : int list)]; [%expect {| (1 2 3 4 6 7 8 9 10 5) |}] ;; let%expect_test "lookup_and_move_to_front_exn" = let hq = Hq.create () in let n = 10 in for i = 1 to n do Hq.enqueue_back_exn hq (string_of_int i) i done; print_s [%sexp (Hq.to_list hq : int list)]; [%expect {| (1 2 3 4 5 6 7 8 9 10) |}]; print_s [%sexp (Hq.lookup_and_move_to_front_exn hq "5" : int)]; [%expect {| 5 |}]; print_s [%sexp (Hq.to_list hq : int list)]; [%expect {| (5 1 2 3 4 6 7 8 9 10) |}] ;; let%expect_test "dequeue_back, dequeue_back_exn" = let open Expect_test_helpers_core in let make_hq () = let hq = Hq.create () in for i = 1 to 10 do Hq.enqueue_front_exn hq (Int.to_string i) i done; hq in let hq = make_hq () in for _ = 1 to 11 do print_s [%sexp (Hq.dequeue_back hq : int option)] done; [%expect {| (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) () |}]; let hq = make_hq () in for _ = 1 to 10 do print_s [%sexp (Hq.dequeue_back_exn hq : int)] done; [%expect {| 1 2 3 4 5 6 7 8 9 10 |}] ;; let%expect_test "drop" = let open Expect_test_helpers_core in let make_hq () = let hq = Hq.create () in for i = 1 to 10 do Hq.enqueue_back_exn hq (Int.to_string i) i done; hq in let hq = make_hq () in Hq.drop_back ~n:3 hq; print_s [%sexp (Hq.to_list hq : int list)]; [%expect {| (1 2 3 4 5 6 7) |}]; let hq = make_hq () in Hq.drop_front ~n:4 hq; print_s [%sexp (Hq.to_list hq : int list)]; [%expect {| (5 6 7 8 9 10) |}]; (* Check when n > length of list *) let hq = make_hq () in Hq.drop_back ~n:20 hq; print_s [%sexp (Hq.to_list hq : int list)]; [%expect {| () |}] ;; let%expect_test "lookup_and_remove" = let hq = Hq.create () in let n = 10 in for i = 1 to n do Hq.enqueue_back_exn hq (Int.to_string i) i done; print_s [%sexp (Hq.to_list hq : int list)]; [%expect {| (1 2 3 4 5 6 7 8 9 10) |}]; print_s [%sexp (Hq.lookup_and_remove hq "5" : int option)]; [%expect {| (5) |}]; print_s [%sexp (Hq.to_list hq : int list)]; [%expect {| (1 2 3 4 6 7 8 9 10) |}]; print_s [%sexp (Hq.lookup_and_remove hq "11" : int option)]; [%expect {| () |}]; print_s [%sexp (Hq.to_list hq : int list)]; [%expect {| (1 2 3 4 6 7 8 9 10) |}] ;; let%expect_test "last" = let hq = Hq.create () in let n = 10 in for i = 1 to n do Hq.enqueue_back_exn hq (Int.to_string i) i done; print_s [%sexp (Hq.to_list hq : int list)]; [%expect {| (1 2 3 4 5 6 7 8 9 10) |}]; print_s [%sexp (Hq.last hq : int option)]; [%expect {| (10) |}]; print_s [%sexp (Hq.last_with_key hq : (string * int) option)]; [%expect {| ((10 10)) |}] ;; let%expect_test "[copy] returns an identical but independent hash queue" = let hq = Hq.create () in let n = 10 in for i = 1 to n do Hq.enqueue_back_exn hq (Int.to_string i) i done; let copy = Hq.copy hq in print_s [%sexp (Hq.to_list hq : int list)]; [%expect {| (1 2 3 4 5 6 7 8 9 10) |}]; print_s [%sexp (Hq.to_list copy : int list)]; [%expect {| (1 2 3 4 5 6 7 8 9 10) |}]; Hq.drop_front hq; Hq.drop_back copy; print_s [%sexp (Hq.to_list hq : int list)]; [%expect {| (2 3 4 5 6 7 8 9 10) |}]; print_s [%sexp (Hq.to_list copy : int list)]; [%expect {| (1 2 3 4 5 6 7 8 9) |}]; print_s [%sexp (Hq.lookup_and_move_to_front_exn hq "5" : int)]; [%expect {| 5 |}]; print_s [%sexp (Hq.lookup_and_move_to_back_exn copy "6" : int)]; [%expect {| 6 |}]; print_s [%sexp (Hq.to_list hq : int list)]; [%expect {| (5 2 3 4 6 7 8 9 10) |}]; print_s [%sexp (Hq.to_list copy : int list)]; [%expect {| (1 2 3 4 5 7 8 9 6) |}] ;; core-0.15.0/core/test/src/test_hash_queue.mli000066400000000000000000000000551420273305200211120ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_hexdump.ml000066400000000000000000000436701420273305200202760ustar00rootroot00000000000000open! Core open Expect_test_helpers_core let require_same here (name1, string1) (name2, string2) = require here (String.equal string1 string2) ~if_false_then_print_s: (lazy [%message "output differs unexpectedly" ~_:(name1, string1 : string * string) ~_:(name2, string2 : string * string)]) ;; let test_m (type a) here (module T : Hexdump.S with type t = a) ?max_lines ?pos ?len t = let to_string_hum = T.Hexdump.to_string_hum ?max_lines ?pos ?len t in let to_sequence = T.Hexdump.to_sequence ?max_lines ?pos ?len t |> Sequence.to_list |> String.concat ~sep:"\n" in require_same here ("to_string_hum", to_string_hum) ("to_sequence", to_sequence); if List.for_all ~f:Option.is_none [ max_lines; pos; len ] then ( let sexp_of_t = [%sexp (t : T.Hexdump.t)] |> [%of_sexp: string list] |> String.concat ~sep:"\n" in require_same here ("to_string_hum", to_string_hum) ("sexp_of_t", sexp_of_t)); to_string_hum ;; let test ?max_lines ?pos ?len string = let of_string = test_m [%here] (module String) ?max_lines ?pos ?len string in print_endline of_string; let of_bigstring = test_m [%here] (module Bigstring) ?max_lines ?pos ?len (Bigstring.of_string string) in require_same [%here] ("String.Hexdump.to_string_hum", of_string) ("Bigstring.Hexdump.to_string_hum", of_bigstring) ;; let string = "Good morning. In less than an hour, aircraft from here will join others from around \ the world. And you will be launching the largest aerial battle in the history of \ mankind. \"Mankind.\" That word should have new meaning for all of us today. We can't \ be consumed by our petty differences anymore. We will be united in our common \ interests. Perhaps it's fate that today is the Fourth of July, and you will once \ again be fighting for our freedom... not from tyranny, oppression, or persecution... \ but from annihilation. We are fighting for our right to live. To exist. And should we \ win the day, the Fourth of July will no longer be known as an American holiday, but \ as the day the world declared in one voice: We will not go quietly into the night! We \ will not vanish without a fight! We're going to live on! We're going to survive! \ Today we celebrate our Independence Day!" ;; let%expect_test _ = for len = 0 to 32 do printf "%d:\n" len; test (String.sub string ~pos:746 ~len) done; [%expect {| 0: 1: 00000000 57 |W| 2: 00000000 57 65 |We| 3: 00000000 57 65 20 |We | 4: 00000000 57 65 20 77 |We w| 5: 00000000 57 65 20 77 69 |We wi| 6: 00000000 57 65 20 77 69 6c |We wil| 7: 00000000 57 65 20 77 69 6c 6c |We will| 8: 00000000 57 65 20 77 69 6c 6c 20 |We will | 9: 00000000 57 65 20 77 69 6c 6c 20 6e |We will n| 10: 00000000 57 65 20 77 69 6c 6c 20 6e 6f |We will no| 11: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 |We will not| 12: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 |We will not | 13: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 |We will not v| 14: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 |We will not va| 15: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e |We will not van| 16: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 17: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 00000010 73 |s| 18: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 00000010 73 68 |sh| 19: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 00000010 73 68 20 |sh | 20: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 00000010 73 68 20 77 |sh w| 21: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 00000010 73 68 20 77 69 |sh wi| 22: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 00000010 73 68 20 77 69 74 |sh wit| 23: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 00000010 73 68 20 77 69 74 68 |sh with| 24: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 00000010 73 68 20 77 69 74 68 6f |sh witho| 25: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 00000010 73 68 20 77 69 74 68 6f 75 |sh withou| 26: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 00000010 73 68 20 77 69 74 68 6f 75 74 |sh without| 27: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 00000010 73 68 20 77 69 74 68 6f 75 74 20 |sh without | 28: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 00000010 73 68 20 77 69 74 68 6f 75 74 20 61 |sh without a| 29: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 00000010 73 68 20 77 69 74 68 6f 75 74 20 61 20 |sh without a | 30: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 00000010 73 68 20 77 69 74 68 6f 75 74 20 61 20 66 |sh without a f| 31: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 00000010 73 68 20 77 69 74 68 6f 75 74 20 61 20 66 69 |sh without a fi| 32: 00000000 57 65 20 77 69 6c 6c 20 6e 6f 74 20 76 61 6e 69 |We will not vani| 00000010 73 68 20 77 69 74 68 6f 75 74 20 61 20 66 69 67 |sh without a fig| |}]; test string; [%expect {| 00000000 47 6f 6f 64 20 6d 6f 72 6e 69 6e 67 2e 20 49 6e |Good morning. In| 00000010 20 6c 65 73 73 20 74 68 61 6e 20 61 6e 20 68 6f | less than an ho| 00000020 75 72 2c 20 61 69 72 63 72 61 66 74 20 66 72 6f |ur, aircraft fro| 00000030 6d 20 68 65 72 65 20 77 69 6c 6c 20 6a 6f 69 6e |m here will join| 00000040 20 6f 74 68 65 72 73 20 66 72 6f 6d 20 61 72 6f | others from aro| 00000050 75 6e 64 20 74 68 65 20 77 6f 72 6c 64 2e 20 41 |und the world. A| 00000060 6e 64 20 79 6f 75 20 77 69 6c 6c 20 62 65 20 6c |nd you will be l| 00000070 61 75 6e 63 68 69 6e 67 20 74 68 65 20 6c 61 72 |aunching the lar| 00000080 67 65 73 74 20 61 65 72 69 61 6c 20 62 61 74 74 |gest aerial batt| 00000090 6c 65 20 69 6e 20 74 68 65 20 68 69 73 74 6f 72 |le in the histor| 000000a0 79 20 6f 66 20 6d 61 6e 6b 69 6e 64 2e 20 22 4d |y of mankind. "M| 000000b0 61 6e 6b 69 6e 64 2e 22 20 54 68 61 74 20 77 6f |ankind." That wo| 000000c0 72 64 20 73 68 6f 75 6c 64 20 68 61 76 65 20 6e |rd should have n| 000000d0 65 77 20 6d 65 61 6e 69 6e 67 20 66 6f 72 20 61 |ew meaning for a| 000000e0 6c 6c 20 6f 66 20 75 73 20 74 6f 64 61 79 2e 20 |ll of us today. | 000000f0 57 65 20 63 61 6e 27 74 20 62 65 20 63 6f 6e 73 |We can't be cons| 00000100 75 6d 65 64 20 62 79 20 6f 75 72 20 70 65 74 74 |umed by our pett| 00000110 79 20 64 69 66 66 65 72 65 6e 63 65 73 20 61 6e |y differences an| 00000120 79 6d 6f 72 65 2e 20 57 65 20 77 69 6c 6c 20 62 |ymore. We will b| 00000130 65 20 75 6e 69 74 65 64 20 69 6e 20 6f 75 72 20 |e united in our | 00000140 63 6f 6d 6d 6f 6e 20 69 6e 74 65 72 65 73 74 73 |common interests| 00000150 2e 20 50 65 72 68 61 70 73 20 69 74 27 73 20 66 |. Perhaps it's f| 00000160 61 74 65 20 74 68 61 74 20 74 6f 64 61 79 20 69 |ate that today i| 00000170 73 20 74 68 65 20 46 6f 75 72 74 68 20 6f 66 20 |s the Fourth of | 00000180 4a 75 6c 79 2c 20 61 6e 64 20 79 6f 75 20 77 69 |July, and you wi| 00000190 6c 6c 20 6f 6e 63 65 20 61 67 61 69 6e 20 62 65 |ll once again be| 000001a0 20 66 69 67 68 74 69 6e 67 20 66 6f 72 20 6f 75 | fighting for ou| 000001b0 72 20 66 72 65 65 64 6f 6d 2e 2e 2e 20 6e 6f 74 |r freedom... not| 000001c0 20 66 72 6f 6d 20 74 79 72 61 6e 6e 79 2c 20 6f | from tyranny, o| 000001d0 70 70 72 65 73 73 69 6f 6e 2c 20 6f 72 20 70 65 |ppression, or pe| 000001e0 72 73 65 63 75 74 69 6f 6e 2e 2e 2e 20 62 75 74 |rsecution... but| 000001f0 20 66 72 6f 6d 20 61 6e 6e 69 68 69 6c 61 74 69 | from annihilati| 00000200 6f 6e 2e 20 57 65 20 61 72 65 20 66 69 67 68 74 |on. We are fight| 00000210 69 6e 67 20 66 6f 72 20 6f 75 72 20 72 69 67 68 |ing for our righ| 00000220 74 20 74 6f 20 6c 69 76 65 2e 20 54 6f 20 65 78 |t to live. To ex| 00000230 69 73 74 2e 20 41 6e 64 20 73 68 6f 75 6c 64 20 |ist. And should | 00000240 77 65 20 77 69 6e 20 74 68 65 20 64 61 79 2c 20 |we win the day, | 00000250 74 68 65 20 46 6f 75 72 74 68 20 6f 66 20 4a 75 |the Fourth of Ju| 00000260 6c 79 20 77 69 6c 6c 20 6e 6f 20 6c 6f 6e 67 65 |ly will no longe| 00000270 72 20 62 65 20 6b 6e 6f 77 6e 20 61 73 20 61 6e |r be known as an| 00000280 20 41 6d 65 72 69 63 61 6e 20 68 6f 6c 69 64 61 | American holida| 00000290 79 2c 20 62 75 74 20 61 73 20 74 68 65 20 64 61 |y, but as the da| 000002a0 79 20 74 68 65 20 77 6f 72 6c 64 20 64 65 63 6c |y the world decl| 000002b0 61 72 65 64 20 69 6e 20 6f 6e 65 20 76 6f 69 63 |ared in one voic| 000002c0 65 3a 20 57 65 20 77 69 6c 6c 20 6e 6f 74 20 67 |e: We will not g| 000002d0 6f 20 71 75 69 65 74 6c 79 20 69 6e 74 6f 20 74 |o quietly into t| 000002e0 68 65 20 6e 69 67 68 74 21 20 57 65 20 77 69 6c |he night! We wil| 000002f0 6c 20 6e 6f 74 20 76 61 6e 69 73 68 20 77 69 74 |l not vanish wit| 00000300 68 6f 75 74 20 61 20 66 69 67 68 74 21 20 20 57 |hout a fight! W| 00000310 65 27 72 65 20 67 6f 69 6e 67 20 74 6f 20 6c 69 |e're going to li| 00000320 76 65 20 6f 6e 21 20 57 65 27 72 65 20 67 6f 69 |ve on! We're goi| 00000330 6e 67 20 74 6f 20 73 75 72 76 69 76 65 21 20 54 |ng to survive! T| 00000340 6f 64 61 79 20 77 65 20 63 65 6c 65 62 72 61 74 |oday we celebrat| 00000350 65 20 6f 75 72 20 49 6e 64 65 70 65 6e 64 65 6e |e our Independen| 00000360 63 65 20 44 61 79 21 |ce Day!| |}]; for max_lines = 0 to 10 do printf "%d:\n" max_lines; test string ~max_lines done; [%expect {| 0: 00000000 47 6f 6f 64 20 6d 6f 72 6e 69 6e 67 2e 20 49 6e |Good morning. In| ... 00000360 63 65 20 44 61 79 21 |ce Day!| 1: 00000000 47 6f 6f 64 20 6d 6f 72 6e 69 6e 67 2e 20 49 6e |Good morning. In| ... 00000360 63 65 20 44 61 79 21 |ce Day!| 2: 00000000 47 6f 6f 64 20 6d 6f 72 6e 69 6e 67 2e 20 49 6e |Good morning. In| ... 00000360 63 65 20 44 61 79 21 |ce Day!| 3: 00000000 47 6f 6f 64 20 6d 6f 72 6e 69 6e 67 2e 20 49 6e |Good morning. In| ... 00000360 63 65 20 44 61 79 21 |ce Day!| 4: 00000000 47 6f 6f 64 20 6d 6f 72 6e 69 6e 67 2e 20 49 6e |Good morning. In| ... 00000350 65 20 6f 75 72 20 49 6e 64 65 70 65 6e 64 65 6e |e our Independen| 00000360 63 65 20 44 61 79 21 |ce Day!| 5: 00000000 47 6f 6f 64 20 6d 6f 72 6e 69 6e 67 2e 20 49 6e |Good morning. In| 00000010 20 6c 65 73 73 20 74 68 61 6e 20 61 6e 20 68 6f | less than an ho| ... 00000350 65 20 6f 75 72 20 49 6e 64 65 70 65 6e 64 65 6e |e our Independen| 00000360 63 65 20 44 61 79 21 |ce Day!| 6: 00000000 47 6f 6f 64 20 6d 6f 72 6e 69 6e 67 2e 20 49 6e |Good morning. In| 00000010 20 6c 65 73 73 20 74 68 61 6e 20 61 6e 20 68 6f | less than an ho| ... 00000340 6f 64 61 79 20 77 65 20 63 65 6c 65 62 72 61 74 |oday we celebrat| 00000350 65 20 6f 75 72 20 49 6e 64 65 70 65 6e 64 65 6e |e our Independen| 00000360 63 65 20 44 61 79 21 |ce Day!| 7: 00000000 47 6f 6f 64 20 6d 6f 72 6e 69 6e 67 2e 20 49 6e |Good morning. In| 00000010 20 6c 65 73 73 20 74 68 61 6e 20 61 6e 20 68 6f | less than an ho| 00000020 75 72 2c 20 61 69 72 63 72 61 66 74 20 66 72 6f |ur, aircraft fro| ... 00000340 6f 64 61 79 20 77 65 20 63 65 6c 65 62 72 61 74 |oday we celebrat| 00000350 65 20 6f 75 72 20 49 6e 64 65 70 65 6e 64 65 6e |e our Independen| 00000360 63 65 20 44 61 79 21 |ce Day!| 8: 00000000 47 6f 6f 64 20 6d 6f 72 6e 69 6e 67 2e 20 49 6e |Good morning. In| 00000010 20 6c 65 73 73 20 74 68 61 6e 20 61 6e 20 68 6f | less than an ho| 00000020 75 72 2c 20 61 69 72 63 72 61 66 74 20 66 72 6f |ur, aircraft fro| ... 00000330 6e 67 20 74 6f 20 73 75 72 76 69 76 65 21 20 54 |ng to survive! T| 00000340 6f 64 61 79 20 77 65 20 63 65 6c 65 62 72 61 74 |oday we celebrat| 00000350 65 20 6f 75 72 20 49 6e 64 65 70 65 6e 64 65 6e |e our Independen| 00000360 63 65 20 44 61 79 21 |ce Day!| 9: 00000000 47 6f 6f 64 20 6d 6f 72 6e 69 6e 67 2e 20 49 6e |Good morning. In| 00000010 20 6c 65 73 73 20 74 68 61 6e 20 61 6e 20 68 6f | less than an ho| 00000020 75 72 2c 20 61 69 72 63 72 61 66 74 20 66 72 6f |ur, aircraft fro| 00000030 6d 20 68 65 72 65 20 77 69 6c 6c 20 6a 6f 69 6e |m here will join| ... 00000330 6e 67 20 74 6f 20 73 75 72 76 69 76 65 21 20 54 |ng to survive! T| 00000340 6f 64 61 79 20 77 65 20 63 65 6c 65 62 72 61 74 |oday we celebrat| 00000350 65 20 6f 75 72 20 49 6e 64 65 70 65 6e 64 65 6e |e our Independen| 00000360 63 65 20 44 61 79 21 |ce Day!| 10: 00000000 47 6f 6f 64 20 6d 6f 72 6e 69 6e 67 2e 20 49 6e |Good morning. In| 00000010 20 6c 65 73 73 20 74 68 61 6e 20 61 6e 20 68 6f | less than an ho| 00000020 75 72 2c 20 61 69 72 63 72 61 66 74 20 66 72 6f |ur, aircraft fro| 00000030 6d 20 68 65 72 65 20 77 69 6c 6c 20 6a 6f 69 6e |m here will join| ... 00000320 76 65 20 6f 6e 21 20 57 65 27 72 65 20 67 6f 69 |ve on! We're goi| 00000330 6e 67 20 74 6f 20 73 75 72 76 69 76 65 21 20 54 |ng to survive! T| 00000340 6f 64 61 79 20 77 65 20 63 65 6c 65 62 72 61 74 |oday we celebrat| 00000350 65 20 6f 75 72 20 49 6e 64 65 70 65 6e 64 65 6e |e our Independen| 00000360 63 65 20 44 61 79 21 |ce Day!| |}]; test string ~pos:707 ~len:123; [%expect {| 000002c3 57 65 20 77 69 6c 6c 20 6e 6f 74 20 67 6f 20 71 |We will not go q| 000002d3 75 69 65 74 6c 79 20 69 6e 74 6f 20 74 68 65 20 |uietly into the | 000002e3 6e 69 67 68 74 21 20 57 65 20 77 69 6c 6c 20 6e |night! We will n| 000002f3 6f 74 20 76 61 6e 69 73 68 20 77 69 74 68 6f 75 |ot vanish withou| 00000303 74 20 61 20 66 69 67 68 74 21 20 20 57 65 27 72 |t a fight! We'r| 00000313 65 20 67 6f 69 6e 67 20 74 6f 20 6c 69 76 65 20 |e going to live | 00000323 6f 6e 21 20 57 65 27 72 65 20 67 6f 69 6e 67 20 |on! We're going | 00000333 74 6f 20 73 75 72 76 69 76 65 21 |to survive!| |}]; test string ~pos:707 ~max_lines:10; [%expect {| 000002c3 57 65 20 77 69 6c 6c 20 6e 6f 74 20 67 6f 20 71 |We will not go q| 000002d3 75 69 65 74 6c 79 20 69 6e 74 6f 20 74 68 65 20 |uietly into the | 000002e3 6e 69 67 68 74 21 20 57 65 20 77 69 6c 6c 20 6e |night! We will n| 000002f3 6f 74 20 76 61 6e 69 73 68 20 77 69 74 68 6f 75 |ot vanish withou| ... 00000323 6f 6e 21 20 57 65 27 72 65 20 67 6f 69 6e 67 20 |on! We're going | 00000333 74 6f 20 73 75 72 76 69 76 65 21 20 54 6f 64 61 |to survive! Toda| 00000343 79 20 77 65 20 63 65 6c 65 62 72 61 74 65 20 6f |y we celebrate o| 00000353 75 72 20 49 6e 64 65 70 65 6e 64 65 6e 63 65 20 |ur Independence | 00000363 44 61 79 21 |Day!| |}]; test string ~pos:707 ~max_lines:20; [%expect {| 000002c3 57 65 20 77 69 6c 6c 20 6e 6f 74 20 67 6f 20 71 |We will not go q| 000002d3 75 69 65 74 6c 79 20 69 6e 74 6f 20 74 68 65 20 |uietly into the | 000002e3 6e 69 67 68 74 21 20 57 65 20 77 69 6c 6c 20 6e |night! We will n| 000002f3 6f 74 20 76 61 6e 69 73 68 20 77 69 74 68 6f 75 |ot vanish withou| 00000303 74 20 61 20 66 69 67 68 74 21 20 20 57 65 27 72 |t a fight! We'r| 00000313 65 20 67 6f 69 6e 67 20 74 6f 20 6c 69 76 65 20 |e going to live | 00000323 6f 6e 21 20 57 65 27 72 65 20 67 6f 69 6e 67 20 |on! We're going | 00000333 74 6f 20 73 75 72 76 69 76 65 21 20 54 6f 64 61 |to survive! Toda| 00000343 79 20 77 65 20 63 65 6c 65 62 72 61 74 65 20 6f |y we celebrate o| 00000353 75 72 20 49 6e 64 65 70 65 6e 64 65 6e 63 65 20 |ur Independence | 00000363 44 61 79 21 |Day!| |}] ;; let%expect_test "pretty" = let test x = print_s ([%sexp_of: String.Hexdump.Pretty.t] x) in test "The world is everything that is the case."; [%expect {| "The world is everything that is the case." |}]; test "What\000are\255 these\001weird bytes?\xfe"; [%expect {| ("00000000 57 68 61 74 00 61 72 65 ff 20 74 68 65 73 65 01 |What.are. these.|" "00000010 77 65 69 72 64 20 62 79 74 65 73 3f fe |weird bytes?.|") |}] ;; core-0.15.0/core/test/src/test_hexdump.mli000066400000000000000000000000551420273305200204350ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_host_and_port.ml000066400000000000000000000005321420273305200214550ustar00rootroot00000000000000open! Core open! Import let%expect_test "validate sexp grammar" = require_ok [%here] (Sexp_grammar_validation.validate_grammar (module struct type t = Host_and_port.Stable.V1.t [@@deriving quickcheck, sexp, sexp_grammar] end)); [%expect {| (Union (String (List (Cons String (Cons Integer Empty))))) |}] ;; core-0.15.0/core/test/src/test_host_and_port.mli000066400000000000000000000000551420273305200216260ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_identifiable.ml000066400000000000000000000060401420273305200212310ustar00rootroot00000000000000open! Core open! Import open! Identifiable (* The unit test below checks that for a call to [Identifiable.Make], the functions in the resulting module call the functions in the argument module the correct number of times. *) let%test_module _ = (module struct module Counter = struct type t = | Compare | Hash | Of_string | Sexp_of_t | T_of_sexp | To_string [@@deriving compare, hash, sexp] end open Counter module Counts = struct module Map = Map.Make (Counter) type t = int Map.t ref [@@deriving sexp_of] let actual = ref Map.empty let expected = ref Map.empty let incr ?(by = 1) t counter = t := Map.update !t counter ~f:(function | None -> by | Some i -> i + by) ;; let check location = if not (Map.equal ( = ) !actual !expected) then failwiths ~here:[%here] "mismatch" (location, `actual actual, `expected expected) [%sexp_of: Source_code_position.t * [ `actual of t ] * [ `expected of t ]] ;; end module T = struct let module_name = "Core.Identifiable.T" type t = | A | B [@@deriving bin_io, compare, hash, sexp] include Sexpable.To_stringable (struct type nonrec t = t [@@deriving sexp] end) let incr ?by counter = Counts.incr Counts.actual counter ?by let compare t1 t2 = incr Compare; compare t1 t2 ;; let hash t = incr Hash; hash t ;; let sexp_of_t t = incr Sexp_of_t; sexp_of_t t ;; let t_of_sexp t = incr T_of_sexp; t_of_sexp t ;; let of_string t = incr Of_string; of_string t ;; let to_string t = incr To_string; to_string t ;; end module Id = Make (T) let int_equal (i1 : int) i2 = Poly.equal i1 i2 let%test_unit _ = let open T in let open Id in let check = Counts.check in let incr ?by counter = Counts.incr Counts.expected counter ?by in check [%here]; ignore (to_string A : string); incr To_string; check [%here]; ignore (of_string "A" : t); incr Of_string; check [%here]; ignore (t_of_sexp (Sexplib.Sexp.of_string "A") : t); incr T_of_sexp; check [%here]; ignore (sexp_of_t A : Base.Sexp.t); incr Sexp_of_t; check [%here]; assert (int_equal (compare A A) 0); incr Compare; check [%here]; assert (int_equal (compare A B) (-1)); incr Compare; check [%here]; assert (int_equal (compare B A) 1); incr Compare; check [%here]; ignore (not (int_equal (hash A) (hash B)) : bool); incr Hash ~by:2; check [%here]; let bigstring = Binable.to_bigstring (module T) A in check [%here]; assert (Poly.equal A (Binable.of_bigstring (module T) bigstring)); check [%here] ;; end) ;; core-0.15.0/core/test/src/test_identifiable.mli000066400000000000000000000000551420273305200214020ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_int63.ml000066400000000000000000000002201420273305200175470ustar00rootroot00000000000000open! Core open! Import open! Int63 let%expect_test _ = print_string [%bin_digest: t]; [%expect {| 2b528f4b22f08e28876ffe0239315ac2 |}] ;; core-0.15.0/core/test/src/test_int63.mli000066400000000000000000000000551420273305200177260ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_list.ml000066400000000000000000000100241420273305200175620ustar00rootroot00000000000000open! Core open! Expect_test_helpers_core open! List let print2 x1 x2 = print_s [%message (x1 : int) (x2 : int)] let print3 x1 x2 x3 = print_s [%message (x1 : int) (x2 : int) (x3 : int)] let print2_and_return result x1 x2 = print2 x1 x2; result ;; let test2 list_f f sexp_of_result = print_s [%message "" ~result:(list_f [ 1 ] [ 2; 3 ] ~f : result Or_unequal_lengths.t)]; print_s [%message "" ~result:(list_f [ 1; 2 ] [ 3; 4 ] ~f : result Or_unequal_lengths.t)] ;; let test3 list_f f sexp_of_result = print_s [%message "" ~result:(list_f [ 1 ] [ 2; 3 ] [ 4; 5 ] ~f : result Or_unequal_lengths.t)]; print_s [%message "" ~result:(list_f [ 1; 2 ] [ 3; 4 ] [ 5; 6 ] ~f : result Or_unequal_lengths.t)] ;; let%expect_test "[exists2]" = test2 exists2 (print2_and_return false) [%sexp_of: bool]; [%expect {| (result Unequal_lengths) ((x1 1) (x2 3)) ((x1 2) (x2 4)) (result (Ok false)) |}]; test2 exists2 (print2_and_return true) [%sexp_of: bool]; [%expect {| (result Unequal_lengths) ((x1 1) (x2 3)) (result (Ok true)) |}] ;; let%expect_test "[fold2]" = test2 (fold2 ~init:[]) (fun ac x1 x2 -> print2 x1 x2; (x1, x2) :: ac) [%sexp_of: (int * int) list]; [%expect {| (result Unequal_lengths) ((x1 1) (x2 3)) ((x1 2) (x2 4)) (result ( Ok ( (2 4) (1 3)))) |}] ;; let%expect_test "[for_all2]" = test2 for_all2 (print2_and_return false) [%sexp_of: bool]; [%expect {| (result Unequal_lengths) ((x1 1) (x2 3)) (result (Ok false)) |}]; test2 for_all2 (print2_and_return true) [%sexp_of: bool]; [%expect {| (result Unequal_lengths) ((x1 1) (x2 3)) ((x1 2) (x2 4)) (result (Ok true)) |}] ;; let%expect_test "[iter2]" = test2 iter2 (print2_and_return ()) [%sexp_of: unit]; [%expect {| (result Unequal_lengths) ((x1 1) (x2 3)) ((x1 2) (x2 4)) (result (Ok ())) |}] ;; let%expect_test "[map2]" = test2 map2 (fun x1 x2 -> print2 x1 x2; x1, x2) [%sexp_of: (int * int) list]; [%expect {| (result Unequal_lengths) ((x1 1) (x2 3)) ((x1 2) (x2 4)) (result ( Ok ( (1 3) (2 4)))) |}] ;; let%expect_test "[map3]" = test3 map3 (fun x1 x2 x3 -> print3 x1 x2 x3; x1, x2, x3) [%sexp_of: (int * int * int) list]; [%expect {| (result Unequal_lengths) ((x1 1) (x2 3) (x3 5)) ((x1 2) (x2 4) (x3 6)) (result ( Ok ( (1 3 5) (2 4 6)))) |}] ;; let%expect_test "[rev_map2]" = test2 rev_map2 (fun x1 x2 -> print2 x1 x2; x1, x2) [%sexp_of: (int * int) list]; [%expect {| (result Unequal_lengths) ((x1 1) (x2 3)) ((x1 2) (x2 4)) (result ( Ok ( (2 4) (1 3)))) |}] ;; let%expect_test "[rev_map3]" = test3 rev_map3 (fun x1 x2 x3 -> print3 x1 x2 x3; x1, x2, x3) [%sexp_of: (int * int * int) list]; [%expect {| (result Unequal_lengths) ((x1 1) (x2 3) (x3 5)) ((x1 2) (x2 4) (x3 6)) (result ( Ok ( (2 4 6) (1 3 5)))) |}] ;; let%test_module "zip_with_remainder" = (module struct let check left right ~expect = [%test_result: (int * string) list * (int list, string list) Either.t option] (List.zip_with_remainder left right) ~expect ;; let numbers = [ 1; 2; 3 ] let words = [ "One"; "Two"; "Three" ] let%test_unit "equal length" = let expect = [ 1, "One"; 2, "Two"; 3, "Three" ], None in check numbers words ~expect ;; let%test_unit "right is longer" = let expect = [ 1, "One" ], Some (Second [ "Two"; "Three" ]) in check [ 1 ] words ~expect ;; let%test_unit "left is longer" = let expect = [ 1, "One" ], Some (First [ 2; 3 ]) in check numbers [ "One" ] ~expect ;; let%test_unit "empty" = check [] [] ~expect:([], None) end) ;; core-0.15.0/core/test/src/test_list.mli000066400000000000000000000000551420273305200177360ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_map.ml000066400000000000000000000052671420273305200174010ustar00rootroot00000000000000open! Import open! Core open! Map let%expect_test "Symmetric_diff_element.map_data" = let print x = print_s [%sexp (x : (string, int) Symmetric_diff_element.t)] in let f x = x + 1 in print (Symmetric_diff_element.map_data ("foo", `Left 1) ~f); [%expect {| (foo (Left 2)) |}]; print (Symmetric_diff_element.map_data ("foo", `Right 5) ~f); [%expect {| (foo (Right 6)) |}]; print (Symmetric_diff_element.map_data ("foo", `Unequal (10, 12)) ~f); [%expect {| (foo (Unequal (11 13))) |}] ;; let%expect_test "Symmetric_diff_element.{left,right}" = let values = [ "foo", `Left 1; "bar", `Right 2; "baz", `Unequal (3, 4) ] in let go f = List.iter values ~f:(fun sd_elt -> printf !"%{sexp: (string, int) Symmetric_diff_element.t} => %{sexp: int option}\n" sd_elt (f sd_elt)) in go Symmetric_diff_element.left; [%expect {| (foo (Left 1)) => (1) (bar (Right 2)) => () (baz (Unequal (3 4))) => (3) |}]; go Symmetric_diff_element.right; [%expect {| (foo (Left 1)) => () (bar (Right 2)) => (2) (baz (Unequal (3 4))) => (4) |}] ;; let%expect_test _ = let open Expect_test_helpers_core in print_and_check_stable_type [%here] (module struct type t = int Map.M(Int).t [@@deriving bin_io, compare, sexp] end) ([ []; [ 1 ]; [ 1; 2 ]; [ 1; 2; 3 ] ] |> List.map ~f:(fun xs -> Map.of_alist_exn (module Int) (xs |> List.map ~f:(fun x -> x, x + 1)))); [%expect {| (bin_shape_digest ed73a010af8ffc32cab7411d6be2d676) ((sexp ()) (bin_io "\000")) ((sexp ((1 2))) (bin_io "\001\001\002")) ((sexp ( (1 2) (2 3))) (bin_io "\002\001\002\002\003")) ((sexp ( (1 2) (2 3) (3 4))) (bin_io "\003\001\002\002\003\003\004")) |}] ;; let%expect_test "remove does not allocate too much if there's nothing to do" = let map1 = Map.of_alist_exn (module Int) [ 1, "one"; 3, "three" ] in (* This is a regression test. Previously this no-op remove allocated 16 words. Ideally, we wouldn't allocate the pair returned by [Tree0.remove] either. *) Expect_test_helpers_core.require_allocation_does_not_exceed (Minor_words 3) [%here] (fun () -> ignore (Sys.opaque_identity (Map.remove map1 2) : string Map.M(Int).t)) ;; let%expect_test "[map_keys]" = let test m c ~f = print_s [%sexp (Map.map_keys c ~f m : [ `Duplicate_key of string | `Ok of string String.Map.t ])] in let map = Int.Map.of_alist_exn [ 1, "one"; 2, "two"; 3, "three" ] in test map (module String) ~f:Int.to_string; [%expect {| (Ok ((1 one) (2 two) (3 three))) |}]; test map (module String) ~f:(fun x -> Int.to_string (x / 2)); [%expect {| (Duplicate_key 1) |}] ;; core-0.15.0/core/test/src/test_map.mlt000066400000000000000000000004761420273305200175620ustar00rootroot00000000000000open Core let _ = Map.add [%%expect {| |}] let _ = String.Map.add [%%expect {| |}] module F (M : Map.S) = struct let _ = M.add end [%%expect {| |}] module F (M : Core.Map.S_binable) = struct let _ = M.add end [%%expect {| |}] module F (M : Core.Map.S_plain) = struct let _ = M.add end [%%expect {| |}] core-0.15.0/core/test/src/test_maybe_bound.ml000066400000000000000000000057031420273305200211030ustar00rootroot00000000000000open! Core open! Import open! Maybe_bound let%test_module "[As_lower_bound.compare], [As_upper_bound.compare]" = (module struct module Ord = struct type t = | O1 | O2 | O3 [@@deriving compare, enumerate, sexp_of] end type t = Ord.t Maybe_bound.t [@@deriving enumerate, sexp_of] type lower = Ord.t As_lower_bound.t [@@deriving compare] type upper = Ord.t As_upper_bound.t [@@deriving compare] let sorted_lower = List.sort all ~compare:[%compare: lower] let sorted_upper = List.sort all ~compare:[%compare: upper] let%expect_test _ = print_s [%sexp (sorted_lower : t list)]; [%expect {| (Unbounded (Incl O1) (Excl O1) (Incl O2) (Excl O2) (Incl O3) (Excl O3)) |}]; print_s [%sexp (sorted_upper : t list)]; [%expect {| ((Excl O1) (Incl O1) (Excl O2) (Incl O2) (Excl O3) (Incl O3) Unbounded) |}] ;; let%test _ = List.is_sorted_strictly sorted_lower ~compare:[%compare: lower] let%test _ = List.is_sorted_strictly sorted_upper ~compare:[%compare: upper] let test_compare compare bound1 bound2 ok = let comparison = compare bound1 bound2 in require [%here] (ok comparison) ~if_false_then_print_s: (lazy [%message "comparison produced unexpected value" (bound1 : t) (bound2 : t) (comparison : int)]) ;; let test_sorted compare sorted = let sorted = Array.of_list sorted in let len = Array.length sorted in for i = 0 to len - 1 do test_compare compare sorted.(i) sorted.(i) (fun c -> c = 0); for j = i + 1 to len - 1 do test_compare compare sorted.(i) sorted.(j) (fun c -> c < 0); test_compare compare sorted.(j) sorted.(i) (fun c -> c > 0) done done ;; let%expect_test _ = test_sorted [%compare: lower] sorted_lower let%expect_test _ = test_sorted [%compare: upper] sorted_upper let%expect_test "relationship between [As_lower_bound.compare] and [is_lower_bound]" = List.iter all ~f:(fun t1 -> List.iter all ~f:(fun t2 -> List.iter Ord.all ~f:(fun a -> let compare = Ord.compare in if As_lower_bound.compare compare t1 t2 <= 0 && is_lower_bound t2 ~of_:a ~compare then require [%here] (is_lower_bound t1 ~of_:a ~compare)))) ;; let%expect_test "relationship between [As_upper_bound.compare] and [is_upper_bound]" = List.iter all ~f:(fun t1 -> List.iter all ~f:(fun t2 -> List.iter Ord.all ~f:(fun a -> let compare = Ord.compare in if As_upper_bound.compare compare t1 t2 <= 0 && is_upper_bound t1 ~of_:a ~compare then require [%here] (is_upper_bound t2 ~of_:a ~compare)))) ;; end) ;; core-0.15.0/core/test/src/test_maybe_bound.mli000066400000000000000000000000551420273305200212470ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_md5.ml000066400000000000000000000037651420273305200173120ustar00rootroot00000000000000open Core open Expect_test_helpers_core open Md5 let%expect_test "digest_bin_prot" = let test (type t) (t : t) (module M : Binable.S with type t = t) = print_s [%sexp (digest_bin_prot M.bin_writer_t t : Md5.t)] in test () (module Unit); test 1337 (module Int); [%expect {| 93b885adfe0da089cdf634904fd59f71 22eaa1d1a43daf2abf8bb3f7b8d0128c |}] ;; let%test_module "Md5.As_binary_string.V1" = (module Stable_unit_test.Make (struct include As_binary_string.Stable.V1 let equal = [%compare.equal: t] let tests = [ ( digest_string "" , {|"\212\029\140\217\143\000\178\004\233\128\t\152\236\248B~"|} , "\016\212\029\140\217\143\000\178\004\233\128\t\152\236\248B~" ) ; ( digest_string "x" , {|"\157\212\228a&\140\1284\245\200VN\021\\g\166"|} , "\016\157\212\228a&\140\1284\245\200VN\021\\g\166" ) ] ;; end)) ;; let%test_module "Md5.V1" = (module Stable_unit_test.Make (struct include Stable.V1 let equal = [%compare.equal: t] let tests = [ ( digest_string "" , "d41d8cd98f00b204e9800998ecf8427e" , "\212\029\140\217\143\000\178\004\233\128\t\152\236\248B~" ) ; ( digest_string "x" , "9dd4e461268c8034f5c8564e155c67a6" , "\157\212\228a&\140\1284\245\200VN\021\\g\166" ) ] ;; end)) ;; let%test_unit "Md5.digest_file_blocking" = let cwd = Caml.Sys.getcwd () in let file = Filename.concat cwd (Filename.basename [%here].pos_fname) in let our_digest = digest_file_blocking file in let actual_digest = Md5.of_binary_exn (Caml.Digest.file file) in [%test_result: Md5.t] our_digest ~expect:actual_digest; assert (Exn.does_raise (fun () -> digest_file_blocking cwd)) ;; let%test_unit "Md5.digest_subbigstring" = let bigstr = Bigstring.of_string "abcd" in let d1 = Md5.digest_subbigstring bigstr ~pos:1 ~len:2 in let d2 = Md5.digest_string "bc" in [%test_result: Md5.t] d1 ~expect:d2 ;; core-0.15.0/core/test/src/test_md5.mli000066400000000000000000000000551420273305200174500ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_memo.ml000066400000000000000000000073551420273305200175610ustar00rootroot00000000000000open! Core open! Import open! Memo let%test_module "lru" = (module struct let count = ref 0 (* number of times f underlying function is run *) let f = general ~cache_size_bound:3 (fun i -> incr count; i) ;; let%test _ = f 0 = 0 let%test _ = !count = 1 let%test _ = f 1 = 1 let%test _ = !count = 2 let%test _ = f 0 = 0 let%test _ = !count = 2 let%test _ = f 3 = 3 (* cache full *) let%test _ = !count = 3 let%test _ = f 4 = 4 (* evict 1 *) let%test _ = !count = 4 let%test _ = f 0 = 0 let%test _ = !count = 4 let%test _ = f 1 = 1 (* recompute 1 *) let%test _ = !count = 5 end) ;; let%test_module "comparable" = (module struct module Env = struct type t = { should_raise : bool ref ; f : int -> int } let create () = let should_raise = ref false in let f = of_comparable (module Int) (fun i -> print_s [%message "Computing value" (i : int)]; if !should_raise then raise_s [%message "I should raise"]; i + 1) in { should_raise; f } ;; end let%expect_test "Ensure no re computation" = let { Env.should_raise; f } = Env.create () in printf "%d" (f 5); [%expect {| ("Computing value" (i 5)) 6 |}]; should_raise := true; printf "%d" (f 5); [%expect {| 6 |}] ;; let%expect_test "What happens if f raises" = let { Env.should_raise; f } = Env.create () in should_raise := true; show_raise (fun () -> printf "%d" (f 5)); [%expect {| ("Computing value" (i 5)) (raised "I should raise") |}]; should_raise := false; show_raise (fun () -> printf "%d" (f 5)); [%expect {| (raised "I should raise") |}] ;; end) ;; let%expect_test "[general] on recursive functions" = let rec fib n = printf "fib %d\n" n; if n < 2 then n else fib (n - 1) + fib (n - 2) in let fib : int -> int = Memo.general ~hashable:Int.hashable fib in printf "%d\n" (fib 2); printf "%d\n" (fib 5); printf "%d\n" (fib 2); printf "%d\n" (fib 5); [%expect {| fib 2 fib 0 fib 1 1 fib 5 fib 3 fib 1 fib 2 fib 0 fib 1 fib 4 fib 2 fib 0 fib 1 fib 3 fib 1 fib 2 fib 0 fib 1 5 1 5 |}] ;; let%expect_test "recursive" = let fib fib n = printf "fib %d\n" n; if n < 2 then n else fib (n - 1) + fib (n - 2) in let fib : int -> int = Memo.recursive ~hashable:Int.hashable fib in printf "%d\n" (fib 2); printf "%d\n" (fib 5); printf "%d\n" (fib 10); [%expect {| fib 2 fib 0 fib 1 1 fib 5 fib 3 fib 4 5 fib 10 fib 8 fib 6 fib 7 fib 9 55 |}] ;; let%expect_test "infinite loop" = let call_count = ref 0 in let f = Memo.recursive ~hashable:Int.hashable (fun f x -> incr call_count; if !call_count > 100 then ( print_endline "infinite loop"; ()) else f x) in f 0; [%expect {| infinite loop |}] ;; let%expect_test "recursive memo initialization effects" = let fib fib = printf "initialization\n"; fun n -> printf "fib %d\n" n; if n < 2 then n else fib (n - 1) + fib (n - 2) in let fib : int -> int = Memo.recursive ~hashable:Int.hashable fib in [%expect {| initialization |}]; printf "%d\n" (fib 2); printf "%d\n" (fib 5); [%expect {| fib 2 fib 0 fib 1 1 fib 5 fib 3 fib 4 5 |}] ;; core-0.15.0/core/test/src/test_memo.mli000066400000000000000000000000551420273305200177200ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_month.ml000066400000000000000000000030611420273305200177370ustar00rootroot00000000000000open! Core open! Import open! Month let%test_module "Month.V1" = (module Stable_unit_test.Make (struct include Stable.V1 let equal t1 t2 = Int.( = ) 0 (compare t1 t2) let tests = let module V = Variant in let c rank sexp bin_io tests variant = assert (Int.( = ) variant.V.rank rank); (variant.V.constructor, sexp, bin_io) :: tests in Variants.fold ~init:[] ~jan:(c 0 "Jan" "\000") ~feb:(c 1 "Feb" "\001") ~mar:(c 2 "Mar" "\002") ~apr:(c 3 "Apr" "\003") ~may:(c 4 "May" "\004") ~jun:(c 5 "Jun" "\005") ~jul:(c 6 "Jul" "\006") ~aug:(c 7 "Aug" "\007") ~sep:(c 8 "Sep" "\008") ~oct:(c 9 "Oct" "\009") ~nov:(c 10 "Nov" "\010") ~dec:(c 11 "Dec" "\011") ;; end)) ;; let%test _ = Int.( = ) (List.length all) 12 let%test_unit _ = [%test_result: t] (List.fold (List.tl_exn all) ~init:Jan ~f:(fun last cur -> assert (Int.( = ) (compare last cur) (-1)); cur)) ~expect:Dec ;; let%test _ = Set.equal (Set.of_list [ Jan ]) (Set.t_of_sexp Sexp.(List [ Atom "0" ])) let%test _ = Poly.( = ) (sexp_of_t Jan) (Sexp.Atom "Jan") let%test _ = Jan = t_of_sexp (Sexp.Atom "Jan") let%test _ = Exn.does_raise (fun () -> t_of_sexp (Sexp.Atom "0")) let%test _ = shift Jan 12 = Jan let%test _ = shift Jan (-12) = Jan let%test _ = shift Jan 16 = May let%test _ = shift Jan (-16) = Sep let%test _ = shift Sep 1 = Oct let%test _ = shift Sep (-1) = Aug core-0.15.0/core/test/src/test_month.mli000066400000000000000000000000551420273305200201100ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_not_found.mlt000066400000000000000000000006611420273305200207740ustar00rootroot00000000000000open Core;; Not_found [%%expect {| Line _, characters _-_: Error (alert deprecated): Not_found [since 2018-02] Instead of raising [Not_found], consider using [raise_s] with an informative error message. If code needs to distinguish [Not_found] from other exceptions, please change it to handle both [Not_found] and [Not_found_s]. Then, instead of raising [Not_found], raise [Not_found_s] with an informative error message. |}] core-0.15.0/core/test/src/test_not_found2.mlt000066400000000000000000000006611420273305200210560ustar00rootroot00000000000000open Core;; Not_found [%%expect {| Line _, characters _-_: Error (alert deprecated): Not_found [since 2018-02] Instead of raising [Not_found], consider using [raise_s] with an informative error message. If code needs to distinguish [Not_found] from other exceptions, please change it to handle both [Not_found] and [Not_found_s]. Then, instead of raising [Not_found], raise [Not_found_s] with an informative error message. |}] core-0.15.0/core/test/src/test_nothing.ml000066400000000000000000000012101420273305200202520ustar00rootroot00000000000000open! Core open! Import let%expect_test "t_of_sexp" = require_does_raise [%here] (fun () -> Nothing.t_of_sexp (Sexp.List [])); [%expect {| (Of_sexp_error "Base.Nothing.t_of_sexp: trying to convert an empty type" (invalid_sexp ())) |}] ;; let%test_module "Stable.V1" = (module struct module Nothing = Nothing.Stable.V1 let%expect_test "t_of_sexp" = require_does_raise [%here] (fun () -> Nothing.t_of_sexp (Sexp.List [])); [%expect {| (Of_sexp_error "lib/core/src/nothing.ml.Stable.V1.t_of_sexp: trying to convert an empty type" (invalid_sexp ())) |}] ;; end) ;; core-0.15.0/core/test/src/test_nothing.mli000066400000000000000000000000551420273305200204310ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_option.ml000066400000000000000000000015611420273305200201250ustar00rootroot00000000000000open! Core open! Import open! Option let%test_module "shrinker" = (module struct module Shrinker = Quickcheck.Shrinker let t1 = Shrinker.create (Fn.const (Sequence.singleton 1)) let%test_unit _ = [%test_result: int option list] (Sequence.to_list (Shrinker.shrink (quickcheck_shrinker t1) None)) ~expect:[] ;; let%test_unit _ = let sort = List.sort ~compare:[%compare: int option] in let expect = [ None; Some 1 ] |> sort in let results = Shrinker.shrink (quickcheck_shrinker t1) (Some 5) |> Sequence.to_list |> sort in [%test_result: int option list] ~expect results ;; end) ;; let%expect_test "unsafe_value" = let test x = require [%here] (phys_equal x (Optional_syntax.Optional_syntax.unsafe_value (Some x))) in test 5; [%expect {| |}]; test "hello"; [%expect {| |}] ;; core-0.15.0/core/test/src/test_option.mli000066400000000000000000000000551420273305200202730ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_percent.ml000066400000000000000000000124551420273305200202610ustar00rootroot00000000000000open! Core open! Expect_test_helpers_core open! Percent let%test_module "Percent.V1" = (module Stable_unit_test.Make (struct include Stable.V1 let equal = equal let tests = [ of_mult 0.375, "37.5%", "\000\000\000\000\000\000\216?" ; of_mult 4.5, "4.5x", "\000\000\000\000\000\000\018@" ; of_mult 0.0002, "2bp", "-C\028\235\2266*?" ; of_mult 0.000075, "0.75bp", "a2U0*\169\019?" ] ;; end)) ;; let%expect_test "rounding" = let p = Percent.of_string "0.0123456%" in let tests = [ Percent.round_significant p ~significant_digits:4 ; Percent.round_decimal_mult p ~decimal_digits:4 ; Percent.round_decimal_percentage p ~decimal_digits:4 ; Percent.round_decimal_bp p ~decimal_digits:4 ] in printf !"%{sexp:Percent.t list}" tests; [%expect "(1.235bp 1bp 1.23bp 1.2346bp)"] ;; let%test_unit {| BUG: The sexp functions don't roundtrip. In this case problem is [of_percentage] divides by 100, and [of_string] scales by 0.01, which can yield different results. |} = let module V1 = Stable.V1 in let t = of_percentage 3.638 in [%test_result: int] (compare t (V1.t_of_sexp (V1.sexp_of_t t))) ~expect:(-1) ;; let%test_unit _ = (* [t_of_sexp] *) List.iter ~f:(fun (string, expected) -> assert (equal (t_of_sexp (Sexp.Atom string)) (of_mult expected))) [ "30%", 0.3 ; "3123bp", 0.3123 ; "3.17x", 3.17 ; "0.0003x", 0.0003 ; "0%", 0. ; "0bp", 0. ; "0x", 0. ; "0.000%", 0. ; "0.00bp", 0. ; "0.00x", 0. ; "3.1e5%", 3100. ; "3.1e5bp", 31. ; "3.1e5x", 310000. ; "10%", 0.1 ; "110%", 1.1 ; "0.1x", 0.1 ; "1.1x", 1.1 ; "0.001x", 0.001 ; "1bp", 0.0001 ; "10bp", 0.001 ; "100bp", 0.01 ; "1000bp", 0.1 ; "11000bp", 1.1 ; "1.1e4bp", 1.1 ; "50%", 0.5 ] ;; let%test_unit _ = (* [sexp_of_t] and [t_of_sexp] *) List.iter ~f:(fun (t1, expected) -> let t1 = of_mult t1 in let s = Sexp.to_string (sexp_of_t t1) in assert (String.equal s expected); let t2 = t_of_sexp (Sexp.of_string s) in assert (equal t1 t2)) [ 0.3, "30%" ; 0.335, "33.5%" ; 0.00335, "33.5bp" ; 33.46, "33.46x" ; 0.1, "10%" ; 0.99, "99%" ; 1., "1x" ; 10., "10x" ; 0.001, "10bp" ; 0.0001, "1bp" ; 0.00001, "0.1bp" ; 0.5, "50%" ] ;; let%test_unit _ = (* [to_string'] and [to_string_f] *) List.iter ~f:(fun (t, precision, format', expect, expectf) -> let t = of_mult t in let output' = format t (Format.compact_E ~precision) in assert (String.equal output' expect); let outputf = format t format' in assert (String.equal outputf expectf)) [ 0.3, 3, Format.decimal ~precision:3, "30%", "30.000%" ; 0.333, 4, Format.decimal ~precision:2, "33.3%", "33.30%" ; 0.333333, 4, Format.decimal ~precision:2, "33.33%", "33.33%" ; 0.000333, 2, Format.decimal ~precision:2, "3.3bp", "3.33bp" ] ;; let%expect_test _ = print_and_check_comparable_sexps [%here] (module Percent) [ Percent.zero; Percent.of_bp 15.; Percent.of_percentage 15.; Percent.of_mult 15. ]; [%expect {| (Set (0x 15bp 15% 15x)) (Map ( (0x 0) (15bp 1) (15% 2) (15x 3))) |}] ;; let%expect_test "accept float in set and map sexps" = let module Of_string (M : Sexpable.S1) = struct type t = string M.t [@@deriving sexp] end in let test (module M : Sexpable) string = print_s (M.sexp_of_t (M.t_of_sexp (Sexp.of_string string))) in test (module Percent.Set) {| (0 0.0001 0.01 1) |}; [%expect {| (0x 1bp 1% 1x) |}]; test (module Of_string (Percent.Map)) {| ((0 "arbitrary value") (0.0001 "arbitrary value") (0.01 "arbitrary value") (1 "arbitrary value")) |}; [%expect {| ((0x "arbitrary value") (1bp "arbitrary value") (1% "arbitrary value") (1x "arbitrary value")) |}] ;; let%expect_test "generator" = Quickcheck.test ~sexp_of:sexp_of_t ~shrinker:Percent.quickcheck_shrinker Percent.quickcheck_generator ~f:(fun t -> Validate.maybe_raise (Percent.validate t)); [%expect {| |}] ;; let%expect_test ("to_mult and of_mult no boxing in arrays" [@tags "fast-flambda"]) = let float_arr = Array.init 1 ~f:(fun i -> Float.of_int i) in let percent_arr = Array.create ~len:1 Percent.zero in require_no_allocation [%here] (fun () -> percent_arr.(0) <- Percent.of_mult float_arr.(0); float_arr.(0) <- Percent.to_mult percent_arr.(0)) ;; let%test "Percent.Option cannot represent nan" = let nan = Percent.of_mult Float.nan in Percent.Option.((not (some_is_representable nan)) && is_none (some nan)) ;; let%expect_test "always-percentage format" = let f x = let p = Percent.of_string x in print_string [%string "%{p#Percent} -> %{p#Percent.Always_percentage}\n"] in let cases = [ "0x"; "3.2bp"; "5x"; "75%" ] in List.iter ~f cases; [%expect {| 0x -> 0% 3.2bp -> 0.032% 5x -> 500% 75% -> 75% |}]; let f x = let p = Percent.of_string x in printf !"%{sexp: Percent.t} -> %s\n" p (Percent.Always_percentage.format p (Percent.Format.decimal ~precision:8)) in List.iter cases ~f; [%expect {| 0x -> 0.00000000% 3.2bp -> 0.03200000% 5x -> 500.00000000% 75% -> 75.00000000% |}] ;; core-0.15.0/core/test/src/test_percent.mli000066400000000000000000000000551420273305200204230ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_phys_same.ml000066400000000000000000000005751420273305200206110ustar00rootroot00000000000000open! Core open! Import let%test _ = phys_same 0 None let%test _ = phys_same 1 true let%test _ = let f () = "statically-allocated" in phys_same (f ()) (f ()) ;; let%test _ = let a = 1, 2 in phys_same a a ;; type thing = Obscure : _ -> thing let same_thing (Obscure a) (Obscure b) = phys_same a b let%test _ = let a = 1, 2 in same_thing (Obscure a) (Obscure a) ;; core-0.15.0/core/test/src/test_phys_same.mli000066400000000000000000000000551420273305200207530ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_popcount.ml000066400000000000000000000062341420273305200204660ustar00rootroot00000000000000open Core let test_int n bits = [%test_result: int] (Int.popcount n) ~expect:bits let test_int32 n bits = [%test_result: int] (Int32.popcount n) ~expect:bits let test_int64 n bits = [%test_result: int] (Int64.popcount n) ~expect:bits let test_nativeint n bits = [%test_result: int] (Nativeint.popcount n) ~expect:bits (* test simple constants and boundary conditions *) let%test_unit _ = test_int 0 0 let%test_unit _ = test_int 1 1 let%test_unit _ = test_int (-1) Int.num_bits let%test_unit _ = test_int Int.max_value (Int.num_bits - 1) let%test_unit _ = test_int Int.min_value 1 let%test_unit _ = test_int32 0l 0 let%test_unit _ = test_int32 1l 1 let%test_unit _ = test_int32 (-1l) 32 let%test_unit _ = test_int32 Int32.max_value 31 let%test_unit _ = test_int32 Int32.min_value 1 let%test_unit _ = test_int64 0L 0 let%test_unit _ = test_int64 1L 1 let%test_unit _ = test_int64 (-1L) 64 let%test_unit _ = test_int64 Int64.max_value 63 let%test_unit _ = test_int64 Int64.min_value 1 let%test_unit _ = test_nativeint 0n 0 let%test_unit _ = test_nativeint 1n 1 let%test_unit _ = test_nativeint (-1n) Nativeint.num_bits let%test_unit _ = test_nativeint Nativeint.max_value (Nativeint.num_bits - 1) let%test_unit _ = test_nativeint Nativeint.min_value 1 (* test that we can account for each bit individually *) let%test_unit _ = for i = 0 to Int.num_bits - 1 do let n = 1 lsl i in test_int n 1; test_int (lnot n) (Int.num_bits - 1) done ;; let%test_unit _ = for i = 0 to 31 do let n = Int32.shift_left 1l i in test_int32 n 1; test_int32 (Int32.bit_not n) 31 done ;; let%test_unit _ = for i = 0 to 63 do let n = Int64.shift_left 1L i in test_int64 n 1; test_int64 (Int64.bit_not n) 63 done ;; let%test_unit _ = for i = 0 to Nativeint.num_bits - 1 do let n = Nativeint.shift_left 1n i in test_nativeint n 1; test_nativeint (Nativeint.bit_not n) (Nativeint.num_bits - 1) done ;; (* Make sure unboxing works as expected and so forth, which it wouldn't if we used C stubs with boxed values for [int64], [int32], and [nativeint]. Use random inputs to make sure the compiler can't inline and precompute results. *) let does_not_allocate f = let test () = let len = 100 in let inputs = ArrayLabels.init len ~f:(fun _ -> Random.bits ()) in let minor_before = Gc.minor_words () in for i = 0 to len - 1 do ignore (f inputs.(i) : int) done; let minor_after = Gc.minor_words () in [%test_result: int] (minor_after - minor_before) ~expect:0 ~message:"number of words allocated" in (* On 32-bit systems, int64 cannot be unboxed, so this test only makes sense on 64-bit systems. Also, without cross-library inlining, the arguments to popcount cannot be unboxed. *) match Word_size.word_size with | W64 when Version_util.x_library_inlining -> test () | _ -> () ;; let%test_unit _ = does_not_allocate (fun x -> Int.popcount x) let%test_unit _ = does_not_allocate (fun x -> Int32.popcount (Caml.Int32.of_int x)) let%test_unit _ = does_not_allocate (fun x -> Int64.popcount (Caml.Int64.of_int x)) let%test_unit _ = does_not_allocate (fun x -> Nativeint.popcount (Caml.Nativeint.of_int x)) ;; core-0.15.0/core/test/src/test_popcount.mli000066400000000000000000000000551420273305200206320ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_printf.ml000066400000000000000000000014531420273305200201170ustar00rootroot00000000000000open Core let%expect_test "collect_to_string" = let output = Printf.collect_to_string (fun { printf } -> printf "hello "; printf "%s%c" "world" '!') in print_s [%sexp (output : string)]; [%expect {| "hello world!" |}] ;; let%expect_test "collect_to_string - try to use printf after [collect_to_string] returned" = let captured_printf = Set_once.create () in let output = Printf.collect_to_string (fun { printf } -> printf "inside"; Set_once.set_exn captured_printf [%here] printf) in [%expect {||}]; print_s [%sexp (output : string)]; [%expect {| inside |}]; Expect_test_helpers_base.require_does_raise [%here] (fun () -> (Set_once.get_exn captured_printf [%here]) "outside"); [%expect {| "[printf] used after [collect_to_string] returned" |}] ;; core-0.15.0/core/test/src/test_printf.mli000066400000000000000000000000551420273305200202650ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_queue.ml000066400000000000000000000023561420273305200177440ustar00rootroot00000000000000open! Core let%test_module _ = (module ( struct include Base.Queue (* Base.Queue is tested separately. Here we test the additions from Core. *) open Core.Queue type nonrec 'a t = 'a t [@@deriving bin_io] let binary_search = binary_search let binary_search_segmented = binary_search_segmented (* Tested where instantiated using [Test_binary_searchable.Make1_and_test] *) module Stable = struct module V1 = Stable.V1 include Stable_unit_test.Make (struct type nonrec t = int V1.t [@@deriving sexp, bin_io, compare] let equal = [%compare.equal: t] let tests = let manipulated = Queue.of_list [ 0; 3; 6; 1 ] in ignore (Queue.dequeue_exn manipulated : int); ignore (Queue.dequeue_exn manipulated : int); Queue.enqueue manipulated 4; [ Queue.of_list [], "()", "\000" ; Queue.of_list [ 1; 2; 6; 4 ], "(1 2 6 4)", "\004\001\002\006\004" ; manipulated, "(6 1 4)", "\003\006\001\004" ] ;; end) end end (* This signature is here to remind us to update the unit tests whenever we change [Queue]. *) : module type of Queue)) ;; core-0.15.0/core/test/src/test_queue.mli000066400000000000000000000000551420273305200201070ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_quickcheck_let_syntax.mlt000066400000000000000000000004011420273305200233550ustar00rootroot00000000000000#verbose true open! Core open! Quickcheck.Let_syntax let quickcheck_generator = let%map_open x = let%map a = of_list [ "a"; "b" ] in a ^ a in x ^ x ;; [%%expect {| val quickcheck_generator : string Base_quickcheck.Generator.t = |}] core-0.15.0/core/test/src/test_quickcheck_signature.ml000066400000000000000000000003711420273305200230060ustar00rootroot00000000000000open! Core module Foo (X : sig type t include Comparable.S with type t := t include Quickcheckable with type t := t end) = struct type t1 = Set.M(X).t [@@deriving quickcheck] type t2 = unit Map.M(X).t [@@deriving quickcheck] end core-0.15.0/core/test/src/test_quickcheck_signature.mli000066400000000000000000000005611420273305200231600ustar00rootroot00000000000000open! Core (*_ Check that the signature generated by deriving quickcheck is able to unify with the corresponding implementation. *) module Foo (X : sig type t include Comparable.S with type t := t include Quickcheckable with type t := t end) : sig type t1 = Set.M(X).t [@@deriving quickcheck] type t2 = unit Map.M(X).t [@@deriving quickcheck] end core-0.15.0/core/test/src/test_result.ml000066400000000000000000000002001420273305200201200ustar00rootroot00000000000000open! Core open! Import open! Result let%test_module "Result.V1" = (module Stable_unit_test.Make (Stable.V1_stable_unit_test)) core-0.15.0/core/test/src/test_result.mli000066400000000000000000000000551420273305200203010ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_sequence.ml000066400000000000000000000134751420273305200204340ustar00rootroot00000000000000open! Core open Expect_test_helpers_core module No_poly_compare = struct module Incomparable : sig type t [@@deriving compare] val create : unit -> t end = struct type t = unit -> unit let compare _ _ = 0 let next = ref 0 let create () = incr next; let x = !next in fun () -> failwithf "Should never be called %i" x () ;; end type 'a t = { incomparable : Incomparable.t ; value : 'a } [@@deriving compare] let sexp_of_t sexp_of_a t = sexp_of_a t.value let create value = { incomparable = Incomparable.create (); value } end let%expect_test "No_poly_compare" = let inc_x = No_poly_compare.Incomparable.create () in (* Unfortunately if we compare [x] with itself it will always work. *) show_raise (fun () -> Poly.compare inc_x inc_x); [%expect {| "did not raise" |}]; (* But otherwise we get an exception. *) show_raise (fun () -> Poly.compare inc_x (No_poly_compare.Incomparable.create ())); [%expect {| (raised (Invalid_argument "compare: functional value")) |}]; let no_x = No_poly_compare.create 0 in show_raise (fun () -> Poly.compare no_x no_x); [%expect {| "did not raise" |}]; show_raise (fun () -> Poly.compare no_x (No_poly_compare.create 0)); [%expect {| (raised (Invalid_argument "compare: functional value")) |}] ;; let%expect_test "merge_all" = let merge_all = Sequence.merge_all (module Fheap) in let compare = No_poly_compare.compare Int.compare in (* We take up to 20 elements so we can test infinite sequences. *) let list_of_sequence sequence = Sequence.to_list (Sequence.take sequence 20) in let sexp_of_sequence sequence = [%sexp (list_of_sequence sequence : int No_poly_compare.t list)] in (* Avoid unnecessary line wrapping of small sexps. *) let print_s sexp = let string = Sexp.to_string sexp in if String.length string < 80 then print_endline string else print_s sexp in let examples = let finite_examples = [ [] ; [ [] ] ; [ [ 1 ] ] ; [ [ 1; 2 ] ] ; [ [ 1 ]; [ 2 ] ] ; [ [ 2 ]; [ 1 ] ] ; [ [ 1; 2; 3 ] ] ; [ [ 1 ]; [ 2 ]; [ 3 ] ] ; [ [ 3 ]; [ 2 ]; [ 1 ] ] ; [ [ 1; 2 ]; [ 3; 4 ] ] ; [ [ 2; 4 ]; [ 1; 3 ] ] ; [ [ 1; 4 ]; [ 3 ]; []; [ 2 ] ] ] |> List.map ~f:(List.map ~f:Sequence.of_list) in let infinite_examples = let naturals = Sequence.unfold ~init:0 ~f:(fun i -> Some (i, i + 1)) in [ [ Sequence.cycle_list_exn [ 1 ]; Sequence.cycle_list_exn [ 2 ] ] ; [ naturals ] ; [ Sequence.filter naturals ~f:(fun i -> i % 2 = 0) ; Sequence.filter naturals ~f:(fun i -> i % 2 = 1) ] ] in finite_examples @ infinite_examples |> List.map ~f:(List.map ~f:(Sequence.map ~f:No_poly_compare.create)) in List.iter examples ~f:(fun example -> print_s [%sexp (example : sequence list)]); [%expect {| () (()) ((1)) ((1 2)) ((1)(2)) ((2)(1)) ((1 2 3)) ((1)(2)(3)) ((3)(2)(1)) ((1 2)(3 4)) ((2 4)(1 3)) ((1 4)(3)()(2)) ((1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) (2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2)) ((0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)) ((0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 32 34 36 38) (1 3 5 7 9 11 13 15 17 19 21 23 25 27 29 31 33 35 37 39)) |}]; List.iter examples ~f:(fun example -> print_s [%sexp (merge_all example ~compare : sequence)]); [%expect {| () () (1) (1 2) (1 2) (1 2) (1 2 3) (1 2 3) (1 2 3) (1 2 3 4) (1 2 3 4) (1 2 3 4) (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) |}]; (* During a Quickcheck test we want to bail out after a single failure. *) let require_exn here ?if_false_then_print_s bool = require here bool ?if_false_then_print_s; if not bool then raise_s [%message "failed on random input"] in let quickcheck_generator = let str_gen = Quickcheck.Generator.map Int.quickcheck_generator ~f:No_poly_compare.create in let seq_gen = Quickcheck.Generator.map (List.quickcheck_generator str_gen) ~f:(fun list -> Sequence.of_list (List.sort list ~compare)) in List.quickcheck_generator seq_gen in let run test = Quickcheck.test ~sexp_of:[%sexp_of: sequence list] ~examples quickcheck_generator ~f:test in (* Test that output is sorted. *) run (fun seqs -> let seq = merge_all seqs ~compare in let list = list_of_sequence seq in require_exn [%here] (List.is_sorted list ~compare) ~if_false_then_print_s:(lazy [%sexp (list : int No_poly_compare.t list)])); [%expect {||}]; (* Test that output is consistent with concat+sort. *) run (fun seqs -> let merge_all = list_of_sequence (merge_all seqs ~compare) in let concat_and_sort = let sorted = List.map seqs ~f:list_of_sequence |> List.concat |> List.sort ~compare in List.take sorted 20 in require_exn [%here] ([%compare.equal: int No_poly_compare.t list] merge_all concat_and_sort) ~if_false_then_print_s: (lazy [%message "inconsistent results" (merge_all : int No_poly_compare.t list) (concat_and_sort : int No_poly_compare.t list)])); [%expect {||}]; (* Test that sequence is replayable. *) run (fun seqs -> let seq = merge_all seqs ~compare in let list1 = list_of_sequence seq in let list2 = list_of_sequence seq in require_exn [%here] ([%compare.equal: int No_poly_compare.t list] list1 list2) ~if_false_then_print_s: (lazy [%message "sequence is impure" (list1 : int No_poly_compare.t list) (list2 : int No_poly_compare.t list)])); [%expect {||}] ;; core-0.15.0/core/test/src/test_sequence.mli000066400000000000000000000000551420273305200205730ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_set_once.ml000066400000000000000000000104631420273305200204150ustar00rootroot00000000000000open! Core open! Import open! Set_once module type Format = sig type 'a t = 'a Set_once.t [@@deriving bin_io, sexp] end let test_serialization (module Format : Format) = let module T = struct type t = int Format.t [@@deriving bin_io, sexp] let compare t1 t2 = Option.compare [%compare: int] (get t1) (get t2) end in let t1 = create () in let t2 = create () in set_exn t2 [%here] 13; print_and_check_stable_type [%here] (module T) [ t1; t2 ] ;; let%expect_test "[Stable.V1] serialization" = test_serialization (module Stable.V1); [%expect {| (bin_shape_digest 8b7c356301db5206ab98e334f4886c11) ((sexp ()) (bin_io "\000")) ((sexp (13)) (bin_io "\001\r")) |}] ;; let%expect_test "[Unstable] serialization" = test_serialization (module Unstable); [%expect {| (bin_shape_digest 8b7c356301db5206ab98e334f4886c11) ((sexp ()) (bin_io "\000")) ((sexp (13)) (bin_io "\001\r")) |}] ;; type t = int Set_once.t [@@deriving sexp_of] let hide_positions = true let show t = print_s ~hide_positions [%message "" ~_:(t : t)]; invariant ignore t ;; let%expect_test "[sexp_of_t]" = let t = create () in show t; [%expect {| unset |}]; set_exn t [%here] 13; show t; [%expect {| ((value 13) (set_at lib/core/test/src/test_set_once.ml:LINE:COL)) |}] ;; let%expect_test "[get]" = let t = create () in let show_get () = print_s [%message "" ~_:(get t : int option)] in show_get (); [%expect {| () |}]; set_exn t [%here] 13; show_get (); [%expect {| (13) |}] ;; let%expect_test "[get] doesn't allocate" = let t = create () in let check_get here = ignore (require_no_allocation here (fun () -> get t) : int option) in check_get [%here]; [%expect {| |}]; set_exn t [%here] 13; check_get [%here]; [%expect {| |}] ;; let%expect_test "[get_exn]" = let t = create () in show_raise ~hide_positions (fun () -> get_exn t [%here]); [%expect {| (raised ( "[Set_once.get_exn] unset" (at lib/core/test/src/test_set_once.ml:LINE:COL))) |}]; set_exn t [%here] 13; print_s [%message "" ~_:(get_exn t [%here] : int)]; [%expect {| 13 |}] ;; let%expect_test "[set]" = let t = create () in print_s [%message "" ~_:(set t [%here] 13 : unit Or_error.t)]; [%expect {| (Ok ()) |}] ;; let%expect_test "[set_if_none]" = let t = create () in let set_if_none_and_print ~value = set_if_none t [%here] value; print_s ~hide_positions [%sexp (Set_once.get_exn t [%here] : string)] in set_if_none_and_print ~value:"first call to set_if_none"; [%expect {| "first call to set_if_none" |}]; set_if_none_and_print ~value:"second call to set_if_none"; [%expect {| "first call to set_if_none" |}] ;; let%expect_test "[set] error" = let t = create () in set_exn t [%here] 13; print_s ~hide_positions [%message "" ~_:(set t [%here] 14 : unit Or_error.t)]; [%expect {| (Error ( "[Set_once.set_exn] already set" (setting_at lib/core/test/src/test_set_once.ml:LINE:COL) (previously_set_at lib/core/test/src/test_set_once.ml:LINE:COL))) |}] ;; let%expect_test "[set_exn] error" = let t = create () in set_exn t [%here] 13; show_raise ~hide_positions (fun () -> set_exn t [%here] 14); [%expect {| (raised ( "[Set_once.set_exn] already set" (setting_at lib/core/test/src/test_set_once.ml:LINE:COL) (previously_set_at lib/core/test/src/test_set_once.ml:LINE:COL))) |}] ;; let%expect_test "[is_none], [is_some]" = let t = create () in let show () = print_s [%message "" ~is_none:(is_none t : bool) ~is_some:(is_some t : bool)] in show (); [%expect {| ((is_none true) (is_some false)) |}]; set_exn t [%here] 13; show (); [%expect {| ((is_none false) (is_some true)) |}] ;; let%expect_test "[match%optional]" = let t = create () in let show () = print_s (let open Optional_syntax in match%optional t with | None -> [%message "none"] | Some i -> [%message "some" ~_:(i : int)]) in show (); [%expect {| none |}]; set_exn t [%here] 13; show (); [%expect {| (some 13) |}] ;; let%expect_test "[iter]" = let t = create () in let iter () = iter t ~f:(fun i -> print_s [%message (i : int)]) in iter (); [%expect {| |}]; set_exn t [%here] 13; iter (); [%expect {| (i 13) |}] ;; core-0.15.0/core/test/src/test_set_once.mli000066400000000000000000000000551420273305200205620ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_sexp.ml000066400000000000000000000062451420273305200176000ustar00rootroot00000000000000open! Core open! Import open! Sexp module _ = struct open! With_text let sexp_of_il = sexp_of_list sexp_of_int let il_of_sexp = list_of_sexp int_of_sexp let il_of_text text = Or_error.ok_exn (of_text il_of_sexp text) let il_of_value il = of_value sexp_of_il il module IL = struct type t = int list [@@deriving compare, sexp_of] let equal = [%compare.equal: t] end let t = il_of_value [ 3; 4 ] let%expect_test _ = print_s [%sexp (text t : string)]; [%expect {| "(3 4)" |}] ;; let t' = il_of_text (text t) let%expect_test _ = require_equal [%here] (module IL) (value t') [ 3; 4 ]; [%expect {| |}] ;; let%expect_test _ = print_s [%sexp (t : il t)]; [%expect {| "(3 4)" |}] ;; let%expect_test _ = require_equal [%here] (module IL) (value (t_of_sexp il_of_sexp (Atom "(3 4)"))) [ 3; 4 ]; [%expect {| |}] ;; let%expect_test _ = require_equal [%here] (module IL) [ 8; 9 ] (value (il_of_text ";this is a comment\n (8; foo\n 9) \n ")); [%expect {| |}] ;; let%expect_test _ = require_does_raise [%here] (fun () -> il_of_text "(1 2 bla)"); [%expect {| (Of_sexp_error :1:5 "int_of_sexp: (Failure int_of_string)" (invalid_sexp bla)) |}] ;; let%expect_test _ = require_does_raise [%here] (fun () -> t_of_sexp il_of_sexp (Sexp.of_string "\"(1 2 bla)\"")); [%expect {| (Of_sexp_error :1:5 "int_of_sexp: (Failure int_of_string)" (invalid_sexp bla)) |}] ;; end let%test_module _ = (module struct type t1 = Sexp.t [@@deriving bin_io] type t2 = Sexp.Stable.V1.t [@@deriving bin_io] type t3 = Core_stable.Sexp.V1.t [@@deriving bin_io] let%expect_test "Sexp.t, Sexp.Stable.V1.t and Core_stable.Sexp.V1.t bin_digests match" = print_endline [%bin_digest: t1]; print_endline [%bin_digest: t2]; print_endline [%bin_digest: t3]; [%expect {| 832b40ae394f2851da8ba67b3339b429 832b40ae394f2851da8ba67b3339b429 832b40ae394f2851da8ba67b3339b429 |}] ;; end) ;; let%test_module "of_sexp_allow_extra_fields_recursively" = (module struct module V = struct type v1 = { a : string ; b : int ; suffix : string } [@@deriving sexp] type v2 = { a : string ; b : int } [@@deriving sexp] type t = v2 [@@deriving sexp_of] let t_of_sexp sexp : t = try v2_of_sexp sexp with | e -> (match v1_of_sexp sexp with | { a; b; suffix } -> { a = a ^ suffix; b } | exception _ -> raise e) ;; end type t = { v : V.t } [@@deriving sexp] let%expect_test "affect sexp converter globally" = let sexp = Sexp.of_string {|((v ((a a)(b 0)(suffix "-suffix"))))|} in let t = t_of_sexp sexp in print_s (sexp_of_t t); [%expect {| (( v ( (a a-suffix) (b 0)))) |}]; let t = Sexp.of_sexp_allow_extra_fields_recursively t_of_sexp sexp in print_s (sexp_of_t t); [%expect {| (( v ( (a a) (b 0)))) |}] ;; end) ;; core-0.15.0/core/test/src/test_sexp.mli000066400000000000000000000000551420273305200177420ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_sign.ml000066400000000000000000000004461420273305200175560ustar00rootroot00000000000000open! Core open! Import open! Sign let ( < ) = Poly.( < ) let ( = ) = Poly.( = ) let%test _ = compare Neg Zero < 0 && compare Zero Pos < 0 let%test _ = List.for_all all ~f:(fun t -> t = (t |> to_int |> of_int)) let%test _ = List.for_all [ -1; 0; 1 ] ~f:(fun i -> i = (i |> of_int |> to_int)) core-0.15.0/core/test/src/test_sign.mli000066400000000000000000000000551420273305200177230ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_signal.ml000066400000000000000000000005411420273305200200670ustar00rootroot00000000000000open! Core open! Import open! Signal let%test_unit _ = [%test_eq: string] (to_string bus) "sigbus"; [%test_eq: string] (Sexp.to_string (sexp_of_t bus)) {|""|}; [%test_eq: string] (Sexp.to_string (Stable.V1.sexp_of_t bus)) {|""|}; [%test_eq: string] (Sexp.to_string (Stable.V2.sexp_of_t bus)) "sigbus" ;; core-0.15.0/core/test/src/test_signal.mli000066400000000000000000000000551420273305200202400ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_stable.ml000066400000000000000000000112601420273305200200640ustar00rootroot00000000000000open! Core open! Expect_test_helpers_core let%expect_test "[sexp_of_int] respects [sexp_of_int_style]" = let sexp_of_int = Core.Core_stable.sexp_of_int in let r = Int_conversions.sexp_of_int_style in let old = !r in r := `Underscores; print_s [%sexp (1234 : int)]; [%expect {| 1_234 |}]; r := `No_underscores; print_s [%sexp (1234 : int)]; [%expect {| 1234 |}]; r := old ;; let%expect_test "older [int_of_sexp] supports both [sexp_of_int_style]s" = let sexp_of_int = Core.Core_stable.sexp_of_int in let int_of_sexp = Sexplib.Std.int_of_sexp in let print () = print_s [%sexp (int_of_sexp (sexp_of_int 1234) : int)] in let r = Int_conversions.sexp_of_int_style in let old = !r in r := `Underscores; print (); [%expect {| 1_234 |}]; r := `No_underscores; print (); [%expect {| 1234 |}]; r := old ;; module _ = struct let%test_module "Hashtbl.V1" = (module Stable_unit_test.Make_unordered_container (struct module Hashable = Core_stable.Hashable.V1.Make (Int) module Table = Hashable.Table type t = string Table.t [@@deriving sexp, bin_io] let equal t1 t2 = Int.Table.equal String.equal t1 t2 let triple_table = Int.Table.of_alist_exn ~size:16 [ 1, "foo"; 2, "bar"; 3, "baz" ] let single_table = Int.Table.of_alist_exn [ 0, "foo" ] module Test = Stable_unit_test.Unordered_container_test let tests = [ ( triple_table , { Test.sexps = [ "(1 foo)"; "(2 bar)"; "(3 baz)" ] ; bin_io_header = "\003" ; bin_io_elements = [ "\001\003foo"; "\002\003bar"; "\003\003baz" ] } ) ; ( Int.Table.create () , { Test.sexps = []; bin_io_header = "\000"; bin_io_elements = [] } ) ; ( single_table , { Test.sexps = [ "(0 foo)" ] ; bin_io_header = "\001" ; bin_io_elements = [ "\000\003foo" ] } ) ] ;; end)) ;; end let%test_module "Hash_set.V1" = (module Stable_unit_test.Make_unordered_container (struct module Hashable = Core_stable.Hashable.V1.Make (Int) include Hashable.Hash_set let equal = Hash_set.equal let int_list = List.init 10 ~f:Fn.id let ten_set = Int.Hash_set.of_list ~size:32 int_list let single_set = Int.Hash_set.of_list [ 0 ] module Test = Stable_unit_test.Unordered_container_test let tests = [ ( ten_set , { Test.sexps = List.init 10 ~f:Int.to_string ; bin_io_header = "\010" ; bin_io_elements = List.init 10 ~f:(fun n -> Char.to_string (Char.of_int_exn n)) } ) ; ( Int.Hash_set.create () , { Test.sexps = []; bin_io_header = "\000"; bin_io_elements = [] } ) ; ( single_set , { Test.sexps = [ "0" ]; bin_io_header = "\001"; bin_io_elements = [ "\000" ] } ) ] ;; end)) ;; module _ = struct module type F = functor (Key : Stable) -> sig type 'a t = (Key.t, 'a, Key.comparator_witness) Map.t [@@deriving bin_io, compare, sexp] end module Test (F : F) = Stable_unit_test.Make (struct include F (Int) type nonrec t = string t [@@deriving sexp, bin_io] let equal = Int.Map.equal String.equal let tests = [ ( Int.Map.of_alist_exn [ 1, "foo"; 2, "bar"; 3, "baz" ] , "((1 foo) (2 bar) (3 baz))" , "\003\001\003foo\002\003bar\003\003baz" ) ; Int.Map.empty, "()", "\000" ; Int.Map.singleton 0 "foo", "((0 foo))", "\001\000\003foo" ] ;; end) let%test_module "Map.V1" = (module Test (Map.Stable.V1.Make)) let%test_module "Map.V1.M" = (module struct module F (Key : Stable) = struct type 'a t = 'a Map.Stable.V1.M(Key).t [@@deriving bin_io, compare, sexp] end include Test (F) end) ;; end module _ = struct module type F = functor (Elt : Stable) -> sig type t = (Elt.t, Elt.comparator_witness) Set.t [@@deriving sexp, bin_io, compare] end module Test (F : F) = Stable_unit_test.Make (struct include F (Int) let equal = Set.equal let tests = [ ( Int.Set.of_list (List.init 10 ~f:Fn.id) , "(0 1 2 3 4 5 6 7 8 9)" , "\010\000\001\002\003\004\005\006\007\008\009" ) ; Int.Set.empty, "()", "\000" ; Int.Set.singleton 0, "(0)", "\001\000" ] ;; end) let%test_module "Set.V1" = (module Test (Set.Stable.V1.Make)) let%test_module "Set.V1.M" = (module struct module F (Elt : Stable) = struct type t = Set.Stable.V1.M(Elt).t [@@deriving bin_io, compare, sexp] end include Test (F) end) ;; end core-0.15.0/core/test/src/test_stable.mli000066400000000000000000000000551420273305200202350ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_string.ml000066400000000000000000000047061420273305200201270ustar00rootroot00000000000000open! Core open! Import open! String (*TEST = slice "hey" 0 0 = ""*) (* This is what I would expect *) let%test _ = slice "hey" 0 0 = "hey" (* But this is what we get! *) let%test _ = slice "hey" 0 1 = "h" let%test _ = slice "hey" 0 2 = "he" let%test _ = slice "hey" 0 3 = "hey" let%test _ = slice "hey" 1 1 = "" let%test _ = slice "hey" 1 2 = "e" let%test _ = slice "hey" 1 3 = "ey" let%test _ = slice "hey" 2 2 = "" let%test _ = slice "hey" 2 3 = "y" let%test _ = slice "hey" 3 3 = "" let%test_module "Caseless Comparable" = (module struct let%test _ = Int.equal (Base.Map.find_exn (Caseless.Map.of_alist_exn [ "a", 4; "b", 5 ]) "A") 4 ;; let%test _ = Base.Set.mem (Caseless.Set.of_list [ "hello"; "world" ]) "heLLO" let%test _ = Int.equal (Base.Set.length (Caseless.Set.of_list [ "a"; "A" ])) 1 end) ;; let%test_module "Caseless Hash" = (module struct let%test _ = Int.equal (Caseless.hash "Hello") (Caseless.hash "HELLO") end) ;; let%test_module "take_while" = (module struct let f = Char.is_digit let%test_unit _ = [%test_result: t] (take_while "123abc456" ~f) ~expect:"123" let%test_unit _ = [%test_result: t] (rtake_while "123abc456" ~f) ~expect:"456" let%test_unit _ = [%test_result: t] (take_while "123456" ~f) ~expect:"123456" let%test_unit _ = [%test_result: t] (rtake_while "123456" ~f) ~expect:"123456" end) ;; let%test_module "Verify reading/writing stable table sexp" = (module struct let expected_sexp = Sexp.of_string "((alpha beta) (delta gamma))" let table = let s = String.Table.create () in Hashtbl.add_exn s ~key:"delta" ~data:"gamma"; Hashtbl.add_exn s ~key:"alpha" ~data:"beta"; s ;; let%expect_test "sexp_of_t" = print_s [%sexp (table : string String.Stable.V1.Table.t)]; [%expect {| ((alpha beta) (delta gamma)) |}] ;; let%test_unit "t_of_sexp" = let loaded_table = [%of_sexp: string String.Stable.V1.Table.t] expected_sexp in assert (Hashtbl.equal String.equal loaded_table table) ;; end) ;; let%expect_test "Hashtbl.merge of String.Table and String.Stable.V1.Table" = Expect_test_helpers_core.require_does_not_raise [%here] (fun () -> let result = Hashtbl.merge (String.Table.t_of_sexp int_of_sexp [%sexp []]) (String.Stable.V1.Table.t_of_sexp int_of_sexp [%sexp []]) ~f:(fun ~key:_ x -> Some x) in require [%here] (Hashtbl.is_empty result)); [%expect {| |}] ;; core-0.15.0/core/test/src/test_string.mli000066400000000000000000000000551420273305200202710ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_string_id.ml000066400000000000000000000174711420273305200206060ustar00rootroot00000000000000open! Core open! Import open! String_id open! Int.Replace_polymorphic_compare module Unit_tests_util = struct let to_bin_str t ~bin_writer_t ~bin_size_t = let write = bin_writer_t.Bin_prot.Type_class.write in let size = bin_size_t t in let buf = Bigstring.create size in let len = write buf ~pos:0 t in assert (len = size); Bigstring.to_string buf ;; let string_to_bin_str t = let bin_writer_t = String.bin_writer_t in let bin_size_t = String.bin_size_t in to_bin_str t ~bin_writer_t ~bin_size_t ;; end (* Test [Make_with_validate_without_pretty_printer]. *) (* Even integers are the only valid identifiers *) module Even_int_id = Make_with_validate_without_pretty_printer (struct let module_name = "Even_int_id" let validate s = if Int.of_string s % 2 <> 0 then Or_error.error_s [%message "Not a valid Even_int_id" ~_:(s : string)] else Ok () ;; let include_default_validation = true end) () let even_int_id_to_bin_str t = let bin_writer_t = Even_int_id.bin_writer_t in let bin_size_t = Even_int_id.bin_size_t in Unit_tests_util.to_bin_str t ~bin_writer_t ~bin_size_t ;; let even_int_id_of_bin_str str = Even_int_id.bin_reader_t.Bin_prot.Type_class.read (Bigstring.of_string str) ~pos_ref:(ref 0) ;; let%test_unit "string roundtrip" = [%test_result: string] (Even_int_id.of_string "14" |> Even_int_id.to_string) ~expect:"14" ;; let%test_unit "sexp roundtrip" = [%test_result: string] (Even_int_id.t_of_sexp (Sexp.of_string "14") |> Even_int_id.sexp_of_t |> Sexp.to_string) ~expect:"14" ;; let%test_unit "bin_prot roundrip" = [%test_result: string] (Even_int_id.of_string "14" |> even_int_id_to_bin_str |> even_int_id_of_bin_str |> Even_int_id.to_string) ~expect:"14" ;; let print_error or_error = match or_error with | Ok _ -> printf "" | Error error -> Error.to_string_hum error |> printf "%s" ;; let%expect_test "of string failure" = Or_error.try_with (fun () -> Even_int_id.of_string "15") |> print_error; [%expect {| (Invalid_argument "(\"Not a valid Even_int_id\"15)") |}] ;; let%expect_test "of sexp failure" = Or_error.try_with (fun () -> Even_int_id.t_of_sexp (Sexp.of_string "15")) |> print_error; [%expect {| (Of_sexp_error "(\"Not a valid Even_int_id\"15)" (invalid_sexp 15)) |}] ;; let%expect_test "set of sexp failure" = Or_error.try_with (fun () -> Even_int_id.Set.t_of_sexp (Sexp.of_string "(15)")) |> print_error; [%expect {| (Of_sexp_error "(\"Not a valid Even_int_id\"15)" (invalid_sexp 15)) |}] ;; let%expect_test "of bin prot failure" = Or_error.try_with (fun () -> even_int_id_of_bin_str (Unit_tests_util.string_to_bin_str "15")) |> print_error; [%expect {| (Invalid_argument "(\"Not a valid Even_int_id\"15)") |}] ;; module M = Make_without_pretty_printer (struct let module_name = "test" end) () let%test_unit "string roundtrip" = [%test_result: string] (M.of_string "FOOBAR" |> M.to_string) ~expect:"FOOBAR" ;; let%test_unit "sexp roundtrip" = [%test_result: string] (M.t_of_sexp (Sexp.of_string "FOOBAR") |> M.sexp_of_t |> Sexp.to_string) ~expect:"FOOBAR" ;; let string_id_to_bin_str t = let bin_writer_t = M.bin_writer_t in let bin_size_t = M.bin_size_t in Unit_tests_util.to_bin_str t ~bin_writer_t ~bin_size_t ;; let string_id_of_bin_str str = M.bin_reader_t.Bin_prot.Type_class.read (Bigstring.of_string str) ~pos_ref:(ref 0) ;; let%test_unit "bin_prot roundrip" = [%test_result: string] (M.of_string "FOOBAR" |> string_id_to_bin_str |> string_id_of_bin_str |> M.to_string) ~expect:"FOOBAR" ;; let%test_unit "whitespace inside is OK" = [%test_result: string] (M.of_string "FOO BAR" |> M.to_string) ~expect:"FOO BAR" ;; let print_error or_error = match or_error with | Ok _ -> printf "" | Error error -> Error.to_string_hum error |> printf "%s" ;; let%expect_test "of string failure - empty string" = Or_error.try_with (fun () -> M.of_string "") |> print_error; [%expect {| (Invalid_argument "'' is not a valid test because it is empty") |}] ;; let%expect_test "of string failure - whitespace after" = Or_error.try_with (fun () -> M.of_string "FOOBAR ") |> print_error; [%expect {| (Invalid_argument "'FOOBAR ' is not a valid test because it has whitespace on the edge") |}] ;; let%expect_test "of string failure - whitespace before" = Or_error.try_with (fun () -> M.of_string " FOOBAR") |> print_error; [%expect {| (Invalid_argument "' FOOBAR' is not a valid test because it has whitespace on the edge") |}] ;; let%expect_test "of sexp failure" = Or_error.try_with (fun () -> M.t_of_sexp (Sexp.of_string "\"FOOBAR \"")) |> print_error; [%expect {| (Of_sexp_error "'FOOBAR ' is not a valid test because it has whitespace on the edge" (invalid_sexp "FOOBAR ")) |}] ;; let%expect_test "set of sexp failure" = Or_error.try_with (fun () -> M.Set.t_of_sexp (Sexp.of_string "(\"FOOBAR \")")) |> print_error; [%expect {| (Of_sexp_error "'FOOBAR ' is not a valid test because it has whitespace on the edge" (invalid_sexp "FOOBAR ")) |}] ;; let%expect_test "of bin prot failure" = Or_error.try_with (fun () -> string_id_of_bin_str (Unit_tests_util.string_to_bin_str "FOOBAR ")) |> print_error; [%expect {| (Invalid_argument "'FOOBAR ' is not a valid test because it has whitespace on the edge") |}] ;; let%test_unit "String_id's of_string shouldn't allocate on success" = let initial_words = Gc.minor_words () in ignore (M.of_string "FOOBAR" : M.t); let allocated = Gc.minor_words () - initial_words in [%test_result: int] allocated ~expect:0 ;; let%test_module "Verify reading/writing stable table sexp" = (module struct let expected_sexp = Sexp.of_string "((alpha beta) (delta gamma))" let table = let s = String_id.Table.create () in Hashtbl.add_exn s ~key:(of_string "delta") ~data:(of_string "gamma"); Hashtbl.add_exn s ~key:(of_string "alpha") ~data:(of_string "beta"); s ;; let%expect_test "sexp_of_t" = print_s [%sexp (table : t String_id.Stable.V1.Table.t)]; [%expect {| ((alpha beta) (delta gamma)) |}] ;; let%test_unit "t_of_sexp" = let loaded_table = [%of_sexp: t String_id.Stable.V1.Table.t] expected_sexp in assert (Hashtbl.equal String_id.equal loaded_table table) ;; end) ;; let%expect_test "include_default_validation" = let test ~include_default_validation = let module M = Make_with_validate (struct let module_name = "M" let validate s = if String.( = ) s "foo" then error_s [%message "no foo"] else Ok () ;; let include_default_validation = include_default_validation end) () in List.iter [ "foobar"; "foo"; " bar "; " bar"; "bar "; "" ] ~f:(fun s -> print_s [%message s ~_:(Or_error.try_with (fun () -> M.of_string s) : M.t Or_error.t)]) in test ~include_default_validation:false; [%expect {| (foobar (Ok foobar)) (foo (Error (Invalid_argument "\"no foo\""))) (" bar " (Ok " bar ")) (" bar" (Ok " bar")) ("bar " (Ok "bar ")) ("" (Ok "")) |}]; test ~include_default_validation:true; [%expect {| (foobar (Ok foobar)) (foo (Error (Invalid_argument "\"no foo\""))) (" bar " ( Error ( Invalid_argument "' bar ' is not a valid M because it has whitespace on the edge"))) (" bar" ( Error ( Invalid_argument "' bar' is not a valid M because it has whitespace on the edge"))) ("bar " ( Error ( Invalid_argument "'bar ' is not a valid M because it has whitespace on the edge"))) ("" (Error (Invalid_argument "'' is not a valid M because it is empty"))) |}] ;; core-0.15.0/core/test/src/test_string_id.mli000066400000000000000000000000551420273305200207450ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_substring.ml000066400000000000000000000150711420273305200206360ustar00rootroot00000000000000open! Core open Poly open! Import module Test (Base : sig type t val of_string : string -> t end) (Substring : Substring.S with type base = Base.t) : sig end = struct open Substring let%test_module "get" = (module struct let hello = Base.of_string "hello" let%test _ = let lo = create ~pos:3 ~len:2 hello in Char.equal (get lo 1) 'o' ;; let%test _ = Exn.does_raise (fun () -> get (create ~pos:1 ~len:3 hello) 3) let%test _ = Exn.does_raise (fun () -> get (create hello) (-1)) end) ;; let%test_module "sub" = (module struct let base = Base.of_string "012345" let t = create ~pos:1 ~len:4 base (* 1234 *) let%test_unit _ = ignore (sub ~pos:0 ~len:4 t : t) let%test _ = Exn.does_raise (fun () -> sub ~pos:0 ~len:5 t) let%test _ = Exn.does_raise (fun () -> sub ~pos:1 ~len:4 t) let%test _ = let t2 = sub t ~pos:1 ~len:3 in String.init (length t2) ~f:(get t2) = "234" ;; let%test _ = let t2 = sub t ~pos:3 in String.init (length t2) ~f:(get t2) = "4" ;; let%test_unit "empty substring" = ignore (sub ~pos:2 ~len:0 t : t) let%test "invalid empty substring" = Exn.does_raise (fun () -> sub ~pos:5 ~len:0 t) end) ;; let%test_module _ = (module struct let ell = create ~pos:1 ~len:3 (Base.of_string "hello") let%test _ = to_array ell = [| 'e'; 'l'; 'l' |] let%test _ = to_list ell = [ 'e'; 'l'; 'l' ] let%test _ = fold ell ~init:[] ~f:(fun acc x -> x :: acc) = [ 'l'; 'l'; 'e' ] let%test _ = foldi ell ~init:[] ~f:(fun i acc x -> (i, x) :: acc) = [ 2, 'l'; 1, 'l'; 0, 'e' ] ;; let%test _ = let stuff = ref [] in iter ell ~f:(fun c -> stuff := c :: !stuff); !stuff = [ 'l'; 'l'; 'e' ] ;; let%test _ = let stuff = ref [] in iteri ell ~f:(fun i c -> stuff := (i, c) :: !stuff); !stuff = [ 2, 'l'; 1, 'l'; 0, 'e' ] ;; end) ;; let%test_module _ = (module struct let bcdefghi = create ~pos:1 ~len:8 (Base.of_string "abcdefghijklmno ") let%test _ = find bcdefghi ~f:Char.is_lowercase = Some 'b' let%test _ = find bcdefghi ~f:Char.is_whitespace = None let%test _ = exists bcdefghi ~f:(Char.equal 'h') let%test _ = not (exists bcdefghi ~f:(Char.equal 'z')) let%test _ = for_all bcdefghi ~f:Char.is_alpha let%test _ = not (for_all bcdefghi ~f:(Char.equal 'h')) let%test _ = not (mem bcdefghi 'a') let%test _ = mem bcdefghi 'b' let%test _ = mem bcdefghi 'i' let%test _ = not (mem bcdefghi 'j') let%test _ = count bcdefghi ~f:(String.mem "aeiou") = 2 let%test _ = sum (module Int) bcdefghi ~f:(fun c -> Char.to_int c - Char.to_int 'a') = 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 ;; let%test _ = min_elt bcdefghi ~compare:Char.compare = Some 'b' let%test _ = max_elt bcdefghi ~compare:Char.compare = Some 'i' let%test _ = existsi bcdefghi ~f:(fun i c -> i = 6 && Char.equal c 'h') let%test _ = not (existsi bcdefghi ~f:(fun i c -> i = 8 || Char.equal c 'z')) let%test _ = for_alli bcdefghi ~f:(fun i c -> i <= 7 && Char.is_alpha c) let%test _ = not (for_alli bcdefghi ~f:(fun i c -> i <= 7 && Char.equal c 'h')) let%test _ = counti bcdefghi ~f:(fun i c -> (not (String.mem "bcde" c)) && i % 2 = 0) = 2 ;; let%test _ = findi bcdefghi ~f:(fun (_ : int) c -> Char.equal c 'f') = Some (4, 'f') let%test _ = findi bcdefghi ~f:(fun (_ : int) c -> Char.equal c 'z') = None let%test _ = find_mapi bcdefghi ~f:(fun (_ : int) c -> Option.some_if (Char.equal c 'e') 42) = Some 42 ;; let%test _ = find_mapi bcdefghi ~f:(fun (_ : int) c -> Option.some_if (Char.equal c 'z') 42) = None ;; end) ;; end include Test (Bytes) (Substring) let sexp_of_substring_for_test t = [%sexp { base = (Substring.base t : bytes) ; pos = (Substring.pos t : int) ; len = (Substring.length t : int) }] ;; let%test_module "quickcheck" = (module struct let%expect_test "can generate" = Quickcheck.test_can_generate ~sexp_of:sexp_of_substring_for_test Substring.quickcheck_generator ~f:(fun sub -> let base_len = Bytes.length (Substring.base sub) in (* whole substring of nontrivial string *) base_len > 0 && Substring.length sub = base_len); Quickcheck.test_can_generate ~sexp_of:sexp_of_substring_for_test Substring.quickcheck_generator ~f:(fun sub -> let pos = Substring.pos sub in let len = Substring.length sub in (* non-triviality: contains at least one character and excludes at least one character from each end *) pos > 0 && len > 0 && pos + len < Bytes.length (Substring.base sub)); [%expect ""] ;; let%expect_test "to_string" = Quickcheck.test ~sexp_of:sexp_of_substring_for_test Substring.quickcheck_generator ~f:(fun sub -> [%test_result: bytes] ~expect: (Bytes.sub (Substring.base sub) ~pos:(Substring.pos sub) ~len:(Substring.length sub)) (Bytes.of_string (Substring.to_string sub))) ;; let%expect_test "prefixes and suffixes" = let sub_and_n = let open Quickcheck.Let_syntax in let%bind sub = [%quickcheck.generator: Substring.t] in let%map n = (* include too-small and too-large indices *) Int.gen_uniform_incl (-1) (Substring.length sub + 2) in sub, n in List.iter [ String.drop_prefix, Substring.drop_prefix ; String.drop_suffix, Substring.drop_suffix ; String.prefix, Substring.prefix ; String.suffix, Substring.suffix ] ~f:(fun (f_str, f_sub) -> Quickcheck.test ~sexp_of:[%sexp_of: substring_for_test * int] sub_and_n ~f:(fun (sub, n) -> let str = Substring.to_string sub in let via_str = Option.try_with (fun () -> f_str str n) in let via_sub = Option.try_with (fun () -> f_sub sub n) |> Option.map ~f:Substring.to_string in if Option.is_some via_str && Option.is_some via_sub then [%test_result: string option] ~expect:via_str via_sub)) ;; end) ;; include Test (struct include Bigstring let of_string s = of_string s end) (Bigsubstring) core-0.15.0/core/test/src/test_substring.mli000066400000000000000000000000551420273305200210030ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_sys.ml000066400000000000000000000005111420273305200174250ustar00rootroot00000000000000open! Core open! Import open! Sys.Private let%test_unit _ = [%test_eq: string] (unix_quote "") {|''|}; [%test_eq: string] (unix_quote "a ") {|'a '|}; [%test_eq: string] (unix_quote "a'") {|'a'\'''|}; [%test_eq: string] (unix_quote "a/b/+share+") {|a/b/+share+|}; [%test_eq: string] (unix_quote "x\000y") "'x\000y'" ;; core-0.15.0/core/test/src/test_time.ml000066400000000000000000001471401420273305200175570ustar00rootroot00000000000000open! Core open Poly open Expect_test_helpers_core let utc date_string ofday_string = Time.of_date_ofday (Date.of_string date_string) (Time.Ofday.of_string ofday_string) ~zone:Time.Zone.utc ;; let examples = [ Time.epoch ; utc "2001-01-01" "00:00:00" ; utc "2013-10-07" "09:30:00" ; utc "2017-07-28" "11:57:00.000123" ] ;; let%expect_test "Time.Stable.With_utc_sexp.V2" = print_and_check_stable_type [%here] (module Time.Stable.With_utc_sexp.V2) examples; [%expect {| (bin_shape_digest 1fd923acb2dd9c5d401ad5b08b1d40cd) ((sexp (1970-01-01 00:00:00.000000Z)) (bin_io "\000\000\000\000\000\000\000\000")) ((sexp (2001-01-01 00:00:00.000000Z)) (bin_io "\000\000\000@\228'\205A")) ((sexp (2013-10-07 09:30:00.000000Z)) (bin_io "\000\000\000\198\159\148\212A")) ((sexp (2017-07-28 11:57:00.000123Z)) (bin_io "\004\002\000\163\201^\214A")) |}] ;; let span_examples = let units = [ Time.Span.nanosecond ; Time.Span.microsecond ; Time.Span.millisecond ; Time.Span.second ; Time.Span.minute ; Time.Span.hour ; Time.Span.day ] in let pos_and_neg_units = units @ List.map units ~f:Time.Span.neg in (Time.Span.zero :: pos_and_neg_units) @ List.map pos_and_neg_units ~f:(fun span -> Time.Span.scale span Float.pi) ;; let%expect_test "Time.Stable.Span.V1" = print_and_check_stable_type [%here] (module struct include Time.Stable.Span.V1 (* [V1] does not precisely round-trip for all suffixes. So we use a comparison that requires accuracy up to one part in a million. *) let compare t1 t2 = let open Time.Span in let magnitude = max (abs t1) (abs t2) in let epsilon = Time.Span.( / ) magnitude 1_000_000. in let diff = t1 - t2 in if diff < neg epsilon then -1 else if diff > epsilon then 1 else 0 ;; end) span_examples; [%expect {| (bin_shape_digest 1fd923acb2dd9c5d401ad5b08b1d40cd) ((sexp 0s) (bin_io "\000\000\000\000\000\000\000\000")) ((sexp 1e-06ms) (bin_io "\149\214&\232\011.\017>")) ((sexp 0.001ms) (bin_io "\141\237\181\160\247\198\176>")) ((sexp 1ms) (bin_io "\252\169\241\210MbP?")) ((sexp 1s) (bin_io "\000\000\000\000\000\000\240?")) ((sexp 1m) (bin_io "\000\000\000\000\000\000N@")) ((sexp 1h) (bin_io "\000\000\000\000\000 \172@")) ((sexp 1d) (bin_io "\000\000\000\000\000\024\245@")) ((sexp -1e-06ms) (bin_io "\149\214&\232\011.\017\190")) ((sexp -0.001ms) (bin_io "\141\237\181\160\247\198\176\190")) ((sexp -1ms) (bin_io "\252\169\241\210MbP\191")) ((sexp -1s) (bin_io "\000\000\000\000\000\000\240\191")) ((sexp -1m) (bin_io "\000\000\000\000\000\000N\192")) ((sexp -1h) (bin_io "\000\000\000\000\000 \172\192")) ((sexp -1d) (bin_io "\000\000\000\000\000\024\245\192")) ((sexp 3.14159e-06ms) (bin_io "\229;!po\252*>")) ((sexp 0.00314159ms) (bin_io "}t\128\211\132Z\202>")) ((sexp 3.14159ms) (bin_io "\195q\139\182e\188i?")) ((sexp 3.14159s) (bin_io "\024-DT\251!\t@")) ((sexp 3.14159m) (bin_io "F\234\255\158\219\143g@")) ((sexp 3.14159h) (bin_io "\162\235\015\229\221\022\198@")) ((sexp 3.14159d) (bin_io "\186\240\203k&\145\016A")) ((sexp -3.14159e-06ms) (bin_io "\229;!po\252*\190")) ((sexp -0.00314159ms) (bin_io "}t\128\211\132Z\202\190")) ((sexp -3.14159ms) (bin_io "\195q\139\182e\188i\191")) ((sexp -3.14159s) (bin_io "\024-DT\251!\t\192")) ((sexp -3.14159m) (bin_io "F\234\255\158\219\143g\192")) ((sexp -3.14159h) (bin_io "\162\235\015\229\221\022\198\192")) ((sexp -3.14159d) (bin_io "\186\240\203k&\145\016\193")) |}] ;; let%expect_test "Time.Stable.Span.V2" = print_and_check_stable_type [%here] (module Time.Stable.Span.V2) ~cr:Comment span_examples; [%expect {| (bin_shape_digest 1fd923acb2dd9c5d401ad5b08b1d40cd) ((sexp 0s) (bin_io "\000\000\000\000\000\000\000\000")) ((sexp 1ns) (bin_io "\149\214&\232\011.\017>")) ((sexp 1us) (bin_io "\141\237\181\160\247\198\176>")) ((sexp 1ms) (bin_io "\252\169\241\210MbP?")) ((sexp 1s) (bin_io "\000\000\000\000\000\000\240?")) ((sexp 1m) (bin_io "\000\000\000\000\000\000N@")) ((sexp 1h) (bin_io "\000\000\000\000\000 \172@")) ((sexp 1d) (bin_io "\000\000\000\000\000\024\245@")) ((sexp -1ns) (bin_io "\149\214&\232\011.\017\190")) ((sexp -1us) (bin_io "\141\237\181\160\247\198\176\190")) ((sexp -1ms) (bin_io "\252\169\241\210MbP\191")) ((sexp -1s) (bin_io "\000\000\000\000\000\000\240\191")) ((sexp -1m) (bin_io "\000\000\000\000\000\000N\192")) ((sexp -1h) (bin_io "\000\000\000\000\000 \172\192")) ((sexp -1d) (bin_io "\000\000\000\000\000\024\245\192")) ((sexp 3.1415926535897931ns) (bin_io "\229;!po\252*>")) ((sexp 3.1415926535897931us) (bin_io "}t\128\211\132Z\202>")) (* require-failed: lib/core/test/src/test_time.ml:LINE:COL. *) ("sexp serialization failed to round-trip" (original 3.1415926535897931us) (sexp 3.1415926535897931us) (sexp_roundtrip 3.1415926535897931us)) ((sexp 3.1415926535897931ms) (bin_io "\195q\139\182e\188i?")) ((sexp 3.1415926535897931s) (bin_io "\024-DT\251!\t@")) ((sexp 3.1415926535897927m) (bin_io "F\234\255\158\219\143g@")) ((sexp 3.1415926535897931h) (bin_io "\162\235\015\229\221\022\198@")) ((sexp 3.1415926535897936d) (bin_io "\186\240\203k&\145\016A")) ((sexp -3.1415926535897931ns) (bin_io "\229;!po\252*\190")) ((sexp -3.1415926535897931us) (bin_io "}t\128\211\132Z\202\190")) (* require-failed: lib/core/test/src/test_time.ml:LINE:COL. *) ("sexp serialization failed to round-trip" (original -3.1415926535897931us) (sexp -3.1415926535897931us) (sexp_roundtrip -3.1415926535897931us)) ((sexp -3.1415926535897931ms) (bin_io "\195q\139\182e\188i\191")) ((sexp -3.1415926535897931s) (bin_io "\024-DT\251!\t\192")) ((sexp -3.1415926535897927m) (bin_io "F\234\255\158\219\143g\192")) ((sexp -3.1415926535897931h) (bin_io "\162\235\015\229\221\022\198\192")) ((sexp -3.1415926535897936d) (bin_io "\186\240\203k&\145\016\193")) |}] ;; let span_gen = Quickcheck.Generator.map Float.gen_finite ~f:Time.Span.of_sec let%test_module "Time.Stable.Span.V3" = (module struct let span_examples = let factors = [ Float.min_positive_subnormal_value ; Float.min_positive_normal_value ; 1e-100 ; 1e19 ; 1e100 ] in let magnitudes = List.concat_map factors ~f:(fun factor -> [ factor; Float.pi *. factor ]) @ [ Float.max_finite_value; Float.infinity ] in let pos_and_neg_magnitudes = List.concat_map magnitudes ~f:(fun magnitude -> [ magnitude; Float.neg magnitude ]) in let magnitude_examples = List.map pos_and_neg_magnitudes ~f:Time.Span.of_sec in span_examples @ magnitude_examples ;; let%expect_test "serialization tests" = print_and_check_stable_type [%here] (module Time.Stable.Span.V3) span_examples; [%expect {| (bin_shape_digest 1fd923acb2dd9c5d401ad5b08b1d40cd) ((sexp 0s) (bin_io "\000\000\000\000\000\000\000\000")) ((sexp 1ns) (bin_io "\149\214&\232\011.\017>")) ((sexp 1us) (bin_io "\141\237\181\160\247\198\176>")) ((sexp 1ms) (bin_io "\252\169\241\210MbP?")) ((sexp 1s) (bin_io "\000\000\000\000\000\000\240?")) ((sexp 1m) (bin_io "\000\000\000\000\000\000N@")) ((sexp 1h) (bin_io "\000\000\000\000\000 \172@")) ((sexp 1d) (bin_io "\000\000\000\000\000\024\245@")) ((sexp -1ns) (bin_io "\149\214&\232\011.\017\190")) ((sexp -1us) (bin_io "\141\237\181\160\247\198\176\190")) ((sexp -1ms) (bin_io "\252\169\241\210MbP\191")) ((sexp -1s) (bin_io "\000\000\000\000\000\000\240\191")) ((sexp -1m) (bin_io "\000\000\000\000\000\000N\192")) ((sexp -1h) (bin_io "\000\000\000\000\000 \172\192")) ((sexp -1d) (bin_io "\000\000\000\000\000\024\245\192")) ((sexp 3.1415926535897931ns) (bin_io "\229;!po\252*>")) ((sexp 3.1415926535897927us4e-13ns) (bin_io "}t\128\211\132Z\202>")) ((sexp 3.1415926535897931ms) (bin_io "\195q\139\182e\188i?")) ((sexp 3.1415926535897931s) (bin_io "\024-DT\251!\t@")) ((sexp 3m8.49555921538757s) (bin_io "F\234\255\158\219\143g@")) ((sexp 3h8m29.733552923255s) (bin_io "\162\235\015\229\221\022\198@")) ((sexp 3d3h23m53.60527015815s) (bin_io "\186\240\203k&\145\016A")) ((sexp -3.1415926535897931ns) (bin_io "\229;!po\252*\190")) ((sexp -3.1415926535897927us4e-13ns) (bin_io "}t\128\211\132Z\202\190")) ((sexp -3.1415926535897931ms) (bin_io "\195q\139\182e\188i\191")) ((sexp -3.1415926535897931s) (bin_io "\024-DT\251!\t\192")) ((sexp -3m8.49555921538757s) (bin_io "F\234\255\158\219\143g\192")) ((sexp -3h8m29.733552923255s) (bin_io "\162\235\015\229\221\022\198\192")) ((sexp -3d3h23m53.60527015815s) (bin_io "\186\240\203k&\145\016\193")) ((sexp 4.94065645841247e-315ns) (bin_io "\001\000\000\000\000\000\000\000")) ((sexp -4.94065645841247e-315ns) (bin_io "\001\000\000\000\000\000\000\128")) ((sexp 1.48219693752374e-314ns) (bin_io "\003\000\000\000\000\000\000\000")) ((sexp -1.48219693752374e-314ns) (bin_io "\003\000\000\000\000\000\000\128")) ((sexp 2.2250738585072014e-299ns) (bin_io "\000\000\000\000\000\000\016\000")) ((sexp -2.2250738585072014e-299ns) (bin_io "\000\000\000\000\000\000\016\128")) ((sexp 6.9902756875809189e-299ns) (bin_io "\024-DT\251!)\000")) ((sexp -6.9902756875809189e-299ns) (bin_io "\024-DT\251!)\128")) ((sexp 1e-91ns) (bin_io "0\005\142\228.\255++")) ((sexp -1e-91ns) (bin_io "0\005\142\228.\255+\171")) ((sexp 3.1415926535897929e-91ns) (bin_io "\012\248;\174\023\253E+")) ((sexp -3.1415926535897929e-91ns) (bin_io "\012\248;\174\023\253E\171")) ((sexp 115740740740740d17h34m) (bin_io "\000=\145`\228X\225C")) ((sexp -115740740740740d17h34m) (bin_io "\000=\145`\228X\225\195")) ((sexp 363610260832152d) (bin_io "n_\197\171\188?\251C")) ((sexp -363610260832152d) (bin_io "n_\197\171\188?\251\195")) ((sexp 1.1574074074074074e+95d) (bin_io "}\195\148%\173I\178T")) ((sexp -1.1574074074074074e+95d) (bin_io "}\195\148%\173I\178\212")) ((sexp 3.63610260832152e+95d) (bin_io "\132\235\242\195\245\185\204T")) ((sexp -3.63610260832152e+95d) (bin_io "\132\235\242\195\245\185\204\212")) ((sexp 2.0806633505350874e+303d2e+287d) (bin_io "\255\255\255\255\255\255\239\127")) ((sexp -2.0806633505350874e+303d2e+287d) (bin_io "\255\255\255\255\255\255\239\255")) ((sexp INFs) (bin_io "\000\000\000\000\000\000\240\127")) ((sexp -INFs) (bin_io "\000\000\000\000\000\000\240\255")) |}] ;; let%expect_test ("serialization tests for NaNs" [@tags "64-bits-only"]) = print_and_check_stable_type [%here] (module Time.Stable.Span.V3) [ Time.Span.of_sec Float.nan; Time.Span.of_sec Float.nan |> Time.Span.neg ]; [%expect {| (bin_shape_digest 1fd923acb2dd9c5d401ad5b08b1d40cd) ((sexp NANs) (bin_io "\001\000\000\000\000\000\240\127")) ((sexp NANs) (bin_io "\001\000\000\000\000\000\240\255")) |}] ;; let%expect_test "V3 accepts V1 and V2 sexp outputs" = let test version (module Vn : Sexpable with type t = Time.Span.t) span = let module V3 = Time.Stable.Span.V3 in let vn_sexp = Vn.sexp_of_t span in let vn = Vn.t_of_sexp vn_sexp in let v3 = V3.t_of_sexp vn_sexp in let vn_error = Time.Span.abs (Time.Span.( - ) vn span) in let v3_error = Time.Span.abs (Time.Span.( - ) v3 span) in require [%here] (Time.Span.( <= ) v3_error vn_error) ~if_false_then_print_s: (lazy [%message "V3 did not read prior version sexp at least as precisely as prior \ version" (version : string) (span : Time.Span.t) (vn_sexp : Sexp.t) (vn : Time.Span.t) (v3 : Time.Span.t) (vn_error : Time.Span.t) (v3_error : Time.Span.t)]) in quickcheck [%here] span_gen ~sexp_of:Time.Span.sexp_of_t ~f:(fun span -> test "V1" (module Time.Stable.Span.V1) span; test "V2" (module Time.Stable.Span.V2) span); [%expect {| |}] ;; end) ;; let%test_module "Span.to_string/of_string" = (module struct let%expect_test "of_string unit tests" = let strings = [ "1d1ns" ; "-1ns1d" ; "1e4d1e-4ms" ; "+1e4d1e-4ms" ; "3e-5ms1e4d3e-5ms" ; "2_400h1.000_001s" ] in List.iter strings ~f:(fun string -> print_endline (Float.to_string (Time.Span.to_sec (Time.Span.of_string string)))); [%expect {| 86400.000000001 -86400.000000001 864000000.00000012 864000000.00000012 864000000. 8640001.000001 |}] ;; let near_powers_of_10 = let powers_of_10 = List.map (List.range ~start:`inclusive ~-20 ~stop:`exclusive 30) ~f:(fun expt -> 10. ** Float.of_int expt) in let powers_of_10_in_various_units = List.concat_map powers_of_10 ~f:(fun power_of_10 -> List.map Unit_of_time.all ~f:(fun unit_of_time -> Time.Span.scale (Time.Span.of_unit_of_time unit_of_time) power_of_10)) in List.concat_map powers_of_10_in_various_units ~f:(fun power -> [ power |> Time.Span.prev |> Time.Span.prev |> Time.Span.prev ; power |> Time.Span.prev |> Time.Span.prev ; power |> Time.Span.prev ; power ; power |> Time.Span.next ; power |> Time.Span.next |> Time.Span.next ; power |> Time.Span.next |> Time.Span.next |> Time.Span.next ]) ;; let%expect_test "string round-trip is precise" = quickcheck [%here] span_gen ~sexp_of:Time.Span.sexp_of_t ~examples:near_powers_of_10 ~f:(fun span -> let string = Time.Span.to_string span in let round_trip = Time.Span.of_string string in require [%here] (Time.Span.equal round_trip span) ~if_false_then_print_s: (lazy [%message "string round-trip is not precise" (span : Time.Span.t) (string : string) (round_trip : Time.Span.t)])); [%expect {| |}] ;; let%expect_test "of_string accepts underscores in between digits" = let open Quickcheck.Let_syntax in let rec with_underscores_gen = function | [] -> return [] | [ char ] -> return [ char ] | a :: b :: rest when Char.is_digit a && Char.is_digit b -> let%bind tail = with_underscores_gen (b :: rest) in if%bind Bool.quickcheck_generator then return (a :: '_' :: tail) else return (a :: tail) | char :: rest -> let%bind tail = with_underscores_gen rest in return (char :: tail) in let string_with_underscores_gen = let%bind span = span_gen in let string = Time.Span.to_string span in let%bind list_with_underscores = with_underscores_gen (String.to_list string) in return (String.of_char_list list_with_underscores) in quickcheck [%here] string_with_underscores_gen ~sexp_of:String.sexp_of_t ~f:(fun string_with_underscores -> require_does_not_raise [%here] (fun () -> let span = Time.Span.of_string string_with_underscores in let string_without_underscores = Time.Span.to_string span in let round_trip = Time.Span.of_string string_without_underscores in require_equal [%here] (module Time.Span) span round_trip ~if_false_then_print_s:(lazy [%message string_without_underscores]); let string_with_underscores_removed = String.filter string_with_underscores ~f:(function | '_' -> false | _ -> true) in require_equal [%here] (module String) string_without_underscores string_with_underscores_removed ~if_false_then_print_s:(lazy [%sexp (span : Time.Span.t)]))); [%expect {| |}] ;; let is_float_char = function | '0' .. '9' | '.' | 'e' | '+' | '-' -> true | _ -> false ;; let min_mantissa = Float.ieee_mantissa Float.min_positive_normal_value let max_mantissa = Float.ieee_mantissa Float.max_finite_value let%expect_test "mantissa bounds" = printf !"%{Int63.Hex#hum} %{Int63.Hex#hum}\n" min_mantissa max_mantissa; (* 13x4 = 52 explicitly-represented bits of mantissa in a 64-bit float *) [%expect {| 0x0 0xf_ffff_ffff_ffff |}] ;; let float_gen_uniform_exponent ~min_exponent ~max_exponent = let open Quickcheck.Generator.Let_syntax in [%map_open let mantissa = Int63.gen_incl min_mantissa max_mantissa (* [Int] is big enough even on 32-bit platforms. *) and exponent = Int.gen_incl min_exponent max_exponent and negative = Bool.quickcheck_generator in Float.create_ieee_exn ~negative ~exponent ~mantissa] ;; let bounded_span_gen ~magnitude_low ~magnitude_high = let min_exponent = Float.ieee_exponent (Time.Span.to_sec magnitude_low) in let max_exponent = Float.ieee_exponent (Time.Span.to_sec magnitude_high) in float_gen_uniform_exponent ~min_exponent ~max_exponent |> Quickcheck.Generator.map ~f:Time.Span.of_sec |> Quickcheck.Generator.filter ~f:(fun span -> let magnitude = Time.Span.abs span in Time.Span.( > ) magnitude magnitude_low && Time.Span.( < ) magnitude magnitude_high) ;; let test_part_magnitudes ~magnitude_low ~magnitude_high ~allow_abnormal_frac = let unit_of_suffix string : Unit_of_time.t = match string with | "d" -> Day | "h" -> Hour | "m" -> Minute | "s" -> Second | "ms" -> Millisecond | "us" -> Microsecond | "ns" -> Nanosecond | _ -> assert false in let rec parts_of_list = function | [] -> [] | magnitude :: suffix :: rest -> (Float.of_string magnitude, unit_of_suffix suffix) :: parts_of_list rest | _ -> assert false in let parts_of_string string = let string = match String.chop_prefix string ~prefix:"-" with | Some prefix -> prefix | None -> string in let magnitudes_and_units = String.to_list string |> List.group ~break:(fun a b -> Bool.( <> ) (is_float_char a) (is_float_char b)) |> List.map ~f:String.of_char_list in parts_of_list magnitudes_and_units in let upper_bound unit_of_time = match (unit_of_time : Unit_of_time.t) with | Day -> None | Hour -> Some 24. | Minute -> Some 60. | Second -> Some 60. | Millisecond -> Some 1000. | Microsecond -> Some 1000. | Nanosecond -> Some 1000. in let quickcheck_generator = bounded_span_gen ~magnitude_low ~magnitude_high in let test_count = ref 0 in let abnormal_count = ref 0 in quickcheck [%here] quickcheck_generator ~sexp_of:Time.Span.sexp_of_t ~f:(fun span -> let seconds = Time.Span.to_sec span in let ulp = Float.one_ulp `Up seconds -. seconds in let string = Time.Span.to_string span in require [%here] (Time.Span.of_string string = span) ~if_false_then_print_s: (lazy [%message "span failed to round-trip string conversion" (string : string) (seconds : float)]); let parts = parts_of_string string in let is_abnormal = (* Spans with a ULP over half a minute start to have abnormal parts like "60s". This is an artifact of our [to_string] algorithm and how it uses smaller units of time to correct for rounding error in the larger ones; once the rounding error is over half the size of the previous unit, the results are no longer what we expect as humans. Since the output is still numerically correct and spans this large are rarely used, we tolerate the abnormality, but only in the very last part. Additionally, we very occasionally have remainders that are >900us, but we print 1 decimal place and end up printing 1000us instead of 1ms *) List.fold parts ~init:false ~f:(fun has_abnormal (magnitude, unit_of_time) -> let open Float.O in require [%here] (not has_abnormal) ~if_false_then_print_s: (lazy [%message "abnormal span part not last" (string : string)]); require [%here] (magnitude > 0.) ~if_false_then_print_s: (lazy [%message "magnitude is negative" (string : string) (magnitude : float) (unit_of_time : Unit_of_time.t)]); Option.value_map ~default:false (upper_bound unit_of_time) ~f:(fun upper_bound -> (* we tolerate one abnormality where the very last part is exactly at the upper bound *) if magnitude = upper_bound then true else ( require [%here] (magnitude < upper_bound) ~if_false_then_print_s: (lazy [%message "magnitude out of bounds" (string : string) (seconds : float) (ulp : float) (magnitude : float) (upper_bound : float) (unit_of_time : Unit_of_time.t)]); false))) in incr test_count; if is_abnormal then incr abnormal_count); let abnormal_frac = Float.of_int !abnormal_count /. Float.of_int !test_count in if Float.(abnormal_frac > allow_abnormal_frac) then raise_s [%message "fraction of inputs with abnormal parts beyond tolerance" (magnitude_low : Time.Span.t) (magnitude_high : Time.Span.t) (test_count : int ref) (abnormal_count : int ref) (abnormal_frac : float) (allow_abnormal_frac : float)] ;; let%expect_test "span magnitudes are within expected range" = (* construct and verify constants with desired ULP values *) let check_ulps x = printf "span : %s\n" Time.Span.(to_string x); printf "ulp up : %s\n" Time.Span.(to_string (next x - x)); printf "ulp down: %s\n" Time.Span.(to_string (x - prev x)) in let tenth_ms_ulp = Time.Span.of_sec (Float.ldexp 1. (53 - 14)) in check_ulps tenth_ms_ulp; [%expect {| span : 6362914d12h18m8s ulp up : 122.0703125us ulp down: 61.03515625us |}]; let ms_ulp = Time.Span.of_sec (Float.ldexp 1. (53 - 10)) in check_ulps ms_ulp; [%expect {| span : 101806632d4h50m8s ulp up : 1.953125ms ulp down: 976.5625us |}]; let half_min_ulp = Time.Span.of_sec (Float.ldexp 1. (53 + 4)) in check_ulps half_min_ulp; [%expect {| span : 1667999861989d1h44m32s ulp up : 32s ulp down: 16s |}]; let two_min_ulp = Time.Span.of_sec (Float.ldexp 1. (53 + 6)) in check_ulps two_min_ulp; [%expect {| span : 6671999447956d6h58m ulp up : 2m8s ulp down: 1m4s |}]; let quarter_hr_ulp = Time.Span.of_sec (Float.ldexp 1. (53 + 9)) in check_ulps quarter_hr_ulp; [%expect {| span : 53375995583650d7h42m ulp up : 17m4s ulp down: 8m32s |}]; let two_hr_ulp = Time.Span.of_sec (Float.ldexp 1. (53 + 12)) in check_ulps two_hr_ulp; [%expect {| span : 427007964669202d14h ulp up : 2h16m32s ulp down: 1h8m16s |}]; let infinity = Time.Span.of_sec Float.infinity in (* Test magnitudes of span parts, allowing abnormal magnitudes (like 24h or 60s) in the ranges where we expect them. The allowed fractions of values with abnormal magnitudes are set generously, so if they break in the future we've seen a significant change in behavior, and not just a different random seed. *) test_part_magnitudes ~magnitude_low:Time.Span.zero ~magnitude_high:tenth_ms_ulp ~allow_abnormal_frac:0.; test_part_magnitudes ~magnitude_low:tenth_ms_ulp ~magnitude_high:ms_ulp ~allow_abnormal_frac:0.00002; test_part_magnitudes ~magnitude_low:ms_ulp ~magnitude_high:half_min_ulp ~allow_abnormal_frac:0.; test_part_magnitudes ~magnitude_low:half_min_ulp ~magnitude_high:two_min_ulp ~allow_abnormal_frac:0.006; test_part_magnitudes ~magnitude_low:two_min_ulp ~magnitude_high:quarter_hr_ulp ~allow_abnormal_frac:0.; test_part_magnitudes ~magnitude_low:quarter_hr_ulp ~magnitude_high:two_hr_ulp ~allow_abnormal_frac:0.02; test_part_magnitudes ~magnitude_low:two_hr_ulp ~magnitude_high:infinity ~allow_abnormal_frac:0.; (* A few explicit examples of abnormal parts *) printf "%s\n" (Time.Span.to_string (Time.Span.of_sec 3004250081760.001)); printf "%s\n" (Time.Span.to_string (Time.Span.of_sec 4.5514503734113075E+17)); printf "%s\n" (Time.Span.to_string (Time.Span.of_sec 1.8863400560491495E+19)); [%expect {| 34771412d23h36m1e+03us 5267882376633d10h60m 218326395376058d24h |}] ;; let%expect_test "unit appearing twice" = let split string = String.to_list string |> List.group ~break:(fun a b -> Bool.( <> ) (is_float_char a) (is_float_char b)) |> List.map ~f:String.of_char_list in let test ?cr suffix = quickcheck [%here] ?cr span_gen ~sexp_of:Time.Span.sexp_of_t ~f:(fun span -> let string = Time.Span.to_string span in let strings = split string in require [%here] ?cr (List.count strings ~f:(String.equal suffix) <= 1)) in (* For very large values (ULP >> 1s), we can see days appear twice, once very large and once smaller by several orders of magnitude. Note that the specific example produced here is nondeterministic and may change. *) test ~cr:Comment "d"; [%expect {| ("quickcheck: test failed" (input -2.1695734240829744e+44d3e+28d)) (* require-failed: lib/core/test/src/test_time.ml:LINE:COL. *) |}]; test "h"; [%expect {| |}]; test "m"; [%expect {| |}]; test "s"; [%expect {| |}]; test "ms"; [%expect {| |}]; test "us"; [%expect {| |}]; (* For some times measured in ns, we can see ns appear twice, with the second one smaller than the first by several orders of magnitude. The specific example produced here is nondeterministic and may change. *) test ~cr:Comment "ns"; [%expect {| ("quickcheck: test failed" (input -3.70807784925899e-59ns4e-75ns)) (* require-failed: lib/core/test/src/test_time.ml:LINE:COL. *) |}] ;; end) ;; let%expect_test "Span.to_parts + Span.create" = List.iter span_examples ~f:(fun span -> let parts = Time.Span.to_parts span in Core.print_s [%sexp (span, parts : Time.Span.t * Time.Span.Parts.t)]; let ({ sign; hr; min; sec; ms; us; ns } : Time.Span.Parts.t) = parts in let round_trip = Time.Span.create ~sign ~hr ~min ~sec ~ms ~us ~ns () in let abs_diff = Time.Span.abs (Time.Span.( - ) span round_trip) in require [%here] (Time.Span.( < ) abs_diff Time.Span.nanosecond) ~if_false_then_print_s: (lazy [%message "round-trip failed" (span : Time.Span.t) (parts : Time.Span.Parts.t) (round_trip : Time.Span.t) (abs_diff : Time.Span.t)])); [%expect {| (0s ((sign Zero) (hr 0) (min 0) (sec 0) (ms 0) (us 0) (ns 0))) (1ns ((sign Pos) (hr 0) (min 0) (sec 0) (ms 0) (us 0) (ns 1))) (1us ((sign Pos) (hr 0) (min 0) (sec 0) (ms 0) (us 1) (ns 0))) (1ms ((sign Pos) (hr 0) (min 0) (sec 0) (ms 1) (us 0) (ns 0))) (1s ((sign Pos) (hr 0) (min 0) (sec 1) (ms 0) (us 0) (ns 0))) (1m ((sign Pos) (hr 0) (min 1) (sec 0) (ms 0) (us 0) (ns 0))) (1h ((sign Pos) (hr 1) (min 0) (sec 0) (ms 0) (us 0) (ns 0))) (1d ((sign Pos) (hr 24) (min 0) (sec 0) (ms 0) (us 0) (ns 0))) (-1ns ((sign Neg) (hr 0) (min 0) (sec 0) (ms 0) (us 0) (ns 1))) (-1us ((sign Neg) (hr 0) (min 0) (sec 0) (ms 0) (us 1) (ns 0))) (-1ms ((sign Neg) (hr 0) (min 0) (sec 0) (ms 1) (us 0) (ns 0))) (-1s ((sign Neg) (hr 0) (min 0) (sec 1) (ms 0) (us 0) (ns 0))) (-1m ((sign Neg) (hr 0) (min 1) (sec 0) (ms 0) (us 0) (ns 0))) (-1h ((sign Neg) (hr 1) (min 0) (sec 0) (ms 0) (us 0) (ns 0))) (-1d ((sign Neg) (hr 24) (min 0) (sec 0) (ms 0) (us 0) (ns 0))) (3.1415926535897931ns ((sign Pos) (hr 0) (min 0) (sec 0) (ms 0) (us 0) (ns 3))) (3.1415926535897927us4e-13ns ((sign Pos) (hr 0) (min 0) (sec 0) (ms 0) (us 3) (ns 142))) (3.1415926535897931ms ((sign Pos) (hr 0) (min 0) (sec 0) (ms 3) (us 141) (ns 593))) (3.1415926535897931s ((sign Pos) (hr 0) (min 0) (sec 3) (ms 141) (us 592) (ns 654))) (3m8.49555921538757s ((sign Pos) (hr 0) (min 3) (sec 8) (ms 495) (us 559) (ns 215))) (3h8m29.733552923255s ((sign Pos) (hr 3) (min 8) (sec 29) (ms 733) (us 552) (ns 923))) (3d3h23m53.60527015815s ((sign Pos) (hr 75) (min 23) (sec 53) (ms 605) (us 270) (ns 158))) (-3.1415926535897931ns ((sign Neg) (hr 0) (min 0) (sec 0) (ms 0) (us 0) (ns 3))) (-3.1415926535897927us4e-13ns ((sign Neg) (hr 0) (min 0) (sec 0) (ms 0) (us 3) (ns 142))) (-3.1415926535897931ms ((sign Neg) (hr 0) (min 0) (sec 0) (ms 3) (us 141) (ns 593))) (-3.1415926535897931s ((sign Neg) (hr 0) (min 0) (sec 3) (ms 141) (us 592) (ns 654))) (-3m8.49555921538757s ((sign Neg) (hr 0) (min 3) (sec 8) (ms 495) (us 559) (ns 215))) (-3h8m29.733552923255s ((sign Neg) (hr 3) (min 8) (sec 29) (ms 733) (us 552) (ns 923))) (-3d3h23m53.60527015815s ((sign Neg) (hr 75) (min 23) (sec 53) (ms 605) (us 270) (ns 158))) |}] ;; let ofday_examples = List.filter_map span_examples ~f:(fun span -> if Time.Span.( >= ) span Time.Span.zero && Time.Span.( < ) span Time.Span.day then Some (Time.Ofday.of_span_since_start_of_day_exn span) else None) ;; let%expect_test "Ofday.to_parts + Ofday.create" = List.iter ofday_examples ~f:(fun ofday -> let parts = Time.Ofday.to_parts ofday in Core.print_s [%sexp (ofday, parts : Time.Ofday.t * Time.Span.Parts.t)]; let ({ sign = _; hr; min; sec; ms; us; ns } : Time.Span.Parts.t) = parts in let round_trip = Time.Ofday.create ~hr ~min ~sec ~ms ~us ~ns () in let abs_diff = Time.Span.abs (Time.Ofday.diff ofday round_trip) in require [%here] (Time.Span.( < ) abs_diff Time.Span.nanosecond) ~if_false_then_print_s: (lazy [%message "round-trip failed" (ofday : Time.Ofday.t) (parts : Time.Span.Parts.t) (round_trip : Time.Ofday.t) (abs_diff : Time.Span.t)])); [%expect {| (00:00:00.000000 ((sign Zero) (hr 0) (min 0) (sec 0) (ms 0) (us 0) (ns 0))) (00:00:00.000000 ((sign Pos) (hr 0) (min 0) (sec 0) (ms 0) (us 0) (ns 1))) (00:00:00.000001 ((sign Pos) (hr 0) (min 0) (sec 0) (ms 0) (us 1) (ns 0))) (00:00:00.001000 ((sign Pos) (hr 0) (min 0) (sec 0) (ms 1) (us 0) (ns 0))) (00:00:01.000000 ((sign Pos) (hr 0) (min 0) (sec 1) (ms 0) (us 0) (ns 0))) (00:01:00.000000 ((sign Pos) (hr 0) (min 1) (sec 0) (ms 0) (us 0) (ns 0))) (01:00:00.000000 ((sign Pos) (hr 1) (min 0) (sec 0) (ms 0) (us 0) (ns 0))) (00:00:00.000000 ((sign Pos) (hr 0) (min 0) (sec 0) (ms 0) (us 0) (ns 3))) (00:00:00.000003 ((sign Pos) (hr 0) (min 0) (sec 0) (ms 0) (us 3) (ns 142))) (00:00:00.003142 ((sign Pos) (hr 0) (min 0) (sec 0) (ms 3) (us 141) (ns 593))) (00:00:03.141593 ((sign Pos) (hr 0) (min 0) (sec 3) (ms 141) (us 592) (ns 654))) (00:03:08.495559 ((sign Pos) (hr 0) (min 3) (sec 8) (ms 495) (us 559) (ns 215))) (03:08:29.733553 ((sign Pos) (hr 3) (min 8) (sec 29) (ms 733) (us 552) (ns 923))) |}] ;; let%expect_test "time zone offset parsing" = let test string = print_endline (Time.to_string_utc (Time.of_string_with_utc_offset string)) in test "2000-01-01 12:34:56.789012-00:00"; test "2000-01-01 12:34:56.789012-0:00"; test "2000-01-01 12:34:56.789012-00"; test "2000-01-01 12:34:56.789012-0"; [%expect {| 2000-01-01 12:34:56.789012Z 2000-01-01 12:34:56.789012Z 2000-01-01 12:34:56.789012Z 2000-01-01 12:34:56.789012Z |}]; test "2000-01-01 12:34:56.789012-05:00"; test "2000-01-01 12:34:56.789012-5:00"; test "2000-01-01 12:34:56.789012-05"; test "2000-01-01 12:34:56.789012-5"; [%expect {| 2000-01-01 17:34:56.789012Z 2000-01-01 17:34:56.789012Z 2000-01-01 17:34:56.789012Z 2000-01-01 17:34:56.789012Z |}]; test "2000-01-01 12:34:56.789012-23:00"; test "2000-01-01 12:34:56.789012-23"; [%expect {| 2000-01-02 11:34:56.789012Z 2000-01-02 11:34:56.789012Z |}]; test "2000-01-01 12:34:56.789012-24:00"; test "2000-01-01 12:34:56.789012-24"; [%expect {| 2000-01-02 12:34:56.789012Z 2000-01-02 12:34:56.789012Z |}] ;; let%expect_test "time zone invalid offset parsing" = let test here string = require_does_raise here (fun () -> Time.of_string_with_utc_offset string) in test [%here] "2000-01-01 12:34:56.789012-0:"; test [%here] "2000-01-01 12:34:56.789012-00:"; test [%here] "2000-01-01 12:34:56.789012-0:0"; test [%here] "2000-01-01 12:34:56.789012-00:0"; test [%here] "2000-01-01 12:34:56.789012-:"; test [%here] "2000-01-01 12:34:56.789012-:00"; test [%here] "2000-01-01 12:34:56.789012-"; [%expect {| (time.ml.Make.Time_of_string "2000-01-01 12:34:56.789012-0:" ("Time.Ofday: invalid string" 0: "expected colon or am/pm suffix with optional space after minutes")) (time.ml.Make.Time_of_string "2000-01-01 12:34:56.789012-00:" ("Time.Ofday: invalid string" 00: "expected colon or am/pm suffix with optional space after minutes")) (time.ml.Make.Time_of_string "2000-01-01 12:34:56.789012-0:0" ("Time.Ofday: invalid string" 0:0 "expected colon or am/pm suffix with optional space after minutes")) (time.ml.Make.Time_of_string "2000-01-01 12:34:56.789012-00:0" ("Time.Ofday: invalid string" 00:0 "expected colon or am/pm suffix with optional space after minutes")) (time.ml.Make.Time_of_string "2000-01-01 12:34:56.789012-:" (Invalid_argument "index out of bounds")) (time.ml.Make.Time_of_string "2000-01-01 12:34:56.789012-:00" (Failure "Char.get_digit_exn ':': not a digit")) (time.ml.Make.Time_of_string "2000-01-01 12:34:56.789012-" (Invalid_argument "index out of bounds")) |}]; test [%here] "2000-01-01 12:34:56.789012-25:00"; test [%here] "2000-01-01 12:34:56.789012-25"; [%expect {| (time.ml.Make.Time_of_string "2000-01-01 12:34:56.789012-25:00" ("Time.Ofday: invalid string" 25:00 "hours out of bounds")) (time.ml.Make.Time_of_string "2000-01-01 12:34:56.789012-25" ("Time.Ofday: invalid string" 25:00 "hours out of bounds")) |}]; test [%here] "2000-01-01 12:34:56.789012--1:00"; test [%here] "2000-01-01 12:34:56.789012--1"; [%expect {| (time.ml.Make.Time_of_string "2000-01-01 12:34:56.789012--1:00" (Failure "Char.get_digit_exn '-': not a digit")) (time.ml.Make.Time_of_string "2000-01-01 12:34:56.789012--1" (Invalid_argument "index out of bounds")) |}] ;; let%expect_test "of_string_iso8601_extended" = let success string = require_does_not_raise [%here] (fun () -> printf "%s <-- %s\n" (Time.Ofday.to_string (Time.Ofday.of_string_iso8601_extended string)) string) in List.iter ~f:success [ (* normal times *) "12" ; "12:34" ; "12:34:56" ; "12:34:56.789" ; "12:34:56.789123" ; "12:34:56.789123456" ; (* lower boundary case *) "00" ; "00:00" ; "00:00:00" ; "00:00:00.000" ; "00:00:00.000000" ; "00:00:00.000000000" ; (* upper boundary case *) "23" ; "23:59" ; "23:59:59" ; "23:59:59.999" ; "23:59:59.999999" ; "23:59:59.999999999" ; (* midnight tomorrow *) "24" ; "24:00" ; "24:00:00" ; "24:00:00.000" ; "24:00:00.000000" ; "24:00:00.000000000" ; (* leap second *) "12:59:60" ; "12:59:60.789" ; "12:59:60.789123" ; "12:59:60.789123456" ]; [%expect {| 12:00:00.000000 <-- 12 12:34:00.000000 <-- 12:34 12:34:56.000000 <-- 12:34:56 12:34:56.789000 <-- 12:34:56.789 12:34:56.789123 <-- 12:34:56.789123 12:34:56.789123 <-- 12:34:56.789123456 00:00:00.000000 <-- 00 00:00:00.000000 <-- 00:00 00:00:00.000000 <-- 00:00:00 00:00:00.000000 <-- 00:00:00.000 00:00:00.000000 <-- 00:00:00.000000 00:00:00.000000 <-- 00:00:00.000000000 23:00:00.000000 <-- 23 23:59:00.000000 <-- 23:59 23:59:59.000000 <-- 23:59:59 23:59:59.999000 <-- 23:59:59.999 23:59:59.999999 <-- 23:59:59.999999 24:00:00.000000 <-- 23:59:59.999999999 24:00:00.000000 <-- 24 24:00:00.000000 <-- 24:00 24:00:00.000000 <-- 24:00:00 24:00:00.000000 <-- 24:00:00.000 24:00:00.000000 <-- 24:00:00.000000 24:00:00.000000 <-- 24:00:00.000000000 13:00:00.000000 <-- 12:59:60 13:00:00.000000 <-- 12:59:60.789 13:00:00.000000 <-- 12:59:60.789123 13:00:00.000000 <-- 12:59:60.789123456 |}]; let failure string = match Time.Ofday.of_string_iso8601_extended string with | exception Invalid_argument message -> print_endline message | exception exn -> (* This is not necessarily an error, we may just need to update this test. *) print_cr [%here] [%message "unexpected exception" (exn : exn)] | ofday -> print_cr [%here] [%message "did not raise" (string : string) (ofday : Time.Ofday.t)] in List.iter ~f:failure [ (* bad syntax *) "" ; "1" ; "123" ; ":" ; "12:" ; "1:23" ; "12:3" ; "12:345" ; "12:34:" ; "12:34:5" ; (* numerical bounds *) "25:00" ; "00:60" ; "00:59:61" ]; [%expect {| Ofday.of_string_iso8601_extended(): (Failure "len < 2") Ofday.of_string_iso8601_extended(1): (Failure "len < 2") Ofday.of_string_iso8601_extended(123): (Failure "2 < len < 5") Ofday.of_string_iso8601_extended(:): (Failure "len < 2") Ofday.of_string_iso8601_extended(12:): (Failure "2 < len < 5") Ofday.of_string_iso8601_extended(1:23): (Failure "Char.get_digit_exn ':': not a digit") Ofday.of_string_iso8601_extended(12:3): (Failure "2 < len < 5") Ofday.of_string_iso8601_extended(12:345): (Failure "5 < len < 8") Ofday.of_string_iso8601_extended(12:34:): (Failure "5 < len < 8") Ofday.of_string_iso8601_extended(12:34:5): (Failure "5 < len < 8") Ofday.of_string_iso8601_extended(25:00): (Failure "hour > 24") Ofday.of_string_iso8601_extended(00:60): (Failure "minute > 60") Ofday.of_string_iso8601_extended(00:59:61): (Failure "invalid second: 61") |}] ;; module _ = struct open Time.Ofday let%test "create can handle a leap second" = let last_second = create ~hr:21 () in List.for_all ~f:(fun v -> equal v last_second) [ create ~hr:20 ~min:59 ~sec:60 () ; create ~hr:20 ~min:59 ~sec:60 ~ms:500 () ; create ~hr:20 ~min:59 ~sec:60 ~ms:500 ~us:500 () ; create ~hr:20 ~min:59 ~sec:60 ~ms:0 ~us:500 () ] ;; let%test_unit "of_string does not naively dispatch to [Int.of_string] and \ [Float.of_string]" = assert (Exn.does_raise (fun () -> of_string "1:0:00")); assert (Exn.does_raise (fun () -> of_string "1:-0:00")); assert (Exn.does_raise (fun () -> of_string "0o10:0x28:3e1")) ;; let%bench "Time.Ofday.of_string" = of_string "12:00:00am" let%test "of_string supports leap seconds" = let last_second = create ~hr:21 () in List.for_all ~f:(fun s -> of_string s = last_second) [ "20:59:60"; "20:59:60.500"; "20:59:60.000" ] ;; let%test_unit "of_string supports non-meridiem times" = assert (create ~hr:7 ~min:21 ~sec:0 () = of_string "07:21:00") ;; module Ofday_helpers = Core_private.Ofday_helpers (* This because we're sharing the suffixes between the parser code and tests, so e.g. typos would otherwise go undetected *) let%expect_test "the permissible suffixes are reasonable" = printf "%s\n" (String.concat ~sep:" " (Lazy.force Ofday_helpers.am_suffixes)); printf "%s\n" (String.concat ~sep:" " (Lazy.force Ofday_helpers.pm_suffixes)); [%expect {| a A am AM a.m A.M a.m. A.M. p P pm PM p.m P.M p.m. P.M. |}] ;; let%test_unit "of_string supports meridiem times" = let test_excluding_noon ~hr ~zeroes ~meridiem () = let hrs_to_add, suffixes = let plus_space xs = xs @ List.map xs ~f:(fun x -> " " ^ x) in match meridiem with | None -> 0, [ "" ] | Some `AM -> 0, plus_space (Lazy.force Ofday_helpers.am_suffixes) | Some `PM -> 12, plus_space (Lazy.force Ofday_helpers.pm_suffixes) in List.iter suffixes ~f:(fun suffix -> let t = create ~hr:(hr + hrs_to_add) () in let str = sprintf "%d%s%s" hr zeroes suffix in assert (t = of_string str)) in let failure f = assert (Exn.does_raise f) in let success f = Or_error.try_with f |> Or_error.tag ~tag:"expected success" |> Or_error.ok_exn in (* Test everything but hour 12 and 0 *) let first_half_of_day_except_0_and_12 = [ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11 ] in let second_half_of_day = [ 13; 14; 15; 16; 17; 18; 19; 21; 21; 22; 23; 24 ] in (* 1 -> 11 are tested here, simplistically by adding 12 when [meridiem is `PM]. We test ~hr:12 later *) List.iter first_half_of_day_except_0_and_12 ~f:(fun hr -> (* Test X:00:00am, X:00am. amd Xam *) success (test_excluding_noon ~hr ~zeroes:":00:00" ~meridiem:(Some `AM)); success (test_excluding_noon ~hr ~zeroes:":00" ~meridiem:(Some `AM)); success (test_excluding_noon ~hr ~zeroes:"" ~meridiem:(Some `AM)); success (test_excluding_noon ~hr ~zeroes:":00:00" ~meridiem:(Some `AM)); success (test_excluding_noon ~hr ~zeroes:":00" ~meridiem:(Some `PM)); success (test_excluding_noon ~hr ~zeroes:"" ~meridiem:(Some `PM)); (* "11pm" is fine, but "11" is not a valid ofday *) failure (test_excluding_noon ~hr ~zeroes:"" ~meridiem:None)); (* None of hour 13 -> 24 should support AM or PM *) List.iter second_half_of_day ~f:(fun hr -> failure (test_excluding_noon ~zeroes:":00:00" ~hr ~meridiem:(Some `AM)); failure (test_excluding_noon ~zeroes:":00" ~hr ~meridiem:(Some `AM)); failure (test_excluding_noon ~zeroes:"" ~hr ~meridiem:(Some `AM)); failure (test_excluding_noon ~zeroes:":00:00" ~hr ~meridiem:(Some `PM)); failure (test_excluding_noon ~zeroes:":00" ~hr ~meridiem:(Some `PM)); failure (test_excluding_noon ~zeroes:"" ~hr ~meridiem:(Some `PM))); List.iter ([ 0; 12 ] @ first_half_of_day_except_0_and_12 @ second_half_of_day) ~f:(fun hr -> success (test_excluding_noon ~hr ~zeroes:":00:00" ~meridiem:None); success (test_excluding_noon ~hr ~zeroes:":00" ~meridiem:None); failure (test_excluding_noon ~hr ~zeroes:"" ~meridiem:None)); (* Test hour 12 *) assert (create ~hr:12 () = of_string "12:00:00 PM"); assert (create ~hr:0 () = of_string "12:00:00 AM"); (* Can't have a 0'th hour ofday with a meridiem suffix *) failure (fun () -> of_string "00:00:00 AM"); failure (fun () -> of_string "00:00:00 PM") ;; let%test "of_string_iso8601_extended supports leap seconds" = let last_second = create ~hr:21 () in List.for_all ~f:(fun s -> equal (of_string_iso8601_extended s) last_second) [ "20:59:60"; "20:59:60.500"; "20:59:60.000" ] ;; let%test "of_string_iso8601_extended doesn't support two leap seconds" = Exn.does_raise (fun () -> of_string_iso8601_extended "23:59:61") ;; let%test _ = Set.equal (Set.of_list [ start_of_day ]) (Set.t_of_sexp (Sexp.List [ Float.sexp_of_t (Time.Span.to_sec (to_span_since_start_of_day start_of_day)) ])) ;; end module _ = struct open! Time.Span module _ = struct open! Time.Stable.Span let%test_module "Span.V1" = (module Stable_unit_test.Make (struct include V1 let equal t1 t2 = Int.( = ) 0 (compare t1 t2) let tests = let span = of_sec in [ span 99e-12, "9.9e-08ms", "\018\006\211\115\129\054\219\061" ; span 1.2e-9, "1.2e-06ms", "\076\206\097\227\167\157\020\062" ; span 0.000001, "0.001ms", "\141\237\181\160\247\198\176\062" ; span 0.707, "707ms", "\057\180\200\118\190\159\230\063" ; span 42., "42s", "\000\000\000\000\000\000\069\064" ; span 1234.56, "20.576m", "\010\215\163\112\061\074\147\064" ; span 39_996., "11.11h", "\000\000\000\000\128\135\227\064" ; span 80000006.4, "925.926d", "\154\153\153\025\208\018\147\065" ] ;; end)) ;; let%test_module "Span.V2" = (module Stable_unit_test.Make (struct include V2 let equal t1 t2 = Int.( = ) 0 (compare t1 t2) let tests = let span = of_sec in [ span 99e-12, "0.098999999999999991ns", "\018\006\211\115\129\054\219\061" ; span 1.2e-9, "1.2ns", "\076\206\097\227\167\157\020\062" ; span 0.000001, "1us", "\141\237\181\160\247\198\176\062" ; span 0.707, "707ms", "\057\180\200\118\190\159\230\063" ; span 42., "42s", "\000\000\000\000\000\000\069\064" ; span 1234.56, "20.576m", "\010\215\163\112\061\074\147\064" ; span 39_996., "11.11h", "\000\000\000\000\128\135\227\064" ; span 80000006.4, "925.926d", "\154\153\153\025\208\018\147\065" ] ;; end)) ;; end module _ = struct let%expect_test "Unit_of_time.all order" = print_s [%sexp (Unit_of_time.all : Unit_of_time.t list)]; [%expect {| (Nanosecond Microsecond Millisecond Second Minute Hour Day) |}] ;; let%test_unit "units of time all parse" = let module Private = Core_private.Span_float.Private in List.iter Unit_of_time.all ~f:(fun unit_of_time -> let s = sprintf "1%s2" (Private.suffix_of_unit_of_time unit_of_time) in [%test_result: Unit_of_time.t] (Private.parse_suffix s ~index:1) ~expect:unit_of_time) ;; end let%expect_test ("^? is useful" [@tags "64-bits-only"]) = let open Int.O in let show_allocation f = let minor1 = Gc.minor_words () in let major1 = Gc.major_words () in let result = (Sys.opaque_identity f) () in let minor2 = Gc.minor_words () in let major2 = Gc.major_words () in if minor2 > minor1 || major2 > major1 then print_endline "allocates" else print_endline "does not allocate"; Sys.opaque_identity result in let empty = Sys.opaque_identity "" in let hello = Sys.opaque_identity "hello" in ignore (show_allocation (fun () -> empty ^ hello) : string); [%expect {| allocates |}]; ignore (show_allocation (fun () -> hello ^ empty) : string); [%expect {| allocates |}] ;; let%test_unit "Span.to_string_hum" = [%test_result: string] (to_string_hum nanosecond) ~expect:"1ns"; [%test_result: string] (to_string_hum day) ~expect:"1d"; [%test_result: string] (to_string_hum ~decimals:6 day) ~expect:"1d"; [%test_result: string] (to_string_hum ~decimals:6 ~align_decimal:false day) ~expect:"1d"; [%test_result: string] (to_string_hum ~decimals:6 ~align_decimal:true day) ~expect:"1.000000d "; [%test_result: string] (to_string_hum ~decimals:6 ~align_decimal:true ~unit_of_time:Day (hour + minute)) ~expect:"0.042361d " ;; let%test _ = Set.equal (Set.of_list [ hour ]) (Set.t_of_sexp (Sexp.List [ Float.sexp_of_t (to_sec hour) ])) ;; (* We should be robustly equal within a microsecond *) let%test _ = zero =. microsecond let%test _ = not (zero =. of_ns 1001.0) end let%expect_test "times with implicit zones" = let test f = show_raise (fun () -> print_endline (Time.to_string_utc (f ()))) in test (fun () -> Time.Stable.With_utc_sexp.V2.t_of_sexp (Sexp.of_string "(2013-10-07 09:30)")); [%expect {| 2013-10-07 09:30:00.000000Z "did not raise" |}]; require_does_raise [%here] (fun () -> Time.of_string_with_utc_offset "2013-10-07 09:30"); [%expect {| (time.ml.Make.Time_of_string "2013-10-07 09:30" ("time has no time zone or UTC offset" "2013-10-07 09:30")) |}] ;; let%expect_test "quickcheck should generate serializable times" = require_does_not_raise [%here] (fun () -> quickcheck_m [%here] (module struct type t = Time.t [@@deriving quickcheck] let sexp_of_t = Time.Stable.With_utc_sexp.V2.sexp_of_t end) ~f:(fun time -> let sexp = Time.Stable.With_utc_sexp.V2.sexp_of_t time in let round_trip = Time.Stable.With_utc_sexp.V2.t_of_sexp sexp in (* We aren't checking precision of round-trips, just that it doesn't raise. *) ignore (round_trip : Time.t))); [%expect {| |}] ;; let%expect_test "regression test: [to_ofday] never returns 24:00" = let zone = Time.Zone.utc in quickcheck_m ~cr:CR_soon [%here] (module struct include Time.Stable.With_utc_sexp.V2 let quickcheck_generator = Time.quickcheck_generator let quickcheck_shrinker = Time.quickcheck_shrinker end) ~f:(fun time -> let ofday = Time.to_ofday time ~zone in [%test_pred: Time.Ofday.t] (fun ofday -> Time.Ofday.( < ) ofday Time.Ofday.start_of_next_day) ofday); [%expect {| |}] ;; core-0.15.0/core/test/src/test_time.mli000066400000000000000000000000551420273305200177210ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_time_ns.ml000066400000000000000000001224751420273305200202630ustar00rootroot00000000000000open! Core open Expect_test_helpers_core type time_ns = Time_ns.t [@@deriving compare] let sexp_of_time_ns = Time_ns.Alternate_sexp.sexp_of_t let quickcheck_generator = let open Quickcheck.Generator.Let_syntax in let%map ns_since_epoch = Int63.gen_incl (Time_ns.to_int63_ns_since_epoch Time_ns.min_value_for_1us_rounding) (Time_ns.to_int63_ns_since_epoch Time_ns.max_value_for_1us_rounding) in Time_ns.of_int63_ns_since_epoch ns_since_epoch ;; let randomly_round quickcheck_generator = let open Quickcheck.Generator.Let_syntax in let%bind time_ns = quickcheck_generator in let%map unit = Quickcheck.Generator.of_list [ Time_ns.Span.second ; Time_ns.Span.of_int_ms 100 ; Time_ns.Span.of_int_ms 10 ; Time_ns.Span.millisecond ; Time_ns.Span.of_int_us 100 ; Time_ns.Span.of_int_us 10 ; Time_ns.Span.microsecond ; Time_ns.Span.of_int63_ns (Int63.of_int 100) ; Time_ns.Span.of_int63_ns (Int63.of_int 10) ; Time_ns.Span.nanosecond ] in let span_ns = Time_ns.to_span_since_epoch time_ns in let rounded_span_ns = Time_ns.Span.scale_int63 unit (Time_ns.Span.div span_ns unit) in Time_ns.of_span_since_epoch rounded_span_ns ;; let quickcheck here quickcheck_generator f = require_does_not_raise here (fun () -> Quickcheck.test quickcheck_generator ~f ~sexp_of:[%sexp_of: time_ns] ~examples: [ Time_ns.min_value_for_1us_rounding ; Time_ns.epoch ; Time_ns.max_value_for_1us_rounding ]) ;; let%test_module "Time_ns.Alternate_sexp" = (module struct module Span = Time_ns.Span let epoch_date = Date.create_exn ~y:1970 ~m:Jan ~d:1 let make ?(h = 0) ?(m = 0) ?(s = 0) ?(ms = 0) ?(us = 0) ?(ns = 0) date = let d = Date.diff (Date.of_string date) epoch_date in let spans = [ Span.scale_int Span.day d ; Span.scale_int Span.hour h ; Span.scale_int Span.minute m ; Span.scale_int Span.second s ; Span.scale_int Span.millisecond ms ; Span.scale_int Span.microsecond us ; Span.scale_int Span.nanosecond ns ] in let span = List.fold ~init:Span.zero ~f:Span.( + ) spans in Time_ns.of_span_since_epoch span ;; let%expect_test "sexp format" = let examples = [ Time_ns.min_value_for_1us_rounding ; Time_ns.max_value_for_1us_rounding ; Time_ns.epoch ; make "2001-01-01" ; make "2001-01-01" ~h:16 ~m:23 ~s:42 ; make "2013-10-07" ~h:09 ~m:14 ~s:47 ~ms:999 ~us:749 ~ns:999 ; make "2013-10-07" ~h:09 ~m:14 ~s:47 ~ms:999 ~us:750 ~ns:000 ; make "2013-10-07" ~h:09 ~m:14 ~s:47 ~ms:999 ~us:750 ~ns:001 ] in List.iter examples ~f:(fun time_ns -> print_s [%sexp (time_ns : Time_ns.Alternate_sexp.t)]; let round_trip = Time_ns.Alternate_sexp.t_of_sexp (Time_ns.Alternate_sexp.sexp_of_t time_ns) in require [%here] (Time_ns.equal time_ns round_trip) ~if_false_then_print_s: (lazy [%message "Time_ns.Alternate_sexp round-trip failed" (time_ns : time_ns) (round_trip : time_ns)])); [%expect {| "1835-02-03 00:00:00Z" "2104-11-29 00:00:00Z" "1970-01-01 00:00:00Z" "2001-01-01 00:00:00Z" "2001-01-01 16:23:42Z" "2013-10-07 09:14:47.999749999Z" "2013-10-07 09:14:47.99975Z" "2013-10-07 09:14:47.999750001Z" |}] ;; let%expect_test "round-trip" = (* randomly round spans to make sure we round-trip at various precisions, since it affects number of decimal places *) quickcheck [%here] (randomly_round quickcheck_generator) (fun time_ns -> [%test_result: time_ns] (Time_ns.Alternate_sexp.t_of_sexp (Time_ns.Alternate_sexp.sexp_of_t time_ns)) ~expect:time_ns); [%expect {| |}] ;; end) ;; let%test_module "Time_ns.Utc.to_date_and_span_since_start_of_day" = (module struct let%expect_test "span is non-negative and less than 1 day" = quickcheck [%here] quickcheck_generator (fun time_ns -> let date, span_since_start_of_day = Core.Time_ns.Utc.to_date_and_span_since_start_of_day time_ns in if Time_ns.Span.( < ) span_since_start_of_day Time_ns.Span.zero || Time_ns.Span.( >= ) span_since_start_of_day Time_ns.Span.day then raise_s [%message "span_since_start_of_day is out of bounds" (time_ns : time_ns) (date : Date.t) (span_since_start_of_day : Time_ns.Span.t)]); [%expect {| |}] ;; let%expect_test "round-trip" = quickcheck [%here] quickcheck_generator (fun time_ns -> let date, span_since_start_of_day = Core.Time_ns.Utc.to_date_and_span_since_start_of_day time_ns in let round_trip_time_ns = Time_ns.Utc.of_date_and_span_since_start_of_day date span_since_start_of_day in [%test_result: time_ns] round_trip_time_ns ~expect:time_ns); [%expect {| |}] ;; end) ;; let succ time_ns = time_ns |> Time_ns.to_int63_ns_since_epoch |> Int63.succ |> Time_ns.of_int63_ns_since_epoch ;; let pred time_ns = time_ns |> Time_ns.to_int63_ns_since_epoch |> Int63.pred |> Time_ns.of_int63_ns_since_epoch ;; let%expect_test "Stable.Alternate_sexp.V1" = print_and_check_stable_type [%here] (module Time_ns.Stable.Alternate_sexp.V1) [ Time_ns.min_value_for_1us_rounding ; Time_ns.min_value_for_1us_rounding |> succ ; Time_ns.min_value_for_1us_rounding |> succ |> succ ; Time_ns.epoch |> pred ; Time_ns.epoch ; Time_ns.epoch |> succ ; Time_ns.of_int63_ns_since_epoch (Int63.of_int64_exn 999_999_999_999_999_999L) ; Time_ns.of_int63_ns_since_epoch (Int63.of_int64_exn 1_000_000_000_000_000_000L) ; Time_ns.of_int63_ns_since_epoch (Int63.of_int64_exn 1_000_000_000_000_000_001L) ; Time_ns.max_value_for_1us_rounding |> pred |> pred ; Time_ns.max_value_for_1us_rounding |> pred ; Time_ns.max_value_for_1us_rounding ]; [%expect {| (bin_shape_digest 2b528f4b22f08e28876ffe0239315ac2) ((sexp "1835-02-03 00:00:00Z") (bin_io "\252\000\000\011\239\162\209\234\196")) ((sexp "1835-02-03 00:00:00.000000001Z") (bin_io "\252\001\000\011\239\162\209\234\196")) ((sexp "1835-02-03 00:00:00.000000002Z") (bin_io "\252\002\000\011\239\162\209\234\196")) ((sexp "1969-12-31 23:59:59.999999999Z") (bin_io "\255\255")) ((sexp "1970-01-01 00:00:00Z") (bin_io "\000")) ((sexp "1970-01-01 00:00:00.000000001Z") (bin_io "\001")) ((sexp "2001-09-09 01:46:39.999999999Z") (bin_io "\252\255\255c\167\179\182\224\r")) ((sexp "2001-09-09 01:46:40Z") (bin_io "\252\000\000d\167\179\182\224\r")) ((sexp "2001-09-09 01:46:40.000000001Z") (bin_io "\252\001\000d\167\179\182\224\r")) ((sexp "2104-11-28 23:59:59.999999998Z") (bin_io "\252\254\255\244\016].\021;")) ((sexp "2104-11-28 23:59:59.999999999Z") (bin_io "\252\255\255\244\016].\021;")) ((sexp "2104-11-29 00:00:00Z") (bin_io "\252\000\000\245\016].\021;")) |}] ;; let%test_module "Ofday" = (module struct let%expect_test "of_string_iso8601_extended" = let success string = require_does_not_raise [%here] (fun () -> printf "%s <-- %s\n" (Time_ns.Ofday.to_string (Time_ns.Ofday.of_string_iso8601_extended string)) string) in List.iter ~f:success [ (* normal times *) "12" ; "12:34" ; "12:34:56" ; "12:34:56.789" ; "12:34:56.789123" ; "12:34:56.789123456" ; (* lower boundary case *) "00" ; "00:00" ; "00:00:00" ; "00:00:00.000" ; "00:00:00.000000" ; "00:00:00.000000000" ; (* upper boundary case *) "23" ; "23:59" ; "23:59:59" ; "23:59:59.999" ; "23:59:59.999999" ; "23:59:59.999999999" ; (* midnight tomorrow *) "24" ; "24:00" ; "24:00:00" ; "24:00:00.000" ; "24:00:00.000000" ; "24:00:00.000000000" ; (* leap second *) "12:59:60" ; "12:59:60.789" ; "12:59:60.789123" ; "12:59:60.789123456" ]; [%expect {| 12:00:00.000000000 <-- 12 12:34:00.000000000 <-- 12:34 12:34:56.000000000 <-- 12:34:56 12:34:56.789000000 <-- 12:34:56.789 12:34:56.789123000 <-- 12:34:56.789123 12:34:56.789123456 <-- 12:34:56.789123456 00:00:00.000000000 <-- 00 00:00:00.000000000 <-- 00:00 00:00:00.000000000 <-- 00:00:00 00:00:00.000000000 <-- 00:00:00.000 00:00:00.000000000 <-- 00:00:00.000000 00:00:00.000000000 <-- 00:00:00.000000000 23:00:00.000000000 <-- 23 23:59:00.000000000 <-- 23:59 23:59:59.000000000 <-- 23:59:59 23:59:59.999000000 <-- 23:59:59.999 23:59:59.999999000 <-- 23:59:59.999999 23:59:59.999999999 <-- 23:59:59.999999999 24:00:00.000000000 <-- 24 24:00:00.000000000 <-- 24:00 24:00:00.000000000 <-- 24:00:00 24:00:00.000000000 <-- 24:00:00.000 24:00:00.000000000 <-- 24:00:00.000000 24:00:00.000000000 <-- 24:00:00.000000000 13:00:00.000000000 <-- 12:59:60 13:00:00.000000000 <-- 12:59:60.789 13:00:00.000000000 <-- 12:59:60.789123 13:00:00.000000000 <-- 12:59:60.789123456 |}]; let failure string = match Time_ns.Ofday.of_string_iso8601_extended string with | exception exn -> print_endline (Exn.to_string exn) | ofday -> print_cr [%here] [%message "did not raise" (string : string) (ofday : Time_ns.Ofday.t)] in List.iter ~f:failure [ (* bad syntax *) "" ; "1" ; "123" ; ":" ; "12:" ; "1:23" ; "12:3" ; "12:345" ; "12:34:" ; "12:34:5" ; (* numerical bounds *) "25:00" ; "00:60" ; "00:59:61" ]; [%expect {| ("Time_ns.Ofday.of_string_iso8601_extended: cannot parse string" "" (Failure "len < 2")) ("Time_ns.Ofday.of_string_iso8601_extended: cannot parse string" 1 (Failure "len < 2")) ("Time_ns.Ofday.of_string_iso8601_extended: cannot parse string" 123 (Failure "2 < len < 5")) ("Time_ns.Ofday.of_string_iso8601_extended: cannot parse string" : (Failure "len < 2")) ("Time_ns.Ofday.of_string_iso8601_extended: cannot parse string" 12: (Failure "2 < len < 5")) ("Time_ns.Ofday.of_string_iso8601_extended: cannot parse string" 1:23 (Failure "Char.get_digit_exn ':': not a digit")) ("Time_ns.Ofday.of_string_iso8601_extended: cannot parse string" 12:3 (Failure "2 < len < 5")) ("Time_ns.Ofday.of_string_iso8601_extended: cannot parse string" 12:345 (Failure "5 < len < 8")) ("Time_ns.Ofday.of_string_iso8601_extended: cannot parse string" 12:34: (Failure "5 < len < 8")) ("Time_ns.Ofday.of_string_iso8601_extended: cannot parse string" 12:34:5 (Failure "5 < len < 8")) ("Time_ns.Ofday.of_string_iso8601_extended: cannot parse string" 25:00 (Failure "hour > 24")) ("Time_ns.Ofday.of_string_iso8601_extended: cannot parse string" 00:60 (Failure "minute > 60")) ("Time_ns.Ofday.of_string_iso8601_extended: cannot parse string" 00:59:61 (Failure "invalid second: 61")) |}] ;; let%expect_test "every" = let open Time_ns in let test ?(verbose = true) span start stop = let result = Ofday.every span ~start ~stop in if verbose then print_s [%sexp (result : Ofday.t list Or_error.t)]; let crossed_bounds = Ofday.( > ) start stop in let non_positive_span = Span.( <= ) span Span.zero in let should_be_error = crossed_bounds || non_positive_span in match result with | Error _ -> require [%here] should_be_error ~if_false_then_print_s: (lazy [%message "should have produced Ok" (crossed_bounds : bool) (non_positive_span : bool)]) | Ok list -> require [%here] (not should_be_error) ~if_false_then_print_s: (lazy [%message "should have produced Error" (crossed_bounds : bool) (non_positive_span : bool)]); require [%here] (List.is_sorted list ~compare:Ofday.compare) ~if_false_then_print_s:(lazy [%message "not sorted"]); require [%here] (List.for_all list ~f:(fun ofday -> Ofday.( >= ) ofday start && Ofday.( <= ) ofday stop)) ~if_false_then_print_s:(lazy [%message "exceeds bounds"]) in let hour = Span.hour in let ten_min = Span.of_min 10.0 in let sod = Ofday.start_of_day in let eod = Ofday.approximate_end_of_day in test hour eod sod; [%expect {| (Error ( "[Time_ns.Ofday.every] called with [start] > [stop]" (start 23:59:59.999999999) (stop 00:00:00.000000000))) |}]; test hour sod eod; [%expect {| (Ok ( 00:00:00.000000000 01:00:00.000000000 02:00:00.000000000 03:00:00.000000000 04:00:00.000000000 05:00:00.000000000 06:00:00.000000000 07:00:00.000000000 08:00:00.000000000 09:00:00.000000000 10:00:00.000000000 11:00:00.000000000 12:00:00.000000000 13:00:00.000000000 14:00:00.000000000 15:00:00.000000000 16:00:00.000000000 17:00:00.000000000 18:00:00.000000000 19:00:00.000000000 20:00:00.000000000 21:00:00.000000000 22:00:00.000000000 23:00:00.000000000)) |}]; test ten_min sod (Ofday.of_string "00:20"); [%expect {| (Ok (00:00:00.000000000 00:10:00.000000000 00:20:00.000000000)) |}]; test ten_min sod (Ofday.of_string "00:25"); [%expect {| (Ok (00:00:00.000000000 00:10:00.000000000 00:20:00.000000000)) |}]; test hour sod (Ofday.of_string "00:25"); [%expect {| (Ok (00:00:00.000000000)) |}]; test hour sod sod; [%expect {| (Ok (00:00:00.000000000)) |}]; test (Span.of_hr 25.) sod eod; [%expect {| (Ok (00:00:00.000000000)) |}]; test Span.max_value_representable sod eod; [%expect {| (Ok (00:00:00.000000000)) |}]; test Span.min_value_representable sod eod; [%expect {| (Error ( "[Time_ns.Ofday.every] called with negative span" -53375d23h53m38.427387904s)) |}]; let span_gen = (* avoid intervals so small we generate, e.g., millions of values *) Quickcheck.Generator.filter Span.quickcheck_generator ~f:(fun span -> Span.( >= ) (Span.abs span) Span.second) in Expect_test_helpers_base.quickcheck [%here] [%quickcheck.generator: [%custom span_gen] * Ofday.t * Ofday.t] ~sexp_of:[%sexp_of: Span.t * Ofday.t * Ofday.t] ~f:(fun (span, start, stop) -> test ~verbose:false span start stop); [%expect {| |}] ;; end) ;; module _ = struct open! Time_ns.Span let%test (_ [@tags "64-bits-only"]) = Int.( > ) (to_int_sec (of_int63_ns Int63.max_value)) 0 ;; (* and doesn't raise *) let%test_module "overflow silently" = (module struct let doesn't_raise = Fn.non Exn.does_raise let%test "+ range up" = doesn't_raise (fun () -> max_value_for_1us_rounding + nanosecond) ;; let%test "+ range down" = doesn't_raise (fun () -> min_value_for_1us_rounding + neg nanosecond) ;; let%test "+ overflow" = doesn't_raise (fun () -> max_value_for_1us_rounding + max_value_for_1us_rounding) ;; let%test "+ underflow" = doesn't_raise (fun () -> min_value_for_1us_rounding + min_value_for_1us_rounding) ;; let%test "- range down" = doesn't_raise (fun () -> min_value_for_1us_rounding - nanosecond) ;; let%test "- range up" = doesn't_raise (fun () -> max_value_for_1us_rounding - neg nanosecond) ;; let%test "- underflow" = doesn't_raise (fun () -> min_value_for_1us_rounding - max_value_for_1us_rounding) ;; let%test "- overflow" = doesn't_raise (fun () -> max_value_for_1us_rounding - min_value_for_1us_rounding) ;; let%test_module "intermediate ( * )" = (module struct let wrap_days = let margin_ns = Int63.( - ) (to_int63_ns min_value_for_1us_rounding) Int63.min_value in Int63.( (max_value / to_int63_ns day) + one + (margin_ns / to_int63_ns day) + one) ;; let%test_unit "wrap_days" = [%test_pred: Int63.t] (Int63.between ~low:(to_int63_ns min_value_for_1us_rounding) ~high:(Int63.neg (to_int63_ns nanosecond))) Int63.(wrap_days * to_int63_ns day) ;; let wrap_days_int = Int63.to_int_exn wrap_days let%test "scale_int63" = doesn't_raise (fun () -> scale_int63 day wrap_days) let%test "scale_int" = doesn't_raise (fun () -> scale_int day wrap_days_int) let%test "create" = doesn't_raise (fun () -> create () ~day:wrap_days_int) end) ;; end) ;; let%test_unit "int63-negative-division-by-positive-truncates-towards-zero" = let open Int63 in assert (of_int (-7) / of_int 4 = of_int (-1)) ;; let%test_module _ = (module struct module Parts = Time_ns.Span.Parts let ( * ) = Int63.( * ) let of_int = Int63.of_int let round_trip t = [%test_result: t] (Private.of_parts (to_parts t)) ~expect:t let eq t expect = [%test_result: t] t ~expect; [%test_result: Parts.t] (to_parts t) ~expect:(to_parts expect); round_trip t ;; let scale (i : int) t = of_int63_ns (of_int i * to_int63_ns t) let%test_unit _ = eq (create ~us:2 ()) (scale 2 microsecond) let%test_unit _ = eq (create ~min:3 ()) (scale 3 minute) let%test_unit _ = eq (create ~ms:4 ()) (scale 4 millisecond) let%test_unit _ = eq (create ~sec:5 ()) (scale 5 second) let%test_unit _ = eq (create ~hr:6 ()) (scale 6 hour) let%test_unit _ = eq (create ~day:7 ()) (scale 7 day) let%test_unit _ = eq (create ~us:8 ~sign:Neg ()) (scale (-8) microsecond) let%test_unit _ = eq (create ~ms:9 ~sign:Zero ()) (scale 9 millisecond) let%test_unit _ = eq (create ~us:3 ~ns:242 () |> to_sec |> of_sec_with_microsecond_precision) (scale 3 microsecond) ;; let%test_unit _ = for _ = 1 to 1_000_000 do let t = of_int63_ns (Int63.of_int64_exn (Random.int64 (Int63.to_int64 Int63.max_value))) + if Random.bool () then zero else min_value_for_1us_rounding in round_trip t done ;; let round_trip parts = [%test_result: Parts.t] (to_parts (Private.of_parts parts)) ~expect:parts ;; let%expect_test _ = print_s [%sexp (to_parts (create ~sign:Neg ~hr:2 ~min:3 ~sec:4 ~ms:5 ~us:6 ~ns:7 ()) : Parts.t)]; [%expect {| ((sign Neg) (hr 2) (min 3) (sec 4) (ms 5) (us 6) (ns 7)) |}] ;; let%test_unit _ = round_trip (to_parts (create ~hr:25 ())) let%test_unit _ = let hr = match Word_size.word_size with | W32 -> Int.max_value | W64 -> Int64.to_int_exn 2217989799822798757L in round_trip (to_parts (create ~hr ())) ;; end) ;; let%test_unit "random smoke" = let state = Random.State.make [||] in for _ = 1 to 1000 do ignore (random ~state () : t) done ;; end open! Time_ns let%test_unit "random smoke" = let state = Random.State.make [||] in for _ = 1 to 1000 do ignore (random ~state () : t) done ;; let%test_module "next_multiple" = (module struct let test can_equal_after interval_ns after_ns = let base = epoch in let interval = Span.of_int63_ns (Int63.of_int interval_ns) in let after = of_int63_ns_since_epoch (Int63.of_int64_exn after_ns) in let result = next_multiple ~can_equal_after ~interval ~base ~after () in let lower_bound, upper_bound = let after_interval = add after interval in if can_equal_after then after, sub after_interval Span.nanosecond else add after Span.nanosecond, after_interval in if result < lower_bound || result > upper_bound then raise_s [%message "result out of bounds" (can_equal_after : bool) (interval : Span.t) (base : Alternate_sexp.t) (after : Alternate_sexp.t) (result : Alternate_sexp.t) (lower_bound : Alternate_sexp.t) (upper_bound : Alternate_sexp.t)] ;; (* The below tests all failed in a previous implementation of [next_multiple], due to the use of floating point division rather than integer division. *) let%test_unit _ = test true 71 1666750235549516973L let%test_unit _ = test true 4398 1232807081547132235L let%test_unit _ = test false 702561 1233263206897519979L let%test_unit _ = test true 65 1813146216102385742L let%test_unit _ = test false 3376 1430224273339105389L let%test_unit _ = test true 25 1289744875932860592L let%test_unit _ = test true 2640 1289026286379471964L let%test_unit _ = test true 7062861 1582734990009845838L let%test_unit _ = test false 26123810 1509919129138733390L let%test_unit _ = test false 1076 1514456253942665045L let%test_unit _ = test false 47873597 1567592770350241609L let%test_unit _ = test true 147 1794365064173405211L let%test_unit _ = test true 37416 1703355717287748172L let%test_unit _ = test false 11 1627963384978464309L let%test_unit _ = test true 362857 1477941666514490237L let%test_unit _ = test true 74 1835379421104268809L let%test_unit _ = test false 95 1518869409078948499L let%test_unit _ = test false 152 1774086601023993329L let%test_unit _ = test true 2963474 1177784542849146405L let%test_unit _ = test false 30 1322037015396216447L let%test_unit _ = test true 25 1686952462277171285L let%test_unit _ = test false 77747994 1232530693599997021L let%test_unit _ = test true 39 1418422346766901525L let%test_unit _ = test true 20 1164906391254697606L let%test_unit _ = test false 492686918 1350478871564364650L let%test_unit _ = test false 5626939 1254841457643911520L let%test_unit _ = test true 1189147 1566503665916540724L let%test_unit _ = test false 97968678 1202922821174442071L let%test_unit _ = test false 20 1241457243504201837L let%test_unit _ = test true 99 1063228554057138547L let%test_unit _ = test true 73 1127965283765790199L let%test_unit _ = test true 92513 1423525486630794877L let%test_unit _ = test true 208946207 1512896538257529954L let%test_unit _ = test true 558 1304902428047905868L let%test_unit _ = test true 27 1454760325484042946L let%test_unit _ = test true 9511417 1224625971869008380L let%test_unit _ = test true 1112121 1486628785456556405L let%test_unit _ = test true 36 1226843097592112449L let%test_unit _ = test true 60 1299700152825201828L let%test_unit _ = test true 114032 1507179377240642938L let%test_unit _ = test true 27905 1379112115218849615L let%test_unit _ = test true 368860702 1318925554630500136L let%test_unit _ = test true 1636 1670399627434728314L let%test_unit _ = test false 27 1735798120119522136L let%test_unit _ = test true 14 1880325938102084694L let%test_unit _ = test true 155 1488215974636830525L let%test_unit _ = test true 14319914 1298824542911254370L let%test_unit _ = test true 94 1961333441294309841L let%test_unit _ = test true 321 1191344461619096942L let%test_unit _ = test true 706626 1179098309603309142L let%test_unit _ = test true 5 1180517413083401326L let%test_unit _ = test false 30523434 1471069600394063742L let%test_unit _ = test false 106875447 1789919428848820069L let%test_unit _ = test true 28 1013606888178097611L let%test_unit _ = test true 5178 1168893256723816286L let%test_unit _ = test true 146907740 1402240657577530746L let%test_unit _ = test true 127125596 1332881548503325287L let%test_unit _ = test true 46691 1526532096462597222L let%test_unit _ = test true 1603 1745157292595832416L let%test_unit _ = test true 141650492 1779813912846436672L let%test_unit _ = test false 20 1916060142837991511L let%test_unit _ = test false 27 1366845916494697310L let%test_unit _ = test true 61 1572832513125636690L let%test_unit _ = test false 11254 1301465801253970270L let%test_unit _ = test true 2817556 1220217790200673585L let%test_unit _ = test true 46399240 1371834303096963699L let%test_unit _ = test true 10280275 1199022106578060117L let%test_unit _ = test true 163667 1277585249492511350L let%test_unit _ = test true 441771131 1865810978398941565L let%test_unit _ = test true 22561070 1535418639166874210L let%test_unit _ = test true 677456 1356038574036607058L let%test_unit _ = test true 109 1102385187927169659L let%test_unit _ = test true 169 1592923082707947954L let%test_unit _ = test false 2150725 1769663126416348286L let%test_unit _ = test true 159 1051696934142612937L let%test_unit _ = test true 29 1844613926625333568L let%test_unit _ = test true 30 1361000119652263049L let%test_unit _ = test false 21058 1323116357214603127L let%test_unit _ = test true 1163794 1221604356987291502L let%test_unit _ = test false 30 1040042732593079852L let%test_unit _ = test false 106 1997585750801910583L let%test_unit _ = test true 78 1292467707712256145L let%test_unit _ = test false 882992 1557796972319309155L let%test_unit _ = test false 1821 1973683565069601822L let%test_unit _ = test false 34661 1737515124214074993L let%test_unit _ = test true 91661 1525765679206225703L let%test_unit _ = test false 55 1287656410542943084L let%test_unit _ = test true 25 1144756873630117512L let%test_unit _ = test true 121625 1374589039260879728L let%test_unit _ = test false 55 1970197704905173942L let%test_unit _ = test true 17 1013158341065700634L let%test_unit _ = test true 5176 1352936504880492660L let%test_unit _ = test true 12 1955810895023292883L let%test_unit _ = test true 67034967 1556142079069258330L let%test_unit _ = test true 690258 1241013338154557567L let%test_unit _ = test false 5606142 1356689387566170970L let%test_unit _ = test true 548 1613807159903275820L let%test_unit _ = test true 13 1425941806049471918L let%test_unit _ = test false 155572024 1398827221896378979L let%test_unit _ = test true 938925403 1550277848520025471L let%test_unit _ = test false 13058335 1306567871862304618L let%test_unit _ = test true 2 1997152439817382933L let%test_unit _ = test true 131456077 1809241097498435420L let%test_unit _ = test true 5 1531223674910420761L let%test_unit _ = test false 1125 1175905228832358761L let%test_unit _ = test true 350 1573261556955534963L let%test_unit _ = test false 21 1529314545697532312L let%test_unit _ = test false 11816 1222083468556908088L let%test_unit _ = test true 86085 1436391155125371248L let%test_unit _ = test true 75063667 1395675403046737786L let%test_unit _ = test false 67 1765632860861960357L let%test_unit _ = test false 184086 1232986716459688821L let%test_unit _ = test true 53 1643034916467763402L let%test_unit _ = test true 164 1931973285029689763L let%test_unit _ = test true 10 1317304422397637720L let%test_unit _ = test true 12566 1421417764422298993L let%test_unit _ = test true 122903121 1389456412090860886L let%test_unit _ = test false 3831308 1617363073756443917L let%test_unit _ = test true 2274 1256309428080267889L let%test_unit _ = test true 69 1975893988922224788L let%test_unit _ = test true 460408083 1956390486383825465L let%test_unit _ = test true 20 1294502403828905377L let%test_unit _ = test true 75279 1210517500455430679L let%test_unit _ = test false 335 1184433858378833746L let%test_unit _ = test false 94523 1420732229891051641L let%test_unit _ = test false 16 1310464979299616987L let%test_unit _ = test true 5886 1602668327390189086L let%test_unit _ = test false 9584 1532134444641007990L let%test_unit _ = test true 17 1362463965931411147L let%test_unit _ = test false 2 1693027090042722358L let%test_unit _ = test false 228135731 1462077890315132778L let%test_unit _ = test false 11 1018644923234572949L let%test_unit _ = test false 132723 1582399817588675962L let%test_unit _ = test false 3667 1506604922540283994L let%test_unit _ = test true 265541944 1695560402922008138L let%test_unit _ = test true 310 1875190738574556027L let%test_unit _ = test true 8570918 1184809728498232683L let%test_unit _ = test false 16536379 1490415593503829866L let%test_unit _ = test false 32222516 1519021258420540539L let%test_unit _ = test true 152467451 1255624172539661165L let%test_unit _ = test true 13 1803425272409148050L let%test_unit _ = test true 26 1021777264383583552L let%test_unit _ = test true 11 1400486869768403422L let%test_unit _ = test true 229637 1410589173350489612L let%test_unit _ = test true 32 1960302290555348647L let%test_unit _ = test false 349881185 1831970413297175407L let%test_unit _ = test false 35457345 1967569813691929674L let%test_unit _ = test false 16 1556051447243676249L let%test_unit _ = test false 302933078 1816140399596962652L let%test_unit _ = test true 3609444 1802393395129668217L end) ;; let%expect_test "times with implicit zones" = require_does_raise [%here] (fun () -> Time_ns.Stable.Alternate_sexp.V1.t_of_sexp (Sexp.Atom "2013-10-07 09:30:00")); [%expect {| (Of_sexp_error (Invalid_argument "String.chop_suffix_exn \"09:30:00\" \"Z\"") (invalid_sexp "2013-10-07 09:30:00")) |}]; require_does_raise [%here] (fun () -> Time_ns.Alternate_sexp.t_of_sexp (Sexp.Atom "2013-10-07 09:30:00")); [%expect {| (Of_sexp_error (Invalid_argument "String.chop_suffix_exn \"09:30:00\" \"Z\"") (invalid_sexp "2013-10-07 09:30:00")) |}] ;; let%expect_test "to_string" = print_endline (Time_ns.to_string_utc (Time_ns.of_int63_ns_since_epoch (Int63.of_int64_exn 1_234_567_890_123_456_789L))); [%expect {| 2009-02-13 23:31:30.123456789Z |}] ;; let%expect_test "Ofday.to_microsecond_string" = let round ofday = ofday |> Time_ns.Ofday.to_span_since_start_of_day |> Time_ns.Span.to_int63_ns |> Int63.round_down ~to_multiple_of:(Int63.of_int 1000) |> Time_ns.Span.of_int63_ns |> Time_ns.Ofday.of_span_since_start_of_day_exn in [ Time_ns.Ofday.start_of_day ; Time_ns.Ofday.start_of_day |> Time_ns.Ofday.next |> Core.Option.value_exn ; Time_ns.Ofday.approximate_end_of_day ; Time_ns.Ofday.start_of_next_day ] |> List.iter ~f:(fun ofday -> let string = Time_ns.Ofday.to_microsecond_string ofday in print_endline string; require_equal [%here] (module Time_ns.Ofday) (Time_ns.Ofday.of_string string) (round ofday)); [%expect {| 00:00:00.000000 00:00:00.000000 23:59:59.999999 24:00:00.000000 |}] ;; let%expect_test "to_sec_string[_with_zone]" = let time = Time_ns.add Time_ns.epoch (Time_ns.Span.of_int_ms 1234) in let zones = List.map [ -5; -1; 0; 1; 8 ] ~f:(fun offset -> Core_private.Time_zone.of_utc_offset ~hours:offset) in List.iter zones ~f:(fun zone -> to_sec_string time ~zone |> print_endline); [%expect {| 1969-12-31 19:00:01 1969-12-31 23:00:01 1970-01-01 00:00:01 1970-01-01 01:00:01 1970-01-01 08:00:01 |}]; List.iter zones ~f:(fun zone -> to_sec_string_with_zone time ~zone |> print_endline); [%expect {| 1969-12-31 19:00:01-05:00 1969-12-31 23:00:01-01:00 1970-01-01 00:00:01Z 1970-01-01 01:00:01+01:00 1970-01-01 08:00:01+08:00 |}] ;; let%expect_test "time zone offset parsing" = let test string = print_endline (Time_ns.to_string_utc (Time_ns.of_string_with_utc_offset string)) in test "2000-01-01 12:34:56.789012345-00:00"; test "2000-01-01 12:34:56.789012345-0:00"; test "2000-01-01 12:34:56.789012345-00"; test "2000-01-01 12:34:56.789012345-0"; [%expect {| 2000-01-01 12:34:56.789012345Z 2000-01-01 12:34:56.789012345Z 2000-01-01 12:34:56.789012345Z 2000-01-01 12:34:56.789012345Z |}]; test "2000-01-01 12:34:56.789012345-05:00"; test "2000-01-01 12:34:56.789012345-5:00"; test "2000-01-01 12:34:56.789012345-05"; test "2000-01-01 12:34:56.789012345-5"; [%expect {| 2000-01-01 17:34:56.789012345Z 2000-01-01 17:34:56.789012345Z 2000-01-01 17:34:56.789012345Z 2000-01-01 17:34:56.789012345Z |}]; test "2000-01-01 12:34:56.789012345-23:00"; test "2000-01-01 12:34:56.789012345-23"; [%expect {| 2000-01-02 11:34:56.789012345Z 2000-01-02 11:34:56.789012345Z |}]; test "2000-01-01 12:34:56.789012345-24:00"; test "2000-01-01 12:34:56.789012345-24"; [%expect {| 2000-01-02 12:34:56.789012345Z 2000-01-02 12:34:56.789012345Z |}] ;; let%expect_test "time zone invalid offset parsing" = let test here string = require_does_raise here (fun () -> Time_ns.of_string_with_utc_offset string) in test [%here] "2000-01-01 12:34:56.789012345-0:"; test [%here] "2000-01-01 12:34:56.789012345-00:"; test [%here] "2000-01-01 12:34:56.789012345-0:0"; test [%here] "2000-01-01 12:34:56.789012345-00:0"; test [%here] "2000-01-01 12:34:56.789012345-:"; test [%here] "2000-01-01 12:34:56.789012345-:00"; test [%here] "2000-01-01 12:34:56.789012345-"; (* yes this says Time.Ofday instead of Time_ns.Ofday, not fixing this (in Ofday_helpers.ml) unless someone cares *) [%expect {| (time_ns.ml.To_and_of_string.Time_ns_of_string "2000-01-01 12:34:56.789012345-0:" ("Time.Ofday: invalid string" 0: "expected colon or am/pm suffix with optional space after minutes")) (time_ns.ml.To_and_of_string.Time_ns_of_string "2000-01-01 12:34:56.789012345-00:" ("Time.Ofday: invalid string" 00: "expected colon or am/pm suffix with optional space after minutes")) (time_ns.ml.To_and_of_string.Time_ns_of_string "2000-01-01 12:34:56.789012345-0:0" ("Time.Ofday: invalid string" 0:0 "expected colon or am/pm suffix with optional space after minutes")) (time_ns.ml.To_and_of_string.Time_ns_of_string "2000-01-01 12:34:56.789012345-00:0" ("Time.Ofday: invalid string" 00:0 "expected colon or am/pm suffix with optional space after minutes")) (time_ns.ml.To_and_of_string.Time_ns_of_string "2000-01-01 12:34:56.789012345-:" (Invalid_argument "index out of bounds")) (time_ns.ml.To_and_of_string.Time_ns_of_string "2000-01-01 12:34:56.789012345-:00" (Failure "Char.get_digit_exn ':': not a digit")) (time_ns.ml.To_and_of_string.Time_ns_of_string "2000-01-01 12:34:56.789012345-" (Invalid_argument "index out of bounds")) |}]; test [%here] "2000-01-01 12:34:56.789012-25:00"; test [%here] "2000-01-01 12:34:56.789012-25"; [%expect {| (time_ns.ml.To_and_of_string.Time_ns_of_string "2000-01-01 12:34:56.789012-25:00" ("Time.Ofday: invalid string" 25:00 "hours out of bounds")) (time_ns.ml.To_and_of_string.Time_ns_of_string "2000-01-01 12:34:56.789012-25" ("Time.Ofday: invalid string" 25:00 "hours out of bounds")) |}]; test [%here] "2000-01-01 12:34:56.789012--1:00"; test [%here] "2000-01-01 12:34:56.789012--1"; [%expect {| (time_ns.ml.To_and_of_string.Time_ns_of_string "2000-01-01 12:34:56.789012--1:00" (Failure "Char.get_digit_exn '-': not a digit")) (time_ns.ml.To_and_of_string.Time_ns_of_string "2000-01-01 12:34:56.789012--1" (Invalid_argument "index out of bounds")) |}] ;; let%expect_test "test human comparisons" = let test first_time last_time = let first_time = Time_ns.of_string_with_utc_offset first_time and last_time = Time_ns.of_string_with_utc_offset last_time in print_s [%sexp { is_later = (Time_ns.is_later first_time ~than:last_time : bool) ; is_earlier = (Time_ns.is_earlier first_time ~than:last_time : bool) ; first_time : Time_ns.Alternate_sexp.t ; last_time : Time_ns.Alternate_sexp.t }] in test "2000-01-01T00:00:00.000Z" "2019-01-01T12:00:00.000Z"; test "2000-01-01T00:00:00.000Z" "2000-01-01T00:00:00.000Z"; test "2019-01-01T12:00:00.000Z" "2000-01-01T00:00:00.000Z"; (* cross the epoch *) test "1969-07-20T20:17:40.000Z" "2000-01-01T00:00:00.000Z"; [%expect {| ((is_later false) (is_earlier true) (first_time "2000-01-01 00:00:00Z") (last_time "2019-01-01 12:00:00Z")) ((is_later false) (is_earlier false) (first_time "2000-01-01 00:00:00Z") (last_time "2000-01-01 00:00:00Z")) ((is_later true) (is_earlier false) (first_time "2019-01-01 12:00:00Z") (last_time "2000-01-01 00:00:00Z")) ((is_later false) (is_earlier true) (first_time "1969-07-20 20:17:40Z") (last_time "2000-01-01 00:00:00Z")) |}] ;; let%expect_test "add_saturating" = let test x y = let sum = Time_ns.add x y in let saturating_sum = Time_ns.add_saturating x y in if Time_ns.equal sum saturating_sum then print_s [%message "correct" (sum : Time_ns.Alternate_sexp.t)] else ( let message = if Time_ns.( < ) saturating_sum sum then "underflow" else "overflow" in print_s [%message message (sum : Time_ns.Alternate_sexp.t) (saturating_sum : Time_ns.Alternate_sexp.t)]) in (* no overflow *) test (Time_ns.of_string_with_utc_offset "2018-01-01 00:00:00Z") Time_ns.Span.minute; [%expect {| (correct (sum "2018-01-01 00:01:00Z")) |}]; (* some positive overflows *) test Time_ns.max_value_representable Time_ns.Span.minute; [%expect {| (overflow (sum "1823-11-12 00:07:21.572612095Z") (saturating_sum "2116-02-20 23:53:38.427387903Z")) |}]; test (Time_ns.of_string_with_utc_offset "2018-01-01 00:00:00Z") (Time_ns.Span.of_sec 4_000_000_000.); [%expect {| (overflow (sum "1852-06-24 07:19:23.145224192Z") (saturating_sum "2116-02-20 23:53:38.427387903Z")) |}]; (* and negative overflows *) test Time_ns.min_value_representable Time_ns.Span.(neg minute); [%expect {| (underflow (sum "2116-02-20 23:52:38.427387904Z") (saturating_sum "1823-11-12 00:06:21.572612096Z")) |}]; test (Time_ns.of_string_with_utc_offset "1918-01-01 00:00:00Z") (Time_ns.Span.of_sec (-4_000_000_000.)); [%expect {| (underflow (sum "2083-07-09 16:40:36.854775808Z") (saturating_sum "1823-11-12 00:06:21.572612096Z")) |}] ;; let%expect_test "sub_saturating" = let test x y = let diff = Time_ns.sub x y in let saturating_diff = Time_ns.sub_saturating x y in if Time_ns.equal diff saturating_diff then print_s [%message "correct" (diff : Time_ns.Alternate_sexp.t)] else ( let message = if Time_ns.( < ) saturating_diff diff then "underflow" else "overflow" in print_s [%message message (diff : Time_ns.Alternate_sexp.t) (saturating_diff : Time_ns.Alternate_sexp.t)]) in (* no overflow *) test (Time_ns.of_string_with_utc_offset "2018-01-01 00:00:00Z") Time_ns.Span.minute; [%expect {| (correct (diff "2017-12-31 23:59:00Z")) |}]; (* some negative overflows *) test Time_ns.min_value_representable Time_ns.Span.minute; [%expect {| (underflow (diff "2116-02-20 23:52:38.427387904Z") (saturating_diff "1823-11-12 00:06:21.572612096Z")) |}]; test (Time_ns.of_string_with_utc_offset "1918-01-01 00:00:00Z") (Time_ns.Span.of_sec 4_000_000_000.); [%expect {| (underflow (diff "2083-07-09 16:40:36.854775808Z") (saturating_diff "1823-11-12 00:06:21.572612096Z")) |}]; (* and positive overflows *) test Time_ns.max_value_representable Time_ns.Span.(neg minute); [%expect {| (overflow (diff "1823-11-12 00:07:21.572612095Z") (saturating_diff "2116-02-20 23:53:38.427387903Z")) |}]; test (Time_ns.of_string_with_utc_offset "2018-01-01 00:00:00Z") (Time_ns.Span.of_sec (-4_000_000_000.)); [%expect {| (overflow (diff "1852-06-24 07:19:23.145224192Z") (saturating_diff "2116-02-20 23:53:38.427387903Z")) |}] ;; let%expect_test "[to_ofday] never returns 24:00" = quickcheck_m [%here] (module struct include struct type t = Time_ns.t [@@deriving quickcheck] end include Time_ns.Stable.Alternate_sexp.V1 end) ~f:(fun time -> let ofday = Time_ns.to_ofday time ~zone:Time.Zone.utc in [%test_pred: Time_ns.Ofday.t] (fun ofday -> Time_ns.Ofday.( < ) ofday Time_ns.Ofday.start_of_next_day) ofday) ;; core-0.15.0/core/test/src/test_time_ns.mli000066400000000000000000000000551420273305200204210ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_union_find.ml000066400000000000000000000051231420273305200207430ustar00rootroot00000000000000open! Core open! Import open! Union_find open! Union_find.Private (* invariant checking wrapper functions *) let create x = let t = create x in assert (is_compressed t); t ;; let union t1 t2 = union t1 t2; invariant ignore t1; invariant ignore t2; assert (is_compressed t1 || is_compressed t2) ;; let get t = let x = get t in assert (is_compressed t); x ;; let set t x = set t x; assert (is_compressed t) ;; let same_class t1 t2 = let b = same_class t1 t2 in assert (is_compressed t1); assert (is_compressed t2); b ;; let%test_unit "union" = let a = create 1 in let b = create 2 in assert (not (same_class a b)); union a b; assert (same_class a b); let c = create 3 in assert (not (same_class a c)); assert (not (same_class b c)); union b c; assert (same_class a c); assert (same_class b c); let d = create 1 in let e = create 2 in let f = create 3 in union d e; union d f; assert (same_class d e); assert (same_class d f); assert (same_class e f) ;; let%test_unit "union" = let a = create 1 in let b = create 2 in union a b; let c = create 1 in let d = create 2 in union c d; union b d; assert (same_class a c) ;; let%test_unit "set/get" = let a = create 1 in let b = create 2 in assert (get a = 1); assert (get b = 2); union a b; set a 3; assert (get a = 3); assert (get b = 3) ;; let%test_unit "compressed" = let n = 1000 in let ts = List.init n ~f:create in let t = List.reduce_exn ts ~f:(fun a b -> union a b; b) in let max_rank = List.fold ts ~init:0 ~f:(fun acc t -> max acc (rank t)) in assert (max_rank = 1); set t 42; assert (List.for_all ts ~f:(fun t' -> same_class t t' && get t' = 42)) ;; let%test_unit "balanced" = let log2 n = int_of_float (Float.round_up (log (float_of_int n) /. log 2.)) in let n = 1000 in let ts = Array.init n ~f:create in let rec sub i j = if i = j then ts.(i) else ( let k = (i + j) / 2 in let a = sub i k in if k + 1 > j then a else ( let b = sub (k + 1) j in union a b; a)) in let t = sub 0 (pred n) in Array.iter ts ~f:(invariant ignore); assert (Array.exists ts ~f:(fun t -> not (is_compressed t))); let max_rank = Array.fold ts ~init:0 ~f:(fun acc t -> max acc (rank t)) in assert (max_rank <= log2 n); set t 42; assert (Array.for_all ts ~f:(fun t' -> same_class t t' && get t' = 42)); assert (Array.for_all ts ~f:is_compressed) ;; let%expect_test "[get] of a root does not allocate" = let t = create () in require_no_allocation [%here] (fun () -> get t) ;; core-0.15.0/core/test/src/test_union_find.mli000066400000000000000000000000551420273305200211130ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_unit_of_time.ml000066400000000000000000000007151420273305200212760ustar00rootroot00000000000000open! Core open! Import open! Unit_of_time let%test_unit "Span.Unit_of_time.t" = [%test_result: int] (compare Nanosecond Microsecond) ~expect:(-1); [%test_result: int] (compare Microsecond Millisecond) ~expect:(-1); [%test_result: int] (compare Millisecond Second) ~expect:(-1); [%test_result: int] (compare Second Minute) ~expect:(-1); [%test_result: int] (compare Minute Hour) ~expect:(-1); [%test_result: int] (compare Hour Day) ~expect:(-1) ;; core-0.15.0/core/test/src/test_unit_of_time.mli000066400000000000000000000000551420273305200214440ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_univ_map.ml000066400000000000000000000241011420273305200204260ustar00rootroot00000000000000open! Core open Poly open! Import open! Univ_map let%test_module _ = (module struct let size = Key.create ~name:"size" Int.sexp_of_t let name = Key.create ~name:"name" String.sexp_of_t let foo = Key.create ~name:"foo" Float.sexp_of_t let kids = Key.create ~name:"kids" (List.sexp_of_t sexp_of_t) let%test _ = is_empty empty let test_contains t ~key ~data = assert (not (is_empty t)); assert (mem t key); (* these do not raise *) ignore (change_exn t key ~f:Fn.id : t); ignore (change t key ~f:(function | None -> assert false | o -> o) : t); match find t key with | None -> assert false | Some v' -> assert (phys_equal data v') ;; let test_add t ~key ~data = test_contains (set t ~key ~data) ~key ~data let test_find t key = let f1 = find t key in let f2 = Option.try_with (fun () -> find_exn t key) in match f1, f2 with | None, None -> () | Some v1, Some v2 -> assert (phys_equal v1 v2) | Some _, None -> assert false | None, Some _ -> assert false ;; let test_change t ~key ~data = let t_minus = change t key ~f:(fun _ -> None) in assert (not (mem t_minus key)); let t_plus = change t key ~f:(fun _ -> Some data) in test_contains t_plus ~key ~data; () ;; let test_remove t ~key ~data = let t_minus = remove t key in assert (not (mem t_minus key)); let t_plus = set t ~key ~data in test_contains t_plus ~key ~data; let t_minus = remove t_plus key in assert (not (mem t_minus key)) ;; let test_remove_by_id t ~key ~data = let t_minus = remove_by_id t (Key.uid key) in assert (not (mem t_minus key)); let t_plus = set t ~key ~data in test_contains t_plus ~key ~data; let t_minus = remove_by_id t_plus (Key.uid key) in assert (not (mem t_minus key)) ;; let test t = (* add *) test_add t ~key:size ~data:12; test_add t ~key:name ~data:"hank"; test_add t ~key:kids ~data:[ t; empty ]; (* find *) test_find t size; test_find t name; test_find t kids; (* change *) test_change t ~key:size ~data:33; test_change t ~key:name ~data:"frank"; test_change t ~key:kids ~data:[]; (* remove *) test_remove t ~key:size ~data:33; test_remove t ~key:name ~data:"frank"; test_remove t ~key:kids ~data:[]; (* remove_by_id *) test_remove_by_id t ~key:size ~data:33; test_remove_by_id t ~key:name ~data:"frank"; test_remove_by_id t ~key:kids ~data:[]; () ;; let t0 = empty let t1 = set t0 ~key:size ~data:9 let t2 = set t1 ~key:foo ~data:13.25 let t3 = set t2 ~key:size ~data:15 let%test_unit _ = test t0 let%test_unit _ = test t1 let%test_unit _ = test t2 let%test_unit _ = test t3 let%test _ = sexp_of_t t3 = Sexp.of_string "((foo 13.25)(size 15))" let%expect_test "[to_alist]" = let test ints = let sexps = ints |> List.rev |> List.map ~f:(fun int -> Packed.T ( Type_equal.Id.create ~name:("key" ^ Int.to_string int) [%sexp_of: int] , int )) |> of_alist_exn |> to_alist |> List.map ~f:(fun (Packed.T (type_id, a)) -> let type_id_name = Type_equal.Id.name type_id in let sexp_of_a = Type_equal.Id.to_sexp type_id in [%sexp (type_id_name : string), (a : a)]) in print_s [%sexp (sexps : Sexp.t list)] in test []; [%expect {| () |}]; test [ 1 ]; [%expect {| ((key1 1)) |}]; test [ 1; 2 ]; [%expect {| ((key1 1) (key2 2)) |}]; test [ 1; 2; 3 ]; [%expect {| ((key1 1) (key2 2) (key3 3)) |}] ;; end) ;; let%expect_test "specified key module" = (* incorrect use *) let module Key_incorrect = struct type _ t = | Foo : int t | Bar : string t [@@deriving sexp_of] let type_id (type a) (t : a t) : a Type_equal.Id.t = match t with | Foo -> Type_equal.Id.create ~name:"foo" [%sexp_of: int] | Bar -> Type_equal.Id.create ~name:"bar" [%sexp_of: string] ;; end in let module U_incorrect = Make (Key_incorrect) (struct type 'a t = 'a [@@deriving sexp_of] end) in print_s [%sexp (Or_error.try_with (fun () -> U_incorrect.find (U_incorrect.of_alist_exn [ T (Foo, 3); T (Bar, "three") ]) Foo) : int option Or_error.t)]; [%expect {| (Error ( "[Key.type_id] must not provide different type ids when called on the same input" (key Foo) (type_id1 ((name foo) (uid ))) (type_id2 ((name foo) (uid ))))) |}]; (* correct use *) let module Key_correct = struct type _ t = | Foo : int t | Bar : string t [@@deriving sexp_of] let foo_id = Type_equal.Id.create ~name:"foo" [%sexp_of: int] let bar_id = Type_equal.Id.create ~name:"bar" [%sexp_of: string] let type_id (type a) (t : a t) : a Type_equal.Id.t = match t with | Foo -> foo_id | Bar -> bar_id ;; end in let module U_correct = Make (Key_correct) (struct type 'a t = 'a [@@deriving sexp_of] end) in print_s [%sexp (U_correct.find (U_correct.of_alist_exn [ T (Foo, 3); T (Bar, "three") ]) Foo : int option)]; [%expect {| (3) |}] ;; let%expect_test "merge" = let module Key = struct type _ t = | Foo : int t | Bar : string t | Baz : char t [@@deriving sexp_of] let foo_id = Type_equal.Id.create ~name:"foo" [%sexp_of: int] let bar_id = Type_equal.Id.create ~name:"bar" [%sexp_of: string] let baz_id = Type_equal.Id.create ~name:"baz" [%sexp_of: char] let type_id (type a) (t : a t) : a Type_equal.Id.t = match t with | Foo -> foo_id | Bar -> bar_id | Baz -> baz_id ;; end in let module Input1 = Make (Key) (Option) in let module Input2 = Make (Key) (List) in let module Output_data = struct type 'a t = { key : 'a Key.t ; merge_result : [ `Left of 'a option | `Right of 'a list | `Both of 'a option * 'a list ] } [@@deriving sexp_of] end in let module Output = Make (Key) (Output_data) in let module Merge = Merge (Key) (Option) (List) (Output_data) in let merged = Merge.merge (Input1.of_alist_exn [ T (Foo, Some 3); T (Bar, Some "three") ]) (Input2.of_alist_exn [ T (Foo, [ 4; 5; 6 ]); T (Baz, [ 'a'; 'b'; 'c' ]) ]) ~f:{ f = (fun ~key merge_result -> Some { key; merge_result }) } in print_s [%sexp (merged : Output.t)]; [%expect {| ((bar ((key Bar) (merge_result (Left (three))))) (baz ((key Baz) (merge_result (Right (a b c))))) (foo ((key Foo) (merge_result (Both ((3) (4 5 6))))))) |}] ;; let%expect_test "merge1" = let module Key = struct type _ t = | Foo : int t | Bar : string t | Baz : char t [@@deriving sexp_of] let foo_id = Type_equal.Id.create ~name:"foo" [%sexp_of: int] let bar_id = Type_equal.Id.create ~name:"bar" [%sexp_of: string] let baz_id = Type_equal.Id.create ~name:"baz" [%sexp_of: char] let type_id (type a) (t : a t) : a Type_equal.Id.t = match t with | Foo -> foo_id | Bar -> bar_id | Baz -> baz_id ;; end in let module Input_data1 = struct type (_, 'a) t = 'a option [@@deriving sexp_of] end in let module Input1 = Make1 (Key) (Input_data1) in let module Input_data2 = struct type (_, 'a) t = 'a list [@@deriving sexp_of] end in let module Input2 = Make1 (Key) (Input_data2) in let module Output_data = struct type ('s, 'a) t = { key : 'a Key.t ; merge_result : [ `Left of ('s, 'a) Input_data1.t | `Right of ('s, 'a) Input_data2.t | `Both of ('s, 'a) Input_data1.t * ('s, 'a) Input_data2.t ] } [@@deriving sexp_of] end in let module Output = Make1 (Key) (Output_data) in let module Merge = Merge1 (Key) (Input_data1) (Input_data2) (Output_data) in let merged = Merge.merge (Input1.of_alist_exn [ T (Foo, Some 3); T (Bar, Some "three") ]) (Input2.of_alist_exn [ T (Foo, [ 4; 5; 6 ]); T (Baz, [ 'a'; 'b'; 'c' ]) ]) ~f:{ f = (fun ~key merge_result -> Some { key; merge_result }) } in print_s [%sexp (merged : _ Output.t)]; [%expect {| ((bar ((key Bar) (merge_result (Left (three))))) (baz ((key Baz) (merge_result (Right (a b c))))) (foo ((key Foo) (merge_result (Both ((3) (4 5 6))))))) |}] ;; module _ = struct open! With_default let%test_unit _ = let key = Key.create ~default:0 ~name:"default 0" Int.sexp_of_t in assert (find empty key = 0); let t = set empty ~key ~data:1 in assert (find t key = 1); let t = set empty ~key ~data:2 in assert (find t key = 2); let t = change t key ~f:( ~- ) in assert (find t key = -2) ;; let%test _ = let key = Key.create ~default:1 ~name:"default 1" Int.sexp_of_t in find (change empty key ~f:( ~- )) key = -1 ;; end module _ = struct open! With_fold let%test_unit _ = let key = Key.create ~init:5 ~f:( + ) ~name:"init 5" Int.sexp_of_t in assert (find empty key = 5); let t = add empty ~key ~data:3 in assert (find t key = 8); let t = change t key ~f:( ~- ) in assert (find t key = -8) ;; let%test_unit _ = let key = Key.create ~init:0 ~f:(fun _ -> assert false) ~name:"don't fold this" Int.sexp_of_t in assert (find empty key = 0); let t = set empty ~key ~data:1 in assert (find t key = 1); let t = change t key ~f:( ~- ) in assert (find t key = -1) ;; end module _ = struct open! Multi let%test_unit _ = let key = Key.create ~name:"int list" Int.sexp_of_t in assert (find empty key = []); let t = add empty ~key ~data:1 in assert (find t key = [ 1 ]); let t = set t ~key ~data:[ 2; 3 ] in assert (find t key = [ 2; 3 ]); let t = change t key ~f:(List.map ~f:( ~- )) in assert (find t key = [ -2; -3 ]) ;; end core-0.15.0/core/test/src/test_univ_map.mli000066400000000000000000000000551420273305200206010ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_validated.ml000066400000000000000000000077671420273305200205700ustar00rootroot00000000000000open! Core open Poly open! Import open Validated module Raw = struct type t = int [@@deriving bin_io, compare, hash, sexp, typerep] let here = [%here] let validate _ = Validate.pass let validate_binio_deserialization = true let all = [ Int.min_value; -100; -1; 0; 1; 100; Int.max_value ] end module V = Make_bin_io_compare_hash_sexp (Raw) module type Output = sig type t [@@deriving sexp_of] include Equal.S with type t := t end let for_all (type a) raw_fn validated_fn (module Output : Output with type t = a) = List.iter Raw.all ~f:(fun raw -> let expected = raw_fn raw in let actual = validated_fn (V.create_exn raw) in require [%here] (Output.equal expected actual) ~if_false_then_print_s: (lazy [%message "Validated conversion not equal to raw conversion" (expected : Output.t) (actual : Output.t) (raw : Raw.t)])) ;; let for_all2 (type a) raw_fn validated_fn (module Output : Output with type t = a) = List.iter Raw.all ~f:(fun raw1 -> List.iter Raw.all ~f:(fun raw2 -> let expected = raw_fn raw1 raw2 in let actual = validated_fn (V.create_exn raw1) (V.create_exn raw2) in require [%here] (Output.equal expected actual) ~if_false_then_print_s: (lazy [%message "Validated conversion not equal to raw conversion" (expected : Output.t) (actual : Output.t) (raw1 : Raw.t) (raw2 : Raw.t)]))) ;; let%expect_test "[bin_io]s match" = let save_bin_io (type a) (module M : Binable with type t = a) a = let buf = Bigstring.create 128 in let len = M.bin_write_t buf ~pos:0 a in Bigstring.to_string buf ~len in for_all (save_bin_io (module Raw)) (save_bin_io (module V)) (module String); [%expect {| |}] ;; let%expect_test "[compare]s match" = for_all2 Raw.compare V.compare (module Int); [%expect {| |}] ;; let%expect_test "[hash]s match" = for_all Raw.hash V.hash (module Int); [%expect {| |}] ;; let%expect_test "[sexp]s match" = for_all [%sexp_of: Raw.t] [%sexp_of: V.t] (module Sexp); [%expect {| |}] ;; (* [Add_typerep] *) module _ : sig type t = V.t [@@deriving typerep] end = struct type t = V.t include Add_typerep (Raw) (V) end let%test_module _ = (module struct module Positive_int = struct type t = int [@@deriving bin_io, sexp] let validate t = if t > 0 then Validate.pass else Validate.fail "must be positive" end let does_raise = Exn.does_raise module M = Make (struct let here = [%here] include Positive_int end) open M let%test_unit _ = assert (does_raise (fun () -> t_of_sexp ([%sexp_of: int] 0))) let%test_unit _ = let sexp = [%sexp_of: int] 13 in assert (sexp_of_t (t_of_sexp sexp) = sexp) ;; let%test_unit _ = assert (does_raise (fun () -> create_exn 0)) let%test_unit _ = match create 0 with | Error _ -> () | Ok _ -> assert false ;; let%test_unit _ = let n = 13 in let t = create_exn n in assert (raw t = n) ;; let%test_unit _ = let n = 13 in match create n with | Error _ -> assert false | Ok t -> assert ((t :> int) = n) ;; module M1 = Make_binable (struct let here = [%here] let validate_binio_deserialization = true include Positive_int end) module M2 = Make_binable (struct let here = [%here] let validate_binio_deserialization = false include Positive_int end) let int = 0 let string = Binable.to_string (module Int) int let%test _ = does_raise (fun () -> Binable.of_string (module M1) string) let%test _ = M2.raw (Binable.of_string (module M2) string) = int let int = 1 let string = Binable.to_string (module Int) int let%test _ = M1.raw (Binable.of_string (module M1) string) = int let%test _ = M2.raw (Binable.of_string (module M2) string) = int end) ;; core-0.15.0/core/test/src/test_validated.mli000066400000000000000000000000551420273305200207200ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/test_zone.ml000066400000000000000000001664501420273305200176010ustar00rootroot00000000000000open! Core open! Import let%expect_test "UTC survives round trip" = let test ?cr zone = require_does_not_raise [%here] ?cr (fun () -> print_s [%sexp (Time.utc_offset Time.epoch ~zone : Time.Span.t)]) in test Time.Zone.utc; [%expect {| 0s |}]; let zone = Time.Zone.utc |> Binable.to_string (module Time.Stable.Zone.Full_data.V1) |> Binable.of_string (module Time.Stable.Zone.Full_data.V1) in test zone; [%expect {| 0s |}] ;; let%expect_test "Time.Stable.Zone.Full_data.V1" = print_and_check_stable_type [%here] (module Time.Stable.Zone.Full_data.V1) [ Time.Zone.utc ; Time.Zone.input_tz_file ~zonename:"Sample Time Zone" ~filename:"sample_time_zone_file" ]; [%expect {| (bin_shape_digest 819b3454610960b488fbed8a9e63887c) ((sexp ( (name UTC) (original_filename ()) (digest ()) (transitions ()) (last_regime_index 0) (default_local_time_type ( (utc_offset_in_seconds 0) (is_dst false) (abbrv UTC))) (leap_seconds ()))) (bin_io "\003UTC\000\000\000\000\000\000\003UTC\000")) ((sexp ( (name "Sample Time Zone") (original_filename (sample_time_zone_file)) (digest ("\228\2028\0165\163Kz\133!\132\204\r\216\155\170")) (transitions ( ((start_time_in_seconds_since_epoch -2_717_650_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_633_280_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_615_140_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_601_830_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_583_690_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_570_381_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_551_636_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_536_512_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_523_210_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_504_458_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_491_760_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_473_008_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_459_706_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_441_558_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_428_256_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_410_109_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_396_807_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_378_659_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_365_357_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_347_210_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_333_908_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_315_155_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_301_853_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_283_706_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_270_404_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_252_256_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_238_954_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_220_806_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_207_504_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_189_357_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_176_055_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_157_302_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_144_605_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_125_853_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_112_551_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_094_403_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_081_101_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_062_954_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_049_652_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_031_504_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -1_018_202_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -1_000_054_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -986_752_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -968_000_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -955_303_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -936_550_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -923_248_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -905_101_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -891_799_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -880_218_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EWT)))) ((start_time_in_seconds_since_epoch -769_395_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EPT)))) ((start_time_in_seconds_since_epoch -765_396_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -747_248_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -733_946_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -715_798_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -702_496_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -684_349_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -671_047_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -652_899_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -639_597_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -620_845_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -608_148_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -589_395_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -576_093_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -557_946_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -544_644_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -526_496_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -513_194_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -495_046_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -481_744_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -463_597_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -447_271_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -431_542_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -415_821_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -400_093_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -384_372_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -368_643_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -352_922_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -337_194_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -321_472_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -305_744_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -289_418_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -273_690_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -257_968_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -242_240_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -226_519_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -210_790_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -195_069_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -179_341_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -163_620_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -147_891_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -131_565_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -116_442_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -100_116_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -84_387_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -68_666_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -52_938_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -37_216_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch -21_488_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch -5_767_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 9_961_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 25_682_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 41_410_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 57_736_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 73_465_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 89_186_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 104_914_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 120_636_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 126_687_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 152_085_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 162_370_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 183_535_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 199_263_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 215_589_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 230_713_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 247_039_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 262_767_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 278_488_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 294_217_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 309_938_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 325_666_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 341_388_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 357_116_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 372_837_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 388_566_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 404_892_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 420_015_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 436_341_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 452_070_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 467_791_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 483_519_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 499_240_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 514_969_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 530_690_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 544_604_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 562_140_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 576_054_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 594_194_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 607_503_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 625_644_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 638_953_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 657_093_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 671_007_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 688_543_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 702_457_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 719_992_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 733_906_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 752_047_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 765_356_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 783_496_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 796_806_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 814_946_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 828_860_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 846_396_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 860_310_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 877_845_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 891_759_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 909_295_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 923_209_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 941_349_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 954_658_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 972_799_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 986_108_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_004_248_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_018_162_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_035_698_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_049_612_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_067_148_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_081_062_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_099_202_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_112_511_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_130_652_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_143_961_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_162_101_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_173_596_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_194_156_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_205_046_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_225_605_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_236_495_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_257_055_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_268_550_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_289_109_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_299_999_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_320_559_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_331_449_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_352_008_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_362_898_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_383_458_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_394_348_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_414_908_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_425_798_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_446_357_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_457_852_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_478_412_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_489_302_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_509_861_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_520_751_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_541_311_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_552_201_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_572_760_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_583_650_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_604_210_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_615_705_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_636_264_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_647_154_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_667_714_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_678_604_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_699_164_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_710_054_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_730_613_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_741_503_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_762_063_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_772_953_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_793_512_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_805_007_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_825_567_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_836_457_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_857_016_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_867_906_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_888_466_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_899_356_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_919_916_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_930_806_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_951_365_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_962_860_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 1_983_420_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 1_994_310_000) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 2_014_869_600) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 2_025_759_600) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 2_046_319_200) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 2_057_209_200) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 2_077_768_800) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 2_088_658_800) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 2_109_218_400) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))) ((start_time_in_seconds_since_epoch 2_120_108_400) (new_regime ( (utc_offset_in_seconds -14_400) (is_dst true) (abbrv EDT)))) ((start_time_in_seconds_since_epoch 2_140_668_000) (new_regime ( (utc_offset_in_seconds -18_000) (is_dst false) (abbrv EST)))))) (last_regime_index 0) (default_local_time_type ( (utc_offset_in_seconds -17_762) (is_dst false) (abbrv LMT))) (leap_seconds ()))) (bin_io "\016Sample Time Zone\001\021sample_time_zone_file\001\016\228\2028\0165\163Kz\133!\132\204\r\216\155\170\254\236\000\252\144\240\003^\255\255\255\255\254\176\185\000\003EST\253p\030\166\158\254\192\199\001\003EDT\253`\235\186\159\254\176\185\000\003EST\253p\000\134\160\254\192\199\001\003EDT\253`\205\154\161\254\176\185\000\003EST\253p\226e\162\254\192\199\001\003EDT\253\224\233\131\163\254\176\185\000\003EST\253p\174j\164\254\192\199\001\003EDT\253`\1675\165\254\176\185\000\003EST\253\240\202S\166\254\192\199\001\003EDT\253`\137\021\167\254\176\185\000\003EST\253\240\1723\168\254\192\199\001\003EDT\253\224\165\254\168\254\176\185\000\003EST\253\240\142\019\170\254\192\199\001\003EDT\253\224\135\222\170\254\176\185\000\003EST\253\240p\243\171\254\192\199\001\003EDT\253\224i\190\172\254\176\185\000\003EST\253\240R\211\173\254\192\199\001\003EDT\253\224K\158\174\254\176\185\000\003EST\253\2404\179\175\254\192\199\001\003EDT\253\224-~\176\254\176\185\000\003EST\253pQ\156\177\254\192\199\001\003EDT\253`Jg\178\254\176\185\000\003EST\253p3|\179\254\192\199\001\003EDT\253`,G\180\254\176\185\000\003EST\253p\021\\\181\254\192\199\001\003EDT\253`\014'\182\254\176\185\000\003EST\253p\247;\183\254\192\199\001\003EDT\253`\240\006\184\254\176\185\000\003EST\253p\217\027\185\254\192\199\001\003EDT\253`\210\230\185\254\176\185\000\003EST\253\240\245\004\187\254\192\199\001\003EDT\253`\180\198\187\254\176\185\000\003EST\253\240\215\228\188\254\192\199\001\003EDT\253\224\208\175\189\254\176\185\000\003EST\253\240\185\196\190\254\192\199\001\003EDT\253\224\178\143\191\254\176\185\000\003EST\253\240\155\164\192\254\192\199\001\003EDT\253\224\148o\193\254\176\185\000\003EST\253\240}\132\194\254\192\199\001\003EDT\253\224vO\195\254\176\185\000\003EST\253\240_d\196\254\192\199\001\003EDT\253\224X/\197\254\176\185\000\003EST\253p|M\198\254\192\199\001\003EDT\253\224:\015\199\254\176\185\000\003EST\253p^-\200\254\192\199\001\003EDT\253`W\248\200\254\176\185\000\003EST\253p@\r\202\254\192\199\001\003EDT\253`9\216\202\254\176\185\000\003EST\253p\240\136\203\254\192\199\001\003EWT\253p\244#\210\254\192\199\001\003EPT\253\224\251`\210\254\176\185\000\003EST\253\240\228u\211\254\192\199\001\003EDT\253\224\221@\212\254\176\185\000\003EST\253\240\198U\213\254\192\199\001\003EDT\253\224\191 \214\254\176\185\000\003EST\253\240\1685\215\254\192\199\001\003EDT\253\224\161\000\216\254\176\185\000\003EST\253\240\138\021\217\254\192\199\001\003EDT\253\224\131\224\217\254\176\185\000\003EST\253p\167\254\218\254\192\199\001\003EDT\253\224e\192\219\254\176\185\000\003EST\253p\137\222\220\254\192\199\001\003EDT\253`\130\169\221\254\176\185\000\003EST\253pk\190\222\254\192\199\001\003EDT\253`d\137\223\254\176\185\000\003EST\253pM\158\224\254\192\199\001\003EDT\253`Fi\225\254\176\185\000\003EST\253p/~\226\254\192\199\001\003EDT\253`(I\227\254\176\185\000\003EST\253p\017^\228\254\192\199\001\003EDT\253\224.W\229\254\176\185\000\003EST\253\240-G\230\254\192\199\001\003EDT\253\224\0167\231\254\176\185\000\003EST\253\240\015'\232\254\192\199\001\003EDT\253\224\242\022\233\254\176\185\000\003EST\253\240\241\006\234\254\192\199\001\003EDT\253\224\212\246\234\254\176\185\000\003EST\253\240\211\230\235\254\192\199\001\003EDT\253\224\182\214\236\254\176\185\000\003EST\253\240\181\198\237\254\192\199\001\003EDT\253`\211\191\238\254\176\185\000\003EST\253p\210\175\239\254\192\199\001\003EDT\253`\181\159\240\254\176\185\000\003EST\253p\180\143\241\254\192\199\001\003EDT\253`\151\127\242\254\176\185\000\003EST\253p\150o\243\254\192\199\001\003EDT\253`y_\244\254\176\185\000\003EST\253pxO\245\254\192\199\001\003EDT\253`[?\246\254\176\185\000\003EST\253pZ/\247\254\192\199\001\003EDT\253\224w(\248\254\176\185\000\003EST\253p<\015\249\254\192\199\001\003EDT\253\224Y\b\250\254\176\185\000\003EST\253\240X\248\250\254\192\199\001\003EDT\253\224;\232\251\254\176\185\000\003EST\253\240:\216\252\254\192\199\001\003EDT\253\224\029\200\253\254\176\185\000\003EST\253\240\028\184\254\254\192\199\001\003EDT\253\224\255\167\255\254\176\185\000\003EST\253\240\254\151\000\254\192\199\001\003EDT\253\224\225\135\001\254\176\185\000\003EST\253\240\224w\002\254\192\199\001\003EDT\253`\254p\003\254\176\185\000\003EST\253p\253`\004\254\192\199\001\003EDT\253`\224P\005\254\176\185\000\003EST\253p\223@\006\254\192\199\001\003EDT\253`\1940\007\254\176\185\000\003EST\253p\025\141\007\254\192\199\001\003EDT\253`\164\016\t\254\176\185\000\003EST\253\240\148\173\t\254\192\199\001\003EDT\253`\134\240\n\254\176\185\000\003EST\253p\133\224\011\254\192\199\001\003EDT\253\224\162\217\012\254\176\185\000\003EST\253pg\192\r\254\192\199\001\003EDT\253\224\132\185\014\254\176\185\000\003EST\253\240\131\169\015\254\192\199\001\003EDT\253\224f\153\016\254\176\185\000\003EST\253\240e\137\017\254\192\199\001\003EDT\253\224Hy\018\254\176\185\000\003EST\253\240Gi\019\254\192\199\001\003EDT\253\224*Y\020\254\176\185\000\003EST\253\240)I\021\254\192\199\001\003EDT\253\224\0129\022\254\176\185\000\003EST\253\240\011)\023\254\192\199\001\003EDT\253`)\"\024\254\176\185\000\003EST\253\240\237\b\025\254\192\199\001\003EDT\253`\011\002\026\254\176\185\000\003EST\253p\n\242\026\254\192\199\001\003EDT\253`\237\225\027\254\176\185\000\003EST\253p\236\209\028\254\192\199\001\003EDT\253`\207\193\029\254\176\185\000\003EST\253p\206\177\030\254\192\199\001\003EDT\253`\177\161\031\254\176\185\000\003EST\253\240\000v \254\192\199\001\003EDT\253`\147\129!\254\176\185\000\003EST\253\240\226U\"\254\192\199\001\003EDT\253\224\175j#\254\176\185\000\003EST\253\240\1965$\254\192\199\001\003EDT\253\224\145J%\254\176\185\000\003EST\253\240\166\021&\254\192\199\001\003EDT\253\224s*'\254\176\185\000\003EST\253p\195\254'\254\192\199\001\003EDT\253\224U\n)\254\176\185\000\003EST\253p\165\222)\254\192\199\001\003EDT\253\2247\234*\254\176\185\000\003EST\253p\135\190+\254\192\199\001\003EDT\253`T\211,\254\176\185\000\003EST\253pi\158-\254\192\199\001\003EDT\253`6\179.\254\176\185\000\003EST\253pK~/\254\192\199\001\003EDT\253`\024\1470\254\176\185\000\003EST\253\240gg1\254\192\199\001\003EDT\253`\250r2\254\176\185\000\003EST\253\240IG3\254\192\199\001\003EDT\253`\220R4\254\176\185\000\003EST\253\240+'5\254\192\199\001\003EDT\253`\19026\254\176\185\000\003EST\253\240\r\0077\254\192\199\001\003EDT\253\224\218\0278\254\176\185\000\003EST\253\240\239\2308\254\192\199\001\003EDT\253\224\188\2519\254\176\185\000\003EST\253\240\209\198:\254\192\199\001\003EDT\253\224\158\219;\254\176\185\000\003EST\253p\238\175<\254\192\199\001\003EDT\253\224\128\187=\254\176\185\000\003EST\253p\208\143>\254\192\199\001\003EDT\253\224b\155?\254\176\185\000\003EST\253p\178o@\254\192\199\001\003EDT\253`\127\132A\254\176\185\000\003EST\253p\148OB\254\192\199\001\003EDT\253`adC\254\176\185\000\003EST\253pv/D\254\192\199\001\003EDT\253`CDE\254\176\185\000\003EST\253\240\168\243E\254\192\199\001\003EDT\253\224_-G\254\176\185\000\003EST\253\240\138\211G\254\192\199\001\003EDT\253\224A\rI\254\176\185\000\003EST\253\240l\179I\254\192\199\001\003EDT\253\224#\237J\254\176\185\000\003EST\253p\137\156K\254\192\199\001\003EDT\253`@\214L\254\176\185\000\003EST\253pk|M\254\192\199\001\003EDT\253`\"\182N\254\176\185\000\003EST\253pM\\O\254\192\199\001\003EDT\253`\004\150P\254\176\185\000\003EST\253p/ 'a option ; int_as_value_exn : int -> 'a ; int_is_value : int -> bool ; value_as_int : 'a -> int option ; value_as_int_exn : 'a -> int ; value_is_int : 'a -> bool } let get_conv typerep_of_t = let immediacy = Type_immediacy.of_typerep typerep_of_t in let int_as_value i = Type_immediacy.int_as_value immediacy i in let int_as_value_exn i = Type_immediacy.int_as_value_exn immediacy i in let int_is_value i = Type_immediacy.int_is_value immediacy i in let value_as_int a = Type_immediacy.value_as_int immediacy a in let value_as_int_exn a = Type_immediacy.value_as_int_exn immediacy a in let value_is_int a = Type_immediacy.value_is_int immediacy a in { int_as_value ; int_as_value_exn ; int_is_value ; value_as_int ; value_as_int_exn ; value_is_int } ;; (*In the following, the three cases for values and two for ints that are discuessed are described in [./type_immediacy.mli]. We merge case 1) and I), as they are really the same, and provide the following 4 test cases: | Convertible of 'a * int (* Corresponds to cases 1) and I) *) For [Convertible (v,i)], we test the conversion invariants mentioned in 1), i.e. we a) check that [v] is immediate, and that it's underlying [int] representation is [i] b) check that [v] converts to [i], using [value_is_int], and [value_as_int(_exn)?] c) check that [i] converts to [v], using [int_is_value], and [int_as_value(_exn)?] | Val_does_not_convert of 'a (* Corresponds to case 3) *) For [Val_does_not_convert v], we test that a) [v] is boxed b) the conversion functions return the appropriate results as described in 3) | Int_does_not_convert of 'a (* Corresponds to case II) *) For [Int_does_not_convert i], we test that the conversion functions return the appropriate results as described in II) | Boxed_value_converts of ('a lazy_t * 'a * int) (* Corresponds to case 2) *) Since case 2) is only relevant if the toplevel type is [lazy_t], we have specialized this case. For [Boxed_value_converts (lazy_v,v,i)], we test that a) [lazy_v] is boxed. b) [lazy_v] converts to [i] when the conversion functions are called. c) [Lazy.force lazy_v == Lazy.force v] d) If we test [Convertible (v,i)], the test passes. (We also implicitly have the property that [Lazy.force lazy_v] is immediate and internally represented by [i], which follows from b), c) and d) above. ) The following functions provide tests for the four cases. *) let is_immediate (type a) (v : a) : bool = Obj.is_int (Obj.repr v) (* Raises an exception if [v] is not immediate, just as a sanity check. *) let to_int (type a) (v : a) : int = if is_immediate v then (Obj.magic (v : a) : int) else failwith "Can't convert a boxed value to an int." ;; (* Does not take a list but a single argument only. *) let test_convertible_single (type a) (conv : a t) ((v, i) : a * int) : bool = to_int v = i (* Contains check for v being immediate. *) && conv.value_is_int v && conv.int_is_value i && i = conv.value_as_int_exn v && phys_equal v (conv.int_as_value_exn i) && (match conv.value_as_int v with | Some i' -> i = i' | None -> false) && match conv.int_as_value i with | Some v' -> phys_equal v v' | None -> false ;; let test_convertibles (type a) (conv : a t) (test_cases : (a * int) list) : bool = List.for_all test_cases ~f:(test_convertible_single conv) ;; let test_inconvertible_values (type a) (conv : a t) (test_cases : a list) : bool = List.for_all test_cases ~f:(fun v -> (not (is_immediate v)) && (not (conv.value_is_int v)) && (match conv.value_as_int v with | Some _ -> false | None -> true) && try let _i = conv.value_as_int_exn v in false with | _ -> true) ;; let test_inconvertible_ints (type a) (conv : a t) (test_cases : int list) : bool = List.for_all test_cases ~f:(fun i -> (not (conv.int_is_value i)) && (match conv.int_as_value i with | Some _ -> false | None -> true) && try let _v = conv.int_as_value_exn i in false with | _ -> true) ;; (* Recurring conversion patterns: *) let no_int_but_zero_converts = [ 1; 2; 3; -1; Int.max_value; Int.min_value ] let no_int_converts = 0 :: no_int_but_zero_converts module type S = sig type t [@@deriving typerep] end let is_never (type a) (module M : S with type t = a) examples = let conv = get_conv M.typerep_of_t in test_inconvertible_values conv examples && test_inconvertible_ints conv no_int_converts ;; let%test (_ [@tags "no-js"]) = is_never (module struct type t = int32 [@@deriving typerep] end) [ Int32.zero ; Int32.one ; Int32.minus_one ; Int32.max_value ; Int32.min_value ; Int32.of_int_exn 328121 ] ;; let%test _ = is_never (module struct type t = int64 [@@deriving typerep] end) [ Int64.zero; Int64.one; Int64.minus_one; Int64.max_value; Int64.min_value ] ;; let%test (_ [@tags "no-js"]) = is_never (module struct type t = nativeint [@@deriving typerep] end) [ Nativeint.zero ; Nativeint.one ; Nativeint.minus_one ; Nativeint.max_value ; Nativeint.min_value ] ;; let%test _ = let module M = struct type t = char [@@deriving typerep] end in let conv = get_conv M.typerep_of_t in test_convertibles conv [ 'a', 97 ; 'A', 65 ; '0', 48 ; '9', 57 ; '\t', 9 ; '\n', 10 ; Char.of_int_exn 0, 0 ; Char.of_int_exn 127, 127 ] && test_inconvertible_ints conv [ 256; -1; 500; Int.max_value; Int.min_value ] ;; let%test (_ [@tags "no-js"]) = is_never (module struct type t = float [@@deriving typerep] end) [ 1.1; 0.0; -3.3; Float.nan; Float.infinity; Float.neg_infinity ] ;; let%test _ = is_never (module struct type t = string [@@deriving typerep] end) [ ""; "Hello world!" ] ;; let%test _ = let module M = struct type t = bool [@@deriving typerep] end in let conv = get_conv M.typerep_of_t in test_convertibles conv [ true, 1; false, 0 ] && test_inconvertible_ints conv [ 2; 3; -1; -2; 50; Int.max_value; Int.min_value ] ;; let%test _ = let module M = struct type t = unit [@@deriving typerep] end in let conv = get_conv M.typerep_of_t in test_convertibles conv [ (), 0 ] && test_inconvertible_ints conv no_int_but_zero_converts ;; let%test _ = let module M = struct type t = unit option [@@deriving typerep] end in let conv = get_conv M.typerep_of_t in test_convertibles conv [ None, 0 ] && test_inconvertible_ints conv no_int_but_zero_converts && test_inconvertible_values conv [ Some () ] ;; let%test _ = let module M = struct type t = int ref option [@@deriving typerep] end in let conv = get_conv M.typerep_of_t in test_convertibles conv [ None, 0 ] && test_inconvertible_ints conv no_int_but_zero_converts && test_inconvertible_values conv [ Some (ref 0); Some (ref 1) ] ;; let%test _ = let module M = struct type t = int ref list [@@deriving typerep] end in let conv = get_conv M.typerep_of_t in test_convertibles conv [ [], 0 ] && test_inconvertible_ints conv no_int_but_zero_converts && test_inconvertible_values conv [ [ ref 0 ]; [ ref 1 ] ] ;; let%test _ = let module M = struct type t = unit list [@@deriving typerep] end in let conv = get_conv M.typerep_of_t in test_convertibles conv [ [], 0 ] && test_inconvertible_ints conv no_int_but_zero_converts && test_inconvertible_values conv [ [ () ] ] ;; let%test _ = is_never (module struct type t = int ref array [@@deriving typerep] end) [ [||]; [| ref 1 |] ] ;; let%test _ = is_never (module struct type t = unit array [@@deriving typerep] end) [ [||]; [| () |]; [| (); () |] ] ;; let%test _ = is_never (module struct type t = unit ref [@@deriving typerep] end) [ ref () ] ;; let%test _ = is_never (module struct type t = int ref [@@deriving typerep] end) [ ref 1; ref 2; ref (-1) ] ;; let%test_module _ = (module struct type 'a t = 'a lazy_t [@@deriving typerep] let%test _ = (* type t = unit lazy_t *) let conv = get_conv (typerep_of_t typerep_of_unit) in test_inconvertible_values conv [ lazy ((fun () -> ()) ()) ] && test_convertibles conv [ Lazy.from_val (), 0 ] && test_inconvertible_ints conv no_int_but_zero_converts ;; let%test _ = (* type t = int lazy_t *) let conv = get_conv (typerep_of_t typerep_of_int) in test_convertibles conv [ lazy 0, 0; lazy (-1), -1; Lazy.from_val Int.max_value, Int.max_value ] && test_inconvertible_values conv [ lazy (1 + 2); lazy (List.length []) ] ;; (* depending on when the Gc runs, some lazy after being forced might be replaced by their immediate value. *) let%test _ = (* type t = int list lazy_t *) let conv = get_conv (typerep_of_t (typerep_of_list typerep_of_int)) in (* Define some lazy lists. *) let l1 = lazy (List.filter [ 1; 2; 3; 4 ] ~f:(fun _ -> false)) in let l2 = lazy (List.filter [] ~f:(fun _ -> true)) in let l3 = lazy (List.filter [ 1 ] ~f:(fun _ -> true)) in let empty = Lazy.from_val [] in test_convertibles conv [ empty, 0 ] && test_inconvertible_values conv [ Lazy.from_val [ 1 ]; l1; l2; l3 ] && test_inconvertible_ints conv no_int_but_zero_converts ;; let%test _ = let conv = get_conv (typerep_of_t (typerep_of_t typerep_of_int)) in let l1 = lazy (lazy (1 + 2)) in test_convertibles conv [ Lazy.from_val (Lazy.from_val 3), 3 ] && test_inconvertible_values conv [ l1 ] ;; end) ;; let%test _ = let module M = struct type t = { foo : unit } [@@deriving typerep] end in is_never (module M) [ { M.foo = () } ] ;; let%expect_test _ = let module M = struct type t = { foo : unit } [@@unboxed] [@@deriving typerep] end in let conv = get_conv M.typerep_of_t in Expect_test_helpers_core.require [%here] ~cr:CR_someday (test_convertibles conv [ { M.foo = () }, 0 ]) ~if_false_then_print_s:(lazy [%message "zero should convert"]); Expect_test_helpers_core.require [%here] (test_inconvertible_ints conv no_int_but_zero_converts) ~if_false_then_print_s:(lazy [%message "non-zero should not convert"]); [%expect {| "zero should convert" |}] ;; let%test _ = let module M = struct type t = { foo : unit ; bar : unit } [@@deriving typerep] end in is_never (module M) [ { M.foo = (); bar = () } ] ;; let%test _ = let module M = struct type t = { foo : string } [@@unboxed] [@@deriving typerep] end in is_never (module M) [ { M.foo = "foo" } ] ;; let%test _ = is_never (module struct type t = unit * unit [@@deriving typerep] end) [ (), () ] ;; let%test _ = is_never (module struct type t = unit * unit * unit [@@deriving typerep] end) [ (), (), () ] ;; let%test _ = is_never (module struct type t = unit * unit * unit * unit [@@deriving typerep] end) [ (), (), (), () ] ;; let%test _ = is_never (module struct type t = unit * unit * unit * unit * unit [@@deriving typerep] end) [ (), (), (), (), () ] ;; let%expect_test _ = let module M = struct type t = Foo of unit [@@unboxed] [@@deriving typerep] end in let conv = get_conv M.typerep_of_t in Expect_test_helpers_core.require [%here] ~cr:CR_someday (test_convertibles conv [ M.Foo (), 0 ]) ~if_false_then_print_s:(lazy [%message "zero should convert"]); Expect_test_helpers_core.require [%here] (test_inconvertible_ints conv no_int_but_zero_converts) ~if_false_then_print_s:(lazy [%message "non-zero should not convert"]); [%expect {| "zero should convert" |}] ;; let%test _ = let module M = struct type t = | Foo | Bar of unit [@@deriving typerep] end in let conv = get_conv M.typerep_of_t in test_convertibles conv [ M.Foo, 0 ] && test_inconvertible_values conv [ M.Bar () ] && test_inconvertible_ints conv no_int_but_zero_converts ;; let%test _ = let module M = struct type t = | Foo | Bar | Baz [@@deriving typerep] end in let conv = get_conv M.typerep_of_t in test_convertibles conv [ M.Foo, 0; M.Bar, 1; M.Baz, 2 ] && test_inconvertible_ints conv [ 3; 4; 5; 500; 232; -1; -2; Int.max_value; Int.min_value ] ;; let%test _ = let module M = struct type t = | Foo of unit | Bar of unit | Baz of unit [@@deriving typerep] end in is_never (module M) [ M.Foo (); M.Bar (); M.Baz () ] ;; let filter_variants variants list = let variants = List.filter_map variants ~f:(fun v -> if Obj.is_int (Obj.repr v) then Some (Obj.magic (v : [> ]) : int) else None) in List.filter list ~f:(fun int -> List.for_all variants ~f:(fun variant -> variant <> int)) ;; let%test _ = let module M = struct type t = [ `Foo | `Bar of unit ] [@@deriving typerep, enumerate] end in let conv = get_conv M.typerep_of_t in test_convertibles conv [ `Foo, Typerep_obj.repr_of_poly_variant `Foo ] && test_inconvertible_values conv [ `Bar () ] && test_inconvertible_ints conv (filter_variants M.all [ 0 ; 1 ; 2 ; 3 ; -1 ; -2 ; 563 ; Int.max_value ; Int.min_value ; Typerep_obj.repr_of_poly_variant `Bar ]) ;; let%test _ = let module M = struct type t = [ `Foo | `Bar | `Baz ] [@@deriving typerep, enumerate] end in let conv = get_conv M.typerep_of_t in test_convertibles conv [ `Foo, Typerep_obj.repr_of_poly_variant `Foo ; `Bar, Typerep_obj.repr_of_poly_variant `Bar ; `Baz, Typerep_obj.repr_of_poly_variant `Baz ] && test_inconvertible_ints conv (filter_variants M.all [ 0; 1; 2; 3; -1; -2; 563; Int.max_value; Int.min_value ]) ;; let%test _ = let module M = struct type t = [ `Foo of unit | `Bar of unit | `Baz of unit ] [@@deriving typerep] end in let conv = get_conv M.typerep_of_t in test_inconvertible_values conv [ `Foo (); `Bar (); `Baz () ] && test_inconvertible_ints conv ([ Typerep_obj.repr_of_poly_variant `Foo ; Typerep_obj.repr_of_poly_variant `Bar ; Typerep_obj.repr_of_poly_variant `Baz ] @ no_int_converts) ;; let%test _ = let module M = struct type 'a t = | Nil | Cons of 'a * 'a t [@@deriving typerep] end in let conv = get_conv (M.typerep_of_t typerep_of_unit) in test_convertibles conv [ M.Nil, 0 ] && test_inconvertible_values conv [ M.Cons ((), M.Nil); M.Cons ((), M.Cons ((), M.Nil)) ] && test_inconvertible_ints conv no_int_but_zero_converts ;; let%test _ = let module M = struct type 'a t = | A | B of 'a t lazy_t | C of 'a * 'a t [@@deriving typerep] end in let conv = get_conv (M.typerep_of_t typerep_of_int) in test_convertibles conv [ M.A, 0 ] && test_inconvertible_values conv [ M.B (lazy M.A); M.C (1, M.A) ] && test_inconvertible_ints conv no_int_but_zero_converts ;; let%test _ = let module M = struct type 'a t = | A | B of ('a t * 'a t) | C of 'a [@@deriving typerep] end in let conv = get_conv (M.typerep_of_t typerep_of_unit) in test_convertibles conv [ M.A, 0 ] && test_inconvertible_values conv [ M.B (M.A, M.A); M.C () ] && test_inconvertible_ints conv no_int_but_zero_converts ;; end) ;; core-0.15.0/core/test/src/type_immediacy_conv_unit_tests.mli000066400000000000000000000000551420273305200242340ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/test/src/type_immediacy_witness_unit_tests.ml000066400000000000000000000351401420273305200246150ustar00rootroot00000000000000open! Core (* Tests to make sure the implementation of values hasn't changed and that witnesses are provided correctly. *) (* Tests are bound to the value returned by Immediate.of_typerep, as the test cases are designed along the value returned and so that they must be revised if changes are made. *) let%test_module _ = (module struct type t = | Always | Sometimes | Never | Unknown (* Where appropriate, unit is used as a representative of something that will always be immediate and int ref is used as a representative of something that will always be boxed, no matter the actual representation. *) let imm_t = typerep_of_unit let box_t = typerep_of_ref typerep_of_int let is_imm v = Obj.is_int (Obj.repr v) (* When [expected] and the actual result is [Sometimes], at least one immediate and one non-immediate value must be supplied. It requires at least one value in any case. *) let check expected typerep list = if List.length list = 0 then failwith "Must provide at least one test case."; let actual = ( Type_immediacy.dest (Type_immediacy.of_typerep typerep) , Type_immediacy.Always.of_typerep typerep , Type_immediacy.Sometimes.of_typerep typerep , Type_immediacy.Never.of_typerep typerep ) in let has_imm = List.exists ~f:is_imm list in let has_boxed = List.exists ~f:(fun x -> not (is_imm x)) list in match has_imm, has_boxed, expected, actual with | true, false, Always, (Type_immediacy.Always _, Some _, None, None) -> true | true, true, Sometimes, (Type_immediacy.Sometimes _, None, Some _, None) -> true | false, true, Never, (Type_immediacy.Never _, None, None, Some _) -> true | _, _, Unknown, (Type_immediacy.Unknown, None, None, None) -> true | _, _, _, _ -> false ;; module T : sig val check_a : 'a Typerep.t -> 'a list -> bool val check_s : 'a Typerep.t -> 'a list -> bool val check_n : 'a Typerep.t -> 'a list -> bool val check_u : 'a Typerep.t -> 'a list -> bool end = struct let check_a typerep list = check Always typerep list let check_s typerep list = check Sometimes typerep list let check_n typerep list = check Never typerep list let check_u typerep list = check Unknown typerep list end include T let sexp_of_dest dest = match (dest : _ Type_immediacy.dest) with | Always _ -> [%sexp "Always"] | Never _ -> [%sexp "Never"] | Sometimes _ -> [%sexp "Sometimes"] | Unknown -> [%sexp "Unknown"] ;; let require_self_consistent ?cr typerep list = let type_immediacy = Type_immediacy.dest (Type_immediacy.of_typerep typerep) in let has_imm = List.exists ~f:is_imm list in let has_boxed = List.exists ~f:(fun x -> not (is_imm x)) list in match has_imm, has_boxed, type_immediacy with | true, false, Always _ -> () | false, true, Never _ -> () | true, true, Sometimes _ -> () | _, _, Unknown -> () | _, _, _ -> Expect_test_helpers_base.print_cr ?cr [%here] [%message "The immediacy of the values did not match the Type_immediacy" (type_immediacy : dest) (has_imm : bool) (has_boxed : bool)] ;; let%test _ = let module M = struct type t = int [@@deriving typerep] end in check_a M.typerep_of_t [ 0; 1 ] ;; let%test (_ [@tags "no-js"]) = let module M = struct type t = int32 [@@deriving typerep] end in check_n M.typerep_of_t [ Int32.zero; Int32.one; Int32.minus_one; Int32.of_int_exn 32580 ] ;; let%test _ = let module M = struct type t = int64 [@@deriving typerep] end in check_n M.typerep_of_t [ Int64.zero ] ;; let%test (_ [@tags "no-js"]) = let module M = struct type t = nativeint [@@deriving typerep] end in check_n M.typerep_of_t [ Nativeint.zero ] ;; let%test _ = let module M = struct type t = char [@@deriving typerep] end in check_a M.typerep_of_t [ 'a' ] ;; let%test (_ [@tags "no-js"]) = let module M = struct type t = float [@@deriving typerep] end in check_n M.typerep_of_t [ 1.1 ; 0.0 ; -3.3 ; Float.nan ; Float.infinity ; Float.neg_infinity ; Float.max_value ; Float.min_value ] ;; let%test _ = let module M = struct type t = string [@@deriving typerep] end in check_n M.typerep_of_t [ ""; "Hello world!" ] ;; let%test _ = let module M = struct type t = bool [@@deriving typerep] end in check_a M.typerep_of_t [ true; false ] ;; let%test _ = let module M = struct type t = unit [@@deriving typerep] end in check_a M.typerep_of_t [ () ] ;; let%test _ = let module M = struct (* The generated typrep in the case of parametric types have this signature: val M.typerep_of_t : 'a Typerep.t -> 'a t Typerep.t *) type 'a t = 'a option [@@deriving typerep] end in check_s (M.typerep_of_t imm_t) [ None; Some () ] && check_s (M.typerep_of_t box_t) [ None; Some (ref 1) ] ;; let%test _ = let module M = struct type 'a t = 'a list [@@deriving typerep] end in check_s (M.typerep_of_t imm_t) [ []; [ () ] ] && check_s (M.typerep_of_t box_t) [ []; [ ref 1 ] ] ;; let static_empty_array = [||] let%test _ = let module M = struct type 'a t = 'a array [@@deriving typerep] end in check_n (M.typerep_of_t imm_t) [ static_empty_array; [||]; [| (); () |] ] ;; let%test _ = let module M = struct type 'a t = 'a ref [@@deriving typerep] end in check_n (M.typerep_of_t imm_t) [ ref () ] ;; let%test _ = let module M = struct type 'a t = 'a lazy_t [@@deriving typerep] end in check_s (M.typerep_of_t typerep_of_int) [ lazy 1; lazy (1 + 2) ] && check_n (M.typerep_of_t typerep_of_float) [ lazy 0.0; lazy (1.0 +. -3.3) ] ;; let require_unboxed ?cr = Expect_test_helpers_base.require ?cr ~if_false_then_print_s: (lazy [%message "Unboxed container types should have the immediacy of their contained type"]) [%here] ;; let require_boxed ?cr = Expect_test_helpers_base.require ?cr ~if_false_then_print_s: (lazy [%message "Boxed container types should never be immediate"]) [%here] ;; let require_maybe_boxed ?cr = Expect_test_helpers_base.require ?cr ~if_false_then_print_s: (lazy [%message "Unboxing may be the default depending on compiler settings. Type \ immediacy for unboxable types that are not explicitly unboxed or boxed \ should be unknown."]) [%here] ;; let%expect_test _ = let module M = struct type t = { foo : unit } [@@deriving typerep] end in require_self_consistent M.typerep_of_t [ { M.foo = () } ]; check_u M.typerep_of_t [ { M.foo = () } ] |> require_maybe_boxed ;; let%expect_test _ = let module M = struct type t = { foo : unit } [@@boxed] [@@deriving typerep] end in require_self_consistent M.typerep_of_t [ { M.foo = () } ]; check_n M.typerep_of_t [ { M.foo = () } ] |> require_boxed ~cr:CR_someday; check_u M.typerep_of_t [ { M.foo = () } ] |> require_maybe_boxed; [%expect {| "Boxed container types should never be immediate" |}] ;; let%expect_test _ = let module M = struct type t = { foo : unit } [@@unboxed] [@@deriving typerep] end in require_self_consistent M.typerep_of_t [ { M.foo = () } ]; check_a M.typerep_of_t [ { M.foo = () } ] |> require_unboxed ~cr:CR_someday; check_u M.typerep_of_t [ { M.foo = () } ] |> require_maybe_boxed; [%expect {| "Unboxed container types should have the immediacy of their contained type" |}] ;; let%expect_test _ = let module M = struct type t = { foo : string } [@@unboxed] [@@deriving typerep] end in require_self_consistent M.typerep_of_t [ { M.foo = "foo" } ]; check_n M.typerep_of_t [ { M.foo = "foo" } ] |> require_unboxed ;; let%test _ = let module M = struct type t = { foo : unit ; bar : unit } [@@deriving typerep] end in check_n M.typerep_of_t [ { M.foo = (); bar = () } ] ;; let%test _ = let module M = struct type ('a, 'b) t = 'a * 'b [@@deriving typerep] end in check_n (M.typerep_of_t imm_t imm_t) [ (), () ] ;; let%test _ = let module M = struct type ('a, 'b, 'c) t = 'a * 'b * 'c [@@deriving typerep] end in check_n (M.typerep_of_t imm_t imm_t imm_t) [ (), (), () ] ;; let%test _ = let module M = struct type ('a, 'b, 'c, 'd) t = 'a * 'b * 'c * 'd [@@deriving typerep] end in check_n (M.typerep_of_t imm_t imm_t imm_t imm_t) [ (), (), (), () ] ;; let%test _ = let module M = struct type ('a, 'b, 'c, 'd, 'e) t = 'a * 'b * 'c * 'd * 'e [@@deriving typerep] end in check_n (M.typerep_of_t imm_t imm_t imm_t imm_t imm_t) [ (), (), (), (), () ] ;; let%test _ = let module M = struct type t = | Foo | Bar of unit [@@deriving typerep] end in check_s M.typerep_of_t [ M.Foo; M.Bar () ] ;; let%test _ = let module M = struct type t = | Foo | Bar | Baz [@@deriving typerep] end in check_a M.typerep_of_t [ M.Foo; M.Bar; M.Baz ] ;; let%test _ = let module M = struct type t = | Foo of unit | Bar of unit | Baz of unit [@@deriving typerep] end in check_n M.typerep_of_t [ M.Foo (); M.Bar (); M.Baz () ] ;; let%expect_test _ = let module M = struct type t = Foo of unit [@@deriving typerep] end in require_self_consistent M.typerep_of_t [ M.Foo () ]; check_u M.typerep_of_t [ M.Foo () ] |> require_maybe_boxed ;; let%expect_test _ = let module M = struct type t = Foo of unit [@@boxed] [@@deriving typerep] end in require_self_consistent M.typerep_of_t [ M.Foo () ]; check_n M.typerep_of_t [ M.Foo () ] |> require_boxed ~cr:CR_someday; check_u M.typerep_of_t [ M.Foo () ] |> require_maybe_boxed; [%expect {| "Boxed container types should never be immediate" |}] ;; let%expect_test _ = let module M = struct type t = Foo of unit [@@unboxed] [@@deriving typerep] end in require_self_consistent M.typerep_of_t [ M.Foo () ]; check_a M.typerep_of_t [ M.Foo () ] |> require_unboxed ~cr:CR_someday; check_u M.typerep_of_t [ M.Foo () ] |> require_maybe_boxed; [%expect {| "Unboxed container types should have the immediacy of their contained type" |}] ;; let%expect_test _ = let module M = struct type t = Foo of string [@@unboxed] [@@deriving typerep] end in require_self_consistent M.typerep_of_t [ M.Foo "foo" ]; check_n M.typerep_of_t [ M.Foo "foo" ] |> require_unboxed ;; let%test _ = let module M = struct type t = [ `Foo | `Bar of unit ] [@@deriving typerep] end in check_s M.typerep_of_t [ `Foo; `Bar () ] ;; let%test _ = let module M = struct type t = [ `Foo | `Bar | `Baz ] [@@deriving typerep] end in check_a M.typerep_of_t [ `Foo; `Bar; `Baz ] ;; let%test _ = let module M = struct type t = [ `Foo of unit | `Bar of unit | `Baz of unit ] [@@deriving typerep] end in check_n M.typerep_of_t [ `Foo (); `Bar (); `Baz () ] ;; let%expect_test _ = let module M = struct type t = [ `Foo of unit ] [@@deriving typerep] end in require_self_consistent M.typerep_of_t [ `Foo () ]; check_n M.typerep_of_t [ `Foo () ] |> require_boxed ;; let%test _ = let module M = struct type 'a t = | Nil | Cons of 'a * 'a t [@@deriving typerep] end in check_s (M.typerep_of_t typerep_of_int) [ M.Nil; M.Cons (1, M.Cons (2, M.Nil)) ] ;; let%test _ = let module M = struct type 'a t = | A | B of 'a t lazy_t | C of 'a * 'a t [@@deriving typerep] end in check_s (M.typerep_of_t typerep_of_int) [ M.A; M.B (lazy M.A); M.C (1, M.A) ] ;; let%test _ = let module M = struct type 'a t = | A | B of ('a t * 'a t) | C of 'a [@@deriving typerep] end in check_s (M.typerep_of_t typerep_of_int) [ M.A; M.B (M.A, M.C 1) ] ;; (* Test the [For_all_parameters] generic witness functors. *) let%test _ = let module M = struct type 'a t = | A | B | C [@@deriving typerep] end in let module _ = Type_immediacy.Always.For_all_parameters_S1 (M) in true ;; let%test _ = let module M = struct type 'a t = 'a option lazy_t [@@deriving typerep] end in let module _ = Type_immediacy.Sometimes.For_all_parameters_S1 (M) in true ;; let%test _ = let module M = struct type 'a t = 'a array lazy_t [@@deriving typerep] end in let module _ = Type_immediacy.Never.For_all_parameters_S1 (M) in true ;; let%test _ = let module M = struct type 'a t = 'a lazy_t [@@deriving typerep] end in try let module _ = Type_immediacy.Sometimes.For_all_parameters_S1 (M) in false with | _ -> (try let module _ = Type_immediacy.Never.For_all_parameters_S1 (M) in false with | _ -> (try let module _ = Type_immediacy.Always.For_all_parameters_S1 (M) in false with | _ -> true)) ;; end) ;; core-0.15.0/core/test/src/type_immediacy_witness_unit_tests.mli000066400000000000000000000000551420273305200247630ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/core/top/000077500000000000000000000000001420273305200142555ustar00rootroot00000000000000core-0.15.0/core/top/core_install_printers.ml000066400000000000000000000011271420273305200212140ustar00rootroot00000000000000open Core let printers = Pretty_printer.all () let eval_string ?(print_outcome = false) ?(err_formatter = Format.err_formatter) str = let lexbuf = Lexing.from_string str in let phrase = !Toploop.parse_toplevel_phrase lexbuf in Toploop.execute_phrase print_outcome err_formatter phrase let rec install_printers = function | [] -> true | printer :: printers -> let cmd = Printf.sprintf "#install_printer %s;;" printer in eval_string cmd && install_printers printers let () = if not (install_printers printers) then Format.eprintf "Problem installing Core-printers@." core-0.15.0/core/top/core_top.mllib000066400000000000000000000001521420273305200171060ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: d4446f978f17aa1e337a53d165c34e8e) Core_install_printers # OASIS_STOP core-0.15.0/core/top/dune000066400000000000000000000002041420273305200151270ustar00rootroot00000000000000(library (name core_top) (public_name core.top) (modes byte) (libraries compiler-libs.toplevel core) (preprocess no_preprocessing))core-0.15.0/dune-project000066400000000000000000000000201420273305200150350ustar00rootroot00000000000000(lang dune 1.10)core-0.15.0/validate/000077500000000000000000000000001420273305200143145ustar00rootroot00000000000000core-0.15.0/validate/src/000077500000000000000000000000001420273305200151035ustar00rootroot00000000000000core-0.15.0/validate/src/dune000066400000000000000000000001431420273305200157570ustar00rootroot00000000000000(library (name validate) (public_name core.validate) (preprocess (pps ppx_jane)) (libraries base))core-0.15.0/validate/src/validate.ml000066400000000000000000000106221420273305200172270ustar00rootroot00000000000000open Base (** Each single_error is a path indicating the location within the datastructure in question that is being validated, along with an error message. *) type single_error = { path : string list ; error : Error.t } type t = single_error list type 'a check = 'a -> t let pass : t = [] let fails message a sexp_of_a = [ { path = []; error = Error.create message a sexp_of_a } ] ;; let fail message = [ { path = []; error = Error.of_string message } ] let failf format = Printf.ksprintf fail format let fail_s sexp = [ { path = []; error = Error.create_s sexp } ] let combine t1 t2 = t1 @ t2 let of_list = List.concat let name name t = match t with | [] -> [] (* when successful, avoid the allocation of a closure for [~f], below *) | _ -> List.map t ~f:(fun { path; error } -> { path = name :: path; error }) ;; let name_list n l = name n (of_list l) let fail_fn message _ = fail message let pass_bool (_ : bool) = pass let pass_unit (_ : unit) = pass let protect f v = try f v with | exn -> fail_s (Sexp.message "Exception raised during validation" [ "", sexp_of_exn exn ]) ;; let try_with f = protect (fun () -> f (); pass) () ;; let path_string path = String.concat ~sep:"." path let errors t = List.map t ~f:(fun { path; error } -> Error.to_string_hum (Error.tag error ~tag:(path_string path))) ;; let result_fail t = Or_error.error "validation errors" (List.map t ~f:(fun { path; error } -> path_string path, error)) [%sexp_of: (string * Error.t) List.t] [@@cold] ;; (** [result] is carefully implemented so that it can be inlined -- calling [result_fail], which is not inlineable, is key to this. *) let result t = if List.is_empty t then Ok () else result_fail t let maybe_raise t = Or_error.ok_exn (result t) let valid_or_error check x = Or_error.map (result (protect check x)) ~f:(fun () -> x) let field_direct check fld _record v = let result = protect check v in name (Field.name fld) result ;; let field check record fld = let v = Field.get fld record in field_direct check fld record v ;; let field_folder check record = (); fun acc fld -> field check record fld :: acc ;; let field_direct_folder check = Staged.stage (fun acc fld record v -> match field_direct check fld record v with | [] -> acc (* Avoid allocating a new list in the success case *) | result -> result :: acc) ;; let all checks v = let rec loop checks v errs = match checks with | [] -> errs | check :: checks -> (match protect check v with | [] -> loop checks v errs | err -> loop checks v (err :: errs)) in of_list (List.rev (loop checks v [])) ;; let of_result f = protect (fun v -> match f v with | Ok () -> pass | Error error -> fail error) ;; let of_error f = protect (fun v -> match f v with | Ok () -> pass | Error error -> [ { path = []; error } ]) ;; let booltest f ~if_false = protect (fun v -> if f v then pass else fail if_false) let pair ~fst ~snd (fst_value, snd_value) = of_list [ name "fst" (protect fst fst_value); name "snd" (protect snd snd_value) ] ;; let list_indexed check list = List.mapi list ~f:(fun i el -> name (Int.to_string (i + 1)) (protect check el)) |> of_list ;; let list ~name:extract_name check list = List.map list ~f:(fun el -> match protect check el with | [] -> [] | t -> (* extra level of protection in case extract_name throws an exception *) protect (fun t -> name (extract_name el) t) t) |> of_list ;; let alist ~name f list' = list (fun (_, x) -> f x) list' ~name:(fun (key, _) -> name key) let first_failure t1 t2 = if List.is_empty t1 then t2 else t1 let of_error_opt = function | None -> pass | Some error -> fail error ;; let bounded ~name ~lower ~upper ~compare x = match Maybe_bound.compare_to_interval_exn ~lower ~upper ~compare x with | In_range -> pass | Below_lower_bound -> (match lower with | Unbounded -> assert false | Incl incl -> fail (Printf.sprintf "value %s < bound %s" (name x) (name incl)) | Excl excl -> fail (Printf.sprintf "value %s <= bound %s" (name x) (name excl))) | Above_upper_bound -> (match upper with | Unbounded -> assert false | Incl incl -> fail (Printf.sprintf "value %s > bound %s" (name x) (name incl)) | Excl excl -> fail (Printf.sprintf "value %s >= bound %s" (name x) (name excl))) ;; module Infix = struct let ( ++ ) t1 t2 = combine t1 t2 end core-0.15.0/validate/src/validate.mli000066400000000000000000000130601420273305200173770ustar00rootroot00000000000000(** A module for organizing validations of data structures. Allows standardized ways of checking for conditions, and keeps track of the location of errors by keeping a path to each error found. Thus, if you were validating the following datastructure: {[ { foo = 3; bar = { snoo = 34.5; blue = Snoot -6; } } ]} One might end up with an error with the error path: {v bar.blue.Snoot : value -6 <= bound 0 v} By convention, the validations for a type defined in module [M] appear in module [M], and have their name prefixed by [validate_]. E.g., [Int.validate_positive]. Here's an example of how you would use [validate] with a record: {[ type t = { foo: int; bar: float; } [@@deriving fields] let validate t = let module V = Validate in let w check = V.field check t in Fields.to_list ~foo:(w Int.validate_positive) ~bar:(w Float.validate_non_negative) |> V.of_list ]} And here's an example of how you would use it with a variant type: {[ type t = | Foo of int | Bar of (float * int) | Snoo of Floogle.t let validate = function | Foo i -> V.name "Foo" (Int.validate_positive i) | Bar p -> V.name "Bar" (V.pair ~fst:Float.validate_positive ~snd:Int.validate_non_negative p) | Snoo floogle -> V.name "Snoo" (Floogle.validate floogle) ]} *) open Base (** The result of a validation. This effectively contains the list of errors, qualified by their location path *) type t (** To make function signatures easier to read. *) type 'a check = 'a -> t (** A result containing no errors. *) val pass : t (** A result containing a single error. *) val fail : string -> t val fails : string -> 'a -> ('a -> Sexp.t) -> t (** This can be used with the [%sexp] extension. *) val fail_s : Sexp.t -> t (** Like [sprintf] or [failwithf] but produces a [t] instead of a string or exception. *) val failf : ('a, unit, string, t) format4 -> 'a val combine : t -> t -> t (** Combines multiple results, merging errors. *) val of_list : t list -> t (** Extends location path by one name. *) val name : string -> t -> t val name_list : string -> t list -> t (** [fail_fn err] returns a function that always returns fail, with [err] as the error message. (Note that there is no [pass_fn] so as to discourage people from ignoring the type of the value being passed unconditionally irrespective of type.) *) val fail_fn : string -> _ check (** Checks for unconditionally passing a bool. *) val pass_bool : bool check (** Checks for unconditionally passing a unit. *) val pass_unit : unit check (** [protect f x] applies the validation [f] to [x], catching any exceptions and returning them as errors. *) val protect : 'a check -> 'a check (** [try_with f] runs [f] catching any exceptions and returning them as errors. *) val try_with : (unit -> unit) -> t val result : t -> unit Or_error.t (** Returns a list of formatted error strings, which include both the error message and the path to the error. *) val errors : t -> string list (** If the result contains any errors, then raises an exception with a formatted error message containing a message for every error. *) val maybe_raise : t -> unit (** Returns an error if validation fails. *) val valid_or_error : 'a check -> 'a -> 'a Or_error.t (** Used for validating an individual field. Should be used with [Fields.to_list]. *) val field : 'a check -> 'record -> ([> `Read ], 'record, 'a) Field.t_with_perm -> t (** Used for validating an individual field. Should be used with [Fields.Direct.to_list]. *) val field_direct : 'a check -> ([> `Read ], 'record, 'a) Field.t_with_perm -> 'record -> 'a -> t (** Creates a function for use in a [Fields.fold]. *) val field_folder : 'a check -> 'record -> t list -> ([> `Read ], 'record, 'a) Field.t_with_perm -> t list (** Creates a function for use in a [Fields.Direct.fold]. *) val field_direct_folder : 'a check -> (t list -> ([> `Read ], 'record, 'a) Field.t_with_perm -> 'record -> 'a -> t list) Staged.t (** Combines a list of validation functions into one that does all validations. *) val all : 'a check list -> 'a check (** Creates a validation function from a function that produces a [Result.t]. *) val of_result : ('a -> (unit, string) Result.t) -> 'a check val of_error : ('a -> unit Or_error.t) -> 'a check (** Creates a validation function from a function that produces a bool. *) val booltest : ('a -> bool) -> if_false:string -> 'a check (** Validation functions for particular data types. *) val pair : fst:'a check -> snd:'b check -> ('a * 'b) check (** Validates a list, naming each element by its position in the list (where the first position is 1, not 0). *) val list_indexed : 'a check -> 'a list check (** Validates a list, naming each element using a user-defined function for computing the name. *) val list : name:('a -> string) -> 'a check -> 'a list check val first_failure : t -> t -> t val of_error_opt : string option -> t (** Validates an association list, naming each element using a user-defined function for computing the name. *) val alist : name:('a -> string) -> 'b check -> ('a * 'b) list check val bounded : name:('a -> string) -> lower:'a Maybe_bound.t -> upper:'a Maybe_bound.t -> compare:('a -> 'a -> int) -> 'a check module Infix : sig (** Infix operator for [combine] above. *) val ( ++ ) : t -> t -> t end core-0.15.0/validate/test/000077500000000000000000000000001420273305200152735ustar00rootroot00000000000000core-0.15.0/validate/test/dune000066400000000000000000000001571420273305200161540ustar00rootroot00000000000000(library (name validate_test) (libraries base expect_test_helpers_core validate) (preprocess (pps ppx_jane)))core-0.15.0/validate/test/test_validate.ml000066400000000000000000000041661420273305200204640ustar00rootroot00000000000000open! Base open! Validate open Expect_test_helpers_core let print t = List.iter (errors t) ~f:Caml.print_endline let%expect_test "Validate.all" = print (all [ (fun _ -> fail "a") ; (fun _ -> pass) ; (fun _ -> fail "b") ; (fun _ -> pass) ; (fun _ -> fail "c") ] ()); [%expect {| ("" a) ("" b) ("" c) |}] ;; let%expect_test _ = print (first_failure pass (fail "foo")); [%expect {| ("" foo) |}] ;; let%expect_test _ = print (first_failure (fail "foo") (fail "bar")); [%expect {| ("" foo) |}] ;; let two_errors = of_list [ fail "foo"; fail "bar" ] let%expect_test _ = print (first_failure two_errors (fail "snoo")); [%expect {| ("" foo) ("" bar) |}] ;; let%expect_test _ = print (first_failure (fail "snoo") two_errors); [%expect {| ("" snoo) |}] ;; let%expect_test _ = let v () = if true then failwith "This unit validation raises"; Validate.pass in print (protect v ()); [%expect {| ("" ("Exception raised during validation" (Failure "This unit validation raises"))) |}] ;; let%expect_test "try_with" = let v () = failwith "this function raises" in print (try_with v); [%expect {| ("" ("Exception raised during validation" (Failure "this function raises"))) |}] ;; type t = { x : bool } [@@deriving fields] let%expect_test "typical use of Validate.field_direct_folder doesn't allocate on success" = let validate_x = Staged.unstage (Validate.field_direct_folder Validate.pass_bool) in let validate t = Fields.Direct.fold t ~init:[] ~x:validate_x |> Validate.of_list |> Validate.result in let t = { x = true } in require_no_allocation [%here] (fun () -> ignore (validate t : unit Or_error.t)) ;; let%expect_test "Validate.all doesn't allocate on success" = let checks = List.init 5 ~f:(Fn.const Validate.pass_bool) in require_no_allocation [%here] (fun () -> ignore (Validate.all checks true : Validate.t)) ;; let%expect_test "Validate.combine doesn't allocate on success" = require_no_allocation [%here] (fun () -> ignore (Validate.combine Validate.pass Validate.pass : Validate.t)) ;; core-0.15.0/validate/test/test_validate.mli000066400000000000000000000000551420273305200206260ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) core-0.15.0/validate/test/validate_fields_folder.mlt000066400000000000000000000042641420273305200224710ustar00rootroot00000000000000open! Base let unstage = Staged.unstage (* Regression tests to ensure that [Validate.field], [Validate.field_folder], and [Validate.field_direct_folder] continue to work with private record types. *) module Fold_with_private (M : sig type t = private { a : int } [@@deriving fields] end) : sig val validate : M.t -> Validate.t end = struct open M let validate t = let w f = Validate.field_folder f t in Fields.fold ~init:[] ~a:(w (fun _ -> Validate.pass)) |> Validate.of_list ;; end [%%expect {| |}] module Fold_regular (M : sig type t = { a : int } [@@deriving fields] end) : sig val validate : M.t -> Validate.t end = struct open M let validate t = let w f = Validate.field_folder f t in Fields.fold ~init:[] ~a:(w (fun _ -> Validate.pass)) |> Validate.of_list ;; end [%%expect {| |}] module Fold_direct_private (M : sig type t = private { a : int } [@@deriving fields] end) : sig val validate : M.t -> Validate.t end = struct open M let validate t = let w f = unstage (Validate.field_direct_folder f) in Fields.Direct.fold t ~init:[] ~a:(w (fun _ -> Validate.pass)) |> Validate.of_list ;; end [%%expect {| |}] module Fold_direct_regular (M : sig type t = { a : int } [@@deriving fields] end) : sig val validate : M.t -> Validate.t end = struct open M let validate t = let w f = unstage (Validate.field_direct_folder f) in Fields.Direct.fold t ~init:[] ~a:(w (fun _ -> Validate.pass)) |> Validate.of_list ;; end [%%expect {| |}] module Validate_field_private (M : sig type t = private { a : int } [@@deriving fields] end) : sig val validate : M.t -> Validate.t end = struct open M let validate t = let w check acc field = Validate.field check t field :: acc in Fields.fold ~init:[] ~a:(w (fun _ -> Validate.pass)) |> Validate.of_list ;; end [%%expect {| |}] module Validate_field (M : sig type t = { a : int } [@@deriving fields] end) : sig val validate : M.t -> Validate.t end = struct open M let validate t = let w check acc field = Validate.field check t field :: acc in Fields.fold ~init:[] ~a:(w (fun _ -> Validate.pass)) |> Validate.of_list ;; end [%%expect {| |}]