diff options
| author | Julien Puydt <jpuydt@debian.org> | 2022-08-15 15:59:36 +0200 |
|---|---|---|
| committer | Julien Puydt <jpuydt@debian.org> | 2022-08-15 15:59:36 +0200 |
| commit | 43049db546a976977e3bc53e756766d79cf380fb (patch) | |
| tree | 74f48217c027eb4f1d8e99bcfd1f84da199d9058 | |
| parent | 786b883d8b19fa563510adf695eb57cf944b57fd (diff) | |
| parent | 085815ac36542b5fd97e45747154d4bd851d7510 (diff) | |
Update upstream source from tag 'upstream/0.15.0'
Update to upstream version '0.15.0'
with Debian dir 30de80b031d3890239e9d2d53aad13a1d5856e12
228 files changed, 9338 insertions, 5889 deletions
@@ -1,6 +1,6 @@ The MIT License -Copyright (c) 2016--2020 Jane Street Group, LLC <opensource@janestreet.com> +Copyright (c) 2016--2022 Jane Street Group, LLC <opensource@janestreet.com> Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -34,12 +34,6 @@ In order to access these values, one must use the =Caml= library, which re-exports them all through the toplevel name =Caml=: =Caml.String=, =Caml.print_string=, ... -The recommended way to build code using Base is as follows: - -#+begin_src ocaml -$ ocamlc -open Base -#+end_src - ** Differences between Base and the OCaml standard library Programmers who are used to the OCaml standard library should read @@ -62,10 +56,10 @@ representation of values. Since these are often error-prone, i.e. they don't correspond to what the user expects, they are not exposed directly by Base. -To use polymorphic comparison with Base, one should use the -=Polymorphic_compare= module. The default comparison operators exposed -by Base are the integer ones, just like the default arithmetic -operators are the integer ones. +To use polymorphic comparison with Base, one should use the =Poly= +module. The default comparison operators exposed by Base are the +integer ones, just like the default arithmetic operators are the +integer ones. The recommended way to compare arbitrary complex data structures is to use the specific =compare= functions. For instance: @@ -131,6 +125,12 @@ Things are not yet setup in the git repository to make it convenient to change types and update the generated code, but they will be setup soon. +** OCaml Version Support + +Base will maintain compatibility with the latest OCaml release, and the three +prior minor version releases. Because of this, there will be a lag of four +minor versions before features introduced in the Stdlib will reach Base. + ** Base coding rules There are a few coding rules across the code base that are enforced by @@ -162,26 +162,55 @@ The Base specific coding rules are checked by =ppx_base_lint=, in the These checks are currently not run by =dune=, but it will soon get a =-dev= flag to run them automatically. -** Roadmap +** Sexp (de-)serializers + +Most types in Base have ~sexp_of_t~ and ~t_of_sexp~ functions for converting +between values of that type and their sexp representations. -Following is the current plan for a stable version 1 of Base. +One pair of functions deserves special attention: ~String.sexp_of_t~ and +~String.t_of_sexp~. These functions have the same types as ~Sexp.of_string~ and +~Sexp.to_string~ but very different behavior. -*** Add more integer types +~String.sexp_of_t~ and ~String.t_of_sexp~ are used to encode and decode strings +"embedded" in a sexp representation. On the other hand, ~Sexp.of_string~ and +~Sexp.to_string~ are used to encode and decode the textual form of +s-expressions. -Add support for ={,u}int{8,16,32,64}=. These are always useful when -implementing binary protocols. +The following example demonstrates the two pairs of functions in action: -Initially they should be implemented with C stubs and eventually we -should propose their inclusion in the compiler. +#+begin_src ocaml + open! Base + open! Stdio + + (* Embed a string in a sexp *) + + let example_sexp : Sexp.t = List.sexp_of_t String.sexp_of_t [ "hello"; "world" ] + + let () = + assert (Sexp.equal example_sexp (Sexp.List [ Sexp.Atom "hello"; Sexp.Atom "world" ])) + ;; -*** 80 columns limit + let () = + assert ( + List.equal + String.equal + [ "hello"; "world" ] + (List.t_of_sexp String.t_of_sexp example_sexp)) + ;; -Currently lines in Base are limited to a maximum width of 90 -characters. To make things more standard, we should use an 80 columns -limit. The only thing needed for this is to extend the style checker -to enforce a maximum line width. + (* Embed a sexp in text (string) *) -*** Improve the generated code + let write_sexp_to_file sexp = + Out_channel.write_all "/tmp/file" ~data:(Sexp.to_string example_sexp) + ;; -Improve our code generators to produce code that looks more like -hand-written code. + (* /tmp/file now contains: + + {v + (hello world) + v} *) + + let () = + assert (Sexp.equal example_sexp (Sexp.of_string (In_channel.read_all "/tmp/file"))) + ;; +#+end_src @@ -1,7 +1,7 @@ opam-version: "2.0" -version: "v0.14.0" -maintainer: "opensource@janestreet.com" -authors: ["Jane Street Group, LLC <opensource@janestreet.com>"] +version: "v0.15.0" +maintainer: "Jane Street developers" +authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/base" bug-reports: "https://github.com/janestreet/base/issues" dev-repo: "git+https://github.com/janestreet/base.git" @@ -11,8 +11,8 @@ build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ - "ocaml" {>= "4.07.0"} - "sexplib0" {>= "v0.14" & < "v0.15"} + "ocaml" {>= "4.10.0"} + "sexplib0" {>= "v0.15" & < "v0.16"} "dune" {>= "2.0.0"} "dune-configurator" ] diff --git a/compiler-stdlib/gen/dune b/compiler-stdlib/gen/dune index 0f60968..693a724 100644 --- a/compiler-stdlib/gen/dune +++ b/compiler-stdlib/gen/dune @@ -1,3 +1 @@ -(executables (names gen) - (libraries compiler-libs.common compiler-libs.bytecomp) - (preprocess no_preprocessing))
\ No newline at end of file +(executables (names gen) (libraries) (preprocess no_preprocessing))
\ No newline at end of file diff --git a/compiler-stdlib/gen/gen.ml b/compiler-stdlib/gen/gen.ml index 10f055f..06c3c24 100644 --- a/compiler-stdlib/gen/gen.ml +++ b/compiler-stdlib/gen/gen.ml @@ -3,8 +3,6 @@ open StdLabels module Ocaml_version : sig type t - val v407 : t - val v408 : t val v412 : t val v414 : t val current : t @@ -26,8 +24,6 @@ end = struct | _ -> failwith (Printf.sprintf "Invalid ocaml version %S" s) ;; - let v407 = parse "4.07" - let v408 = parse "4.08" let v412 = parse "4.12" let v414 = parse "4.14" let current = parse Sys.ocaml_version @@ -40,50 +36,16 @@ end = struct end let () = - let ocaml_where, oc = + let oc = match Sys.argv with - | [| _; "-ocaml-where"; ocaml_where; "-o"; fn |] -> ocaml_where, open_out fn + | [| _; "-o"; fn |] -> open_out fn | _ -> failwith "bad command line arguments" in let pr fmt = Printf.fprintf oc (fmt ^^ "\n") in pr "(* This file is automatically generated *)"; pr ""; - if Ocaml_version.(compare current v407) >= 0 - then pr "include Stdlib" - else ( - (* The cma format is documented in typing/cmo_format.mli in the compiler sources *) - let ic = - let ( ^/ ) = Filename.concat in - try open_in_bin (ocaml_where ^/ "stdlib" ^/ "stdlib.cma") with - | Sys_error _ -> open_in_bin (ocaml_where ^/ "stdlib.cma") - in - let len_magic_number = String.length Config.cma_magic_number in - let magic_number = really_input_string ic len_magic_number in - assert (magic_number = Config.cma_magic_number); - let toc_pos = input_binary_int ic in - seek_in ic toc_pos; - let toc : Cmo_format.library = input_value ic in - close_in ic; - let units = - List.map toc.lib_units ~f:(fun cu -> cu.Cmo_format.cu_name) - |> List.sort ~cmp:String.compare - in - let max_len = - List.fold_left units ~init:0 ~f:(fun acc unit -> max acc (String.length unit)) - in - List.iter units ~f:(fun u -> pr "module %-*s = %s" max_len u u); - pr ""; - pr "include Pervasives"); + pr "include Stdlib"; pr ""; - if Ocaml_version.(compare current v407) < 0 then pr "module Float = struct end"; - if Ocaml_version.(compare current v408) < 0 - then ( - pr "module Bool = struct end"; - pr "module Int = struct end"; - pr "module Option = struct end"; - pr "module Result = struct end"; - pr "module Unit = struct end"; - pr "module Fun = struct end"); if Ocaml_version.(compare current v412) < 0 then ( pr "module Atomic = struct end"; @@ -91,7 +53,5 @@ let () = if Ocaml_version.(compare current v414) < 0 then ( pr "module In_channel = struct end"; - pr "module Out_channel = struct end"); - pr ""; - pr "exception Not_found = Not_found" + pr "module Out_channel = struct end") ;; diff --git a/compiler-stdlib/src/dune b/compiler-stdlib/src/dune index f0125b1..70cb249 100644 --- a/compiler-stdlib/src/dune +++ b/compiler-stdlib/src/dune @@ -1,4 +1,3 @@ (library (name caml) (public_name base.caml) (preprocess no_preprocessing)) -(rule (targets caml.ml) - (action (run ../gen/gen.exe -ocaml-where %{ocaml_where} -o %{targets}))) +(rule (targets caml.ml) (action (run ../gen/gen.exe -o %{targets})))
\ No newline at end of file diff --git a/hash_types/test/dune b/hash_types/test/dune index ceac954..798afd3 100644 --- a/hash_types/test/dune +++ b/hash_types/test/dune @@ -1,3 +1,2 @@ (library (name base_internalhash_types_test) - (libraries base expect_test_helpers_core stdio) - (preprocess (pps ppx_jane -allow-unannotated-ignores)))
\ No newline at end of file + (libraries base expect_test_helpers_core stdio) (preprocess (pps ppx_jane)))
\ No newline at end of file @@ -1,3 +1,3 @@ (library (name ppx_base_lint) (kind ppx_rewriter) - (libraries compiler-libs.common base ppxlib ppx_cold ppx_js_style) + (libraries compiler-libs.common base ppxlib ppx_cold) (preprocess no_preprocessing))
\ No newline at end of file diff --git a/lint/ppx_base_lint.ml b/lint/ppx_base_lint.ml index aade12b..459633f 100644 --- a/lint/ppx_base_lint.ml +++ b/lint/ppx_base_lint.ml @@ -53,17 +53,11 @@ let print_payload ppf = function let remove_loc = object inherit Ast_traverse.map - method! location _ = Location.none - method! location_stack _ = [] end ;; -(* Disable this check given that in base we replace [@cold] by [@cold] [@inline never] - ... in the source code *) -let () = Ppx_js_style.cold_instead_of_inline_never := false - let check current_module = let zero_modules = zero_modules () in object diff --git a/shadow-stdlib/gen/gen.ml b/shadow-stdlib/gen/gen.ml index 33e8a09..9ddc8c7 100644 --- a/shadow-stdlib/gen/gen.ml +++ b/shadow-stdlib/gen/gen.ml @@ -1,12 +1,16 @@ open StdLabels let () = - let cmi_fn, oc = + (* -permissive indicates that we should tolerate additions to stdlib. + It's [true] in public-release so that new versions of the stdlib can be compatible + with base, but it should be [false] internally so that we remember to + consider implementing the equivalents in base. *) + let permissive, cmi_fn, oc = match Sys.argv with - | [| _; "-caml-cmi"; cmi_fn; "-o"; fn |] -> cmi_fn, open_out fn - | [| _; "-caml-cmi"; cmi_fn1; cmi_fn2; "-o"; fn |] -> + | [| _; "-caml-cmi"; cmi_fn; "-o"; fn |] -> false, cmi_fn, open_out fn + | [| _; "-caml-cmi"; "-permissive"; cmi_fn1; cmi_fn2; "-o"; fn |] -> let cmi_fn = if Sys.file_exists cmi_fn1 then cmi_fn1 else cmi_fn2 in - cmi_fn, open_out fn + true, cmi_fn, open_out fn | _ -> failwith "bad command line arguments" in try @@ -19,6 +23,7 @@ let () = let s = Buffer.contents buf in let lines = Str.split (Str.regexp "\n") s in Printf.fprintf oc "[@@@warning \"-3\"]\n\n"; + Mapper.permissive := permissive; List.iter lines ~f:(fun line -> let repl = Mapper.line (Lexing.from_string line) in if repl <> "" then Printf.fprintf oc "%s\n\n" repl); diff --git a/shadow-stdlib/gen/mapper.mll b/shadow-stdlib/gen/mapper.mll index 382074d..a1d7c23 100644 --- a/shadow-stdlib/gen/mapper.mll +++ b/shadow-stdlib/gen/mapper.mll @@ -58,17 +58,66 @@ type replacement = | Repl_text of string | Approx of string +let permissive = ref false + let val_replacement = function + | "( ! )" -> No_equivalent | "( != )" -> Repl "not (phys_equal ...)" - | "( == )" -> Repl "phys_equal" + | "( & )" -> No_equivalent + | "( && )" -> No_equivalent + | "( * )" -> No_equivalent | "( ** )" -> Repl "**." - | "( mod )" -> Repl_text "Use (%), which has slightly different \ - semantics, or Int.rem which is equivalent" + | "( *. )" -> No_equivalent + | "( + )" -> No_equivalent + | "( +. )" -> No_equivalent + | "( - )" -> No_equivalent + | "( -. )" -> No_equivalent + | "( / )" -> No_equivalent + | "( /. )" -> No_equivalent + | "( := )" -> No_equivalent + | "( < )" -> No_equivalent + | "( <= )" -> No_equivalent + | "( <> )" -> No_equivalent + | "( = )" -> No_equivalent + | "( == )" -> Repl "phys_equal" + | "( > )" -> No_equivalent + | "( >= )" -> No_equivalent + | "( @ )" -> No_equivalent + | "( @@ )" -> No_equivalent + | "( ^ )" -> No_equivalent + | "( ^^ )" -> No_equivalent + | "( asr )" -> No_equivalent + | "( land )" -> No_equivalent + | "( lor )" -> No_equivalent + | "( lsl )" -> No_equivalent + | "( lsr )" -> No_equivalent + | "( lxor )" -> No_equivalent + | "( mod )" -> Repl_text "Use (%), which has slightly different semantics, or Int.rem which is equivalent" + | "( or )" -> No_equivalent + | "( |> )" -> No_equivalent + | "( || )" -> No_equivalent + | "( ~+ )" -> No_equivalent + | "( ~+. )" -> No_equivalent + | "( ~- )" -> No_equivalent + | "( ~-. )" -> No_equivalent + | "__FILE__" -> No_equivalent + | "__FUNCTION__" -> No_equivalent + | "__LINE__" -> No_equivalent + | "__LINE_OF__" -> No_equivalent + | "__LOC__" -> No_equivalent + | "__LOC_OF__" -> No_equivalent + | "__MODULE__" -> No_equivalent + | "__POS__" -> No_equivalent + | "__POS_OF__" -> No_equivalent + | "abs" -> No_equivalent + | "abs_float" -> No_equivalent | "acos" -> Repl "Float.acos" | "asin" -> Repl "Float.asin" + | "at_exit" -> No_equivalent | "atan" -> Repl "Float.atan" | "atan2" -> Repl "Float.atan2" | "bool_of_string" -> Repl "Bool.of_string" + | "bool_of_string_opt" -> No_equivalent | "ceil" -> Repl "Float.round_up" | "char_of_int" -> Repl "Char.of_int_exn" | "classify_float" -> Repl "Float.classify" @@ -76,24 +125,32 @@ let val_replacement = function | "close_in_noerr" -> Repl "Stdio.In_channel.close" | "close_out" -> Repl "Stdio.Out_channel.close" | "close_out_noerr" -> Repl "Stdio.Out_channel.close" + | "compare" -> No_equivalent | "copysign" -> Repl "Float.copysign" | "cos" -> Repl "Float.cos" | "cosh" -> Repl "Float.cosh" | "decr" -> Repl "Int.decr" + | "do_at_exit" -> No_equivalent | "epsilon_float" -> Repl "Float.epsilon_float" + | "exit" -> No_equivalent | "exp" -> Repl "Float.exp" | "expm1" -> Repl "Float.expm1" + | "failwith" -> No_equivalent | "float" -> Repl "Float.of_int" | "float_of_int" -> Repl "Float.of_int" | "float_of_string" -> Repl "Float.of_string" + | "float_of_string_opt" -> No_equivalent | "floor" -> Repl "Float.round_down" | "flush" -> Repl "Stdio.Out_channel.flush" | "flush_all" -> No_equivalent + | "format_of_string" -> No_equivalent | "frexp" -> Repl "Float.frexp" + | "fst" -> No_equivalent | "hypot" -> Repl "Float.hypot" + | "ignore" -> No_equivalent | "in_channel_length" -> Repl "Stdio.In_channel.length" - | "infinity" -> Repl "Float.infinity" | "incr" -> Repl "Int.incr" + | "infinity" -> Repl "Float.infinity" | "input" -> Repl "Stdio.In_channel.input" | "input_binary_int" -> Repl "Stdio.In_channel.input_binary_int" | "input_byte" -> Repl "Stdio.In_channel.input_byte" @@ -103,18 +160,24 @@ let val_replacement = function | "int_of_char" -> Repl "Char.to_int" | "int_of_float" -> Repl "Int.of_float" | "int_of_string" -> Repl "Int.of_string" + | "int_of_string_opt" -> No_equivalent + | "invalid_arg" -> No_equivalent | "ldexp" -> Repl "Float.ldexp" + | "lnot" -> No_equivalent | "log" -> Repl "Float.log" | "log10" -> Repl "Float.log10" | "log1p" -> Repl "Float.log1p" + | "max" -> No_equivalent | "max_float" -> Repl "Float.max_finite_value" | "max_int" -> Repl "Int.max_value" + | "min" -> No_equivalent | "min_float" -> Repl "Float.min_positive_normal_value" | "min_int" -> Repl "Int.min_value" | "mod_float" -> Repl "Float.mod_float" | "modf" -> Repl "Float.modf" | "nan" -> Repl "Float.nan" | "neg_infinity" -> Repl "Float.neg_infinity" + | "not" -> No_equivalent | "open_in" -> Repl "Stdio.In_channel.create" | "open_in_bin" -> Repl "Stdio.In_channel.create" | "open_in_gen" -> No_equivalent @@ -147,31 +210,44 @@ let val_replacement = function | "print_int" -> Repl "Stdio.eprintf \"%d\"" | "print_newline" -> Repl "Stdio.eprintf \"\n%!\"" | "print_string" -> Repl "Stdio.Out_channel.output_string Stdio.stdout" + | "raise" -> No_equivalent + | "raise_notrace" -> No_equivalent | "read_float" -> No_equivalent + | "read_float_opt" -> No_equivalent | "read_int" -> No_equivalent + | "read_int_opt" -> No_equivalent | "read_line" -> Repl "Stdio.In_channel.input_line" | "really_input" -> Repl "Stdio.In_channel.really_input" | "really_input_string" -> Approx "Stdio.In_channel" + | "ref" -> No_equivalent | "seek_in" -> Repl "Stdio.In_channel.seek" | "seek_out" -> Repl "Stdio.Out_channel.seek" | "set_binary_mode_in" -> Repl "Stdio.In_channel.set_binary_mode" | "set_binary_mode_out" -> Repl "Stdio.Out_channel.set_binary_mode" | "sin" -> Repl "Float.sin" | "sinh" -> Repl "Float.sinh" + | "snd" -> No_equivalent | "sqrt" -> Repl "Float.sqrt" | "stderr" -> Repl "Stdio.stderr" | "stdin" -> Repl "Stdio.stdin" | "stdout" -> Repl "Stdio.stdout" | "string_of_bool" -> Repl "Bool.to_string" | "string_of_float" -> Repl "Float.to_string" + | "string_of_format" -> No_equivalent | "string_of_int" -> Repl "Int.to_string" | "succ" -> Repl "Int.succ" | "tan" -> Repl "Float.tan" | "tanh" -> Repl "Float.tanh" | "truncate" -> Repl "Int.of_float" - (* This is documented as DO-NOT-USE in the stdlib *) | "unsafe_really_input" -> No_equivalent - | _ -> No_equivalent + | "valid_float_lexem" -> No_equivalent + | symbol -> + if !permissive then No_equivalent + else + failwith + (sprintf + "Consider adding to [Base] an equivalent for symbol %S defined in stdlib" + symbol) ;; let exception_replacement = function @@ -184,14 +260,13 @@ raise [Not_found_s] with an informative error message") | _ -> None let type_replacement = function - | "result" -> Some (Repl "Result.t") | "in_channel" -> Some (Repl "Stdio.In_channel.t") | "out_channel" -> Some (Repl "Stdio.Out_channel.t") - | _ -> None + | "result" -> Some (Repl "Result.t") + | _ -> None ;; let module_replacement = function - | "Printexc" -> Some (Repl_text "Use [Exn] or [Backtrace] instead") | "Format" -> let repl_text = "[Base] doesn't export a [Format] module, although the \n\ @@ -199,10 +274,11 @@ let module_replacement = function for interaction with other libraries" in Some (Repl_text repl_text) - | "Fun" -> Some (Repl "Fn") - | "Gc" -> Some No_equivalent - | "Seq" -> Some (Approx "Sequence") - | _ -> None + | "Fun" -> Some (Repl "Fn") + | "Gc" -> Some No_equivalent + | "Printexc" -> Some (Repl_text "Use [Exn] or [Backtrace] instead") + | "Seq" -> Some (Approx "Sequence") + | _ -> None let replace ~is_exn id replacement line = let msg = diff --git a/shadow-stdlib/src/dune b/shadow-stdlib/src/dune index 5a8571d..42926c4 100644 --- a/shadow-stdlib/src/dune +++ b/shadow-stdlib/src/dune @@ -1,8 +1,8 @@ (library (name shadow_stdlib) (public_name base.shadow_stdlib) (libraries caml) (preprocess no_preprocessing)) -(rule (targets shadow_stdlib.mli) - (deps ../../compiler-stdlib/src/caml.cma) +(rule (targets shadow_stdlib.mli) (deps ../../compiler-stdlib/src/caml.cma) (action - (run ../gen/gen.exe -caml-cmi ../../compiler-stdlib/src/.caml.objs/caml.cmi - ../../compiler-stdlib/src/.caml.objs/byte/caml.cmi -o %{targets}))) + (run ../gen/gen.exe -caml-cmi -permissive + ../../compiler-stdlib/src/.caml.objs/caml.cmi + ../../compiler-stdlib/src/.caml.objs/byte/caml.cmi -o %{targets})))
\ No newline at end of file diff --git a/src/applicative.ml b/src/applicative.ml index 579133f..60a8a0d 100644 --- a/src/applicative.ml +++ b/src/applicative.ml @@ -1,91 +1,31 @@ open! Import include Applicative_intf +module List = List0 (** This module serves mostly as a partial check that [S2] and [S] are in sync, but actually calling it is occasionally useful. *) module S_to_S2 (X : S) : S2 with type ('a, 'e) t = 'a X.t = struct - type ('a, 'e) t = 'a X.t + include X - include (X : S with type 'a t := 'a X.t) + type ('a, 'e) t = 'a X.t end module S2_to_S (X : S2) : S with type 'a t = ('a, unit) X.t = struct - type 'a t = ('a, unit) X.t + include X - include (X : S2 with type ('a, 'e) t := ('a, 'e) X.t) + type 'a t = ('a, unit) X.t end module S2_to_S3 (X : S2) : S3 with type ('a, 'd, 'e) t = ('a, 'd) X.t = struct - type ('a, 'd, 'e) t = ('a, 'd) X.t + include X - include (X : S2 with type ('a, 'd) t := ('a, 'd) X.t) + type ('a, 'd, 'e) t = ('a, 'd) X.t end module S3_to_S2 (X : S3) : S2 with type ('a, 'd) t = ('a, 'd, unit) X.t = struct - type ('a, 'd) t = ('a, 'd, unit) X.t - - include (X : S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t) -end - -(* These functors serve only to check that the signatures for various Foo and Foo2 module - types don't drift apart over time. -*) -module Check_compatibility = struct - module Applicative_infix_to_Applicative_infix2 (X : Applicative_infix) : - Applicative_infix2 with type ('a, 'e) t = 'a X.t = struct - type ('a, 'e) t = 'a X.t - - include (X : Applicative_infix with type 'a t := 'a X.t) - end - - module Applicative_infix2_to_Applicative_infix (X : Applicative_infix2) : - Applicative_infix with type 'a t = ('a, unit) X.t = struct - type 'a t = ('a, unit) X.t - - include (X : Applicative_infix2 with type ('a, 'e) t := ('a, 'e) X.t) - end - - module Applicative_infix2_to_Applicative_infix3 (X : Applicative_infix2) : - Applicative_infix3 with type ('a, 'd, 'e) t = ('a, 'd) X.t = struct - type ('a, 'd, 'e) t = ('a, 'd) X.t - - include (X : Applicative_infix2 with type ('a, 'd) t := ('a, 'd) X.t) - end - - module Applicative_infix3_to_Applicative_infix2 (X : Applicative_infix3) : - Applicative_infix2 with type ('a, 'd) t = ('a, 'd, unit) X.t = struct - type ('a, 'd) t = ('a, 'd, unit) X.t - - include (X : Applicative_infix3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t) - end - - module Let_syntax_to_Let_syntax2 (X : Let_syntax) : - Let_syntax2 with type ('a, 'e) t = 'a X.t = struct - type ('a, 'e) t = 'a X.t - - include (X : Let_syntax with type 'a t := 'a X.t) - end - - module Let_syntax2_to_Let_syntax (X : Let_syntax2) : - Let_syntax with type 'a t = ('a, unit) X.t = struct - type 'a t = ('a, unit) X.t - - include (X : Let_syntax2 with type ('a, 'e) t := ('a, 'e) X.t) - end - - module Let_syntax2_to_Let_syntax3 (X : Let_syntax2) : - Let_syntax3 with type ('a, 'd, 'e) t = ('a, 'd) X.t = struct - type ('a, 'd, 'e) t = ('a, 'd) X.t - - include (X : Let_syntax2 with type ('a, 'd) t := ('a, 'd) X.t) - end - - module Let_syntax3_to_Let_syntax2 (X : Let_syntax3) : - Let_syntax2 with type ('a, 'd) t = ('a, 'd, unit) X.t = struct - type ('a, 'd) t = ('a, 'd, unit) X.t + include X - include (X : Let_syntax3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t) - end + type ('a, 'd) t = ('a, 'd, unit) X.t end module Make3 (X : Basic3) : S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t = struct @@ -118,15 +58,15 @@ module Make3 (X : Basic3) : S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t = st end module Make2 (X : Basic2) : S2 with type ('a, 'e) t := ('a, 'e) X.t = Make3 (struct - type ('a, 'd, 'e) t = ('a, 'd) X.t + include X - include (X : Basic2 with type ('a, 'e) t := ('a, 'e) X.t) + type ('a, 'd, 'e) t = ('a, 'd) X.t end) module Make (X : Basic) : S with type 'a t := 'a X.t = Make2 (struct - type ('a, 'e) t = 'a X.t + include X - include (X : Basic with type 'a t := 'a X.t) + type ('a, 'e) t = 'a X.t end) module Make_let_syntax3 @@ -152,9 +92,9 @@ module Make_let_syntax2 (Impl : Intf.S) = Make_let_syntax3 (struct - type ('a, 'd, _) t = ('a, 'd) X.t + include X - include (X : For_let_syntax2 with type ('a, 'e) t := ('a, 'e) X.t) + type ('a, 'd, _) t = ('a, 'd) X.t end) (Intf) (Impl) @@ -166,37 +106,61 @@ module Make_let_syntax (Impl : Intf.S) = Make_let_syntax2 (struct - type ('a, _) t = 'a X.t + include X - include (X : For_let_syntax with type 'a t := 'a X.t) + type ('a, _) t = 'a X.t end) (Intf) (Impl) -module Make3_using_map2 (X : Basic3_using_map2) = Make3 (struct - include X +(** This functor closely resembles [Make3], and indeed it could be implemented + much shorter in terms of [Make3]. However, we implement it by hand so that + the resulting functions are more efficient, e.g. using [map2] directly instead of + defining [apply] in terms of it and then [map2] in terms of that. For most + applicatives this does not matter, but for some (such as Bonsai.Value.t), it has a + larger impact. *) +module Make3_using_map2 (X : Basic3_using_map2) : + S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t = struct + include X - let apply tf tx = map2 tf tx ~f:(fun f x -> f x) + let apply tf ta = map2 tf ta ~f:(fun f a -> f a) + let ( <*> ) = apply + let derived_map t ~f = return f <*> t - let map = - match map with - | `Custom map -> `Custom map - | `Define_using_map2 -> `Define_using_apply - ;; - end) + let map = + match X.map with + | `Define_using_map2 -> derived_map + | `Custom x -> x + ;; + + let ( >>| ) t f = map t ~f + let both ta tb = map2 ta tb ~f:(fun a b -> a, b) + let map3 ta tb tc ~f = map2 (map2 ta tb ~f) tc ~f:(fun fab c -> fab c) + let all ts = List.fold_right ts ~init:(return []) ~f:(map2 ~f:(fun x xs -> x :: xs)) + let ( *> ) u v = map2 u v ~f:(fun () y -> y) + let ( <* ) u v = map2 u v ~f:(fun x () -> x) + let all_unit ts = List.fold ts ~init:(return ()) ~f:( *> ) + + module Applicative_infix = struct + let ( <*> ) = ( <*> ) + let ( *> ) = ( *> ) + let ( <* ) = ( <* ) + let ( >>| ) = ( >>| ) + end +end module Make2_using_map2 (X : Basic2_using_map2) : S2 with type ('a, 'e) t := ('a, 'e) X.t = Make3_using_map2 (struct - type ('a, 'd, 'e) t = ('a, 'd) X.t + include X - include (X : Basic2_using_map2 with type ('a, 'e) t := ('a, 'e) X.t) + type ('a, 'd, 'e) t = ('a, 'd) X.t end) module Make_using_map2 (X : Basic_using_map2) : S with type 'a t := 'a X.t = Make2_using_map2 (struct - type ('a, 'e) t = 'a X.t + include X - include (X : Basic_using_map2 with type 'a t := 'a X.t) + type ('a, 'e) t = 'a X.t end) module Of_monad2 (M : Monad.S2) : S2 with type ('a, 'e) t := ('a, 'e) M.t = Make2 (struct @@ -208,9 +172,9 @@ module Of_monad2 (M : Monad.S2) : S2 with type ('a, 'e) t := ('a, 'e) M.t = Make end) module Of_monad (M : Monad.S) : S with type 'a t := 'a M.t = Of_monad2 (struct - type ('a, _) t = 'a M.t + include M - include (M : Monad.S with type 'a t := 'a M.t) + type ('a, _) t = 'a M.t end) module Compose (F : S) (G : S) : S with type 'a t = 'a F.t G.t = struct diff --git a/src/applicative_intf.ml b/src/applicative_intf.ml index e9a33b0..aa664fb 100644 --- a/src/applicative_intf.ml +++ b/src/applicative_intf.ml @@ -239,8 +239,7 @@ module type S3 = sig val all : ('a, 'd, 'e) t list -> ('a list, 'd, 'e) t val all_unit : (unit, 'd, 'e) t list -> (unit, 'd, 'e) t - module Applicative_infix : - Applicative_infix3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) t + module Applicative_infix : Applicative_infix3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) t end module type Let_syntax3 = sig diff --git a/src/array.ml b/src/array.ml index 851ae5d..7e2b265 100644 --- a/src/array.ml +++ b/src/array.ml @@ -1,37 +1,14 @@ open! Import include Array0 -module Int = Int0 type 'a t = 'a array [@@deriving_inline compare, sexp, sexp_grammar] let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = compare_array +let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = array_of_sexp +let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = sexp_of_array -let t_of_sexp : 'a. (Ppx_sexp_conv_lib.Sexp.t -> 'a) -> Ppx_sexp_conv_lib.Sexp.t -> 'a t = - array_of_sexp -;; - -let sexp_of_t : 'a. ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t = - sexp_of_array -;; - -let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "array" ] - ; ggid = "j\132);\135qH\158\135\222H\001\007\004\158\218" - ; types = [ "t", Explicit_bind ([ "a" ], Apply (Implicit_var 0, [ Explicit_var 0 ])) ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ array_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "array.ml" - } - in - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("t", _the_group) - in - t_sexp_grammar +let (t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t) = + fun _'a_sexp_grammar -> array_sexp_grammar _'a_sexp_grammar ;; [@@@end] @@ -274,14 +251,24 @@ module Sort = struct intro_sort arr ~max_depth ~compare ~left:(r + 1) ~right) ;; - let log10_of_3 = Caml.log10 3. - let log3 x = Caml.log10 x /. log10_of_3 - let sort arr ~compare ~left ~right = - let len = right - left + 1 in let heap_sort_switch_depth = - (* with perfect 3-way partitioning, this is the recursion depth *) - Int.of_float (log3 (Int.to_float len)) + (* We bail out to heap sort at a recursion depth of 32. GNU introsort uses 2lg(n). + The expected recursion depth for perfect 3-way splits is log_3(n). + + Using 32 means a balanced 3-way split would work up to 3^32 elements (roughly + 2^50 or 10^15). GNU reaches a depth of 32 at 65536 elements. + + For small arrays, this makes us less likely to bail out to heap sort, but the + 32*N cost before we do is not that much. + + For large arrays, this means we are more likely to bail out to heap sort at + some point if we get some bad splits or if the array is huge. But that's only a + constant factor cost in the final stages of recursion. + + All in all, this seems to be a small tradeoff and avoids paying a cost to + compute a logarithm at the start. *) + 32 in intro_sort arr ~max_depth:heap_sort_switch_depth ~compare ~left ~right ;; @@ -299,23 +286,66 @@ let to_array t = t let is_empty t = length t = 0 let is_sorted t ~compare = - let rec is_sorted_loop t ~compare i = - if i < 1 - then true - else compare t.(i - 1) t.(i) <= 0 && is_sorted_loop t ~compare (i - 1) - in - is_sorted_loop t ~compare (length t - 1) + let i = ref (length t - 1) in + let result = ref true in + while !i > 0 && !result do + let elt_i = unsafe_get t !i in + let elt_i_minus_1 = unsafe_get t (!i - 1) in + if compare elt_i_minus_1 elt_i > 0 then result := false; + decr i + done; + !result ;; let is_sorted_strictly t ~compare = - let rec is_sorted_strictly_loop t ~compare i = - if i < 1 - then true - else compare t.(i - 1) t.(i) < 0 && is_sorted_strictly_loop t ~compare (i - 1) - in - is_sorted_strictly_loop t ~compare (length t - 1) + let i = ref (length t - 1) in + let result = ref true in + while !i > 0 && !result do + let elt_i = unsafe_get t !i in + let elt_i_minus_1 = unsafe_get t (!i - 1) in + if compare elt_i_minus_1 elt_i >= 0 then result := false; + decr i + done; + !result +;; + +let merge a1 a2 ~compare = + let l1 = Array.length a1 in + let l2 = Array.length a2 in + if l1 = 0 + then copy a2 + else if l2 = 0 + then copy a1 + else if compare (unsafe_get a2 0) (unsafe_get a1 (l1 - 1)) >= 0 + then append a1 a2 + else if compare (unsafe_get a1 0) (unsafe_get a2 (l2 - 1)) > 0 + then append a2 a1 + else ( + let len = l1 + l2 in + let merged = create ~len (unsafe_get a1 0) in + let a1_index = ref 0 in + let a2_index = ref 0 in + for i = 0 to len - 1 do + let use_a1 = + if l1 = !a1_index + then false + else if l2 = !a2_index + then true + else compare (unsafe_get a1 !a1_index) (unsafe_get a2 !a2_index) <= 0 + in + if use_a1 + then ( + unsafe_set merged i (unsafe_get a1 !a1_index); + a1_index := !a1_index + 1) + else ( + unsafe_set merged i (unsafe_get a2 !a2_index); + a2_index := !a2_index + 1) + done; + merged) ;; +let copy_matrix = map ~f:copy + let folding_map t ~init ~f = let acc = ref init in map t ~f:(fun x -> @@ -343,10 +373,11 @@ let min_elt t ~compare = Container.min_elt ~fold t ~compare let max_elt t ~compare = Container.max_elt ~fold t ~compare let foldi t ~init ~f = - let rec foldi_loop t i ac ~f = - if i = length t then ac else foldi_loop t (i + 1) (f i ac t.(i)) ~f - in - foldi_loop t 0 init ~f + let acc = ref init in + for i = 0 to length t - 1 do + acc := f i !acc (unsafe_get t i) + done; + !acc ;; let folding_mapi t ~init ~f = @@ -385,6 +416,12 @@ let rev_inplace t = done ;; +let rev t = + let t = copy t in + rev_inplace t; + t +;; + let of_list_rev l = match l with | [] -> [||] @@ -476,66 +513,80 @@ let check_length2_exn name t1 t2 = let iter2_exn t1 t2 ~f = check_length2_exn "Array.iter2_exn" t1 t2; - iteri t1 ~f:(fun i x1 -> f x1 t2.(i)) + iteri t1 ~f:(fun i x1 -> f x1 (unsafe_get t2 i)) ;; let map2_exn t1 t2 ~f = check_length2_exn "Array.map2_exn" t1 t2; - init (length t1) ~f:(fun i -> f t1.(i) t2.(i)) + init (length t1) ~f:(fun i -> f (unsafe_get t1 i) (unsafe_get t2 i)) ;; let fold2_exn t1 t2 ~init ~f = check_length2_exn "Array.fold2_exn" t1 t2; - foldi t1 ~init ~f:(fun i ac x -> f ac x t2.(i)) + foldi t1 ~init ~f:(fun i ac x -> f ac x (unsafe_get t2 i)) ;; let filter t ~f = filter_map t ~f:(fun x -> if f x then Some x else None) let filteri t ~f = filter_mapi t ~f:(fun i x -> if f i x then Some x else None) + let exists t ~f = - let rec exists_loop t ~f i = - if i < 0 then false else f t.(i) || exists_loop t ~f (i - 1) - in - exists_loop t ~f (length t - 1) + let i = ref (length t - 1) in + let result = ref false in + while !i >= 0 && not !result do + if f (unsafe_get t !i) then result := true else decr i + done; + !result ;; let existsi t ~f = - let rec existsi_loop t ~f i = - if i < 0 then false else f i t.(i) || existsi_loop t ~f (i - 1) - in - existsi_loop t ~f (length t - 1) + let i = ref (length t - 1) in + let result = ref false in + while !i >= 0 && not !result do + if f !i (unsafe_get t !i) then result := true else decr i + done; + !result ;; let mem t a ~equal = exists t ~f:(equal a) let for_all t ~f = - let rec for_all_loop t ~f i = - if i < 0 then true else f t.(i) && for_all_loop t ~f (i - 1) - in - for_all_loop t ~f (length t - 1) + let i = ref (length t - 1) in + let result = ref true in + while !i >= 0 && !result do + if not (f (unsafe_get t !i)) then result := false else decr i + done; + !result ;; let for_alli t ~f = - let rec for_alli_loop t ~f i = - if i < 0 then true else f i t.(i) && for_alli_loop t ~f (i - 1) - in - for_alli_loop t ~f (length t - 1) + let length = length t in + let i = ref (length - 1) in + let result = ref true in + while !i >= 0 && !result do + if not (f !i (unsafe_get t !i)) then result := false else decr i + done; + !result ;; let exists2_exn t1 t2 ~f = - let rec exists2_exn_loop t1 t2 ~f i = - if i < 0 then false else f t1.(i) t2.(i) || exists2_exn_loop t1 t2 ~f (i - 1) - in check_length2_exn "Array.exists2_exn" t1 t2; - exists2_exn_loop t1 t2 ~f (length t1 - 1) + let i = ref (length t1 - 1) in + let result = ref false in + while !i >= 0 && not !result do + if f (unsafe_get t1 !i) (unsafe_get t2 !i) then result := true else decr i + done; + !result ;; let for_all2_exn t1 t2 ~f = - let rec for_all2_loop t1 t2 ~f i = - if i < 0 then true else f t1.(i) t2.(i) && for_all2_loop t1 t2 ~f (i - 1) - in check_length2_exn "Array.for_all2_exn" t1 t2; - for_all2_loop t1 t2 ~f (length t1 - 1) + let i = ref (length t1 - 1) in + let result = ref true in + while !i >= 0 && !result do + if not (f (unsafe_get t1 !i) (unsafe_get t2 !i)) then result := false else decr i + done; + !result ;; let equal equal t1 t2 = length t1 = length t2 && for_all2_exn t1 t2 ~f:equal @@ -543,57 +594,68 @@ let equal equal t1 t2 = length t1 = length t2 && for_all2_exn t1 t2 ~f:equal let map_inplace t ~f = for i = 0 to length t - 1 do - t.(i) <- f t.(i) + unsafe_set t i (f (unsafe_get t i)) done ;; -let findi t ~f = - let rec findi_loop t ~f ~length i = - if i >= length - then None - else if f i t.(i) - then Some (i, t.(i)) - else findi_loop t ~f ~length (i + 1) - in +let[@inline always] findi_internal t ~f ~if_found ~if_not_found = let length = length t in - findi_loop t ~f ~length 0 + if length = 0 + then if_not_found () + else ( + let i = ref 0 in + let found = ref false in + let value_found = ref (unsafe_get t 0) in + while (not !found) && !i < length do + let value = unsafe_get t !i in + if f !i value + then ( + value_found := value; + found := true) + else incr i + done; + if !found then if_found ~i:!i ~value:!value_found else if_not_found ()) ;; -let findi_exn = - let not_found = Not_found_s (Atom "Array.findi_exn: not found") in - let findi_exn t ~f = - match findi t ~f with - | None -> raise not_found - | Some x -> x - in - (* named to preserve symbol in compiled binary *) - findi_exn +let findi t ~f = + findi_internal + t + ~f + ~if_found:(fun ~i ~value -> Some (i, value)) + ~if_not_found:(fun () -> None) ;; -let find_exn = - let not_found = Not_found_s (Atom "Array.find_exn: not found") in - let find_exn t ~f = - match findi t ~f:(fun _i x -> f x) with - | None -> raise not_found - | Some (_i, x) -> x - in - (* named to preserve symbol in compiled binary *) - find_exn +let findi_exn t ~f = + findi_internal + t + ~f + ~if_found:(fun ~i ~value -> i, value) + ~if_not_found:(fun () -> raise (Not_found_s (Atom "Array.findi_exn: not found"))) +;; + +let find_exn t ~f = + findi_internal + t + ~f:(fun _i x -> f x) + ~if_found:(fun ~i:_ ~value -> value) + ~if_not_found:(fun () -> raise (Not_found_s (Atom "Array.find_exn: not found"))) ;; let find t ~f = Option.map (findi t ~f:(fun _i x -> f x)) ~f:(fun (_i, x) -> x) let find_map t ~f = - let rec find_map_loop t ~f ~length i = - if i >= length - then None - else ( - match f t.(i) with - | None -> find_map_loop t ~f ~length (i + 1) - | Some _ as res -> res) - in let length = length t in - find_map_loop t ~f ~length 0 + if length = 0 + then None + else ( + let i = ref 0 in + let value_found = ref None in + while Option.is_none !value_found && !i < length do + let value = unsafe_get t !i in + value_found := f value; + incr i + done; + !value_found) ;; let find_map_exn = @@ -608,16 +670,18 @@ let find_map_exn = ;; let find_mapi t ~f = - let rec find_mapi_loop t ~f ~length i = - if i >= length - then None - else ( - match f i t.(i) with - | None -> find_mapi_loop t ~f ~length (i + 1) - | Some _ as res -> res) - in let length = length t in - find_mapi_loop t ~f ~length 0 + if length = 0 + then None + else ( + let i = ref 0 in + let value_found = ref None in + while Option.is_none !value_found && !i < length do + let value = unsafe_get t !i in + value_found := f !i value; + incr i + done; + !value_found) ;; let find_mapi_exn = @@ -638,9 +702,9 @@ let find_consecutive_duplicate t ~equal = else ( let result = ref None in let i = ref 1 in - let prev = ref t.(0) in + let prev = ref (unsafe_get t 0) in while !i < n do - let cur = t.(!i) in + let cur = unsafe_get t !i in if equal cur !prev then ( result := Some (!prev, cur); @@ -656,9 +720,9 @@ let reduce t ~f = if length t = 0 then None else ( - let r = ref t.(0) in + let r = ref (unsafe_get t 0) in for i = 1 to length t - 1 do - r := f !r t.(i) + r := f !r (unsafe_get t i) done; Some !r) ;; @@ -751,7 +815,7 @@ let cartesian_product t1 t2 = let r = ref 0 in for i1 = 0 to n1 - 1 do for i2 = 0 to n2 - 1 do - t.(!r) <- (t1.(i1), t2.(i2)); + t.(!r) <- t1.(i1), t2.(i2); incr r done done; @@ -795,7 +859,7 @@ include Blit.Make1 (struct create ~len t.(0)) ;; - let unsafe_blit = blit + let unsafe_blit = unsafe_blit end) let invariant invariant_a t = iter t ~f:invariant_a diff --git a/src/array.mli b/src/array.mli index 30ce178..a8c608c 100644 --- a/src/array.mli +++ b/src/array.mli @@ -1,14 +1,13 @@ -(** Mutable vector of elements with O(1) [get] and [set] operations. *) +(** Fixed-length, mutable vector of elements with O(1) [get] and [set] operations. *) open! Import type 'a t = 'a array [@@deriving_inline compare, sexp, sexp_grammar] -val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int +include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t +include Sexplib0.Sexpable.S1 with type 'a t := 'a t -include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t := 'a t - -val t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t +val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] @@ -22,6 +21,11 @@ include Invariant.S1 with type 'a t := 'a t [max_length/2] on 32-bit machines and [max_length] on 64-bit machines. *) val max_length : int +(*_ Declared as externals so that the compiler skips the caml_apply_X wrapping even when + compiling without cross library inlining. *) + +external length : 'a array -> int = "%array_length" + (** [Array.get a n] returns the element number [n] of array [a]. The first element has number 0. The last element has number [Array.length a - 1]. @@ -51,6 +55,12 @@ external unsafe_set : 'a t -> int -> 'a -> unit = "%array_unsafe_set" each element. *) val create : len:int -> 'a -> 'a t +(** [create_float_uninitialized ~len] creates a float array of length [len] with + uninitialized elements -- that is, they may contain arbitrary, nondeterministic float + values. This can be significantly faster than using [create], when unboxed float array + representations are enabled. *) +val create_float_uninitialized : len:int -> float t + (** [init n ~f] creates an array of length [n] where the [i]th element (starting at zero) is initialized with [f i]. *) val init : int -> f:(int -> 'a) -> 'a t @@ -67,6 +77,10 @@ val init : int -> f:(int -> 'a) -> 'a t [Array.max_length / 2]. *) val make_matrix : dimx:int -> dimy:int -> 'a -> 'a t t +(** [Array.copy_matrix t] returns a fresh copy of the array of arrays [t]. This is + typically used when [t] is a matrix created by [Array.make_matrix]. *) +val copy_matrix : 'a t t -> 'a t t + (** [Array.append v1 v2] returns a fresh array containing the concatenation of the arrays [v1] and [v2]. *) val append : 'a t -> 'a t -> 'a t @@ -95,8 +109,7 @@ val fill : 'a t -> pos:int -> len:int -> 'a -> unit [int_blit] and [float_blit] provide fast bound-checked blits for immediate data types. The unsafe versions do not bound-check the arguments. *) -include - Blit.S1 with type 'a t := 'a t +include Blit.S1 with type 'a t := 'a t (** [Array.of_list l] returns a fresh array containing the elements of [l]. *) val of_list : 'a list -> 'a t @@ -148,6 +161,12 @@ val is_sorted : 'a t -> compare:('a -> 'a -> int) -> bool consecutive elements in [xs] are equal according to [compare]. *) val is_sorted_strictly : 'a t -> compare:('a -> 'a -> int) -> bool +(** Merges two arrays: assuming that [a1] and [a2] are sorted according to the comparison + function [compare], [merge a1 a2 ~compare] will return a sorted array containing all + the elements of [a1] and [a2]. If several elements compare equal, the elements of [a1] + will be before the elements of [a2]. *) +val merge : 'a t -> 'a t -> compare:('a -> 'a -> int) -> 'a t + (** Like [List.concat_map], [List.concat_mapi]. *) val concat_map : 'a t -> f:('a -> 'b array) -> 'b array @@ -208,6 +227,9 @@ val swap : 'a t -> int -> int -> unit (** [rev_inplace t] reverses [t] in place. *) val rev_inplace : 'a t -> unit +(** [rev t] returns a reversed copy of [t] *) +val rev : 'a t -> 'a t + (** [of_list_rev l] converts from list then reverses in place. *) val of_list_rev : 'a list -> 'a t @@ -259,11 +281,14 @@ val reduce : 'a t -> f:('a -> 'a -> 'a) -> 'a option val reduce_exn : 'a t -> f:('a -> 'a -> 'a) -> 'a -(** [permute ?random_state t] randomly permutes [t] in place. +(** [permute ?random_state ?pos ?len t] randomly permutes [t] in place. + + To permute only part of the array, specify [pos] to be the index to start permuting + from and [len] indicating how many elements to permute. [permute] side-effects [random_state] by repeated calls to [Random.State.int]. If [random_state] is not supplied, [permute] uses [Random.State.default]. *) -val permute : ?random_state:Random.State.t -> 'a t -> unit +val permute : ?random_state:Random.State.t -> ?pos:int -> ?len:int -> 'a t -> unit (** [random_element ?random_state t] is [None] if [t] is empty, else it is [Some x] for some [x] chosen uniformly at random from [t]. diff --git a/src/array0.ml b/src/array0.ml index 2de57d4..f06bd57 100644 --- a/src/array0.ml +++ b/src/array0.ml @@ -15,11 +15,21 @@ let invalid_argf = Printf.invalid_argf module Array = struct external create : int -> 'a -> 'a array = "caml_make_vect" + external create_float_uninitialized : int -> float array = "caml_make_float_vect" external get : 'a array -> int -> 'a = "%array_safe_get" external length : 'a array -> int = "%array_length" external set : 'a array -> int -> 'a -> unit = "%array_safe_set" external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" + + external unsafe_blit + : src:'a array + -> src_pos:int + -> dst:'a array + -> dst_pos:int + -> len:int + -> unit + = "caml_array_blit" end include Array @@ -31,6 +41,12 @@ let create ~len x = | Invalid_argument _ -> invalid_argf "Array.create ~len:%d: invalid length" len () ;; +let create_float_uninitialized ~len = + try create_float_uninitialized len with + | Invalid_argument _ -> + invalid_argf "Array.create_float_uninitialized ~len:%d: invalid length" len () +;; + let append = Caml.Array.append let blit = Caml.Array.blit let concat = Caml.Array.concat @@ -53,7 +69,8 @@ let mapi t ~f = Caml.Array.mapi t ~f let stable_sort t ~compare = Caml.Array.stable_sort t ~cmp:compare let swap t i j = - let tmp = t.(i) in - t.(i) <- t.(j); - t.(j) <- tmp + let elt_i = t.(i) in + let elt_j = t.(j) in + unsafe_set t i elt_j; + unsafe_set t j elt_i ;; diff --git a/src/array_permute.ml b/src/array_permute.ml index e31b453..ea9a521 100644 --- a/src/array_permute.ml +++ b/src/array_permute.ml @@ -4,9 +4,21 @@ open! Import include Array0 -(** randomly permute an array. *) -let permute ?(random_state = Random.State.default) t = - for i = length t downto 2 do - swap t (i - 1) (Random.State.int random_state i) +let permute ?(random_state = Random.State.default) ?(pos = 0) ?len t = + (* Copied from [Ordered_collection_common0] to avoid allocating a tuple when compiling + without flambda. *) + let total_length = length t in + let len = + match len with + | Some l -> l + | None -> total_length - pos + in + Ordered_collection_common0.check_pos_len_exn ~pos ~len ~total_length; + let num_swaps = len - 1 in + for i = num_swaps downto 1 do + let this_i = pos + i in + (* [random_i] is drawn from [pos,this_i] *) + let random_i = pos + Random.State.int random_state (i + 1) in + swap t this_i random_i done ;; diff --git a/src/backtrace.ml b/src/backtrace.ml index ea6a2ca..d0df105 100644 --- a/src/backtrace.ml +++ b/src/backtrace.ml @@ -3,7 +3,7 @@ module Sys = Sys0 type t = Caml.Printexc.raw_backtrace -let elide = ref am_testing +let elide = ref false let elided_message = "<backtrace elided in test>" let get ?(at_most_num_frames = Int.max_value) () = @@ -22,6 +22,10 @@ module Exn = struct let am_recording = Caml.Printexc.backtrace_status let most_recent () = Caml.Printexc.get_raw_backtrace () + let most_recent_for_exn exn = + if Exn.is_phys_equal_most_recent exn then Some (most_recent ()) else None + ;; + (* We turn on backtraces by default if OCAMLRUNPARAM doesn't explicitly mention them. *) let maybe_set_recording () = let ocamlrunparam_mentions_backtraces = diff --git a/src/backtrace.mli b/src/backtrace.mli index c77ac98..27fd9b8 100644 --- a/src/backtrace.mli +++ b/src/backtrace.mli @@ -12,9 +12,9 @@ open! Import represented as a string with newlines separating the frames. [sexp_of_t] splits the string at newlines and removes some of the cruft, leaving a human-friendly list of frames, but [to_string] does not. *) -type t [@@deriving_inline sexp_of] +type t = Caml.Printexc.raw_backtrace [@@deriving_inline sexp_of] -val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t +val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] @@ -28,7 +28,7 @@ val to_string_list : t -> string list When set to [true], these functions will ignore their argument and return a message indicating that behavior. - The default value is {!am_testing}. *) + The default value is [false]. *) val elide : bool ref (** [Backtrace.Exn] has functions for controlling and printing the backtrace of the most @@ -69,10 +69,37 @@ module Exn : sig val with_recording : bool -> f:(unit -> 'a) -> 'a (** [most_recent ()] returns a backtrace containing the stack that was unwound by the - most recently raised exception. *) + most recently raised exception. + + Normally this includes just the function calls that lead from the exception handler + being set up to the exception being raised. However, due to inlining, the stack + frame that has the exception handler may correspond to a chain of multiple function + calls. All of those function calls are then reported in this backtrace, even though + they are not themselves on the path from the exception handler to the "raise". *) val most_recent : unit -> t + + (** [most_recent_for_exn exn] returns a backtrace containing the stack that was unwound + when raising [exn] if [exn] is the most recently raised exception. Otherwise it + returns [None]. + + Note that this may return a misleading backtrace instead of [None] if + different raise events happen to raise physically equal exceptions. + Consider the example below. Here if [e = Not_found] and [g] usees + [Not_found] internally then the backtrace will correspond to the + internal backtrace in [g] instead of the one used in [f], which is + not desirable. + + {[ + try f () with + | e -> + g (); + let bt = Backtrace.Exn.most_recent_for_exn e in + ... + ]} + *) + val most_recent_for_exn : Exn.t -> t option end -(** User code never calls this. It is called only in [std_kernel.ml], as a top-level side +(** User code never calls this. It is called only in [base.ml], as a top-level side effect, to initialize [am_recording ()] as specified above. *) val initialize_module : unit -> unit diff --git a/src/base.ml b/src/base.ml index a0fe196..83ab746 100644 --- a/src/base.ml +++ b/src/base.ml @@ -1,7 +1,6 @@ (** This module is the toplevel of the Base library; it's what you get when you write [open Base]. - The goal of Base is both to be a more complete standard library, with richer APIs, and to be more consistent in its design. For instance, in the standard library some things have modules and others don't; in Base, everything is a module. @@ -20,9 +19,6 @@ - [Container], which provides a consistent interface across container-like data structures (arrays, lists, strings). - [Result], [Error], and [Or_error], supporting the or-error pattern. - - The recommended way to use Base is to build with [-open Base]. Files compiled this - way will have the environment described in this file as their initial environment. *) (*_ We hide this from the web docs because the line wrapping is bad, making it @@ -158,7 +154,6 @@ module Type_equal = Type_equal module Uniform_array = Uniform_array module Unit = Unit module Uchar = Uchar -module Validate = Validate module Variant = Variant module With_return = With_return module Word_size = Word_size @@ -176,10 +171,9 @@ end module Exported_for_specific_uses = struct module Fieldslib = Fieldslib module Ppx_hash_lib = Ppx_hash_lib - module Sexplib = Sexplib module Variantslib = Variantslib module Ppx_compare_lib = Ppx_compare_lib - module Ppx_sexp_conv_lib = Ppx_sexp_conv_lib + module Ppx_enumerate_lib = Ppx_enumerate_lib let am_testing = am_testing end @@ -187,48 +181,24 @@ end (**/**) module Export = struct - include Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.Builtin - (* [deriving hash] is missing for [array] and [ref] since these types are mutable. *) type 'a array = 'a Array.t [@@deriving_inline compare, equal, sexp, sexp_grammar] - let compare_array : 'a. ('a -> 'a -> int) -> 'a array -> 'a array -> int = - Array.compare - ;; - + let compare_array : 'a. ('a -> 'a -> int) -> 'a array -> 'a array -> int = Array.compare let equal_array : 'a. ('a -> 'a -> bool) -> 'a array -> 'a array -> bool = Array.equal - let array_of_sexp : - 'a. (Ppx_sexp_conv_lib.Sexp.t -> 'a) -> Ppx_sexp_conv_lib.Sexp.t -> 'a array - = + let array_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a array = Array.t_of_sexp ;; - let sexp_of_array : - 'a. ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a array -> Ppx_sexp_conv_lib.Sexp.t - = + let sexp_of_array : 'a. ('a -> Sexplib0.Sexp.t) -> 'a array -> Sexplib0.Sexp.t = Array.sexp_of_t ;; - let (array_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "Array.t" ] - ; ggid = "r\177A\255~\129%\178\226\196g\165\t\232\204\001" - ; types = - [ "array", Explicit_bind ([ "a" ], Apply (Implicit_var 0, [ Explicit_var 0 ])) ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ Array.t_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "base.ml.Export" - } - in - let (array_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("array", _the_group) - in - array_sexp_grammar + let (array_sexp_grammar : + 'a Sexplib0.Sexp_grammar.t -> 'a array Sexplib0.Sexp_grammar.t) + = + fun _'a_sexp_grammar -> Array.t_sexp_grammar _'a_sexp_grammar ;; [@@@end] @@ -248,28 +218,9 @@ module Export = struct fun x -> func x ;; - let bool_of_sexp = (Bool.t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> bool) - let sexp_of_bool = (Bool.sexp_of_t : bool -> Ppx_sexp_conv_lib.Sexp.t) - - let (bool_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "Bool.t" ] - ; ggid = "{\171\239\166\219\128\005\201\192$\149\202\251?\186\164" - ; types = [ "bool", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ Bool.t_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "base.ml.Export" - } - in - let (bool_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("bool", _the_group) - in - bool_sexp_grammar - ;; + let bool_of_sexp = (Bool.t_of_sexp : Sexplib0.Sexp.t -> bool) + let sexp_of_bool = (Bool.sexp_of_t : bool -> Sexplib0.Sexp.t) + let (bool_sexp_grammar : bool Sexplib0.Sexp_grammar.t) = Bool.t_sexp_grammar [@@@end] @@ -288,34 +239,15 @@ module Export = struct fun x -> func x ;; - let char_of_sexp = (Char.t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> char) - let sexp_of_char = (Char.sexp_of_t : char -> Ppx_sexp_conv_lib.Sexp.t) - - let (char_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "Char.t" ] - ; ggid = "H\140\243\204Y\222\191d\000@\024Md\028\147>" - ; types = [ "char", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ Char.t_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "base.ml.Export" - } - in - let (char_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("char", _the_group) - in - char_sexp_grammar - ;; + let char_of_sexp = (Char.t_of_sexp : Sexplib0.Sexp.t -> char) + let sexp_of_char = (Char.sexp_of_t : char -> Sexplib0.Sexp.t) + let (char_sexp_grammar : char Sexplib0.Sexp_grammar.t) = Char.t_sexp_grammar [@@@end] type exn = Exn.t [@@deriving_inline sexp_of] - let sexp_of_exn = (Exn.sexp_of_t : exn -> Ppx_sexp_conv_lib.Sexp.t) + let sexp_of_exn = (Exn.sexp_of_t : exn -> Sexplib0.Sexp.t) [@@@end] @@ -334,28 +266,9 @@ module Export = struct fun x -> func x ;; - let float_of_sexp = (Float.t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> float) - let sexp_of_float = (Float.sexp_of_t : float -> Ppx_sexp_conv_lib.Sexp.t) - - let (float_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "Float.t" ] - ; ggid = "\190E\020\242\249\135C\240+\214\226\143Ip\217\223" - ; types = [ "float", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ Float.t_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "base.ml.Export" - } - in - let (float_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("float", _the_group) - in - float_sexp_grammar - ;; + let float_of_sexp = (Float.t_of_sexp : Sexplib0.Sexp.t -> float) + let sexp_of_float = (Float.sexp_of_t : float -> Sexplib0.Sexp.t) + let (float_sexp_grammar : float Sexplib0.Sexp_grammar.t) = Float.t_sexp_grammar [@@@end] @@ -364,8 +277,7 @@ module Export = struct let compare_int = (Int.compare : int -> int -> int) let equal_int = (Int.equal : int -> int -> bool) - let (hash_fold_int : Ppx_hash_lib.Std.Hash.state -> int -> Ppx_hash_lib.Std.Hash.state) - = + let (hash_fold_int : Ppx_hash_lib.Std.Hash.state -> int -> Ppx_hash_lib.Std.Hash.state) = Int.hash_fold_t and (hash_int : int -> Ppx_hash_lib.Std.Hash.hash_value) = @@ -373,28 +285,9 @@ module Export = struct fun x -> func x ;; - let int_of_sexp = (Int.t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> int) - let sexp_of_int = (Int.sexp_of_t : int -> Ppx_sexp_conv_lib.Sexp.t) - - let (int_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "Int.t" ] - ; ggid = "\159\159\197^\165]\236\165\229\165R8\169\225H\020" - ; types = [ "int", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ Int.t_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "base.ml.Export" - } - in - let (int_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("int", _the_group) - in - int_sexp_grammar - ;; + let int_of_sexp = (Int.t_of_sexp : Sexplib0.Sexp.t -> int) + let sexp_of_int = (Int.sexp_of_t : int -> Sexplib0.Sexp.t) + let (int_sexp_grammar : int Sexplib0.Sexp_grammar.t) = Int.t_sexp_grammar [@@@end] @@ -413,28 +306,9 @@ module Export = struct fun x -> func x ;; - let int32_of_sexp = (Int32.t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> int32) - let sexp_of_int32 = (Int32.sexp_of_t : int32 -> Ppx_sexp_conv_lib.Sexp.t) - - let (int32_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "Int32.t" ] - ; ggid = "9\153\000*L5O+l\018\179b\198\248\026\177" - ; types = [ "int32", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ Int32.t_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "base.ml.Export" - } - in - let (int32_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("int32", _the_group) - in - int32_sexp_grammar - ;; + let int32_of_sexp = (Int32.t_of_sexp : Sexplib0.Sexp.t -> int32) + let sexp_of_int32 = (Int32.sexp_of_t : int32 -> Sexplib0.Sexp.t) + let (int32_sexp_grammar : int32 Sexplib0.Sexp_grammar.t) = Int32.t_sexp_grammar [@@@end] @@ -453,28 +327,9 @@ module Export = struct fun x -> func x ;; - let int64_of_sexp = (Int64.t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> int64) - let sexp_of_int64 = (Int64.sexp_of_t : int64 -> Ppx_sexp_conv_lib.Sexp.t) - - let (int64_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "Int64.t" ] - ; ggid = "r\153\022\135\131L\155\236\235CKa\197o\248^" - ; types = [ "int64", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ Int64.t_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "base.ml.Export" - } - in - let (int64_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("int64", _the_group) - in - int64_sexp_grammar - ;; + let int64_of_sexp = (Int64.t_of_sexp : Sexplib0.Sexp.t -> int64) + let sexp_of_int64 = (Int64.sexp_of_t : int64 -> Sexplib0.Sexp.t) + let (int64_sexp_grammar : int64 Sexplib0.Sexp_grammar.t) = Int64.t_sexp_grammar [@@@end] @@ -484,43 +339,25 @@ module Export = struct let equal_list : 'a. ('a -> 'a -> bool) -> 'a list -> 'a list -> bool = List.equal let hash_fold_list : - 'a. (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) - -> Ppx_hash_lib.Std.Hash.state -> 'a list -> Ppx_hash_lib.Std.Hash.state + 'a. + (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) + -> Ppx_hash_lib.Std.Hash.state + -> 'a list + -> Ppx_hash_lib.Std.Hash.state = List.hash_fold_t ;; - let list_of_sexp : - 'a. (Ppx_sexp_conv_lib.Sexp.t -> 'a) -> Ppx_sexp_conv_lib.Sexp.t -> 'a list - = + let list_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a list = List.t_of_sexp ;; - let sexp_of_list : - 'a. ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a list -> Ppx_sexp_conv_lib.Sexp.t - = + let sexp_of_list : 'a. ('a -> Sexplib0.Sexp.t) -> 'a list -> Sexplib0.Sexp.t = List.sexp_of_t ;; - let (list_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "List.t" ] - ; ggid = "\144\022<Z\014\198\014\175\025\218\004\199\252~\031=" - ; types = - [ "list", Explicit_bind ([ "a" ], Apply (Implicit_var 0, [ Explicit_var 0 ])) ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ List.t_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "base.ml.Export" - } - in - let (list_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("list", _the_group) - in - list_sexp_grammar + let (list_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a list Sexplib0.Sexp_grammar.t) = + fun _'a_sexp_grammar -> List.t_sexp_grammar _'a_sexp_grammar ;; [@@@end] @@ -541,27 +378,11 @@ module Export = struct fun x -> func x ;; - let nativeint_of_sexp = (Nativeint.t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> nativeint) - let sexp_of_nativeint = (Nativeint.sexp_of_t : nativeint -> Ppx_sexp_conv_lib.Sexp.t) - - let (nativeint_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "Nativeint.t" ] - ; ggid = "\019\184AE\023\\->1fcm\002\254\196\129" - ; types = [ "nativeint", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ Nativeint.t_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "base.ml.Export" - } - in - let (nativeint_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("nativeint", _the_group) - in - nativeint_sexp_grammar + let nativeint_of_sexp = (Nativeint.t_of_sexp : Sexplib0.Sexp.t -> nativeint) + let sexp_of_nativeint = (Nativeint.sexp_of_t : nativeint -> Sexplib0.Sexp.t) + + let (nativeint_sexp_grammar : nativeint Sexplib0.Sexp_grammar.t) = + Nativeint.t_sexp_grammar ;; [@@@end] @@ -578,44 +399,27 @@ module Export = struct ;; let hash_fold_option : - 'a. (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) - -> Ppx_hash_lib.Std.Hash.state -> 'a option -> Ppx_hash_lib.Std.Hash.state + 'a. + (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) + -> Ppx_hash_lib.Std.Hash.state + -> 'a option + -> Ppx_hash_lib.Std.Hash.state = Option.hash_fold_t ;; - let option_of_sexp : - 'a. (Ppx_sexp_conv_lib.Sexp.t -> 'a) -> Ppx_sexp_conv_lib.Sexp.t -> 'a option - = + let option_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a option = Option.t_of_sexp ;; - let sexp_of_option : - 'a. ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a option -> Ppx_sexp_conv_lib.Sexp.t - = + let sexp_of_option : 'a. ('a -> Sexplib0.Sexp.t) -> 'a option -> Sexplib0.Sexp.t = Option.sexp_of_t ;; - let (option_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "Option.t" ] - ; ggid = "\242@\255j`*d\203\161\182\021\175\236\146x\217" - ; types = - [ "option", Explicit_bind ([ "a" ], Apply (Implicit_var 0, [ Explicit_var 0 ])) - ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ Option.t_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "base.ml.Export" - } - in - let (option_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("option", _the_group) - in - option_sexp_grammar + let (option_sexp_grammar : + 'a Sexplib0.Sexp_grammar.t -> 'a option Sexplib0.Sexp_grammar.t) + = + fun _'a_sexp_grammar -> Option.t_sexp_grammar _'a_sexp_grammar ;; [@@@end] @@ -625,37 +429,16 @@ module Export = struct let compare_ref : 'a. ('a -> 'a -> int) -> 'a ref -> 'a ref -> int = Ref.compare let equal_ref : 'a. ('a -> 'a -> bool) -> 'a ref -> 'a ref -> bool = Ref.equal - let ref_of_sexp : - 'a. (Ppx_sexp_conv_lib.Sexp.t -> 'a) -> Ppx_sexp_conv_lib.Sexp.t -> 'a ref - = + let ref_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a ref = Ref.t_of_sexp ;; - let sexp_of_ref : - 'a. ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a ref -> Ppx_sexp_conv_lib.Sexp.t - = + let sexp_of_ref : 'a. ('a -> Sexplib0.Sexp.t) -> 'a ref -> Sexplib0.Sexp.t = Ref.sexp_of_t ;; - let (ref_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "Ref.t" ] - ; ggid = "\185\246\012[\001\197\230\192y=\b\199\141\248\020\012" - ; types = - [ "ref", Explicit_bind ([ "a" ], Apply (Implicit_var 0, [ Explicit_var 0 ])) ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ Ref.t_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "base.ml.Export" - } - in - let (ref_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("ref", _the_group) - in - ref_sexp_grammar + let (ref_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a ref Sexplib0.Sexp_grammar.t) = + fun _'a_sexp_grammar -> Ref.t_sexp_grammar _'a_sexp_grammar ;; [@@@end] @@ -675,28 +458,9 @@ module Export = struct fun x -> func x ;; - let string_of_sexp = (String.t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> string) - let sexp_of_string = (String.sexp_of_t : string -> Ppx_sexp_conv_lib.Sexp.t) - - let (string_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "String.t" ] - ; ggid = "\141\195]\143\139/M\t\159\t\152\214g\198\023\176" - ; types = [ "string", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ String.t_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "base.ml.Export" - } - in - let (string_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("string", _the_group) - in - string_sexp_grammar - ;; + let string_of_sexp = (String.t_of_sexp : Sexplib0.Sexp.t -> string) + let sexp_of_string = (String.sexp_of_t : string -> Sexplib0.Sexp.t) + let (string_sexp_grammar : string Sexplib0.Sexp_grammar.t) = String.t_sexp_grammar [@@@end] @@ -704,28 +468,9 @@ module Export = struct let compare_bytes = (Bytes.compare : bytes -> bytes -> int) let equal_bytes = (Bytes.equal : bytes -> bytes -> bool) - let bytes_of_sexp = (Bytes.t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> bytes) - let sexp_of_bytes = (Bytes.sexp_of_t : bytes -> Ppx_sexp_conv_lib.Sexp.t) - - let (bytes_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "Bytes.t" ] - ; ggid = "\015\153L1\012\241\015\252\150\000\191\127Jb#3" - ; types = [ "bytes", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ Bytes.t_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "base.ml.Export" - } - in - let (bytes_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("bytes", _the_group) - in - bytes_sexp_grammar - ;; + let bytes_of_sexp = (Bytes.t_of_sexp : Sexplib0.Sexp.t -> bytes) + let sexp_of_bytes = (Bytes.sexp_of_t : bytes -> Sexplib0.Sexp.t) + let (bytes_sexp_grammar : bytes Sexplib0.Sexp_grammar.t) = Bytes.t_sexp_grammar [@@@end] @@ -744,28 +489,9 @@ module Export = struct fun x -> func x ;; - let unit_of_sexp = (Unit.t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> unit) - let sexp_of_unit = (Unit.sexp_of_t : unit -> Ppx_sexp_conv_lib.Sexp.t) - - let (unit_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "Unit.t" ] - ; ggid = "=\005 \134\187\"64\197S\19256,\031l" - ; types = [ "unit", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ Unit.t_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "base.ml.Export" - } - in - let (unit_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("unit", _the_group) - in - unit_sexp_grammar - ;; + let unit_of_sexp = (Unit.t_of_sexp : Sexplib0.Sexp.t -> unit) + let sexp_of_unit = (Unit.sexp_of_t : unit -> Sexplib0.Sexp.t) + let (unit_sexp_grammar : unit Sexplib0.Sexp_grammar.t) = Unit.t_sexp_grammar [@@@end] @@ -775,33 +501,6 @@ module Export = struct type nonrec ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'd) format4 type nonrec ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) format6 - (** {2 Sexp} - - Exporting the ad-hoc types that are recognized by [ppx_sexp_*] converters. - [sexp_array], [sexp_list], and [sexp_option] allow a record field to be absent when - converting from a sexp, and if absent, the field will take a default value of the - appropriate type: - - {v - sexp_array [||] - sexp_bool false - sexp_list [] - sexp_option None - v} - - [sexp_opaque] causes the conversion to sexp to produce the atom [<opaque>]. - - For more documentation, see sexplib/README.md. *) - - type 'a sexp_array = 'a array - [@@deprecated "[since 2019-03] use [@sexp.array] instead"] - - type 'a sexp_list = 'a list [@@deprecated "[since 2019-03] use [@sexp.list] instead"] - type 'a sexp_opaque = 'a [@@deprecated "[since 2019-03] use [@sexp.opaque] instead"] - - type 'a sexp_option = 'a option - [@@deprecated "[since 2019-03] use [@sexp.option] instead"] - (** List operators *) include List.Infix diff --git a/src/binary_searchable.ml b/src/binary_searchable.ml index 74e2226..3de24e6 100644 --- a/src/binary_searchable.ml +++ b/src/binary_searchable.ml @@ -23,10 +23,10 @@ module Make_gen (T : Arg) = struct end module Make (T : Indexable) = Make_gen (struct + include T + type 'a elt = T.elt type 'a t = T.t - - include (T : Indexable with type elt := T.elt with type t := T.t) end) module Make1 (T : Indexable1) = Make_gen (struct diff --git a/src/binary_searchable_intf.ml b/src/binary_searchable_intf.ml index 61bdf96..a03f1a9 100644 --- a/src/binary_searchable_intf.ml +++ b/src/binary_searchable_intf.ml @@ -21,18 +21,49 @@ module type Indexable1 = sig val length : _ t -> int end +module Which_target_by_key = struct + type t = + [ `Last_strictly_less_than (** {v | < elt X | v} *) + | `Last_less_than_or_equal_to (** {v | <= elt X | v} *) + | `Last_equal_to (** {v | = elt X | v} *) + | `First_equal_to (** {v | X = elt | v} *) + | `First_greater_than_or_equal_to (** {v | X >= elt | v} *) + | `First_strictly_greater_than (** {v | X > elt | v} *) + ] + [@@deriving_inline enumerate] + + let all = + ([ `Last_strictly_less_than + ; `Last_less_than_or_equal_to + ; `Last_equal_to + ; `First_equal_to + ; `First_greater_than_or_equal_to + ; `First_strictly_greater_than + ] + : t list) + ;; + + [@@@end] +end + +module Which_target_by_segment = struct + type t = + [ `Last_on_left + | `First_on_right + ] + [@@deriving_inline enumerate] + + let all = ([ `Last_on_left; `First_on_right ] : t list) + + [@@@end] +end + type ('t, 'elt, 'key) binary_search = ?pos:int -> ?len:int -> 't -> compare:('elt -> 'key -> int) - -> [ `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} *) - ] + -> Which_target_by_key.t -> 'key -> int option @@ -41,7 +72,7 @@ type ('t, 'elt) binary_search_segmented = -> ?len:int -> 't -> segment_of:('elt -> [ `Left | `Right ]) - -> [ `Last_on_left | `First_on_right ] + -> Which_target_by_segment.t -> int option module type S = sig @@ -68,6 +99,9 @@ module type Binary_searchable = sig module type Indexable = Indexable module type Indexable1 = Indexable1 + module Which_target_by_key = Which_target_by_key + module Which_target_by_segment = Which_target_by_segment + type nonrec ('t, 'elt, 'key) binary_search = ('t, 'elt, 'key) binary_search type nonrec ('t, 'elt) binary_search_segmented = ('t, 'elt) binary_search_segmented diff --git a/src/bool.ml b/src/bool.ml index 18bde43..ef86e30 100644 --- a/src/bool.ml +++ b/src/bool.ml @@ -16,31 +16,14 @@ module T = struct fun x -> func x ;; - let t_of_sexp = (bool_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t) - let sexp_of_t = (sexp_of_bool : t -> Ppx_sexp_conv_lib.Sexp.t) - - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "bool" ] - ; ggid = "\146e\023\249\235eE\139c\132W\195\137\129\235\025" - ; types = [ "t", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ bool_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "bool.ml.T" - } - in - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("t", _the_group) - in - t_sexp_grammar - ;; + let t_of_sexp = (bool_of_sexp : Sexplib0.Sexp.t -> t) + let sexp_of_t = (sexp_of_bool : t -> Sexplib0.Sexp.t) + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = bool_sexp_grammar [@@@end] + let hashable : t Hashable.t = { hash; compare; sexp_of_t } + let of_string = function | "true" -> true | "false" -> false @@ -52,7 +35,6 @@ end include T include Comparator.Make (T) -include Comparable.Validate (T) include Pretty_printer.Register (struct type nonrec t = t diff --git a/src/bool.mli b/src/bool.mli index 7586e8f..94a5106 100644 --- a/src/bool.mli +++ b/src/bool.mli @@ -5,11 +5,10 @@ open! Import type t = bool [@@deriving_inline enumerate, sexp, sexp_grammar] -val all : t list +include Ppx_enumerate_lib.Enumerable.S with type t := t +include Sexplib0.Sexpable.S with type t := t -include Ppx_sexp_conv_lib.Sexpable.S with type t := t - -val t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t +val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] diff --git a/src/buffer_intf.ml b/src/buffer_intf.ml index bcd8df9..8a81a5f 100644 --- a/src/buffer_intf.ml +++ b/src/buffer_intf.ml @@ -4,7 +4,7 @@ module type S = sig (** The abstract type of buffers. *) type t [@@deriving_inline sexp_of] - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] diff --git a/src/bytes.ml b/src/bytes.ml index 3a00f43..e3641f6 100644 --- a/src/bytes.ml +++ b/src/bytes.ml @@ -6,28 +6,9 @@ let stage = Staged.stage module T = struct type t = bytes [@@deriving_inline sexp, sexp_grammar] - let t_of_sexp = (bytes_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t) - let sexp_of_t = (sexp_of_bytes : t -> Ppx_sexp_conv_lib.Sexp.t) - - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "bytes" ] - ; ggid = "\146e\023\249\235eE\139c\132W\195\137\129\235\025" - ; types = [ "t", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ bytes_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "bytes.ml.T" - } - in - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("t", _the_group) - in - t_sexp_grammar - ;; + let t_of_sexp = (bytes_of_sexp : Sexplib0.Sexp.t -> t) + let sexp_of_t = (sexp_of_bytes : t -> Sexplib0.Sexp.t) + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = bytes_sexp_grammar [@@@end] @@ -47,7 +28,6 @@ module To_bytes = Blit.Make (struct include To_bytes include Comparator.Make (T) -include Comparable.Validate (T) include Pretty_printer.Register_pp (T) (* Open replace_polymorphic_compare after including functor instantiations so they do not diff --git a/src/bytes.mli b/src/bytes.mli index a1aa925..5fb9f9a 100644 --- a/src/bytes.mli +++ b/src/bytes.mli @@ -9,9 +9,9 @@ open! Import type t = bytes [@@deriving_inline sexp, sexp_grammar] -include Ppx_sexp_conv_lib.Sexpable.S with type t := t +include Sexplib0.Sexpable.S with type t := t -val t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t +val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] @@ -23,8 +23,7 @@ include Stringable.S with type t := t (** Note that [pp] allocates in order to preserve the state of the byte sequence it was initially called with. *) -include - Pretty_printer.S with type t := t +include Pretty_printer.S with type t := t include Invariant.S with type t := t @@ -64,7 +63,7 @@ val init : int -> f:(int -> char) -> t val of_char_list : char list -> t (** [length t] returns the number of bytes in [t]. *) -val length : t -> int +external length : t -> int = "%bytes_length" (** [get t i] returns the [i]th byte of [t]. *) val get : t -> int -> char @@ -75,6 +74,8 @@ external unsafe_get : t -> int -> char = "%bytes_unsafe_get" val set : t -> int -> char -> unit external unsafe_set : t -> int -> char -> unit = "%bytes_unsafe_set" +external unsafe_get_int64 : t -> int -> int64 = "%caml_bytes_get64u" +external unsafe_set_int64 : t -> int -> int64 -> unit = "%caml_bytes_set64u" (** [fill t ~pos ~len c] modifies [t] in place, replacing all the bytes from [pos] to [pos + len] with [c]. *) diff --git a/src/bytes0.ml b/src/bytes0.ml index 42e89e9..6669184 100644 --- a/src/bytes0.ml +++ b/src/bytes0.ml @@ -34,6 +34,9 @@ module Primitives = struct -> unit = "caml_blit_string" [@@noalloc] + + external unsafe_get_int64 : bytes -> int -> int64 = "%caml_bytes_get64u" + external unsafe_set_int64 : bytes -> int -> int64 -> unit = "%caml_bytes_set64u" end include Primitives @@ -52,9 +55,5 @@ let sub = Caml.Bytes.sub let unsafe_blit = Caml.Bytes.unsafe_blit let to_string = Caml.Bytes.to_string let of_string = Caml.Bytes.of_string - -let unsafe_to_string ~no_mutation_while_string_reachable:s = - Caml.Bytes.unsafe_to_string s -;; - +let unsafe_to_string ~no_mutation_while_string_reachable:s = Caml.Bytes.unsafe_to_string s let unsafe_of_string_promise_no_mutation = Caml.Bytes.unsafe_of_string diff --git a/src/bytes_tr.ml b/src/bytes_tr.ml index 202e743..ea1268e 100644 --- a/src/bytes_tr.ml +++ b/src/bytes_tr.ml @@ -20,8 +20,7 @@ let tr_create_map ~target ~replacement = done; let last_replacement = String.unsafe_get replacement (String.length replacement - 1) in for - i = min (String.length target) (String.length replacement) - to String.length target - 1 + i = min (String.length target) (String.length replacement) to String.length target - 1 do let index = Char.to_int (String.unsafe_get target i) in Bytes.unsafe_set tr_map index last_replacement diff --git a/src/char.ml b/src/char.ml index 4416e64..7426655 100644 --- a/src/char.ml +++ b/src/char.ml @@ -16,28 +16,9 @@ module T = struct fun x -> func x ;; - let t_of_sexp = (char_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t) - let sexp_of_t = (sexp_of_char : t -> Ppx_sexp_conv_lib.Sexp.t) - - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "char" ] - ; ggid = "\146e\023\249\235eE\139c\132W\195\137\129\235\025" - ; types = [ "t", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ char_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "char.ml.T" - } - in - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("t", _the_group) - in - t_sexp_grammar - ;; + let t_of_sexp = (char_of_sexp : Sexplib0.Sexp.t -> t) + let sexp_of_t = (sexp_of_char : t -> Sexplib0.Sexp.t) + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = char_sexp_grammar [@@@end] @@ -58,6 +39,8 @@ include Identifiable.Make (struct let module_name = "Base.Char" end) +let pp fmt c = Caml.Format.fprintf fmt "%C" c + (* Open replace_polymorphic_compare after including functor instantiations so they do not shadow its definitions. This is here so that efficient versions of the comparison functions are available within this module. *) @@ -113,6 +96,34 @@ let get_digit_exn t = let get_digit t = if is_digit t then Some (get_digit_unsafe t) else None +let is_hex_digit = function + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false +;; + +let is_hex_digit_lower = function + | '0' .. '9' | 'a' .. 'f' -> true + | _ -> false +;; + +let is_hex_digit_upper = function + | '0' .. '9' | 'A' .. 'F' -> true + | _ -> false +;; + +let get_hex_digit_exn = function + | '0' .. '9' as t -> to_int t - to_int '0' + | 'a' .. 'f' as t -> to_int t - to_int 'a' + 10 + | 'A' .. 'F' as t -> to_int t - to_int 'A' + 10 + | t -> + Error.raise_s + (Sexp.message + "Char.get_hex_digit_exn: not a hexadecimal digit" + [ "char", sexp_of_t t ]) +;; + +let get_hex_digit t = if is_hex_digit t then Some (get_hex_digit_exn t) else None + module O = struct let ( >= ) = ( >= ) let ( <= ) = ( <= ) @@ -124,10 +135,11 @@ end module Caseless = struct module T = struct - type t = char [@@deriving_inline sexp] + type t = char [@@deriving_inline sexp, sexp_grammar] - let t_of_sexp = (char_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t) - let sexp_of_t = (sexp_of_char : t -> Ppx_sexp_conv_lib.Sexp.t) + let t_of_sexp = (char_of_sexp : Sexplib0.Sexp.t -> t) + let sexp_of_t = (sexp_of_char : t -> Sexplib0.Sexp.t) + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = char_sexp_grammar [@@@end] diff --git a/src/char.mli b/src/char.mli index 7bb1e7e..fca8ab3 100644 --- a/src/char.mli +++ b/src/char.mli @@ -5,11 +5,10 @@ open! Import (** An alias for the type of characters. *) type t = char [@@deriving_inline enumerate, sexp, sexp_grammar] -val all : t list +include Ppx_enumerate_lib.Enumerable.S with type t := t +include Sexplib0.Sexpable.S with type t := t -include Ppx_sexp_conv_lib.Sexpable.S with type t := t - -val t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t +val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] @@ -24,6 +23,7 @@ val to_int : t -> int the range 0 to 255. *) val of_int : int -> t option + (** Returns the character with the given ASCII code. Raises [Failure] if the argument is outside the range 0 to 255. *) val of_int_exn : int -> t @@ -67,18 +67,33 @@ val get_digit : t -> int option (** Returns [i] if [is_digit c] and raises [Failure] otherwise. *) val get_digit_exn : t -> int +(** '0' - '9' or 'a' - 'f' or 'A' - 'F' *) +val is_hex_digit : t -> bool + +(** '0' - '9' or 'a' - 'f' *) +val is_hex_digit_lower : t -> bool + +(** '0' - '9' or 'A' - 'F' *) +val is_hex_digit_upper : t -> bool + +(** Returns [Some i] where [0 <= i && i < 16] if [is_hex_digit c] and [None] otherwise. *) +val get_hex_digit : t -> int option + +(** Same as [get_hex_digit] but raises instead of returning None. *) +val get_hex_digit_exn : t -> int + val min_value : t val max_value : t (** [Caseless] compares and hashes characters ignoring case, so that for example [Caseless.equal 'A' 'a'] and [Caseless.('a' < 'B')] are [true]. *) module Caseless : sig - type nonrec t = t [@@deriving_inline hash, sexp] + type nonrec t = t [@@deriving_inline hash, sexp, sexp_grammar] - val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state - val hash : t -> Ppx_hash_lib.Std.Hash.hash_value + include Ppx_hash_lib.Hashable.S with type t := t + include Sexplib0.Sexpable.S with type t := t - include Ppx_sexp_conv_lib.Sexpable.S with type t := t + val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] diff --git a/src/comparable.ml b/src/comparable.ml index bf2a507..30c69b9 100644 --- a/src/comparable.ml +++ b/src/comparable.ml @@ -1,49 +1,18 @@ open! Import include Comparable_intf -module Validate (T : sig - type t [@@deriving_inline compare, sexp_of] - - val compare : t -> t -> int - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t - - [@@@end] - end) : Validate with type t := T.t = struct - module V = Validate - open Maybe_bound - - let to_string t = 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 With_zero (T : sig type t [@@deriving_inline compare] - val compare : t -> t -> int + include Ppx_compare_lib.Comparable.S with type t := t [@@@end] val zero : t - - include Validate with type t := t end) = struct open T - (* Preallocate the interesting bounds to minimize allocation in the implementations of - [validate_*]. *) - let excl_zero = Maybe_bound.Excl zero - let incl_zero = Maybe_bound.Incl 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 let is_positive t = compare t zero > 0 let is_non_negative t = compare t zero >= 0 let is_negative t = compare t zero < 0 @@ -51,30 +20,10 @@ struct let sign t = Sign0.of_int (compare t zero) end -module Validate_with_zero (T : sig - type t [@@deriving_inline compare, sexp_of] - - val compare : t -> t -> int - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t - - [@@@end] - - val zero : t - end) = -struct - module V = Validate (T) - include V - - include With_zero (struct - include T - include V - end) -end - module Poly (T : sig type t [@@deriving_inline sexp_of] - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end) = @@ -82,7 +31,7 @@ struct module Replace_polymorphic_compare = struct type t = T.t [@@deriving_inline sexp_of] - let sexp_of_t = (T.sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t) + let sexp_of_t = (T.sexp_of_t : t -> Sexplib0.Sexp.t) [@@@end] @@ -115,15 +64,6 @@ struct end include C - - include Validate (struct - type nonrec t = t [@@deriving_inline compare, sexp_of] - - let compare = (compare : t -> t -> int) - let sexp_of_t = (sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t) - - [@@@end] - end) end let gt cmp a b = cmp a b > 0 @@ -138,7 +78,7 @@ let max cmp t t' = if geq cmp t t' then t else t' module Infix (T : sig type t [@@deriving_inline compare] - val compare : t -> t -> int + include Ppx_compare_lib.Comparable.S with type t := t [@@@end] end) : Infix with type t := T.t = struct @@ -153,7 +93,7 @@ end module Polymorphic_compare (T : sig type t [@@deriving_inline compare] - val compare : t -> t -> int + include Ppx_compare_lib.Comparable.S with type t := t [@@@end] end) : Polymorphic_compare with type t := T.t = struct @@ -168,7 +108,7 @@ end module Make_using_comparator (T : sig type t [@@deriving_inline sexp_of] - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] @@ -203,15 +143,14 @@ module Make_using_comparator (T : sig [ "min", T.sexp_of_t min; "max", T.sexp_of_t max ]) else Ok (clamp_unchecked t ~min ~max) ;; - - include Validate (T) end module Make (T : sig type t [@@deriving_inline compare, sexp_of] - val compare : t -> t -> int - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + include Ppx_compare_lib.Comparable.S with type t := t + + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end) = @@ -223,13 +162,13 @@ module Make (T : sig module Inherit (C : sig type t [@@deriving_inline compare] - val compare : t -> t -> int + include Ppx_compare_lib.Comparable.S with type t := t [@@@end] end) (T : sig type t [@@deriving_inline sexp_of] - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] @@ -238,7 +177,7 @@ module Inherit (C : sig Make (struct type t = T.t [@@deriving_inline sexp_of] - let sexp_of_t = (T.sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t) + let sexp_of_t = (T.sexp_of_t : t -> Sexplib0.Sexp.t) [@@@end] diff --git a/src/comparable_intf.ml b/src/comparable_intf.ml index 9adbe4c..03e359b 100644 --- a/src/comparable_intf.ml +++ b/src/comparable_intf.ml @@ -3,28 +3,47 @@ open! Import module type Infix = Comparisons.Infix module type Polymorphic_compare = Comparisons.S -module type Validate = sig - type t +module Sign = Sign0 (** @canonical Base.Sign *) + +module type With_compare = sig + (** Various combinators for [compare] and [equal] functions. *) + + (** [lexicographic cmps x y] compares [x] and [y] lexicographically using functions in the + list [cmps]. *) + val lexicographic : ('a -> 'a -> int) list -> 'a -> 'a -> int + + (** [lift cmp ~f x y] compares [x] and [y] by comparing [f x] and [f y] via [cmp]. *) + val lift : ('a -> 'a -> 'result) -> f:('b -> 'a) -> 'b -> 'b -> 'result + + (** [reverse cmp x y = cmp y x] + + Reverses the direction of asymmetric relations by swapping their arguments. Useful, + e.g., for relations implementing "is a subset of" or "is a descendant of". + + Where reversed relations are already provided, use them directly. For example, + [Comparable.S] provides [ascending] and [descending], which are more readable as a + pair than [compare] and [reverse compare]. Similarly, [<=] is more idiomatic than + [reverse (>=)]. *) + val reverse : ('a -> 'a -> 'result) -> 'a -> 'a -> 'result - 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 + (** The functions below are analogues of the type-specific functions exported by the + [Comparable.S] interface. *) + + val equal : ('a -> 'a -> int) -> 'a -> 'a -> bool + val max : ('a -> 'a -> int) -> 'a -> 'a -> 'a + val min : ('a -> 'a -> int) -> 'a -> 'a -> 'a end module type With_zero = sig type t - val 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 val is_positive : t -> bool val is_non_negative : t -> bool val is_negative : t -> bool val is_non_positive : t -> bool (** Returns [Neg], [Zero], or [Pos] in a way consistent with the above functions. *) - val sign : t -> Sign0.t + val sign : t -> Sign.t end module type S = sig @@ -51,7 +70,6 @@ module type S = sig val clamp : t -> min:t -> max:t -> t Or_error.t include Comparator.S with type t := t - include Validate with type t := t end (** Usage example: @@ -120,33 +138,10 @@ module type Comparable = sig module type Infix = Infix module type S = S module type Polymorphic_compare = Polymorphic_compare - module type Validate = Validate + module type With_compare = With_compare module type With_zero = With_zero - (** [lexicographic cmps x y] compares [x] and [y] lexicographically using functions in the - list [cmps]. *) - val lexicographic : ('a -> 'a -> int) list -> 'a -> 'a -> int - - (** [lift cmp ~f x y] compares [x] and [y] by comparing [f x] and [f y] via [cmp]. *) - val lift : ('a -> 'a -> 'result) -> f:('b -> 'a) -> 'b -> 'b -> 'result - - (** [reverse cmp x y = cmp y x] - - Reverses the direction of asymmetric relations by swapping their arguments. Useful, - e.g., for relations implementing "is a subset of" or "is a descendant of". - - Where reversed relations are already provided, use them directly. For example, - [Comparable.S] provides [ascending] and [descending], which are more readable as a - pair than [compare] and [reverse compare]. Similarly, [<=] is more idiomatic than - [reverse (>=)]. *) - val reverse : ('a -> 'a -> 'result) -> 'a -> 'a -> 'result - - (** The functions below are analogues of the type-specific functions exported by the - [Comparable.S] interface. *) - - val equal : ('a -> 'a -> int) -> 'a -> 'a -> bool - val max : ('a -> 'a -> int) -> 'a -> 'a -> 'a - val min : ('a -> 'a -> int) -> 'a -> 'a -> 'a + include With_compare (** Derive [Infix] or [Polymorphic_compare] functions from just [[@@deriving compare]], without need for the [sexp_of_t] required by [Make*] (see below). *) @@ -154,7 +149,7 @@ module type Comparable = sig module Infix (T : sig type t [@@deriving_inline compare] - val compare : t -> t -> int + include Ppx_compare_lib.Comparable.S with type t := t [@@@end] end) : Infix with type t := T.t @@ -162,7 +157,7 @@ module type Comparable = sig module Polymorphic_compare (T : sig type t [@@deriving_inline compare] - val compare : t -> t -> int + include Ppx_compare_lib.Comparable.S with type t := t [@@@end] end) : Polymorphic_compare with type t := T.t @@ -171,13 +166,13 @@ module type Comparable = sig module Inherit (C : sig type t [@@deriving_inline compare] - val compare : t -> t -> int + include Ppx_compare_lib.Comparable.S with type t := t [@@@end] end) (T : sig type t [@@deriving_inline sexp_of] - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] @@ -187,8 +182,9 @@ module type Comparable = sig module Make (T : sig type t [@@deriving_inline compare, sexp_of] - val compare : t -> t -> int - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + include Ppx_compare_lib.Comparable.S with type t := t + + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end) : S with type t := T.t @@ -196,7 +192,7 @@ module type Comparable = sig module Make_using_comparator (T : sig type t [@@deriving_inline sexp_of] - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] @@ -206,44 +202,22 @@ module type Comparable = sig module Poly (T : sig type t [@@deriving_inline sexp_of] - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end) : S with type t := T.t - module Validate (T : sig - type t [@@deriving_inline compare, sexp_of] - - val compare : t -> t -> int - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t - - [@@@end] - end) : Validate with type t := T.t - module With_zero (T : sig type t [@@deriving_inline compare, sexp_of] - val compare : t -> t -> int - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t - - [@@@end] - - val zero : t - - include Validate with type t := t - end) : With_zero with type t := T.t - - module Validate_with_zero (T : sig - type t [@@deriving_inline compare, sexp_of] + include Ppx_compare_lib.Comparable.S with type t := t - val compare : t -> t -> int - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] val zero : t end) : sig - include Validate with type t := T.t include With_zero with type t := T.t end end diff --git a/src/comparator.ml b/src/comparator.ml index 62900f3..c7d2726 100644 --- a/src/comparator.ml +++ b/src/comparator.ml @@ -27,6 +27,10 @@ module type S_fc = sig include S with type t := comparable_t end +module Module = struct + type ('a, 'b) t = (module S with type t = 'a and type comparator_witness = 'b) +end + let make (type t) ~compare ~sexp_of_t = (module struct type comparable_t = t @@ -49,8 +53,9 @@ end module Make (M : sig type t [@@deriving_inline compare, sexp_of] - val compare : t -> t -> int - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + include Ppx_compare_lib.Comparable.S with type t := t + + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end) = @@ -95,8 +100,9 @@ end module Derived (M : sig type 'a t [@@deriving_inline compare, sexp_of] - val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int - val sexp_of_t : ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t + include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t + + val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t [@@@end] end) = @@ -121,13 +127,13 @@ end module Derived2 (M : sig type ('a, 'b) t [@@deriving_inline compare, sexp_of] - val compare : ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int + include Ppx_compare_lib.Comparable.S2 with type ('a, 'b) t := ('a, 'b) t val sexp_of_t - : ('a -> Ppx_sexp_conv_lib.Sexp.t) - -> ('b -> Ppx_sexp_conv_lib.Sexp.t) + : ('a -> Sexplib0.Sexp.t) + -> ('b -> Sexplib0.Sexp.t) -> ('a, 'b) t - -> Ppx_sexp_conv_lib.Sexp.t + -> Sexplib0.Sexp.t [@@@end] end) = diff --git a/src/comparator.mli b/src/comparator.mli index 3842c86..4367804 100644 --- a/src/comparator.mli +++ b/src/comparator.mli @@ -1,12 +1,11 @@ -(** A type-indexed value that allows one to compare (and for generating error messages, - serialize) values of the type in question. - - One of the type parameters is a phantom parameter used to distinguish comparators - potentially built on different comparison functions. In particular, we want to - distinguish those using polymorphic compare from those using a monomorphic compare. *) +(** Comparison and serialization for a type, using a witness type to distinguish between + comparison functions with different behavior. *) open! Import +(** [('a, 'witness) t] contains a comparison function for values of type ['a]. Two values + of type [t] with the same ['witness] are guaranteed to have the same comparison + function. *) type ('a, 'witness) t = private { compare : 'a -> 'a -> int ; sexp_of_t : 'a -> Sexp.t @@ -37,7 +36,11 @@ end (** [make] creates a comparator witness for the given comparison. It is intended as a lightweight alternative to the functors below, to be used like so: - [include (val Comparator.make ~compare ~sexp_of_t)] *) + + {[ + include (val Comparator.make ~compare ~sexp_of_t) + ]} +*) val make : compare:('a -> 'a -> int) -> sexp_of_t:('a -> Sexp.t) @@ -45,6 +48,11 @@ val make module Poly : S1 with type 'a t = 'a +module Module : sig + (** First-class module providing a comparator and witness type. *) + type ('a, 'b) t = (module S with type t = 'a and type comparator_witness = 'b) +end + module S_to_S1 (S : S) : S1 with type 'a t = S.t with type comparator_witness = S.comparator_witness @@ -53,12 +61,14 @@ module S_to_S1 (S : S) : module Make (M : sig type t [@@deriving_inline compare, sexp_of] - val compare : t -> t -> int - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + include Ppx_compare_lib.Comparable.S with type t := t + + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end) : S with type t := M.t + (** [Make1] creates a [comparator] value and its phantom [comparator_witness] type for a unary type. It takes a [compare] and [sexp_of_t] that have non-standard types because the [Comparator.t] type doesn't allow passing in @@ -82,8 +92,9 @@ end module Derived (M : sig type 'a t [@@deriving_inline compare, sexp_of] - val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int - val sexp_of_t : ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t + include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t + + val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t [@@@end] end) : Derived with type 'a t := 'a M.t @@ -103,13 +114,13 @@ end module Derived2 (M : sig type ('a, 'b) t [@@deriving_inline compare, sexp_of] - val compare : ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int + include Ppx_compare_lib.Comparable.S2 with type ('a, 'b) t := ('a, 'b) t val sexp_of_t - : ('a -> Ppx_sexp_conv_lib.Sexp.t) - -> ('b -> Ppx_sexp_conv_lib.Sexp.t) + : ('a -> Sexplib0.Sexp.t) + -> ('b -> Sexplib0.Sexp.t) -> ('a, 'b) t - -> Ppx_sexp_conv_lib.Sexp.t + -> Sexplib0.Sexp.t [@@@end] end) : Derived2 with type ('a, 'b) t := ('a, 'b) M.t diff --git a/src/container.ml b/src/container.ml index 5d23d35..c6c40b9 100644 --- a/src/container.ml +++ b/src/container.ml @@ -139,7 +139,7 @@ end module Make0 (T : Make0_arg) = struct include Make_gen (struct - include (T : Make0_arg with type t := T.t with module Elt := T.Elt) + include T type 'a t = T.t type 'a elt = T.Elt.t @@ -147,67 +147,3 @@ module Make0 (T : Make0_arg) = struct let mem t elt = exists t ~f:(T.Elt.equal elt) end - -open T - - -(* The following functors exist as a consistency check among all the various [S?] - interfaces. They ensure that each particular [S?] is an instance of a more generic - signature. *) -module Check - (T : T1) - (Elt : T1) - (M : Generic with type 'a t := 'a T.t with type 'a elt := 'a Elt.t) = -struct end - -module Check_S0 (M : S0) = - Check - (struct - type 'a t = M.t - end) - (struct - type 'a t = M.elt - end) - (M) - -module Check_S0_phantom (M : S0_phantom) = - Check - (struct - type 'a t = 'a M.t - end) - (struct - type 'a t = M.elt - end) - (M) - -module Check_S1 (M : S1) = - Check - (struct - type 'a t = 'a M.t - end) - (struct - type 'a t = 'a - end) - (M) - -type phantom - -module Check_S1_phantom (M : S1_phantom) = - Check - (struct - type 'a t = ('a, phantom) M.t - end) - (struct - type 'a t = 'a - end) - (M) - -module Check_S1_phantom_invariant (M : S1_phantom_invariant) = - Check - (struct - type 'a t = ('a, phantom) M.t - end) - (struct - type 'a t = 'a - end) - (M) diff --git a/src/container_intf.ml b/src/container_intf.ml index e54cf37..8885e66 100644 --- a/src/container_intf.ml +++ b/src/container_intf.ml @@ -9,7 +9,10 @@ open! Import module Export = struct (** [Continue_or_stop.t] is used by the [f] argument to [fold_until] in order to - indicate whether folding should continue, or stop early. *) + indicate whether folding should continue, or stop early. + + @canonical Base.Container.Continue_or_stop + *) module Continue_or_stop = struct type ('a, 'b) t = | Continue of 'a @@ -19,6 +22,7 @@ end include Export +(** @canonical Base.Container.Summable *) module type Summable = sig type t @@ -30,7 +34,9 @@ module type Summable = sig val ( + ) : t -> t -> t end -(** Signature for monomorphic container, e.g., string. *) +(** Signature for monomorphic container - a container for a specific element type, e.g., + string, which is a container of characters ([type elt = char]) and never of anything + else. *) module type S0 = sig type t type elt @@ -531,9 +537,7 @@ module type Make0_arg = sig type t - val fold : t -> init:'accum -> f:('accum -> Elt.t -> 'accum) -> 'accum - val iter : [ `Define_using_fold | `Custom of t -> f:(Elt.t -> unit) -> unit ] - val length : [ `Define_using_fold | `Custom of t -> int ] + include Make_gen_arg with type 'a t := t and type 'a elt := Elt.t end module type Container = sig @@ -632,4 +636,7 @@ module type Container = sig module Make (T : Make_arg) : S1 with type 'a t := 'a T.t module Make0 (T : Make0_arg) : S0 with type t := T.t and type elt := T.Elt.t + + module Make_gen (T : Make_gen_arg) : + Generic with type 'a t := 'a T.t and type 'a elt := 'a T.elt end @@ -20,4 +20,6 @@ (rule (targets mpopcnt.sexp) (action (run ./discover/discover.exe -o %{targets}))) -(ocamllex hex_lexer)
\ No newline at end of file +(ocamllex hex_lexer) + +(documentation)
\ No newline at end of file diff --git a/src/either.ml b/src/either.ml index 6e4d6b7..33de827 100644 --- a/src/either.ml +++ b/src/either.ml @@ -1,6 +1,5 @@ open! Import include Either_intf -module Array = Array0 module List = List0 include Either0 diff --git a/src/either0.ml b/src/either0.ml index 3ccf6a5..dfe10f9 100644 --- a/src/either0.ml +++ b/src/either0.ml @@ -3,7 +3,7 @@ open! Import type ('f, 's) t = | First of 'f | Second of 's -[@@deriving_inline compare, hash, sexp] +[@@deriving_inline compare, hash, sexp, sexp_grammar] let compare : 'f 's. ('f -> 'f -> int) -> ('s -> 's -> int) -> ('f, 's) t -> ('f, 's) t -> int @@ -39,56 +39,90 @@ let hash_fold_t _hash_fold_s hsv _a0 ;; -let t_of_sexp - : type f s. - (Ppx_sexp_conv_lib.Sexp.t -> f) - -> (Ppx_sexp_conv_lib.Sexp.t -> s) - -> Ppx_sexp_conv_lib.Sexp.t - -> (f, s) t +let t_of_sexp : + 'f 's. + (Sexplib0.Sexp.t -> 'f) -> (Sexplib0.Sexp.t -> 's) -> Sexplib0.Sexp.t -> ('f, 's) t = - let _tp_loc = "either0.ml.t" in - fun _of_f _of_s -> function - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom (("first" | "First") as _tag) :: sexp_args) as _sexp - -> - (match sexp_args with - | [ v0 ] -> - let v0 = _of_f v0 in - First v0 - | _ -> Ppx_sexp_conv_lib.Conv_error.stag_incorrect_n_args _tp_loc _tag _sexp) - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom (("second" | "Second") as _tag) :: sexp_args) as - _sexp -> - (match sexp_args with - | [ v0 ] -> - let v0 = _of_s v0 in - Second v0 - | _ -> Ppx_sexp_conv_lib.Conv_error.stag_incorrect_n_args _tp_loc _tag _sexp) - | Ppx_sexp_conv_lib.Sexp.Atom ("first" | "First") as sexp -> - Ppx_sexp_conv_lib.Conv_error.stag_takes_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.Atom ("second" | "Second") as sexp -> - Ppx_sexp_conv_lib.Conv_error.stag_takes_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.List _ :: _) as sexp -> - Ppx_sexp_conv_lib.Conv_error.nested_list_invalid_sum _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List [] as sexp -> - Ppx_sexp_conv_lib.Conv_error.empty_list_invalid_sum _tp_loc sexp - | sexp -> Ppx_sexp_conv_lib.Conv_error.unexpected_stag _tp_loc sexp + fun (type f__023_ s__024_) + : ((Sexplib0.Sexp.t -> f__023_) -> (Sexplib0.Sexp.t -> s__024_) -> Sexplib0.Sexp.t + -> (f__023_, s__024_) t) -> + let error_source__011_ = "either0.ml.t" in + fun _of_f__007_ _of_s__008_ -> function + | Sexplib0.Sexp.List + (Sexplib0.Sexp.Atom (("first" | "First") as _tag__014_) :: sexp_args__015_) as + _sexp__013_ -> + (match sexp_args__015_ with + | [ arg0__016_ ] -> + let res0__017_ = _of_f__007_ arg0__016_ in + First res0__017_ + | _ -> + Sexplib0.Sexp_conv_error.stag_incorrect_n_args + error_source__011_ + _tag__014_ + _sexp__013_) + | Sexplib0.Sexp.List + (Sexplib0.Sexp.Atom (("second" | "Second") as _tag__019_) :: sexp_args__020_) as + _sexp__018_ -> + (match sexp_args__020_ with + | [ arg0__021_ ] -> + let res0__022_ = _of_s__008_ arg0__021_ in + Second res0__022_ + | _ -> + Sexplib0.Sexp_conv_error.stag_incorrect_n_args + error_source__011_ + _tag__019_ + _sexp__018_) + | Sexplib0.Sexp.Atom ("first" | "First") as sexp__012_ -> + Sexplib0.Sexp_conv_error.stag_takes_args error_source__011_ sexp__012_ + | Sexplib0.Sexp.Atom ("second" | "Second") as sexp__012_ -> + Sexplib0.Sexp_conv_error.stag_takes_args error_source__011_ sexp__012_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__010_ -> + Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__011_ sexp__010_ + | Sexplib0.Sexp.List [] as sexp__010_ -> + Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__011_ sexp__010_ + | sexp__010_ -> + Sexplib0.Sexp_conv_error.unexpected_stag error_source__011_ sexp__010_ ;; -let sexp_of_t - : type f s. - (f -> Ppx_sexp_conv_lib.Sexp.t) - -> (s -> Ppx_sexp_conv_lib.Sexp.t) - -> (f, s) t - -> Ppx_sexp_conv_lib.Sexp.t +let sexp_of_t : + 'f 's. + ('f -> Sexplib0.Sexp.t) -> ('s -> Sexplib0.Sexp.t) -> ('f, 's) t -> Sexplib0.Sexp.t + = + fun (type f__031_ s__032_) + : ((f__031_ -> Sexplib0.Sexp.t) -> (s__032_ -> Sexplib0.Sexp.t) + -> (f__031_, s__032_) t -> Sexplib0.Sexp.t) -> + fun _of_f__025_ _of_s__026_ -> function + | First arg0__027_ -> + let res0__028_ = _of_f__025_ arg0__027_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "First"; res0__028_ ] + | Second arg0__029_ -> + let res0__030_ = _of_s__026_ arg0__029_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Second"; res0__030_ ] +;; + +let (t_sexp_grammar : + 'f Sexplib0.Sexp_grammar.t + -> 's Sexplib0.Sexp_grammar.t + -> ('f, 's) t Sexplib0.Sexp_grammar.t) = - fun _of_f _of_s -> function - | First v0 -> - let v0 = _of_f v0 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "First"; v0 ] - | Second v0 -> - let v0 = _of_s v0 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Second"; v0 ] + fun _'f_sexp_grammar _'s_sexp_grammar -> + { untyped = + Variant + { case_sensitivity = Case_sensitive_except_first_character + ; clauses = + [ No_tag + { name = "First" + ; clause_kind = + List_clause { args = Cons (_'f_sexp_grammar.untyped, Empty) } + } + ; No_tag + { name = "Second" + ; clause_kind = + List_clause { args = Cons (_'s_sexp_grammar.untyped, Empty) } + } + ] + } + } ;; [@@@end] diff --git a/src/either_intf.ml b/src/either_intf.ml index 53ec9c3..48cb53d 100644 --- a/src/either_intf.ml +++ b/src/either_intf.ml @@ -34,18 +34,16 @@ module type Either = sig type ('f, 's) t = ('f, 's) Either0.t = | First of 'f | Second of 's - [@@deriving_inline compare, hash, sexp] + [@@deriving_inline compare, hash, sexp, sexp_grammar] - val compare : ('f -> 'f -> int) -> ('s -> 's -> int) -> ('f, 's) t -> ('f, 's) t -> int + include Ppx_compare_lib.Comparable.S2 with type ('f, 's) t := ('f, 's) t + include Ppx_hash_lib.Hashable.S2 with type ('f, 's) t := ('f, 's) t + include Sexplib0.Sexpable.S2 with type ('f, 's) t := ('f, 's) t - val hash_fold_t - : (Ppx_hash_lib.Std.Hash.state -> 'f -> Ppx_hash_lib.Std.Hash.state) - -> (Ppx_hash_lib.Std.Hash.state -> 's -> Ppx_hash_lib.Std.Hash.state) - -> Ppx_hash_lib.Std.Hash.state - -> ('f, 's) t - -> Ppx_hash_lib.Std.Hash.state - - include Ppx_sexp_conv_lib.Sexpable.S2 with type ('f, 's) t := ('f, 's) t + val t_sexp_grammar + : 'f Sexplib0.Sexp_grammar.t + -> 's Sexplib0.Sexp_grammar.t + -> ('f, 's) t Sexplib0.Sexp_grammar.t [@@@end] @@ -56,13 +54,7 @@ module type Either = sig val iter : ('a, 'b) t -> first:('a -> unit) -> second:('b -> unit) -> unit val value_map : ('a, 'b) t -> first:('a -> 'c) -> second:('b -> 'c) -> 'c val map : ('a, 'b) t -> first:('a -> 'c) -> second:('b -> 'd) -> ('c, 'd) t - - val equal - : ('f -> 'f -> bool) - -> ('s -> 's -> bool) - -> ('f, 's) t - -> ('f, 's) t - -> bool + val equal : ('f -> 'f -> bool) -> ('s -> 's -> bool) -> ('f, 's) t -> ('f, 's) t -> bool module type Focused = Focused diff --git a/src/error.ml b/src/error.ml index 521bb9b..3ca891e 100644 --- a/src/error.ml +++ b/src/error.ml @@ -5,6 +5,7 @@ open! Import include Info +let t_sexp_grammar : t Sexplib0.Sexp_grammar.t = { untyped = Any "Error.t" } let raise t = raise (to_exn t) let raise_s sexp = raise (create_s sexp) let to_info t = t @@ -2,7 +2,7 @@ open! Import type t = exn [@@deriving_inline sexp_of] -let sexp_of_t = (sexp_of_exn : t -> Ppx_sexp_conv_lib.Sexp.t) +let sexp_of_t = (sexp_of_exn : t -> Sexplib0.Sexp.t) [@@@end] @@ -11,12 +11,11 @@ let exit = Caml.exit exception Finally of t * t [@@deriving_inline sexp] let () = - Ppx_sexp_conv_lib.Conv.Exn_converter.add [%extension_constructor Finally] (function - | Finally (v0, v1) -> - let v0 = sexp_of_t v0 - and v1 = sexp_of_t v1 in - Ppx_sexp_conv_lib.Sexp.List - [ Ppx_sexp_conv_lib.Sexp.Atom "exn.ml.Finally"; v0; v1 ] + Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Finally] (function + | Finally (arg0__001_, arg1__002_) -> + let res0__003_ = sexp_of_t arg0__001_ + and res1__004_ = sexp_of_t arg1__002_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "exn.ml.Finally"; res0__003_; res1__004_ ] | _ -> assert false) ;; @@ -25,12 +24,12 @@ let () = exception Reraised of string * t [@@deriving_inline sexp] let () = - Ppx_sexp_conv_lib.Conv.Exn_converter.add [%extension_constructor Reraised] (function - | Reraised (v0, v1) -> - let v0 = sexp_of_string v0 - and v1 = sexp_of_t v1 in - Ppx_sexp_conv_lib.Sexp.List - [ Ppx_sexp_conv_lib.Sexp.Atom "exn.ml.Reraised"; v0; v1 ] + Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Reraised] (function + | Reraised (arg0__005_, arg1__006_) -> + let res0__007_ = sexp_of_string arg0__005_ + and res1__008_ = sexp_of_t arg1__006_ in + Sexplib0.Sexp.List + [ Sexplib0.Sexp.Atom "exn.ml.Reraised"; res0__007_; res1__008_ ] | _ -> assert false) ;; @@ -48,7 +47,7 @@ exception Sexp of Sexp.t to eliminate the extra wrapping of [(Sexp ...)]. *) let () = - Sexplib.Conv.Exn_converter.add [%extension_constructor Sexp] (function + Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Sexp] (function | Sexp t -> t | _ -> (* Reaching this branch indicates a bug in sexplib. *) @@ -56,7 +55,22 @@ let () = ;; let create_s sexp = Sexp sexp -let reraise exc str = raise (Reraised (str, exc)) + +let raise_with_original_backtrace t backtrace = + Caml.Printexc.raise_with_backtrace t backtrace +;; + +external is_phys_equal_most_recent : t -> bool = "Base_caml_exn_is_most_recent_exn" + +let reraise exn str = + let exn' = Reraised (str, exn) in + if is_phys_equal_most_recent exn + then ( + let bt = Caml.Printexc.get_raw_backtrace () in + raise_with_original_backtrace exn' bt) + else raise exn' +;; + let reraisef exc format = Printf.ksprintf (fun str () -> reraise exc str) format let to_string exc = Sexp.to_string_hum ~indent:2 (sexp_of_exn exc) let to_string_mach exc = Sexp.to_string_mach (sexp_of_exn exc) @@ -68,10 +82,12 @@ let protectx ~f x ~(finally : _ -> unit) = finally x; res | exception exn -> - raise - (match finally x with - | () -> exn - | exception final_exn -> Finally (exn, final_exn)) + let bt = Caml.Printexc.get_raw_backtrace () in + (match finally x with + | () -> raise_with_original_backtrace exn bt + | exception final_exn -> + (* Unfortunately, the backtrace of the [final_exn] is discarded here. *) + raise_with_original_backtrace (Finally (exn, final_exn)) bt) ;; let protect ~f ~finally = protectx ~f () ~finally @@ -136,7 +152,9 @@ let handle_uncaught ~exit:must_exit f = let reraise_uncaught str func = try func () with - | exn -> raise (Reraised (str, exn)) + | exn -> + let bt = Caml.Printexc.get_raw_backtrace () in + raise_with_original_backtrace (Reraised (str, exn)) bt ;; external clear_backtrace : unit -> unit = "Base_clear_caml_backtrace_pos" [@@noalloc] diff --git a/src/exn.mli b/src/exn.mli index e0d27f1..e8fe809 100644 --- a/src/exn.mli +++ b/src/exn.mli @@ -9,7 +9,7 @@ open! Import type t = exn [@@deriving_inline sexp_of] -val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t +val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] @@ -30,6 +30,11 @@ val create_s : Sexp.t -> t (** Same as [raise], except that the backtrace is not recorded. *) val raise_without_backtrace : t -> _ +(** [raise_with_original_backtrace t bt] raises the exception [exn], recording [bt] + as the backtrace it was originally raised at. This is useful to re-raise + exceptions annotated with extra information. *) +val raise_with_original_backtrace : t -> Caml.Printexc.raw_backtrace -> _ + val reraise : t -> string -> _ (** Types with [format4] are hard to read, so here's an example. @@ -86,7 +91,17 @@ val reraise_uncaught : string -> (unit -> 'a) -> 'a tests. *) val does_raise : (unit -> _) -> bool -(** User code never calls this. It is called in [std_kernel.ml] as a top-level side +(** Returns [true] if this exception is physically equal to the most recently raised one. + If so, then [Backtrace.Exn.most_recent ()] is a backtrace corresponding to this + exception. + + Note that, confusingly, exceptions can be physically equal even if the caller was not + involved in handling of the last-raised exception. See the documentation of + [Backtrace.Exn.most_recent_for_exn] for further discussion. +*) +val is_phys_equal_most_recent : t -> bool + +(** User code never calls this. It is called in [base.ml] as a top-level side effect to change the display of exceptions and install an uncaught-exception printer. *) val initialize_module : unit -> unit diff --git a/src/exn_stubs.c b/src/exn_stubs.c index 891902f..2f90074 100644 --- a/src/exn_stubs.c +++ b/src/exn_stubs.c @@ -1,4 +1,10 @@ #define CAML_INTERNALS +#ifndef CAML_NAME_SPACE +#define CAML_NAME_SPACE +#endif +/* If CAML_NAME_SPACE is not defined, then legacy names like + [backtrace_last_exn] are in scope, which can lead to confusing errors. + It's cleaner to disable those names. */ #include <caml/mlvalues.h> #include <caml/backtrace.h> @@ -6,3 +12,7 @@ CAMLprim value Base_clear_caml_backtrace_pos () { caml_backtrace_pos = 0; return Val_unit; } + +CAMLprim value Base_caml_exn_is_most_recent_exn (value exn) { + return Val_bool(caml_backtrace_last_exn == exn); +} diff --git a/src/float.ml b/src/float.ml index 918865d..fe517a6 100644 --- a/src/float.ml +++ b/src/float.ml @@ -16,31 +16,13 @@ module T = struct fun x -> func x ;; - let t_of_sexp = (float_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t) - let sexp_of_t = (sexp_of_float : t -> Ppx_sexp_conv_lib.Sexp.t) - - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "float" ] - ; ggid = "\146e\023\249\235eE\139c\132W\195\137\129\235\025" - ; types = [ "t", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ float_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "float.ml.T" - } - in - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("t", _the_group) - in - t_sexp_grammar - ;; + let t_of_sexp = (float_of_sexp : Sexplib0.Sexp.t -> t) + let sexp_of_t = (sexp_of_float : t -> Sexplib0.Sexp.t) + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = float_sexp_grammar [@@@end] + let hashable : t Hashable.t = { hash; compare; sexp_of_t } let compare = Float_replace_polymorphic_compare.compare end @@ -306,7 +288,7 @@ let round_nearest_ub = 2. ** 52. and it gets rounded up to [1.] due to the round-ties-to-even rule. *) let one_ulp_less_than_half = one_ulp `Down 0.5 -let add_half_for_round_nearest t = +let[@ocaml.inline always] add_half_for_round_nearest t = t +. if t = one_ulp_less_than_half @@ -397,11 +379,8 @@ let iround ?(dir = `Nearest) t = | _ -> None ;; -let is_inf x = - match classify_float x with - | FP_infinite -> true - | _ -> false -;; +let is_inf t = 1. /. t = 0. +let is_finite t = t -. t = 0. let min_inan (x : t) y = if is_nan y then x else if is_nan x then y else if x < y then x else y @@ -508,7 +487,7 @@ let int63_round_down_exn t = ;; let int63_round_nearest_portable_alloc_exn t0 = - let t = round_nearest t0 in + let t = (round_nearest [@ocaml.inlined always]) t0 in if t > 0. then if t <= int63_round_ubound @@ -550,48 +529,61 @@ module Class = struct | Normal | Subnormal | Zero - [@@deriving_inline compare, enumerate, sexp] + [@@deriving_inline compare, enumerate, sexp, sexp_grammar] let compare = (Ppx_compare_lib.polymorphic_compare : t -> t -> int) let all = ([ Infinite; Nan; Normal; Subnormal; Zero ] : t list) let t_of_sexp = - (let _tp_loc = "float.ml.Class.t" in + (let error_source__006_ = "float.ml.Class.t" in function - | Ppx_sexp_conv_lib.Sexp.Atom ("infinite" | "Infinite") -> Infinite - | Ppx_sexp_conv_lib.Sexp.Atom ("nan" | "Nan") -> Nan - | Ppx_sexp_conv_lib.Sexp.Atom ("normal" | "Normal") -> Normal - | Ppx_sexp_conv_lib.Sexp.Atom ("subnormal" | "Subnormal") -> Subnormal - | Ppx_sexp_conv_lib.Sexp.Atom ("zero" | "Zero") -> Zero - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom ("infinite" | "Infinite") :: _) as sexp -> - Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom ("nan" | "Nan") :: _) as - sexp -> Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom ("normal" | "Normal") :: _) as sexp -> - Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom ("subnormal" | "Subnormal") :: _) as sexp -> - Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom ("zero" | "Zero") :: _) - as sexp -> Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.List _ :: _) as sexp -> - Ppx_sexp_conv_lib.Conv_error.nested_list_invalid_sum _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List [] as sexp -> - Ppx_sexp_conv_lib.Conv_error.empty_list_invalid_sum _tp_loc sexp - | sexp -> Ppx_sexp_conv_lib.Conv_error.unexpected_stag _tp_loc sexp - : Ppx_sexp_conv_lib.Sexp.t -> t) + | Sexplib0.Sexp.Atom ("infinite" | "Infinite") -> Infinite + | Sexplib0.Sexp.Atom ("nan" | "Nan") -> Nan + | Sexplib0.Sexp.Atom ("normal" | "Normal") -> Normal + | Sexplib0.Sexp.Atom ("subnormal" | "Subnormal") -> Subnormal + | Sexplib0.Sexp.Atom ("zero" | "Zero") -> Zero + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("infinite" | "Infinite") :: _) as + sexp__007_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__006_ sexp__007_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("nan" | "Nan") :: _) as sexp__007_ -> + Sexplib0.Sexp_conv_error.stag_no_args error_source__006_ sexp__007_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("normal" | "Normal") :: _) as sexp__007_ -> + Sexplib0.Sexp_conv_error.stag_no_args error_source__006_ sexp__007_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("subnormal" | "Subnormal") :: _) as + sexp__007_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__006_ sexp__007_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("zero" | "Zero") :: _) as sexp__007_ -> + Sexplib0.Sexp_conv_error.stag_no_args error_source__006_ sexp__007_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__005_ -> + Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__006_ sexp__005_ + | Sexplib0.Sexp.List [] as sexp__005_ -> + Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__006_ sexp__005_ + | sexp__005_ -> + Sexplib0.Sexp_conv_error.unexpected_stag error_source__006_ sexp__005_ + : Sexplib0.Sexp.t -> t) ;; let sexp_of_t = (function - | Infinite -> Ppx_sexp_conv_lib.Sexp.Atom "Infinite" - | Nan -> Ppx_sexp_conv_lib.Sexp.Atom "Nan" - | Normal -> Ppx_sexp_conv_lib.Sexp.Atom "Normal" - | Subnormal -> Ppx_sexp_conv_lib.Sexp.Atom "Subnormal" - | Zero -> Ppx_sexp_conv_lib.Sexp.Atom "Zero" - : t -> Ppx_sexp_conv_lib.Sexp.t) + | Infinite -> Sexplib0.Sexp.Atom "Infinite" + | Nan -> Sexplib0.Sexp.Atom "Nan" + | Normal -> Sexplib0.Sexp.Atom "Normal" + | Subnormal -> Sexplib0.Sexp.Atom "Subnormal" + | Zero -> Sexplib0.Sexp.Atom "Zero" + : t -> Sexplib0.Sexp.t) + ;; + + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = + { untyped = + Variant + { case_sensitivity = Case_sensitive_except_first_character + ; clauses = + [ No_tag { name = "Infinite"; clause_kind = Atom_clause } + ; No_tag { name = "Nan"; clause_kind = Atom_clause } + ; No_tag { name = "Normal"; clause_kind = Atom_clause } + ; No_tag { name = "Subnormal"; clause_kind = Atom_clause } + ; No_tag { name = "Zero"; clause_kind = Atom_clause } + ] + } + } ;; [@@@end] @@ -610,8 +602,6 @@ let classify t = | FP_nan -> C.Nan ;; -let is_finite t = not (t = infinity || t = neg_infinity || is_nan t) - let insert_underscores ?(delimiter = '_') ?(strip_zero = false) string = match String.lsplit2 string ~on:'.' with | None -> Int_conversions.insert_delimiter string ~delimiter @@ -625,14 +615,17 @@ let insert_underscores ?(delimiter = '_') ?(strip_zero = false) string = | _ -> left ^ "." ^ right) ;; -let to_string_hum ?delimiter ?(decimals = 3) ?strip_zero f = +let to_string_hum ?delimiter ?(decimals = 3) ?strip_zero ?(explicit_plus = false) f = if Int_replace_polymorphic_compare.( < ) decimals 0 then invalid_argf "to_string_hum: invalid argument ~decimals=%d" decimals (); match classify f with | Class.Infinite -> if f > 0. then "inf" else "-inf" | Class.Nan -> "nan" | Class.Normal | Class.Subnormal | Class.Zero -> - insert_underscores (sprintf "%.*f" decimals f) ?delimiter ?strip_zero + let s = + if explicit_plus then sprintf "%+.*f" decimals f else sprintf "%.*f" decimals f + in + insert_underscores s ?delimiter ?strip_zero ;; let sexp_of_t t = @@ -882,6 +875,7 @@ let ( - ) = ( -. ) let ( * ) = ( *. ) let ( ** ) = ( ** ) let ( / ) = ( /. ) +let ( % ) = ( %. ) let ( ~- ) = ( ~-. ) let sign_exn t : Sign.t = @@ -950,41 +944,13 @@ module Terse = struct let to_string x = Printf.sprintf "%.8G" x let sexp_of_t x = Sexp.Atom (to_string x) let of_string x = of_string x + let t_sexp_grammar = t_sexp_grammar end -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 - include Comparable.With_zero (struct include T let zero = zero - - include V end) (* These are partly here as a performance hack to avoid some boxing we're getting with @@ -1008,6 +974,7 @@ module O = struct let ( - ) = ( - ) let ( * ) = ( * ) let ( / ) = ( / ) + let ( % ) = ( % ) let ( ~- ) = ( ~- ) let ( ** ) = ( ** ) @@ -1025,6 +992,7 @@ module O_dot = struct let ( +. ) = ( + ) let ( -. ) = ( - ) let ( /. ) = ( / ) + let ( %. ) = ( % ) let ( ~-. ) = ( ~- ) let ( **. ) = ( ** ) end diff --git a/src/float.mli b/src/float.mli index 930abf4..3b0e204 100644 --- a/src/float.mli +++ b/src/float.mli @@ -10,7 +10,7 @@ open! Import type t = float [@@deriving_inline sexp_grammar] -val t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t +val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] @@ -19,15 +19,11 @@ include Floatable.S with type t := t (** [max] and [min] will return nan if either argument is nan. The [validate_*] functions always fail if class is [Nan] or [Infinite]. *) -include - Identifiable.S with type t := t +include Identifiable.S with type t := t include Comparable.With_zero with type t := t include Invariant.S with type t := t -(** [validate_ordinary] fails if class is [Nan] or [Infinite]. *) -val validate_ordinary : t Validate.check - val nan : t val infinity : t val neg_infinity : t @@ -161,11 +157,13 @@ val int63_round_down_exn : t -> Int63.t val int63_round_up_exn : t -> Int63.t val int63_round_nearest_exn : t -> Int63.t -(** If [f <= iround_lbound || f >= iround_ubound], then [iround*] functions will refuse - to round [f], returning [None] or raising as appropriate. *) +(** If [f < iround_lbound || f > iround_ubound], then [iround*] functions will refuse to + round [f], returning [None] or raising as appropriate. *) val iround_lbound : t val iround_ubound : t +val int63_round_lbound : t +val int63_round_ubound : t (** [round_significant x ~significant_digits:n] rounds to the nearest number with [n] significant digits. More precisely: it returns the representable float closest to [x @@ -242,9 +240,15 @@ val round_decimal : float -> decimal_digits:int -> float val is_nan : t -> bool -(** Includes positive and negative [Float.infinity]. *) +(** A float is infinite when it is either [infinity] or [neg_infinity]. *) val is_inf : t -> bool +(** A float is finite when neither [is_nan] nor [is_inf] is true. *) +val is_finite : t -> bool + +(** [is_integer x] is [true] if and only if [x] is an integer. *) +val is_integer : t -> bool + (** [min_inan] and [max_inan] return, respectively, the min and max of the two given values, except when one of the values is a [nan], in which case the other is returned. (Returns [nan] if both arguments are [nan].) *) @@ -254,6 +258,17 @@ val max_inan : t -> t -> t val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( / ) : t -> t -> t + +(** In analogy to Int.( % ), ( % ): + - always produces non-negative (or NaN) result + - raises when given a negative modulus. + + Like the other infix operators, NaNs in mean NaNs out. + + Other cases: (a % Infinity) = a when 0 <= a < Infinity, (a % Infinity) = Infinity when + -Infinity < a < 0, (+/- Infinity % a) = NaN, (a % 0) = NaN. *) +val ( % ) : t -> t -> t + val ( * ) : t -> t -> t val ( ** ) : t -> t -> t val ( ~- ) : t -> t @@ -301,6 +316,7 @@ module O : sig val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t + val ( % ) : t -> t -> t val ( ** ) : t -> t -> t val ( ~- ) : t -> t @@ -320,6 +336,7 @@ module O_dot : sig val ( -. ) : t -> t -> t val ( *. ) : t -> t -> t val ( /. ) : t -> t -> t + val ( %. ) : t -> t -> t val ( **. ) : t -> t -> t val ( ~-. ) : t -> t end @@ -340,6 +357,9 @@ val to_string_hum : ?delimiter:char (** defaults to ['_'] *) -> ?decimals:int (** defaults to [3] *) -> ?strip_zero:bool (** defaults to [false] *) + -> ?explicit_plus:bool + (** Forces a + in front of non-negative values. Defaults + to [false] *) -> t -> string @@ -543,12 +563,13 @@ module Class : sig | Normal | Subnormal | Zero - [@@deriving_inline compare, enumerate, sexp] + [@@deriving_inline compare, enumerate, sexp, sexp_grammar] - val compare : t -> t -> int - val all : t list + include Ppx_compare_lib.Comparable.S with type t := t + include Ppx_enumerate_lib.Enumerable.S with type t := t + include Sexplib0.Sexpable.S with type t := t - include Ppx_sexp_conv_lib.Sexpable.S with type t := t + val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] @@ -557,9 +578,6 @@ end val classify : t -> Class.t -(** [is_finite t] returns [true] iff [classify t] is in [Normal; Subnormal; Zero;]. *) -val is_finite : t -> bool - (*_ Caution: If we remove this sig item, [sign] will still be present from [Comparable.With_zero]. *) @@ -595,9 +613,11 @@ val ieee_mantissa : t -> Int63.t (** S-expressions contain at most 8 significant digits. *) module Terse : sig - type nonrec t = t [@@deriving_inline sexp] + type nonrec t = t [@@deriving_inline sexp, sexp_grammar] + + include Sexplib0.Sexpable.S with type t := t - include Ppx_sexp_conv_lib.Sexpable.S with type t := t + val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] diff --git a/src/float0.ml b/src/float0.ml index 10ce865..37d5b03 100644 --- a/src/float0.ml +++ b/src/float0.ml @@ -17,8 +17,18 @@ let max_finite_value = Caml.max_float let epsilon_float = Caml.epsilon_float let classify_float = Caml.classify_float let abs_float = Caml.abs_float +let is_integer = Caml.Float.is_integer let ( ** ) = Caml.( ** ) +let ( %. ) a b = + (* Raise in case of a negative modulus, as does Int.( % ). *) + if b < 0. + then Printf.invalid_argf "%f %% %f in float0.ml: modulus should be positive" a b (); + let m = Caml.mod_float a b in + (* Produce a non-negative result in analogy with Int.( % ). *) + if m < 0. then m +. b else m +;; + (* The bits of INRIA's [Pervasives] that we just want to expose in [Float]. Most are already deprecated in [Pervasives], and eventually all of them should be. *) include ( @@ -33,8 +43,7 @@ include ( = "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc] - external log10 : float -> float = "caml_log10_float" "log10" - [@@unboxed] [@@noalloc] + external log10 : float -> float = "caml_log10_float" "log10" [@@unboxed] [@@noalloc] external expm1 : float -> float = "caml_expm1_float" "caml_expm1" [@@unboxed] [@@noalloc] @@ -2,14 +2,16 @@ open! Import -(** A "pipe" operator. *) +(** A "pipe" operator. [x |> f] is equivalent to [f x]. + + See {{:https://github.com/janestreet/ppx_pipebang} ppx_pipebang} for + further details. *) external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" (** Produces a function that just returns its first argument. *) val const : 'a -> _ -> 'a -(** [ignore] is the same as [Caml.ignore]. It is useful to have here so that code - that rebinds [ignore] can still refer to [Fn.ignore]. *) +(** Ingores its argument and returns [()]. *) external ignore : _ -> unit = "%ignore" (** Negates a boolean function. *) diff --git a/src/hash.ml b/src/hash.ml index 470527e..ff059c6 100644 --- a/src/hash.ml +++ b/src/hash.ml @@ -182,17 +182,7 @@ module T = struct module Builtin = struct module Folding = Folding (Internalhash) - - include ( - Folding : - Hash_intf.Builtin_hash_fold_intf - with type state := state - and type 'a folder := 'a folder) - - let hash_nativeint = Folding.hash_nativeint - let hash_int64 = Folding.hash_int64 - let hash_int32 = Folding.hash_int32 - let hash_string = Folding.hash_string + include Folding (* [Folding] provides some default implementations for the [hash_*] functions below, but they are inefficient for some use-cases because of the use of the [hash_fold] diff --git a/src/hash_set.ml b/src/hash_set.ml index 84d2d9d..e9e881c 100644 --- a/src/hash_set.ml +++ b/src/hash_set.ml @@ -130,19 +130,15 @@ module Creators (Elt : sig val hashable : 'a t Hashable.t end) : sig - type 'a t_ = 'a Elt.t t - - val t_of_sexp : (Sexp.t -> 'a Elt.t) -> Sexp.t -> 'a t_ + val t_of_sexp : (Sexp.t -> 'a Elt.t) -> Sexp.t -> 'a Elt.t t include Creators_generic - with type 'a t := 'a t_ + with type 'a t := 'a Elt.t t with type 'a elt := 'a Elt.t with type ('elt, 'z) create_options := ('elt, 'z) create_options_without_first_class_module end = struct - type 'a t_ = 'a Elt.t t - let create ?growth_allowed ?size () = create ?growth_allowed ?size (Hashable.to_key Elt.hashable) ;; @@ -169,30 +165,13 @@ module Poly = struct include Accessors let sexp_of_t = sexp_of_t + let t_sexp_grammar grammar = Sexplib0.Sexp_grammar.coerce (List.t_sexp_grammar grammar) end module M (Elt : T.T) = struct type nonrec t = Elt.t t end -module type Sexp_of_m = sig - type t [@@deriving_inline sexp_of] - - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t - - [@@@end] -end - -module type M_of_sexp = sig - type t [@@deriving_inline of_sexp] - - val t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t - - [@@@end] - - include Hashtbl_intf.Key.S with type t := t -end - let sexp_of_m__t (type elt) (module Elt : Sexp_of_m with type t = elt) t = sexp_of_t Elt.sexp_of_t t ;; @@ -201,6 +180,12 @@ let m__t_of_sexp (type elt) (module Elt : M_of_sexp with type t = elt) sexp = t_of_sexp (module Elt) Elt.t_of_sexp sexp ;; +let m__t_sexp_grammar (type elt) (module Elt : M_sexp_grammar with type t = elt) = + Sexplib0.Sexp_grammar.coerce (list_sexp_grammar Elt.t_sexp_grammar) +;; + +let equal_m__t (module _ : Equal_m) t1 t2 = equal t1 t2 + module Private = struct let hashable = Hashtbl.Private.hashable end diff --git a/src/hash_set_intf.ml b/src/hash_set_intf.ml index 1ec9c91..2167dd1 100644 --- a/src/hash_set_intf.ml +++ b/src/hash_set_intf.ml @@ -71,39 +71,74 @@ module type Creators_generic = sig val of_list : ('a, 'a elt list -> 'a t) create_options end -module Check = struct - module Make_creators_check - (Type : T.T1) - (Elt : T.T1) - (Options : T.T2) - (M : Creators_generic - with type 'a t := 'a Type.t - with type 'a elt := 'a Elt.t - with type ('a, 'z) create_options := ('a, 'z) Options.t) = - struct end - - module Check_creators_is_specialization_of_creators_generic (M : Creators) = - Make_creators_check - (struct - type 'a t = 'a M.t - end) - (struct - type 'a t = 'a - end) - (struct - type ('a, 'z) t = ('a, 'z) create_options - end) - (struct - include M - - let create ?growth_allowed ?size m () = create ?growth_allowed ?size m - end) +module type Sexp_of_m = sig + type t [@@deriving_inline sexp_of] + + val sexp_of_t : t -> Sexplib0.Sexp.t + + [@@@end] +end + +module type M_of_sexp = sig + type t [@@deriving_inline of_sexp] + + val t_of_sexp : Sexplib0.Sexp.t -> t + + [@@@end] + + include Hashtbl_intf.Key.S with type t := t +end + +module type M_sexp_grammar = sig + type t [@@deriving_inline sexp_grammar] + + val t_sexp_grammar : t Sexplib0.Sexp_grammar.t + + [@@@end] +end + +module type Equal_m = sig end + +module type For_deriving = sig + type 'a t + + module type M_of_sexp = M_of_sexp + module type Sexp_of_m = Sexp_of_m + module type Equal_m = Equal_m + + (** [M] is meant to be used in combination with OCaml applicative functor types: + + {[ + type string_hash_set = Hash_set.M(String).t + ]} + + which stands for: + + {[ + type string_hash_set = String.t Hash_set.t + ]} + + The point is that [Hash_set.M(String).t] supports deriving, whereas the second + syntax doesn't (because [t_of_sexp] doesn't know what comparison/hash function to + use). *) + module M (Elt : T.T) : sig + type nonrec t = Elt.t t + end + + val sexp_of_m__t : (module Sexp_of_m with type t = 'elt) -> 'elt t -> Sexp.t + val m__t_of_sexp : (module M_of_sexp with type t = 'elt) -> Sexp.t -> 'elt t + + val m__t_sexp_grammar + : (module M_sexp_grammar with type t = 'elt) + -> 'elt t Sexplib0.Sexp_grammar.t + + val equal_m__t : (module Equal_m) -> 'elt t -> 'elt t -> bool end module type Hash_set = sig type 'a t [@@deriving_inline sexp_of] - val sexp_of_t : ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t [@@@end] @@ -116,6 +151,7 @@ module type Hash_set = sig module type Creators = Creators module type Creators_generic = Creators_generic + module type For_deriving = For_deriving type nonrec ('key, 'z) create_options = ('key, 'z) create_options @@ -132,9 +168,11 @@ module type Hash_set = sig (** A hash set that uses polymorphic comparison *) module Poly : sig - type nonrec 'a t = 'a t [@@deriving_inline sexp] + type nonrec 'a t = 'a t [@@deriving_inline sexp, sexp_grammar] - include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t := 'a t + include Sexplib0.Sexpable.S1 with type 'a t := 'a t + + val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] @@ -148,63 +186,23 @@ module type Hash_set = sig include Accessors with type 'a t := 'a t with type 'a elt := 'a elt end - (** [M] is meant to be used in combination with OCaml applicative functor types: - - {[ - type string_hash_set = Hash_set.M(String).t - ]} - - which stands for: - - {[ - type string_hash_set = (String.t, int) Hash_set.t - ]} - - The point is that [Hash_set.M(String).t] supports deriving, whereas the second - syntax doesn't (because [t_of_sexp] doesn't know what comparison/hash function to - use). *) - module M (Elt : T.T) : sig - type nonrec t = Elt.t t - end - - module type Sexp_of_m = sig - type t [@@deriving_inline sexp_of] - - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t - - [@@@end] - end - - module type M_of_sexp = sig - type t [@@deriving_inline of_sexp] - - val t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t - - [@@@end] - - include Hashtbl_intf.Key.S with type t := t - end - - val sexp_of_m__t : (module Sexp_of_m with type t = 'elt) -> 'elt t -> Sexp.t - val m__t_of_sexp : (module M_of_sexp with type t = 'elt) -> Sexp.t -> 'elt t - module Creators (Elt : sig type 'a t val hashable : 'a t Hashable.t end) : sig - type 'a t_ = 'a Elt.t t - - val t_of_sexp : (Sexp.t -> 'a Elt.t) -> Sexp.t -> 'a t_ + val t_of_sexp : (Sexp.t -> 'a Elt.t) -> Sexp.t -> 'a Elt.t t include Creators_generic - with type 'a t := 'a t_ + with type 'a t := 'a Elt.t t with type 'a elt := 'a Elt.t with type ('elt, 'z) create_options := ('elt, 'z) create_options_without_first_class_module end + include For_deriving with type 'a t := 'a t + (**/**) (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: diff --git a/src/hashable_intf.ml b/src/hashable_intf.ml index 7929b67..f921755 100644 --- a/src/hashable_intf.ml +++ b/src/hashable_intf.ml @@ -1,10 +1,12 @@ open! Import +(** @canonical Base.Hashable.Key *) module type Key = sig type t [@@deriving_inline compare, sexp_of] - val compare : t -> t -> int - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + include Ppx_compare_lib.Comparable.S with type t := t + + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] diff --git a/src/hashtbl.ml b/src/hashtbl.ml index e991cf9..2197cd0 100644 --- a/src/hashtbl.ml +++ b/src/hashtbl.ml @@ -25,8 +25,7 @@ let sexp_of_key t = t.hashable.Hashable.sexp_of_t let compare_key t = t.hashable.Hashable.compare let ensure_mutation_allowed t = - if not t.mutation_allowed - then failwith "Hashtbl: mutation not allowed during iteration" + if not t.mutation_allowed then failwith "Hashtbl: mutation not allowed during iteration" ;; let without_mutating t f = @@ -180,14 +179,7 @@ let find_and_call2 t key ~a ~b ~if_found ~if_not_found = | Avltree.Leaf { key = k; value = v } -> if compare_key t k key = 0 then if_found v a b else if_not_found key a b | tree -> - Avltree.find_and_call2 - tree - ~compare:(compare_key t) - key - ~a - ~b - ~if_found - ~if_not_found + Avltree.find_and_call2 tree ~compare:(compare_key t) key ~a ~b ~if_found ~if_not_found ;; let findi_and_call t key ~if_found ~if_not_found = @@ -408,28 +400,35 @@ let partition_mapi t ~f = let partition_map t ~f = partition_mapi t ~f:(fun ~key:_ ~data -> f data) let partitioni_tf t ~f = - partition_mapi t ~f:(fun ~key ~data -> - if f ~key ~data then First data else Second data) + partition_mapi t ~f:(fun ~key ~data -> if f ~key ~data then First data else Second data) ;; let partition_tf t ~f = partitioni_tf t ~f:(fun ~key:_ ~data -> f data) let find_or_add t id ~default = - match find t id with - | Some x -> x - | None -> - let default = default () in - set t ~key:id ~data:default; - default + find_and_call2 + t + id + ~a:t + ~b:default + ~if_found:(fun data _ _ -> data) + ~if_not_found:(fun key t default -> + let default = default () in + set t ~key ~data:default; + default) ;; let findi_or_add t id ~default = - match find t id with - | Some x -> x - | None -> - let default = default id in - set t ~key:id ~data:default; - default + find_and_call2 + t + id + ~a:t + ~b:default + ~if_found:(fun data _ _ -> data) + ~if_not_found:(fun key t default -> + let default = default key in + set t ~key ~data:default; + default) ;; (* Some hashtbl implementations may be able to perform this more efficiently than two @@ -447,7 +446,13 @@ let change t id ~f = | Some data -> set t ~key:id ~data ;; -let update t id ~f = set t ~key:id ~data:(f (find t id)) +let update_and_return t id ~f = + let data = f (find t id) in + set t ~key:id ~data; + data +;; + +let update t id ~f = ignore (update_and_return t id ~f : _) let incr_by ~remove_if_zero t key by = if remove_if_zero @@ -570,7 +575,15 @@ let t_of_sexp ~hashable k_of_sexp d_of_sexp sexp = assert false ;; -let validate ~name f t = Validate.alist ~name f (to_alist t) +let t_sexp_grammar + (type k v) + (k_grammar : k Sexplib0.Sexp_grammar.t) + (v_grammar : v Sexplib0.Sexp_grammar.t) + : (k, v) t Sexplib0.Sexp_grammar.t + = + Sexplib0.Sexp_grammar.coerce (List.Assoc.t_sexp_grammar k_grammar v_grammar) +;; + let keys t = fold t ~init:[] ~f:(fun ~key ~data:_ acc -> key :: acc) let data t = fold ~f:(fun ~key:_ ~data list -> data :: list) ~init:[] t @@ -608,8 +621,7 @@ let create_with_key_or_error ?growth_allowed ?size ~hashable ~get_key rows = ;; let create_with_key_exn ?growth_allowed ?size ~hashable ~get_key rows = - Or_error.ok_exn - (create_with_key_or_error ?growth_allowed ?size ~hashable ~get_key rows) + Or_error.ok_exn (create_with_key_or_error ?growth_allowed ?size ~hashable ~get_key rows) ;; let merge = @@ -665,9 +677,7 @@ let filter_inplace t ~f = filteri_inplace t ~f:(fun ~key:_ ~data -> f data) let filter_keys_inplace t ~f = filteri_inplace t ~f:(fun ~key ~data:_ -> f key) let filter_mapi_inplace t ~f = - let map_results = - fold t ~init:[] ~f:(fun ~key ~data ac -> (key, f ~key ~data) :: ac) - in + let map_results = fold t ~init:[] ~f:(fun ~key ~data ac -> (key, f ~key ~data) :: ac) in List.iter map_results ~f:(fun (key, result) -> match result with | None -> remove t key @@ -708,6 +718,7 @@ module Accessors = struct let add_exn = add_exn let change = change let update = update + let update_and_return = update_and_return let add_multi = add_multi let remove_multi = remove_multi let find_multi = find_multi @@ -747,7 +758,6 @@ module Accessors = struct let findi_and_call2 = findi_and_call2 let find_and_remove = find_and_remove let to_alist = to_alist - let validate = validate let merge = merge let merge_into = merge_into let keys = keys @@ -843,6 +853,7 @@ module Poly = struct include Accessors let sexp_of_t = sexp_of_t + let t_sexp_grammar = t_sexp_grammar end module Private = struct @@ -908,7 +919,7 @@ end module type Sexp_of_m = sig type t [@@deriving_inline sexp_of] - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end @@ -916,13 +927,23 @@ end module type M_of_sexp = sig type t [@@deriving_inline of_sexp] - val t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t + val t_of_sexp : Sexplib0.Sexp.t -> t [@@@end] include Key.S with type t := t end +module type M_sexp_grammar = sig + type t [@@deriving_inline sexp_grammar] + + val t_sexp_grammar : t Sexplib0.Sexp_grammar.t + + [@@@end] +end + +module type Equal_m = sig end + let sexp_of_m__t (type k) (module K : Sexp_of_m with type t = k) sexp_of_v t = sexp_of_t K.sexp_of_t sexp_of_v t ;; @@ -931,33 +952,8 @@ let m__t_of_sexp (type k) (module K : M_of_sexp with type t = k) v_of_sexp sexp t_of_sexp ~hashable:(Hashable.of_key (module K)) K.t_of_sexp v_of_sexp sexp ;; -(* typechecking this code is a compile-time test that [Creators] is a specialization of - [Creators_generic]. *) -module Check : sig end = struct - module Make_creators_check - (Type : T.T2) - (Key : T.T1) - (Options : T.T3) - (M : Creators_generic - with type ('a, 'b) t := ('a, 'b) Type.t - with type 'a key := 'a Key.t - with type ('a, 'b, 'z) create_options := ('a, 'b, 'z) Options.t) = - struct end - - module Check_creators_is_specialization_of_creators_generic (M : Creators) = - Make_creators_check - (struct - type ('a, 'b) t = ('a, 'b) M.t - end) - (struct - type 'a t = 'a - end) - (struct - type ('a, 'b, 'z) t = ('a, 'b, 'z) create_options - end) - (struct - include M - - let create ?growth_allowed ?size m () = create ?growth_allowed ?size m - end) -end +let m__t_sexp_grammar (type k) (module K : M_sexp_grammar with type t = k) v_grammar = + t_sexp_grammar K.t_sexp_grammar v_grammar +;; + +let equal_m__t (module _ : Equal_m) equal_v t1 t2 = equal equal_v t1 t2 diff --git a/src/hashtbl_intf.ml b/src/hashtbl_intf.ml index c4d3f33..e210645 100644 --- a/src/hashtbl_intf.ml +++ b/src/hashtbl_intf.ml @@ -1,11 +1,13 @@ open! Import +(** @canonical Base.Hashtbl.Key *) module Key = struct module type S = sig type t [@@deriving_inline compare, sexp_of] - val compare : t -> t -> int - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + include Ppx_compare_lib.Comparable.S with type t := t + + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] @@ -17,6 +19,7 @@ module Key = struct type 'a t = (module S with type t = 'a) end +(** @canonical Base.Hashtbl.Merge_into_action *) module Merge_into_action = struct type 'a t = | Remove @@ -81,6 +84,9 @@ module type Accessors = sig (** [update t key ~f] is [change t key ~f:(fun o -> Some (f o))]. *) val update : ('a, 'b) t -> 'a key -> f:('b option -> 'b) -> unit + (** [update_and_return t key ~f] is [update], but returns the result of [f o]. *) + val update_and_return : ('a, 'b) t -> 'a key -> f:('b option -> 'b) -> 'b + (** [map t f] returns a new table with values replaced by the result of applying [f] to the current values. @@ -120,10 +126,7 @@ module type Accessors = sig (** Returns new tables with bound values partitioned by [f] applied to the bound values. *) - val partition_map - : ('a, 'b) t - -> f:('b -> ('c, 'd) Either.t) - -> ('a, 'c) t * ('a, 'd) t + val partition_map : ('a, 'b) t -> f:('b -> ('c, 'd) Either.t) -> ('a, 'c) t * ('a, 'd) t (** Like [partition_map], but the function [f] takes both key and data as arguments. *) val partition_mapi @@ -297,11 +300,6 @@ module type Accessors = sig (** Returns the list of all (key, data) pairs for given hashtable. *) val to_alist : ('a, 'b) t -> ('a key * 'b) list - val validate - : name:('a key -> string) - -> 'b Validate.check - -> ('a, 'b) t Validate.check - (** [remove_if_zero]'s default is [false]. *) val incr : ?by:int -> ?remove_if_zero:bool -> ('a, int) t -> 'a key -> unit @@ -597,13 +595,11 @@ module type S_without_submodules = sig include Creators with type ('a, 'b) t := ('a, 'b) t (** @inline *) - include - Accessors with type ('a, 'b) t := ('a, 'b) t with type 'a key = 'a + include Accessors with type ('a, 'b) t := ('a, 'b) t with type 'a key = 'a (** @inline *) - include - Multi with type ('a, 'b) t := ('a, 'b) t with type 'a key := 'a key + include Multi with type ('a, 'b) t := ('a, 'b) t with type 'a key := 'a key (** @inline *) val hashable_s : ('key, _) t -> 'key Key.t @@ -612,9 +608,14 @@ module type S_without_submodules = sig end module type S_poly = sig - type ('a, 'b) t [@@deriving_inline sexp] + type ('a, 'b) t [@@deriving_inline sexp, sexp_grammar] - include Ppx_sexp_conv_lib.Sexpable.S2 with type ('a, 'b) t := ('a, 'b) t + include Sexplib0.Sexpable.S2 with type ('a, 'b) t := ('a, 'b) t + + val t_sexp_grammar + : 'a Sexplib0.Sexp_grammar.t + -> 'b Sexplib0.Sexp_grammar.t + -> ('a, 'b) t Sexplib0.Sexp_grammar.t [@@@end] @@ -639,7 +640,7 @@ module type For_deriving = sig module type Sexp_of_m = sig type t [@@deriving_inline sexp_of] - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end @@ -647,13 +648,23 @@ module type For_deriving = sig module type M_of_sexp = sig type t [@@deriving_inline of_sexp] - val t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t + val t_of_sexp : Sexplib0.Sexp.t -> t [@@@end] include Key.S with type t := t end + module type M_sexp_grammar = sig + type t [@@deriving_inline sexp_grammar] + + val t_sexp_grammar : t Sexplib0.Sexp_grammar.t + + [@@@end] + end + + module type Equal_m = sig end + val sexp_of_m__t : (module Sexp_of_m with type t = 'k) -> ('v -> Sexp.t) @@ -665,6 +676,18 @@ module type For_deriving = sig -> (Sexp.t -> 'v) -> Sexp.t -> ('k, 'v) t + + val m__t_sexp_grammar + : (module M_sexp_grammar with type t = 'k) + -> 'v Sexplib0.Sexp_grammar.t + -> ('k, 'v) t Sexplib0.Sexp_grammar.t + + val equal_m__t + : (module Equal_m) + -> ('v -> 'v -> bool) + -> ('k, 'v) t + -> ('k, 'v) t + -> bool end module type Hashtbl = sig @@ -746,7 +769,6 @@ module type Hashtbl = sig module type Accessors = Accessors module type Creators = Creators - module type Key = Key.S [@@deprecated "[since 2019-03] Use [Hashtbl.Key.S]"] module type Multi = Multi module type S_poly = S_poly module type S_without_submodules = S_without_submodules diff --git a/src/identifiable.ml b/src/identifiable.ml index 0521865..653e4ac 100644 --- a/src/identifiable.ml +++ b/src/identifiable.ml @@ -1,58 +1,18 @@ open! Import +include Identifiable_intf -module type S = sig - type t [@@deriving_inline hash, sexp] - - val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state - val hash : t -> Ppx_hash_lib.Std.Hash.hash_value - - include Ppx_sexp_conv_lib.Sexpable.S with type t := t - - [@@@end] - - include Stringable.S with type t := t - include Comparable.S with type t := t - include Pretty_printer.S with type t := t -end - -module Make (T : sig - type t [@@deriving_inline compare, hash, sexp] - - val compare : t -> t -> int - val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state - val hash : t -> Ppx_hash_lib.Std.Hash.hash_value - - include Ppx_sexp_conv_lib.Sexpable.S with type t := t - - [@@@end] - - include Stringable.S with type t := t - - val module_name : string - end) = -struct +module Make (T : Arg) = struct include T include Comparable.Make (T) include Pretty_printer.Register (T) -end - -module Make_using_comparator (T : sig - type t [@@deriving_inline hash, sexp] - - val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state - val hash : t -> Ppx_hash_lib.Std.Hash.hash_value - include Ppx_sexp_conv_lib.Sexpable.S with type t := t - - [@@@end] - - include Comparator.S with type t := t - include Stringable.S with type t := t + let hashable : t Hashable.t = { hash; compare; sexp_of_t } +end - val module_name : string - end) = -struct +module Make_using_comparator (T : Arg_with_comparator) = struct include T include Comparable.Make_using_comparator (T) include Pretty_printer.Register (T) + + let hashable : t Hashable.t = { hash; compare; sexp_of_t } end diff --git a/src/identifiable.mli b/src/identifiable.mli index f470886..ea3eb49 100644 --- a/src/identifiable.mli +++ b/src/identifiable.mli @@ -1,74 +1 @@ -(** A signature combining functionality that is commonly used for types that are intended - to act as names or identifiers. - - Modules that satisfy [Identifiable] can be printed and parsed (both through string and - s-expression converters) and can be used in hash-based and comparison-based - containers (e.g., hashtables and maps). - - This module also provides functors for conveniently constructing identifiable - modules. *) - -open! Import - -module type S = sig - type t [@@deriving_inline hash, sexp] - - val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state - val hash : t -> Ppx_hash_lib.Std.Hash.hash_value - - include Ppx_sexp_conv_lib.Sexpable.S with type t := t - - [@@@end] - - include Stringable.S with type t := t - include Comparable.S with type t := t - include Pretty_printer.S with type t := t -end - -(** Used for making an Identifiable module. Here's an example. - - {[ - module Id = struct - module T = struct - type t = A | B [@@deriving compare, hash, sexp] - let of_string s = t_of_sexp (sexp_of_string s) - let to_string t = string_of_sexp (sexp_of_t t) - let module_name = "My_library.Id" - end - include T - include Identifiable.Make (T) - end - ]} *) -module Make (M : sig - type t [@@deriving_inline compare, hash, sexp] - - val compare : t -> t -> int - val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state - val hash : t -> Ppx_hash_lib.Std.Hash.hash_value - - include Ppx_sexp_conv_lib.Sexpable.S with type t := t - - [@@@end] - - 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_using_comparator (M : sig - type t [@@deriving_inline compare, hash, sexp] - - val compare : t -> t -> int - val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state - val hash : t -> Ppx_hash_lib.Std.Hash.hash_value - - include Ppx_sexp_conv_lib.Sexpable.S with type t := t - - [@@@end] - - 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 +include Identifiable_intf.Identifiable (** @inline *) diff --git a/src/identifiable_intf.ml b/src/identifiable_intf.ml new file mode 100644 index 0000000..a33e34b --- /dev/null +++ b/src/identifiable_intf.ml @@ -0,0 +1,71 @@ +(** A signature combining functionality that is commonly used for types that are intended + to act as names or identifiers. + + Modules that satisfy [Identifiable] can be printed and parsed (both through string and + s-expression converters) and can be used in hash-based and comparison-based + containers (e.g., hashtables and maps). + + This module also provides functors for conveniently constructing identifiable + modules. *) + +open! Import + +module type Arg = sig + type t [@@deriving_inline compare, hash, sexp] + + include Ppx_compare_lib.Comparable.S with type t := t + include Ppx_hash_lib.Hashable.S with type t := t + include Sexplib0.Sexpable.S with type t := t + + [@@@end] + + include Stringable.S with type t := t + + (** For registering the pretty printer. *) + val module_name : string +end + +module type Arg_with_comparator = sig + include Arg + include Comparator.S with type t := t +end + +module type S = sig + type t [@@deriving_inline hash, sexp] + + include Ppx_hash_lib.Hashable.S with type t := t + include Sexplib0.Sexpable.S with type t := t + + [@@@end] + + include Stringable.S with type t := t + include Comparable.S with type t := t + include Pretty_printer.S with type t := t + + val hashable : t Hashable.t +end + +module type Identifiable = sig + module type Arg = Arg + module type Arg_with_comparator = Arg_with_comparator + module type S = S + + (** Used for making an Identifiable module. Here's an example. + + {[ + module Id = struct + module T = struct + type t = A | B [@@deriving compare, hash, sexp] + let of_string s = t_of_sexp (sexp_of_string s) + let to_string t = string_of_sexp (sexp_of_t t) + let module_name = "My_library.Id" + end + include T + include Identifiable.Make (T) + end + ]} *) + module Make (M : Arg) : S with type t := M.t + + module Make_using_comparator (M : Arg_with_comparator) : + S with type t := M.t with type comparator_witness := M.comparator_witness +end diff --git a/src/import.ml b/src/import.ml index 0adf605..6567db5 100644 --- a/src/import.ml +++ b/src/import.ml @@ -1,6 +1,5 @@ include Import0 include Sexplib0.Sexp_conv -include Sexp.Private.Raw_grammar.Builtin include Hash.Builtin include Ppx_compare_lib.Builtin diff --git a/src/import0.ml b/src/import0.ml index 08a232a..f680d21 100644 --- a/src/import0.ml +++ b/src/import0.ml @@ -152,16 +152,19 @@ let ( /. ) = Caml.( /. ) module Poly = Poly0 (** @canonical Base.Poly *) module Int_replace_polymorphic_compare = struct - let ( < ) (x : int) y = Poly.( < ) x y - let ( <= ) (x : int) y = Poly.( <= ) x y - let ( <> ) (x : int) y = Poly.( <> ) x y - let ( = ) (x : int) y = Poly.( = ) x y - let ( > ) (x : int) y = Poly.( > ) x y - let ( >= ) (x : int) y = Poly.( >= ) x y - let compare (x : int) y = bool_to_int (x > y) - bool_to_int (x < y) + (* Declared as externals so that the compiler skips the caml_apply_X wrapping even when + compiling without cross library inlining. *) + external ( = ) : int -> int -> bool = "%equal" + external ( <> ) : int -> int -> bool = "%notequal" + external ( < ) : int -> int -> bool = "%lessthan" + external ( > ) : int -> int -> bool = "%greaterthan" + external ( <= ) : int -> int -> bool = "%lessequal" + external ( >= ) : int -> int -> bool = "%greaterequal" + external compare : int -> int -> int = "%compare" + external equal : int -> int -> bool = "%equal" + let ascending (x : int) y = compare x y let descending (x : int) y = compare y x - let equal (x : int) y = Poly.equal x y let max (x : int) y = if x >= y then x else y let min (x : int) y = if x <= y then x else y end @@ -184,16 +187,19 @@ module Int32_replace_polymorphic_compare = struct end module Int64_replace_polymorphic_compare = struct - let ( < ) (x : Caml.Int64.t) y = Poly.( < ) x y - let ( <= ) (x : Caml.Int64.t) y = Poly.( <= ) x y - let ( <> ) (x : Caml.Int64.t) y = Poly.( <> ) x y - let ( = ) (x : Caml.Int64.t) y = Poly.( = ) x y - let ( > ) (x : Caml.Int64.t) y = Poly.( > ) x y - let ( >= ) (x : Caml.Int64.t) y = Poly.( >= ) x y + (* Declared as externals so that the compiler skips the caml_apply_X wrapping even when + compiling without cross library inlining. *) + external ( = ) : Caml.Int64.t -> Caml.Int64.t -> bool = "%equal" + external ( <> ) : Caml.Int64.t -> Caml.Int64.t -> bool = "%notequal" + external ( < ) : Caml.Int64.t -> Caml.Int64.t -> bool = "%lessthan" + external ( > ) : Caml.Int64.t -> Caml.Int64.t -> bool = "%greaterthan" + external ( <= ) : Caml.Int64.t -> Caml.Int64.t -> bool = "%lessequal" + external ( >= ) : Caml.Int64.t -> Caml.Int64.t -> bool = "%greaterequal" + external compare : Caml.Int64.t -> Caml.Int64.t -> int = "%compare" + external equal : Caml.Int64.t -> Caml.Int64.t -> bool = "%equal" + let ascending (x : Caml.Int64.t) y = Poly.ascending x y let descending (x : Caml.Int64.t) y = Poly.descending x y - let compare (x : Caml.Int64.t) y = Poly.compare x y - let equal (x : Caml.Int64.t) y = Poly.equal x y let max (x : Caml.Int64.t) y = if x >= y then x else y let min (x : Caml.Int64.t) y = if x <= y then x else y end diff --git a/src/index.mld b/src/index.mld index 386f8d3..367212f 100644 --- a/src/index.mld +++ b/src/index.mld @@ -15,21 +15,14 @@ left to other libraries. Note that an API for OCaml's channel-based I/O can be found in the {{!module:Stdio}[Stdio]} library. -{1 Relationship to Core_kernel and Core} - -Base is the smallest, most self-contained version of Jane Street's -family of three standard library replacements. It is extended by -[Core_kernel], which is in turn extended by [Core]. - -In sum: +{1 Relationship to Core} - {b {!Base}}: Minimal stdlib replacement. Portable and lightweight and intended to be highly stable. -- {b {!Core_kernel}}: Extension of Base. More fully featured, with more + +- {b {!Core}}: Extension of Base. More fully featured, with more code and dependencies, and APIs that evolve more quickly. Portable, and works on Javascript. -- {b {!Core}}: Core_kernel extended with UNIX APIs. - {1 Using the OCaml standard library with Base} @@ -162,8 +155,8 @@ The Base specific coding rules are checked by [ppx_base_lint], in the [lint] subfolder. The indentation rules are checked by a wrapper around [ocp-indent] and the coding style rules are checked by [ppx_js_style]. -These checks are currently not run by [jbuilder], but it will soon get -a [-dev] flag to run them automatically. +These checks are currently not run by [dune], but it will soon get a [-dev] flag +to run them automatically. {1 Roadmap} diff --git a/src/indexed_container.ml b/src/indexed_container.ml index 5cef378..f6a50e8 100644 --- a/src/indexed_container.ml +++ b/src/indexed_container.ml @@ -47,8 +47,13 @@ let findi ~iteri c ~f = None) ;; -module Make (T : Make_arg) : S1 with type 'a t := 'a T.t = struct - include Container.Make (T) +module Make_gen (T : sig + include Container_intf.Make_gen_arg + + val iteri : [ `Define_using_fold | `Custom of ('a t, 'a elt) iteri ] + val foldi : [ `Define_using_fold | `Custom of ('a t, 'a elt, _) foldi ] + end) : Generic with type 'a t := 'a T.t with type 'a elt := 'a T.elt = struct + include Container.Make_gen (T) let iteri = match T.iteri with @@ -68,3 +73,31 @@ module Make (T : Make_arg) : S1 with type 'a t := 'a T.t = struct let find_mapi t ~f = find_mapi ~iteri t ~f let findi t ~f = findi ~iteri t ~f end + +module Make (T : Make_arg) = struct + module C = Container.Make (T) + + (* Not part of [Container.Generic]. *) + let mem = C.mem + + include Make_gen (struct + include T + + type 'a t = 'a T.t + type 'a elt = 'a + end) +end + +module Make0 (T : Make0_arg) = struct + module C = Container.Make0 (T) + + (* Not part of [Container.Generic]. *) + let mem = C.mem + + include Make_gen (struct + include T + + type 'a t = T.t + type 'a elt = T.Elt.t + end) +end diff --git a/src/indexed_container_intf.ml b/src/indexed_container_intf.ml index 2650467..c0ba228 100644 --- a/src/indexed_container_intf.ml +++ b/src/indexed_container_intf.ml @@ -6,6 +6,21 @@ type ('t, 'a, 'accum) foldi = type ('t, 'a) iteri = 't -> f:(int -> 'a -> unit) -> unit +module type S0 = sig + include Container.S0 + + (** These are all like their equivalents in [Container] except that an index starting at + 0 is added as the first argument to [f]. *) + + val foldi : (t, elt, _) foldi + val iteri : (t, elt) iteri + val existsi : t -> f:(int -> elt -> bool) -> bool + val for_alli : t -> f:(int -> elt -> bool) -> bool + val counti : t -> f:(int -> elt -> bool) -> int + val findi : t -> f:(int -> elt -> bool) -> (int * elt) option + val find_mapi : t -> f:(int -> elt -> 'a option) -> 'a option +end + module type S1 = sig include Container.S1 @@ -21,11 +36,33 @@ module type S1 = sig val find_mapi : 'a t -> f:(int -> 'a -> 'b option) -> 'b option end -module type Make_arg = sig - include Container_intf.Make_arg +module type Generic = sig + include Container.Generic + + (** These are all like their equivalents in [Container] except that an index starting at + 0 is added as the first argument to [f]. *) + + val foldi : ('a t, 'a elt, _) foldi + val iteri : ('a t, 'a elt) iteri + val existsi : 'a t -> f:(int -> 'a elt -> bool) -> bool + val for_alli : 'a t -> f:(int -> 'a elt -> bool) -> bool + val counti : 'a t -> f:(int -> 'a elt -> bool) -> int + val findi : 'a t -> f:(int -> 'a elt -> bool) -> (int * 'a elt) option + val find_mapi : 'a t -> f:(int -> 'a elt -> 'b option) -> 'b option +end + +module type Make_gen_arg = sig + include Container_intf.Make_gen_arg - val iteri : [ `Define_using_fold | `Custom of ('a t, 'a) iteri ] - val foldi : [ `Define_using_fold | `Custom of ('a t, 'a, _) foldi ] + val iteri : [ `Define_using_fold | `Custom of ('a t, 'a elt) iteri ] + val foldi : [ `Define_using_fold | `Custom of ('a t, 'a elt, _) foldi ] +end + +module type Make_arg = Make_gen_arg with type 'a elt := 'a Monad.Ident.t + +module type Make0_arg = sig + include Container_intf.Make0_arg + include Make_gen_arg with type 'a t := t and type 'a elt := Elt.t end module type Indexed_container = sig @@ -34,6 +71,8 @@ module type Indexed_container = sig but the idea is that [Indexed_container_intf] should be included only for containers that have a meaningful underlying ordering. *) + module type Generic = Generic + module type S0 = S0 module type S1 = S1 (** Generic definitions of [foldi] and [iteri] in terms of [fold]. @@ -55,4 +94,8 @@ module type Indexed_container = sig val find_mapi : iteri:('t, 'a) iteri -> 't -> f:(int -> 'a -> 'b option) -> 'b option module Make (T : Make_arg) : S1 with type 'a t := 'a T.t + module Make0 (T : Make0_arg) : S0 with type t := T.t and type elt := T.Elt.t + + module Make_gen (T : Make_gen_arg) : + Generic with type 'a t := 'a T.t and type 'a elt := 'a T.elt end diff --git a/src/info.ml b/src/info.ml index 79a9b1d..9462537 100644 --- a/src/info.ml +++ b/src/info.ml @@ -21,43 +21,43 @@ module Message = struct let rec sexp_of_t = (function - | Could_not_construct v0 -> - let v0 = Sexp.sexp_of_t v0 in - Ppx_sexp_conv_lib.Sexp.List - [ Ppx_sexp_conv_lib.Sexp.Atom "Could_not_construct"; v0 ] - | String v0 -> - let v0 = sexp_of_string v0 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "String"; v0 ] - | Exn v0 -> - let v0 = sexp_of_exn v0 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Exn"; v0 ] - | Sexp v0 -> - let v0 = Sexp.sexp_of_t v0 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Sexp"; v0 ] - | Tag_sexp (v0, v1, v2) -> - let v0 = sexp_of_string v0 - and v1 = Sexp.sexp_of_t v1 - and v2 = sexp_of_option Source_code_position0.sexp_of_t v2 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Tag_sexp"; v0; v1; v2 ] - | Tag_t (v0, v1) -> - let v0 = sexp_of_string v0 - and v1 = sexp_of_t v1 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Tag_t"; v0; v1 ] - | Tag_arg (v0, v1, v2) -> - let v0 = sexp_of_string v0 - and v1 = Sexp.sexp_of_t v1 - and v2 = sexp_of_t v2 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Tag_arg"; v0; v1; v2 ] - | Of_list (v0, v1) -> - let v0 = sexp_of_option sexp_of_int v0 - and v1 = sexp_of_list sexp_of_t v1 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Of_list"; v0; v1 ] - | With_backtrace (v0, v1) -> - let v0 = sexp_of_t v0 - and v1 = sexp_of_string v1 in - Ppx_sexp_conv_lib.Sexp.List - [ Ppx_sexp_conv_lib.Sexp.Atom "With_backtrace"; v0; v1 ] - : t -> Ppx_sexp_conv_lib.Sexp.t) + | Could_not_construct arg0__001_ -> + let res0__002_ = Sexp.sexp_of_t arg0__001_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Could_not_construct"; res0__002_ ] + | String arg0__003_ -> + let res0__004_ = sexp_of_string arg0__003_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "String"; res0__004_ ] + | Exn arg0__005_ -> + let res0__006_ = sexp_of_exn arg0__005_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Exn"; res0__006_ ] + | Sexp arg0__007_ -> + let res0__008_ = Sexp.sexp_of_t arg0__007_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Sexp"; res0__008_ ] + | Tag_sexp (arg0__009_, arg1__010_, arg2__011_) -> + let res0__012_ = sexp_of_string arg0__009_ + and res1__013_ = Sexp.sexp_of_t arg1__010_ + and res2__014_ = sexp_of_option Source_code_position0.sexp_of_t arg2__011_ in + Sexplib0.Sexp.List + [ Sexplib0.Sexp.Atom "Tag_sexp"; res0__012_; res1__013_; res2__014_ ] + | Tag_t (arg0__015_, arg1__016_) -> + let res0__017_ = sexp_of_string arg0__015_ + and res1__018_ = sexp_of_t arg1__016_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Tag_t"; res0__017_; res1__018_ ] + | Tag_arg (arg0__019_, arg1__020_, arg2__021_) -> + let res0__022_ = sexp_of_string arg0__019_ + and res1__023_ = Sexp.sexp_of_t arg1__020_ + and res2__024_ = sexp_of_t arg2__021_ in + Sexplib0.Sexp.List + [ Sexplib0.Sexp.Atom "Tag_arg"; res0__022_; res1__023_; res2__024_ ] + | Of_list (arg0__025_, arg1__026_) -> + let res0__027_ = sexp_of_option sexp_of_int arg0__025_ + and res1__028_ = sexp_of_list sexp_of_t arg1__026_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Of_list"; res0__027_; res1__028_ ] + | With_backtrace (arg0__029_, arg1__030_) -> + let res0__031_ = sexp_of_t arg0__029_ + and res1__032_ = sexp_of_string arg1__030_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "With_backtrace"; res0__031_; res1__032_ ] + : t -> Sexplib0.Sexp.t) ;; [@@@end] @@ -149,6 +149,7 @@ let of_message = Message.to_info can handle any sexp. *) let sexp_of_t t = Message.to_sexp_hum (to_message t) let t_of_sexp sexp = lazy (Message.Sexp sexp) +let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Any "Info.t" } let compare t1 t2 = Sexp.compare (sexp_of_t t1) (sexp_of_t t2) let equal t1 t2 = Sexp.equal (sexp_of_t t1) (sexp_of_t t2) let hash_fold_t state t = Sexp.hash_fold_t state (sexp_of_t t) @@ -163,6 +164,7 @@ let to_string_hum t = let to_string_hum_deprecated t = Message.to_string_hum_deprecated (to_message t) let to_string_mach t = Sexp.to_string_mach (sexp_of_t t) let of_lazy l = lazy (protect (fun () -> String (Lazy.force l))) +let of_lazy_sexp l = lazy (protect (fun () -> Sexp (Lazy.force l))) let of_lazy_t lazy_t = Lazy.join lazy_t let of_string message = Lazy.from_val (String message) let createf format = Printf.ksprintf of_string format @@ -176,7 +178,12 @@ let create ?here ?strict tag x sexp_of_x = let create_s sexp = Lazy.from_val (Sexp sexp) let tag t ~tag = lazy (Tag_t (tag, to_message t)) -let tag_s t ~tag = lazy (protect (fun () -> Tag_arg ("", tag, to_message t))) + +let tag_s_lazy t ~tag = + lazy (protect (fun () -> Tag_arg ("", Lazy.force tag, to_message t))) +;; + +let tag_s t ~tag = tag_s_lazy t ~tag:(Lazy.from_val tag) let tag_arg t tag x sexp_of_x = lazy (protect (fun () -> Tag_arg (tag, sexp_of_x x, to_message t))) @@ -190,7 +197,7 @@ let () = (* We install a custom exn-converter rather than use [exception Exn of t [@@deriving_inline sexp] ... [@@@end]] to eliminate the extra wrapping of "(Exn ...)". *) - Sexplib.Conv.Exn_converter.add [%extension_constructor Exn] (function + Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Exn] (function | Exn t -> sexp_of_t t | _ -> (* Reaching this branch indicates a bug in sexplib. *) diff --git a/src/info_intf.ml b/src/info_intf.ml index 1920a0f..2bd8109 100644 --- a/src/info_intf.ml +++ b/src/info_intf.ml @@ -35,14 +35,14 @@ open! Import module type S = sig (** Serialization and comparison force the lazy message. *) - type t [@@deriving_inline compare, equal, hash, sexp] + type t [@@deriving_inline compare, equal, hash, sexp, sexp_grammar] - val compare : t -> t -> int - val equal : t -> t -> bool - val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state - val hash : t -> Ppx_hash_lib.Std.Hash.hash_value + include Ppx_compare_lib.Comparable.S with type t := t + include Ppx_compare_lib.Equal.S with type t := t + include Ppx_hash_lib.Hashable.S with type t := t + include Sexplib0.Sexpable.S with type t := t - include Ppx_sexp_conv_lib.Sexpable.S with type t := t + val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] @@ -73,6 +73,7 @@ module type S = sig will only be called at an undetermined later point. *) val of_lazy : string Lazy.t -> t + val of_lazy_sexp : Sexp.t Lazy.t -> t val of_thunk : (unit -> string) -> t val of_lazy_t : t Lazy.t -> t @@ -100,6 +101,9 @@ module type S = sig (** Adds a sexp to the front. *) val tag_s : t -> tag:Sexp.t -> t + (** Adds a lazy sexp to the front. *) + val tag_s_lazy : t -> tag:Sexp.t Lazy.t -> t + (** Adds a string and some other data in the form of an s-expression at the front. *) val tag_arg : t -> string -> 'a -> ('a -> Sexp.t) -> t @@ -134,7 +138,7 @@ module type S = sig | With_backtrace of t * string (** The second argument is the backtrace *) [@@deriving_inline sexp_of] - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] @@ -147,5 +151,5 @@ end module type Info = sig module type S = S - include S + include S (** @inline *) end @@ -13,31 +13,13 @@ module T = struct fun x -> func x ;; - let t_of_sexp = (int_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t) - let sexp_of_t = (sexp_of_int : t -> Ppx_sexp_conv_lib.Sexp.t) - - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "int" ] - ; ggid = "\146e\023\249\235eE\139c\132W\195\137\129\235\025" - ; types = [ "t", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ int_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "int.ml.T" - } - in - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("t", _the_group) - in - t_sexp_grammar - ;; + let t_of_sexp = (int_of_sexp : Sexplib0.Sexp.t -> t) + let sexp_of_t = (sexp_of_int : t -> Sexplib0.Sexp.t) + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = int_sexp_grammar [@@@end] + let hashable : t Hashable.t = { hash; compare; sexp_of_t } let compare x y = Int_replace_polymorphic_compare.compare x y let of_string s = @@ -72,7 +54,7 @@ let minus_one = -1 include T include Comparator.Make (T) -include Comparable.Validate_with_zero (struct +include Comparable.With_zero (struct include T let zero = zero @@ -137,6 +119,11 @@ let clamp t ~min ~max = else Ok (clamp_unchecked t ~min ~max) ;; +external to_int32_trunc : t -> int32 = "%int32_of_int" +external of_int32_trunc : int32 -> t = "%int32_to_int" +external of_int64_trunc : int64 -> t = "%int64_to_int" +external of_nativeint_trunc : nativeint -> t = "%nativeint_to_int" + let pred i = i - 1 let succ i = i + 1 let to_int i = i @@ -148,26 +135,16 @@ let min_value = Caml.min_int let max_value_30_bits = 0x3FFF_FFFF let of_int32 = Conv.int32_to_int let of_int32_exn = Conv.int32_to_int_exn -let of_int32_trunc = Conv.int32_to_int_trunc let to_int32 = Conv.int_to_int32 let to_int32_exn = Conv.int_to_int32_exn -let to_int32_trunc = Conv.int_to_int32_trunc let of_int64 = Conv.int64_to_int let of_int64_exn = Conv.int64_to_int_exn -let of_int64_trunc = Conv.int64_to_int_trunc let to_int64 = Conv.int_to_int64 let of_nativeint = Conv.nativeint_to_int let of_nativeint_exn = Conv.nativeint_to_int_exn -let of_nativeint_trunc = Conv.nativeint_to_int_trunc let to_nativeint = Conv.int_to_nativeint let to_nativeint_exn = to_nativeint let abs x = abs x -let ( + ) x y = x + y -let ( - ) x y = x - y -let ( * ) x y = x * y -let ( / ) x y = x / y -let neg x = -x -let ( ~- ) = neg (* note that rem is not same as % *) let rem a b = a mod b @@ -185,7 +162,6 @@ let ( ** ) b e = pow b e module Pow2 = struct open! Import - module Sys = Sys0 let raise_s = Error.raise_s @@ -246,8 +222,7 @@ module Pow2 = struct (** Hacker's Delight Second Edition p106 *) let floor_log2 i = if i <= 0 - then - raise_s (Sexp.message "[Int.floor_log2] got invalid input" [ "", sexp_of_int i ]); + then raise_s (Sexp.message "[Int.floor_log2] got invalid input" [ "", sexp_of_int i ]); num_bits - 1 - clz i ;; @@ -260,23 +235,24 @@ end include Pow2 -(* This is already defined by Comparable.Validate_with_zero, but Sign.of_int is - more direct. *) let sign = Sign.of_int let popcount = Popcount.int_popcount module Pre_O = struct - let ( + ) = ( + ) - let ( - ) = ( - ) - let ( * ) = ( * ) - let ( / ) = ( / ) - let ( ~- ) = ( ~- ) + external ( + ) : int -> int -> int = "%addint" + external ( - ) : int -> int -> int = "%subint" + external ( * ) : int -> int -> int = "%mulint" + external ( / ) : int -> int -> int = "%divint" + external ( ~- ) : int -> int = "%negint" + let ( ** ) = ( ** ) - include (Int_replace_polymorphic_compare : Comparisons.Infix with type t := t) + include Int_replace_polymorphic_compare let abs = abs - let neg = neg + + external neg : t -> t = "%negint" + let zero = zero let of_int_exn = of_int_exn end @@ -334,13 +310,16 @@ module O = struct ;; let ( // ) x y = to_float x /. to_float y - let ( land ) = ( land ) - let ( lor ) = ( lor ) - let ( lxor ) = ( lxor ) + + external ( land ) : int -> int -> int = "%andint" + external ( lor ) : int -> int -> int = "%orint" + external ( lxor ) : int -> int -> int = "%xorint" + let lnot = lnot - let ( lsl ) = ( lsl ) - let ( asr ) = ( asr ) - let ( lsr ) = ( lsr ) + + external ( lsl ) : int -> int -> int = "%lslint" + external ( lsr ) : int -> int -> int = "%lsrint" + external ( asr ) : int -> int -> int = "%asrint" end include O diff --git a/src/int32.ml b/src/int32.ml index 414b843..ada750b 100644 --- a/src/int32.ml +++ b/src/int32.ml @@ -12,31 +12,13 @@ module T = struct fun x -> func x ;; - let t_of_sexp = (int32_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t) - let sexp_of_t = (sexp_of_int32 : t -> Ppx_sexp_conv_lib.Sexp.t) - - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "int32" ] - ; ggid = "\146e\023\249\235eE\139c\132W\195\137\129\235\025" - ; types = [ "t", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ int32_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "int32.ml.T" - } - in - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("t", _the_group) - in - t_sexp_grammar - ;; + let t_of_sexp = (int32_of_sexp : Sexplib0.Sexp.t -> t) + let sexp_of_t = (sexp_of_int32 : t -> Sexplib0.Sexp.t) + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = int32_sexp_grammar [@@@end] + let hashable : t Hashable.t = { hash; compare; sexp_of_t } let compare (x : t) y = compare x y let to_string = to_string let of_string = of_string @@ -82,7 +64,7 @@ let of_float f = () ;; -include Comparable.Validate_with_zero (struct +include Comparable.With_zero (struct include T let zero = zero @@ -170,7 +152,6 @@ let bswap16 x = Caml.Int32.shift_right_logical (bswap32 x) 16 module Pow2 = struct open! Import open Int32_replace_polymorphic_compare - module Sys = Sys0 let raise_s = Error.raise_s @@ -236,8 +217,7 @@ module Pow2 = struct let ceil_log2 i = if i <= Caml.Int32.zero then - raise_s - (Sexp.message "[Int32.ceil_log2] got invalid input" [ "", sexp_of_int32 i ]); + raise_s (Sexp.message "[Int32.ceil_log2] got invalid input" [ "", sexp_of_int32 i ]); (* The [i = 1] check is needed because clz(0) is undefined *) if Caml.Int32.equal i Caml.Int32.one then 0 else num_bits - clz (Caml.Int32.pred i) ;; diff --git a/src/int63.ml b/src/int63.ml index b8347a1..2677564 100644 --- a/src/int63.ml +++ b/src/int63.ml @@ -124,6 +124,30 @@ module Overflow_exn = struct else diff ;; + let negative_one = of_int (-1) + let div_would_overflow t u = t = min_value && u = negative_one + + let ( * ) t u = + let product = t * u in + if u <> zero && (div_would_overflow product u || product / u <> t) + then + raise_s + (Sexp.message + "( * ) overflow" + [ "t", sexp_of_t t; "u", sexp_of_t u; "product", sexp_of_t product ]) + else product + ;; + + let ( / ) t u = + if div_would_overflow t u + then + raise_s + (Sexp.message + "( / ) overflow" + [ "t", sexp_of_t t; "u", sexp_of_t u; "product", sexp_of_t (t / u) ]) + else t / u + ;; + let abs t = if t = min_value then failwith "abs overflow" else abs t let neg t = if t = min_value then failwith "neg overflow" else neg t end diff --git a/src/int63.mli b/src/int63.mli index 48116cb..c830cc6 100644 --- a/src/int63.mli +++ b/src/int63.mli @@ -26,6 +26,8 @@ include Int_intf.S with type t := t module Overflow_exn : sig val ( + ) : t -> t -> t val ( - ) : t -> t -> t + val ( * ) : t -> t -> t + val ( / ) : t -> t -> t val abs : t -> t val neg : t -> t end diff --git a/src/int63_emul.ml b/src/int63_emul.ml index 209061f..c338ca5 100644 --- a/src/int63_emul.ml +++ b/src/int63_emul.ml @@ -21,31 +21,13 @@ module T0 = struct fun x -> func x ;; - let t_of_sexp = (int64_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t) - let sexp_of_t = (sexp_of_int64 : t -> Ppx_sexp_conv_lib.Sexp.t) - - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) - = - { implicit_vars = [ "int64" ] - ; ggid = "\146e\023\249\235eE\139c\132W\195\137\129\235\025" - ; types = [ "t", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ int64_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "int63_emul.ml.T0.T" - } - in - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("t", _the_group) - in - t_sexp_grammar - ;; + let t_of_sexp = (int64_of_sexp : Sexplib0.Sexp.t -> t) + let sexp_of_t = (sexp_of_int64 : t -> Sexplib0.Sexp.t) + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = int64_sexp_grammar [@@@end] + + let hashable : t Hashable.t = { hash; compare; sexp_of_t } end include T @@ -56,12 +38,11 @@ module Conv = Int_conversions module W : sig - type t = int64 - include module type of struct include T0 end - with type t := t + + type t = int64 val wrap_exn : Caml.Int64.t -> t val wrap_modulo : Caml.Int64.t -> t @@ -104,14 +85,9 @@ module W : sig val clz : t -> int val ctz : t -> int end = struct - type t = int64 + include T0 - include ( - T0 : - module type of struct - include T0 - end - with type t := t) + type t = int64 let wrap_exn x = (* Raises if the int64 value does not fit on int63. *) @@ -192,28 +168,9 @@ module T = struct fun x -> func x ;; - let t_of_sexp = (W.t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t) - let sexp_of_t = (W.sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t) - - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "W.t" ] - ; ggid = "\146e\023\249\235eE\139c\132W\195\137\129\235\025" - ; types = [ "t", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ W.t_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "int63_emul.ml.T" - } - in - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("t", _the_group) - in - t_sexp_grammar - ;; + let t_of_sexp = (W.t_of_sexp : Sexplib0.Sexp.t -> t) + let sexp_of_t = (W.sexp_of_t : t -> Sexplib0.Sexp.t) + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = W.t_sexp_grammar [@@@end] @@ -226,6 +183,7 @@ module T = struct (* We don't expect [hash] to follow the behavior of int in 64bit architecture *) let _ = hash let hash (x : t) = Caml.Hashtbl.hash x + let hashable : t Hashable.t = { hash; compare; sexp_of_t } let invalid_str x = Printf.failwithf "Int63.of_string: invalid input %S" x () (* @@ -346,7 +304,7 @@ let of_int64_exn = of_int64_exn let of_int64_trunc = of_int64_trunc let to_int64 = to_int64 -include Comparable.Validate_with_zero (struct +include Comparable.With_zero (struct include T let zero = zero diff --git a/src/int63_emul.mli b/src/int63_emul.mli index a1c0bbe..8dbe5ad 100644 --- a/src/int63_emul.mli +++ b/src/int63_emul.mli @@ -20,7 +20,7 @@ val bswap16 : t -> t val bswap32 : t -> t val bswap48 : t -> t -(*_ exported for Core_kernel *) +(*_ exported for Core *) module W : sig val wrap_exn : int64 -> t val unwrap : t -> int64 diff --git a/src/int64.ml b/src/int64.ml index 6d2b106..4006e02 100644 --- a/src/int64.ml +++ b/src/int64.ml @@ -12,31 +12,14 @@ module T = struct fun x -> func x ;; - let t_of_sexp = (int64_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t) - let sexp_of_t = (sexp_of_int64 : t -> Ppx_sexp_conv_lib.Sexp.t) - - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "int64" ] - ; ggid = "\146e\023\249\235eE\139c\132W\195\137\129\235\025" - ; types = [ "t", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ int64_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "int64.ml.T" - } - in - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("t", _the_group) - in - t_sexp_grammar - ;; + let t_of_sexp = (int64_of_sexp : Sexplib0.Sexp.t -> t) + let sexp_of_t = (sexp_of_int64 : t -> Sexplib0.Sexp.t) + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = int64_sexp_grammar [@@@end] + let hashable : t Hashable.t = { hash; compare; sexp_of_t } + let compare = Int64_replace_polymorphic_compare.compare let to_string = to_string let of_string = of_string @@ -98,7 +81,7 @@ let[@inline always] bswap32 x = let[@inline always] bswap48 x = Caml.Int64.shift_right_logical (bswap64 x) 16 -include Comparable.Validate_with_zero (struct +include Comparable.With_zero (struct include T let zero = zero @@ -128,40 +111,37 @@ let clamp t ~min ~max = else Ok (clamp_unchecked t ~min ~max) ;; -let ( / ) = div -let ( * ) = mul -let ( - ) = sub -let ( + ) = add -let ( ~- ) = neg -let incr r = r := !r + one -let decr r = r := !r - one -let of_int64 t = t +let incr r = r := add !r one +let decr r = r := sub !r one + +external of_int64 : t -> t = "%identity" + let of_int64_exn = of_int64 let to_int64 t = t let popcount = Popcount.int64_popcount module Conv = Int_conversions -let of_int = Conv.int_to_int64 +external to_int_trunc : t -> int = "%int64_to_int" +external to_int32_trunc : int64 -> int32 = "%int64_to_int32" +external to_nativeint_trunc : int64 -> nativeint = "%int64_to_nativeint" +external of_int : int -> int64 = "%int64_of_int" +external of_int32 : int32 -> int64 = "%int64_of_int32" + let of_int_exn = of_int let to_int = Conv.int64_to_int let to_int_exn = Conv.int64_to_int_exn -let to_int_trunc = Conv.int64_to_int_trunc -let of_int32 = Conv.int32_to_int64 let of_int32_exn = of_int32 let to_int32 = Conv.int64_to_int32 let to_int32_exn = Conv.int64_to_int32_exn -let to_int32_trunc = Conv.int64_to_int32_trunc let of_nativeint = Conv.nativeint_to_int64 let of_nativeint_exn = of_nativeint let to_nativeint = Conv.int64_to_nativeint let to_nativeint_exn = Conv.int64_to_nativeint_exn -let to_nativeint_trunc = Conv.int64_to_nativeint_trunc module Pow2 = struct open! Import open Int64_replace_polymorphic_compare - module Sys = Sys0 let raise_s = Error.raise_s @@ -229,8 +209,7 @@ module Pow2 = struct let ceil_log2 i = if Poly.( <= ) i Caml.Int64.zero then - raise_s - (Sexp.message "[Int64.ceil_log2] got invalid input" [ "", sexp_of_int64 i ]); + raise_s (Sexp.message "[Int64.ceil_log2] got invalid input" [ "", sexp_of_int64 i ]); if Caml.Int64.equal i Caml.Int64.one then 0 else num_bits - clz (Caml.Int64.pred i) ;; end @@ -254,7 +233,7 @@ include Conv.Make_hex (struct [@@@end] let zero = zero - let neg = ( ~- ) + let neg = neg let ( < ) = ( < ) let to_string i = Printf.sprintf "%Lx" i let of_string s = Caml.Scanf.sscanf s "%Lx" Fn.id @@ -269,17 +248,20 @@ include Pretty_printer.Register (struct end) module Pre_O = struct - let ( + ) = ( + ) - let ( - ) = ( - ) - let ( * ) = ( * ) - let ( / ) = ( / ) - let ( ~- ) = ( ~- ) + external ( + ) : t -> t -> t = "%int64_add" + external ( - ) : t -> t -> t = "%int64_sub" + external ( * ) : t -> t -> t = "%int64_mul" + external ( / ) : t -> t -> t = "%int64_div" + external ( ~- ) : t -> t = "%int64_neg" + let ( ** ) = ( ** ) - include (Int64_replace_polymorphic_compare : Comparisons.Infix with type t := t) + include Int64_replace_polymorphic_compare let abs = abs - let neg = neg + + external neg : t -> t = "%int64_neg" + let zero = zero let of_int_exn = of_int_exn end @@ -299,13 +281,15 @@ module O = struct let to_string = T.to_string end) - let ( land ) = bit_and - let ( lor ) = bit_or - let ( lxor ) = bit_xor + external ( land ) : t -> t -> t = "%int64_and" + external ( lor ) : t -> t -> t = "%int64_or" + external ( lxor ) : t -> t -> t = "%int64_xor" + let lnot = bit_not - let ( lsl ) = shift_left - let ( asr ) = shift_right - let ( lsr ) = shift_right_logical + + external ( lsl ) : t -> int -> t = "%int64_lsl" + external ( asr ) : t -> int -> t = "%int64_asr" + external ( lsr ) : t -> int -> t = "%int64_lsr" end include O diff --git a/src/int64.mli b/src/int64.mli index 9b8f441..fcd0fe2 100644 --- a/src/int64.mli +++ b/src/int64.mli @@ -3,24 +3,60 @@ open! Import include Int_intf.S with type t = int64 +module O : sig + (*_ Declared as externals so that the compiler skips the caml_apply_X wrapping even when + compiling without cross library inlining. *) + external ( + ) : t -> t -> t = "%int64_add" + external ( - ) : t -> t -> t = "%int64_sub" + external ( * ) : t -> t -> t = "%int64_mul" + external ( / ) : t -> t -> t = "%int64_div" + external ( ~- ) : t -> t = "%int64_neg" + val ( ** ) : t -> t -> t + external ( = ) : t -> t -> bool = "%equal" + external ( <> ) : t -> t -> bool = "%notequal" + external ( < ) : t -> t -> bool = "%lessthan" + external ( > ) : t -> t -> bool = "%greaterthan" + external ( <= ) : t -> t -> bool = "%lessequal" + external ( >= ) : t -> t -> bool = "%greaterequal" + external ( land ) : t -> t -> t = "%int64_and" + external ( lor ) : t -> t -> t = "%int64_or" + external ( lxor ) : t -> t -> t = "%int64_xor" + val lnot : t -> t + val abs : t -> t + external neg : t -> t = "%int64_neg" + val zero : t + val ( % ) : t -> t -> t + val ( /% ) : t -> t -> t + val ( // ) : t -> t -> float + external ( lsl ) : t -> int -> t = "%int64_lsl" + external ( asr ) : t -> int -> t = "%int64_asr" + external ( lsr ) : t -> int -> t = "%int64_lsr" +end + +include module type of O + (** {2 Conversion functions} *) -val of_int : int -> t +(*_ Declared as externals so that the compiler skips the caml_apply_X wrapping even when + compiling without cross library inlining. *) +external of_int : int -> t = "%int64_of_int" +external of_int32 : int32 -> t = "%int64_of_int32" +external of_int64 : t -> t = "%identity" val to_int : t -> int option -val of_int32 : int32 -> t val to_int32 : t -> int32 option val of_nativeint : nativeint -> t val to_nativeint : t -> nativeint option -val of_int64 : t -> t (** {3 Truncating conversions} These functions return the least-significant bits of the input. In cases where optional conversions return [Some x], truncating conversions return [x]. *) -val to_int_trunc : t -> int -val to_int32_trunc : t -> int32 -val to_nativeint_trunc : t -> nativeint +(*_ Declared as externals so that the compiler skips the caml_apply_X wrapping even when + compiling without cross library inlining. *) +external to_int_trunc : t -> int = "%int64_to_int" +external to_int32_trunc : int64 -> int32 = "%int64_to_int32" +external to_nativeint_trunc : int64 -> nativeint = "%int64_to_nativeint" (** {3 Low-level float conversions} *) @@ -40,4 +76,7 @@ val float_of_bits : t -> float val bswap16 : t -> t val bswap32 : t -> t val bswap48 : t -> t -val bswap64 : t -> t + +(*_ Declared as an external so that the compiler skips the caml_apply_X wrapping even when + compiling without cross library inlining. *) +external bswap64 : t -> t = "%bswap_int64" diff --git a/src/int_conversions.ml b/src/int_conversions.ml index 0ea94d0..4bd55a5 100644 --- a/src/int_conversions.ml +++ b/src/int_conversions.ml @@ -62,15 +62,11 @@ let int32_to_int x = ;; let int_to_int32_exn x = - if int_is_representable_as_int32 x - then int_to_int32_trunc x - else int_to_int32_failure x + if int_is_representable_as_int32 x then int_to_int32_trunc x else int_to_int32_failure x ;; let int32_to_int_exn x = - if int32_is_representable_as_int x - then int32_to_int_trunc x - else int32_to_int_failure x + if int32_is_representable_as_int x then int32_to_int_trunc x else int32_to_int_failure x ;; (* int <-> int64 *) @@ -91,9 +87,7 @@ let int64_to_int x = ;; let int64_to_int_exn x = - if int64_is_representable_as_int x - then int64_to_int_trunc x - else int64_to_int_failure x + if int64_is_representable_as_int x then int64_to_int_trunc x else int64_to_int_failure x ;; (* int <-> nativeint *) @@ -286,9 +280,8 @@ end module Make_hex (I : sig type t [@@deriving_inline compare, hash] - val compare : t -> t -> int - val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state - val hash : t -> Ppx_hash_lib.Std.Hash.hash_value + include Ppx_compare_lib.Comparable.S with type t := t + include Ppx_hash_lib.Hashable.S with type t := t [@@@end] @@ -350,6 +343,10 @@ struct | Some (Pos body) -> of_string_with_delimiter body) else invalid str ;; + + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = + Sexplib0.Sexp_grammar.coerce String.t_sexp_grammar + ;; end module Hex = struct diff --git a/src/int_conversions.mli b/src/int_conversions.mli index 31e725c..7e5f6ea 100644 --- a/src/int_conversions.mli +++ b/src/int_conversions.mli @@ -83,9 +83,8 @@ end module Make_hex (I : sig type t [@@deriving_inline compare, hash] - val compare : t -> t -> int - val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state - val hash : t -> Ppx_hash_lib.Std.Hash.hash_value + include Ppx_compare_lib.Comparable.S with type t := t + include Ppx_hash_lib.Hashable.S with type t := t [@@@end] @@ -111,11 +110,7 @@ val sexp_of_int_style : [ `No_underscores | `Underscores ] ref (** utility for defining to_string_hum on numeric types -- takes a string matching (-|+)?[0-9a-fA-F]+ and puts [delimiter] every [chars_per_delimiter] characters starting from the right. *) -val insert_delimiter_every - : string - -> delimiter:char - -> chars_per_delimiter:int - -> string +val insert_delimiter_every : string -> delimiter:char -> chars_per_delimiter:int -> string (** [insert_delimiter_every ~chars_per_delimiter:3] *) val insert_delimiter : string -> delimiter:char -> string diff --git a/src/int_intf.ml b/src/int_intf.ml index 26276a9..7814f7b 100644 --- a/src/int_intf.ml +++ b/src/int_intf.ml @@ -41,13 +41,14 @@ module type Hexable = sig type t module Hex : sig - type nonrec t = t [@@deriving_inline sexp, compare, hash] + type nonrec t = t [@@deriving_inline sexp, sexp_grammar, compare, hash] - include Ppx_sexp_conv_lib.Sexpable.S with type t := t + include Sexplib0.Sexpable.S with type t := t - val compare : t -> t -> int - val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state - val hash : t -> Ppx_hash_lib.Std.Hash.hash_value + val t_sexp_grammar : t Sexplib0.Sexp_grammar.t + + include Ppx_compare_lib.Comparable.S with type t := t + include Ppx_hash_lib.Hashable.S with type t := t [@@@end] @@ -60,9 +61,9 @@ end module type S_common = sig type t [@@deriving_inline sexp, sexp_grammar] - include Ppx_sexp_conv_lib.Sexpable.S with type t := t + include Sexplib0.Sexpable.S with type t := t - val t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t + val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] @@ -298,19 +299,48 @@ module type S = sig module O : Operators with type t := t end -include ( -struct - (** Various functors whose type-correctness ensures desired relationships between - interfaces. *) - - module Check_O_contained_in_S (M : S) : module type of M.O = M - module Check_O_contained_in_S_unbounded (M : S_unbounded) : module type of M.O = M - module Check_S_unbounded_in_S (M : S) : S_unbounded = M -end : -sig end) - module type Int_without_module_types = sig - include S with type t = int + (** OCaml's native integer type. + + The number of bits in an integer is platform dependent, being 31-bits on a 32-bit + platform, and 63-bits on a 64-bit platform. [int] is a signed integer type. [int]s + are also subject to overflow, meaning that [Int.max_value + 1 = Int.min_value]. + + [int]s always fit in a machine word. *) + + include S with type t = int (** @inline *) + + module O : sig + (*_ Declared as externals so that the compiler skips the caml_apply_X wrapping even + when compiling without cross library inlining. *) + external ( + ) : t -> t -> t = "%addint" + external ( - ) : t -> t -> t = "%subint" + external ( * ) : t -> t -> t = "%mulint" + external ( / ) : t -> t -> t = "%divint" + external ( ~- ) : t -> t = "%negint" + val ( ** ) : t -> t -> t + external ( = ) : t -> t -> bool = "%equal" + external ( <> ) : t -> t -> bool = "%notequal" + external ( < ) : t -> t -> bool = "%lessthan" + external ( > ) : t -> t -> bool = "%greaterthan" + external ( <= ) : t -> t -> bool = "%lessequal" + external ( >= ) : t -> t -> bool = "%greaterequal" + external ( land ) : t -> t -> t = "%andint" + external ( lor ) : t -> t -> t = "%orint" + external ( lxor ) : t -> t -> t = "%xorint" + val lnot : t -> t + val abs : t -> t + external neg : t -> t = "%negint" + val zero : t + val ( % ) : t -> t -> t + val ( /% ) : t -> t -> t + val ( // ) : t -> t -> float + external ( lsl ) : t -> int -> t = "%lslint" + external ( asr ) : t -> int -> t = "%asrint" + external ( lsr ) : t -> int -> t = "%lsrint" + end + + include module type of O (** [max_value_30_bits = 2^30 - 1]. It is useful for writing tests that work on both 64-bit and 32-bit platforms. *) @@ -331,10 +361,12 @@ module type Int_without_module_types = sig These functions return the least-significant bits of the input. In cases where optional conversions return [Some x], truncating conversions return [x]. *) - val of_int32_trunc : int32 -> t - val to_int32_trunc : t -> int32 - val of_int64_trunc : int64 -> t - val of_nativeint_trunc : nativeint -> t + (*_ Declared as externals so that the compiler skips the caml_apply_X wrapping even when + compiling without cross library inlining. *) + external to_int32_trunc : t -> int32 = "%int32_of_int" + external of_int32_trunc : int32 -> t = "%int32_to_int" + external of_int64_trunc : int64 -> t = "%int64_to_int" + external of_nativeint_trunc : nativeint -> t = "%nativeint_to_int" (** {2 Byte swap operations} @@ -350,7 +382,9 @@ module type Int_without_module_types = sig (** Byte swaps bottom 16 bits (2 bytes). The values of the remaining bytes are undefined. *) - val bswap16 : t -> t + external bswap16 : int -> int = "%bswap16" + (*_ Declared as an external so that the compiler skips the caml_apply_X wrapping even + when compiling without cross library inlining. *) (**/**) @@ -367,15 +401,8 @@ module type Int_without_module_types = sig end end -(** OCaml's native integer type. - - The number of bits in an integer is platform dependent, being 31-bits on a 32-bit - platform, and 63-bits on a 64-bit platform. [int] is a signed integer type. [int]s - are also subject to overflow, meaning that [Int.max_value + 1 = Int.min_value]. - - [int]s always fit in a machine word. *) module type Int = sig - include Int_without_module_types + include Int_without_module_types (** @inline *) (** {2 Module types specifying integer operations.} *) module type Hexable = Hexable diff --git a/src/int_math_stubs.c b/src/int_math_stubs.c index 58e26e2..6bb5752 100644 --- a/src/int_math_stubs.c +++ b/src/int_math_stubs.c @@ -12,17 +12,24 @@ #define __builtin_popcountll __popcnt64 #define __builtin_popcount __popcnt -static uint32_t __inline __builtin_clz(uint32_t x) +static int __inline __builtin_clz(uint32_t x) { int r = 0; _BitScanForward(&r, x); return r; } -static uint64_t __inline __builtin_clzll(uint64_t x) +static int __inline __builtin_clzll(uint64_t x) { int r = 0; +#ifdef _WIN64 _BitScanForward64(&r, x); +#else + if (!_BitScanForward(&r, (uint32_t)x) && + _BitScanForward(&r, (uint32_t)(x>>32))) { + r += 32; + } +#endif return r; } diff --git a/src/lazy.ml b/src/lazy.ml index fabf419..be3e887 100644 --- a/src/lazy.ml +++ b/src/lazy.ml @@ -1,25 +1,24 @@ open! Import +include Caml.Lazy -type 'a t = 'a lazy_t [@@deriving_inline sexp] +type 'a t = 'a lazy_t [@@deriving_inline sexp, sexp_grammar] -let t_of_sexp : 'a. (Ppx_sexp_conv_lib.Sexp.t -> 'a) -> Ppx_sexp_conv_lib.Sexp.t -> 'a t = - lazy_t_of_sexp -;; +let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = lazy_t_of_sexp +let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = sexp_of_lazy_t -let sexp_of_t : 'a. ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t = - sexp_of_lazy_t +let (t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t) = + fun _'a_sexp_grammar -> lazy_t_sexp_grammar _'a_sexp_grammar ;; [@@@end] -include (Caml.Lazy : module type of Caml.Lazy with type 'a t := 'a t) - let map t ~f = lazy (f (force t)) let compare compare_a t1 t2 = if phys_equal t1 t2 then 0 else compare_a (force t1) (force t2) ;; +let equal equal_a t1 t2 = if phys_equal t1 t2 then true else equal_a (force t1) (force t2) let hash_fold_t = Hash.Builtin.hash_fold_lazy_t include Monad.Make (struct diff --git a/src/lazy.mli b/src/lazy.mli index 5e765a8..b5becd4 100644 --- a/src/lazy.mli +++ b/src/lazy.mli @@ -21,17 +21,14 @@ open! Import -type 'a t = 'a lazy_t [@@deriving_inline compare, hash, sexp] +type 'a t = 'a lazy_t [@@deriving_inline compare, equal, hash, sexp, sexp_grammar] -val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int +include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t +include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t +include Ppx_hash_lib.Hashable.S1 with type 'a t := 'a t +include Sexplib0.Sexpable.S1 with type 'a t := 'a t -val hash_fold_t - : (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) - -> Ppx_hash_lib.Std.Hash.state - -> 'a t - -> Ppx_hash_lib.Std.Hash.state - -include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t := 'a t +val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] @@ -73,7 +70,7 @@ val is_val : 'a t -> bool module T_unforcing : sig type nonrec 'a t = 'a t [@@deriving_inline sexp_of] - val sexp_of_t : ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t [@@@end] end diff --git a/src/linked_queue.ml b/src/linked_queue.ml index 1584a1f..276dfc6 100644 --- a/src/linked_queue.ml +++ b/src/linked_queue.ml @@ -141,6 +141,12 @@ let to_array t = let t_of_sexp a_of_sexp sexp = of_list (list_of_sexp a_of_sexp sexp) let sexp_of_t sexp_of_a t = sexp_of_list sexp_of_a (to_list t) +let t_sexp_grammar (type a) (grammar : a Sexplib0.Sexp_grammar.t) + : a t Sexplib0.Sexp_grammar.t + = + Sexplib0.Sexp_grammar.coerce (List.t_sexp_grammar grammar) +;; + let singleton a = let t = create () in enqueue t a; diff --git a/src/list.ml b/src/list.ml index 8449382..4ac462d 100644 --- a/src/list.ml +++ b/src/list.ml @@ -12,37 +12,11 @@ let invalid_argf = Printf.invalid_argf module T = struct type 'a t = 'a list [@@deriving_inline sexp, sexp_grammar] - let t_of_sexp : - 'a. (Ppx_sexp_conv_lib.Sexp.t -> 'a) -> Ppx_sexp_conv_lib.Sexp.t -> 'a t - = - list_of_sexp - ;; + let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = list_of_sexp + let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = sexp_of_list - let sexp_of_t : - 'a. ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t - = - sexp_of_list - ;; - - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "list" ] - ; ggid = "j\132);\135qH\158\135\222H\001\007\004\158\218" - ; types = - [ "t", Explicit_bind ([ "a" ], Apply (Implicit_var 0, [ Explicit_var 0 ])) ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ list_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "list.ml.T" - } - in - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("t", _the_group) - in - t_sexp_grammar + let (t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t) = + fun _'a_sexp_grammar -> list_sexp_grammar _'a_sexp_grammar ;; [@@@end] @@ -55,25 +29,24 @@ module Or_unequal_lengths = struct [@@deriving_inline compare, sexp_of] let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = - fun _cmp__a a__001_ b__002_ -> - if Ppx_compare_lib.phys_equal a__001_ b__002_ + fun _cmp__a a__006_ b__007_ -> + if Ppx_compare_lib.phys_equal a__006_ b__007_ then 0 else ( - match a__001_, b__002_ with - | Ok _a__003_, Ok _b__004_ -> _cmp__a _a__003_ _b__004_ + match a__006_, b__007_ with + | Ok _a__008_, Ok _b__009_ -> _cmp__a _a__008_ _b__009_ | Ok _, _ -> -1 | _, Ok _ -> 1 | Unequal_lengths, Unequal_lengths -> 0) ;; - let sexp_of_t - : type a. (a -> Ppx_sexp_conv_lib.Sexp.t) -> a t -> Ppx_sexp_conv_lib.Sexp.t - = - fun _of_a -> function - | Ok v0 -> - let v0 = _of_a v0 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Ok"; v0 ] - | Unequal_lengths -> Ppx_sexp_conv_lib.Sexp.Atom "Unequal_lengths" + let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = + fun (type a__013_) : ((a__013_ -> Sexplib0.Sexp.t) -> a__013_ t -> Sexplib0.Sexp.t) -> + fun _of_a__010_ -> function + | Ok arg0__011_ -> + let res0__012_ = _of_a__010_ arg0__011_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Ok"; res0__012_ ] + | Unequal_lengths -> Sexplib0.Sexp.Atom "Unequal_lengths" ;; [@@@end] @@ -165,29 +138,82 @@ let unordered_append l1 l2 = | _ -> rev_append l1 l2 ;; -let check_length2_exn name l1 l2 = - let n1 = length l1 in - let n2 = length l2 in - if n1 <> n2 then invalid_argf "length mismatch in %s: %d <> %d" name n1 n2 () -;; +module Check_length2 = struct + type ('a, 'b) t = + | Same_length of int + | Unequal_lengths of + { shared_length : int + ; tail_of_a : 'a list + ; tail_of_b : 'b list + } + + (* In the [Unequal_lengths] case, at least one of the tails will be non-empty. *) + let of_lists l1 l2 = + let rec loop a b shared_length = + match a, b with + | [], [] -> Same_length shared_length + | _ :: a, _ :: b -> loop a b (shared_length + 1) + | [], _ | _, [] -> Unequal_lengths { shared_length; tail_of_a = a; tail_of_b = b } + in + loop l1 l2 0 + ;; +end -let check_length3_exn name l1 l2 l3 = - let n1 = length l1 in - let n2 = length l2 in - let n3 = length l3 in - if n1 <> n2 || n2 <> n3 - then invalid_argf "length mismatch in %s: %d <> %d || %d <> %d" name n1 n2 n2 n3 () +let check_length2_exn name l1 l2 = + match Check_length2.of_lists l1 l2 with + | Same_length _ -> () + | Unequal_lengths { shared_length; tail_of_a; tail_of_b } -> + invalid_argf + "length mismatch in %s: %d <> %d" + name + (shared_length + length tail_of_a) + (shared_length + length tail_of_b) + () ;; let check_length2 l1 l2 ~f = - if length l1 <> length l2 then Or_unequal_lengths.Unequal_lengths else Ok (f l1 l2) + match Check_length2.of_lists l1 l2 with + | Same_length _ -> Or_unequal_lengths.Ok (f l1 l2) + | Unequal_lengths _ -> Unequal_lengths +;; + +module Check_length3 = struct + type ('a, 'b, 'c) t = + | Same_length of int + | Unequal_lengths of + { shared_length : int + ; tail_of_a : 'a list + ; tail_of_b : 'b list + ; tail_of_c : 'c list + } + + (* In the [Unequal_lengths] case, at least one of the tails will be non-empty. *) + let of_lists l1 l2 l3 = + let rec loop a b c shared_length = + match a, b, c with + | [], [], [] -> Same_length shared_length + | _ :: a, _ :: b, _ :: c -> loop a b c (shared_length + 1) + | [], _, _ | _, [], _ | _, _, [] -> + Unequal_lengths { shared_length; tail_of_a = a; tail_of_b = b; tail_of_c = c } + in + loop l1 l2 l3 0 + ;; +end + +let check_length3_exn name l1 l2 l3 = + match Check_length3.of_lists l1 l2 l3 with + | Same_length _ -> () + | Unequal_lengths { shared_length; tail_of_a; tail_of_b; tail_of_c } -> + let n1 = shared_length + length tail_of_a in + let n2 = shared_length + length tail_of_b in + let n3 = shared_length + length tail_of_c in + invalid_argf "length mismatch in %s: %d <> %d || %d <> %d" name n1 n2 n2 n3 () ;; let check_length3 l1 l2 l3 ~f = - let n1 = length l1 in - let n2 = length l2 in - let n3 = length l3 in - if n1 <> n2 || n2 <> n3 then Or_unequal_lengths.Unequal_lengths else Ok (f l1 l2 l3) + match Check_length3.of_lists l1 l2 l3 with + | Same_length _ -> Or_unequal_lengths.Ok (f l1 l2 l3) + | Unequal_lengths _ -> Unequal_lengths ;; let iter2 l1 l2 ~f = check_length2 l1 l2 ~f:(iter2_ok ~f) @@ -295,6 +321,16 @@ let findi t ~f = loop 0 t ;; +let findi_exn = + let not_found = Not_found_s (Atom "List.findi_exn: not found") in + let findi_exn t ~f = + match findi t ~f with + | None -> raise not_found + | Some x -> x + in + findi_exn +;; + let find_mapi t ~f = let rec loop i t = match t with @@ -342,9 +378,18 @@ let fold_left = fold let to_array = Array.of_list let to_list t = t +let max_non_tailcall = + match Sys.backend_type with + | Sys.Native | Sys.Bytecode -> 1_000 + (* We don't know the size of the stack, better be safe and assume it's small. This + number was taken from ocaml#stdlib/list.ml which is also equal to the default limit + of recursive call in the js_of_ocaml compiler before switching to trampoline. *) + | Sys.Other _ -> 50 +;; + (** Tail recursive versions of standard [List] module *) -let slow_append l1 l2 = rev_append (rev l1) l2 +let tail_append l1 l2 = rev_append (rev l1) l2 (* There are a few optimized list operations here, including append and map. There are basically two optimizations in play: loop unrolling, and dynamic switching between @@ -374,11 +419,41 @@ let rec count_append l1 l2 count = :: x3 :: x4 :: x5 - :: (if count > 1000 then slow_append tl l2 else count_append tl l2 (count + 1))) + :: + (if count > max_non_tailcall + then tail_append tl l2 + else count_append tl l2 (count + 1))) ;; let append l1 l2 = count_append l1 l2 0 -let slow_map l ~f = rev (rev_map l ~f) + +(* An ordinary tail recursive map builds up an intermediate (reversed) representation, + with one heap allocated object per element. The following implementation instead chunks + 9 objects into one heap allocated object, reducing allocation and performance costs + accordingly. Note that the very end of the list is done by the stdlib's map + function. *) +let tail_map xs ~f = + let rec rise ys = function + | [] -> ys + | (y0, y1, y2, y3, y4, y5, y6, y7, y8) :: bs -> + rise (y0 :: y1 :: y2 :: y3 :: y4 :: y5 :: y6 :: y7 :: y8 :: ys) bs + in + let rec dive bs = function + | x0 :: x1 :: x2 :: x3 :: x4 :: x5 :: x6 :: x7 :: x8 :: xs -> + let y0 = f x0 in + let y1 = f x1 in + let y2 = f x2 in + let y3 = f x3 in + let y4 = f x4 in + let y5 = f x5 in + let y6 = f x6 in + let y7 = f x7 in + let y8 = f x8 in + dive ((y0, y1, y2, y3, y4, y5, y6, y7, y8) :: bs) xs + | xs -> rise (nontail_map ~f xs) bs + in + dive [] xs +;; let rec count_map ~f l ctr = match l with @@ -412,7 +487,7 @@ let rec count_map ~f l ctr = :: f3 :: f4 :: f5 - :: (if ctr > 1000 then slow_map ~f tl else count_map ~f tl (ctr + 1)) + :: (if ctr > max_non_tailcall then tail_map ~f tl else count_map ~f tl (ctr + 1)) ;; let map l ~f = count_map ~f l 0 @@ -476,33 +551,27 @@ let rec rev_map_append l1 l2 ~f = | h :: t -> rev_map_append ~f t (f h :: l2) ;; -let fold_right l ~f ~init = - match l with - | [] -> init (* avoid the allocation of [~f] below *) - | _ -> fold ~f:(fun a b -> f b a) ~init (rev l) -;; - let unzip list = let rec loop list l1 l2 = match list with - | [] -> rev l1, rev l2 + | [] -> l1, l2 | (x, y) :: tl -> loop tl (x :: l1) (y :: l2) in - loop list [] [] + loop (rev list) [] [] ;; let unzip3 list = let rec loop list l1 l2 l3 = match list with - | [] -> rev l1, rev l2, rev l3 + | [] -> l1, l2, l3 | (x, y, z) :: tl -> loop tl (x :: l1) (y :: l2) (z :: l3) in - loop list [] [] [] + loop (rev list) [] [] [] ;; let zip_exn l1 l2 = - check_length2_exn "zip_exn" l1 l2; - map2_ok ~f:(fun a b -> a, b) l1 l2 + try map2_ok ~f:(fun a b -> a, b) l1 l2 with + | _ -> invalid_argf "length mismatch in zip_exn: %d <> %d" (length l1) (length l2) () ;; let zip l1 l2 = map2 ~f:(fun a b -> a, b) l1 l2 @@ -630,6 +699,10 @@ let groupi l ~break = let group l ~break = groupi l ~break:(fun _ x y -> break x y) +let sort_and_group l ~compare = + l |> stable_sort ~compare |> group ~break:(fun x y -> compare x y <> 0) +;; + let concat_map l ~f = let rec aux acc = function | [] -> rev acc @@ -657,30 +730,77 @@ let merge l1 l2 ~compare = loop [] l1 l2 ;; -include struct - (* We are explicit about what we import from the general Monad functor so that we don't - accidentally rebind more efficient list-specific functions. *) - module Monad = Monad.Make (struct - type 'a t = 'a list - - let bind x ~f = concat_map x ~f - let map = `Custom map - let return x = [ x ] - end) - - open Monad - module Monad_infix = Monad_infix - module Let_syntax = Let_syntax +module Cartesian_product = struct + (* We are explicit about what we export from functors so that we don't accidentally + rebind more efficient list-specific functions. *) - let ignore_m = ignore_m - let join = join - let bind = bind + let bind = concat_map + let map = map + let map2 a b ~f = concat_map a ~f:(fun x -> map b ~f:(fun y -> f x y)) + let return x = [ x ] + let ( >>| ) = ( >>| ) let ( >>= ) t f = bind t ~f - let return = return - let all = all - let all_unit = all_unit + + open struct + module Applicative = Applicative.Make_using_map2 (struct + type 'a t = 'a list + + let return = return + let map = `Custom map + let map2 = map2 + end) + + module Monad = Monad.Make (struct + type 'a t = 'a list + + let return = return + let map = `Custom map + let bind = bind + end) + end + + let all = Monad.all + let all_unit = Monad.all_unit + let ignore_m = Monad.ignore_m + let join = Monad.join + + module Monad_infix = struct + let ( >>| ) = ( >>| ) + let ( >>= ) = ( >>= ) + end + + let apply = Applicative.apply + let both = Applicative.both + let map3 = Applicative.map3 + let ( <*> ) = Applicative.( <*> ) + let ( *> ) = Applicative.( *> ) + let ( <* ) = Applicative.( <* ) + + module Applicative_infix = struct + let ( >>| ) = ( >>| ) + let ( <*> ) = Applicative.( <*> ) + let ( *> ) = Applicative.( *> ) + let ( <* ) = Applicative.( <* ) + end + + module Let_syntax = struct + let return = return + let ( >>| ) = ( >>| ) + let ( >>= ) = ( >>= ) + + module Let_syntax = struct + let return = return + let bind = bind + let map = map + let both = both + + module Open_on_rhs = struct end + end + end end +include (Cartesian_product : Monad.S with type 'a t := 'a t) + (** returns final element of list *) let rec last_exn list = match list with @@ -739,7 +859,7 @@ let remove_consecutive_duplicates ?(which_to_keep = `Last) list ~equal = ;; (** returns sorted version of list with duplicates removed *) -let dedup_and_sort ~compare list = +let dedup_and_sort list ~compare = match list with | [] | [ _ ] -> list (* performance hack *) | _ -> @@ -748,8 +868,8 @@ let dedup_and_sort ~compare list = remove_consecutive_duplicates ~equal sorted ;; -let find_a_dup ~compare l = - let sorted = sort ~compare l in +let find_a_dup l ~compare = + let sorted = sort l ~compare in let rec loop l = match l with | [] | [ _ ] -> None @@ -758,13 +878,13 @@ let find_a_dup ~compare l = loop sorted ;; -let contains_dup ~compare lst = - match find_a_dup ~compare lst with +let contains_dup lst ~compare = + match find_a_dup lst ~compare with | Some _ -> true | None -> false ;; -let find_all_dups ~compare l = +let find_all_dups l ~compare = (* We add this reversal, so we can skip a [rev] at the end. We could skip [rev] anyway since we don not give any ordering guarantees, but it is nice to get results in natural order. *) @@ -786,6 +906,18 @@ let find_all_dups ~compare l = | hd :: tl -> loop tl hd ~already_recorded:false [] ;; +let rec all_equal_to t v ~equal = + match t with + | [] -> true + | x :: xs -> equal x v && all_equal_to xs v ~equal +;; + +let all_equal t ~equal = + match t with + | [] -> None + | x :: xs -> if all_equal_to xs x ~equal then Some x else None +;; + let count t ~f = Container.count ~fold t ~f let sum m t ~f = Container.sum ~fold m t ~f let min_elt t ~compare = Container.min_elt ~fold t ~compare @@ -854,40 +986,75 @@ let partition_tf t ~f = let partition_result t = partition_map t ~f:Result.to_either module Assoc = struct - type ('a, 'b) t = ('a * 'b) list [@@deriving_inline sexp] + type ('a, 'b) t = ('a * 'b) list [@@deriving_inline sexp, sexp_grammar] let t_of_sexp : - 'a 'b. (Ppx_sexp_conv_lib.Sexp.t -> 'a) -> (Ppx_sexp_conv_lib.Sexp.t -> 'b) - -> Ppx_sexp_conv_lib.Sexp.t -> ('a, 'b) t + 'a 'b. + (Sexplib0.Sexp.t -> 'a) + -> (Sexplib0.Sexp.t -> 'b) + -> Sexplib0.Sexp.t + -> ('a, 'b) t = - let _tp_loc = "list.ml.Assoc.t" in - fun _of_a _of_b t -> + let error_source__022_ = "list.ml.Assoc.t" in + fun _of_a__014_ _of_b__015_ x__023_ -> list_of_sexp (function - | Ppx_sexp_conv_lib.Sexp.List [ v0; v1 ] -> - let v0 = _of_a v0 - and v1 = _of_b v1 in - v0, v1 - | sexp -> Ppx_sexp_conv_lib.Conv_error.tuple_of_size_n_expected _tp_loc 2 sexp) - t + | Sexplib0.Sexp.List [ arg0__017_; arg1__018_ ] -> + let res0__019_ = _of_a__014_ arg0__017_ + and res1__020_ = _of_b__015_ arg1__018_ in + res0__019_, res1__020_ + | sexp__021_ -> + Sexplib0.Sexp_conv_error.tuple_of_size_n_expected + error_source__022_ + 2 + sexp__021_) + x__023_ ;; let sexp_of_t : - 'a 'b. ('a -> Ppx_sexp_conv_lib.Sexp.t) -> ('b -> Ppx_sexp_conv_lib.Sexp.t) - -> ('a, 'b) t -> Ppx_sexp_conv_lib.Sexp.t + 'a 'b. + ('a -> Sexplib0.Sexp.t) + -> ('b -> Sexplib0.Sexp.t) + -> ('a, 'b) t + -> Sexplib0.Sexp.t = - fun _of_a _of_b v -> + fun _of_a__024_ _of_b__025_ x__030_ -> sexp_of_list - (function - | v0, v1 -> - let v0 = _of_a v0 - and v1 = _of_b v1 in - Ppx_sexp_conv_lib.Sexp.List [ v0; v1 ]) - v + (fun (arg0__026_, arg1__027_) -> + let res0__028_ = _of_a__024_ arg0__026_ + and res1__029_ = _of_b__025_ arg1__027_ in + Sexplib0.Sexp.List [ res0__028_; res1__029_ ]) + x__030_ + ;; + + let (t_sexp_grammar : + 'a Sexplib0.Sexp_grammar.t + -> 'b Sexplib0.Sexp_grammar.t + -> ('a, 'b) t Sexplib0.Sexp_grammar.t) + = + fun _'a_sexp_grammar _'b_sexp_grammar -> + list_sexp_grammar + { untyped = + List (Cons (_'a_sexp_grammar.untyped, Cons (_'b_sexp_grammar.untyped, Empty))) + } ;; [@@@end] + let pair_of_group = function + | [] -> assert false + | (k, _) :: _ as list -> k, map list ~f:snd + ;; + + let group alist ~equal = + group alist ~break:(fun (x, _) (y, _) -> not (equal x y)) |> map ~f:pair_of_group + ;; + + let sort_and_group alist ~compare = + sort_and_group alist ~compare:(fun (x, _) (y, _) -> compare x y) + |> map ~f:pair_of_group + ;; + let find t ~equal key = match find t ~f:(fun (key', _) -> equal key key') with | None -> None @@ -969,8 +1136,7 @@ let rec drop t n = ;; let chunks_of l ~length = - if length <= 0 - then invalid_argf "List.chunks_of: Expected length > 0, got %d" length (); + if length <= 0 then invalid_argf "List.chunks_of: Expected length > 0, got %d" length (); let rec aux of_length acc l = match l with | [] -> rev acc @@ -1099,33 +1265,38 @@ let equal equal t1 t2 = ;; let transpose = - let rec transpose_aux t rev_columns = - match - partition_map t ~f:(function - | [] -> Second () - | x :: xs -> First (x, xs)) - with - | _ :: _, _ :: _ -> None - | [], _ -> Some (rev_append rev_columns []) - | heads_and_tails, [] -> - let column, trimmed_rows = unzip heads_and_tails in - transpose_aux trimmed_rows (column :: rev_columns) + let rec split_off_first_column t column_acc trimmed found_empty = + match t with + | [] -> column_acc, trimmed, found_empty + | [] :: tl -> split_off_first_column tl column_acc trimmed true + | (x :: xs) :: tl -> + split_off_first_column tl (x :: column_acc) (xs :: trimmed) found_empty + in + let split_off_first_column rows = split_off_first_column rows [] [] false in + let rec loop rows columns do_rev = + match split_off_first_column rows with + | [], [], _ -> Some (rev columns) + | column, trimmed_rows, found_empty -> + if found_empty + then None + else ( + let column = if do_rev then rev column else column in + loop trimmed_rows (column :: columns) (not do_rev)) in - fun t -> transpose_aux t [] + fun t -> loop t [] true ;; exception Transpose_got_lists_of_different_lengths of int list [@@deriving_inline sexp] let () = - Ppx_sexp_conv_lib.Conv.Exn_converter.add + Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Transpose_got_lists_of_different_lengths] (function - | Transpose_got_lists_of_different_lengths v0 -> - let v0 = sexp_of_list sexp_of_int v0 in - Ppx_sexp_conv_lib.Sexp.List - [ Ppx_sexp_conv_lib.Sexp.Atom - "list.ml.Transpose_got_lists_of_different_lengths" - ; v0 + | Transpose_got_lists_of_different_lengths arg0__031_ -> + let res0__032_ = sexp_of_list sexp_of_int arg0__031_ in + Sexplib0.Sexp.List + [ Sexplib0.Sexp.Atom "list.ml.Transpose_got_lists_of_different_lengths" + ; res0__032_ ] | _ -> assert false) ;; diff --git a/src/list.mli b/src/list.mli index 49ff651..bf7254b 100644 --- a/src/list.mli +++ b/src/list.mli @@ -6,17 +6,11 @@ open! Import type 'a t = 'a list [@@deriving_inline compare, hash, sexp, sexp_grammar] -val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int +include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t +include Ppx_hash_lib.Hashable.S1 with type 'a t := 'a t +include Sexplib0.Sexpable.S1 with type 'a t := 'a t -val hash_fold_t - : (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) - -> Ppx_hash_lib.Std.Hash.state - -> 'a t - -> Ppx_hash_lib.Std.Hash.state - -include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t := 'a t - -val t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t +val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] @@ -24,6 +18,14 @@ val t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t include Container.S1 with type 'a t := 'a t include Invariant_intf.S1 with type 'a t := 'a t + +(** Implements cartesian-product behavior for [map] and [bind]. **) +module Cartesian_product : sig + include Applicative.S with type 'a t := 'a t + include Monad.S with type 'a t := 'a t +end + +(** The monad portion of [Cartesian_product] is re-exported at top level. *) include Monad.S with type 'a t := 'a t (** [Or_unequal_lengths] is used for functions that take multiple lists and that only make @@ -36,8 +38,9 @@ module Or_unequal_lengths : sig | Unequal_lengths [@@deriving_inline compare, sexp_of] - val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int - val sexp_of_t : ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t + include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t + + val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t [@@@end] end @@ -88,12 +91,7 @@ val rev_map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t Or_unequal_lengths.t ...) bn cn]. The exn version will raise if the two lists have different lengths. *) val fold2_exn : 'a t -> 'b t -> init:'c -> f:('c -> 'a -> 'b -> 'c) -> 'c -val fold2 - : 'a t - -> 'b t - -> init:'c - -> f:('c -> 'a -> 'b -> 'c) - -> 'c Or_unequal_lengths.t +val fold2 : 'a t -> 'b t -> init:'c -> f:('c -> 'a -> 'b -> 'c) -> 'c Or_unequal_lengths.t (** Like {!List.for_all}, but passes the index as an argument. *) val for_alli : 'a t -> f:(int -> 'a -> bool) -> bool @@ -132,8 +130,8 @@ val partition3_map -> 'b t * 'c t * 'd t (** [partition_tf l ~f] returns a pair of lists [(l1, l2)], where [l1] is the list of all - the elements of [l] that satisfy the predicate [p], and [l2] is the list of all the - elements of [l] that do not satisfy [p]. The order of the elements in the input list + the elements of [l] that satisfy the predicate [f], and [l2] is the list of all the + elements of [l] that do not satisfy [f]. The order of the elements in the input list is preserved. The "tf" suffix is mnemonic to remind readers at a call that the result is (trues, falses). *) val partition_tf : 'a t -> f:('a -> bool) -> 'a t * 'a t @@ -183,6 +181,9 @@ val tl_exn : 'a t -> 'a t val findi : 'a t -> f:(int -> 'a -> bool) -> (int * 'a) option +(** Like [find_exn], but passes the index as an argument. *) +val findi_exn : 'a t -> f:(int -> 'a -> bool) -> int * 'a + (** [find_exn t ~f] returns the first element of [t] that satisfies [f]. It raises [Caml.Not_found] or [Not_found_s] if there is no such element. *) val find_exn : 'a t -> f:('a -> bool) -> 'a @@ -224,8 +225,8 @@ val concat_mapi : 'a t -> f:(int -> 'a -> 'b t) -> 'b t (** [map2 [a1; ...; an] [b1; ...; bn] ~f] is [[f a1 b1; ...; f an bn]]. The exn version will raise if the two lists have different lengths. *) -val map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t +val map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t Or_unequal_lengths.t (** Analogous to [rev_map2]. *) @@ -325,6 +326,9 @@ val group : 'a t -> break:('a -> 'a -> bool) -> 'a t t *) val groupi : 'a t -> break:(int -> 'a -> 'a -> bool) -> 'a t t +(** Group equal elements into the same buckets. Sorting is stable. *) +val sort_and_group : 'a t -> compare:('a -> 'a -> int) -> 'a t t + (** [chunks_of l ~length] returns a list of lists whose concatenation is equal to the original list. Every list has [length] elements, except for possibly the last list, which may have fewer. [chunks_of] raises if [length <= 0]. *) @@ -358,19 +362,23 @@ val remove_consecutive_duplicates -> 'a t (** Returns the given list with duplicates removed and in sorted order. *) -val dedup_and_sort : compare:('a -> 'a -> int) -> 'a t -> 'a t +val dedup_and_sort : 'a t -> compare:('a -> 'a -> int) -> 'a t (** [find_a_dup] returns a duplicate from the list (with no guarantees about which duplicate you get), or [None] if there are no dups. *) -val find_a_dup : compare:('a -> 'a -> int) -> 'a t -> 'a option +val find_a_dup : 'a t -> compare:('a -> 'a -> int) -> 'a option (** Returns true if there are any two elements in the list which are the same. O(n log n) time complexity. *) -val contains_dup : compare:('a -> 'a -> int) -> 'a t -> bool +val contains_dup : 'a t -> compare:('a -> 'a -> int) -> bool (** [find_all_dups] returns a list of all elements that occur more than once, with no guarantees about order. O(n log n) time complexity. *) -val find_all_dups : compare:('a -> 'a -> int) -> 'a t -> 'a list +val find_all_dups : 'a t -> compare:('a -> 'a -> int) -> 'a list + +(** [all_equal] returns a single element of the list that is equal to all other elements, + or [None] if no such element exists. *) +val all_equal : 'a t -> equal:('a -> 'a -> bool) -> 'a option (** [count l ~f] is the number of elements in [l] that satisfy the predicate [f]. *) val count : 'a t -> f:('a -> bool) -> int @@ -435,9 +443,14 @@ val filter_opt : 'a option t -> 'a t {[ Map.xxx (alist |> Map.of_alist_multi |> Map.map ~f:List.hd) ...args... ]} *) module Assoc : sig - type ('a, 'b) t = ('a * 'b) list [@@deriving_inline sexp] + type ('a, 'b) t = ('a * 'b) list [@@deriving_inline sexp, sexp_grammar] + + include Sexplib0.Sexpable.S2 with type ('a, 'b) t := ('a, 'b) t - include Ppx_sexp_conv_lib.Sexpable.S2 with type ('a, 'b) t := ('a, 'b) t + val t_sexp_grammar + : 'a Sexplib0.Sexp_grammar.t + -> 'b Sexplib0.Sexp_grammar.t + -> ('a, 'b) t Sexplib0.Sexp_grammar.t [@@@end] @@ -450,6 +463,15 @@ module Assoc : sig (** Bijectivity is not guaranteed because we allow a key to appear more than once. *) val inverse : ('a, 'b) t -> ('b, 'a) t + + (** Converts an association list with potential consecutive duplicate keys into an + association list of (non-empty) lists with no (consecutive) duplicate keys. Any + non-consecutive duplicate keys in the input will remain in the output. *) + val group : ('a * 'b) list -> equal:('a -> 'a -> bool) -> ('a, 'b list) t + + (** Converts an association list with potential duplicate keys into an association list + of (non-empty) lists with no duplicate keys. *) + val sort_and_group : ('a * 'b) list -> compare:('a -> 'a -> int) -> ('a, 'b list) t end (** [sub pos len l] is the [len]-element sublist of [l], starting at [pos]. *) diff --git a/src/list0.ml b/src/list0.ml index cb71bd5..5cebb9f 100644 --- a/src/list0.ml +++ b/src/list0.ml @@ -36,3 +36,9 @@ let rev = function | ([] | [ _ ]) as res -> res | x :: y :: rest -> rev_append rest [ y; x ] ;; + +let fold_right l ~f ~init = + match l with + | [] -> init (* avoid the allocation of [~f] below *) + | _ -> fold ~f:(fun a b -> f b a) ~init (rev l) +;; @@ -13,30 +13,7 @@ open! Import module List = List0 - -include ( - Map_intf : - sig - module Or_duplicate = Map_intf.Or_duplicate - module Continue_or_stop = Map_intf.Continue_or_stop - 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 - - (* The module susbstitutions below are needed for older versions of OCaml - (before 4.07), because back then [module type of] did not keep module - aliases. *) - - include module type of struct - include Map_intf - end - with module Finished_or_unfinished := Map_intf.Finished_or_unfinished - and module Or_duplicate := Or_duplicate - and module Continue_or_stop := Continue_or_stop - and module With_comparator := With_comparator - and module With_first_class_module := With_first_class_module - and module Without_comparator := Without_comparator - end) +include Map_intf module Finished_or_unfinished = struct include Map_intf.Finished_or_unfinished @@ -47,13 +24,46 @@ module Finished_or_unfinished = struct let to_continue_or_stop : t -> Continue_or_stop.t = Caml.Obj.magic end +module Merge_element = struct + include Map_intf.Merge_element + + let left = function + | `Right _ -> None + | `Left left | `Both (left, _) -> Some left + ;; + + let right = function + | `Left _ -> None + | `Right right | `Both (_, right) -> Some right + ;; + + let left_value t ~default = + match t with + | `Right _ -> default + | `Left left | `Both (left, _) -> left + ;; + + let right_value t ~default = + match t with + | `Left _ -> default + | `Right right | `Both (_, right) -> right + ;; + + let values t ~left_default ~right_default = + match t with + | `Left left -> left, right_default + | `Right right -> left_default, right + | `Both (left, right) -> left, right + ;; +end + let with_return = With_return.with_return exception Duplicate [@@deriving_inline sexp] let () = - Ppx_sexp_conv_lib.Conv.Exn_converter.add [%extension_constructor Duplicate] (function - | Duplicate -> Ppx_sexp_conv_lib.Sexp.Atom "map.ml.Duplicate" + Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Duplicate] (function + | Duplicate -> Sexplib0.Sexp.Atom "map.ml.Duplicate" | _ -> assert false) ;; @@ -111,7 +121,7 @@ module Tree0 = struct let singleton key data = Leaf (key, data) (* We must call [f] with increasing indexes, because the bin_prot reader in - Core_kernel.Map needs it. *) + Core.Map needs it. *) let of_increasing_iterator_unchecked ~len ~f = let rec loop n ~f i : (_, _) t = match n with @@ -160,14 +170,12 @@ module Tree0 = struct with_return (fun r -> let increasing = match compare_key (fst array.(0)) (fst array.(1)) with - | 0 -> - r.return (Or_error.error_string "of_sorted_array: duplicated elements") + | 0 -> r.return (Or_error.error_string "of_sorted_array: duplicated elements") | i -> i < 0 in for i = 1 to Array.length array - 2 do match compare_key (fst array.(i)) (fst array.(i + 1)) with - | 0 -> - r.return (Or_error.error_string "of_sorted_array: duplicated elements") + | 0 -> r.return (Or_error.error_string "of_sorted_array: duplicated elements") | i -> if Poly.( <> ) (i < 0) increasing then @@ -192,8 +200,7 @@ module Tree0 = struct else ( match lr with | Empty -> invalid_arg "Map.bal" - | Leaf (lrv, lrd) -> - create (create ll lv ld Empty) lrv lrd (create Empty x d r) + | Leaf (lrv, lrd) -> create (create ll lv ld Empty) lrv lrd (create Empty x d r) | Node (lrl, lrv, lrd, lrr, _) -> create (create ll lv ld lrl) lrv lrd (create lrr x d r))) else if hr > hl + 2 @@ -207,8 +214,7 @@ module Tree0 = struct else ( match rl with | Empty -> invalid_arg "Map.bal" - | Leaf (rlv, rld) -> - create (create l x d Empty) rlv rld (create Empty rv rd rr) + | Leaf (rlv, rld) -> create (create l x d Empty) rlv rld (create Empty rv rd rr) | Node (rll, rlv, rld, rlr, _) -> create (create l x d rll) rlv rld (create rlr rv rd rr))) else create l x d r @@ -267,39 +273,18 @@ module Tree0 = struct else if c < 0 then ( let l, length = - find_and_add_or_set - ~length - ~key:x - ~data - l - ~compare_key - ~sexp_of_key - ~add_or_set + find_and_add_or_set ~length ~key:x ~data l ~compare_key ~sexp_of_key ~add_or_set in bal l v d r, length) else ( let r, length = - find_and_add_or_set - ~length - ~key:x - ~data - r - ~compare_key - ~sexp_of_key - ~add_or_set + find_and_add_or_set ~length ~key:x ~data r ~compare_key ~sexp_of_key ~add_or_set in bal l v d r, length) ;; let add_exn t ~length ~key ~data ~compare_key ~sexp_of_key = - find_and_add_or_set - t - ~length - ~key - ~data - ~compare_key - ~sexp_of_key - ~add_or_set:Add_exn + find_and_add_or_set t ~length ~key ~data ~compare_key ~sexp_of_key ~add_or_set:Add_exn ;; let add_exn_internal t ~length ~key ~data ~compare_key ~sexp_of_key = @@ -375,7 +360,7 @@ module Tree0 = struct fun t ~key ~data -> go t (Fragment.singleton ~key ~data) ;; - let to_tree = + let to_tree_unchecked = let rec go t r = match t with | Zero () -> r @@ -407,7 +392,7 @@ module Tree0 = struct (Or_error.error_string "of_increasing_sequence: non-increasing key") | _ -> Build_increasing.add_unchecked builder ~key ~data, length + 1) in - Ok (Build_increasing.to_tree builder, length)) + Ok (Build_increasing.to_tree_unchecked builder, length)) ;; (* Like [bal] but allows any difference in height between [l] and [r]. @@ -486,8 +471,7 @@ module Tree0 = struct let mid, right = match upper_bound with | Unbounded -> mid_and_right, empty - | Incl lb -> - split_and_reinsert_boundary ~into:`Left mid_and_right lb ~compare_key + | Incl lb -> split_and_reinsert_boundary ~into:`Left mid_and_right lb ~compare_key | Excl lb -> split_and_reinsert_boundary ~into:`Right mid_and_right lb ~compare_key in @@ -524,9 +508,7 @@ module Tree0 = struct | Leaf (v, d) -> if compare_key x v = 0 then d else if_not_found x ~sexp_of_key | Node (l, v, d, r, _) -> let c = compare_key x v in - if c = 0 - then d - else find_exn (if c < 0 then l else r) x ~compare_key ~sexp_of_key + if c = 0 then d else find_exn (if c < 0 then l else r) x ~compare_key ~sexp_of_key in (* named to preserve symbol in compiled binary *) find_exn @@ -544,11 +526,11 @@ module Tree0 = struct exception Map_min_elt_exn_of_empty_map [@@deriving_inline sexp] let () = - Ppx_sexp_conv_lib.Conv.Exn_converter.add + Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Map_min_elt_exn_of_empty_map] (function | Map_min_elt_exn_of_empty_map -> - Ppx_sexp_conv_lib.Sexp.Atom "map.ml.Tree0.Map_min_elt_exn_of_empty_map" + Sexplib0.Sexp.Atom "map.ml.Tree0.Map_min_elt_exn_of_empty_map" | _ -> assert false) ;; @@ -557,11 +539,11 @@ module Tree0 = struct exception Map_max_elt_exn_of_empty_map [@@deriving_inline sexp] let () = - Ppx_sexp_conv_lib.Conv.Exn_converter.add + Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Map_max_elt_exn_of_empty_map] (function | Map_max_elt_exn_of_empty_map -> - Ppx_sexp_conv_lib.Sexp.Atom "map.ml.Tree0.Map_max_elt_exn_of_empty_map" + Sexplib0.Sexp.Atom "map.ml.Tree0.Map_max_elt_exn_of_empty_map" | _ -> assert false) ;; @@ -598,8 +580,7 @@ module Tree0 = struct match max_elt lower_part, min_elt upper_part with | None, _ -> `Ok upper_part | _, None -> `Ok lower_part - | Some (max_lower, _), Some (min_upper, v) when compare_key max_lower min_upper < 0 - -> + | Some (max_lower, _), Some (min_upper, v) when compare_key max_lower min_upper < 0 -> let upper_part_without_min = remove_min_elt upper_part in `Ok (join ~compare_key lower_part min_upper v upper_part_without_min) | _ -> `Overlapping_key_ranges @@ -661,21 +642,30 @@ module Tree0 = struct bal t1 x d (remove_min_elt t2) ;; - let rec remove t x ~length ~compare_key = - match t with - | Empty -> Empty, length - | Leaf (v, _) -> if compare_key x v = 0 then Empty, length - 1 else t, length - | Node (l, v, d, r, _) -> - let c = compare_key x v in - if c = 0 - then concat_unchecked l r, length - 1 - else if c < 0 - then ( - let l, length = remove l x ~length ~compare_key in - bal l v d r, length) - else ( - let r, length = remove r x ~length ~compare_key in - bal l v d r, length) + exception Remove_no_op + + let remove t x ~length ~compare_key = + let rec remove_loop t x ~length ~compare_key = + match t with + | Empty -> Exn.raise_without_backtrace Remove_no_op + | Leaf (v, _) -> + if compare_key x v = 0 + then Empty, length - 1 + else Exn.raise_without_backtrace Remove_no_op + | Node (l, v, d, r, _) -> + let c = compare_key x v in + if c = 0 + then concat_unchecked l r, length - 1 + else if c < 0 + then ( + let l, length = remove_loop l x ~length ~compare_key in + bal l v d r, length) + else ( + let r, length = remove_loop r x ~length ~compare_key in + bal l v d r, length) + in + try remove_loop t x ~length ~compare_key with + | Remove_no_op -> t, length ;; (* Use exception to avoid tree-rebuild in no-op case *) @@ -838,6 +828,24 @@ module Tree0 = struct | Node (l, v, d, r, _) -> fold ~f r ~init:(f ~key:v ~data:d (fold ~f l ~init:accu)) ;; + let fold_until t ~init ~f ~finish = + let rec fold_until_loop t ~acc ~f : (_, _) Container.Continue_or_stop.t = + match t with + | Empty -> Continue acc + | Leaf (v, d) -> f ~key:v ~data:d acc + | Node (l, v, d, r, _) -> + (match fold_until_loop l ~acc ~f with + | Stop final -> Stop final + | Continue acc -> + (match f ~key:v ~data:d acc with + | Stop final -> Stop final + | Continue acc -> fold_until_loop r ~acc ~f)) + in + match fold_until_loop t ~acc:init ~f with + | Continue acc -> finish acc + | Stop stop -> stop + ;; + let rec fold_right t ~init:accu ~f = match t with | Empty -> accu @@ -1025,8 +1033,7 @@ module Tree0 = struct Sequence.Step.Yield ((key, `Right data), (End, cons tree enum)) | More (key, data, tree, enum), End -> Sequence.Step.Yield ((key, `Left data), (cons tree enum, End)) - | (More (k1, v1, tree1, enum1) as left), (More (k2, v2, tree2, enum2) as right) - -> + | (More (k1, v1, tree1, enum1) as left), (More (k2, v2, tree2, enum2) as right) -> let compare_result = compare_key k1 k2 in if compare_result = 0 then ( @@ -1052,8 +1059,7 @@ module Tree0 = struct match left, right with | End, enum -> fold enum ~init:acc ~f:(fun ~key ~data acc -> add acc key data) | enum, End -> fold enum ~init:acc ~f:(fun ~key ~data acc -> remove acc key data) - | (More (k1, v1, tree1, enum1) as left), (More (k2, v2, tree2, enum2) as right) - -> + | (More (k1, v1, tree1, enum1) as left), (More (k2, v2, tree2, enum2) as right) -> let compare_result = compare_key k1 k2 in if compare_result = 0 then ( @@ -1153,14 +1159,10 @@ module Tree0 = struct slower, as we have to allocate quite a lot of state to track enumeration of a tree. Avoid if we can. *) - let slow x y ~init = - Enum.fold_symmetric_diff x y ~compare_key ~data_equal ~f ~init - in + let slow x y ~init = Enum.fold_symmetric_diff x y ~compare_key ~data_equal ~f ~init in let add acc k v = f acc (k, `Right v) in let remove acc k v = f acc (k, `Left v) in - let delta acc k v v' = - if data_equal v v' then acc else f acc (k, `Unequal (v, v')) - in + let delta acc k v v' = if data_equal v v' then acc else f acc (k, `Unequal (v, v')) in (* If two trees have the same structure at the root (and the same key, if they're [Node]s) we can trivially diff each subpart in obvious ways. *) let rec loop t t' acc = @@ -1263,10 +1265,7 @@ module Tree0 = struct match of_foldable foldable ~compare_key:comparator.Comparator.compare with | `Ok x -> x | `Duplicate_key key -> - Error.create - ("Map.of_" ^ M.name ^ "_exn: duplicate key") - key - comparator.sexp_of_t + Error.create ("Map.of_" ^ M.name ^ "_exn: duplicate key") key comparator.sexp_of_t |> Error.raise ;; end @@ -1368,6 +1367,21 @@ module Tree0 = struct tree, len ;; + let merge_skewed = + let merge_large_first length_large t_large t_small ~call ~combine ~compare_key = + fold t_small ~init:(t_large, length_large) ~f:(fun ~key ~data:data' (t, length) -> + update t key ~length ~compare_key ~f:(function + | None -> data' + | Some data -> call combine ~key data data')) + in + let call f ~key x y = f ~key x y in + let swap f ~key x y = f ~key y x in + fun t1 t2 ~length1 ~length2 ~combine ~compare_key -> + if length2 <= length1 + then merge_large_first length1 t1 t2 ~call ~combine ~compare_key + else merge_large_first length2 t2 t1 ~call:swap ~combine ~compare_key + ;; + module Closest_key_impl = struct (* [marker] and [repackage] allow us to create "logical" options without actually allocating any options. Passing [Found key value] to a function is equivalent to @@ -1391,10 +1405,15 @@ module Tree0 = struct (* The type signature is explicit here to allow polymorphic recursion. *) let rec loop : - 'k 'v 'k_opt 'v_opt. ('k, 'v) tree + 'k 'v 'k_opt 'v_opt. + ('k, 'v) tree -> [ `Greater_or_equal_to | `Greater_than | `Less_or_equal_to | `Less_than ] - -> 'k -> compare_key:('k -> 'k -> int) -> ('k, 'v, 'k_opt, 'v_opt) marker - -> 'k_opt -> 'v_opt -> ('k * 'v) option + -> 'k + -> compare_key:('k -> 'k -> int) + -> ('k, 'v, 'k_opt, 'v_opt) marker + -> 'k_opt + -> 'v_opt + -> ('k * 'v) option = fun t dir k ~compare_key found_marker found_key found_value -> match t with @@ -1416,13 +1435,9 @@ module Tree0 = struct match dir with | `Greater_or_equal_to | `Less_or_equal_to -> Some (k', v') | `Greater_than -> - if is_empty r - then repackage found_marker found_key found_value - else min_elt r + if is_empty r then repackage found_marker found_key found_value else min_elt r | `Less_than -> - if is_empty l - then repackage found_marker found_key found_value - else max_elt l) + if is_empty l then repackage found_marker found_key found_value else max_elt l) else ( (* We are guaranteed here that k' <> k. *) (* This is the only recursive case. *) @@ -1512,9 +1527,7 @@ module Tree0 = struct | `Last_less_than_or_equal_to -> find_last_satisfying t ~f:(fun ~key ~data -> compare ~key ~data v <= 0) | `First_equal_to -> - (match - find_first_satisfying t ~f:(fun ~key ~data -> compare ~key ~data v >= 0) - with + (match find_first_satisfying t ~f:(fun ~key ~data -> compare ~key ~data v >= 0) with | Some (key, data) as pair when compare ~key ~data v = 0 -> pair | None | Some _ -> None) | `Last_equal_to -> @@ -1539,6 +1552,48 @@ module Tree0 = struct | `First_on_right -> find_first_satisfying t ~f:is_right ;; + (* [binary_search_one_sided_bound] finds the key in [t] which satisfies [maybe_bound] + and the relevant one of [if_exclusive] or [if_inclusive], as judged by [compare]. *) + let binary_search_one_sided_bound t maybe_bound ~compare ~if_exclusive ~if_inclusive = + let find_bound t how bound ~compare : _ Maybe_bound.t option = + match binary_search t how bound ~compare with + | Some (bound, _) -> Some (Incl bound) + | None -> None + in + match (maybe_bound : _ Maybe_bound.t) with + | Excl bound -> find_bound t if_exclusive bound ~compare + | Incl bound -> find_bound t if_inclusive bound ~compare + | Unbounded -> Some Unbounded + ;; + + (* [binary_search_two_sided_bounds] finds the (not necessarily distinct) keys in [t] + which most closely approach (but do not cross) [lower_bound] and [upper_bound], as + judged by [compare]. It returns [None] if no keys in [t] are within that range. *) + let binary_search_two_sided_bounds t ~compare ~lower_bound ~upper_bound = + let find_lower_bound t maybe_bound ~compare = + binary_search_one_sided_bound + t + maybe_bound + ~compare + ~if_exclusive:`First_strictly_greater_than + ~if_inclusive:`First_greater_than_or_equal_to + in + let find_upper_bound t maybe_bound ~compare = + binary_search_one_sided_bound + t + maybe_bound + ~compare + ~if_exclusive:`Last_strictly_less_than + ~if_inclusive:`Last_less_than_or_equal_to + in + match find_lower_bound t lower_bound ~compare with + | None -> None + | Some lower_bound -> + (match find_upper_bound t upper_bound ~compare with + | None -> None + | Some upper_bound -> Some (lower_bound, upper_bound)) + ;; + type ('k, 'v) acc = { mutable bad_key : 'k option ; mutable map_length : ('k, 'v) t * int @@ -1557,6 +1612,14 @@ module Tree0 = struct | Some key -> `Duplicate_key key ;; + let of_iteri_exn ~iteri ~(comparator : _ Comparator.t) = + match of_iteri ~iteri ~compare_key:comparator.compare with + | `Ok v -> v + | `Duplicate_key key -> + Error.create "Map.of_iteri_exn: duplicate key" key comparator.sexp_of_t + |> Error.raise + ;; + let t_of_sexp_direct key_of_sexp value_of_sexp sexp ~(comparator : _ Comparator.t) = let alist = list_of_sexp (pair_of_sexp key_of_sexp value_of_sexp) sexp in let compare_key = comparator.compare in @@ -1587,6 +1650,28 @@ module Tree0 = struct then Ok oks else Or_error.error_s (sexp_of_t sexp_of_key Error.sexp_of_t error_tree) ;; + + let map_keys + t1 + ~f + ~comparator:({ compare = compare_key; sexp_of_t = sexp_of_key } : _ Comparator.t) + = + with_return (fun { return } -> + `Ok + (fold t1 ~init:(empty, 0) ~f:(fun ~key ~data (t2, length) -> + let key = f key in + try add_exn_internal t2 ~length ~key ~data ~compare_key ~sexp_of_key with + | Duplicate -> return (`Duplicate_key key)))) + ;; + + let map_keys_exn t ~f ~comparator = + match map_keys t ~f ~comparator with + | `Ok result -> result + | `Duplicate_key key -> + let sexp_of_key = comparator.Comparator.sexp_of_t in + Error.raise_s + (Sexp.message "Map.map_keys_exn: duplicate key" [ "key", key |> sexp_of_key ]) + ;; end type ('k, 'v, 'comparator) t = @@ -1609,6 +1694,12 @@ let like { tree = _; length = _; comparator } (tree, length) = ;; let like2 x (y, z) = like x y, like x z + +let like_maybe_no_op ({ tree = old_tree; length = _; comparator } as old_t) (tree, length) + = + if phys_equal old_tree tree then old_t else { tree; length; comparator } +;; + let with_same_length { tree = _; comparator; length } tree = { tree; comparator; length } let of_tree ~comparator tree = { tree; comparator; length = Tree0.length tree } @@ -1619,7 +1710,11 @@ let of_tree_unsafe ~comparator ~length tree = { tree; comparator; length } module Accessors = struct let comparator t = t.comparator let to_tree t = t.tree - let invariants t = Tree0.invariants t.tree ~compare_key:(compare_key t) + + let invariants t = + Tree0.invariants t.tree ~compare_key:(compare_key t) && Tree0.length t.tree = t.length + ;; + let is_empty t = Tree0.is_empty t.tree let length t = t.length @@ -1688,7 +1783,9 @@ module Accessors = struct let find t key = Tree0.find t.tree key ~compare_key:(compare_key t) let remove t key = - like t (Tree0.remove t.tree key ~length:t.length ~compare_key:(compare_key t)) + like_maybe_no_op + t + (Tree0.remove t.tree key ~length:t.length ~compare_key:(compare_key t)) ;; let mem t key = Tree0.mem t.tree key ~compare_key:(compare_key t) @@ -1700,23 +1797,18 @@ module Accessors = struct let map t ~f = with_same_length t (Tree0.map t.tree ~f) let mapi t ~f = with_same_length t (Tree0.mapi t.tree ~f) let fold t ~init ~f = Tree0.fold t.tree ~f ~init + let fold_until t ~init ~f = Tree0.fold_until t.tree ~f ~init let fold_right t ~init ~f = Tree0.fold_right t.tree ~f ~init let fold2 t1 t2 ~init ~f = Tree0.fold2 t1.tree t2.tree ~init ~f ~compare_key:(compare_key t1) ;; - let filter_keys t ~f = - like t (Tree0.filter_keys t.tree ~f ~compare_key:(compare_key t)) - ;; - + let filter_keys t ~f = like t (Tree0.filter_keys t.tree ~f ~compare_key:(compare_key t)) let filter t ~f = like t (Tree0.filter t.tree ~f ~compare_key:(compare_key t)) let filteri t ~f = like t (Tree0.filteri t.tree ~f ~compare_key:(compare_key t)) let filter_map t ~f = like t (Tree0.filter_map t.tree ~f ~compare_key:(compare_key t)) - - let filter_mapi t ~f = - like t (Tree0.filter_mapi t.tree ~f ~compare_key:(compare_key t)) - ;; + let filter_mapi t ~f = like t (Tree0.filter_mapi t.tree ~f ~compare_key:(compare_key t)) let partition_mapi t ~f = like2 t (Tree0.partition_mapi t.tree ~f ~compare_key:(compare_key t)) @@ -1747,15 +1839,10 @@ module Accessors = struct Tree0.compare (compare_key t1) compare_data t1.tree t2.tree ;; - let equal compare_data t1 t2 = - Tree0.equal (compare_key t1) compare_data t1.tree t2.tree - ;; - + let equal compare_data t1 t2 = Tree0.equal (compare_key t1) compare_data t1.tree t2.tree let keys t = Tree0.keys t.tree let data t = Tree0.data t.tree let to_alist ?key_order t = Tree0.to_alist ?key_order t.tree - let 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 t1 t2 ~data_equal = Tree0.symmetric_diff t1.tree t2.tree ~compare_key:(compare_key t1) ~data_equal @@ -1775,6 +1862,19 @@ module Accessors = struct like t1 (Tree0.merge t1.tree t2.tree ~f ~compare_key:(compare_key t1)) ;; + let merge_skewed t1 t2 ~combine = + (* This is only a no-op in the case where at least one of the maps is empty. *) + like_maybe_no_op + (if t2.length <= t1.length then t1 else t2) + (Tree0.merge_skewed + t1.tree + t2.tree + ~length1:t1.length + ~length2:t2.length + ~combine + ~compare_key:(compare_key t1)) + ;; + let min_elt t = Tree0.min_elt t.tree let min_elt_exn t = Tree0.min_elt_exn t.tree let max_elt t = Tree0.max_elt t.tree @@ -1870,6 +1970,14 @@ module Accessors = struct let hash_fold_direct hash_fold_key hash_fold_data state t = Tree0.hash_fold_t_ignoring_structure hash_fold_key hash_fold_data state t.tree ;; + + let binary_search_subrange t ~compare ~lower_bound ~upper_bound = + match + Tree0.binary_search_two_sided_bounds t.tree ~compare ~lower_bound ~upper_bound + with + | Some (lower_bound, upper_bound) -> subrange t ~lower_bound ~upper_bound + | None -> like_maybe_no_op t (Empty, 0) + ;; end (* [0] is used as the [length] argument everywhere in this module, since trees do not @@ -1883,8 +1991,7 @@ module Tree = struct let singleton ~comparator:_ k v = Tree0.singleton k v let of_sorted_array_unchecked ~comparator array = - fst - (Tree0.of_sorted_array_unchecked array ~compare_key:comparator.Comparator.compare) + fst (Tree0.of_sorted_array_unchecked array ~compare_key:comparator.Comparator.compare) ;; let of_sorted_array ~comparator array = @@ -1922,6 +2029,8 @@ module Tree = struct | `Duplicate_key _ as d -> d ;; + let of_iteri_exn ~comparator ~iteri = fst (Tree0.of_iteri_exn ~iteri ~comparator) + let of_increasing_iterator_unchecked ~comparator:_required_by_intf ~len ~f = Tree0.of_increasing_iterator_unchecked ~len ~f ;; @@ -2014,9 +2123,7 @@ module Tree = struct ~sexp_of_key:comparator.Comparator.sexp_of_t ;; - let find ~comparator t key = - Tree0.find t key ~compare_key:comparator.Comparator.compare - ;; + let find ~comparator t key = Tree0.find t key ~compare_key:comparator.Comparator.compare let remove ~comparator t key = fst (Tree0.remove t key ~length:0 ~compare_key:comparator.Comparator.compare) @@ -2035,6 +2142,7 @@ module Tree = struct let map t ~f = Tree0.map t ~f let mapi t ~f = Tree0.mapi t ~f let fold t ~init ~f = Tree0.fold t ~f ~init + let fold_until t ~init ~f ~finish = Tree0.fold_until t ~f ~init ~finish let fold_right t ~init ~f = Tree0.fold_right t ~f ~init let fold2 ~comparator t1 t2 ~init ~f = @@ -2109,8 +2217,6 @@ module Tree = struct let keys t = Tree0.keys t let data t = Tree0.data t let to_alist ?key_order t = Tree0.to_alist ?key_order t - let 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 ~comparator t1 t2 ~data_equal = Tree0.symmetric_diff t1 t2 ~compare_key:comparator.Comparator.compare ~data_equal @@ -2130,6 +2236,19 @@ module Tree = struct fst (Tree0.merge t1 t2 ~f ~compare_key:comparator.Comparator.compare) ;; + let merge_skewed ~comparator t1 t2 ~combine = + (* Length computation makes this significantly slower than [merge_skewed] on a map + with a [length] field, but does preserve amount of allocation. *) + fst + (Tree0.merge_skewed + t1 + t2 + ~length1:(length t1) + ~length2:(length t2) + ~combine + ~compare_key:comparator.Comparator.compare) + ;; + let min_elt t = Tree0.min_elt t let min_elt_exn t = Tree0.min_elt_exn t let max_elt t = Tree0.max_elt t @@ -2175,13 +2294,9 @@ module Tree = struct Tree0.closest_key t dir key ~compare_key:comparator.Comparator.compare ;; - let nth ~comparator:_ t n = Tree0.nth t n - let nth_exn ~comparator t n = Option.value_exn (nth ~comparator t n) - - let rank ~comparator t key = - Tree0.rank t key ~compare_key:comparator.Comparator.compare - ;; - + let nth t n = Tree0.nth t n + let nth_exn t n = Option.value_exn (nth t n) + let rank ~comparator t key = Tree0.rank t key ~compare_key:comparator.Comparator.compare let sexp_of_t sexp_of_k sexp_of_v _ t = Tree0.sexp_of_t sexp_of_k sexp_of_v t let t_of_sexp_direct ~comparator k_of_sexp v_of_sexp sexp = @@ -2189,12 +2304,7 @@ module Tree = struct ;; let to_sequence ~comparator ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t = - Tree0.to_sequence - comparator - ?order - ?keys_greater_or_equal_to - ?keys_less_or_equal_to - t + Tree0.to_sequence comparator ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t ;; let binary_search ~comparator:_ t ~compare how v = Tree0.binary_search t ~compare how v @@ -2202,6 +2312,35 @@ module Tree = struct let binary_search_segmented ~comparator:_ t ~segment_of how = Tree0.binary_search_segmented t ~segment_of how ;; + + let binary_search_subrange ~comparator t ~compare ~lower_bound ~upper_bound = + match Tree0.binary_search_two_sided_bounds t ~compare ~lower_bound ~upper_bound with + | Some (lower_bound, upper_bound) -> subrange ~comparator t ~lower_bound ~upper_bound + | None -> Empty + ;; + + let map_keys ~comparator t ~f = + match Tree0.map_keys ~comparator t ~f with + | `Ok (t, _) -> `Ok t + | `Duplicate_key _ as dup -> dup + ;; + + let map_keys_exn ~comparator t ~f = fst (Tree0.map_keys_exn ~comparator t ~f) + + module Build_increasing = struct + type ('k, 'v, 'w) t = ('k, 'v) Tree0.Build_increasing.t + + let empty = Tree0.Build_increasing.empty + + let add_exn t ~comparator ~key ~data = + match Tree0.Build_increasing.max_key t with + | Some prev_key when comparator.Comparator.compare prev_key key >= 0 -> + Error.raise_s (Sexp.Atom "Map.Build_increasing.add: non-increasing key") + | _ -> Tree0.Build_increasing.add_unchecked t ~key ~data + ;; + + let to_tree t = Tree0.Build_increasing.to_tree_unchecked t + end end module Using_comparator = struct @@ -2266,6 +2405,10 @@ module Using_comparator = struct | `Duplicate_key _ as z -> z ;; + let of_iteri_exn ~comparator ~iteri = + of_tree0 ~comparator (Tree0.of_iteri_exn ~comparator ~iteri) + ;; + let of_increasing_iterator_unchecked ~comparator ~len ~f = of_tree0 ~comparator (Tree0.of_increasing_iterator_unchecked ~len ~f, len) ;; @@ -2313,6 +2456,16 @@ module Using_comparator = struct of_tree0 ~comparator (Tree0.t_of_sexp_direct k_of_sexp v_of_sexp sexp ~comparator) ;; + let map_keys ~comparator t ~f = + match Tree0.map_keys t.tree ~f ~comparator with + | `Ok pair -> `Ok (of_tree0 ~comparator pair) + | `Duplicate_key _ as dup -> dup + ;; + + let map_keys_exn ~comparator t ~f = + of_tree0 ~comparator (Tree0.map_keys_exn t.tree ~f ~comparator) + ;; + module Empty_without_value_restriction (K : Comparator.S1) = struct let empty = { tree = Tree0.empty; comparator = K.comparator; length = 0 } end @@ -2335,6 +2488,11 @@ let comparator_s (type k cmp) t : (k, cmp) comparator = ;; let to_comparator (type k cmp) ((module M) : (k, cmp) comparator) = M.comparator + +let of_tree (type k cmp) ((module M) : (k, cmp) comparator) tree = + of_tree ~comparator:M.comparator tree +;; + let empty m = Using_comparator.empty ~comparator:(to_comparator m) let singleton m a = Using_comparator.singleton ~comparator:(to_comparator m) a let of_alist m a = Using_comparator.of_alist ~comparator:(to_comparator m) a @@ -2358,12 +2516,13 @@ let of_sorted_array_unchecked m a = Using_comparator.of_sorted_array_unchecked ~comparator:(to_comparator m) a ;; -let of_sorted_array m a = - Using_comparator.of_sorted_array ~comparator:(to_comparator m) a -;; - +let of_sorted_array m a = Using_comparator.of_sorted_array ~comparator:(to_comparator m) a let of_iteri m ~iteri = Using_comparator.of_iteri ~iteri ~comparator:(to_comparator m) +let of_iteri_exn m ~iteri = + Using_comparator.of_iteri_exn ~iteri ~comparator:(to_comparator m) +;; + let of_increasing_iterator_unchecked m ~len ~f = Using_comparator.of_increasing_iterator_unchecked ~len ~f ~comparator:(to_comparator m) ;; @@ -2378,9 +2537,7 @@ let of_sequence_or_error m s = Using_comparator.of_sequence_or_error ~comparator:(to_comparator m) s ;; -let of_sequence_exn m s = - Using_comparator.of_sequence_exn ~comparator:(to_comparator m) s -;; +let of_sequence_exn m s = Using_comparator.of_sequence_exn ~comparator:(to_comparator m) s let of_sequence_multi m s = Using_comparator.of_sequence_multi ~comparator:(to_comparator m) s @@ -2394,6 +2551,9 @@ let of_sequence_reduce m s ~f = Using_comparator.of_sequence_reduce ~comparator:(to_comparator m) s ~f ;; +let map_keys m t ~f = Using_comparator.map_keys ~comparator:(to_comparator m) t ~f +let map_keys_exn m t ~f = Using_comparator.map_keys_exn ~comparator:(to_comparator m) t ~f + module M (K : sig type t type comparator_witness @@ -2405,7 +2565,7 @@ end module type Sexp_of_m = sig type t [@@deriving_inline sexp_of] - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end @@ -2413,13 +2573,21 @@ end module type M_of_sexp = sig type t [@@deriving_inline of_sexp] - val t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t + val t_of_sexp : Sexplib0.Sexp.t -> t [@@@end] include Comparator.S with type t := t end +module type M_sexp_grammar = sig + type t [@@deriving_inline sexp_grammar] + + val t_sexp_grammar : t Sexplib0.Sexp_grammar.t + + [@@@end] +end + module type Compare_m = sig end module type Equal_m = sig end module type Hash_fold_m = Hasher.S @@ -2437,37 +2605,25 @@ let m__t_of_sexp Using_comparator.t_of_sexp_direct ~comparator:K.comparator K.t_of_sexp v_of_sexp sexp ;; -let m__t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t = - Inline - (Explicit_bind - ( [ "'k"; "'v" ] - , Apply - ( Grammar list_sexp_grammar - , [ Apply - ( Grammar Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.tuple2_sexp_grammar - , [ Explicit_var 0; Explicit_var 1 ] ) - ] ) )) +let m__t_sexp_grammar + (type k) + (module K : M_sexp_grammar with type t = k) + (v_grammar : _ Sexplib0.Sexp_grammar.t) + : _ Sexplib0.Sexp_grammar.t + = + { untyped = + List + (Many (List (Cons (K.t_sexp_grammar.untyped, Cons (v_grammar.untyped, Empty))))) + } ;; -let compare_m__t (module K : Compare_m) compare_v t1 t2 = compare_direct compare_v t1 t2 -let equal_m__t (module K : Equal_m) equal_v t1 t2 = equal equal_v t1 t2 +let compare_m__t (module _ : Compare_m) compare_v t1 t2 = compare_direct compare_v t1 t2 +let equal_m__t (module _ : Equal_m) equal_v t1 t2 = equal equal_v t1 t2 let hash_fold_m__t (type k) (module K : Hash_fold_m with type t = k) hash_fold_v state = hash_fold_direct K.hash_fold_t hash_fold_v state ;; -let merge_skewed t1 t2 ~combine = - let t1, t2, combine = - if length t2 <= length t1 - then t1, t2, combine - else t2, t1, fun ~key v1 v2 -> combine ~key v2 v1 - in - fold t2 ~init:t1 ~f:(fun ~key ~data:v2 t1 -> - change t1 key ~f:(function - | None -> Some v2 - | Some v1 -> Some (combine ~key v1 v2))) -;; - module Poly = struct type nonrec ('k, 'v) t = ('k, 'v, Comparator.Poly.comparator_witness) t type nonrec ('k, 'v) tree = ('k, 'v) Tree0.t @@ -2494,15 +2650,13 @@ module Poly = struct let of_sorted_array a = Using_comparator.of_sorted_array ~comparator a let of_iteri ~iteri = Using_comparator.of_iteri ~iteri ~comparator + let of_iteri_exn ~iteri = Using_comparator.of_iteri_exn ~iteri ~comparator let of_increasing_iterator_unchecked ~len ~f = Using_comparator.of_increasing_iterator_unchecked ~len ~f ~comparator ;; - let of_increasing_sequence seq = - Using_comparator.of_increasing_sequence ~comparator seq - ;; - + let of_increasing_sequence seq = Using_comparator.of_increasing_sequence ~comparator seq let of_sequence s = Using_comparator.of_sequence ~comparator s let of_sequence_or_error s = Using_comparator.of_sequence_or_error ~comparator s let of_sequence_exn s = Using_comparator.of_sequence_exn ~comparator s @@ -2513,4 +2667,6 @@ module Poly = struct ;; let of_sequence_reduce s ~f = Using_comparator.of_sequence_reduce ~comparator s ~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 end diff --git a/src/map_intf.ml b/src/map_intf.ml index 1785afa..4b9b34e 100644 --- a/src/map_intf.ml +++ b/src/map_intf.ml @@ -6,14 +6,34 @@ module Or_duplicate = struct [ `Ok of 'a | `Duplicate ] - [@@deriving_inline sexp_of] + [@@deriving_inline compare, equal, sexp_of] + + let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = + fun _cmp__a a__001_ b__002_ -> + if Ppx_compare_lib.phys_equal a__001_ b__002_ + then 0 + else ( + match a__001_, b__002_ with + | `Ok _left__003_, `Ok _right__004_ -> _cmp__a _left__003_ _right__004_ + | `Duplicate, `Duplicate -> 0 + | x, y -> Ppx_compare_lib.polymorphic_compare x y) + ;; - let sexp_of_t : - 'a. ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t - = - fun _of_a -> function - | `Ok v0 -> Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Ok"; _of_a v0 ] - | `Duplicate -> Ppx_sexp_conv_lib.Sexp.Atom "Duplicate" + let equal : 'a. ('a -> 'a -> bool) -> 'a t -> 'a t -> bool = + fun _cmp__a a__005_ b__006_ -> + if Ppx_compare_lib.phys_equal a__005_ b__006_ + then true + else ( + match a__005_, b__006_ with + | `Ok _left__007_, `Ok _right__008_ -> _cmp__a _left__007_ _right__008_ + | `Duplicate, `Duplicate -> true + | x, y -> Ppx_compare_lib.polymorphic_equal x y) + ;; + + let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = + fun _of_a__009_ -> function + | `Ok v__010_ -> Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Ok"; _of_a__009_ v__010_ ] + | `Duplicate -> Sexplib0.Sexp.Atom "Duplicate" ;; [@@@end] @@ -28,133 +48,303 @@ module With_comparator = struct end module With_first_class_module = struct - type ('key, 'cmp, 'z) t = - (module Comparator.S with type t = 'key and type comparator_witness = 'cmp) -> 'z + type ('key, 'cmp, 'z) t = ('key, 'cmp) Comparator.Module.t -> 'z end module Symmetric_diff_element = struct type ('k, 'v) t = 'k * [ `Left of 'v | `Right of 'v | `Unequal of 'v * 'v ] - [@@deriving_inline compare, sexp] + [@@deriving_inline compare, equal, sexp, sexp_grammar] let compare : 'k 'v. ('k -> 'k -> int) -> ('v -> 'v -> int) -> ('k, 'v) t -> ('k, 'v) t -> int = - fun _cmp__k _cmp__v a__001_ b__002_ -> - let t__003_, t__004_ = a__001_ in - let t__005_, t__006_ = b__002_ in - match _cmp__k t__003_ t__005_ with + fun _cmp__k _cmp__v a__011_ b__012_ -> + let t__013_, t__014_ = a__011_ in + let t__015_, t__016_ = b__012_ in + match _cmp__k t__013_ t__015_ with | 0 -> - if Ppx_compare_lib.phys_equal t__004_ t__006_ + if Ppx_compare_lib.phys_equal t__014_ t__016_ then 0 else ( - match t__004_, t__006_ with - | `Left _left__007_, `Left _right__008_ -> _cmp__v _left__007_ _right__008_ - | `Right _left__009_, `Right _right__010_ -> _cmp__v _left__009_ _right__010_ - | `Unequal _left__011_, `Unequal _right__012_ -> - let t__013_, t__014_ = _left__011_ in - let t__015_, t__016_ = _right__012_ in - (match _cmp__v t__013_ t__015_ with - | 0 -> _cmp__v t__014_ t__016_ + match t__014_, t__016_ with + | `Left _left__017_, `Left _right__018_ -> _cmp__v _left__017_ _right__018_ + | `Right _left__019_, `Right _right__020_ -> _cmp__v _left__019_ _right__020_ + | `Unequal _left__021_, `Unequal _right__022_ -> + let t__023_, t__024_ = _left__021_ in + let t__025_, t__026_ = _right__022_ in + (match _cmp__v t__023_ t__025_ with + | 0 -> _cmp__v t__024_ t__026_ | n -> n) | x, y -> Ppx_compare_lib.polymorphic_compare x y) | n -> n ;; + let equal : + 'k 'v. + ('k -> 'k -> bool) -> ('v -> 'v -> bool) -> ('k, 'v) t -> ('k, 'v) t -> bool + = + fun _cmp__k _cmp__v a__027_ b__028_ -> + let t__029_, t__030_ = a__027_ in + let t__031_, t__032_ = b__028_ in + Ppx_compare_lib.( && ) + (_cmp__k t__029_ t__031_) + (if Ppx_compare_lib.phys_equal t__030_ t__032_ + then true + else ( + match t__030_, t__032_ with + | `Left _left__033_, `Left _right__034_ -> _cmp__v _left__033_ _right__034_ + | `Right _left__035_, `Right _right__036_ -> _cmp__v _left__035_ _right__036_ + | `Unequal _left__037_, `Unequal _right__038_ -> + let t__039_, t__040_ = _left__037_ in + let t__041_, t__042_ = _right__038_ in + Ppx_compare_lib.( && ) (_cmp__v t__039_ t__041_) (_cmp__v t__040_ t__042_) + | x, y -> Ppx_compare_lib.polymorphic_equal x y)) + ;; + let t_of_sexp : - 'k 'v. (Ppx_sexp_conv_lib.Sexp.t -> 'k) -> (Ppx_sexp_conv_lib.Sexp.t -> 'v) - -> Ppx_sexp_conv_lib.Sexp.t -> ('k, 'v) t + 'k 'v. + (Sexplib0.Sexp.t -> 'k) + -> (Sexplib0.Sexp.t -> 'v) + -> Sexplib0.Sexp.t + -> ('k, 'v) t = - let _tp_loc = "map_intf.ml.Symmetric_diff_element.t" in - fun _of_k _of_v -> function - | Ppx_sexp_conv_lib.Sexp.List [ v0; v1 ] -> - let v0 = _of_k v0 - and v1 = - (fun sexp -> - try - match sexp with - | Ppx_sexp_conv_lib.Sexp.Atom atom as _sexp -> - (match atom with - | "Left" -> Ppx_sexp_conv_lib.Conv_error.ptag_takes_args _tp_loc _sexp - | "Right" -> Ppx_sexp_conv_lib.Conv_error.ptag_takes_args _tp_loc _sexp - | "Unequal" -> Ppx_sexp_conv_lib.Conv_error.ptag_takes_args _tp_loc _sexp - | _ -> Ppx_sexp_conv_lib.Conv_error.no_variant_match ()) - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom atom :: sexp_args) as _sexp -> - (match atom with - | "Left" as _tag -> - (match sexp_args with - | [ v0 ] -> - let v0 = _of_v v0 in - `Left v0 - | _ -> - Ppx_sexp_conv_lib.Conv_error.ptag_incorrect_n_args _tp_loc _tag _sexp) - | "Right" as _tag -> - (match sexp_args with - | [ v0 ] -> - let v0 = _of_v v0 in - `Right v0 - | _ -> - Ppx_sexp_conv_lib.Conv_error.ptag_incorrect_n_args _tp_loc _tag _sexp) - | "Unequal" as _tag -> - (match sexp_args with - | [ v0 ] -> - let v0 = - match v0 with - | Ppx_sexp_conv_lib.Sexp.List [ v0; v1 ] -> - let v0 = _of_v v0 - and v1 = _of_v v1 in - v0, v1 - | sexp -> - Ppx_sexp_conv_lib.Conv_error.tuple_of_size_n_expected - _tp_loc - 2 - sexp - in - `Unequal v0 - | _ -> - Ppx_sexp_conv_lib.Conv_error.ptag_incorrect_n_args _tp_loc _tag _sexp) - | _ -> Ppx_sexp_conv_lib.Conv_error.no_variant_match ()) - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.List _ :: _) as sexp - -> Ppx_sexp_conv_lib.Conv_error.nested_list_invalid_poly_var _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List [] as sexp -> - Ppx_sexp_conv_lib.Conv_error.empty_list_invalid_poly_var _tp_loc sexp - with - | Ppx_sexp_conv_lib.Conv_error.No_variant_match -> - Ppx_sexp_conv_lib.Conv_error.no_matching_variant_found _tp_loc sexp) - v1 + let error_source__057_ = "map_intf.ml.Symmetric_diff_element.t" in + fun _of_k__043_ _of_v__044_ -> function + | Sexplib0.Sexp.List [ arg0__067_; arg1__068_ ] -> + let res0__069_ = _of_k__043_ arg0__067_ + and res1__070_ = + let sexp__066_ = arg1__068_ in + try + match sexp__066_ with + | Sexplib0.Sexp.Atom atom__047_ as _sexp__049_ -> + (match atom__047_ with + | "Left" -> + Sexplib0.Sexp_conv_error.ptag_takes_args error_source__057_ _sexp__049_ + | "Right" -> + Sexplib0.Sexp_conv_error.ptag_takes_args error_source__057_ _sexp__049_ + | "Unequal" -> + Sexplib0.Sexp_conv_error.ptag_takes_args error_source__057_ _sexp__049_ + | _ -> Sexplib0.Sexp_conv_error.no_variant_match ()) + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom atom__047_ :: sexp_args__050_) as + _sexp__049_ -> + (match atom__047_ with + | "Left" as _tag__063_ -> + (match sexp_args__050_ with + | [ arg0__064_ ] -> + let res0__065_ = _of_v__044_ arg0__064_ in + `Left res0__065_ + | _ -> + Sexplib0.Sexp_conv_error.ptag_incorrect_n_args + error_source__057_ + _tag__063_ + _sexp__049_) + | "Right" as _tag__060_ -> + (match sexp_args__050_ with + | [ arg0__061_ ] -> + let res0__062_ = _of_v__044_ arg0__061_ in + `Right res0__062_ + | _ -> + Sexplib0.Sexp_conv_error.ptag_incorrect_n_args + error_source__057_ + _tag__060_ + _sexp__049_) + | "Unequal" as _tag__051_ -> + (match sexp_args__050_ with + | [ arg0__058_ ] -> + let res0__059_ = + match arg0__058_ with + | Sexplib0.Sexp.List [ arg0__052_; arg1__053_ ] -> + let res0__054_ = _of_v__044_ arg0__052_ + and res1__055_ = _of_v__044_ arg1__053_ in + res0__054_, res1__055_ + | sexp__056_ -> + Sexplib0.Sexp_conv_error.tuple_of_size_n_expected + error_source__057_ + 2 + sexp__056_ + in + `Unequal res0__059_ + | _ -> + Sexplib0.Sexp_conv_error.ptag_incorrect_n_args + error_source__057_ + _tag__051_ + _sexp__049_) + | _ -> Sexplib0.Sexp_conv_error.no_variant_match ()) + | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__048_ -> + Sexplib0.Sexp_conv_error.nested_list_invalid_poly_var + error_source__057_ + sexp__048_ + | Sexplib0.Sexp.List [] as sexp__048_ -> + Sexplib0.Sexp_conv_error.empty_list_invalid_poly_var + error_source__057_ + sexp__048_ + with + | Sexplib0.Sexp_conv_error.No_variant_match -> + Sexplib0.Sexp_conv_error.no_matching_variant_found + error_source__057_ + sexp__066_ in - v0, v1 - | sexp -> Ppx_sexp_conv_lib.Conv_error.tuple_of_size_n_expected _tp_loc 2 sexp + res0__069_, res1__070_ + | sexp__071_ -> + Sexplib0.Sexp_conv_error.tuple_of_size_n_expected error_source__057_ 2 sexp__071_ ;; let sexp_of_t : - 'k 'v. ('k -> Ppx_sexp_conv_lib.Sexp.t) -> ('v -> Ppx_sexp_conv_lib.Sexp.t) - -> ('k, 'v) t -> Ppx_sexp_conv_lib.Sexp.t + 'k 'v. + ('k -> Sexplib0.Sexp.t) + -> ('v -> Sexplib0.Sexp.t) + -> ('k, 'v) t + -> Sexplib0.Sexp.t = - fun _of_k _of_v -> function - | v0, v1 -> - let v0 = _of_k v0 - and v1 = - match v1 with - | `Left v0 -> - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Left"; _of_v v0 ] - | `Right v0 -> - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Right"; _of_v v0 ] - | `Unequal v0 -> - Ppx_sexp_conv_lib.Sexp.List - [ Ppx_sexp_conv_lib.Sexp.Atom "Unequal" - ; (let v0, v1 = v0 in - let v0 = _of_v v0 - and v1 = _of_v v1 in - Ppx_sexp_conv_lib.Sexp.List [ v0; v1 ]) - ] - in - Ppx_sexp_conv_lib.Sexp.List [ v0; v1 ] + fun _of_k__072_ _of_v__073_ (arg0__081_, arg1__082_) -> + let res0__083_ = _of_k__072_ arg0__081_ + and res1__084_ = + match arg1__082_ with + | `Left v__074_ -> + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Left"; _of_v__073_ v__074_ ] + | `Right v__075_ -> + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Right"; _of_v__073_ v__075_ ] + | `Unequal v__076_ -> + Sexplib0.Sexp.List + [ Sexplib0.Sexp.Atom "Unequal" + ; (let arg0__077_, arg1__078_ = v__076_ in + let res0__079_ = _of_v__073_ arg0__077_ + and res1__080_ = _of_v__073_ arg1__078_ in + Sexplib0.Sexp.List [ res0__079_; res1__080_ ]) + ] + in + Sexplib0.Sexp.List [ res0__083_; res1__084_ ] + ;; + + let (t_sexp_grammar : + 'k Sexplib0.Sexp_grammar.t + -> 'v Sexplib0.Sexp_grammar.t + -> ('k, 'v) t Sexplib0.Sexp_grammar.t) + = + fun _'k_sexp_grammar _'v_sexp_grammar -> + { untyped = + List + (Cons + ( _'k_sexp_grammar.untyped + , Cons + ( Variant + { case_sensitivity = Case_sensitive + ; clauses = + [ No_tag + { name = "Left" + ; clause_kind = + List_clause + { args = Cons (_'v_sexp_grammar.untyped, Empty) } + } + ; No_tag + { name = "Right" + ; clause_kind = + List_clause + { args = Cons (_'v_sexp_grammar.untyped, Empty) } + } + ; No_tag + { name = "Unequal" + ; clause_kind = + List_clause + { args = + Cons + ( List + (Cons + ( _'v_sexp_grammar.untyped + , Cons (_'v_sexp_grammar.untyped, Empty) + )) + , Empty ) + } + } + ] + } + , Empty ) )) + } + ;; + + [@@@end] +end + +module Merge_element = struct + type ('left, 'right) t = + [ `Left of 'left + | `Right of 'right + | `Both of 'left * 'right + ] + [@@deriving_inline compare, equal, sexp_of] + + let compare : + 'left 'right. + ('left -> 'left -> int) + -> ('right -> 'right -> int) + -> ('left, 'right) t + -> ('left, 'right) t + -> int + = + fun _cmp__left _cmp__right a__085_ b__086_ -> + if Ppx_compare_lib.phys_equal a__085_ b__086_ + then 0 + else ( + match a__085_, b__086_ with + | `Left _left__087_, `Left _right__088_ -> _cmp__left _left__087_ _right__088_ + | `Right _left__089_, `Right _right__090_ -> _cmp__right _left__089_ _right__090_ + | `Both _left__091_, `Both _right__092_ -> + let t__093_, t__094_ = _left__091_ in + let t__095_, t__096_ = _right__092_ in + (match _cmp__left t__093_ t__095_ with + | 0 -> _cmp__right t__094_ t__096_ + | n -> n) + | x, y -> Ppx_compare_lib.polymorphic_compare x y) + ;; + + let equal : + 'left 'right. + ('left -> 'left -> bool) + -> ('right -> 'right -> bool) + -> ('left, 'right) t + -> ('left, 'right) t + -> bool + = + fun _cmp__left _cmp__right a__097_ b__098_ -> + if Ppx_compare_lib.phys_equal a__097_ b__098_ + then true + else ( + match a__097_, b__098_ with + | `Left _left__099_, `Left _right__100_ -> _cmp__left _left__099_ _right__100_ + | `Right _left__101_, `Right _right__102_ -> _cmp__right _left__101_ _right__102_ + | `Both _left__103_, `Both _right__104_ -> + let t__105_, t__106_ = _left__103_ in + let t__107_, t__108_ = _right__104_ in + Ppx_compare_lib.( && ) (_cmp__left t__105_ t__107_) (_cmp__right t__106_ t__108_) + | x, y -> Ppx_compare_lib.polymorphic_equal x y) + ;; + + let sexp_of_t : + 'left 'right. + ('left -> Sexplib0.Sexp.t) + -> ('right -> Sexplib0.Sexp.t) + -> ('left, 'right) t + -> Sexplib0.Sexp.t + = + fun _of_left__109_ _of_right__110_ -> function + | `Left v__111_ -> + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Left"; _of_left__109_ v__111_ ] + | `Right v__112_ -> + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Right"; _of_right__110_ v__112_ ] + | `Both v__113_ -> + Sexplib0.Sexp.List + [ Sexplib0.Sexp.Atom "Both" + ; (let arg0__114_, arg1__115_ = v__113_ in + let res0__116_ = _of_left__109_ arg0__114_ + and res1__117_ = _of_right__110_ arg1__115_ in + Sexplib0.Sexp.List [ res0__116_; res1__117_ ]) + ] ;; [@@@end] end +(** @canonical Base.Map.Continue_or_stop *) module Continue_or_stop = struct type t = | Continue @@ -167,14 +357,15 @@ module Continue_or_stop = struct let sexp_of_t = (function - | Continue -> Ppx_sexp_conv_lib.Sexp.Atom "Continue" - | Stop -> Ppx_sexp_conv_lib.Sexp.Atom "Stop" - : t -> Ppx_sexp_conv_lib.Sexp.t) + | Continue -> Sexplib0.Sexp.Atom "Continue" + | Stop -> Sexplib0.Sexp.Atom "Stop" + : t -> Sexplib0.Sexp.t) ;; [@@@end] end +(** @canonical Base.Map.Finished_or_unfinished *) module Finished_or_unfinished = struct type t = | Finished @@ -187,9 +378,9 @@ module Finished_or_unfinished = struct let sexp_of_t = (function - | Finished -> Ppx_sexp_conv_lib.Sexp.Atom "Finished" - | Unfinished -> Ppx_sexp_conv_lib.Sexp.Atom "Unfinished" - : t -> Ppx_sexp_conv_lib.Sexp.t) + | Finished -> Sexplib0.Sexp.Atom "Finished" + | Unfinished -> Sexplib0.Sexp.Atom "Unfinished" + : t -> Sexplib0.Sexp.t) ;; [@@@end] @@ -259,9 +450,7 @@ module type Accessors_generic = sig , 'cmp , ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t - -> f:(key:'k key - -> data:[ `Left of 'v1 | `Right of 'v2 | `Both of 'v1 * 'v2 ] - -> unit) + -> f:(key:'k key -> data:('v1, 'v2) Merge_element.t -> unit) -> unit ) options @@ -269,11 +458,14 @@ module type Accessors_generic = sig val mapi : ('k, 'v1, 'cmp) t -> f:(key:'k key -> data:'v1 -> 'v2) -> ('k, 'v2, 'cmp) t val fold : ('k, 'v, _) t -> init:'a -> f:(key:'k key -> data:'v -> 'a -> 'a) -> 'a - val fold_right + val fold_until : ('k, 'v, _) t -> init:'a - -> f:(key:'k key -> data:'v -> 'a -> 'a) - -> 'a + -> f:(key:'k key -> data:'v -> 'a -> ('a, 'final) Container.Continue_or_stop.t) + -> finish:('a -> 'final) + -> 'final + + val fold_right : ('k, 'v, _) t -> init:'a -> f:(key:'k key -> data:'v -> 'a -> 'a) -> 'a val fold2 : ( 'k @@ -281,10 +473,7 @@ module type Accessors_generic = sig , ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t -> init:'a - -> f:(key:'k key - -> data:[ `Left of 'v1 | `Right of 'v2 | `Both of 'v1 * 'v2 ] - -> 'a - -> 'a) + -> f:(key:'k key -> data:('v1, 'v2) Merge_element.t -> 'a -> 'a) -> 'a ) options @@ -305,9 +494,8 @@ module type Accessors_generic = sig val filter_mapi : ( 'k , 'cmp - , ('k, 'v1, 'cmp) t - -> f:(key:'k key -> data:'v1 -> 'v2 option) - -> ('k, 'v2, 'cmp) t ) + , ('k, 'v1, 'cmp) t -> f:(key:'k key -> data:'v1 -> 'v2 option) -> ('k, 'v2, 'cmp) t + ) options val partition_mapi @@ -344,10 +532,7 @@ module type Accessors_generic = sig : ('k, 'cmp, ('k, 'v Or_error.t, 'cmp) t -> ('k, 'v, 'cmp) t Or_error.t) options val compare_direct - : ( 'k - , 'cmp - , ('v -> 'v -> int) -> ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> int ) - options + : ('k, 'cmp, ('v -> 'v -> int) -> ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> int) options val equal : ( 'k @@ -363,27 +548,24 @@ module type Accessors_generic = sig -> ('k, 'v, _) t -> ('k key * 'v) list - 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 merge : ( 'k , 'cmp , ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t - -> f:(key:'k key - -> [ `Left of 'v1 | `Right of 'v2 | `Both of 'v1 * 'v2 ] - -> 'v3 option) + -> f:(key:'k key -> ('v1, 'v2) Merge_element.t -> 'v3 option) -> ('k, 'v3, 'cmp) t ) options + val merge_skewed + : ( 'k + , 'cmp + , ('k, 'v, 'cmp) t + -> ('k, 'v, 'cmp) t + -> combine:(key:'k key -> 'v -> 'v -> 'v) + -> ('k, 'v, 'cmp) t ) + options + val symmetric_diff : ( 'k , 'cmp @@ -466,8 +648,8 @@ module type Accessors_generic = sig -> ('k key * 'v) option ) options - val nth : ('k, 'cmp, ('k, 'v, 'cmp) t -> int -> ('k key * 'v) option) options - val nth_exn : ('k, 'cmp, ('k, 'v, 'cmp) t -> int -> 'k key * 'v) options + val nth : ('k, 'v, 'cmp) t -> int -> ('k key * 'v) option + val nth_exn : ('k, 'v, 'cmp) t -> int -> 'k key * 'v val rank : ('k, 'cmp, ('k, _, 'cmp) t -> 'k key -> int option) options val to_tree : ('k, 'v, 'cmp) t -> ('k key, 'v, 'cmp) tree @@ -486,13 +668,7 @@ module type Accessors_generic = sig , 'cmp , ('k, 'v, 'cmp) t -> compare:(key:'k key -> data:'v -> 'key -> int) - -> [ `Last_strictly_less_than - | `Last_less_than_or_equal_to - | `Last_equal_to - | `First_equal_to - | `First_greater_than_or_equal_to - | `First_strictly_greater_than - ] + -> Binary_searchable.Which_target_by_key.t -> 'key -> ('k key * 'v) option ) options @@ -502,9 +678,19 @@ module type Accessors_generic = sig , 'cmp , ('k, 'v, 'cmp) t -> segment_of:(key:'k key -> data:'v -> [ `Left | `Right ]) - -> [ `Last_on_left | `First_on_right ] + -> Binary_searchable.Which_target_by_segment.t -> ('k key * 'v) option ) options + + val binary_search_subrange + : ( 'k + , 'cmp + , ('k, 'v, 'cmp) t + -> compare:(key:'k key -> data:'v -> 'bound -> int) + -> lower_bound:'bound Maybe_bound.t + -> upper_bound:'bound Maybe_bound.t + -> ('k, 'v, 'cmp) t ) + options end module type Accessors1 = sig @@ -537,22 +723,25 @@ module type Accessors1 = sig -> f:(key:key -> data:'a -> Continue_or_stop.t) -> Finished_or_unfinished.t - val iter2 - : 'a t - -> 'b t - -> f:(key:key -> data:[ `Left of 'a | `Right of 'b | `Both of 'a * 'b ] -> unit) - -> unit - + val iter2 : 'a t -> 'b t -> f:(key:key -> data:('a, 'b) Merge_element.t -> unit) -> unit val map : 'a t -> f:('a -> 'b) -> 'b t val mapi : 'a t -> f:(key:key -> data:'a -> 'b) -> 'b t val fold : 'a t -> init:'b -> f:(key:key -> data:'a -> 'b -> 'b) -> 'b + + val fold_until + : 'a t + -> init:'acc + -> f:(key:key -> data:'a -> 'acc -> ('acc, 'final) Container.Continue_or_stop.t) + -> finish:('acc -> 'final) + -> 'final + val fold_right : 'a t -> init:'b -> f:(key:key -> data:'a -> 'b -> 'b) -> 'b val fold2 : 'a t -> 'b t -> init:'c - -> f:(key:key -> data:[ `Left of 'a | `Right of 'b | `Both of 'a * 'b ] -> 'c -> 'c) + -> f:(key:key -> data:('a, 'b) Merge_element.t -> 'c -> 'c) -> 'c val filter_keys : 'a t -> f:(key -> bool) -> 'a t @@ -570,18 +759,8 @@ module type Accessors1 = sig val keys : _ t -> key list val data : 'a t -> 'a list val to_alist : ?key_order:[ `Increasing | `Decreasing ] -> 'a t -> (key * 'a) list - 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 merge - : 'a t - -> 'b t - -> f:(key:key -> [ `Left of 'a | `Right of 'b | `Both of 'a * 'b ] -> 'c option) - -> 'c t + val merge : 'a t -> 'b t -> f:(key:key -> ('a, 'b) Merge_element.t -> 'c option) -> 'c t + val merge_skewed : 'v t -> 'v t -> combine:(key:key -> 'v -> 'v -> 'v) -> 'v t val symmetric_diff : 'a t @@ -651,21 +830,22 @@ module type Accessors1 = sig val binary_search : 'a t -> compare:(key:key -> data:'a -> 'key -> int) - -> [ `Last_strictly_less_than - | `Last_less_than_or_equal_to - | `Last_equal_to - | `First_equal_to - | `First_greater_than_or_equal_to - | `First_strictly_greater_than - ] + -> Binary_searchable.Which_target_by_key.t -> 'key -> (key * 'a) option val binary_search_segmented : 'a t -> segment_of:(key:key -> data:'a -> [ `Left | `Right ]) - -> [ `Last_on_left | `First_on_right ] + -> Binary_searchable.Which_target_by_segment.t -> (key * 'a) option + + val binary_search_subrange + : 'a t + -> compare:(key:key -> data:'a -> 'bound -> int) + -> lower_bound:'bound Maybe_bound.t + -> upper_bound:'bound Maybe_bound.t + -> 'a t end module type Accessors2 = sig @@ -700,19 +880,27 @@ module type Accessors2 = sig val iter2 : ('a, 'b) t -> ('a, 'c) t - -> f:(key:'a -> data:[ `Left of 'b | `Right of 'c | `Both of 'b * 'c ] -> unit) + -> f:(key:'a -> data:('b, 'c) Merge_element.t -> unit) -> unit val map : ('a, 'b) t -> f:('b -> 'c) -> ('a, 'c) t val mapi : ('a, 'b) t -> f:(key:'a -> data:'b -> 'c) -> ('a, 'c) t val fold : ('a, 'b) t -> init:'c -> f:(key:'a -> data:'b -> 'c -> 'c) -> 'c + + val fold_until + : ('k, 'v) t + -> init:'a + -> f:(key:'k -> data:'v -> 'a -> ('a, 'final) Container.Continue_or_stop.t) + -> finish:('a -> 'final) + -> 'final + val fold_right : ('a, 'b) t -> init:'c -> f:(key:'a -> data:'b -> 'c -> 'c) -> 'c val fold2 : ('a, 'b) t -> ('a, 'c) t -> init:'d - -> f:(key:'a -> data:[ `Left of 'b | `Right of 'c | `Both of 'b * 'c ] -> 'd -> 'd) + -> f:(key:'a -> data:('b, 'c) Merge_element.t -> 'd -> 'd) -> 'd val filter_keys : ('a, 'b) t -> f:('a -> bool) -> ('a, 'b) t @@ -726,10 +914,7 @@ module type Accessors2 = sig -> f:(key:'a -> data:'b -> ('c, 'd) Either.t) -> ('a, 'c) t * ('a, 'd) t - val partition_map - : ('a, 'b) t - -> f:('b -> ('c, 'd) Either.t) - -> ('a, 'c) t * ('a, 'd) t + val partition_map : ('a, 'b) t -> f:('b -> ('c, 'd) Either.t) -> ('a, 'c) t * ('a, 'd) t val partitioni_tf : ('a, 'b) t @@ -743,19 +928,19 @@ module type Accessors2 = sig val keys : ('a, _) t -> 'a list val data : (_, 'b) t -> 'b list val to_alist : ?key_order:[ `Increasing | `Decreasing ] -> ('a, 'b) t -> ('a * 'b) list - 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 merge : ('a, 'b) t -> ('a, 'c) t - -> f:(key:'a -> [ `Left of 'b | `Right of 'c | `Both of 'b * 'c ] -> 'd option) + -> f:(key:'a -> ('b, 'c) Merge_element.t -> 'd option) -> ('a, 'd) t + val merge_skewed + : ('k, 'v) t + -> ('k, 'v) t + -> combine:(key:'k -> 'v -> 'v -> 'v) + -> ('k, 'v) t + val symmetric_diff : ('a, 'b) t -> ('a, 'b) t @@ -824,21 +1009,22 @@ module type Accessors2 = sig val binary_search : ('k, 'v) t -> compare:(key:'k -> data:'v -> 'key -> int) - -> [ `Last_strictly_less_than - | `Last_less_than_or_equal_to - | `Last_equal_to - | `First_equal_to - | `First_greater_than_or_equal_to - | `First_strictly_greater_than - ] + -> Binary_searchable.Which_target_by_key.t -> 'key -> ('k * 'v) option val binary_search_segmented : ('k, 'v) t -> segment_of:(key:'k -> data:'v -> [ `Left | `Right ]) - -> [ `Last_on_left | `First_on_right ] + -> Binary_searchable.Which_target_by_segment.t -> ('k * 'v) option + + val binary_search_subrange + : ('k, 'v) t + -> compare:(key:'k -> data:'v -> 'bound -> int) + -> lower_bound:'bound Maybe_bound.t + -> upper_bound:'bound Maybe_bound.t + -> ('k, 'v) t end module type Accessors3 = sig @@ -872,19 +1058,27 @@ module type Accessors3 = sig val iter2 : ('a, 'b, 'cmp) t -> ('a, 'c, 'cmp) t - -> f:(key:'a -> data:[ `Left of 'b | `Right of 'c | `Both of 'b * 'c ] -> unit) + -> f:(key:'a -> data:('b, 'c) Merge_element.t -> unit) -> unit val map : ('a, 'b, 'cmp) t -> f:('b -> 'c) -> ('a, 'c, 'cmp) t val mapi : ('a, 'b, 'cmp) t -> f:(key:'a -> data:'b -> 'c) -> ('a, 'c, 'cmp) t val fold : ('a, 'b, _) t -> init:'c -> f:(key:'a -> data:'b -> 'c -> 'c) -> 'c + + val fold_until + : ('k, 'v, _) t + -> init:'a + -> f:(key:'k -> data:'v -> 'a -> ('a, 'final) Container.Continue_or_stop.t) + -> finish:('a -> 'final) + -> 'final + val fold_right : ('a, 'b, _) t -> init:'c -> f:(key:'a -> data:'b -> 'c -> 'c) -> 'c val fold2 : ('a, 'b, 'cmp) t -> ('a, 'c, 'cmp) t -> init:'d - -> f:(key:'a -> data:[ `Left of 'b | `Right of 'c | `Both of 'b * 'c ] -> 'd -> 'd) + -> f:(key:'a -> data:('b, 'c) Merge_element.t -> 'd -> 'd) -> 'd val filter_keys : ('a, 'b, 'cmp) t -> f:('a -> bool) -> ('a, 'b, 'cmp) t @@ -928,19 +1122,18 @@ module type Accessors3 = sig -> ('a, 'b, _) t -> ('a * 'b) list - 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 merge : ('a, 'b, 'cmp) t -> ('a, 'c, 'cmp) t - -> f:(key:'a -> [ `Left of 'b | `Right of 'c | `Both of 'b * 'c ] -> 'd option) + -> f:(key:'a -> ('b, 'c) Merge_element.t -> 'd option) -> ('a, 'd, 'cmp) t + val merge_skewed + : ('k, 'v, 'cmp) t + -> ('k, 'v, 'cmp) t + -> combine:(key:'k -> 'v -> 'v -> 'v) + -> ('k, 'v, 'cmp) t + val symmetric_diff : ('a, 'b, 'cmp) t -> ('a, 'b, 'cmp) t @@ -1013,21 +1206,22 @@ module type Accessors3 = sig val binary_search : ('k, 'v, _) t -> compare:(key:'k -> data:'v -> 'key -> int) - -> [ `Last_strictly_less_than - | `Last_less_than_or_equal_to - | `Last_equal_to - | `First_equal_to - | `First_greater_than_or_equal_to - | `First_strictly_greater_than - ] + -> Binary_searchable.Which_target_by_key.t -> 'key -> ('k * 'v) option val binary_search_segmented : ('k, 'v, _) t -> segment_of:(key:'k -> data:'v -> [ `Left | `Right ]) - -> [ `Last_on_left | `First_on_right ] + -> Binary_searchable.Which_target_by_segment.t -> ('k * 'v) option + + 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 end module type Accessors3_with_comparator = sig @@ -1115,12 +1309,20 @@ module type Accessors3_with_comparator = sig : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> ('a, 'c, 'cmp) t - -> f:(key:'a -> data:[ `Left of 'b | `Right of 'c | `Both of 'b * 'c ] -> unit) + -> f:(key:'a -> data:('b, 'c) Merge_element.t -> unit) -> unit val map : ('a, 'b, 'cmp) t -> f:('b -> 'c) -> ('a, 'c, 'cmp) t val mapi : ('a, 'b, 'cmp) t -> f:(key:'a -> data:'b -> 'c) -> ('a, 'c, 'cmp) t val fold : ('a, 'b, _) t -> init:'c -> f:(key:'a -> data:'b -> 'c -> 'c) -> 'c + + val fold_until + : ('k, 'v, _) t + -> init:'a + -> f:(key:'k -> data:'v -> 'a -> ('a, 'final) Container.Continue_or_stop.t) + -> finish:('a -> 'final) + -> 'final + val fold_right : ('a, 'b, _) t -> init:'c -> f:(key:'a -> data:'b -> 'c -> 'c) -> 'c val fold2 @@ -1128,7 +1330,7 @@ module type Accessors3_with_comparator = sig -> ('a, 'b, 'cmp) t -> ('a, 'c, 'cmp) t -> init:'d - -> f:(key:'a -> data:[ `Left of 'b | `Right of 'c | `Both of 'b * 'c ] -> 'd -> 'd) + -> f:(key:'a -> data:('b, 'c) Merge_element.t -> 'd -> 'd) -> 'd val filter_keys @@ -1212,20 +1414,20 @@ module type Accessors3_with_comparator = sig -> ('a, 'b, _) t -> ('a * 'b) list - 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 merge : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> ('a, 'c, 'cmp) t - -> f:(key:'a -> [ `Left of 'b | `Right of 'c | `Both of 'b * 'c ] -> 'd option) + -> f:(key:'a -> ('b, 'c) Merge_element.t -> 'd option) -> ('a, 'd, 'cmp) t + val merge_skewed + : comparator:('k, 'cmp) Comparator.t + -> ('k, 'v, 'cmp) t + -> ('k, 'v, 'cmp) t + -> combine:(key:'k -> 'v -> 'v -> 'v) + -> ('k, 'v, 'cmp) t + val symmetric_diff : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t @@ -1295,13 +1497,8 @@ module type Accessors3_with_comparator = sig -> 'a -> ('a * 'b) option - val nth - : comparator:('a, 'cmp) Comparator.t - -> ('a, 'b, 'cmp) t - -> int - -> ('a * 'b) option - - val nth_exn : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> int -> 'a * 'b + val nth : ('a, 'b, 'cmp) t -> int -> ('a * 'b) option + val nth_exn : ('a, 'b, 'cmp) t -> int -> 'a * 'b val rank : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> 'a -> int option val to_tree : ('a, 'b, 'cmp) t -> ('a, 'b, 'cmp) tree @@ -1317,13 +1514,7 @@ module type Accessors3_with_comparator = sig : comparator:('k, 'cmp) Comparator.t -> ('k, 'v, 'cmp) t -> compare:(key:'k -> data:'v -> 'key -> int) - -> [ `Last_strictly_less_than - | `Last_less_than_or_equal_to - | `Last_equal_to - | `First_equal_to - | `First_greater_than_or_equal_to - | `First_strictly_greater_than - ] + -> Binary_searchable.Which_target_by_key.t -> 'key -> ('k * 'v) option @@ -1331,8 +1522,16 @@ module type Accessors3_with_comparator = sig : comparator:('k, 'cmp) Comparator.t -> ('k, 'v, 'cmp) t -> segment_of:(key:'k -> data:'v -> [ `Left | `Right ]) - -> [ `Last_on_left | `First_on_right ] + -> Binary_searchable.Which_target_by_segment.t -> ('k * 'v) option + + val binary_search_subrange + : comparator:('k, 'cmp) Comparator.t + -> ('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 end (** Consistency checks (same as in [Container]). *) @@ -1342,7 +1541,7 @@ module Check_accessors (Key : T1) (Cmp : T1) (Options : T3) - (M : Accessors_generic + (_ : 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 @@ -1428,6 +1627,20 @@ module type Creators_generic = sig val empty : ('k, 'cmp, ('k, _, 'cmp) t) options val singleton : ('k, 'cmp, 'k key -> 'v -> ('k, 'v, 'cmp) t) options + val map_keys + : ( 'k2 + , 'cmp2 + , ('k1, 'v, 'cmp1) t + -> f:('k1 key -> 'k2 key) + -> [ `Ok of ('k2, 'v, 'cmp2) t | `Duplicate_key of 'k2 key ] ) + options + + val map_keys_exn + : ( 'k2 + , 'cmp2 + , ('k1, 'v, 'cmp1) t -> f:('k1 key -> 'k2 key) -> ('k2, 'v, 'cmp2) t ) + options + val of_sorted_array : ('k, 'cmp, ('k key * 'v) array -> ('k, 'v, 'cmp) t Or_error.t) options @@ -1498,6 +1711,12 @@ module type Creators_generic = sig -> [ `Ok of ('k, 'v, 'cmp) t | `Duplicate_key of 'k key ] ) options + val of_iteri_exn + : ( 'k + , 'cmp + , iteri:(f:(key:'k key -> data:'v -> unit) -> unit) -> ('k, 'v, 'cmp) t ) + options + val of_tree : ('k, 'cmp, ('k key, 'v, 'cmp) tree -> ('k, 'v, 'cmp) t) options end @@ -1509,6 +1728,8 @@ module type Creators1 = sig val empty : _ t val singleton : key -> 'a -> 'a t + val map_keys : 'v t -> f:(key -> key) -> [ `Ok of 'v t | `Duplicate_key of key ] + val map_keys_exn : 'v t -> f:(key -> key) -> 'v t val of_alist : (key * 'a) list -> [ `Ok of 'a t | `Duplicate_key of key ] val of_alist_or_error : (key * 'a) list -> 'a t Or_error.t val of_alist_exn : (key * 'a) list -> 'a t @@ -1530,6 +1751,7 @@ module type Creators1 = sig : iteri:(f:(key:key -> data:'v -> unit) -> unit) -> [ `Ok of 'v t | `Duplicate_key of key ] + val of_iteri_exn : iteri:(f:(key:key -> data:'v -> unit) -> unit) -> 'v t val of_tree : 'a tree -> 'a t end @@ -1540,6 +1762,13 @@ module type Creators2 = sig val empty : (_, _) t val singleton : 'a -> 'b -> ('a, 'b) t + + val map_keys + : ('k1, 'v) t + -> f:('k1 -> 'k2) + -> [ `Ok of ('k2, 'v) t | `Duplicate_key of 'k2 ] + + val map_keys_exn : ('k1, 'v) t -> f:('k1 -> 'k2) -> ('k2, 'v) t val of_alist : ('a * 'b) list -> [ `Ok of ('a, 'b) t | `Duplicate_key of 'a ] val of_alist_or_error : ('a * 'b) list -> ('a, 'b) t Or_error.t val of_alist_exn : ('a * 'b) list -> ('a, 'b) t @@ -1567,6 +1796,7 @@ module type Creators2 = sig : iteri:(f:(key:'a -> data:'b -> unit) -> unit) -> [ `Ok of ('a, 'b) t | `Duplicate_key of 'a ] + val of_iteri_exn : iteri:(f:(key:'a -> data:'b -> unit) -> unit) -> ('a, 'b) t val of_tree : ('a, 'b) tree -> ('a, 'b) t end @@ -1577,6 +1807,18 @@ module type Creators3_with_comparator = sig val empty : comparator:('a, 'cmp) Comparator.t -> ('a, _, 'cmp) t val singleton : comparator:('a, 'cmp) Comparator.t -> 'a -> 'b -> ('a, 'b, 'cmp) t + val map_keys + : comparator:('k2, 'cmp2) Comparator.t + -> ('k1, 'v, 'cmp1) t + -> f:('k1 -> 'k2) + -> [ `Ok of ('k2, 'v, 'cmp2) t | `Duplicate_key of 'k2 ] + + val map_keys_exn + : comparator:('k2, 'cmp2) Comparator.t + -> ('k1, 'v, 'cmp1) t + -> f:('k1 -> 'k2) + -> ('k2, 'v, 'cmp2) t + val of_alist : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) list @@ -1669,6 +1911,11 @@ module type Creators3_with_comparator = sig -> iteri:(f:(key:'a -> data:'b -> unit) -> unit) -> [ `Ok of ('a, 'b, 'cmp) t | `Duplicate_key of 'a ] + val of_iteri_exn + : comparator:('a, 'cmp) Comparator.t + -> iteri:(f:(key:'a -> data:'b -> unit) -> unit) + -> ('a, 'b, 'cmp) t + val of_tree : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) tree @@ -1681,7 +1928,7 @@ module Check_creators (Key : T1) (Cmp : T1) (Options : T3) - (M : Creators_generic + (_ : 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 @@ -1790,7 +2037,7 @@ module type For_deriving = sig module type Sexp_of_m = sig type t [@@deriving_inline sexp_of] - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end @@ -1798,13 +2045,21 @@ module type For_deriving = sig module type M_of_sexp = sig type t [@@deriving_inline of_sexp] - val t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t + val t_of_sexp : Sexplib0.Sexp.t -> t [@@@end] include Comparator.S with type t := t end + module type M_sexp_grammar = sig + type t [@@deriving_inline sexp_grammar] + + val t_sexp_grammar : t Sexplib0.Sexp_grammar.t + + [@@@end] + end + module type Compare_m = sig end module type Equal_m = sig end module type Hash_fold_m = Hasher.S @@ -1821,7 +2076,10 @@ module type For_deriving = sig -> Sexp.t -> ('k, 'v, 'cmp) t - val m__t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t + val m__t_sexp_grammar + : (module M_sexp_grammar with type t = 'k) + -> 'v Sexplib0.Sexp_grammar.t + -> ('k, 'v, 'cmp) t Sexplib0.Sexp_grammar.t val compare_m__t : (module Compare_m) @@ -1860,10 +2118,11 @@ module type Map = sig | Unfinished [@@deriving_inline compare, enumerate, equal, sexp_of] - val compare : t -> t -> int - val all : t list - val equal : t -> t -> bool - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + include Ppx_compare_lib.Comparable.S with type t := t + include Ppx_enumerate_lib.Enumerable.S with type t := t + include Ppx_compare_lib.Equal.S with type t := t + + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] @@ -1874,50 +2133,109 @@ module type Map = sig val to_continue_or_stop : t -> Continue_or_stop.t end - type ('k, 'cmp) comparator = - (module Comparator.S with type t = 'k and type comparator_witness = 'cmp) + module Merge_element : sig + type ('left, 'right) t = + [ `Left of 'left + | `Right of 'right + | `Both of 'left * 'right + ] + [@@deriving_inline compare, equal, sexp_of] + + val compare + : ('left -> 'left -> int) + -> ('right -> 'right -> int) + -> ('left, 'right) t + -> ('left, 'right) t + -> int + + val equal + : ('left -> 'left -> bool) + -> ('right -> 'right -> bool) + -> ('left, 'right) t + -> ('left, 'right) t + -> bool + + val sexp_of_t + : ('left -> Sexplib0.Sexp.t) + -> ('right -> Sexplib0.Sexp.t) + -> ('left, 'right) t + -> Sexplib0.Sexp.t + + [@@@end] + + val left : ('left, _) t -> 'left option + val right : (_, 'right) t -> 'right option + val left_value : ('left, _) t -> default:'left -> 'left + val right_value : (_, 'right) t -> default:'right -> 'right + + val values + : ('left, 'right) t + -> left_default:'left + -> right_default:'right + -> 'left * 'right + end + + type ('k, 'cmp) comparator = ('k, 'cmp) Comparator.Module.t + [@@deprecated "[since 2021-12] use [Comparator.Module.t] instead"] (** Test if the invariants of the internal AVL search tree hold. *) val invariants : (_, _, _) t -> bool (** Returns a first-class module that can be used to build other map/set/etc. with the same notion of comparison. *) - val comparator_s : ('a, _, 'cmp) t -> ('a, 'cmp) comparator + val comparator_s : ('a, _, 'cmp) t -> ('a, 'cmp) Comparator.Module.t val comparator : ('a, _, 'cmp) t -> ('a, 'cmp) Comparator.t (** The empty map. *) - val empty : ('a, 'cmp) comparator -> ('a, 'b, 'cmp) t + val empty : ('a, 'cmp) Comparator.Module.t -> ('a, 'b, 'cmp) t (** A map with one (key, data) pair. *) - val singleton : ('a, 'cmp) comparator -> 'a -> 'b -> ('a, 'b, 'cmp) t + val singleton : ('a, 'cmp) Comparator.Module.t -> 'a -> 'b -> ('a, 'b, 'cmp) t (** Creates a map from an association list with unique keys. *) val of_alist - : ('a, 'cmp) comparator + : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) list -> [ `Ok of ('a, 'b, 'cmp) t | `Duplicate_key of 'a ] (** Creates a map from an association list with unique keys, returning an error if duplicate ['a] keys are found. *) val of_alist_or_error - : ('a, 'cmp) comparator + : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) list -> ('a, 'b, 'cmp) t Or_error.t (** Creates a map from an association list with unique keys, raising an exception if duplicate ['a] keys are found. *) - val of_alist_exn : ('a, 'cmp) comparator -> ('a * 'b) list -> ('a, 'b, 'cmp) t + val of_alist_exn : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) list -> ('a, 'b, 'cmp) t (** Creates a map from an association list with possibly repeated keys. The values in the map for a given key appear in the same order as they did in the association list. *) - val of_alist_multi : ('a, 'cmp) comparator -> ('a * 'b) list -> ('a, 'b list, 'cmp) t + val of_alist_multi + : ('a, 'cmp) Comparator.Module.t + -> ('a * 'b) list + -> ('a, 'b list, 'cmp) t (** Combines an association list into a map, folding together bound values with common - keys. *) + keys. The accumulator is per-key. + + Example: + + {[ + # let map = String.Map.of_alist_fold + [ "a", 1; "a", 10; "b", 2; "b", 20; "b", 200 ] + ~init:Int.Set.empty + ~f:Set.add + in + print_s [%sexp (map : Int.Set.t String.Map.t)];; + ((a (1 10)) (b (2 20 200))) + - : unit = () + ]} + *) val of_alist_fold - : ('a, 'cmp) comparator + : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) list -> init:'c -> f:('c -> 'b -> 'c) @@ -1926,7 +2244,7 @@ module type Map = sig (** Combines an association list into a map, reducing together bound values with common keys. *) val of_alist_reduce - : ('a, 'cmp) comparator + : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) list -> f:('b -> 'b -> 'b) -> ('a, 'b, 'cmp) t @@ -1936,23 +2254,29 @@ module type Map = sig into a map: [of_iteri (module String) ~f:(Hashtbl.iteri table)]. It is faster than adding the elements one by one. *) val of_iteri - : ('a, 'cmp) comparator + : ('a, 'cmp) Comparator.Module.t -> 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.Module.t + -> iteri:(f:(key:'a -> data:'b -> unit) -> unit) + -> ('a, 'b, 'cmp) t + (** Creates a map from a sorted array of key-data pairs. The input array must be sorted (either in ascending or descending order), as given by the relevant comparator, and must not contain duplicate keys. If either of these conditions does not hold, an error is returned. *) val of_sorted_array - : ('a, 'cmp) comparator + : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) array -> ('a, 'b, 'cmp) t Or_error.t (** Like [of_sorted_array] except that it returns a map with broken invariants when an [Error] would have been returned. *) val of_sorted_array_unchecked - : ('a, 'cmp) comparator + : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) array -> ('a, 'b, 'cmp) t @@ -1961,7 +2285,7 @@ module type Map = sig 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 + : ('a, 'cmp) Comparator.Module.t -> len:int -> f:(int -> 'a * 'b) -> ('a, 'b, 'cmp) t @@ -1972,7 +2296,7 @@ module type Map = sig The sequence will be folded over once, and the additional time complexity is {e O(n)}. *) val of_increasing_sequence - : ('k, 'cmp) comparator + : ('k, 'cmp) Comparator.Module.t -> ('k * 'v) Sequence.t -> ('k, 'v, 'cmp) t Or_error.t @@ -1984,7 +2308,7 @@ module type Map = sig If your sequence is increasing, use [of_increasing_sequence]. *) val of_sequence - : ('k, 'cmp) comparator + : ('k, 'cmp) Comparator.Module.t -> ('k * 'v) Sequence.t -> [ `Ok of ('k, 'v, 'cmp) t | `Duplicate_key of 'k ] @@ -1995,7 +2319,7 @@ module type Map = sig but does not allocate the intermediate list. *) val of_sequence_or_error - : ('a, 'cmp) comparator + : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) Sequence.t -> ('a, 'b, 'cmp) t Or_error.t @@ -2005,7 +2329,10 @@ module type Map = sig [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 + val of_sequence_exn + : ('a, 'cmp) Comparator.Module.t + -> ('a * 'b) Sequence.t + -> ('a, 'b, 'cmp) t (** Creates a map from an association sequence with possibly repeated keys. The values in the map for a given key appear in the same order as they did in the association @@ -2015,7 +2342,7 @@ module type Map = sig does not allocate the intermediate list. *) val of_sequence_multi - : ('a, 'cmp) comparator + : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) Sequence.t -> ('a, 'b list, 'cmp) t @@ -2026,7 +2353,7 @@ module type Map = sig but does not allocate the intermediate list. *) val of_sequence_fold - : ('a, 'cmp) comparator + : ('a, 'cmp) Comparator.Module.t -> ('a * 'b) Sequence.t -> init:'c -> f:('c -> 'b -> 'c) @@ -2038,7 +2365,7 @@ module type Map = sig [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, 'cmp) Comparator.Module.t -> ('a * 'b) Sequence.t -> f:('b -> 'b -> 'b) -> ('a, 'b, 'cmp) t @@ -2110,7 +2437,7 @@ module type Map = sig val iter2 : ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t - -> f:(key:'k -> data:[ `Left of 'v1 | `Right of 'v2 | `Both of 'v1 * 'v2 ] -> unit) + -> f:(key:'k -> data:('v1, 'v2) Merge_element.t -> unit) -> unit (** Returns a new map with bound values replaced by [f] applied to the bound values.*) @@ -2119,9 +2446,34 @@ module type Map = sig (** Like [map], but the passed function takes both [key] and [data] as arguments. *) val mapi : ('k, 'v1, 'cmp) t -> f:(key:'k -> data:'v1 -> 'v2) -> ('k, 'v2, 'cmp) t + (** Convert map with keys of type ['k2] to a map with keys of type ['k2] using [f]. *) + val map_keys + : ('k2, 'cmp2) Comparator.Module.t + -> ('k1, 'v, 'cmp1) t + -> f:('k1 -> 'k2) + -> [ `Ok of ('k2, 'v, 'cmp2) t | `Duplicate_key of 'k2 ] + + (** Like [map_keys], but raises on duplicate key. *) + val map_keys_exn + : ('k2, 'cmp2) Comparator.Module.t + -> ('k1, 'v, 'cmp1) t + -> f:('k1 -> 'k2) + -> ('k2, 'v, 'cmp2) t + (** Folds over keys and data in the 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 the map in decreasing order of [key]. *) val fold_right : ('k, 'v, _) t -> init:'a -> f:(key:'k -> data:'v -> 'a -> 'a) -> 'a @@ -2130,10 +2482,7 @@ module type Map = sig : ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t -> init:'a - -> f:(key:'k - -> data:[ `Left of 'v1 | `Right of 'v2 | `Both of 'v1 * 'v2 ] - -> 'a - -> '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 @@ -2218,13 +2567,6 @@ module type Map = sig -> ('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)). You shouldn't use this @@ -2232,7 +2574,7 @@ module type Map = sig val merge : ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t - -> f:(key:'k -> [ `Left of 'v1 | `Right of 'v2 | `Both of 'v1 * 'v2 ] -> 'v3 option) + -> 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 @@ -2240,10 +2582,9 @@ module type Map = sig combined into a single value using the [combine] function. In a call [combine ~key v1 v2], the value [v1] comes from [t1] and [v2] from [t2]. - The runtime of [merge_skewed] is [O(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. *) + The runtime of [merge_skewed] is [O(min(l1, l2) * log(max(l1, l2)))], where [l1] is + the length of [t1] and [l2] the length of [t2]. This is likely to be faster than + [merge] when one of the maps is a lot smaller, or when you merge a list of maps. *) val merge_skewed : ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t @@ -2252,16 +2593,16 @@ module type Map = sig module Symmetric_diff_element : sig type ('k, 'v) t = 'k * [ `Left of 'v | `Right of 'v | `Unequal of 'v * 'v ] - [@@deriving_inline compare, sexp] + [@@deriving_inline compare, equal, sexp, sexp_grammar] - val compare - : ('k -> 'k -> int) - -> ('v -> 'v -> int) - -> ('k, 'v) t - -> ('k, 'v) t - -> int + include Ppx_compare_lib.Comparable.S2 with type ('k, 'v) t := ('k, 'v) t + include Ppx_compare_lib.Equal.S2 with type ('k, 'v) t := ('k, 'v) t + include Sexplib0.Sexpable.S2 with type ('k, 'v) t := ('k, 'v) t - include Ppx_sexp_conv_lib.Sexpable.S2 with type ('k, 'v) t := ('k, 'v) t + val t_sexp_grammar + : 'k Sexplib0.Sexp_grammar.t + -> 'v Sexplib0.Sexp_grammar.t + -> ('k, 'v) t Sexplib0.Sexp_grammar.t [@@@end] end @@ -2472,6 +2813,27 @@ module type Map = sig -> [ `Last_on_left | `First_on_right ] -> ('k * 'v) option + (** [binary_search_subrange] takes a [compare] function that divides [t] into three + (possibly empty) segments with respect to [lower_bound] and [upper_bound]: + + {v + | Below_lower_bound | In_range | Above_upper_bound | + v} + + and returns a map of the [In_range] segment. + + Runtime is O(log m + n) where [m] is the length of the input map and [n] is the + length of the output. The linear term in [n] is to compute the length of the output. + + Behavior is undefined if [compare] does not segment [t] as shown above, or if + [compare] mutates its inputs. *) + val binary_search_subrange + : ('k, 'v, 'cmp) t + -> compare:(key:'k -> data:'v -> 'bound -> int) + -> lower_bound:'bound Maybe_bound.t + -> upper_bound:'bound Maybe_bound.t + -> ('k, 'v, 'cmp) t + (** [M] is meant to be used in combination with OCaml applicative functor types: {[ @@ -2509,11 +2871,6 @@ module type Map = sig include For_deriving with type ('key, 'value, 'cmp) t := ('key, 'value, 'cmp) t - (** A polymorphic Map. *) - module Poly : - S_poly - with type ('key, +'value) t = ('key, 'value, Comparator.Poly.comparator_witness) t - (** [Using_comparator] is a similar interface as the toplevel of [Map], except the functions take a [~comparator:('k, 'cmp) Comparator.t], whereas the functions at the toplevel of [Map] take a [('k, 'cmp) comparator]. *) @@ -2521,11 +2878,11 @@ module type Map = sig type nonrec ('k, +'v, 'cmp) t = ('k, 'v, 'cmp) t [@@deriving_inline sexp_of] val sexp_of_t - : ('k -> Ppx_sexp_conv_lib.Sexp.t) - -> ('v -> Ppx_sexp_conv_lib.Sexp.t) - -> ('cmp -> Ppx_sexp_conv_lib.Sexp.t) + : ('k -> Sexplib0.Sexp.t) + -> ('v -> Sexplib0.Sexp.t) + -> ('cmp -> Sexplib0.Sexp.t) -> ('k, 'v, 'cmp) t - -> Ppx_sexp_conv_lib.Sexp.t + -> Sexplib0.Sexp.t [@@@end] @@ -2537,14 +2894,14 @@ module type Map = sig -> ('k, 'v, 'cmp) t module Tree : sig - type ('k, +'v, 'cmp) t [@@deriving_inline sexp_of] + type (+'k, +'v, 'cmp) t [@@deriving_inline sexp_of] val sexp_of_t - : ('k -> Ppx_sexp_conv_lib.Sexp.t) - -> ('v -> Ppx_sexp_conv_lib.Sexp.t) - -> ('cmp -> Ppx_sexp_conv_lib.Sexp.t) + : ('k -> Sexplib0.Sexp.t) + -> ('v -> Sexplib0.Sexp.t) + -> ('cmp -> Sexplib0.Sexp.t) -> ('k, 'v, 'cmp) t - -> Ppx_sexp_conv_lib.Sexp.t + -> Sexplib0.Sexp.t [@@@end] @@ -2561,6 +2918,34 @@ module type Map = sig with type ('a, 'b, 'c) tree := ('a, 'b, 'c) t val empty_without_value_restriction : (_, _, _) t + + (** [Build_increasing] can be used to construct a map incrementally from a + sequence that is known to be increasing. + + The total time complexity of constructing a map this way is O(n), which is more + efficient than using [Map.add] by a logarithmic factor. + + This interface can be thought of as a dual of [to_sequence], but we don't have + an equally neat idiom for the duals of sequences ([of_sequence] is much less + general because it does not allow the sequence to be produced asynchronously). *) + module Build_increasing : sig + type ('a, 'b, 'c) tree := ('a, 'b, 'c) t + type ('k, 'v, 'w) t + + val empty : ('k, 'v, 'w) t + + (** Time complexity of [add_exn] is amortized constant-time (if [t] is used + linearly), with a worst-case O(log(n)) time. *) + val add_exn + : ('k, 'v, 'w) t + -> comparator:('k, 'w) Comparator.t + -> key:'k + -> data:'v + -> ('k, 'v, 'w) t + + (** Time complexity is O(log(n)). *) + val to_tree : ('k, 'v, 'w) t -> ('k, 'v, 'w) tree + end end include @@ -2587,10 +2972,27 @@ module type Map = sig end end + (** A polymorphic Map. *) + module Poly : + S_poly + with type ('key, +'value) t = ('key, 'value, Comparator.Poly.comparator_witness) t + and type ('key, +'value) tree = + ('key, 'value, Comparator.Poly.comparator_witness) Using_comparator.Tree.t + and type comparator_witness = Comparator.Poly.comparator_witness + + (** Create a map from a tree using the given comparator. *) + val of_tree + : ('k, 'cmp) Comparator.Module.t + -> ('k, 'v, 'cmp) Using_comparator.Tree.t + -> ('k, 'v, 'cmp) t + + (** Extract a tree from a map. *) + val to_tree : ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) Using_comparator.Tree.t + (** {2 Modules and module types for extending [Map]} - For use in extensions of Base, like [Core_kernel]. *) + For use in extensions of Base, like [Core]. *) module With_comparator = With_comparator module With_first_class_module = With_first_class_module diff --git a/src/maybe_bound.ml b/src/maybe_bound.ml index 97a8851..2ccec18 100644 --- a/src/maybe_bound.ml +++ b/src/maybe_bound.ml @@ -4,7 +4,7 @@ type 'a t = | Incl of 'a | Excl of 'a | Unbounded -[@@deriving_inline enumerate, sexp] +[@@deriving_inline enumerate, sexp, sexp_grammar] let all : 'a. 'a list -> 'a t list = fun _all_of_a -> @@ -25,53 +25,81 @@ let all : 'a. 'a list -> 'a t list = [ Unbounded ]) ;; -let t_of_sexp - : type a. (Ppx_sexp_conv_lib.Sexp.t -> a) -> Ppx_sexp_conv_lib.Sexp.t -> a t - = - let _tp_loc = "maybe_bound.ml.t" in - fun _of_a -> function - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom (("incl" | "Incl") as _tag) :: sexp_args) as _sexp - -> - (match sexp_args with - | [ v0 ] -> - let v0 = _of_a v0 in - Incl v0 - | _ -> Ppx_sexp_conv_lib.Conv_error.stag_incorrect_n_args _tp_loc _tag _sexp) - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom (("excl" | "Excl") as _tag) :: sexp_args) as _sexp - -> - (match sexp_args with - | [ v0 ] -> - let v0 = _of_a v0 in - Excl v0 - | _ -> Ppx_sexp_conv_lib.Conv_error.stag_incorrect_n_args _tp_loc _tag _sexp) - | Ppx_sexp_conv_lib.Sexp.Atom ("unbounded" | "Unbounded") -> Unbounded - | Ppx_sexp_conv_lib.Sexp.Atom ("incl" | "Incl") as sexp -> - Ppx_sexp_conv_lib.Conv_error.stag_takes_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.Atom ("excl" | "Excl") as sexp -> - Ppx_sexp_conv_lib.Conv_error.stag_takes_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom ("unbounded" | "Unbounded") :: _) as sexp -> - Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.List _ :: _) as sexp -> - Ppx_sexp_conv_lib.Conv_error.nested_list_invalid_sum _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List [] as sexp -> - Ppx_sexp_conv_lib.Conv_error.empty_list_invalid_sum _tp_loc sexp - | sexp -> Ppx_sexp_conv_lib.Conv_error.unexpected_stag _tp_loc sexp -;; - -let sexp_of_t - : type a. (a -> Ppx_sexp_conv_lib.Sexp.t) -> a t -> Ppx_sexp_conv_lib.Sexp.t - = - fun _of_a -> function - | Incl v0 -> - let v0 = _of_a v0 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Incl"; v0 ] - | Excl v0 -> - let v0 = _of_a v0 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Excl"; v0 ] - | Unbounded -> Ppx_sexp_conv_lib.Sexp.Atom "Unbounded" +let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = + fun (type a__018_) : ((Sexplib0.Sexp.t -> a__018_) -> Sexplib0.Sexp.t -> a__018_ t) -> + let error_source__006_ = "maybe_bound.ml.t" in + fun _of_a__003_ -> function + | Sexplib0.Sexp.List + (Sexplib0.Sexp.Atom (("incl" | "Incl") as _tag__009_) :: sexp_args__010_) as + _sexp__008_ -> + (match sexp_args__010_ with + | [ arg0__011_ ] -> + let res0__012_ = _of_a__003_ arg0__011_ in + Incl res0__012_ + | _ -> + Sexplib0.Sexp_conv_error.stag_incorrect_n_args + error_source__006_ + _tag__009_ + _sexp__008_) + | Sexplib0.Sexp.List + (Sexplib0.Sexp.Atom (("excl" | "Excl") as _tag__014_) :: sexp_args__015_) as + _sexp__013_ -> + (match sexp_args__015_ with + | [ arg0__016_ ] -> + let res0__017_ = _of_a__003_ arg0__016_ in + Excl res0__017_ + | _ -> + Sexplib0.Sexp_conv_error.stag_incorrect_n_args + error_source__006_ + _tag__014_ + _sexp__013_) + | Sexplib0.Sexp.Atom ("unbounded" | "Unbounded") -> Unbounded + | Sexplib0.Sexp.Atom ("incl" | "Incl") as sexp__007_ -> + Sexplib0.Sexp_conv_error.stag_takes_args error_source__006_ sexp__007_ + | Sexplib0.Sexp.Atom ("excl" | "Excl") as sexp__007_ -> + Sexplib0.Sexp_conv_error.stag_takes_args error_source__006_ sexp__007_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("unbounded" | "Unbounded") :: _) as + sexp__007_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__006_ sexp__007_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__005_ -> + Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__006_ sexp__005_ + | Sexplib0.Sexp.List [] as sexp__005_ -> + Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__006_ sexp__005_ + | sexp__005_ -> + Sexplib0.Sexp_conv_error.unexpected_stag error_source__006_ sexp__005_ +;; + +let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = + fun (type a__024_) : ((a__024_ -> Sexplib0.Sexp.t) -> a__024_ t -> Sexplib0.Sexp.t) -> + fun _of_a__019_ -> function + | Incl arg0__020_ -> + let res0__021_ = _of_a__019_ arg0__020_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Incl"; res0__021_ ] + | Excl arg0__022_ -> + let res0__023_ = _of_a__019_ arg0__022_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Excl"; res0__023_ ] + | Unbounded -> Sexplib0.Sexp.Atom "Unbounded" +;; + +let (t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t) = + fun _'a_sexp_grammar -> + { untyped = + Variant + { case_sensitivity = Case_sensitive_except_first_character + ; clauses = + [ No_tag + { name = "Incl" + ; clause_kind = + List_clause { args = Cons (_'a_sexp_grammar.untyped, Empty) } + } + ; No_tag + { name = "Excl" + ; clause_kind = + List_clause { args = Cons (_'a_sexp_grammar.untyped, Empty) } + } + ; No_tag { name = "Unbounded"; clause_kind = Atom_clause } + ] + } + } ;; [@@@end] @@ -80,39 +108,49 @@ type interval_comparison = | Below_lower_bound | In_range | Above_upper_bound -[@@deriving_inline sexp, compare, hash] +[@@deriving_inline sexp, sexp_grammar, compare, hash] let interval_comparison_of_sexp = - (let _tp_loc = "maybe_bound.ml.interval_comparison" in + (let error_source__027_ = "maybe_bound.ml.interval_comparison" in function - | Ppx_sexp_conv_lib.Sexp.Atom ("below_lower_bound" | "Below_lower_bound") -> - Below_lower_bound - | Ppx_sexp_conv_lib.Sexp.Atom ("in_range" | "In_range") -> In_range - | Ppx_sexp_conv_lib.Sexp.Atom ("above_upper_bound" | "Above_upper_bound") -> - Above_upper_bound - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom ("below_lower_bound" | "Below_lower_bound") :: _) as - sexp -> Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom ("in_range" | "In_range") :: _) as sexp -> - Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom ("above_upper_bound" | "Above_upper_bound") :: _) as - sexp -> Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.List _ :: _) as sexp -> - Ppx_sexp_conv_lib.Conv_error.nested_list_invalid_sum _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List [] as sexp -> - Ppx_sexp_conv_lib.Conv_error.empty_list_invalid_sum _tp_loc sexp - | sexp -> Ppx_sexp_conv_lib.Conv_error.unexpected_stag _tp_loc sexp - : Ppx_sexp_conv_lib.Sexp.t -> interval_comparison) + | Sexplib0.Sexp.Atom ("below_lower_bound" | "Below_lower_bound") -> Below_lower_bound + | Sexplib0.Sexp.Atom ("in_range" | "In_range") -> In_range + | Sexplib0.Sexp.Atom ("above_upper_bound" | "Above_upper_bound") -> Above_upper_bound + | Sexplib0.Sexp.List + (Sexplib0.Sexp.Atom ("below_lower_bound" | "Below_lower_bound") :: _) as sexp__028_ + -> Sexplib0.Sexp_conv_error.stag_no_args error_source__027_ sexp__028_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("in_range" | "In_range") :: _) as sexp__028_ + -> Sexplib0.Sexp_conv_error.stag_no_args error_source__027_ sexp__028_ + | Sexplib0.Sexp.List + (Sexplib0.Sexp.Atom ("above_upper_bound" | "Above_upper_bound") :: _) as sexp__028_ + -> Sexplib0.Sexp_conv_error.stag_no_args error_source__027_ sexp__028_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__026_ -> + Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__027_ sexp__026_ + | Sexplib0.Sexp.List [] as sexp__026_ -> + Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__027_ sexp__026_ + | sexp__026_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__027_ sexp__026_ + : Sexplib0.Sexp.t -> interval_comparison) ;; let sexp_of_interval_comparison = (function - | Below_lower_bound -> Ppx_sexp_conv_lib.Sexp.Atom "Below_lower_bound" - | In_range -> Ppx_sexp_conv_lib.Sexp.Atom "In_range" - | Above_upper_bound -> Ppx_sexp_conv_lib.Sexp.Atom "Above_upper_bound" - : interval_comparison -> Ppx_sexp_conv_lib.Sexp.t) + | Below_lower_bound -> Sexplib0.Sexp.Atom "Below_lower_bound" + | In_range -> Sexplib0.Sexp.Atom "In_range" + | Above_upper_bound -> Sexplib0.Sexp.Atom "Above_upper_bound" + : interval_comparison -> Sexplib0.Sexp.t) +;; + +let (interval_comparison_sexp_grammar : interval_comparison Sexplib0.Sexp_grammar.t) = + { untyped = + Variant + { case_sensitivity = Case_sensitive_except_first_character + ; clauses = + [ No_tag { name = "Below_lower_bound"; clause_kind = Atom_clause } + ; No_tag { name = "In_range"; clause_kind = Atom_clause } + ; No_tag { name = "Above_upper_bound"; clause_kind = Atom_clause } + ] + } + } ;; let compare_interval_comparison = diff --git a/src/maybe_bound.mli b/src/maybe_bound.mli index e0aa3f5..d8ee7a2 100644 --- a/src/maybe_bound.mli +++ b/src/maybe_bound.mli @@ -7,11 +7,12 @@ type 'a t = | Incl of 'a | Excl of 'a | Unbounded -[@@deriving_inline enumerate, sexp] +[@@deriving_inline enumerate, sexp, sexp_grammar] -val all : 'a list -> 'a t list +include Ppx_enumerate_lib.Enumerable.S1 with type 'a t := 'a t +include Sexplib0.Sexpable.S1 with type 'a t := 'a t -include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t := 'a t +val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] @@ -37,10 +38,11 @@ type interval_comparison = | Below_lower_bound | In_range | Above_upper_bound -[@@deriving_inline sexp, compare, hash] +[@@deriving_inline sexp, sexp_grammar, compare, hash] -val sexp_of_interval_comparison : interval_comparison -> Ppx_sexp_conv_lib.Sexp.t -val interval_comparison_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> interval_comparison +val sexp_of_interval_comparison : interval_comparison -> Sexplib0.Sexp.t +val interval_comparison_of_sexp : Sexplib0.Sexp.t -> interval_comparison +val interval_comparison_sexp_grammar : interval_comparison Sexplib0.Sexp_grammar.t val compare_interval_comparison : interval_comparison -> interval_comparison -> int val hash_fold_interval_comparison diff --git a/src/monad.ml b/src/monad.ml index 8870b84..3712ab0 100644 --- a/src/monad.ml +++ b/src/monad.ml @@ -70,31 +70,130 @@ end module Make_indexed (M : Basic_indexed) : S_indexed with type ('a, 'i, 'j) t := ('a, 'i, 'j) M.t = Make_general (struct - type ('a, 'i, 'j, 'd, 'e) t = ('a, 'i, 'j) M.t + include M - include (M : Basic_indexed with type ('a, 'b, 'c) t := ('a, 'b, 'c) M.t) + type ('a, 'i, 'j, 'd, 'e) t = ('a, 'i, 'j) M.t end) module Make3 (M : Basic3) : S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) M.t = Make_general (struct - type ('a, 'i, 'j, 'd, 'e) t = ('a, 'd, 'e) M.t + include M - include (M : Basic3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) M.t) + type ('a, 'i, 'j, 'd, 'e) t = ('a, 'd, 'e) M.t end) -module Make2 (M : Basic2) : S2 with type ('a, 'd) t := ('a, 'd) M.t = - Make_general (struct - type ('a, 'i, 'j, 'd, 'e) t = ('a, 'd) M.t +module Make2 (M : Basic2) : S2 with type ('a, 'd) t := ('a, 'd) M.t = Make_general (struct + include M - include (M : Basic2 with type ('a, 'b) t := ('a, 'b) M.t) + type ('a, 'i, 'j, 'd, 'e) t = ('a, 'd) M.t end) module Make (M : Basic) : S with type 'a t := 'a M.t = Make_general (struct + include M + type ('a, 'i, 'j, 'd, 'e) t = 'a M.t + end) + +module Of_monad_general (Monad : sig + type ('a, 'i, 'j, 'd, 'e) t - include (M : Basic with type 'a t := 'a M.t) + val bind + : ('a, 'i, 'j, 'd, 'e) t + -> f:('a -> ('b, 'j, 'k, 'd, 'e) t) + -> ('b, 'i, 'k, 'd, 'e) t + + val map : ('a, 'i, 'j, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'i, 'j, 'd, 'e) t + val return : 'a -> ('a, 'i, 'i, 'd, 'e) t + end) (M : sig + type ('a, 'i, 'j, 'd, 'e) t + + val to_monad : ('a, 'i, 'j, 'd, 'e) t -> ('a, 'i, 'j, 'd, 'e) Monad.t + val of_monad : ('a, 'i, 'j, 'd, 'e) Monad.t -> ('a, 'i, 'j, 'd, 'e) t + end) = + Make_general (struct + type ('a, 'i, 'j, 'd, 'e) t = ('a, 'i, 'j, 'd, 'e) M.t + + let return a = M.of_monad (Monad.return a) + let bind t ~f = M.of_monad (Monad.bind (M.to_monad t) ~f:(fun a -> M.to_monad (f a))) + let map = `Custom (fun t ~f -> M.of_monad (Monad.map (M.to_monad t) ~f)) end) +module Of_monad_indexed + (Monad : S_indexed) (M : sig + type ('a, 'i, 'j) t + + val to_monad : ('a, 'i, 'j) t -> ('a, 'i, 'j) Monad.t + val of_monad : ('a, 'i, 'j) Monad.t -> ('a, 'i, 'j) t + end) = + Of_monad_general + (struct + include Monad + + type ('a, 'i, 'j, 'd, 'e) t = ('a, 'i, 'j) Monad.t + end) + (struct + include M + + type ('a, 'i, 'j, 'd, 'e) t = ('a, 'i, 'j) M.t + end) + +module Of_monad3 + (Monad : S3) (M : sig + type ('a, 'b, 'c) t + + val to_monad : ('a, 'b, 'c) t -> ('a, 'b, 'c) Monad.t + val of_monad : ('a, 'b, 'c) Monad.t -> ('a, 'b, 'c) t + end) = + Of_monad_general + (struct + include Monad + + type ('a, 'i, 'j, 'd, 'e) t = ('a, 'd, 'e) Monad.t + end) + (struct + include M + + type ('a, 'i, 'j, 'd, 'e) t = ('a, 'd, 'e) M.t + end) + +module Of_monad2 + (Monad : S2) (M : sig + type ('a, 'b) t + + val to_monad : ('a, 'b) t -> ('a, 'b) Monad.t + val of_monad : ('a, 'b) Monad.t -> ('a, 'b) t + end) = + Of_monad_general + (struct + include Monad + + type ('a, 'i, 'j, 'd, 'e) t = ('a, 'd) Monad.t + end) + (struct + include M + + type ('a, 'i, 'j, 'd, 'e) t = ('a, 'd) M.t + end) + +module Of_monad + (Monad : S) (M : sig + type 'a t + + val to_monad : 'a t -> 'a Monad.t + val of_monad : 'a Monad.t -> 'a t + end) = + Of_monad_general + (struct + include Monad + + type ('a, 'i, 'j, 'd, 'e) t = 'a Monad.t + end) + (struct + include M + + type ('a, 'i, 'j, 'd, 'e) t = 'a M.t + end) + module Ident = struct type 'a t = 'a diff --git a/src/monad_intf.ml b/src/monad_intf.ml index 80b506d..30e1eda 100644 --- a/src/monad_intf.ml +++ b/src/monad_intf.ml @@ -36,9 +36,10 @@ module type Infix = sig val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t end -(** Opening a module of this type allows one to use the [%bind] and [%map] syntax - extensions defined by ppx_let, and brings [return] into scope. *) module type Syntax = sig + (** Opening a module of this type allows one to use the [%bind] and [%map] syntax + extensions defined by ppx_let, and brings [return] into scope. *) + type 'a t module Let_syntax : sig @@ -97,10 +98,11 @@ module type S = sig include Syntax with type 'a t := 'a t end -(** Multi parameter monad. The second parameter gets unified across all the computation. - This is used to encode monads working on a multi parameter data structure like - ([('a,'b) result]). *) module type Basic2 = sig + (** Multi parameter monad. The second parameter gets unified across all the computation. + This is used to encode monads working on a multi parameter data structure like + ([('a,'b) result]). *) + type ('a, 'e) t val bind : ('a, 'e) t -> f:('a -> ('b, 'e) t) -> ('b, 'e) t @@ -108,9 +110,10 @@ module type Basic2 = sig val return : 'a -> ('a, _) t end -(** Same as Infix, except the monad type has two arguments. The second is always just - passed through. *) module type Infix2 = sig + (** Same as {!Infix}, except the monad type has two arguments. The second is always just + passed through. *) + type ('a, 'e) t val ( >>= ) : ('a, 'e) t -> ('a -> ('b, 'e) t) -> ('b, 'e) t @@ -136,9 +139,10 @@ module type Syntax2 = sig end end -(** The same as S except the monad type has two arguments. The second is always just - passed through. *) module type S2 = sig + (** The same as {!S} except the monad type has two arguments. The second is always just + passed through. *) + type ('a, 'e) t include Infix2 with type ('a, 'e) t := ('a, 'e) t @@ -154,9 +158,10 @@ module type S2 = sig val all_unit : (unit, 'e) t list -> (unit, 'e) t end -(** Multi parameter monad. The second and third parameters get unified across all the - computation. *) module type Basic3 = sig + (** Multi parameter monad. The second and third parameters get unified across all the + computation. *) + type ('a, 'd, 'e) t val bind : ('a, 'd, 'e) t -> f:('a -> ('b, 'd, 'e) t) -> ('b, 'd, 'e) t @@ -167,9 +172,10 @@ module type Basic3 = sig val return : 'a -> ('a, _, _) t end -(** Same as Infix, except the monad type has three arguments. The second and third are - always just passed through. *) module type Infix3 = sig + (** Same as Infix, except the monad type has three arguments. The second and third are + always just passed through. *) + type ('a, 'd, 'e) t val ( >>= ) : ('a, 'd, 'e) t -> ('a -> ('b, 'd, 'e) t) -> ('b, 'd, 'e) t @@ -195,9 +201,10 @@ module type Syntax3 = sig end end -(** The same as S except the monad type has three arguments. The second and third are - always just passed through. *) module type S3 = sig + (** The same as {!S} except the monad type has three arguments. The second + and third are always just passed through. *) + type ('a, 'd, 'e) t include Infix3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) t @@ -213,28 +220,29 @@ module type S3 = sig val all_unit : (unit, 'd, 'e) t list -> (unit, 'd, 'e) t end -(** Indexed monad, in the style of Atkey. The second and third parameters are composed - across all computation. To see this more clearly, you can look at the type of bind: +module type Basic_indexed = sig + (** Indexed monad, in the style of Atkey. The second and third parameters are composed + across all computation. To see this more clearly, you can look at the type of bind: - {[ - val bind : ('a, 'i, 'j) t -> f:('a -> ('b, 'j, 'k) t) -> ('b, 'i, 'k) t - ]} + {[ + val bind : ('a, 'i, 'j) t -> f:('a -> ('b, 'j, 'k) t) -> ('b, 'i, 'k) t + ]} - and isolate some of the type variables to see their individual behaviors: + and isolate some of the type variables to see their individual behaviors: - {[ - val bind : 'a -> f:('a -> 'b ) -> 'b - val bind : 'i, 'j -> 'j, 'k -> 'i, 'k - ]} + {[ + val bind : 'a -> f:('a -> 'b ) -> 'b + val bind : 'i, 'j -> 'j, 'k -> 'i, 'k + ]} - For more information on Atkey-style indexed monads, see: + For more information on Atkey-style indexed monads, see: + + {v + Parameterised Notions of Computation + Robert Atkey + http://bentnib.org/paramnotions-jfp.pdf + v} *) - {v - Parameterised Notions of Computation - Robert Atkey - http://bentnib.org/paramnotions-jfp.pdf - v} *) -module type Basic_indexed = sig type ('a, 'i, 'j) t val bind : ('a, 'i, 'j) t -> f:('a -> ('b, 'j, 'k) t) -> ('b, 'i, 'k) t @@ -245,9 +253,10 @@ module type Basic_indexed = sig val return : 'a -> ('a, 'i, 'i) t end -(** Same as Infix, except the monad type has three arguments. The second and third are - compose across all computation. *) module type Infix_indexed = sig + (** Same as {!Infix}, except the monad type has three arguments. The second and + third are composed across all computation. *) + type ('a, 'i, 'j) t val ( >>= ) : ('a, 'i, 'j) t -> ('a -> ('b, 'j, 'k) t) -> ('b, 'i, 'k) t @@ -273,9 +282,10 @@ module type Syntax_indexed = sig end end -(** The same as S except the monad type has three arguments. The second and third are - composed across all computation. *) module type S_indexed = sig + (** The same as {!S} except the monad type has three arguments. The second and + third are composed across all computation. *) + type ('a, 'i, 'j) t include Infix_indexed with type ('a, 'i, 'j) t := ('a, 'i, 'j) t @@ -292,40 +302,40 @@ module type S_indexed = sig end module S_to_S2 (X : S) : S2 with type ('a, 'e) t = 'a X.t = struct - type ('a, 'e) t = 'a X.t + include X - include (X : S with type 'a t := 'a X.t) + type ('a, 'e) t = 'a X.t end module S2_to_S3 (X : S2) : S3 with type ('a, 'd, 'e) t = ('a, 'd) X.t = struct - type ('a, 'd, 'e) t = ('a, 'd) X.t + include X - include (X : S2 with type ('a, 'd) t := ('a, 'd) X.t) + type ('a, 'd, 'e) t = ('a, 'd) X.t end module S_to_S_indexed (X : S) : S_indexed with type ('a, 'i, 'j) t = 'a X.t = struct - type ('a, 'i, 'j) t = 'a X.t + include X - include (X : S with type 'a t := 'a X.t) + type ('a, 'i, 'j) t = 'a X.t end module S2_to_S (X : S2) : S with type 'a t = ('a, unit) X.t = struct - type 'a t = ('a, unit) X.t + include X - include (X : S2 with type ('a, 'e) t := ('a, 'e) X.t) + type 'a t = ('a, unit) X.t end module S3_to_S2 (X : S3) : S2 with type ('a, 'e) t = ('a, 'e, unit) X.t = struct - type ('a, 'e) t = ('a, 'e, unit) X.t + include X - include (X : S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t) + type ('a, 'e) t = ('a, 'e, unit) X.t end module S_indexed_to_S2 (X : S_indexed) : S2 with type ('a, 'e) t = ('a, 'e, 'e) X.t = struct - type ('a, 'e) t = ('a, 'e, 'e) X.t + include X - include (X : S_indexed with type ('a, 'i, 'j) t := ('a, 'i, 'j) X.t) + type ('a, 'e) t = ('a, 'e, 'e) X.t end module type Monad = sig @@ -357,5 +367,49 @@ module type Monad = sig module Make_indexed (X : Basic_indexed) : S_indexed with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t + (** Define a monad through an isomorphism with an existing monad. For example: + + {[ + type 'a t = { value : 'a } + + include Monad.Of_monad (Monad.Ident) (struct + type nonrec 'a t = 'a t + + let to_monad { value } = value + let of_monad value = { value } + end) + ]} *) + module Of_monad + (Monad : S) (M : sig + type 'a t + + val to_monad : 'a t -> 'a Monad.t + val of_monad : 'a Monad.t -> 'a t + end) : S with type 'a t := 'a M.t + + module Of_monad2 + (Monad : S2) (M : sig + type ('a, 'b) t + + val to_monad : ('a, 'b) t -> ('a, 'b) Monad.t + val of_monad : ('a, 'b) Monad.t -> ('a, 'b) t + end) : S2 with type ('a, 'b) t := ('a, 'b) M.t + + module Of_monad3 + (Monad : S3) (M : sig + type ('a, 'b, 'c) t + + val to_monad : ('a, 'b, 'c) t -> ('a, 'b, 'c) Monad.t + val of_monad : ('a, 'b, 'c) Monad.t -> ('a, 'b, 'c) t + end) : S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) M.t + + module Of_monad_indexed + (Monad : S_indexed) (M : sig + type ('a, 'i, 'j) t + + val to_monad : ('a, 'i, 'j) t -> ('a, 'i, 'j) Monad.t + val of_monad : ('a, 'i, 'j) Monad.t -> ('a, 'i, 'j) t + end) : S_indexed with type ('a, 'i, 'j) t := ('a, 'i, 'j) M.t + module Ident : S with type 'a t = 'a end diff --git a/src/nativeint.ml b/src/nativeint.ml index 6c6c254..a7bf84d 100644 --- a/src/nativeint.ml +++ b/src/nativeint.ml @@ -13,31 +13,13 @@ module T = struct fun x -> func x ;; - let t_of_sexp = (nativeint_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t) - let sexp_of_t = (sexp_of_nativeint : t -> Ppx_sexp_conv_lib.Sexp.t) - - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "nativeint" ] - ; ggid = "\146e\023\249\235eE\139c\132W\195\137\129\235\025" - ; types = [ "t", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ nativeint_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "nativeint.ml.T" - } - in - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("t", _the_group) - in - t_sexp_grammar - ;; + let t_of_sexp = (nativeint_of_sexp : Sexplib0.Sexp.t -> t) + let sexp_of_t = (sexp_of_nativeint : t -> Sexplib0.Sexp.t) + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = nativeint_sexp_grammar [@@@end] + let hashable : t Hashable.t = { hash; compare; sexp_of_t } let compare = Nativeint_replace_polymorphic_compare.compare let to_string = to_string let of_string = of_string @@ -46,7 +28,7 @@ end include T include Comparator.Make (T) -include Comparable.Validate_with_zero (struct +include Comparable.With_zero (struct include T let zero = zero @@ -130,7 +112,6 @@ let of_float f = module Pow2 = struct open! Import open Nativeint_replace_polymorphic_compare - module Sys = Sys0 let raise_s = Error.raise_s diff --git a/src/nothing.ml b/src/nothing.ml index 947c059..6161121 100644 --- a/src/nothing.ml +++ b/src/nothing.ml @@ -12,7 +12,8 @@ module T = struct let hash = unreachable_code let compare a _ = unreachable_code a let sexp_of_t = unreachable_code - let t_of_sexp sexp = Sexplib.Conv_error.empty_type "Base.Nothing.t" sexp + let t_of_sexp sexp = Sexplib0.Sexp_conv_error.empty_type "Base.Nothing.t" sexp + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Union [] } let to_string = unreachable_code let of_string (_ : string) = failwith "Base.Nothing.of_string: not supported" end diff --git a/src/nothing.mli b/src/nothing.mli index 8011e28..8c05bf8 100644 --- a/src/nothing.mli +++ b/src/nothing.mli @@ -22,9 +22,11 @@ open! Import another case where [[@deriving enumerate]] could be useful is when this type is part of some larger type. *) -type t = | [@@deriving_inline enumerate] +type t = | [@@deriving_inline enumerate, sexp_grammar] -val all : t list +include Ppx_enumerate_lib.Enumerable.S with type t := t + +val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] @@ -55,5 +57,4 @@ val unreachable_code : t -> _ 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 +include Identifiable.S with type t := t diff --git a/src/obj_array.ml b/src/obj_array.ml index 85c5c1e..ee53c09 100644 --- a/src/obj_array.ml +++ b/src/obj_array.ml @@ -9,8 +9,7 @@ module Array = Array0 type t = Caml.Obj.t array let invariant t = assert (Caml.Obj.tag (Caml.Obj.repr t) <> Caml.Obj.double_array_tag) -let length = Array.length -let swap t i j = Array.swap t i j +let length = Array.length (* would check for float arrays in 32 bit, but whatever *) let sexp_of_t t = Sexp.Atom @@ -22,21 +21,6 @@ let zero_obj = Caml.Obj.repr (0 : int) (* We call [Array.create] with a value that is not a float so that the array doesn't get tagged with [Double_array_tag]. *) let create_zero ~len = Array.create ~len zero_obj - -let create ~len x = - (* If we can, use [Array.create] directly. *) - if Caml.Obj.tag x <> Caml.Obj.double_tag - then Array.create ~len x - else ( - (* Otherwise use [create_zero] and set the contents *) - let t = create_zero ~len in - let x = Sys.opaque_identity x in - for i = 0 to len - 1 do - Array.unsafe_set t i x - done; - t) -;; - let empty = [||] type not_a_float = @@ -73,6 +57,12 @@ let[@inline always] unsafe_set_with_caml_modify t i obj = (Caml.Obj.obj (Sys.opaque_identity obj) : not_a_float) ;; +let[@inline always] set_with_caml_modify t i obj = + (* same as unsafe_set_with_caml_modify but safe *) + (Caml.Obj.magic (t : t) : not_a_float array).(i) + <- (Caml.Obj.obj (Sys.opaque_identity obj) : not_a_float) +;; + let[@inline always] unsafe_set_int_assuming_currently_int t i int = (* This skips [caml_modify], which is OK if both the old and new values are integers. *) Array.unsafe_set (Caml.Obj.magic (t : t) : int array) i (Sys.opaque_identity int) @@ -109,6 +99,27 @@ let[@inline always] unsafe_set_omit_phys_equal_check t i obj = else unsafe_set_with_caml_modify t i obj ;; +let swap t i j = + let a = get t i in + let b = get t j in + unsafe_set t i b; + unsafe_set t j a +;; + +let create ~len x = + (* If we can, use [Array.create] directly. *) + if Caml.Obj.tag x <> Caml.Obj.double_tag + then Array.create ~len x + else ( + (* Otherwise use [create_zero] and set the contents *) + let t = create_zero ~len in + let x = Sys.opaque_identity x in + for i = 0 to len - 1 do + unsafe_set_with_caml_modify t i x + done; + t) +;; + let singleton obj = create ~len:1 obj (* Pre-condition: t.(i) is an integer. *) diff --git a/src/obj_array.mli b/src/obj_array.mli index 511a7eb..a92ef74 100644 --- a/src/obj_array.mli +++ b/src/obj_array.mli @@ -6,7 +6,7 @@ open! Import type t [@@deriving_inline sexp_of] -val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t +val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] @@ -38,6 +38,13 @@ val set : t -> int -> Caml.Obj.t -> unit val unsafe_set : t -> int -> Caml.Obj.t -> unit val swap : t -> int -> int -> unit +(** [set_with_caml_modify] simply sets the value in the array with no bells and whistles, + unlike [set] which first reads the value to optimize immediate values and setting the + index to its current value. This can be used when these optimizations are not useful, + but the noise in generated code is annoying (and might have an impact on performance, + although this is pure speculation). *) +val set_with_caml_modify : t -> int -> Caml.Obj.t -> unit + (** [unsafe_set_assuming_currently_int t i obj] sets index [i] of [t] to [obj], but only works correctly if [Caml.Obj.is_int (get t i)]. This precondition saves a dynamic check. @@ -57,6 +64,11 @@ val unsafe_set_int : t -> int -> int -> unit values are [phys_equal]. *) val unsafe_set_omit_phys_equal_check : t -> int -> Caml.Obj.t -> unit +(** Same as [set_with_caml_modify], but without bounds checks. This is like + [unsafe_set_omit_phys_equal_check] except it doesn't check whether the old value and + the value being set are integers to try to skip [caml_modify]. *) +val unsafe_set_with_caml_modify : t -> int -> Caml.Obj.t -> unit + (** [unsafe_clear_if_pointer t i] prevents [t.(i)] from pointing to anything to prevent space leaks. It does this by setting [t.(i)] to [Caml.Obj.repr 0]. As a performance hack, it only does this when [not (Caml.Obj.is_int t.(i))]. *) diff --git a/src/option.ml b/src/option.ml index 8e1c355..6cf55d0 100644 --- a/src/option.ml +++ b/src/option.ml @@ -1,9 +1,5 @@ open! Import -type 'a t = 'a option = - | None - | Some of 'a - include ( struct type 'a t = 'a option [@@deriving_inline compare, hash, sexp, sexp_grammar] @@ -11,44 +7,25 @@ struct let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = compare_option let hash_fold_t : - 'a. (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) - -> Ppx_hash_lib.Std.Hash.state -> 'a t -> Ppx_hash_lib.Std.Hash.state + 'a. + (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) + -> Ppx_hash_lib.Std.Hash.state + -> 'a t + -> Ppx_hash_lib.Std.Hash.state = hash_fold_option ;; - let t_of_sexp : - 'a. (Ppx_sexp_conv_lib.Sexp.t -> 'a) -> Ppx_sexp_conv_lib.Sexp.t -> 'a t - = + let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = option_of_sexp ;; - let sexp_of_t : - 'a. ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t - = + let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = sexp_of_option ;; - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) - = - { implicit_vars = [ "option" ] - ; ggid = "j\132);\135qH\158\135\222H\001\007\004\158\218" - ; types = - [ "t", Explicit_bind ([ "a" ], Apply (Implicit_var 0, [ Explicit_var 0 ])) ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ option_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "option.ml" - } - in - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("t", _the_group) - in - t_sexp_grammar + let (t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t) = + fun _'a_sexp_grammar -> option_sexp_grammar _'a_sexp_grammar ;; [@@@end] @@ -56,21 +33,18 @@ end : sig type 'a t = 'a option [@@deriving_inline compare, hash, sexp, sexp_grammar] - val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t + include Ppx_hash_lib.Hashable.S1 with type 'a t := 'a t + include Sexplib0.Sexpable.S1 with type 'a t := 'a t - val hash_fold_t - : (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) - -> Ppx_hash_lib.Std.Hash.state - -> 'a t - -> Ppx_hash_lib.Std.Hash.state - - include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t := 'a t - - val t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t + val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] -end -with type 'a t := 'a t) +end) + +type 'a t = 'a option = + | None + | Some of 'a let is_none = function | None -> true @@ -96,12 +70,6 @@ let iter o ~f = let invariant f t = iter t ~f -let map2 o1 o2 ~f = - match o1, o2 with - | Some a1, Some a2 -> Some (f a1 a2) - | _ -> None -;; - let call x ~f = match f with | None -> () @@ -136,6 +104,12 @@ let value_exn ?here ?error ?message t = Error.raise error ;; +let value_or_thunk o ~default = + match o with + | Some x -> x + | None -> default () +;; + let to_array t = match t with | None -> [||] @@ -152,9 +126,7 @@ let min_elt t ~compare:_ = t let max_elt t ~compare:_ = t let sum (type a) (module M : Container.Summable with type t = a) t ~f = - match t with - | None -> M.zero - | Some x -> f x + value_map t ~default:M.zero ~f ;; let for_all t ~f = @@ -198,7 +170,7 @@ let count t ~f = let find t ~f = match t with | None -> None - | Some x -> if f x then Some x else None + | Some x -> if f x then t else None ;; let find_map t ~f = @@ -216,12 +188,6 @@ let equal f t t' = let some x = Some x -let both x y = - match x, y with - | Some a, Some b -> Some (a, b) - | _ -> None -;; - let first_some x y = match x with | Some _ -> x @@ -254,32 +220,34 @@ let try_with_join f = | exception _ -> None ;; -include Monad.Make (struct - type 'a t = 'a option +let map t ~f = + match t with + | None -> None + | Some a -> Some (f a) +;; - let return x = Some x +let apply f x = + match f with + | None -> None + | Some f -> map ~f x +;; - let map t ~f = - match t with - | None -> None - | Some a -> Some (f a) - ;; +module Monad_arg = struct + type 'a t = 'a option - let map = `Custom map + let return x = Some x + let apply = apply + let map = `Custom map - let bind o ~f = - match o with - | None -> None - | Some x -> f x - ;; - end) + let bind o ~f = + match o with + | None -> None + | Some x -> f x + ;; +end + +include Monad.Make (Monad_arg) +include Applicative.Make (Monad_arg) 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 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) -;; diff --git a/src/option.mli b/src/option.mli index acc2ab9..02b41ea 100644 --- a/src/option.mli +++ b/src/option.mli @@ -1,58 +1,73 @@ -(** Option type. *) +(** The option type indicates whether a meaningful value is present. It is frequently used + to represent success or failure, using [None] for failure. To be more descriptive + about why a function failed, see the {!Or_error} module. + + Usage example from a utop session follows. Hash table lookups use the option type to + indicate success or failure when looking up a key. + + {v + # let h = Hashtbl.of_alist (module String) [ ("Bar", "Value") ];; + val h : (string, string) Hashtbl.t = <abstr>;; + - : (string, string) Hashtbl.t = <abstr> + # Hashtbl.find h "Foo";; + - : string option = None + # Hashtbl.find h "Bar";; + - : string option = Some "Value" + v} *) open! Import +(** {2 Type and Interfaces} *) + type 'a t = 'a option = | None | Some of 'a -[@@deriving_inline compare, hash, sexp, sexp_grammar] - -val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int - -val hash_fold_t - : (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) - -> Ppx_hash_lib.Std.Hash.state - -> 'a t - -> Ppx_hash_lib.Std.Hash.state +[@@deriving_inline compare, hash, sexp_grammar] -include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t := 'a t +include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t +include Ppx_hash_lib.Hashable.S1 with type 'a t := 'a t -val t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t +val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] -include Container.S1 with type 'a t := 'a t include Equal.S1 with type 'a t := 'a t include Invariant.S1 with type 'a t := 'a t +include Sexpable.S1 with type 'a t := 'a t -(** Options form a monad, where [return x = Some x], [(None >>= f) = None], and [(Some x - >>= f) = f x]. *) -include - Monad.S with type 'a t := 'a t +(** {3 Applicative interface} -(** [is_none t] returns true iff [t = None]. *) -val is_none : 'a t -> bool + Options form an applicative, where: -(** [is_some t] returns true iff [t = Some x]. *) -val is_some : 'a t -> bool + {ul + {- [return x = Some x] } + {- [None <*> x = None] } + {- [Some f <*> None = None] } + {- [Some f <*> Some x = Some (f x)] }} +*) -(** [value_map ~default ~f] is the same as [function Some x -> f x | None -> default]. *) -val value_map : 'a t -> default:'b -> f:('a -> 'b) -> 'b +include Applicative.S with type 'a t := 'a t -(** [map2 o f] maps ['a option] and ['b option] to a ['c option] using [~f]. *) -val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t +(** {3 Monadic interface} -(** [call x f] runs an optional function [~f] on the argument. *) -val call : 'a -> f:('a -> unit) t -> unit + Options form a monad, where: + + {ul + {- [return x = Some x]} + {- [(None >>= f) = None]} + {- [(Some x >>= f) = f x]}} +*) + +include Monad.S with type 'a t := 'a t -(** [value None ~default] = [default] +(** {2 Extracting Underlying Values} *) - [value (Some x) ~default] = [x] *) +(** Extracts the underlying value if present, otherwise returns [default]. *) val value : 'a t -> default:'a -> 'a -(** [value_exn (Some x)] = [x]. [value_exn None] raises an error whose contents contain - the supplied [~here], [~error], and [message], or a default message if none are - supplied. *) +(** Extracts the underlying value, or raises if there is no value present. The + error raised can be augmented using the [~here], [~error], and [~message] + optional arguments. *) val value_exn : ?here:Source_code_position0.t -> ?error:Error.t @@ -60,10 +75,42 @@ val value_exn -> 'a t -> 'a -val some : 'a -> 'a t -val both : 'a t -> 'b t -> ('a * 'b) t -val first_some : 'a t -> 'a t -> 'a t -val some_if : bool -> 'a -> 'a t +(** Extracts the underlying value and applies [f] to it if present, otherwise returns + [default]. *) +val value_map : 'a t -> default:'b -> f:('a -> 'b) -> 'b + +(** Extracts the underlying value if present, otherwise executes and returns the result of + [default]. [default] is only executed if the underlying value is absent. *) +val value_or_thunk : 'a t -> default:(unit -> 'a) -> 'a + + +(** On [None], returns [init]. On [Some x], returns [f init x]. *) +val fold : 'a t -> init:'accum -> f:('accum -> 'a -> 'accum) -> 'accum + +(** Checks whether the provided element is there, using [equal]. *) +val mem : 'a t -> 'a -> equal:('a -> 'a -> bool) -> bool + +val length : 'a t -> int +val iter : 'a t -> f:('a -> unit) -> unit + +(** On [None], returns [false]. On [Some x], returns [f x]. *) +val exists : 'a t -> f:('a -> bool) -> bool + +(** On [None], returns [true]. On [Some x], returns [f x]. *) +val for_all : 'a t -> f:('a -> bool) -> bool + +(** [find t ~f] returns [t] if [t = Some x] and [f x = true]; otherwise, [find] returns + [None]. *) +val find : 'a t -> f:('a -> bool) -> 'a option + +(** On [None], returns [None]. On [Some x], returns [f x]. *) +val find_map : 'a t -> f:('a -> 'b option) -> 'b option + +val to_list : 'a t -> 'a list +val to_array : 'a t -> 'a array + +(** [call x f] runs an optional function [~f] on the argument. *) +val call : 'a -> f:('a -> unit) t -> unit (** [merge a b ~f] merges together the values from [a] and [b] using [f]. If both [a] and [b] are [None], returns [None]. If only one is [Some], returns that one, and if both @@ -73,6 +120,8 @@ val merge : 'a t -> 'a t -> f:('a -> 'a -> 'a) -> 'a t val filter : 'a t -> f:('a -> bool) -> 'a t +(** {2 Constructors} *) + (** [try_with f] returns [Some x] if [f] returns [x] and [None] if [f] raises an exception. See [Result.try_with] if you'd like to know which exception. *) val try_with : (unit -> 'a) -> 'a t @@ -81,4 +130,52 @@ val try_with : (unit -> 'a) -> 'a t [None] if [f] raises an exception. *) val try_with_join : (unit -> 'a t) -> 'a t -val validate : none:unit Validate.check -> some:'a Validate.check -> 'a t Validate.check +(** Wraps the [Some] constructor as a function. *) +val some : 'a -> 'a t + +(** [first_some t1 t2] returns [t1] if it has an underlying value, or [t2] + otherwise. *) +val first_some : 'a t -> 'a t -> 'a t + +(** [some_if b x] converts a value [x] to [Some x] if [b], and [None] + otherwise. *) +val some_if : bool -> 'a -> 'a t + +(** {2 Predicates} *) + +(** [is_none t] returns true iff [t = None]. *) +val is_none : 'a t -> bool + +(** [is_some t] returns true iff [t = Some x]. *) +val is_some : 'a t -> bool + +(**/**) + +val is_empty : 'a t -> bool [@@deprecated "[since 2019-07] Use [is_none] instead"] + +val fold_result + : 'a t + -> init:'accum + -> f:('accum -> 'a -> ('accum, 'e) Result.t) + -> ('accum, 'e) Result.t +[@@deprecated "[since 2019-07] It is not a useful function"] + +val fold_until + : 'a t + -> init:'accum + -> f:('accum -> 'a -> ('accum, 'final) Container.Continue_or_stop.t) + -> finish:('accum -> 'final) + -> 'final +[@@deprecated "[since 2019-07] It is not a useful function"] + +val min_elt : 'a t -> compare:('a -> 'a -> int) -> 'a option +[@@deprecated "[since 2019-07] Use [Fn.id] instead"] + +val max_elt : 'a t -> compare:('a -> 'a -> int) -> 'a option +[@@deprecated "[since 2019-07] Use [Fn.id] instead"] + +val count : 'a t -> f:('a -> bool) -> int +[@@deprecated "[since 2019-07] Use pattern matching instead"] + +val sum : (module Container.Summable with type t = 'sum) -> 'a t -> f:('a -> 'sum) -> 'sum +[@@deprecated "[since 2019-07] Use [value_map ~default:Summable.zero ~f] instead"] diff --git a/src/option_array.ml b/src/option_array.ml index c743717..c6c10d0 100644 --- a/src/option_array.ml +++ b/src/option_array.ml @@ -16,8 +16,8 @@ open! Import through the module signature then it could decide to construct a float array instead. *) module Cheap_option = struct - (* This is taken from core_kernel. Rather than expose it in the public - interface of base, just keep a copy around here. *) + (* This is taken from core. Rather than expose it in the public interface of base, just + keep a copy around here. *) let phys_same (type a b) (a : a) (b : b) = phys_equal a (Caml.Obj.magic b : a) module T0 : sig @@ -29,6 +29,7 @@ module Cheap_option = struct val is_some : _ t -> bool val value_exn : 'a t -> 'a val value_unsafe : 'a t -> 'a + val iter_some : 'a t -> f:('a -> unit) -> unit end = struct type +'a t @@ -74,6 +75,8 @@ module Cheap_option = struct then value_unsafe x else failwith "Option_array.get_some_exn: the element is [None]" ;; + + let iter_some t ~f = if is_some t then f (value_unsafe t) end module T1 = struct @@ -84,24 +87,36 @@ module Cheap_option = struct | Some x -> some x ;; - let to_option x = if is_some x then Some (value_unsafe x) else None + let[@inline] to_option x = if is_some x then Some (value_unsafe x) else None let to_sexpable = to_option let of_sexpable = of_option + + let t_sexp_grammar (type a) (grammar : a Sexplib0.Sexp_grammar.t) + : a t Sexplib0.Sexp_grammar.t + = + Sexplib0.Sexp_grammar.coerce (Option.t_sexp_grammar grammar) + ;; end include T1 include Sexpable.Of_sexpable1 (Option) (T1) end -type 'a t = 'a Cheap_option.t Uniform_array.t [@@deriving_inline sexp] +type 'a t = 'a Cheap_option.t Uniform_array.t [@@deriving_inline sexp, sexp_grammar] -let t_of_sexp : 'a. (Ppx_sexp_conv_lib.Sexp.t -> 'a) -> Ppx_sexp_conv_lib.Sexp.t -> 'a t = - let _tp_loc = "option_array.ml.t" in - fun _of_a t -> Uniform_array.t_of_sexp (Cheap_option.t_of_sexp _of_a) t +let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = + fun _of_a__001_ x__003_ -> + Uniform_array.t_of_sexp (Cheap_option.t_of_sexp _of_a__001_) x__003_ ;; -let sexp_of_t : 'a. ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t = - fun _of_a v -> Uniform_array.sexp_of_t (Cheap_option.sexp_of_t _of_a) v +let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = + fun _of_a__004_ x__005_ -> + Uniform_array.sexp_of_t (Cheap_option.sexp_of_t _of_a__004_) x__005_ +;; + +let (t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t) = + fun _'a_sexp_grammar -> + Uniform_array.t_sexp_grammar (Cheap_option.t_sexp_grammar _'a_sexp_grammar) ;; [@@@end] @@ -111,7 +126,7 @@ let create ~len = Uniform_array.create ~len Cheap_option.none let init n ~f = Uniform_array.init n ~f:(fun i -> Cheap_option.of_option (f i)) let init_some n ~f = Uniform_array.init n ~f:(fun i -> Cheap_option.some (f i)) let length = Uniform_array.length -let get t i = Cheap_option.to_option (Uniform_array.get t i) +let[@inline] get t i = Cheap_option.to_option (Uniform_array.get t i) let get_some_exn t i = Cheap_option.value_exn (Uniform_array.get t i) let is_none t i = Cheap_option.is_none (Uniform_array.get t i) let is_some t i = Cheap_option.is_some (Uniform_array.get t i) @@ -137,6 +152,61 @@ let clear t = done ;; +let iteri input ~f = + for i = 0 to length input - 1 do + f i (unsafe_get input i) + done +;; + +let iter input ~f = iteri input ~f:(fun (_ : int) x -> f x) + +let foldi input ~init ~f = + let acc = ref init in + iteri input ~f:(fun i elem -> acc := f i !acc elem); + !acc +;; + +let fold input ~init ~f = foldi input ~init ~f:(fun (_ : int) acc x -> f acc x) + +include Indexed_container.Make_gen (struct + type nonrec 'a t = 'a t + type 'a elt = 'a option + + let fold = fold + let foldi = `Custom foldi + let iter = `Custom iter + let iteri = `Custom iteri + let length = `Custom length + end) + +let mapi input ~f = + let output = create ~len:(length input) in + iteri input ~f:(fun i elem -> unsafe_set output i (f i elem)); + output +;; + +let map input ~f = mapi input ~f:(fun (_ : int) elem -> f elem) + +let map_some input ~f = + let len = length input in + let output = create ~len in + let () = + for i = 0 to len - 1 do + let opt = Uniform_array.unsafe_get input i in + Cheap_option.iter_some opt ~f:(fun x -> unsafe_set_some output i (f x)) + done + in + output +;; + +let of_array array = init (Array.length array) ~f:(fun i -> Array.unsafe_get array i) + +let of_array_some array = + init_some (Array.length array) ~f:(fun i -> Array.unsafe_get array i) +;; + +let to_array t = Array.init (length t) ~f:(fun i -> unsafe_get t i) + include Blit.Make1_generic (struct type nonrec 'a t = 'a t diff --git a/src/option_array.mli b/src/option_array.mli index 33c9756..27493eb 100644 --- a/src/option_array.mli +++ b/src/option_array.mli @@ -5,9 +5,11 @@ open! Import -type 'a t [@@deriving_inline sexp] +type 'a t [@@deriving_inline sexp, sexp_grammar] -include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t := 'a t +include Sexplib0.Sexpable.S1 with type 'a t := 'a t + +val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] @@ -16,10 +18,13 @@ val empty : _ t (** Initially filled with all [None] *) val create : len:int -> _ t +include Indexed_container.Generic with type 'a t := 'a t and type 'a elt := 'a option val init_some : int -> f:(int -> 'a) -> 'a t val init : int -> f:(int -> 'a option) -> 'a t -val length : _ t -> int +val of_array : 'a option array -> 'a t +val of_array_some : 'a array -> 'a t +val to_array : 'a t -> 'a option Array.t (** [get t i] returns the element number [i] of array [t], raising if [i] is outside the range 0 to [length t - 1]. *) @@ -61,6 +66,14 @@ val swap : _ t -> int -> int -> unit (** Replaces all the elements of the array with [None]. *) val clear : _ t -> unit +(** [map f [|a1; ...; an|]] applies function [f] to [a1], [a2], ..., [an], in order, + and builds the option_array [[|f a1; ...; f an|]] with the results returned by [f]. *) +val map : 'a t -> f:('a option -> 'b option) -> 'b t + +(** [map_some t ~f] is like [map], but [None] elements always map to [None] and [Some] + always map to [Some]. *) +val map_some : 'a t -> f:('a -> 'b) -> 'b t + (** Unsafe versions of [set*]. Can cause arbitrary behaviour when used for an out-of-bounds array access. *) @@ -79,7 +92,7 @@ module For_testing : sig module Unsafe_cheap_option : sig type 'a t [@@deriving_inline sexp] - include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t := 'a t + include Sexplib0.Sexpable.S1 with type 'a t := 'a t [@@@end] diff --git a/src/or_error.ml b/src/or_error.ml index 817697c..99b957e 100644 --- a/src/or_error.ml +++ b/src/or_error.ml @@ -1,6 +1,14 @@ open! Import -type 'a t = ('a, Error.t) Result.t [@@deriving_inline compare, equal, hash, sexp] +include ( + Result : + module type of struct + include Result + end + with module Error := Result.Error) + +type 'a t = ('a, Error.t) Result.t +[@@deriving_inline compare, equal, hash, sexp, sexp_grammar] let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = fun _cmp__a a__001_ b__002_ -> Result.compare _cmp__a Error.compare a__001_ b__002_ @@ -11,19 +19,25 @@ let equal : 'a. ('a -> 'a -> bool) -> 'a t -> 'a t -> bool = ;; let hash_fold_t : - 'a. (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) - -> Ppx_hash_lib.Std.Hash.state -> 'a t -> Ppx_hash_lib.Std.Hash.state + 'a. + (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) + -> Ppx_hash_lib.Std.Hash.state + -> 'a t + -> Ppx_hash_lib.Std.Hash.state = fun _hash_fold_a hsv arg -> Result.hash_fold_t _hash_fold_a Error.hash_fold_t hsv arg ;; -let t_of_sexp : 'a. (Ppx_sexp_conv_lib.Sexp.t -> 'a) -> Ppx_sexp_conv_lib.Sexp.t -> 'a t = - let _tp_loc = "or_error.ml.t" in - fun _of_a t -> Result.t_of_sexp _of_a Error.t_of_sexp t +let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = + fun _of_a__013_ x__015_ -> Result.t_of_sexp _of_a__013_ Error.t_of_sexp x__015_ +;; + +let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = + fun _of_a__016_ x__017_ -> Result.sexp_of_t _of_a__016_ Error.sexp_of_t x__017_ ;; -let sexp_of_t : 'a. ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t = - fun _of_a v -> Result.sexp_of_t _of_a Error.sexp_of_t v +let (t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t) = + fun _'a_sexp_grammar -> Result.t_sexp_grammar _'a_sexp_grammar Error.t_sexp_grammar ;; [@@@end] @@ -34,12 +48,6 @@ let invariant invariant_a t = | Error error -> Error.invariant error ;; -include ( - Result : - Monad.S2 - with type ('a, 'b) t := ('a, 'b) Result.t - with module Let_syntax := Result.Let_syntax) - include Applicative.Make (struct type nonrec 'a t = 'a t @@ -91,12 +99,16 @@ let of_exn_result ?backtrace = function | Error exn -> of_exn ?backtrace exn ;; -let error ?strict message a sexp_of_a = Error (Error.create ?strict message a sexp_of_a) +let error ?here ?strict message a sexp_of_a = + Error (Error.create ?here ?strict message a sexp_of_a) +;; + let error_s sexp = Error (Error.create_s sexp) let error_string message = Error (Error.of_string message) let errorf format = Printf.ksprintf error_string format let tag t ~tag = Result.map_error t ~f:(Error.tag ~tag) let tag_s t ~tag = Result.map_error t ~f:(Error.tag_s ~tag) +let tag_s_lazy t ~tag = Result.map_error t ~f:(Error.tag_s_lazy ~tag) let tag_arg t message a sexp_of_a = Result.map_error t ~f:(fun e -> Error.tag_arg e message a sexp_of_a) diff --git a/src/or_error.mli b/src/or_error.mli index 6cd2c40..6852b41 100644 --- a/src/or_error.mli +++ b/src/or_error.mli @@ -9,18 +9,15 @@ open! Import (** Serialization and comparison of an [Error] force the error's lazy message. *) -type 'a t = ('a, Error.t) Result.t [@@deriving_inline compare, equal, hash, sexp] +type 'a t = ('a, Error.t) Result.t +[@@deriving_inline compare, equal, hash, sexp, sexp_grammar] -val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int -val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool +include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t +include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t +include Ppx_hash_lib.Hashable.S1 with type 'a t := 'a t +include Sexplib0.Sexpable.S1 with type 'a t := 'a t -val hash_fold_t - : (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) - -> Ppx_hash_lib.Std.Hash.state - -> 'a t - -> Ppx_hash_lib.Std.Hash.state - -include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t := 'a t +val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] @@ -28,8 +25,7 @@ include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t := 'a t [Applicative.Of_Monad(Or_error)] would give -- [apply (Error e1) (Error e2)] returns the combination of [e1] and [e2], whereas it would only return [e1] if it were defined using [bind]. *) -include - Applicative.S with type 'a t := 'a t +include Applicative.S with type 'a t := 'a t include Invariant.S1 with type 'a t := 'a t include Monad.S with type 'a t := 'a t @@ -72,7 +68,13 @@ val of_exn_result : ?backtrace:[ `Get | `This of string ] -> ('a, exn) Result.t to a sexp. So, if [a] is mutated in the time between the call to [create] and the sexp conversion, those mutations will be reflected in the sexp. Use [~strict:()] to force [sexp_of_a a] to be computed immediately. *) -val error : ?strict:unit -> string -> 'a -> ('a -> Sexp.t) -> _ t +val error + : ?here:Source_code_position0.t + -> ?strict:unit + -> string + -> 'a + -> ('a -> Sexp.t) + -> _ t val error_s : Sexp.t -> _ t @@ -84,11 +86,16 @@ val error_string : string -> _ t instead. *) val errorf : ('a, unit, string, _ t) format4 -> 'a -(** [tag t ~tag] is [Result.map_error t ~f:(Error.tag ~tag)]. - [tag_arg] is similar. *) +(** [tag t ~tag] is [Result.map_error t ~f:(Error.tag ~tag)]. *) val tag : 'a t -> tag:string -> 'a t +(** [tag_s] is like [tag] with a sexp tag. *) val tag_s : 'a t -> tag:Sexp.t -> 'a t + +(** [tag_s_lazy] is like [tag] with a lazy sexp tag. *) +val tag_s_lazy : 'a t -> tag:Sexp.t Lazy.t -> 'a t + +(** [tag_arg] is like [tag], with a tag that has a sexpable argument. *) val tag_arg : 'a t -> string -> 'b -> ('b -> Sexp.t) -> 'a t (** For marking a given value as unimplemented. Typically combined with conditional diff --git a/src/ordered_collection_common.ml b/src/ordered_collection_common.ml index bcdd70f..42d7db0 100644 --- a/src/ordered_collection_common.ml +++ b/src/ordered_collection_common.ml @@ -1,49 +1,7 @@ open! Import - -let invalid_argf = Printf.invalid_argf - -let slow_check_pos_len_exn ~pos ~len ~total_length = - if pos < 0 then invalid_argf "Negative position: %d" pos (); - if len < 0 then invalid_argf "Negative length: %d" len (); - (* We use [pos > total_length - len] rather than [pos + len > total_length] to avoid the - possibility of overflow. *) - if pos > total_length - len - then invalid_argf "pos + len past end: %d + %d > %d" pos len total_length () -[@@cold] [@@inline never] [@@local never] [@@specialise never] -;; - -let check_pos_len_exn ~pos ~len ~total_length = - (* This is better than [slow_check_pos_len_exn] for two reasons: - - - much less inlined code - - only one conditional jump - - The reason it works is that checking [< 0] is testing the highest order bit, so - [a < 0 || b < 0] is the same as [a lor b < 0]. - - [pos + len] can overflow, so [pos > total_length - len] is not equivalent to - [total_length - len - pos < 0], we need to test for [pos + len] overflow as - well. *) - let stop = pos + len in - if pos lor len lor stop lor (total_length - stop) < 0 - then slow_check_pos_len_exn ~pos ~len ~total_length -;; - -let get_pos_len_exn ?(pos = 0) ?len () ~total_length = - let len = - match len with - | Some i -> i - | None -> total_length - pos - in - check_pos_len_exn ~pos ~len ~total_length; - pos, len -;; +include Ordered_collection_common0 let get_pos_len ?pos ?len () ~total_length = try Result.Ok (get_pos_len_exn () ?pos ?len ~total_length) with | Invalid_argument s -> Or_error.error_string s ;; - -module Private = struct - let slow_check_pos_len_exn = slow_check_pos_len_exn -end diff --git a/src/ordered_collection_common.mli b/src/ordered_collection_common.mli index cf19ec3..7d7231e 100644 --- a/src/ordered_collection_common.mli +++ b/src/ordered_collection_common.mli @@ -2,44 +2,12 @@ open! Import -(** [get_pos_len], [get_pos_len_exn], and [check_pos_len_exn] are intended to be used - by functions that take a sequence (array, string, bigstring, ...) and an optional - [pos] and [len] specifying a subrange of the sequence. Such functions should call - [get_pos_len] with the length of the sequence and the optional [pos] and [len], and it - will return the [pos] and [len] specifying the range, where the default [pos] is zero - and the default [len] is to go to the end of the sequence. +include module type of Ordered_collection_common0 (** @inline *) - It should be the case that: - - {[ - pos >= 0 && len >= 0 && pos + len <= total_length - ]} - - Note that this allows [pos = total_length] and [len = 0], i.e., an empty subrange - at the end of the sequence. - - [get_pos_len] returns [(pos', len')] specifying a subrange where: - - {v - pos' = match pos with None -> 0 | Some i -> i - len' = match len with None -> total_length - pos' | Some i -> i - v} *) +(** Like [get_pos_len_exn]. Returns an [Or_error.t]. *) val get_pos_len : ?pos:int -> ?len:int -> unit -> total_length:int -> (int * int) Or_error.t - -val get_pos_len_exn : ?pos:int -> ?len:int -> unit -> total_length:int -> int * int - -(** [check_pos_len_exn ~pos ~len ~total_length] raises unless [pos >= 0 && len >= 0 && - pos + len <= total_length]. *) -val check_pos_len_exn : pos:int -> len:int -> total_length:int -> unit - -(*_ See the Jane Street Style Guide for an explanation of [Private] submodules: - - https://opensource.janestreet.com/standards/#private-submodules *) -module Private : sig - val slow_check_pos_len_exn : pos:int -> len:int -> total_length:int -> unit -end diff --git a/src/ordered_collection_common0.ml b/src/ordered_collection_common0.ml new file mode 100644 index 0000000..8bcdeab --- /dev/null +++ b/src/ordered_collection_common0.ml @@ -0,0 +1,46 @@ +(* Split off to avoid a cyclic dependency with [Or_error]. *) + +open! Import + +let invalid_argf = Printf.invalid_argf + +let slow_check_pos_len_exn ~pos ~len ~total_length = + if pos < 0 then invalid_argf "Negative position: %d" pos (); + if len < 0 then invalid_argf "Negative length: %d" len (); + (* We use [pos > total_length - len] rather than [pos + len > total_length] to avoid the + possibility of overflow. *) + if pos > total_length - len + then invalid_argf "pos + len past end: %d + %d > %d" pos len total_length () +[@@cold] [@@inline never] [@@local never] [@@specialise never] +;; + +let check_pos_len_exn ~pos ~len ~total_length = + (* This is better than [slow_check_pos_len_exn] for two reasons: + + - much less inlined code + - only one conditional jump + + The reason it works is that checking [< 0] is testing the highest order bit, so + [a < 0 || b < 0] is the same as [a lor b < 0]. + + [pos + len] can overflow, so [pos > total_length - len] is not equivalent to + [total_length - len - pos < 0], we need to test for [pos + len] overflow as + well. *) + let stop = pos + len in + if pos lor len lor stop lor (total_length - stop) < 0 + then slow_check_pos_len_exn ~pos ~len ~total_length +;; + +let get_pos_len_exn ?(pos = 0) ?len () ~total_length = + let len = + match len with + | Some i -> i + | None -> total_length - pos + in + check_pos_len_exn ~pos ~len ~total_length; + pos, len +;; + +module Private = struct + let slow_check_pos_len_exn = slow_check_pos_len_exn +end diff --git a/src/ordered_collection_common0.mli b/src/ordered_collection_common0.mli new file mode 100644 index 0000000..5bd6e70 --- /dev/null +++ b/src/ordered_collection_common0.mli @@ -0,0 +1,36 @@ +open! Import + +(** [get_pos_len_exn], and [check_pos_len_exn] are intended to be used + by functions that take a sequence (array, string, bigstring, ...) and an optional + [pos] and [len] specifying a subrange of the sequence. Such functions should call + [get_pos_len] with the length of the sequence and the optional [pos] and [len], and it + will return the [pos] and [len] specifying the range, where the default [pos] is zero + and the default [len] is to go to the end of the sequence. + + It should be the case that: + + {[ + pos >= 0 && len >= 0 && pos + len <= total_length + ]} + + Note that this allows [pos = total_length] and [len = 0], i.e., an empty subrange + at the end of the sequence. + + [get_pos_len_exn] returns [(pos', len')] specifying a subrange where: + + {v + pos' = match pos with None -> 0 | Some i -> i + len' = match len with None -> total_length - pos' | Some i -> i + v} *) +val get_pos_len_exn : ?pos:int -> ?len:int -> unit -> total_length:int -> int * int + +(** [check_pos_len_exn ~pos ~len ~total_length] raises unless [pos >= 0 && len >= 0 && + pos + len <= total_length]. *) +val check_pos_len_exn : pos:int -> len:int -> total_length:int -> unit + +(*_ See the Jane Street Style Guide for an explanation of [Private] submodules: + + https://opensource.janestreet.com/standards/#private-submodules *) +module Private : sig + val slow_check_pos_len_exn : pos:int -> len:int -> total_length:int -> unit +end diff --git a/src/ordering.ml b/src/ordering.ml index 513202b..5976e12 100644 --- a/src/ordering.ml +++ b/src/ordering.ml @@ -4,7 +4,7 @@ type t = | Less | Equal | Greater -[@@deriving_inline compare, hash, enumerate, sexp] +[@@deriving_inline compare, hash, enumerate, sexp, sexp_grammar] let compare = (Ppx_compare_lib.polymorphic_compare : t -> t -> int) @@ -29,32 +29,44 @@ let (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = let all = ([ Less; Equal; Greater ] : t list) let t_of_sexp = - (let _tp_loc = "ordering.ml.t" in + (let error_source__005_ = "ordering.ml.t" in function - | Ppx_sexp_conv_lib.Sexp.Atom ("less" | "Less") -> Less - | Ppx_sexp_conv_lib.Sexp.Atom ("equal" | "Equal") -> Equal - | Ppx_sexp_conv_lib.Sexp.Atom ("greater" | "Greater") -> Greater - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom ("less" | "Less") :: _) as - sexp -> Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom ("equal" | "Equal") :: _) - as sexp -> Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom ("greater" | "Greater") :: _) as sexp -> - Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.List _ :: _) as sexp -> - Ppx_sexp_conv_lib.Conv_error.nested_list_invalid_sum _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List [] as sexp -> - Ppx_sexp_conv_lib.Conv_error.empty_list_invalid_sum _tp_loc sexp - | sexp -> Ppx_sexp_conv_lib.Conv_error.unexpected_stag _tp_loc sexp - : Ppx_sexp_conv_lib.Sexp.t -> t) + | Sexplib0.Sexp.Atom ("less" | "Less") -> Less + | Sexplib0.Sexp.Atom ("equal" | "Equal") -> Equal + | Sexplib0.Sexp.Atom ("greater" | "Greater") -> Greater + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("less" | "Less") :: _) as sexp__006_ -> + Sexplib0.Sexp_conv_error.stag_no_args error_source__005_ sexp__006_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("equal" | "Equal") :: _) as sexp__006_ -> + Sexplib0.Sexp_conv_error.stag_no_args error_source__005_ sexp__006_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("greater" | "Greater") :: _) as sexp__006_ -> + Sexplib0.Sexp_conv_error.stag_no_args error_source__005_ sexp__006_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__004_ -> + Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__005_ sexp__004_ + | Sexplib0.Sexp.List [] as sexp__004_ -> + Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__005_ sexp__004_ + | sexp__004_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__005_ sexp__004_ + : Sexplib0.Sexp.t -> t) ;; let sexp_of_t = (function - | Less -> Ppx_sexp_conv_lib.Sexp.Atom "Less" - | Equal -> Ppx_sexp_conv_lib.Sexp.Atom "Equal" - | Greater -> Ppx_sexp_conv_lib.Sexp.Atom "Greater" - : t -> Ppx_sexp_conv_lib.Sexp.t) + | Less -> Sexplib0.Sexp.Atom "Less" + | Equal -> Sexplib0.Sexp.Atom "Equal" + | Greater -> Sexplib0.Sexp.Atom "Greater" + : t -> Sexplib0.Sexp.t) +;; + +let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = + { untyped = + Variant + { case_sensitivity = Case_sensitive_except_first_character + ; clauses = + [ No_tag { name = "Less"; clause_kind = Atom_clause } + ; No_tag { name = "Equal"; clause_kind = Atom_clause } + ; No_tag { name = "Greater"; clause_kind = Atom_clause } + ] + } + } ;; [@@@end] diff --git a/src/ordering.mli b/src/ordering.mli index 1c745fd..733c9a3 100644 --- a/src/ordering.mli +++ b/src/ordering.mli @@ -30,17 +30,19 @@ type t = | Less | Equal | Greater -[@@deriving_inline compare, enumerate, hash, sexp] +[@@deriving_inline compare, hash, sexp, sexp_grammar] -val compare : t -> t -> int -val all : t list -val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state -val hash : t -> Ppx_hash_lib.Std.Hash.hash_value +include Ppx_compare_lib.Comparable.S with type t := t +include Ppx_hash_lib.Hashable.S with type t := t +include Sexplib0.Sexpable.S with type t := t -include Ppx_sexp_conv_lib.Sexpable.S with type t := t +val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] +(*_ Avoid [@@deriving_inline enumerate] due to circular dependency *) +val all : t list + include Equal.S with type t := t (** [of_int n] is: diff --git a/src/ppx_compare_lib.ml b/src/ppx_compare_lib.ml index 3de1f45..daadf68 100644 --- a/src/ppx_compare_lib.ml +++ b/src/ppx_compare_lib.ml @@ -23,6 +23,58 @@ let equal_abstract ~type_name _ _ = type 'a compare = 'a -> 'a -> int type 'a equal = 'a -> 'a -> bool +module Comparable = struct + module type S = sig + type t + + val compare : t compare + end + + module type S1 = sig + type 'a t + + val compare : 'a compare -> 'a t compare + end + + module type S2 = sig + type ('a, 'b) t + + val compare : 'a compare -> 'b compare -> ('a, 'b) t compare + end + + module type S3 = sig + type ('a, 'b, 'c) t + + val compare : 'a compare -> 'b compare -> 'c compare -> ('a, 'b, 'c) t compare + end +end + +module Equal = struct + module type S = sig + type t + + val equal : t equal + end + + module type S1 = sig + type 'a t + + val equal : 'a equal -> 'a t equal + end + + module type S2 = sig + type ('a, 'b) t + + val equal : 'a equal -> 'b equal -> ('a, 'b) t equal + end + + module type S3 = sig + type ('a, 'b, 'c) t + + val equal : 'a equal -> 'b equal -> 'c equal -> ('a, 'b, 'c) t equal + end +end + module Builtin = struct let compare_bool : bool compare = Poly.compare let compare_char : char compare = Poly.compare diff --git a/src/ppx_compare_lib.mli b/src/ppx_compare_lib.mli index 629c72b..21e7c60 100644 --- a/src/ppx_compare_lib.mli +++ b/src/ppx_compare_lib.mli @@ -19,6 +19,58 @@ val compare_abstract : type_name:string -> _ compare val equal_abstract : type_name:string -> _ equal +module Comparable : sig + module type S = sig + type t + + val compare : t compare + end + + module type S1 = sig + type 'a t + + val compare : 'a compare -> 'a t compare + end + + module type S2 = sig + type ('a, 'b) t + + val compare : 'a compare -> 'b compare -> ('a, 'b) t compare + end + + module type S3 = sig + type ('a, 'b, 'c) t + + val compare : 'a compare -> 'b compare -> 'c compare -> ('a, 'b, 'c) t compare + end +end + +module Equal : sig + module type S = sig + type t + + val equal : t equal + end + + module type S1 = sig + type 'a t + + val equal : 'a equal -> 'a t equal + end + + module type S2 = sig + type ('a, 'b) t + + val equal : 'a equal -> 'b equal -> ('a, 'b) t equal + end + + module type S3 = sig + type ('a, 'b, 'c) t + + val equal : 'a equal -> 'b equal -> 'c equal -> ('a, 'b, 'c) t equal + end +end + module Builtin : sig val compare_bool : bool compare val compare_char : char compare diff --git a/src/ppx_enumerate_lib.ml b/src/ppx_enumerate_lib.ml index bde251f..ccb725c 100644 --- a/src/ppx_enumerate_lib.ml +++ b/src/ppx_enumerate_lib.ml @@ -1 +1,27 @@ module List = List + +module Enumerable = struct + module type S = sig + type t + + val all : t list + end + + module type S1 = sig + type 'a t + + val all : 'a list -> 'a t list + end + + module type S2 = sig + type ('a, 'b) t + + val all : 'a list -> 'b list -> ('a, 'b) t list + end + + module type S3 = sig + type ('a, 'b, 'c) t + + val all : 'a list -> 'b list -> 'c list -> ('a, 'b, 'c) t list + end +end diff --git a/src/ppx_hash_lib.ml b/src/ppx_hash_lib.ml index 119a1cc..84ae88a 100644 --- a/src/ppx_hash_lib.ml +++ b/src/ppx_hash_lib.ml @@ -2,3 +2,36 @@ module Std = struct module Hash = Hash (** @canonical Base.Hash *) end + +type 'a hash_fold = Std.Hash.state -> 'a -> Std.Hash.state + +module Hashable = struct + module type S = sig + type t + + val hash_fold_t : t hash_fold + val hash : t -> Std.Hash.hash_value + end + + module type S1 = sig + type 'a t + + val hash_fold_t : 'a hash_fold -> 'a t hash_fold + end + + module type S2 = sig + type ('a, 'b) t + + val hash_fold_t : 'a hash_fold -> 'b hash_fold -> ('a, 'b) t hash_fold + end + + module type S3 = sig + type ('a, 'b, 'c) t + + val hash_fold_t + : 'a hash_fold + -> 'b hash_fold + -> 'c hash_fold + -> ('a, 'b, 'c) t hash_fold + end +end diff --git a/src/ppx_sexp_conv_lib.ml b/src/ppx_sexp_conv_lib.ml deleted file mode 100644 index 9375c99..0000000 --- a/src/ppx_sexp_conv_lib.ml +++ /dev/null @@ -1,8 +0,0 @@ -include Sexplib -module Lazy_group_id = Sexplib0.Private.Lazy_group_id - -module Option = struct - type 'a t = 'a option = - | None - | Some of 'a -end diff --git a/src/pretty_printer.mli b/src/pretty_printer.mli index a5cfd36..69b14d0 100644 --- a/src/pretty_printer.mli +++ b/src/pretty_printer.mli @@ -8,8 +8,15 @@ ]} The names are actually OCaml identifier names, e.g., "Base.Int.pp". Code for - building toplevels (this code is not in Base) evaluates the strings to yield the - pretty printers and register them with the OCaml runtime. *) + building toplevels evaluates the strings to yield the + pretty printers and register them with the OCaml runtime. + + This module is only responsible for collecting the pretty-printers. Another mechanism + is needed to register this collection with the "toploop" library for pretty-printing + to actually happen. How to do that depends on how you build and deploy + the OCaml toplevel. One common way to do it in vanilla toplevel is to call + [#require "core.top"]. +*) open! Import diff --git a/src/queue.ml b/src/queue.ml index eb7ef95..bcee404 100644 --- a/src/queue.ml +++ b/src/queue.ml @@ -17,37 +17,36 @@ type 'a t = } [@@deriving_inline sexp_of] -let sexp_of_t : 'a. ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t = - fun _of_a -> function - | { num_mutations = v_num_mutations - ; front = v_front - ; mask = v_mask - ; length = v_length - ; elts = v_elts - } -> - let bnds = [] in - let bnds = - let arg = Option_array.sexp_of_t _of_a v_elts in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "elts"; arg ] :: bnds - in - let bnds = - let arg = sexp_of_int v_length in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "length"; arg ] :: bnds - in - let bnds = - let arg = sexp_of_int v_mask in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "mask"; arg ] :: bnds - in - let bnds = - let arg = sexp_of_int v_front in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "front"; arg ] :: bnds - in - let bnds = - let arg = sexp_of_int v_num_mutations in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "num_mutations"; arg ] - :: bnds - in - Ppx_sexp_conv_lib.Sexp.List bnds +let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = + fun _of_a__001_ + { num_mutations = num_mutations__003_ + ; front = front__005_ + ; mask = mask__007_ + ; length = length__009_ + ; elts = elts__011_ + } -> + let bnds__002_ = [] in + let bnds__002_ = + let arg__012_ = Option_array.sexp_of_t _of_a__001_ elts__011_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "elts"; arg__012_ ] :: bnds__002_ + in + let bnds__002_ = + let arg__010_ = sexp_of_int length__009_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "length"; arg__010_ ] :: bnds__002_ + in + let bnds__002_ = + let arg__008_ = sexp_of_int mask__007_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "mask"; arg__008_ ] :: bnds__002_ + in + let bnds__002_ = + let arg__006_ = sexp_of_int front__005_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "front"; arg__006_ ] :: bnds__002_ + in + let bnds__002_ = + let arg__004_ = sexp_of_int num_mutations__003_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "num_mutations"; arg__004_ ] :: bnds__002_ + in + Sexplib0.Sexp.List bnds__002_ ;; [@@@end] @@ -331,6 +330,14 @@ let iteri t ~f = done ;; +let to_list t = + let result = ref [] in + for i = t.length - 1 downto 0 do + result := unsafe_get t i :: !result + done; + !result +;; + module C = Indexed_container.Make (struct type nonrec 'a t = 'a t @@ -352,7 +359,6 @@ let max_elt = C.max_elt let mem = C.mem let min_elt = C.min_elt let sum = C.sum -let to_list = C.to_list let counti = C.counti let existsi = C.existsi let find_mapi = C.find_mapi @@ -481,3 +487,9 @@ let singleton x = let sexp_of_t sexp_of_a t = to_list t |> List.sexp_of_t sexp_of_a let t_of_sexp a_of_sexp sexp = List.t_of_sexp a_of_sexp sexp |> of_list + +let t_sexp_grammar (type a) (grammar : a Sexplib0.Sexp_grammar.t) + : a t Sexplib0.Sexp_grammar.t + = + Sexplib0.Sexp_grammar.coerce (List.t_sexp_grammar grammar) +;; diff --git a/src/queue_intf.ml b/src/queue_intf.ml index 0d65ebd..3b6f897 100644 --- a/src/queue_intf.ml +++ b/src/queue_intf.ml @@ -3,9 +3,11 @@ open! Import (** An interface for queues that follows Base's conventions, as opposed to OCaml's standard [Queue] module. *) module type S = sig - type 'a t [@@deriving_inline sexp] + type 'a t [@@deriving_inline sexp, sexp_grammar] - include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t := 'a t + include Sexplib0.Sexpable.S1 with type 'a t := 'a t + + val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] @@ -90,7 +92,7 @@ module type Queue = sig type 'a t [@@deriving_inline compare] - val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t [@@@end] @@ -1,50 +1,16 @@ open! Import -(* In the definition of [t], we do not have [[@@deriving compare, sexp]] because - in general, syntax extensions tend to use the implementation when available rather than - using the alias. Here that would lead to use the record representation [ { mutable - contents : 'a } ] which would result in different (and unwanted) behavior. *) -type 'a t = 'a ref = { mutable contents : 'a } - include ( struct type 'a t = 'a ref [@@deriving_inline compare, equal, sexp, sexp_grammar] let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = compare_ref let equal : 'a. ('a -> 'a -> bool) -> 'a t -> 'a t -> bool = equal_ref + let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = ref_of_sexp + let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = sexp_of_ref - let t_of_sexp : - 'a. (Ppx_sexp_conv_lib.Sexp.t -> 'a) -> Ppx_sexp_conv_lib.Sexp.t -> 'a t - = - ref_of_sexp - ;; - - let sexp_of_t : - 'a. ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t - = - sexp_of_ref - ;; - - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) - = - { implicit_vars = [ "ref" ] - ; ggid = "j\132);\135qH\158\135\222H\001\007\004\158\218" - ; types = - [ "t", Explicit_bind ([ "a" ], Apply (Implicit_var 0, [ Explicit_var 0 ])) ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ ref_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "ref.ml" - } - in - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("t", _the_group) - in - t_sexp_grammar + let (t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t) = + fun _'a_sexp_grammar -> ref_sexp_grammar _'a_sexp_grammar ;; [@@@end] @@ -52,16 +18,20 @@ end : sig type 'a t = 'a ref [@@deriving_inline compare, equal, sexp, sexp_grammar] - val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int - val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - - include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t := 'a t + include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t + include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t + include Sexplib0.Sexpable.S1 with type 'a t := 'a t - val t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t + val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] -end -with type 'a t := 'a t) +end) + +(* In the definition of [t], we do not have [[@@deriving compare, sexp]] because + in general, syntax extensions tend to use the implementation when available rather than + using the alias. Here that would lead to use the record representation [ { mutable + contents : 'a } ] which would result in different (and unwanted) behavior. *) +type 'a t = 'a ref = { mutable contents : 'a } external create : 'a -> 'a t = "%makemutable" external ( ! ) : 'a t -> 'a = "%field0" diff --git a/src/ref.mli b/src/ref.mli index 6754612..d385ca4 100644 --- a/src/ref.mli +++ b/src/ref.mli @@ -6,12 +6,11 @@ open! Import type 'a t = 'a Caml.ref = { mutable contents : 'a } [@@deriving_inline compare, equal, sexp, sexp_grammar] -val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int -val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool +include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t +include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t +include Sexplib0.Sexpable.S1 with type 'a t := 'a t -include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t := 'a t - -val t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t +val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] diff --git a/src/result.ml b/src/result.ml index d9966e2..a73a72f 100644 --- a/src/result.ml +++ b/src/result.ml @@ -4,85 +4,120 @@ module Either = Either0 type ('a, 'b) t = ('a, 'b) Caml.result = | Ok of 'a | Error of 'b -[@@deriving_inline sexp, compare, equal, hash] +[@@deriving_inline sexp, sexp_grammar, compare, equal, hash] -let t_of_sexp - : type a b. - (Ppx_sexp_conv_lib.Sexp.t -> a) - -> (Ppx_sexp_conv_lib.Sexp.t -> b) - -> Ppx_sexp_conv_lib.Sexp.t - -> (a, b) t +let t_of_sexp : + 'a 'b. + (Sexplib0.Sexp.t -> 'a) -> (Sexplib0.Sexp.t -> 'b) -> Sexplib0.Sexp.t -> ('a, 'b) t = - let _tp_loc = "result.ml.t" in - fun _of_a _of_b -> function - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom (("ok" | "Ok") as _tag) :: sexp_args) as _sexp -> - (match sexp_args with - | [ v0 ] -> - let v0 = _of_a v0 in - Ok v0 - | _ -> Ppx_sexp_conv_lib.Conv_error.stag_incorrect_n_args _tp_loc _tag _sexp) - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom (("error" | "Error") as _tag) :: sexp_args) as _sexp - -> - (match sexp_args with - | [ v0 ] -> - let v0 = _of_b v0 in - Error v0 - | _ -> Ppx_sexp_conv_lib.Conv_error.stag_incorrect_n_args _tp_loc _tag _sexp) - | Ppx_sexp_conv_lib.Sexp.Atom ("ok" | "Ok") as sexp -> - Ppx_sexp_conv_lib.Conv_error.stag_takes_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.Atom ("error" | "Error") as sexp -> - Ppx_sexp_conv_lib.Conv_error.stag_takes_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.List _ :: _) as sexp -> - Ppx_sexp_conv_lib.Conv_error.nested_list_invalid_sum _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List [] as sexp -> - Ppx_sexp_conv_lib.Conv_error.empty_list_invalid_sum _tp_loc sexp - | sexp -> Ppx_sexp_conv_lib.Conv_error.unexpected_stag _tp_loc sexp -;; - -let sexp_of_t - : type a b. - (a -> Ppx_sexp_conv_lib.Sexp.t) - -> (b -> Ppx_sexp_conv_lib.Sexp.t) - -> (a, b) t - -> Ppx_sexp_conv_lib.Sexp.t + fun (type a__017_ b__018_) + : ((Sexplib0.Sexp.t -> a__017_) -> (Sexplib0.Sexp.t -> b__018_) -> Sexplib0.Sexp.t + -> (a__017_, b__018_) t) -> + let error_source__005_ = "result.ml.t" in + fun _of_a__001_ _of_b__002_ -> function + | Sexplib0.Sexp.List + (Sexplib0.Sexp.Atom (("ok" | "Ok") as _tag__008_) :: sexp_args__009_) as + _sexp__007_ -> + (match sexp_args__009_ with + | [ arg0__010_ ] -> + let res0__011_ = _of_a__001_ arg0__010_ in + Ok res0__011_ + | _ -> + Sexplib0.Sexp_conv_error.stag_incorrect_n_args + error_source__005_ + _tag__008_ + _sexp__007_) + | Sexplib0.Sexp.List + (Sexplib0.Sexp.Atom (("error" | "Error") as _tag__013_) :: sexp_args__014_) as + _sexp__012_ -> + (match sexp_args__014_ with + | [ arg0__015_ ] -> + let res0__016_ = _of_b__002_ arg0__015_ in + Error res0__016_ + | _ -> + Sexplib0.Sexp_conv_error.stag_incorrect_n_args + error_source__005_ + _tag__013_ + _sexp__012_) + | Sexplib0.Sexp.Atom ("ok" | "Ok") as sexp__006_ -> + Sexplib0.Sexp_conv_error.stag_takes_args error_source__005_ sexp__006_ + | Sexplib0.Sexp.Atom ("error" | "Error") as sexp__006_ -> + Sexplib0.Sexp_conv_error.stag_takes_args error_source__005_ sexp__006_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__004_ -> + Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__005_ sexp__004_ + | Sexplib0.Sexp.List [] as sexp__004_ -> + Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__005_ sexp__004_ + | sexp__004_ -> + Sexplib0.Sexp_conv_error.unexpected_stag error_source__005_ sexp__004_ +;; + +let sexp_of_t : + 'a 'b. + ('a -> Sexplib0.Sexp.t) -> ('b -> Sexplib0.Sexp.t) -> ('a, 'b) t -> Sexplib0.Sexp.t + = + fun (type a__025_ b__026_) + : ((a__025_ -> Sexplib0.Sexp.t) -> (b__026_ -> Sexplib0.Sexp.t) + -> (a__025_, b__026_) t -> Sexplib0.Sexp.t) -> + fun _of_a__019_ _of_b__020_ -> function + | Ok arg0__021_ -> + let res0__022_ = _of_a__019_ arg0__021_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Ok"; res0__022_ ] + | Error arg0__023_ -> + let res0__024_ = _of_b__020_ arg0__023_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Error"; res0__024_ ] +;; + +let (t_sexp_grammar : + 'a Sexplib0.Sexp_grammar.t + -> 'b Sexplib0.Sexp_grammar.t + -> ('a, 'b) t Sexplib0.Sexp_grammar.t) = - fun _of_a _of_b -> function - | Ok v0 -> - let v0 = _of_a v0 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Ok"; v0 ] - | Error v0 -> - let v0 = _of_b v0 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Error"; v0 ] + fun _'a_sexp_grammar _'b_sexp_grammar -> + { untyped = + Variant + { case_sensitivity = Case_sensitive_except_first_character + ; clauses = + [ No_tag + { name = "Ok" + ; clause_kind = + List_clause { args = Cons (_'a_sexp_grammar.untyped, Empty) } + } + ; No_tag + { name = "Error" + ; clause_kind = + List_clause { args = Cons (_'b_sexp_grammar.untyped, Empty) } + } + ] + } + } ;; let compare : 'a 'b. ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int = - fun _cmp__a _cmp__b a__001_ b__002_ -> - if Ppx_compare_lib.phys_equal a__001_ b__002_ + fun _cmp__a _cmp__b a__027_ b__028_ -> + if Ppx_compare_lib.phys_equal a__027_ b__028_ then 0 else ( - match a__001_, b__002_ with - | Ok _a__003_, Ok _b__004_ -> _cmp__a _a__003_ _b__004_ + match a__027_, b__028_ with + | Ok _a__029_, Ok _b__030_ -> _cmp__a _a__029_ _b__030_ | Ok _, _ -> -1 | _, Ok _ -> 1 - | Error _a__005_, Error _b__006_ -> _cmp__b _a__005_ _b__006_) + | Error _a__031_, Error _b__032_ -> _cmp__b _a__031_ _b__032_) ;; let equal : 'a 'b. ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t -> bool = - fun _cmp__a _cmp__b a__007_ b__008_ -> - if Ppx_compare_lib.phys_equal a__007_ b__008_ + fun _cmp__a _cmp__b a__033_ b__034_ -> + if Ppx_compare_lib.phys_equal a__033_ b__034_ then true else ( - match a__007_, b__008_ with - | Ok _a__009_, Ok _b__010_ -> _cmp__a _a__009_ _b__010_ + match a__033_, b__034_ with + | Ok _a__035_, Ok _b__036_ -> _cmp__a _a__035_ _b__036_ | Ok _, _ -> false | _, Ok _ -> false - | Error _a__011_, Error _b__012_ -> _cmp__b _a__011_ _b__012_) + | Error _a__037_, Error _b__038_ -> _cmp__b _a__037_ _b__038_) ;; let hash_fold_t @@ -141,6 +176,19 @@ let map_error t ~f = | Error x -> Error (f x) ;; +module Error = Monad.Make2 (struct + type nonrec ('a, 'b) t = ('b, 'a) t + + let bind x ~f = + match x with + | Ok _ as ok -> ok + | Error e -> f e + ;; + + let map = `Custom map_error + let return e = Error e + end) + let is_ok = function | Ok _ -> true | Error _ -> false diff --git a/src/result.mli b/src/result.mli index 5143bb4..8031a1e 100644 --- a/src/result.mli +++ b/src/result.mli @@ -17,34 +17,23 @@ open! Import type ('ok, 'err) t = ('ok, 'err) Caml.result = | Ok of 'ok | Error of 'err -[@@deriving_inline sexp, compare, equal, hash] - -include Ppx_sexp_conv_lib.Sexpable.S2 with type ('ok, 'err) t := ('ok, 'err) t - -val compare - : ('ok -> 'ok -> int) - -> ('err -> 'err -> int) - -> ('ok, 'err) t - -> ('ok, 'err) t - -> int - -val equal - : ('ok -> 'ok -> bool) - -> ('err -> 'err -> bool) - -> ('ok, 'err) t - -> ('ok, 'err) t - -> bool - -val hash_fold_t - : (Ppx_hash_lib.Std.Hash.state -> 'ok -> Ppx_hash_lib.Std.Hash.state) - -> (Ppx_hash_lib.Std.Hash.state -> 'err -> Ppx_hash_lib.Std.Hash.state) - -> Ppx_hash_lib.Std.Hash.state - -> ('ok, 'err) t - -> Ppx_hash_lib.Std.Hash.state +[@@deriving_inline sexp, sexp_grammar, compare, equal, hash] + +include Sexplib0.Sexpable.S2 with type ('ok, 'err) t := ('ok, 'err) t + +val t_sexp_grammar + : 'ok Sexplib0.Sexp_grammar.t + -> 'err Sexplib0.Sexp_grammar.t + -> ('ok, 'err) t Sexplib0.Sexp_grammar.t + +include Ppx_compare_lib.Comparable.S2 with type ('ok, 'err) t := ('ok, 'err) t +include Ppx_compare_lib.Equal.S2 with type ('ok, 'err) t := ('ok, 'err) t +include Ppx_hash_lib.Hashable.S2 with type ('ok, 'err) t := ('ok, 'err) t [@@@end] include Monad.S2 with type ('a, 'err) t := ('a, 'err) t +module Error : Monad.S2 with type ('err, 'a) t := ('a, 'err) t include Invariant_intf.S2 with type ('ok, 'err) t := ('ok, 'err) t diff --git a/src/runtime.js b/src/runtime.js index 6bfdbeb..55ec813 100644 --- a/src/runtime.js +++ b/src/runtime.js @@ -10,6 +10,11 @@ function Base_clear_caml_backtrace_pos(x) { return 0; } +//Provides: Base_caml_exn_is_most_recent_exn const +function Base_caml_exn_is_most_recent_exn(x) { + return 1; +} + //Provides: Base_int_math_int32_clz const function Base_int_math_int32_clz(x) { var n = 32; diff --git a/src/sequence.ml b/src/sequence.ml index 6102cf8..cf3b05d 100644 --- a/src/sequence.ml +++ b/src/sequence.ml @@ -12,22 +12,25 @@ module Step = struct | Yield of 'a * 's [@@deriving_inline sexp_of] - let sexp_of_t - : type a s. - (a -> Ppx_sexp_conv_lib.Sexp.t) - -> (s -> Ppx_sexp_conv_lib.Sexp.t) - -> (a, s) t - -> Ppx_sexp_conv_lib.Sexp.t + let sexp_of_t : + 'a 's. + ('a -> Sexplib0.Sexp.t) + -> ('s -> Sexplib0.Sexp.t) + -> ('a, 's) t + -> Sexplib0.Sexp.t = - fun _of_a _of_s -> function - | Done -> Ppx_sexp_conv_lib.Sexp.Atom "Done" - | Skip v0 -> - let v0 = _of_s v0 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Skip"; v0 ] - | Yield (v0, v1) -> - let v0 = _of_a v0 - and v1 = _of_s v1 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Yield"; v0; v1 ] + fun (type a__009_ s__010_) + : ((a__009_ -> Sexplib0.Sexp.t) -> (s__010_ -> Sexplib0.Sexp.t) + -> (a__009_, s__010_) t -> Sexplib0.Sexp.t) -> + fun _of_a__001_ _of_s__002_ -> function + | Done -> Sexplib0.Sexp.Atom "Done" + | Skip arg0__003_ -> + let res0__004_ = _of_s__002_ arg0__003_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Skip"; res0__004_ ] + | Yield (arg0__005_, arg1__006_) -> + let res0__007_ = _of_a__001_ arg0__005_ + and res1__008_ = _of_s__002_ arg1__006_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Yield"; res0__007_; res1__008_ ] ;; [@@@end] @@ -444,25 +447,25 @@ module Merge_with_duplicates_element = struct | Left of 'a | Right of 'b | Both of 'a * 'b - [@@deriving_inline compare, hash, sexp] + [@@deriving_inline compare, hash, sexp, sexp_grammar] let compare : 'a 'b. ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int = - fun _cmp__a _cmp__b a__001_ b__002_ -> - if Ppx_compare_lib.phys_equal a__001_ b__002_ + fun _cmp__a _cmp__b a__011_ b__012_ -> + if Ppx_compare_lib.phys_equal a__011_ b__012_ then 0 else ( - match a__001_, b__002_ with - | Left _a__003_, Left _b__004_ -> _cmp__a _a__003_ _b__004_ + match a__011_, b__012_ with + | Left _a__013_, Left _b__014_ -> _cmp__a _a__013_ _b__014_ | Left _, _ -> -1 | _, Left _ -> 1 - | Right _a__005_, Right _b__006_ -> _cmp__b _a__005_ _b__006_ + | Right _a__015_, Right _b__016_ -> _cmp__b _a__015_ _b__016_ | Right _, _ -> -1 | _, Right _ -> 1 - | Both (_a__007_, _a__009_), Both (_b__008_, _b__010_) -> - (match _cmp__a _a__007_ _b__008_ with - | 0 -> _cmp__b _a__009_ _b__010_ + | Both (_a__017_, _a__019_), Both (_b__018_, _b__020_) -> + (match _cmp__a _a__017_ _b__018_ with + | 0 -> _cmp__b _a__019_ _b__020_ | n -> n)) ;; @@ -493,71 +496,125 @@ module Merge_with_duplicates_element = struct _hash_fold_b hsv _a1 ;; - let t_of_sexp - : type a b. - (Ppx_sexp_conv_lib.Sexp.t -> a) - -> (Ppx_sexp_conv_lib.Sexp.t -> b) - -> Ppx_sexp_conv_lib.Sexp.t - -> (a, b) t + let t_of_sexp : + 'a 'b. + (Sexplib0.Sexp.t -> 'a) + -> (Sexplib0.Sexp.t -> 'b) + -> Sexplib0.Sexp.t + -> ('a, 'b) t = - let _tp_loc = "sequence.ml.Merge_with_duplicates_element.t" in - fun _of_a _of_b -> function - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom (("left" | "Left") as _tag) :: sexp_args) as _sexp - -> - (match sexp_args with - | [ v0 ] -> - let v0 = _of_a v0 in - Left v0 - | _ -> Ppx_sexp_conv_lib.Conv_error.stag_incorrect_n_args _tp_loc _tag _sexp) - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom (("right" | "Right") as _tag) :: sexp_args) as - _sexp -> - (match sexp_args with - | [ v0 ] -> - let v0 = _of_b v0 in - Right v0 - | _ -> Ppx_sexp_conv_lib.Conv_error.stag_incorrect_n_args _tp_loc _tag _sexp) - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom (("both" | "Both") as _tag) :: sexp_args) as _sexp - -> - (match sexp_args with - | [ v0; v1 ] -> - let v0 = _of_a v0 - and v1 = _of_b v1 in - Both (v0, v1) - | _ -> Ppx_sexp_conv_lib.Conv_error.stag_incorrect_n_args _tp_loc _tag _sexp) - | Ppx_sexp_conv_lib.Sexp.Atom ("left" | "Left") as sexp -> - Ppx_sexp_conv_lib.Conv_error.stag_takes_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.Atom ("right" | "Right") as sexp -> - Ppx_sexp_conv_lib.Conv_error.stag_takes_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.Atom ("both" | "Both") as sexp -> - Ppx_sexp_conv_lib.Conv_error.stag_takes_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.List _ :: _) as sexp -> - Ppx_sexp_conv_lib.Conv_error.nested_list_invalid_sum _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List [] as sexp -> - Ppx_sexp_conv_lib.Conv_error.empty_list_invalid_sum _tp_loc sexp - | sexp -> Ppx_sexp_conv_lib.Conv_error.unexpected_stag _tp_loc sexp + fun (type a__044_ b__045_) + : ((Sexplib0.Sexp.t -> a__044_) -> (Sexplib0.Sexp.t -> b__045_) + -> Sexplib0.Sexp.t -> (a__044_, b__045_) t) -> + let error_source__025_ = "sequence.ml.Merge_with_duplicates_element.t" in + fun _of_a__021_ _of_b__022_ -> function + | Sexplib0.Sexp.List + (Sexplib0.Sexp.Atom (("left" | "Left") as _tag__028_) :: sexp_args__029_) as + _sexp__027_ -> + (match sexp_args__029_ with + | [ arg0__030_ ] -> + let res0__031_ = _of_a__021_ arg0__030_ in + Left res0__031_ + | _ -> + Sexplib0.Sexp_conv_error.stag_incorrect_n_args + error_source__025_ + _tag__028_ + _sexp__027_) + | Sexplib0.Sexp.List + (Sexplib0.Sexp.Atom (("right" | "Right") as _tag__033_) :: sexp_args__034_) as + _sexp__032_ -> + (match sexp_args__034_ with + | [ arg0__035_ ] -> + let res0__036_ = _of_b__022_ arg0__035_ in + Right res0__036_ + | _ -> + Sexplib0.Sexp_conv_error.stag_incorrect_n_args + error_source__025_ + _tag__033_ + _sexp__032_) + | Sexplib0.Sexp.List + (Sexplib0.Sexp.Atom (("both" | "Both") as _tag__038_) :: sexp_args__039_) as + _sexp__037_ -> + (match sexp_args__039_ with + | [ arg0__040_; arg1__041_ ] -> + let res0__042_ = _of_a__021_ arg0__040_ + and res1__043_ = _of_b__022_ arg1__041_ in + Both (res0__042_, res1__043_) + | _ -> + Sexplib0.Sexp_conv_error.stag_incorrect_n_args + error_source__025_ + _tag__038_ + _sexp__037_) + | Sexplib0.Sexp.Atom ("left" | "Left") as sexp__026_ -> + Sexplib0.Sexp_conv_error.stag_takes_args error_source__025_ sexp__026_ + | Sexplib0.Sexp.Atom ("right" | "Right") as sexp__026_ -> + Sexplib0.Sexp_conv_error.stag_takes_args error_source__025_ sexp__026_ + | Sexplib0.Sexp.Atom ("both" | "Both") as sexp__026_ -> + Sexplib0.Sexp_conv_error.stag_takes_args error_source__025_ sexp__026_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__024_ -> + Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__025_ sexp__024_ + | Sexplib0.Sexp.List [] as sexp__024_ -> + Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__025_ sexp__024_ + | sexp__024_ -> + Sexplib0.Sexp_conv_error.unexpected_stag error_source__025_ sexp__024_ ;; - let sexp_of_t - : type a b. - (a -> Ppx_sexp_conv_lib.Sexp.t) - -> (b -> Ppx_sexp_conv_lib.Sexp.t) - -> (a, b) t - -> Ppx_sexp_conv_lib.Sexp.t + let sexp_of_t : + 'a 'b. + ('a -> Sexplib0.Sexp.t) + -> ('b -> Sexplib0.Sexp.t) + -> ('a, 'b) t + -> Sexplib0.Sexp.t = - fun _of_a _of_b -> function - | Left v0 -> - let v0 = _of_a v0 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Left"; v0 ] - | Right v0 -> - let v0 = _of_b v0 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Right"; v0 ] - | Both (v0, v1) -> - let v0 = _of_a v0 - and v1 = _of_b v1 in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "Both"; v0; v1 ] + fun (type a__056_ b__057_) + : ((a__056_ -> Sexplib0.Sexp.t) -> (b__057_ -> Sexplib0.Sexp.t) + -> (a__056_, b__057_) t -> Sexplib0.Sexp.t) -> + fun _of_a__046_ _of_b__047_ -> function + | Left arg0__048_ -> + let res0__049_ = _of_a__046_ arg0__048_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Left"; res0__049_ ] + | Right arg0__050_ -> + let res0__051_ = _of_b__047_ arg0__050_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Right"; res0__051_ ] + | Both (arg0__052_, arg1__053_) -> + let res0__054_ = _of_a__046_ arg0__052_ + and res1__055_ = _of_b__047_ arg1__053_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Both"; res0__054_; res1__055_ ] + ;; + + let (t_sexp_grammar : + 'a Sexplib0.Sexp_grammar.t + -> 'b Sexplib0.Sexp_grammar.t + -> ('a, 'b) t Sexplib0.Sexp_grammar.t) + = + fun _'a_sexp_grammar _'b_sexp_grammar -> + { untyped = + Variant + { case_sensitivity = Case_sensitive_except_first_character + ; clauses = + [ No_tag + { name = "Left" + ; clause_kind = + List_clause { args = Cons (_'a_sexp_grammar.untyped, Empty) } + } + ; No_tag + { name = "Right" + ; clause_kind = + List_clause { args = Cons (_'b_sexp_grammar.untyped, Empty) } + } + ; No_tag + { name = "Both" + ; clause_kind = + List_clause + { args = + Cons + ( _'a_sexp_grammar.untyped + , Cons (_'b_sexp_grammar.untyped, Empty) ) + } + } + ] + } + } ;; [@@@end] @@ -583,11 +640,33 @@ let merge_with_duplicates (Sequence (s1, next1)) (Sequence (s2, next2)) ~compare Sequence ((Skip s1, Skip s2), next) ;; -let merge s1 s2 ~compare = +let merge_deduped_and_sorted s1 s2 ~compare = map (merge_with_duplicates s1 s2 ~compare) ~f:(function | Left x | Right x | Both (x, _) -> x) ;; +let (merge [@deprecated + "[since 2021-07] For identical behavior, use \ + [Sequence.merge_deduped_and_sorted], but consider using \ + [Sequence.merge_sorted] instead."]) + = + merge_deduped_and_sorted +;; + +let merge_sorted (Sequence (s1, next1)) (Sequence (s2, next2)) ~compare = + let next = function + | Skip s1, s2 -> Skip (next1 s1, s2) + | s1, Skip s2 -> Skip (s1, next2 s2) + | (Yield (a, s1') as s1), (Yield (b, s2') as s2) -> + let comparison = compare a b in + if comparison <= 0 then Yield (a, (Skip s1', s2)) else Yield (b, (s1, Skip s2')) + | Done, Done -> Done + | Yield (a, s1), Done -> Yield (a, (Skip s1, Done)) + | Done, Yield (b, s2) -> Yield (b, (Done, Skip s2)) + in + Sequence ((Skip s1, Skip s2), next) +;; + let hd s = let rec loop s next = match next s with diff --git a/src/sequence.mli b/src/sequence.mli index fd4ff53..677e6c9 100644 --- a/src/sequence.mli +++ b/src/sequence.mli @@ -31,14 +31,15 @@ open! Import -type +'a t [@@deriving_inline compare, equal, sexp_of] +type +'a t [@@deriving_inline sexp_of] -val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int -val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool -val sexp_of_t : ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t +val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t [@@@end] +include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t +include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t + type 'a sequence = 'a t include Indexed_container.S1 with type 'a t := 'a t @@ -68,10 +69,10 @@ module Step : sig [@@deriving_inline sexp_of] val sexp_of_t - : ('a -> Ppx_sexp_conv_lib.Sexp.t) - -> ('s -> Ppx_sexp_conv_lib.Sexp.t) + : ('a -> Sexplib0.Sexp.t) + -> ('s -> Sexplib0.Sexp.t) -> ('a, 's) t - -> Ppx_sexp_conv_lib.Sexp.t + -> Sexplib0.Sexp.t [@@@end] end @@ -114,28 +115,39 @@ val mapi : 'a t -> f:(int -> 'a -> 'b) -> 'b t val filteri : 'a t -> f:(int -> 'a -> bool) -> 'a t val filter : 'a t -> f:('a -> bool) -> 'a t -(** [merge t1 t2 ~compare] merges two sorted sequences [t1] and [t2], returning a sorted - sequence, all according to [compare]. If two elements are equal, the one from [t1] is - preferred. The behavior is undefined if the inputs aren't sorted. *) +(** If [t1] and [t2] are each sorted without duplicates, [merge_deduped_and_sorted t1 t2 + ~compare] merges [t1] and [t2] into a sorted sequence without duplicates. Whenever + identical elements are found in both [t1] and [t2], the one from [t1] is used and the + one from [t2] is discarded. The behavior is undefined if the inputs aren't sorted or + contain duplicates. *) +val merge_deduped_and_sorted : 'a t -> 'a t -> compare:('a -> 'a -> int) -> 'a t + val merge : 'a t -> 'a t -> compare:('a -> 'a -> int) -> 'a t +[@@deprecated + "[since 2021-07] For identical behavior, use [Sequence.merge_deduped_and_sorted], \ + but consider using [Sequence.merge_sorted] instead."] + +(** If [t1] and [t2] are each sorted, [merge_sorted t1 t2 ~compare] merges [t1] and [t2] + into a sorted sequence. Whenever identical elements are found in both [t1] and [t2], + the one from [t1] is used first. The behavior is undefined if the inputs aren't + sorted. *) +val merge_sorted : 'a t -> 'a t -> compare:('a -> 'a -> int) -> 'a t module Merge_with_duplicates_element : sig type ('a, 'b) t = | Left of 'a | Right of 'b | Both of 'a * 'b - [@@deriving_inline compare, hash, sexp] - - val compare : ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int + [@@deriving_inline compare, hash, sexp, sexp_grammar] - val hash_fold_t - : (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) - -> (Ppx_hash_lib.Std.Hash.state -> 'b -> Ppx_hash_lib.Std.Hash.state) - -> Ppx_hash_lib.Std.Hash.state - -> ('a, 'b) t - -> Ppx_hash_lib.Std.Hash.state + include Ppx_compare_lib.Comparable.S2 with type ('a, 'b) t := ('a, 'b) t + include Ppx_hash_lib.Hashable.S2 with type ('a, 'b) t := ('a, 'b) t + include Sexplib0.Sexpable.S2 with type ('a, 'b) t := ('a, 'b) t - include Ppx_sexp_conv_lib.Sexpable.S2 with type ('a, 'b) t := ('a, 'b) t + val t_sexp_grammar + : 'a Sexplib0.Sexp_grammar.t + -> 'b Sexplib0.Sexp_grammar.t + -> ('a, 'b) t Sexplib0.Sexp_grammar.t [@@@end] end @@ -113,7 +113,7 @@ module Tree0 = struct ;; (* We must call [f] with increasing indexes, because the bin_prot reader in - Core_kernel.Set needs it. *) + Core.Set needs it. *) let of_increasing_iterator_unchecked ~len ~f = let rec loop n ~f i = match n with @@ -160,14 +160,12 @@ module Tree0 = struct with_return (fun r -> let increasing = match compare_elt array.(0) array.(1) with - | 0 -> - r.return (Or_error.error_string "of_sorted_array: duplicated elements") + | 0 -> r.return (Or_error.error_string "of_sorted_array: duplicated elements") | i -> i < 0 in for i = 1 to Array.length array - 2 do match compare_elt array.(i) array.(i + 1) with - | 0 -> - r.return (Or_error.error_string "of_sorted_array: duplicated elements") + | 0 -> r.return (Or_error.error_string "of_sorted_array: duplicated elements") | i -> if Poly.( <> ) (i < 0) increasing then @@ -214,7 +212,7 @@ module Tree0 = struct then ( match r with | Empty -> assert false - | Leaf rv -> create (create l v Empty) rv Empty + | Leaf _ -> assert false (* because h(r)>h(l)+2 and h(leaf)=1 *) | Node (rl, rv, rr, _, _) -> if height rr >= height rl then create (create l v rl) rv rr @@ -254,8 +252,8 @@ module Tree0 = struct if c = 0 then raise Same else if c < 0 - then bal (Leaf x) v Empty - else bal Empty v (Leaf x) + then create (Leaf x) v Empty + else create Empty v (Leaf x) | Node (l, v, r, _, _) -> let c = compare_elt x v in if c = 0 then raise Same else if c < 0 then bal (aux l) v r else bal l v (aux r) @@ -290,11 +288,11 @@ module Tree0 = struct exception Set_min_elt_exn_of_empty_set [@@deriving_inline sexp] let () = - Ppx_sexp_conv_lib.Conv.Exn_converter.add + Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Set_min_elt_exn_of_empty_set] (function | Set_min_elt_exn_of_empty_set -> - Ppx_sexp_conv_lib.Sexp.Atom "set.ml.Tree0.Set_min_elt_exn_of_empty_set" + Sexplib0.Sexp.Atom "set.ml.Tree0.Set_min_elt_exn_of_empty_set" | _ -> assert false) ;; @@ -303,11 +301,11 @@ module Tree0 = struct exception Set_max_elt_exn_of_empty_set [@@deriving_inline sexp] let () = - Ppx_sexp_conv_lib.Conv.Exn_converter.add + Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Set_max_elt_exn_of_empty_set] (function | Set_max_elt_exn_of_empty_set -> - Ppx_sexp_conv_lib.Sexp.Atom "set.ml.Tree0.Set_max_elt_exn_of_empty_set" + Sexplib0.Sexp.Atom "set.ml.Tree0.Set_max_elt_exn_of_empty_set" | _ -> assert false) ;; @@ -322,7 +320,7 @@ module Tree0 = struct let fold_until t ~init ~f ~finish = let rec fold_until_helper ~f t acc = match t with - | Empty -> Continue_or_stop.Continue acc + | Empty -> Container.Continue_or_stop.Continue acc | Leaf value -> f acc value | Node (left, value, right, _, _) -> (match fold_until_helper ~f left acc with @@ -714,8 +712,7 @@ module Tree0 = struct let binary_search t ~compare how v = match how with | `Last_strictly_less_than -> find_last_satisfying t ~f:(fun x -> compare x v < 0) - | `Last_less_than_or_equal_to -> - find_last_satisfying t ~f:(fun x -> compare x v <= 0) + | `Last_less_than_or_equal_to -> find_last_satisfying t ~f:(fun x -> compare x v <= 0) | `First_equal_to -> (match find_first_satisfying t ~f:(fun x -> compare x v >= 0) with | Some x as elt when compare x v = 0 -> elt @@ -889,9 +886,7 @@ module Tree0 = struct | Empty -> accu | Leaf v -> if p v then add t v ~compare_elt, f else t, add f v ~compare_elt | Node (l, v, r, _, _) -> - part - (part (if p v then add t v ~compare_elt, f else t, add f v ~compare_elt) l) - r + part (part (if p v then add t v ~compare_elt, f else t, add f v ~compare_elt) l) r in part (Empty, Empty) s ;; @@ -926,6 +921,10 @@ module Tree0 = struct List.fold lst ~init:empty ~f:(fun t x -> add t x ~compare_elt) ;; + let of_sequence sequence ~compare_elt = + Sequence.fold sequence ~init:empty ~f:(fun t x -> add t x ~compare_elt) + ;; + let to_list s = elements s let of_array a ~compare_elt = @@ -1135,10 +1134,7 @@ module Accessors = struct let compare_direct t1 t2 = Tree0.compare (compare_elt t1) t1.tree t2.tree let equal t1 t2 = Tree0.equal t1.tree t2.tree ~compare_elt:(compare_elt t1) - - let is_subset t ~of_ = - Tree0.is_subset t.tree ~of_:of_.tree ~compare_elt:(compare_elt t) - ;; + let is_subset t ~of_ = Tree0.is_subset t.tree ~of_:of_.tree ~compare_elt:(compare_elt t) let are_disjoint t1 t2 = Tree0.are_disjoint t1.tree t2.tree ~compare_elt:(compare_elt t1) @@ -1180,11 +1176,7 @@ module Accessors = struct ;; let nth t i = Tree0.nth t.tree i - - let remove_index t i = - like t (Tree0.remove_index t.tree i ~compare_elt:(compare_elt t)) - ;; - + let remove_index t i = like t (Tree0.remove_index t.tree i ~compare_elt:(compare_elt t)) let sexp_of_t sexp_of_a _ t = Tree0.sexp_of_t sexp_of_a t.tree let to_sequence ?order ?greater_or_equal_to ?less_or_equal_to t = @@ -1254,11 +1246,7 @@ module Tree = struct let map ~comparator t ~f = Tree0.map t ~f ~compare_elt:(ce comparator) let filter ~comparator t ~f = Tree0.filter t ~f ~compare_elt:(ce comparator) let filter_map ~comparator t ~f = Tree0.filter_map t ~f ~compare_elt:(ce comparator) - - let partition_tf ~comparator t ~f = - Tree0.partition_tf t ~f ~compare_elt:(ce comparator) - ;; - + let partition_tf ~comparator t ~f = Tree0.partition_tf t ~f ~compare_elt:(ce comparator) let iter2 ~comparator a b ~f = Tree0.iter2 a b ~f ~compare_elt:(ce comparator) let mem ~comparator t a = Tree0.mem t a ~compare_elt:(ce comparator) let add ~comparator t a = Tree0.add t a ~compare_elt:(ce comparator) @@ -1280,6 +1268,7 @@ module Tree = struct ;; let of_list ~comparator l = Tree0.of_list l ~compare_elt:(ce comparator) + let of_sequence ~comparator s = Tree0.of_sequence s ~compare_elt:(ce comparator) let of_array ~comparator a = Tree0.of_array a ~compare_elt:(ce comparator) let of_sorted_array_unchecked ~comparator a = @@ -1290,20 +1279,14 @@ module Tree = struct Tree0.of_increasing_iterator_unchecked ~len ~f ;; - let of_sorted_array ~comparator a = - Tree0.of_sorted_array a ~compare_elt:(ce comparator) - ;; - + let of_sorted_array ~comparator a = Tree0.of_sorted_array a ~compare_elt:(ce comparator) let union_list ~comparator l = Tree0.union_list l ~to_tree:Fn.id ~comparator let stable_dedup_list ~comparator xs = Tree0.stable_dedup_list xs ~compare_elt:(ce comparator) ;; - let group_by ~comparator t ~equiv = - Tree0.group_by t ~equiv ~compare_elt:(ce comparator) - ;; - + let group_by ~comparator t ~equiv = Tree0.group_by t ~equiv ~compare_elt:(ce comparator) let split ~comparator t a = Tree0.split t a ~compare_elt:(ce comparator) let nth t i = Tree0.nth t i let remove_index ~comparator t i = Tree0.remove_index t i ~compare_elt:(ce comparator) @@ -1395,6 +1378,10 @@ module Using_comparator = struct { comparator; tree = Tree0.of_list l ~compare_elt:comparator.Comparator.compare } ;; + let of_sequence ~comparator s = + { comparator; tree = Tree0.of_sequence s ~compare_elt:comparator.Comparator.compare } + ;; + let of_array ~comparator a = { comparator; tree = Tree0.of_array a ~compare_elt:comparator.Comparator.compare } ;; @@ -1441,11 +1428,9 @@ let of_increasing_iterator_unchecked m ~len ~f = Using_comparator.of_increasing_iterator_unchecked ~comparator:(to_comparator m) ~len ~f ;; -let of_sorted_array m a = - Using_comparator.of_sorted_array ~comparator:(to_comparator m) a -;; - +let of_sorted_array m a = Using_comparator.of_sorted_array ~comparator:(to_comparator m) a let of_list m a = Using_comparator.of_list ~comparator:(to_comparator m) a +let of_sequence m a = Using_comparator.of_sequence ~comparator:(to_comparator m) a let of_array m a = Using_comparator.of_array ~comparator:(to_comparator m) a let stable_dedup_list m a = @@ -1466,7 +1451,7 @@ end module type Sexp_of_m = sig type t [@@deriving_inline sexp_of] - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end @@ -1474,13 +1459,21 @@ end module type M_of_sexp = sig type t [@@deriving_inline of_sexp] - val t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t + val t_of_sexp : Sexplib0.Sexp.t -> t [@@@end] include Comparator.S with type t := t end +module type M_sexp_grammar = sig + type t [@@deriving_inline sexp_grammar] + + val t_sexp_grammar : t Sexplib0.Sexp_grammar.t + + [@@@end] +end + module type Compare_m = sig end module type Equal_m = sig end module type Hash_fold_m = Hasher.S @@ -1497,8 +1490,14 @@ let m__t_of_sexp Using_comparator.t_of_sexp_direct ~comparator:Elt.comparator Elt.t_of_sexp sexp ;; -let compare_m__t (module Elt : Compare_m) t1 t2 = compare_direct t1 t2 -let equal_m__t (module Elt : Equal_m) t1 t2 = equal t1 t2 +let m__t_sexp_grammar (type elt) (module Elt : M_sexp_grammar with type t = elt) + : (elt, _) t Sexplib0.Sexp_grammar.t + = + Sexplib0.Sexp_grammar.coerce (list_sexp_grammar Elt.t_sexp_grammar) +;; + +let compare_m__t (module _ : Compare_m) t1 t2 = compare_direct t1 t2 +let equal_m__t (module _ : Equal_m) t1 t2 = equal t1 t2 let hash_fold_m__t (type elt) (module Elt : Hash_fold_m with type t = elt) state = hash_fold_direct Elt.hash_fold_t state @@ -1535,6 +1534,7 @@ module Poly = struct let of_sorted_array a = Using_comparator.of_sorted_array ~comparator a let of_list a = Using_comparator.of_list ~comparator a + let of_sequence a = Using_comparator.of_sequence ~comparator a let of_array a = Using_comparator.of_array ~comparator a let stable_dedup_list a = Using_comparator.stable_dedup_list ~comparator a let map a ~f = Using_comparator.map ~comparator a ~f diff --git a/src/set_intf.ml b/src/set_intf.ml index 21c4024..de59de2 100644 --- a/src/set_intf.ml +++ b/src/set_intf.ml @@ -4,8 +4,9 @@ open! T module type Elt_plain = sig type t [@@deriving_inline compare, sexp_of] - val compare : t -> t -> int - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + include Ppx_compare_lib.Comparable.S with type t := t + + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end @@ -13,7 +14,6 @@ end module Without_comparator = Map_intf.Without_comparator module With_comparator = Map_intf.With_comparator module With_first_class_module = Map_intf.With_first_class_module -include Container_intf.Export module Merge_to_sequence_element = Sequence.Merge_with_duplicates_element module type Accessors_generic = sig @@ -62,7 +62,7 @@ module type Accessors_generic = sig val fold_until : ('a, _) t -> init:'b - -> f:('b -> 'a elt -> ('b, 'final) Continue_or_stop.t) + -> f:('b -> 'a elt -> ('b, 'final) Container.Continue_or_stop.t) -> finish:('b -> 'final) -> 'final @@ -125,13 +125,7 @@ module type Accessors_generic = sig , 'cmp , ('a, 'cmp) t -> compare:('a elt -> 'key -> int) - -> [ `Last_strictly_less_than - | `Last_less_than_or_equal_to - | `Last_equal_to - | `First_equal_to - | `First_greater_than_or_equal_to - | `First_strictly_greater_than - ] + -> Binary_searchable.Which_target_by_key.t -> 'key -> 'a elt option ) options @@ -141,7 +135,7 @@ module type Accessors_generic = sig , 'cmp , ('a, 'cmp) t -> segment_of:('a elt -> [ `Left | `Right ]) - -> [ `Last_on_left | `First_on_right ] + -> Binary_searchable.Which_target_by_segment.t -> 'a elt option ) options @@ -186,7 +180,7 @@ module type Accessors0 = sig val fold_until : t -> init:'b - -> f:('b -> elt -> ('b, 'final) Continue_or_stop.t) + -> f:('b -> elt -> ('b, 'final) Container.Continue_or_stop.t) -> finish:('b -> 'final) -> 'final @@ -224,20 +218,14 @@ module type Accessors0 = sig val binary_search : t -> compare:(elt -> 'key -> int) - -> [ `Last_strictly_less_than - | `Last_less_than_or_equal_to - | `Last_equal_to - | `First_equal_to - | `First_greater_than_or_equal_to - | `First_strictly_greater_than - ] + -> Binary_searchable.Which_target_by_key.t -> 'key -> elt option val binary_search_segmented : t -> segment_of:(elt -> [ `Left | `Right ]) - -> [ `Last_on_left | `First_on_right ] + -> Binary_searchable.Which_target_by_segment.t -> elt option val merge_to_sequence @@ -278,7 +266,7 @@ module type Accessors1 = sig val fold_until : 'a t -> init:'b - -> f:('b -> 'a -> ('b, 'final) Continue_or_stop.t) + -> f:('b -> 'a -> ('b, 'final) Container.Continue_or_stop.t) -> finish:('b -> 'final) -> 'final @@ -316,20 +304,14 @@ module type Accessors1 = sig val binary_search : 'a t -> compare:('a -> 'key -> int) - -> [ `Last_strictly_less_than - | `Last_less_than_or_equal_to - | `Last_equal_to - | `First_equal_to - | `First_greater_than_or_equal_to - | `First_strictly_greater_than - ] + -> Binary_searchable.Which_target_by_key.t -> 'key -> 'a option val binary_search_segmented : 'a t -> segment_of:('a -> [ `Left | `Right ]) - -> [ `Last_on_left | `First_on_right ] + -> Binary_searchable.Which_target_by_segment.t -> 'a option val merge_to_sequence @@ -369,7 +351,7 @@ module type Accessors2 = sig val fold_until : ('a, _) t -> init:'b - -> f:('b -> 'a -> ('b, 'final) Continue_or_stop.t) + -> f:('b -> 'a -> ('b, 'final) Container.Continue_or_stop.t) -> finish:('b -> 'final) -> 'final @@ -407,20 +389,14 @@ module type Accessors2 = sig val binary_search : ('a, 'cmp) t -> compare:('a -> 'key -> int) - -> [ `Last_strictly_less_than - | `Last_less_than_or_equal_to - | `Last_equal_to - | `First_equal_to - | `First_greater_than_or_equal_to - | `First_strictly_greater_than - ] + -> Binary_searchable.Which_target_by_key.t -> 'key -> 'a option val binary_search_segmented : ('a, 'cmp) t -> segment_of:('a -> [ `Left | `Right ]) - -> [ `Last_on_left | `First_on_right ] + -> Binary_searchable.Which_target_by_segment.t -> 'a option val merge_to_sequence @@ -505,7 +481,7 @@ module type Accessors2_with_comparator = sig val fold_until : ('a, _) t -> init:'accum - -> f:('accum -> 'a -> ('accum, 'final) Continue_or_stop.t) + -> f:('accum -> 'a -> ('accum, 'final) Container.Continue_or_stop.t) -> finish:('accum -> 'final) -> 'final @@ -573,13 +549,7 @@ module type Accessors2_with_comparator = sig : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> compare:('a -> 'key -> int) - -> [ `Last_strictly_less_than - | `Last_less_than_or_equal_to - | `Last_equal_to - | `First_equal_to - | `First_greater_than_or_equal_to - | `First_strictly_greater_than - ] + -> Binary_searchable.Which_target_by_key.t -> 'key -> 'a option @@ -587,7 +557,7 @@ module type Accessors2_with_comparator = sig : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> segment_of:('a -> [ `Left | `Right ]) - -> [ `Last_on_left | `First_on_right ] + -> Binary_searchable.Which_target_by_segment.t -> 'a option val merge_to_sequence @@ -608,7 +578,7 @@ module Check_accessors (Named : T2) (Cmp : T1) (Options : T3) - (M : Accessors_generic + (_ : 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 @@ -709,6 +679,7 @@ module type Creators_generic = sig val singleton : ('a, 'cmp, 'a elt -> ('a, 'cmp) t) options val union_list : ('a, 'cmp, ('a, 'cmp) t list -> ('a, 'cmp) t) options val of_list : ('a, 'cmp, 'a elt list -> ('a, 'cmp) t) options + val of_sequence : ('a, 'cmp, 'a elt Sequence.t -> ('a, 'cmp) t) options val of_array : ('a, 'cmp, 'a elt array -> ('a, 'cmp) t) options val of_sorted_array : ('a, 'cmp, 'a elt array -> ('a, 'cmp) t Or_error.t) options val of_sorted_array_unchecked : ('a, 'cmp, 'a elt array -> ('a, 'cmp) t) options @@ -746,6 +717,7 @@ module type Creators0 = sig val singleton : elt -> t val union_list : t list -> t val of_list : elt list -> t + val of_sequence : elt Sequence.t -> t val of_array : elt array -> t val of_sorted_array : elt array -> t Or_error.t val of_sorted_array_unchecked : elt array -> t @@ -766,6 +738,7 @@ module type Creators1 = sig val singleton : 'a -> 'a t val union_list : 'a t list -> 'a t val of_list : 'a list -> 'a t + val of_sequence : 'a Sequence.t -> 'a t val of_array : 'a array -> 'a t val of_sorted_array : 'a array -> 'a t Or_error.t val of_sorted_array_unchecked : 'a array -> 'a t @@ -785,6 +758,7 @@ module type Creators2 = sig val singleton : 'a -> ('a, 'cmp) t val union_list : ('a, 'cmp) t list -> ('a, 'cmp) t val of_list : 'a list -> ('a, 'cmp) t + val of_sequence : 'a Sequence.t -> ('a, 'cmp) t val of_array : 'a array -> ('a, 'cmp) t val of_sorted_array : 'a array -> ('a, 'cmp) t Or_error.t val of_sorted_array_unchecked : 'a array -> ('a, 'cmp) t @@ -802,13 +776,9 @@ module type Creators2_with_comparator = sig val empty : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t val singleton : comparator:('a, 'cmp) Comparator.t -> 'a -> ('a, 'cmp) t - - val union_list - : comparator:('a, 'cmp) Comparator.t - -> ('a, 'cmp) t list - -> ('a, 'cmp) t - + val union_list : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t list -> ('a, 'cmp) t val of_list : comparator:('a, 'cmp) Comparator.t -> 'a list -> ('a, 'cmp) t + val of_sequence : comparator:('a, 'cmp) Comparator.t -> 'a Sequence.t -> ('a, 'cmp) t val of_array : comparator:('a, 'cmp) Comparator.t -> 'a array -> ('a, 'cmp) t val of_sorted_array @@ -850,7 +820,7 @@ module Check_creators (Elt : T1) (Cmp : T1) (Options : T3) - (M : Creators_generic + (_ : 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 @@ -983,7 +953,7 @@ module type For_deriving = sig module type Sexp_of_m = sig type t [@@deriving_inline sexp_of] - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] end @@ -991,13 +961,21 @@ module type For_deriving = sig module type M_of_sexp = sig type t [@@deriving_inline of_sexp] - val t_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t + val t_of_sexp : Sexplib0.Sexp.t -> t [@@@end] include Comparator.S with type t := t end + module type M_sexp_grammar = sig + type t [@@deriving_inline sexp_grammar] + + val t_sexp_grammar : t Sexplib0.Sexp_grammar.t + + [@@@end] + end + module type Compare_m = sig end module type Equal_m = sig end module type Hash_fold_m = Hasher.S @@ -1009,6 +987,10 @@ module type For_deriving = sig -> Sexp.t -> ('elt, 'cmp) t + val m__t_sexp_grammar + : (module M_sexp_grammar with type t = 'elt) + -> ('elt, 'cmp) t Sexplib0.Sexp_grammar.t + val compare_m__t : (module Compare_m) -> ('elt, 'cmp) t -> ('elt, 'cmp) t -> int val equal_m__t : (module Equal_m) -> ('elt, 'cmp) t -> ('elt, 'cmp) t -> bool @@ -1022,8 +1004,10 @@ module type For_deriving = sig end module type Set = sig - (** This module defines the [Set] module for [Base]. Functions that construct a set take - as an argument the comparator for the element type. *) + (** Sets based on {!Comparator.S}. + + Creators require a comparator argument to be passed in, whereas accessors use the + comparator provided by the input set. *) (** The type of a set. The first type parameter identifies the type of the element, and the second identifies the comparator, which determines the comparison function that @@ -1032,33 +1016,28 @@ module type Set = sig type. *) type ('elt, 'cmp) t [@@deriving_inline compare] - val compare - : ('elt -> 'elt -> int) - -> ('cmp -> 'cmp -> int) - -> ('elt, 'cmp) t - -> ('elt, 'cmp) t - -> int + include Ppx_compare_lib.Comparable.S2 with type ('elt, 'cmp) t := ('elt, 'cmp) t [@@@end] - type ('k, 'cmp) comparator = - (module Comparator.S with type t = 'k and type comparator_witness = 'cmp) + type ('k, 'cmp) comparator = ('k, 'cmp) Comparator.Module.t + [@@deprecated "[since 2021-12] use [Comparator.Module.t] instead"] (** Tests internal invariants of the set data structure. Returns true on success. *) val invariants : (_, _) t -> bool (** Returns a first-class module that can be used to build other map/set/etc with the same notion of comparison. *) - val comparator_s : ('a, 'cmp) t -> ('a, 'cmp) comparator + val comparator_s : ('a, 'cmp) t -> ('a, 'cmp) Comparator.Module.t val comparator : ('a, 'cmp) t -> ('a, 'cmp) Comparator.t (** Creates an empty set based on the provided comparator. *) - val empty : ('a, 'cmp) comparator -> ('a, 'cmp) t + val empty : ('a, 'cmp) Comparator.Module.t -> ('a, 'cmp) t (** Creates a set based on the provided comparator that contains only the provided element. *) - val singleton : ('a, 'cmp) comparator -> 'a -> ('a, 'cmp) t + val singleton : ('a, 'cmp) Comparator.Module.t -> 'a -> ('a, 'cmp) t (** Returns the cardinality of the set. [O(1)]. *) val length : (_, _) t -> int @@ -1083,7 +1062,7 @@ module type Set = sig (** [union c list] returns the union of all the sets in [list]. The [comparator] argument is required for the case where [list] is empty. [O(max(List.length list, n log n))], where [n] is the sum of sizes of the input sets. *) - val union_list : ('a, 'cmp) comparator -> ('a, 'cmp) t list -> ('a, 'cmp) t + val union_list : ('a, 'cmp) Comparator.Module.t -> ('a, 'cmp) t list -> ('a, 'cmp) t (** [inter t1 t2] computes the intersection of sets [t1] and [t2]. [O(length t1 + length t2)]. *) @@ -1197,9 +1176,10 @@ module type Set = sig 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_list : ('a, 'cmp) Comparator.Module.t -> 'a list -> ('a, 'cmp) t - val of_array : ('a, 'cmp) comparator -> 'a array -> ('a, 'cmp) t + val of_sequence : ('a, 'cmp) Comparator.Module.t -> 'a Sequence.t -> ('a, 'cmp) t + val of_array : ('a, 'cmp) Comparator.Module.t -> 'a array -> ('a, 'cmp) t (** [to_list] and [to_array] produce sequences sorted in ascending order according to the comparator. *) @@ -1210,17 +1190,23 @@ module type Set = sig (** 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 + val of_sorted_array + : ('a, 'cmp) Comparator.Module.t + -> 'a array + -> ('a, 'cmp) t Or_error.t (** Similar to [of_sorted_array], but without checking the input array. *) - val of_sorted_array_unchecked : ('a, 'cmp) comparator -> 'a array -> ('a, 'cmp) t + val of_sorted_array_unchecked + : ('a, 'cmp) Comparator.Module.t + -> 'a array + -> ('a, 'cmp) t (** [of_increasing_iterator_unchecked c ~len ~f] behaves like [of_sorted_array_unchecked c (Array.init len ~f)], with the additional restriction that a decreasing order is not supported. The advantage is not requiring you to allocate an intermediate array. [f] will be called with 0, 1, ... [len - 1], in order. *) val of_increasing_iterator_unchecked - : ('a, 'cmp) comparator + : ('a, 'cmp) Comparator.Module.t -> len:int -> f:(int -> 'a) -> ('a, 'cmp) t @@ -1229,15 +1215,15 @@ module type Set = sig 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 + val stable_dedup_list : ('a, _) Comparator.Module.t -> 'a list -> 'a list (** [map c t ~f] returns a new set created by applying [f] to every element in [t]. The returned set is based on the provided [comparator]. [O(n log n)]. *) - val map : ('b, 'cmp) comparator -> ('a, _) t -> f:('a -> 'b) -> ('b, 'cmp) t + val map : ('b, 'cmp) Comparator.Module.t -> ('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 + : ('b, 'cmp) Comparator.Module.t -> ('a, _) t -> f:('a -> 'b option) -> ('b, 'cmp) t @@ -1263,7 +1249,7 @@ module type Set = sig val fold_until : ('a, _) t -> init:'accum - -> f:('accum -> 'a -> ('accum, 'final) Continue_or_stop.t) + -> f:('accum -> 'a -> ('accum, 'final) Container.Continue_or_stop.t) -> finish:('accum -> 'final) -> 'final @@ -1406,14 +1392,8 @@ module type Set = sig | Both of 'a * 'b [@@deriving_inline compare, sexp] - val compare - : ('a -> 'a -> int) - -> ('b -> 'b -> int) - -> ('a, 'b) t - -> ('a, 'b) t - -> int - - include Ppx_sexp_conv_lib.Sexpable.S2 with type ('a, 'b) t := ('a, 'b) t + include Ppx_compare_lib.Comparable.S2 with type ('a, 'b) t := ('a, 'b) t + include Sexplib0.Sexpable.S2 with type ('a, 'b) t := ('a, 'b) t [@@@end] end @@ -1460,10 +1440,10 @@ module type Set = sig type nonrec ('elt, 'cmp) t = ('elt, 'cmp) t [@@deriving_inline sexp_of] val sexp_of_t - : ('elt -> Ppx_sexp_conv_lib.Sexp.t) - -> ('cmp -> Ppx_sexp_conv_lib.Sexp.t) + : ('elt -> Sexplib0.Sexp.t) + -> ('cmp -> Sexplib0.Sexp.t) -> ('elt, 'cmp) t - -> Ppx_sexp_conv_lib.Sexp.t + -> Sexplib0.Sexp.t [@@@end] @@ -1480,10 +1460,10 @@ module type Set = sig type ('a, 'cmp) t [@@deriving_inline sexp_of] val sexp_of_t - : ('a -> Ppx_sexp_conv_lib.Sexp.t) - -> ('cmp -> Ppx_sexp_conv_lib.Sexp.t) + : ('a -> Sexplib0.Sexp.t) + -> ('cmp -> Sexplib0.Sexp.t) -> ('a, 'cmp) t - -> Ppx_sexp_conv_lib.Sexp.t + -> Sexplib0.Sexp.t [@@@end] @@ -1545,7 +1525,7 @@ module type Set = sig (** {2 Modules and module types for extending [Set]} - For use in extensions of Base, like [Core_kernel]. *) + For use in extensions of Base, like [Core]. *) module With_comparator = With_comparator module With_first_class_module = With_first_class_module diff --git a/src/sexp.ml b/src/sexp.ml index bdf2f53..4bc8680 100644 --- a/src/sexp.ml +++ b/src/sexp.ml @@ -1,8 +1,6 @@ open Hash.Builtin open Ppx_compare_lib.Builtin -module List = List0 -module String = String0 -include (Sexplib0.Sexp : module type of Sexplib0.Sexp with type t := Sexplib0.Sexp.t) +include Sexplib0.Sexp (** Type of S-expressions *) type t = Sexplib0.Sexp.t = @@ -47,5 +45,6 @@ and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) = [@@@end] +let t_sexp_grammar = Sexplib0.Sexp_conv.sexp_t_sexp_grammar let of_string = () let invariant (_ : t) = () diff --git a/src/sexp.mli b/src/sexp.mli index 9534855..4a0bc81 100644 --- a/src/sexp.mli +++ b/src/sexp.mli @@ -4,13 +4,14 @@ type t = Sexplib0.Sexp.t = | List of t list [@@deriving_inline hash] -val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state -val hash : t -> Ppx_hash_lib.Std.Hash.hash_value +include Ppx_hash_lib.Hashable.S with type t := t [@@@end] include module type of Sexplib0.Sexp with type t := Sexplib0.Sexp.t +val t_sexp_grammar : t Sexplib0.Sexp_grammar.t + val invariant : t -> unit (** Base has never had an [of_string] function. We expose a deprecated [of_string] here diff --git a/src/sexpable.mli b/src/sexpable.mli index 05ee012..6fb8fe3 100644 --- a/src/sexpable.mli +++ b/src/sexpable.mli @@ -1,13 +1,9 @@ -(** Provides functors for making modules sexpable. New code should use the [[@@deriving - sexp]] syntax directly. These module types ([S], [S1], [S2], and [S3]) are exported - for backwards compatibility only. *) +(** Provides functors for making modules sexpable when you want the sexp representation of + one type to be the same as that for some other isomorphic type. *) open! Import +open! Sexplib0.Sexpable -include module type of Sexplib0.Sexpable (** @inline *) - -(** For when you want the sexp representation of one type to be the same as that for - some other isomorphic type. *) module Of_sexpable (Sexpable : S) (M : sig type t @@ -41,3 +37,9 @@ module Of_sexpable3 end) : S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) M.t module Of_stringable (M : Stringable.S) : S with type t := M.t + +(** New code should use the [[@@deriving sexp]] syntax directly. These module types ([S], + [S1], [S2], and [S3]) are exported for backwards compatibility only. +*) +include module type of Sexplib0.Sexpable +(** @inline *) diff --git a/src/sexplib.ml b/src/sexplib.ml deleted file mode 100644 index 5414d04..0000000 --- a/src/sexplib.ml +++ /dev/null @@ -1,9 +0,0 @@ -(** This module is for use by ppx_sexp_conv, and is thus not in the interface of - Base. *) -module Conv_error = Sexplib0.Sexp_conv_error - -module Conv = Sexplib0.Sexp_conv - -module Sexp = Sexp (** @canonical Base.Sexp *) - -module Sexpable = Sexpable (** @canonical Base.Sexpable *) diff --git a/src/sign.mli b/src/sign.mli index ba24b19..185e719 100644 --- a/src/sign.mli +++ b/src/sign.mli @@ -6,15 +6,16 @@ type t = Sign0.t = | Neg | Zero | Pos -[@@deriving_inline enumerate] +[@@deriving_inline enumerate, sexp_grammar] -val all : t list +include Ppx_enumerate_lib.Enumerable.S with type t := t + +val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] (** This provides [to_string]/[of_string], sexp conversion, Map, Hashtbl, etc. *) -include - Identifiable.S with type t := t +include Identifiable.S with type t := t val of_int : int -> t diff --git a/src/sign0.ml b/src/sign0.ml index 147cac5..372a35a 100644 --- a/src/sign0.ml +++ b/src/sign0.ml @@ -6,34 +6,47 @@ type t = | Neg | Zero | Pos -[@@deriving_inline sexp, compare, hash, enumerate] +[@@deriving_inline sexp, sexp_grammar, compare, hash, enumerate] let t_of_sexp = - (let _tp_loc = "sign0.ml.t" in + (let error_source__003_ = "sign0.ml.t" in function - | Ppx_sexp_conv_lib.Sexp.Atom ("neg" | "Neg") -> Neg - | Ppx_sexp_conv_lib.Sexp.Atom ("zero" | "Zero") -> Zero - | Ppx_sexp_conv_lib.Sexp.Atom ("pos" | "Pos") -> Pos - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom ("neg" | "Neg") :: _) as - sexp -> Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom ("zero" | "Zero") :: _) as - sexp -> Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom ("pos" | "Pos") :: _) as - sexp -> Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.List _ :: _) as sexp -> - Ppx_sexp_conv_lib.Conv_error.nested_list_invalid_sum _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List [] as sexp -> - Ppx_sexp_conv_lib.Conv_error.empty_list_invalid_sum _tp_loc sexp - | sexp -> Ppx_sexp_conv_lib.Conv_error.unexpected_stag _tp_loc sexp - : Ppx_sexp_conv_lib.Sexp.t -> t) + | Sexplib0.Sexp.Atom ("neg" | "Neg") -> Neg + | Sexplib0.Sexp.Atom ("zero" | "Zero") -> Zero + | Sexplib0.Sexp.Atom ("pos" | "Pos") -> Pos + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("neg" | "Neg") :: _) as sexp__004_ -> + Sexplib0.Sexp_conv_error.stag_no_args error_source__003_ sexp__004_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("zero" | "Zero") :: _) as sexp__004_ -> + Sexplib0.Sexp_conv_error.stag_no_args error_source__003_ sexp__004_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("pos" | "Pos") :: _) as sexp__004_ -> + Sexplib0.Sexp_conv_error.stag_no_args error_source__003_ sexp__004_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__002_ -> + Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__003_ sexp__002_ + | Sexplib0.Sexp.List [] as sexp__002_ -> + Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__003_ sexp__002_ + | sexp__002_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__003_ sexp__002_ + : Sexplib0.Sexp.t -> t) ;; let sexp_of_t = (function - | Neg -> Ppx_sexp_conv_lib.Sexp.Atom "Neg" - | Zero -> Ppx_sexp_conv_lib.Sexp.Atom "Zero" - | Pos -> Ppx_sexp_conv_lib.Sexp.Atom "Pos" - : t -> Ppx_sexp_conv_lib.Sexp.t) + | Neg -> Sexplib0.Sexp.Atom "Neg" + | Zero -> Sexplib0.Sexp.Atom "Zero" + | Pos -> Sexplib0.Sexp.Atom "Pos" + : t -> Sexplib0.Sexp.t) +;; + +let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = + { untyped = + Variant + { case_sensitivity = Case_sensitive_except_first_character + ; clauses = + [ No_tag { name = "Neg"; clause_kind = Atom_clause } + ; No_tag { name = "Zero"; clause_kind = Atom_clause } + ; No_tag { name = "Pos"; clause_kind = Atom_clause } + ] + } + } ;; let compare = (Ppx_compare_lib.polymorphic_compare : t -> t -> int) diff --git a/src/sign_or_nan.ml b/src/sign_or_nan.ml index 264bdf4..af5e25b 100644 --- a/src/sign_or_nan.ml +++ b/src/sign_or_nan.ml @@ -6,38 +6,53 @@ module T = struct | Zero | Pos | Nan - [@@deriving_inline sexp, compare, hash, enumerate] + [@@deriving_inline sexp, sexp_grammar, compare, hash, enumerate] let t_of_sexp = - (let _tp_loc = "sign_or_nan.ml.T.t" in + (let error_source__003_ = "sign_or_nan.ml.T.t" in function - | Ppx_sexp_conv_lib.Sexp.Atom ("neg" | "Neg") -> Neg - | Ppx_sexp_conv_lib.Sexp.Atom ("zero" | "Zero") -> Zero - | Ppx_sexp_conv_lib.Sexp.Atom ("pos" | "Pos") -> Pos - | Ppx_sexp_conv_lib.Sexp.Atom ("nan" | "Nan") -> Nan - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom ("neg" | "Neg") :: _) as - sexp -> Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom ("zero" | "Zero") :: _) - as sexp -> Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom ("pos" | "Pos") :: _) as - sexp -> Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom ("nan" | "Nan") :: _) as - sexp -> Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.List _ :: _) as sexp -> - Ppx_sexp_conv_lib.Conv_error.nested_list_invalid_sum _tp_loc sexp - | Ppx_sexp_conv_lib.Sexp.List [] as sexp -> - Ppx_sexp_conv_lib.Conv_error.empty_list_invalid_sum _tp_loc sexp - | sexp -> Ppx_sexp_conv_lib.Conv_error.unexpected_stag _tp_loc sexp - : Ppx_sexp_conv_lib.Sexp.t -> t) + | Sexplib0.Sexp.Atom ("neg" | "Neg") -> Neg + | Sexplib0.Sexp.Atom ("zero" | "Zero") -> Zero + | Sexplib0.Sexp.Atom ("pos" | "Pos") -> Pos + | Sexplib0.Sexp.Atom ("nan" | "Nan") -> Nan + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("neg" | "Neg") :: _) as sexp__004_ -> + Sexplib0.Sexp_conv_error.stag_no_args error_source__003_ sexp__004_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("zero" | "Zero") :: _) as sexp__004_ -> + Sexplib0.Sexp_conv_error.stag_no_args error_source__003_ sexp__004_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("pos" | "Pos") :: _) as sexp__004_ -> + Sexplib0.Sexp_conv_error.stag_no_args error_source__003_ sexp__004_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("nan" | "Nan") :: _) as sexp__004_ -> + Sexplib0.Sexp_conv_error.stag_no_args error_source__003_ sexp__004_ + | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__002_ -> + Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__003_ sexp__002_ + | Sexplib0.Sexp.List [] as sexp__002_ -> + Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__003_ sexp__002_ + | sexp__002_ -> + Sexplib0.Sexp_conv_error.unexpected_stag error_source__003_ sexp__002_ + : Sexplib0.Sexp.t -> t) ;; let sexp_of_t = (function - | Neg -> Ppx_sexp_conv_lib.Sexp.Atom "Neg" - | Zero -> Ppx_sexp_conv_lib.Sexp.Atom "Zero" - | Pos -> Ppx_sexp_conv_lib.Sexp.Atom "Pos" - | Nan -> Ppx_sexp_conv_lib.Sexp.Atom "Nan" - : t -> Ppx_sexp_conv_lib.Sexp.t) + | Neg -> Sexplib0.Sexp.Atom "Neg" + | Zero -> Sexplib0.Sexp.Atom "Zero" + | Pos -> Sexplib0.Sexp.Atom "Pos" + | Nan -> Sexplib0.Sexp.Atom "Nan" + : t -> Sexplib0.Sexp.t) + ;; + + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = + { untyped = + Variant + { case_sensitivity = Case_sensitive_except_first_character + ; clauses = + [ No_tag { name = "Neg"; clause_kind = Atom_clause } + ; No_tag { name = "Zero"; clause_kind = Atom_clause } + ; No_tag { name = "Pos"; clause_kind = Atom_clause } + ; No_tag { name = "Nan"; clause_kind = Atom_clause } + ] + } + } ;; let compare = (Ppx_compare_lib.polymorphic_compare : t -> t -> int) diff --git a/src/sign_or_nan.mli b/src/sign_or_nan.mli index bdee316..1eef216 100644 --- a/src/sign_or_nan.mli +++ b/src/sign_or_nan.mli @@ -8,15 +8,16 @@ type t = | Zero | Pos | Nan -[@@deriving_inline enumerate] +[@@deriving_inline enumerate, sexp_grammar] -val all : t list +include Ppx_enumerate_lib.Enumerable.S with type t := t + +val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] (** This provides [to_string]/[of_string], sexp conversion, Map, Hashtbl, etc. *) -include - Identifiable.S with type t := t +include Identifiable.S with type t := t val of_int : int -> t diff --git a/src/source_code_position.mli b/src/source_code_position.mli index a38dd6c..8d1f136 100644 --- a/src/source_code_position.mli +++ b/src/source_code_position.mli @@ -15,9 +15,9 @@ type t = Caml.Lexing.position = } [@@deriving_inline hash, sexp_of] -val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state -val hash : t -> Ppx_hash_lib.Std.Hash.hash_value -val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t +include Ppx_hash_lib.Hashable.S with type t := t + +val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] diff --git a/src/source_code_position0.ml b/src/source_code_position0.ml index 02e87c2..17d3a7e 100644 --- a/src/source_code_position0.ml +++ b/src/source_code_position0.ml @@ -9,7 +9,7 @@ module T = struct ; pos_bol : int ; pos_cnum : int } - [@@deriving_inline compare, hash, sexp] + [@@deriving_inline compare, hash, sexp_of] let compare = (fun a__001_ b__002_ -> @@ -52,138 +52,31 @@ module T = struct fun x -> func x ;; - let t_of_sexp = - (let _tp_loc = "source_code_position0.ml.T.t" in - function - | Ppx_sexp_conv_lib.Sexp.List field_sexps as sexp -> - let pos_fname_field = ref Ppx_sexp_conv_lib.Option.None - and pos_lnum_field = ref Ppx_sexp_conv_lib.Option.None - and pos_bol_field = ref Ppx_sexp_conv_lib.Option.None - and pos_cnum_field = ref Ppx_sexp_conv_lib.Option.None - and duplicates = ref [] - and extra = ref [] in - let rec iter = function - | Ppx_sexp_conv_lib.Sexp.List - (Ppx_sexp_conv_lib.Sexp.Atom field_name :: (([] | [ _ ]) as _field_sexps)) - :: tail -> - let _field_sexp () = - match _field_sexps with - | [ x ] -> x - | [] -> Ppx_sexp_conv_lib.Conv_error.record_only_pairs_expected _tp_loc sexp - | _ -> assert false - in - (match field_name with - | "pos_fname" -> - (match !pos_fname_field with - | Ppx_sexp_conv_lib.Option.None -> - let _field_sexp = _field_sexp () in - let fvalue = string_of_sexp _field_sexp in - pos_fname_field := Ppx_sexp_conv_lib.Option.Some fvalue - | Ppx_sexp_conv_lib.Option.Some _ -> duplicates := field_name :: !duplicates) - | "pos_lnum" -> - (match !pos_lnum_field with - | Ppx_sexp_conv_lib.Option.None -> - let _field_sexp = _field_sexp () in - let fvalue = int_of_sexp _field_sexp in - pos_lnum_field := Ppx_sexp_conv_lib.Option.Some fvalue - | Ppx_sexp_conv_lib.Option.Some _ -> duplicates := field_name :: !duplicates) - | "pos_bol" -> - (match !pos_bol_field with - | Ppx_sexp_conv_lib.Option.None -> - let _field_sexp = _field_sexp () in - let fvalue = int_of_sexp _field_sexp in - pos_bol_field := Ppx_sexp_conv_lib.Option.Some fvalue - | Ppx_sexp_conv_lib.Option.Some _ -> duplicates := field_name :: !duplicates) - | "pos_cnum" -> - (match !pos_cnum_field with - | Ppx_sexp_conv_lib.Option.None -> - let _field_sexp = _field_sexp () in - let fvalue = int_of_sexp _field_sexp in - pos_cnum_field := Ppx_sexp_conv_lib.Option.Some fvalue - | Ppx_sexp_conv_lib.Option.Some _ -> duplicates := field_name :: !duplicates) - | _ -> - if !Ppx_sexp_conv_lib.Conv.record_check_extra_fields - then extra := field_name :: !extra - else ()); - iter tail - | ((Ppx_sexp_conv_lib.Sexp.Atom _ | Ppx_sexp_conv_lib.Sexp.List _) as sexp) :: _ - -> Ppx_sexp_conv_lib.Conv_error.record_only_pairs_expected _tp_loc sexp - | [] -> () - in - iter field_sexps; - (match !duplicates with - | _ :: _ -> - Ppx_sexp_conv_lib.Conv_error.record_duplicate_fields _tp_loc !duplicates sexp - | [] -> - (match !extra with - | _ :: _ -> Ppx_sexp_conv_lib.Conv_error.record_extra_fields _tp_loc !extra sexp - | [] -> - (match !pos_fname_field, !pos_lnum_field, !pos_bol_field, !pos_cnum_field with - | ( Ppx_sexp_conv_lib.Option.Some pos_fname_value - , Ppx_sexp_conv_lib.Option.Some pos_lnum_value - , Ppx_sexp_conv_lib.Option.Some pos_bol_value - , Ppx_sexp_conv_lib.Option.Some pos_cnum_value ) -> - { pos_fname = pos_fname_value - ; pos_lnum = pos_lnum_value - ; pos_bol = pos_bol_value - ; pos_cnum = pos_cnum_value - } - | _ -> - Ppx_sexp_conv_lib.Conv_error.record_undefined_elements - _tp_loc - sexp - [ ( Ppx_sexp_conv_lib.Conv.( = ) - !pos_fname_field - Ppx_sexp_conv_lib.Option.None - , "pos_fname" ) - ; ( Ppx_sexp_conv_lib.Conv.( = ) - !pos_lnum_field - Ppx_sexp_conv_lib.Option.None - , "pos_lnum" ) - ; ( Ppx_sexp_conv_lib.Conv.( = ) - !pos_bol_field - Ppx_sexp_conv_lib.Option.None - , "pos_bol" ) - ; ( Ppx_sexp_conv_lib.Conv.( = ) - !pos_cnum_field - Ppx_sexp_conv_lib.Option.None - , "pos_cnum" ) - ]))) - | Ppx_sexp_conv_lib.Sexp.Atom _ as sexp -> - Ppx_sexp_conv_lib.Conv_error.record_list_instead_atom _tp_loc sexp - : Ppx_sexp_conv_lib.Sexp.t -> t) - ;; - let sexp_of_t = - (function - | { pos_fname = v_pos_fname - ; pos_lnum = v_pos_lnum - ; pos_bol = v_pos_bol - ; pos_cnum = v_pos_cnum - } -> - let bnds = [] in - let bnds = - let arg = sexp_of_int v_pos_cnum in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "pos_cnum"; arg ] - :: bnds - in - let bnds = - let arg = sexp_of_int v_pos_bol in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "pos_bol"; arg ] - :: bnds - in - let bnds = - let arg = sexp_of_int v_pos_lnum in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "pos_lnum"; arg ] - :: bnds - in - let bnds = - let arg = sexp_of_string v_pos_fname in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "pos_fname"; arg ] - :: bnds - in - Ppx_sexp_conv_lib.Sexp.List bnds - : t -> Ppx_sexp_conv_lib.Sexp.t) + (fun { pos_fname = pos_fname__004_ + ; pos_lnum = pos_lnum__006_ + ; pos_bol = pos_bol__008_ + ; pos_cnum = pos_cnum__010_ + } -> + let bnds__003_ = [] in + let bnds__003_ = + let arg__011_ = sexp_of_int pos_cnum__010_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "pos_cnum"; arg__011_ ] :: bnds__003_ + in + let bnds__003_ = + let arg__009_ = sexp_of_int pos_bol__008_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "pos_bol"; arg__009_ ] :: bnds__003_ + in + let bnds__003_ = + let arg__007_ = sexp_of_int pos_lnum__006_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "pos_lnum"; arg__007_ ] :: bnds__003_ + in + let bnds__003_ = + let arg__005_ = sexp_of_string pos_fname__004_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "pos_fname"; arg__005_ ] :: bnds__003_ + in + Sexplib0.Sexp.List bnds__003_ + : t -> Sexplib0.Sexp.t) ;; [@@@end] diff --git a/src/stack.ml b/src/stack.ml index 3849908..d4b8452 100644 --- a/src/stack.ml +++ b/src/stack.ml @@ -13,19 +13,18 @@ type 'a t = } [@@deriving_inline sexp_of] -let sexp_of_t : 'a. ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t = - fun _of_a -> function - | { length = v_length; elts = v_elts } -> - let bnds = [] in - let bnds = - let arg = Option_array.sexp_of_t _of_a v_elts in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "elts"; arg ] :: bnds - in - let bnds = - let arg = sexp_of_int v_length in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "length"; arg ] :: bnds - in - Ppx_sexp_conv_lib.Sexp.List bnds +let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = + fun _of_a__001_ { length = length__003_; elts = elts__005_ } -> + let bnds__002_ = [] in + let bnds__002_ = + let arg__006_ = Option_array.sexp_of_t _of_a__001_ elts__005_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "elts"; arg__006_ ] :: bnds__002_ + in + let bnds__002_ = + let arg__004_ = sexp_of_int length__003_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "length"; arg__004_ ] :: bnds__002_ + in + Sexplib0.Sexp.List bnds__002_ ;; [@@@end] @@ -59,7 +58,7 @@ let length t = t.length let is_empty t = length t = 0 (* The order in which elements are visited has been chosen so as to be backwards - compatible with both [Linked_stack] and [Caml.Stack] *) + compatible with [Caml.Stack] *) let fold t ~init ~f = let r = ref init in for i = t.length - 1 downto 0 do @@ -116,6 +115,12 @@ let of_list (type a) (l : a list) = let sexp_of_t sexp_of_a t = List.sexp_of_t sexp_of_a (to_list t) let t_of_sexp a_of_sexp sexp = of_list (List.t_of_sexp a_of_sexp sexp) +let t_sexp_grammar (type a) (grammar : a Sexplib0.Sexp_grammar.t) + : a t Sexplib0.Sexp_grammar.t + = + Sexplib0.Sexp_grammar.coerce (List.t_sexp_grammar grammar) +;; + let resize t size = let arr = Option_array.create ~len:size in Option_array.blit ~src:t.elts ~dst:arr ~src_pos:0 ~dst_pos:0 ~len:t.length; diff --git a/src/stack_intf.ml b/src/stack_intf.ml index e04f328..0fb9e20 100644 --- a/src/stack_intf.ml +++ b/src/stack_intf.ml @@ -4,9 +4,11 @@ open! Import module type S = sig - type 'a t [@@deriving_inline sexp] + type 'a t [@@deriving_inline sexp, sexp_grammar] - include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t := 'a t + include Sexplib0.Sexpable.S1 with type 'a t := 'a t + + val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t [@@@end] @@ -21,8 +23,7 @@ module type S = sig should still be memory-safe) when the stack is mutated while they are running (e.g. by having the passed-in function call [push] or [pop] on the stack). *) - include - Container.S1 with type 'a t := 'a t + include Container.S1 with type 'a t := 'a t (** [of_list l] returns a stack whose top is the first element of [l] and bottom is the last element of [l]. *) diff --git a/src/string.ml b/src/string.ml index 501b06f..0ee495a 100644 --- a/src/string.ml +++ b/src/string.ml @@ -18,31 +18,13 @@ module T = struct fun x -> func x ;; - let t_of_sexp = (string_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t) - let sexp_of_t = (sexp_of_string : t -> Ppx_sexp_conv_lib.Sexp.t) - - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "string" ] - ; ggid = "\146e\023\249\235eE\139c\132W\195\137\129\235\025" - ; types = [ "t", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ string_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "string.ml.T" - } - in - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("t", _the_group) - in - t_sexp_grammar - ;; + let t_of_sexp = (string_of_sexp : Sexplib0.Sexp.t -> t) + let sexp_of_t = (sexp_of_string : t -> Sexplib0.Sexp.t) + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = string_sexp_grammar [@@@end] + let hashable : t Hashable.t = { hash; compare; sexp_of_t } let compare = compare end @@ -62,9 +44,12 @@ let sub src ~pos ~len = then src else ( Ordered_collection_common.check_pos_len_exn ~pos ~len ~total_length:(length src); - let dst = Bytes.create len in - if len > 0 then Bytes.unsafe_blit_string ~src ~src_pos:pos ~dst ~dst_pos:0 ~len; - Bytes.unsafe_to_string ~no_mutation_while_string_reachable:dst) + if len = 0 + then "" + else ( + let dst = Bytes.create len in + Bytes.unsafe_blit_string ~src ~src_pos:pos ~dst ~dst_pos:0 ~len; + Bytes.unsafe_to_string ~no_mutation_while_string_reachable:dst)) ;; let subo ?(pos = 0) ?len src = @@ -343,12 +328,7 @@ module Search_pattern0 = struct let next_src_pos = ref 0 in List.iter matches ~f:(fun i -> let len = i - !next_src_pos in - Bytes.blit_string - ~src:s - ~src_pos:!next_src_pos - ~dst - ~dst_pos:!next_dst_pos - ~len; + Bytes.blit_string ~src:s ~src_pos:!next_src_pos ~dst ~dst_pos:!next_dst_pos ~len; Bytes.blit_string ~src:with_ ~src_pos:0 @@ -366,6 +346,15 @@ module Search_pattern0 = struct Bytes.unsafe_to_string ~no_mutation_while_string_reachable:dst ;; + let split_on t s = + let pattern_len = String.length t.pattern in + let matches = index_all t ~may_overlap:false ~in_:s in + List.map2_exn + (-pattern_len :: matches) + (matches @ [ String.length s ]) + ~f:(fun i j -> sub s ~pos:(i + pattern_len) ~len:(j - i - pattern_len)) + ;; + module Private = struct type public = t @@ -377,43 +366,39 @@ module Search_pattern0 = struct [@@deriving_inline equal, sexp_of] let equal = - (fun a__001_ b__002_ -> - if Ppx_compare_lib.phys_equal a__001_ b__002_ + (fun a__002_ b__003_ -> + if Ppx_compare_lib.phys_equal a__002_ b__003_ then true else Ppx_compare_lib.( && ) - (equal_string a__001_.pattern b__002_.pattern) + (equal_string a__002_.pattern b__003_.pattern) (Ppx_compare_lib.( && ) - (equal_bool a__001_.case_sensitive b__002_.case_sensitive) - (equal_array equal_int a__001_.kmp_array b__002_.kmp_array)) + (equal_bool a__002_.case_sensitive b__003_.case_sensitive) + (equal_array equal_int a__002_.kmp_array b__003_.kmp_array)) : t -> t -> bool) ;; let sexp_of_t = - (function - | { pattern = v_pattern - ; case_sensitive = v_case_sensitive - ; kmp_array = v_kmp_array - } -> - let bnds = [] in - let bnds = - let arg = sexp_of_array sexp_of_int v_kmp_array in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "kmp_array"; arg ] - :: bnds - in - let bnds = - let arg = sexp_of_bool v_case_sensitive in - Ppx_sexp_conv_lib.Sexp.List - [ Ppx_sexp_conv_lib.Sexp.Atom "case_sensitive"; arg ] - :: bnds - in - let bnds = - let arg = sexp_of_string v_pattern in - Ppx_sexp_conv_lib.Sexp.List [ Ppx_sexp_conv_lib.Sexp.Atom "pattern"; arg ] - :: bnds - in - Ppx_sexp_conv_lib.Sexp.List bnds - : t -> Ppx_sexp_conv_lib.Sexp.t) + (fun { pattern = pattern__007_ + ; case_sensitive = case_sensitive__009_ + ; kmp_array = kmp_array__011_ + } -> + let bnds__006_ = [] in + let bnds__006_ = + let arg__012_ = sexp_of_array sexp_of_int kmp_array__011_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "kmp_array"; arg__012_ ] :: bnds__006_ + in + let bnds__006_ = + let arg__010_ = sexp_of_bool case_sensitive__009_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "case_sensitive"; arg__010_ ] + :: bnds__006_ + in + let bnds__006_ = + let arg__008_ = sexp_of_string pattern__007_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "pattern"; arg__008_ ] :: bnds__006_ + in + Sexplib0.Sexp.List bnds__006_ + : t -> Sexplib0.Sexp.t) ;; [@@@end] @@ -444,10 +429,7 @@ let substr_index_all_gen ~case_sensitive t ~may_overlap ~pattern = ;; let substr_replace_first_gen ~case_sensitive ?pos t ~pattern = - Search_pattern.replace_first - ?pos - (Search_pattern.create ~case_sensitive pattern) - ~in_:t + Search_pattern.replace_first ?pos (Search_pattern.create ~case_sensitive pattern) ~in_:t ;; let substr_replace_all_gen ~case_sensitive t ~pattern = @@ -470,8 +452,7 @@ let is_substring_at_gen = if sub_pos = sub_len then true else if char_equal (unsafe_get str str_pos) (unsafe_get sub sub_pos) - then - loop ~str ~str_pos:(str_pos + 1) ~sub ~sub_pos:(sub_pos + 1) ~sub_len ~char_equal + then loop ~str ~str_pos:(str_pos + 1) ~sub ~sub_pos:(sub_pos + 1) ~sub_len ~char_equal else false in fun str ~pos:str_pos ~substring:sub ~char_equal -> @@ -508,16 +489,15 @@ let is_prefix_gen string ~prefix ~char_equal = module Caseless = struct module T = struct - type t = string [@@deriving_inline sexp] + type t = string [@@deriving_inline sexp, sexp_grammar] - let t_of_sexp = (string_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t) - let sexp_of_t = (sexp_of_string : t -> Ppx_sexp_conv_lib.Sexp.t) + let t_of_sexp = (string_of_sexp : Sexplib0.Sexp.t -> t) + let sexp_of_t = (sexp_of_string : t -> Sexplib0.Sexp.t) + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = string_sexp_grammar [@@@end] - let char_compare_caseless c1 c2 = - Char.compare (Char.lowercase c1) (Char.lowercase c2) - ;; + let char_compare_caseless c1 c2 = Char.compare (Char.lowercase c1) (Char.lowercase c2) let rec compare_loop ~pos ~string1 ~len1 ~string2 ~len2 = if pos = len1 @@ -525,9 +505,7 @@ module Caseless = struct else if pos = len2 then 1 else ( - let c = - char_compare_caseless (unsafe_get string1 pos) (unsafe_get string2 pos) - in + let c = char_compare_caseless (unsafe_get string1 pos) (unsafe_get string2 pos) in match c with | 0 -> compare_loop ~pos:(pos + 1) ~string1 ~len1 ~string2 ~len2 | _ -> c) @@ -817,16 +795,24 @@ let for_all = fun s ~f -> loop s 0 ~len:(length s) ~f ;; -let fold t ~init ~f = - let n = length t in - let rec loop i ac = if i = n then ac else loop (i + 1) (f ac t.[i]) in - loop 0 init +let fold = + let rec loop t i ac ~f ~len = + if i = len then ac else loop t (i + 1) (f ac t.[i]) ~f ~len + in + fun t ~init ~f -> loop t 0 init ~f ~len:(length t) ;; -let foldi t ~init ~f = - let n = length t in - let rec loop i ac = if i = n then ac else loop (i + 1) (f i ac t.[i]) in - loop 0 init +let foldi = + let rec loop t i ac ~f ~len = + if i = len then ac else loop t (i + 1) (f i ac t.[i]) ~f ~len + in + fun t ~init ~f -> loop t 0 init ~f ~len:(length t) +;; + +let iteri t ~f = + for i = 0 to length t - 1 do + f i (unsafe_get t i) + done ;; let count t ~f = Container.count ~fold t ~f @@ -835,6 +821,11 @@ let min_elt t = Container.min_elt ~fold t let max_elt t = Container.max_elt ~fold t let fold_result t ~init ~f = Container.fold_result ~fold ~init ~f t let fold_until t ~init ~f = Container.fold_until ~fold ~init ~f t +let find_mapi t ~f = Indexed_container.find_mapi ~iteri t ~f +let findi t ~f = Indexed_container.findi ~iteri t ~f +let counti t ~f = Indexed_container.counti ~foldi t ~f +let for_alli t ~f = Indexed_container.for_alli ~iteri t ~f +let existsi t ~f = Indexed_container.existsi ~iteri t ~f let mem = let rec loop t c ~pos:i ~len = @@ -944,6 +935,32 @@ let filter t ~f = if !out_pos = n - 1 then out else sub out ~pos:0 ~len:!out_pos) ;; +(* repeated code to avoid requiring an extra allocation for a closure on each call. *) +let filteri t ~f = + let n = length t in + let i = ref 0 in + while !i < n && f !i t.[!i] do + incr i + done; + if !i = n + then t + else ( + let out = Bytes.create (n - 1) in + Bytes.blit_string ~src:t ~src_pos:0 ~dst:out ~dst_pos:0 ~len:!i; + let out_pos = ref !i in + incr i; + while !i < n do + let c = t.[!i] in + if f !i c + then ( + Bytes.set out !out_pos c; + incr out_pos); + incr i + done; + let out = Bytes.unsafe_to_string ~no_mutation_while_string_reachable:out in + if !out_pos = n - 1 then out else sub out ~pos:0 ~len:!out_pos) +;; + let chop_prefix s ~prefix = if is_prefix s ~prefix then Some (drop_prefix s (length prefix)) else None ;; @@ -972,6 +989,114 @@ let chop_suffix_exn s ~suffix = | None -> invalid_argf "String.chop_suffix_exn %S %S" s suffix () ;; +module For_common_prefix_and_suffix = struct + (* When taking a string prefix or suffix, we extract from the shortest input available + in case we can just return one of our inputs without allocating a new string. *) + + let shorter a b = if length a <= length b then a else b + + let shortest list = + match list with + | [] -> "" + | first :: rest -> List.fold rest ~init:first ~f:shorter + ;; + + (* Our generic accessors for common prefix/suffix abstract over [get_pos], which is + either [pos_from_left] or [pos_from_right]. *) + + let pos_from_left (_ : t) (i : int) = i + let pos_from_right t i = length t - i - 1 + + let rec common_generic2_length_loop a b ~get_pos ~max_len ~len_so_far = + if len_so_far >= max_len + then max_len + else if Char.equal + (unsafe_get a (get_pos a len_so_far)) + (unsafe_get b (get_pos b len_so_far)) + then common_generic2_length_loop a b ~get_pos ~max_len ~len_so_far:(len_so_far + 1) + else len_so_far + ;; + + let common_generic2_length a b ~get_pos = + let max_len = min (length a) (length b) in + common_generic2_length_loop a b ~get_pos ~max_len ~len_so_far:0 + ;; + + let rec common_generic_length_loop first list ~get_pos ~max_len = + match list with + | [] -> max_len + | second :: rest -> + let max_len = + (* We call [common_generic2_length_loop] rather than [common_generic2_length] so + that [max_len] limits our traversal of [first] and [second]. *) + common_generic2_length_loop first second ~get_pos ~max_len ~len_so_far:0 + in + common_generic_length_loop second rest ~get_pos ~max_len + ;; + + let common_generic_length list ~get_pos = + match list with + | [] -> 0 + | first :: rest -> + (* Precomputing [max_len] based on [shortest list] saves us work in longer strings, + at the cost of an extra pass over the spine of [list]. + + For example, if you're looking for the longest prefix of the strings: + + {v + let long_a = List.init 1000 ~f:(Fn.const 'a') + [ long_a; long_a; 'aa' ] + v} + + the approach below will just check the first two characters of all the strings. + *) + let max_len = length (shortest list) in + common_generic_length_loop first rest ~get_pos ~max_len + ;; + + (* Our generic accessors that produce a string abstract over [take], which is either + [prefix] or [suffix]. *) + + let common_generic2 a b ~get_pos ~take = + let len = common_generic2_length a b ~get_pos in + (* Use the shorter of the two strings, so that if the shorter one is the shared + prefix, [take] won't allocate another string. *) + take (shorter a b) len + ;; + + let common_generic list ~get_pos ~take = + match list with + | [] -> "" + | first :: rest -> + (* As with [common_generic_length], we base [max_len] on [shortest list]. We also + use this result for [take], below, to potentially avoid allocating a string. *) + let s = shortest list in + let max_len = length s in + if max_len = 0 + then "" + else ( + let len = + (* We call directly into [common_generic_length_loop] rather than + [common_generic_length] to avoid recomputing [shortest list]. *) + common_generic_length_loop first rest ~get_pos ~max_len + in + take s len) + ;; +end + +include struct + open For_common_prefix_and_suffix + + let common_prefix list = common_generic list ~take:prefix ~get_pos:pos_from_left + let common_suffix list = common_generic list ~take:suffix ~get_pos:pos_from_right + let common_prefix2 a b = common_generic2 a b ~take:prefix ~get_pos:pos_from_left + let common_suffix2 a b = common_generic2 a b ~take:suffix ~get_pos:pos_from_right + let common_prefix_length list = common_generic_length list ~get_pos:pos_from_left + let common_suffix_length list = common_generic_length list ~get_pos:pos_from_right + let common_prefix2_length a b = common_generic2_length a b ~get_pos:pos_from_left + let common_suffix2_length a b = common_generic2_length a b ~get_pos:pos_from_right +end + (* There used to be a custom implementation that was faster for very short strings (peaking at 40% faster for 4-6 char long strings). This new function is around 20% faster than the default hash function, but slower @@ -990,11 +1115,10 @@ end let _ = hash include Hash -include Comparable.Validate (T) (* for interactive top-levels -- modules deriving from String should have String's pretty printer. *) -let pp = Caml.Format.pp_print_string +let pp ppf string = Caml.Format.fprintf ppf "%S" string let of_char c = make 1 c let of_char_list l = @@ -1258,8 +1382,7 @@ module Escaping = struct ;; let check_bound str pos function_name = - if pos >= length str || pos < 0 - then invalid_argf "%s: out of bounds" function_name () + if pos >= length str || pos < 0 then invalid_argf "%s: out of bounds" function_name () ;; let is_char_escaping str ~escape_char pos = diff --git a/src/string.mli b/src/string.mli index bd0a22e..a226755 100644 --- a/src/string.mli +++ b/src/string.mli @@ -5,16 +5,16 @@ open! Import type t = string [@@deriving_inline sexp, sexp_grammar] -include Ppx_sexp_conv_lib.Sexpable.S with type t := t +include Sexplib0.Sexpable.S with type t := t -val t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t +val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] val sub : (t, t) Blit.sub val subo : (t, t) Blit.subo -include Container.S0 with type t := t with type elt = char +include Indexed_container.S0 with type t := t with type elt = char include Identifiable.S with type t := t include Invariant.S with type t := t @@ -67,17 +67,6 @@ val capitalize : t -> t val uncapitalize : t -> t -(** [index] gives the index of the first appearance of [char] in the string when - searching from left to right, or [None] if it's not found. [rindex] does the same but - searches from the right. - - For example, [String.index "Foo" 'o'] is [Some 1] while [String.rindex "Foo" 'o'] is - [Some 2]. - - The [_exn] versions return the actual index (instead of an option) when [char] is - found, and throw an exception otherwise. -*) - (** [Caseless] compares and hashes strings ignoring case, so that for example [Caseless.equal "OCaml" "ocaml"] and [Caseless.("apple" < "Banana")] are [true]. @@ -85,12 +74,12 @@ val uncapitalize : t -> t that for example [Caseless.is_suffix "OCaml" ~suffix:"AmL"] and [Caseless.is_prefix "OCaml" ~prefix:"oc"] are [true]. *) module Caseless : sig - type nonrec t = t [@@deriving_inline hash, sexp] + type nonrec t = t [@@deriving_inline hash, sexp, sexp_grammar] - val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state - val hash : t -> Ppx_hash_lib.Std.Hash.hash_value + include Ppx_hash_lib.Hashable.S with type t := t + include Sexplib0.Sexpable.S with type t := t - include Ppx_sexp_conv_lib.Sexpable.S with type t := t + val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] @@ -107,19 +96,24 @@ module Caseless : sig val substr_replace_all : t -> pattern:t -> with_:t -> t end -(** [index_exn] and [index_from_exn] raise [Caml.Not_found] or [Not_found_s] when [char] - cannot be found in [s]. *) -val index : t -> char -> int option +(** [index] gives the index of the first appearance of [char] in the string when + searching from left to right, or [None] if it's not found. [rindex] does the same but + searches from the right. + + For example, [String.index "Foo" 'o'] is [Some 1] while [String.rindex "Foo" 'o'] is + [Some 2]. + The [_exn] versions return the actual index (instead of an option) when [char] is + found, and raise [Caml.Not_found] or [Not_found_s] otherwise. +*) + +val index : t -> char -> int option val index_exn : t -> char -> int val index_from : t -> int -> char -> int option val index_from_exn : t -> int -> char -> int -(** [rindex_exn] and [rindex_from_exn] raise [Caml.Not_found] or [Not_found_s] when [char] - cannot be found in [s]. *) val rindex : t -> char -> int option - val rindex_exn : t -> char -> int val rindex_from : t -> int -> char -> int option val rindex_from_exn : t -> int -> char -> int @@ -132,7 +126,7 @@ val rindex_from_exn : t -> int -> char -> int module Search_pattern : sig type t [@@deriving_inline sexp_of] - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] @@ -176,6 +170,10 @@ module Search_pattern : sig val replace_all : t -> in_:string -> with_:string -> string + (** Similar to [String.split] or [String.split_on_chars], but instead uses a given + search pattern as the separator. Separators are non-overlapping. *) + val split_on : t -> string -> string list + (**/**) (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: @@ -191,8 +189,9 @@ module Search_pattern : sig } [@@deriving_inline equal, sexp_of] - val equal : t -> t -> bool - val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t + include Ppx_compare_lib.Equal.S with type t := t + + val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] @@ -304,6 +303,9 @@ val concat_map : ?sep:t -> t -> f:(char -> t) -> t (** [filter s ~f:predicate] discards characters not satisfying [predicate]. *) val filter : t -> f:(char -> bool) -> t +(** Like [filter], but passes each character's index to [f] along with the char. *) +val filteri : t -> f:(int -> char -> bool) -> t + (** [tr ~target ~replacement s] replaces every instance of [target] in [s] with [replacement]. *) val tr : target:char -> replacement:char -> t -> t @@ -360,6 +362,30 @@ val drop_suffix : t -> int -> t [n]. *) val drop_prefix : t -> int -> t +(** Produces the longest common suffix, or [""] if the list is empty. *) +val common_suffix : t list -> t + +(** Produces the longest common prefix, or [""] if the list is empty. *) +val common_prefix : t list -> t + +(** Produces the length of the longest common suffix, or 0 if the list is empty. *) +val common_suffix_length : t list -> int + +(** Produces the length of the longest common prefix, or 0 if the list is empty. *) +val common_prefix_length : t list -> int + +(** Produces the longest common suffix. *) +val common_suffix2 : t -> t -> t + +(** Produces the longest common prefix. *) +val common_prefix2 : t -> t -> t + +(** Produces the length of the longest common suffix. *) +val common_suffix2_length : t -> t -> int + +(** Produces the length of the longest common prefix. *) +val common_prefix2_length : t -> t -> int + (** [concat_array sep ar] like {!String.concat}, but operates on arrays. *) val concat_array : ?sep:t -> t array -> t diff --git a/src/sys.mli b/src/sys.mli index c31b2e4..04d61d4 100644 --- a/src/sys.mli +++ b/src/sys.mli @@ -21,9 +21,14 @@ val argv : string array otherwise. *) val interactive : bool ref -(** [os_type] describes the operating system that the OCaml program is running on. Its - value is one of ["Unix"], ["Win32"], or ["Cygwin"]. When running in JavaScript, it is - ["Unix"]. *) +(** [os_type] describes the operating system that the OCaml program is running on. + + Its value is one of: + - ["Unix"] (for all Unix versions, including Linux and macOS); + - ["Win32"] (for MS-Windows, OCaml compiled with MSVC++ or MinGW); or + - ["Cygwin"] (for MS-Windows, OCaml compiled with Cygwin) + + When running in JavaScript, it is ["Unix"]. *) val os_type : string (** [unix] is [true] if [os_type = "Unix"]. *) @@ -103,6 +108,7 @@ val getenv : string -> string option val getenv_exn : string -> string + (** For the purposes of optimization, [opaque_identity] behaves like an unknown (and thus possibly side-effecting) function. At runtime, [opaque_identity] disappears altogether. A typical use of this function is to prevent pure computations from being diff --git a/src/type_equal.ml b/src/type_equal.ml index f7c1523..e004cd8 100644 --- a/src/type_equal.ml +++ b/src/type_equal.ml @@ -2,15 +2,14 @@ open! Import type ('a, 'b) t = T : ('a, 'a) t [@@deriving_inline sexp_of] -let sexp_of_t - : type a b. - (a -> Ppx_sexp_conv_lib.Sexp.t) - -> (b -> Ppx_sexp_conv_lib.Sexp.t) - -> (a, b) t - -> Ppx_sexp_conv_lib.Sexp.t +let sexp_of_t : + 'a 'b. + ('a -> Sexplib0.Sexp.t) -> ('b -> Sexplib0.Sexp.t) -> ('a, 'b) t -> Sexplib0.Sexp.t = - fun _of_a _of_b -> function - | T -> Ppx_sexp_conv_lib.Sexp.Atom "T" + fun (type a__003_ b__004_) + : ((a__003_ -> Sexplib0.Sexp.t) -> (b__004_ -> Sexplib0.Sexp.t) + -> (a__003_, b__004_) t -> Sexplib0.Sexp.t) -> + fun _of_a__001_ _of_b__002_ T -> Sexplib0.Sexp.Atom "T" ;; [@@@end] @@ -55,9 +54,7 @@ let detuple2 (type a1 a2 b1 b2) (T : (a1 * a2, b1 * b2) t) : (a1, b1) t * (a2, b T, T ;; -let tuple2 (type a1 a2 b1 b2) (T : (a1, b1) t) (T : (a2, b2) t) : (a1 * a2, b1 * b2) t = - T -;; +let tuple2 (type a1 a2 b1 b2) (T : (a1, b1) t) (T : (a2, b2) t) : (a1 * a2, b1 * b2) t = T module type Injective = sig type 'a t @@ -95,11 +92,9 @@ module Id = struct type type_witness_int = [ `type_witness of int ] [@@deriving_inline sexp_of] let sexp_of_type_witness_int = - (function - | `type_witness v0 -> - Ppx_sexp_conv_lib.Sexp.List - [ Ppx_sexp_conv_lib.Sexp.Atom "type_witness"; sexp_of_int v0 ] - : type_witness_int -> Ppx_sexp_conv_lib.Sexp.t) + (fun (`type_witness v__005_) -> + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "type_witness"; sexp_of_int v__005_ ] + : type_witness_int -> Sexplib0.Sexp.t) ;; [@@@end] diff --git a/src/type_equal.mli b/src/type_equal.mli index 380a1d4..a440758 100644 --- a/src/type_equal.mli +++ b/src/type_equal.mli @@ -35,10 +35,10 @@ open T type ('a, 'b) t = T : ('a, 'a) t [@@deriving_inline sexp_of] val sexp_of_t - : ('a -> Ppx_sexp_conv_lib.Sexp.t) - -> ('b -> Ppx_sexp_conv_lib.Sexp.t) + : ('a -> Sexplib0.Sexp.t) + -> ('b -> Sexplib0.Sexp.t) -> ('a, 'b) t - -> Ppx_sexp_conv_lib.Sexp.t + -> Sexplib0.Sexp.t [@@@end] @@ -125,8 +125,8 @@ val tuple2 : ('a1, 'b1) t -> ('a2, 'b2) t -> ('a1 * 'a2, 'b1 * 'b2) t are equal from a proof that both types transformed by [M.t] are equal. OCaml has no built-in language feature to state that a type is injective, which is why - we have [module type Injective]. However, OCaml can infer that a type is injective, - and we can use this to match [Injective]. A typical implementation will look like + we have [module type Injective]. However, OCaml can infer that a type is injective, + and we can use this to match [Injective]. A typical implementation will look like this: {[ @@ -183,7 +183,7 @@ module Composition_preserves_injectivity (M1 : Injective) (M2 : Injective) : module Id : sig type 'a t [@@deriving_inline sexp_of] - val sexp_of_t : ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t + val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t [@@@end] @@ -192,8 +192,7 @@ module Id : sig module Uid : sig type t [@@deriving_inline hash] - val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state - val hash : t -> Ppx_hash_lib.Std.Hash.hash_value + include Ppx_hash_lib.Hashable.S with type t := t [@@@end] diff --git a/src/uchar.ml b/src/uchar.ml index 2b2567a..9c068f4 100644 --- a/src/uchar.ml +++ b/src/uchar.ml @@ -21,6 +21,10 @@ module T = struct (try Caml.Scanf.sscanf s "U+%X" (fun i -> Uchar0.of_int i) with | _ -> of_sexp_error "Uchar.t_of_sexp: atom of the form U+XXXX needed" sexp) ;; + + let t_sexp_grammar : t Sexplib0.Sexp_grammar.t = + Sexplib0.Sexp_grammar.coerce String.t_sexp_grammar + ;; end include T @@ -72,6 +76,17 @@ let to_char_exn c = else failwithf "Uchar.to_char_exn got a non latin-1 character: U+%04X" (to_int c) () ;; +let utf8_byte_length uchar = + let codepoint = to_scalar uchar in + if Int.( < ) codepoint 0x80 + then 1 + else if Int.( < ) codepoint 0x800 + then 2 + else if Int.( < ) codepoint 0x10000 + then 3 + else 4 +;; + (* Include type-specific [Replace_polymorphic_compare] at the end, after including functor application that could shadow its definitions. This is here so that efficient versions of the comparison functions are exported by diff --git a/src/uchar.mli b/src/uchar.mli index b25a63f..fe619b0 100644 --- a/src/uchar.mli +++ b/src/uchar.mli @@ -1,13 +1,20 @@ -(** Unicode character operations. *) +(** Unicode character operations. + + A [Uchar.t] represents a Unicode code point -- that is, an integer identifying the + character in abstract. This module does not provide any utilties for converting + [Uchar.t]s to and from strings -- in order to do so, one needs to settle on a + particular encoding, such as UTF-8 or UTF-16. See, for instance, the [utf8_text] + library for converting to and from UTF-8. +*) open! Import -type t = Uchar0.t [@@deriving_inline hash, sexp] +type t = Uchar0.t [@@deriving_inline hash, sexp, sexp_grammar] -val hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state -val hash : t -> Ppx_hash_lib.Std.Hash.hash_value +include Ppx_hash_lib.Hashable.S with type t := t +include Sexplib0.Sexpable.S with type t := t -include Ppx_sexp_conv_lib.Sexpable.S with type t := t +val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] @@ -52,5 +59,11 @@ val of_scalar_exn : int -> t (** [to_scalar t] is [t] as an integer scalar value. *) val to_scalar : t -> int +(** [utf8_byte_width t] returns the number of bytes needed to represent [t] in the UTF-8 + encoding (https://en.wikipedia.org/wiki/UTF-8). + +*) +val utf8_byte_length : t -> int + val min_value : t val max_value : t diff --git a/src/uniform_array.ml b/src/uniform_array.ml index 974c9f5..acf3889 100644 --- a/src/uniform_array.ml +++ b/src/uniform_array.ml @@ -21,6 +21,8 @@ module Trusted : sig val unsafe_set_int : 'a t -> int -> int -> unit val unsafe_set_int_assuming_currently_int : 'a t -> int -> int -> unit val unsafe_set_assuming_currently_int : 'a t -> int -> 'a -> unit + val unsafe_set_with_caml_modify : 'a t -> int -> 'a -> unit + val set_with_caml_modify : 'a t -> int -> 'a -> unit val length : 'a t -> int val unsafe_blit : ('a t, 'a t) Blit.blit val copy : 'a t -> 'a t @@ -56,6 +58,11 @@ end = struct Obj_array.unsafe_set_omit_phys_equal_check t i (Caml.Obj.repr x) ;; + let unsafe_set_with_caml_modify t i x = + Obj_array.unsafe_set_with_caml_modify t i (Caml.Obj.repr x) + ;; + + let set_with_caml_modify t i x = Obj_array.set_with_caml_modify t i (Caml.Obj.repr x) let unsafe_clear_if_pointer = Obj_array.unsafe_clear_if_pointer end @@ -76,6 +83,7 @@ let init l ~f = let of_array arr = init ~f:(Array.unsafe_get arr) (Array.length arr) let map a ~f = init ~f:(fun i -> f (unsafe_get a i)) (length a) +let mapi a ~f = init ~f:(fun i -> f i (unsafe_get a i)) (length a) let iter a ~f = for i = 0 to length a - 1 do @@ -89,6 +97,14 @@ let iteri a ~f = done ;; +let foldi a ~init ~f = + let acc = ref init in + for i = 0 to length a - 1 do + acc := f i !acc (unsafe_get a i) + done; + !acc +;; + let to_list t = List.init ~f:(get t) (length t) let of_list l = @@ -109,13 +125,25 @@ let exists t ~f = loop t ~f (length t - 1) ;; +let for_all t ~f = + let rec loop t ~f i = if i < 0 then true else f (unsafe_get t i) && loop t ~f (i - 1) in + loop t ~f (length t - 1) +;; + let map2_exn t1 t2 ~f = let len = length t1 in if length t2 <> len then invalid_arg "Array.map2_exn"; init len ~f:(fun i -> f (unsafe_get t1 i) (unsafe_get t2 i)) ;; -include Sexpable.Of_sexpable1 +let t_sexp_grammar (type elt) (grammar : elt Sexplib0.Sexp_grammar.t) + : elt t Sexplib0.Sexp_grammar.t + = + Sexplib0.Sexp_grammar.coerce (Array.t_sexp_grammar grammar) +;; + +include + Sexpable.Of_sexpable1 (Array) (struct type nonrec 'a t = 'a t @@ -150,3 +178,26 @@ let fold t ~init ~f = let min_elt t ~compare = Container.min_elt ~fold t ~compare let max_elt t ~compare = Container.max_elt ~fold t ~compare + +(* This is the same as the ppx_compare [compare_array] but uses our [unsafe_get] and [length]. *) +let compare compare_elt a b = + if phys_equal a b + then 0 + else ( + let len_a = length a in + let len_b = length b in + let ret = compare len_a len_b in + if ret <> 0 + then ret + else ( + let rec loop i = + if i = len_a + then 0 + else ( + let l = unsafe_get a i + and r = unsafe_get b i in + let res = compare_elt l r in + if res <> 0 then res else loop (i + 1)) + in + loop 0)) +;; diff --git a/src/uniform_array.mli b/src/uniform_array.mli index aa41794..d746fbd 100644 --- a/src/uniform_array.mli +++ b/src/uniform_array.mli @@ -10,9 +10,13 @@ open! Import (** See [Base.Array] for comments. *) -type 'a t [@@deriving_inline sexp] +type 'a t [@@deriving_inline sexp, sexp_grammar, compare] -include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t := 'a t +include Sexplib0.Sexpable.S1 with type 'a t := 'a t + +val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t + +include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t [@@@end] @@ -35,13 +39,25 @@ val swap : _ t -> int -> int -> unit values are [phys_equal]. *) val unsafe_set_omit_phys_equal_check : 'a t -> int -> 'a -> unit +(** [unsafe_set_with_caml_modify] always calls [caml_modify] before setting and never gets + the old value. This is like [unsafe_set_omit_phys_equal_check] except it doesn't + check whether the old value and the value being set are integers to try to skip + [caml_modify]. *) +val unsafe_set_with_caml_modify : 'a t -> int -> 'a -> unit + +(** Same as [unsafe_set_with_caml_modify], but with bounds check. *) +val set_with_caml_modify : 'a t -> int -> 'a -> unit + val map : 'a t -> f:('a -> 'b) -> 'b t +val mapi : 'a t -> f:(int -> 'a -> 'b) -> 'b t val iter : 'a t -> f:('a -> unit) -> unit (** Like {!iter}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) val iteri : 'a t -> f:(int -> 'a -> unit) -> unit +val foldi : 'a t -> init:'b -> f:(int -> 'b -> 'a -> 'b) -> 'b + (** [of_array] and [to_array] return fresh arrays with the same contents rather than returning a reference to the underlying array. *) val of_array : 'a array -> 'a t @@ -85,6 +101,9 @@ val unsafe_clear_if_pointer : Caml.Obj.t t -> int -> unit (** As [Array.exists]. *) val exists : 'a t -> f:('a -> bool) -> bool +(** As [Array.for_all]. *) +val for_all : 'a t -> f:('a -> bool) -> bool + (** Functions with the 2 suffix raise an exception if the lengths of the two given arrays aren't the same. *) val map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t diff --git a/src/unit.ml b/src/unit.ml index 66464d9..9796d71 100644 --- a/src/unit.ml +++ b/src/unit.ml @@ -13,28 +13,9 @@ module T = struct fun x -> func x ;; - let t_of_sexp = (unit_of_sexp : Ppx_sexp_conv_lib.Sexp.t -> t) - let sexp_of_t = (sexp_of_unit : t -> Ppx_sexp_conv_lib.Sexp.t) - - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = - { implicit_vars = [ "unit" ] - ; ggid = "\146e\023\249\235eE\139c\132W\195\137\129\235\025" - ; types = [ "t", Implicit_var 0 ] - } - in - let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = - { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () - ; apply_implicit = [ unit_sexp_grammar ] - ; generic_group = _the_generic_group - ; origin = "unit.ml.T" - } - in - let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = - Ref ("t", _the_group) - in - t_sexp_grammar - ;; + let t_of_sexp = (unit_of_sexp : Sexplib0.Sexp.t -> t) + let sexp_of_t = (sexp_of_unit : t -> Sexplib0.Sexp.t) + let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = unit_sexp_grammar [@@@end] diff --git a/src/unit.mli b/src/unit.mli index d42e80a..e43f1eb 100644 --- a/src/unit.mli +++ b/src/unit.mli @@ -4,11 +4,10 @@ open! Import type t = unit [@@deriving_inline enumerate, sexp, sexp_grammar] -val all : t list +include Ppx_enumerate_lib.Enumerable.S with type t := t +include Sexplib0.Sexpable.S with type t := t -include Ppx_sexp_conv_lib.Sexpable.S with type t := t - -val t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t +val t_sexp_grammar : t Sexplib0.Sexp_grammar.t [@@@end] diff --git a/src/validate.ml b/src/validate.ml deleted file mode 100644 index b48644d..0000000 --- a/src/validate.ml +++ /dev/null @@ -1,164 +0,0 @@ -open! Import -module Int = Int0 -module String = String0 - -(** 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_list (sexp_of_pair sexp_of_string Error.sexp_of_t)) -[@@cold] [@@inline never] [@@local never] [@@specialise never] -;; - -(** [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 x check = Or_error.map (result (protect check x)) ~f:(fun () -> x) - -let field record fld f = - let v = Field.get fld record in - let result = protect f v in - name (Field.name fld) result -;; - -let field_folder record check = - (); - fun acc fld -> field record fld check :: acc -;; - -let field_direct_folder check = - Staged.stage (fun acc fld _record v -> - match protect check v with - | [] -> acc - | result -> name (Field.name fld) 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 diff --git a/src/validate.mli b/src/validate.mli deleted file mode 100644 index f34d123..0000000 --- a/src/validate.mli +++ /dev/null @@ -1,177 +0,0 @@ -(** 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_folder t check in - V.of_list - (Fields.fold ~init:[] - ~foo:(w Int.validate_positive) - ~bar:(w Float.validate_non_negative) - ) - ]} - - - 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! Import - -(** 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 -> 'a check -> 'a Or_error.t - -(** Used for validating an individual field. *) -val field : 'record -> ([> `Read ], 'record, 'a) Field.t_with_perm -> 'a check -> t - -(** Creates a function for use in a [Fields.fold]. *) -val field_folder - : 'record - -> 'a check - -> 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 diff --git a/src/word_size.ml b/src/word_size.ml index b451730..c828842 100644 --- a/src/word_size.ml +++ b/src/word_size.ml @@ -8,9 +8,9 @@ type t = let sexp_of_t = (function - | W32 -> Ppx_sexp_conv_lib.Sexp.Atom "W32" - | W64 -> Ppx_sexp_conv_lib.Sexp.Atom "W64" - : t -> Ppx_sexp_conv_lib.Sexp.t) + | W32 -> Sexplib0.Sexp.Atom "W32" + | W64 -> Sexplib0.Sexp.Atom "W64" + : t -> Sexplib0.Sexp.t) ;; [@@@end] diff --git a/src/word_size.mli b/src/word_size.mli index 31dfeef..626b280 100644 --- a/src/word_size.mli +++ b/src/word_size.mli @@ -7,7 +7,7 @@ type t = | W64 [@@deriving_inline sexp_of] -val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t +val sexp_of_t : t -> Sexplib0.Sexp.t [@@@end] diff --git a/test/allocation/base_test_allocation.ml b/test/allocation/base_test_allocation.ml new file mode 100644 index 0000000..3e216ec --- /dev/null +++ b/test/allocation/base_test_allocation.ml @@ -0,0 +1 @@ +(*_ This library deliberately does not export anything. *) diff --git a/test/allocation/dune b/test/allocation/dune new file mode 100644 index 0000000..445beb9 --- /dev/null +++ b/test/allocation/dune @@ -0,0 +1,3 @@ +(library (name base_test_allocation) + (libraries base expect_test_helpers_core compiler-libs.common) + (preprocess (pps ppx_jane)))
\ No newline at end of file diff --git a/test/allocation/test_array_allocation.ml b/test/allocation/test_array_allocation.ml new file mode 100644 index 0000000..c77673d --- /dev/null +++ b/test/allocation/test_array_allocation.ml @@ -0,0 +1,27 @@ +open! Base +open Expect_test_helpers_core + +let%expect_test "Array.sort [||] only allocates when computing bounds" = + require_allocation_does_not_exceed (Minor_words 3) [%here] (fun () -> + Array.sort ~compare:Int.compare [||]); + [%expect {||}] +;; + +let%expect_test "Array.sort [| 5; 2; 3; 4; 1 |] only allocates when computing bounds" = + let arr = [| 5; 2; 3; 4; 1 |] in + require_allocation_does_not_exceed (Minor_words 3) [%here] (fun () -> + Array.sort ~compare:Int.compare arr); + [%expect {||}] +;; + +let%test "equal does not allocate" = + let arr1 = [| 1; 2; 3; 4 |] in + let arr2 = [| 1; 2; 4; 3 |] in + require_no_allocation [%here] (fun () -> not (Array.equal Int.equal arr1 arr2)) +;; + +let%test "foldi does not allocate" = + let arr = [| 1; 2; 3; 4 |] in + let f i x y = i + x + y in + require_no_allocation [%here] (fun () -> 16 = Array.foldi ~init:0 ~f arr) +;; diff --git a/test/test_sexp.mli b/test/allocation/test_array_allocation.mli index 74bb729..74bb729 100644 --- a/test/test_sexp.mli +++ b/test/allocation/test_array_allocation.mli diff --git a/test/allocation/test_char_allocation.ml b/test/allocation/test_char_allocation.ml new file mode 100644 index 0000000..916c256 --- /dev/null +++ b/test/allocation/test_char_allocation.ml @@ -0,0 +1,10 @@ +open! Base +open Expect_test_helpers_core + +let%expect_test _ = + let x = Sys.opaque_identity 'a' in + let y = Sys.opaque_identity 'b' in + require_no_allocation [%here] (fun () -> + ignore (Sys.opaque_identity (Char.Caseless.equal x y) : bool)); + [%expect {||}] +;; diff --git a/test/test_validate.mli b/test/allocation/test_char_allocation.mli index 74bb729..74bb729 100644 --- a/test/test_validate.mli +++ b/test/allocation/test_char_allocation.mli diff --git a/test/allocation/test_float_allocation.ml b/test/allocation/test_float_allocation.ml new file mode 100644 index 0000000..208d2d3 --- /dev/null +++ b/test/allocation/test_float_allocation.ml @@ -0,0 +1,10 @@ +open! Base +open Stdio +open Float + +let%expect_test "iround_nearest_exn noalloc" = + let t = Sys.opaque_identity 205.414 in + Expect_test_helpers_core.require_no_allocation [%here] (fun () -> iround_nearest_exn t) + |> printf "%d\n"; + [%expect {| 205 |}] +;; diff --git a/test/allocation/test_float_allocation.mli b/test/allocation/test_float_allocation.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/allocation/test_float_allocation.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/allocation/test_hashtbl_allocation.ml b/test/allocation/test_hashtbl_allocation.ml new file mode 100644 index 0000000..0cfe58c --- /dev/null +++ b/test/allocation/test_hashtbl_allocation.ml @@ -0,0 +1,89 @@ +open! Base +open Expect_test_helpers_core + +let () = Int_conversions.sexp_of_int_style := `Underscores + +let%expect_test "find_and_call_1_and_2" = + let test x = + let t = Hashtbl.create (module Int) ~size:16 ~growth_allowed:false in + for i = 0 to x - 1 do + Hashtbl.add_exn t ~key:i ~data:(i * 7) + done; + let if_found a b = assert (a = b) in + let if_not_found a b = + assert (a = x); + assert (b = x * 7) + in + require_no_allocation [%here] (fun () -> + for i = 0 to x do + Hashtbl.find_and_call1 t i ~a:(i * 7) ~if_found ~if_not_found + done); + let if_found ~key ~data:a b = + assert (a = b); + assert (key = a / 7) + in + let if_not_found a b = + assert (a = x); + assert (b = x * 7) + in + require_no_allocation [%here] (fun () -> + for i = 0 to x do + Hashtbl.findi_and_call1 t i ~a:(i * 7) ~if_found ~if_not_found + done); + let if_found a b c = + assert (a = b); + assert (b = c / 2) + in + let if_not_found a b c = + assert (a = x); + assert (b = x * 7); + assert (c = x * 14) + in + require_no_allocation [%here] (fun () -> + for i = 0 to x do + Hashtbl.find_and_call2 t i ~a:(i * 7) ~b:(i * 14) ~if_found ~if_not_found + done); + let if_found ~key ~data:a b c = + assert (a = b); + assert (b = c / 2); + assert (key = a / 7) + in + let if_not_found a b c = + assert (a = x); + assert (b = x * 7); + assert (c = x * 14) + in + require_no_allocation [%here] (fun () -> + for i = 0 to x do + Hashtbl.findi_and_call2 t i ~a:(i * 7) ~b:(i * 14) ~if_found ~if_not_found + done); + print_s (Int.sexp_of_t x) + in + (* try various load factors, to exercise all branches of matching on the structure of + the avl tree *) + test 1; + test 3; + test 10; + test 17; + test 25; + test 29; + test 33; + test 3133; + [%expect {| + 1 + 3 + 10 + 17 + 25 + 29 + 33 + 3_133 |}] +;; + +let%expect_test ("find_or_add shouldn't allocate" [@tags "no-js"]) = + let default = Fn.const () in + let t = Hashtbl.create (module Int) ~size:16 ~growth_allowed:false in + Hashtbl.add_exn t ~key:100 ~data:(); + require_no_allocation [%here] (fun () -> Hashtbl.find_or_add t 100 ~default); + [%expect {| |}] +;; diff --git a/test/allocation/test_hashtbl_allocation.mli b/test/allocation/test_hashtbl_allocation.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/allocation/test_hashtbl_allocation.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/allocation/test_list_allocation.ml b/test/allocation/test_list_allocation.ml new file mode 100644 index 0000000..9848345 --- /dev/null +++ b/test/allocation/test_list_allocation.ml @@ -0,0 +1,22 @@ +open! Base +open Expect_test_helpers_core + +let%expect_test "is_prefix does not allocate" = + let list = Sys.opaque_identity [ 1; 2; 3 ] in + let prefix = Sys.opaque_identity [ 1; 2 ] in + let equal = Int.equal in + let (_ : bool) = + require_no_allocation [%here] (fun () -> List.is_prefix list ~equal ~prefix) + in + [%expect {| |}] +;; + +let%expect_test "is_suffix does not allocate" = + let list = Sys.opaque_identity [ 1; 2; 3 ] in + let suffix = Sys.opaque_identity [ 2; 3 ] in + let equal = Int.equal in + let (_ : bool) = + require_no_allocation [%here] (fun () -> List.is_suffix list ~equal ~suffix) + in + [%expect {| |}] +;; diff --git a/test/allocation/test_list_allocation.mli b/test/allocation/test_list_allocation.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/allocation/test_list_allocation.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/allocation/test_option_array_allocation.ml b/test/allocation/test_option_array_allocation.ml new file mode 100644 index 0000000..9d5dc4d --- /dev/null +++ b/test/allocation/test_option_array_allocation.ml @@ -0,0 +1,49 @@ +open! Base +open Option_array +open Expect_test_helpers_core + +let%expect_test "[match get] returning [None] does not allocate" = + let t = of_array [| None |] in + assert ( + require_no_allocation [%here] (fun () -> + match get t 0 with + | None -> true + | Some _ -> false)); + [%expect {||}] +;; + +let%expect_test ("[match get] returning [Some] allocates" [@tags "no-js"]) = + let t = of_array [| Some 0 |] in + let get_some () = + match get t 0 with + | None -> false + | Some _ -> true + in + (* After inlining, [match get t 0 with] is: + + {[ + match + let cheap_option = Uniform_array.get t 0 in + if Cheap_option.is_some cheap_option + then Some (Cheap_option.value_unsafe cheap_option) + else None + with + ]} + + This situation is called "match-in-match" (the inner [if] is essentially a match). + The OCaml compiler and Flambda optimizer don't handle match-in-match well, and so + cannot eliminate the allocation of [Some]. Flambda2 is expected to eliminate the + allocation, at which point we can [require_no_allocation] (possibly annotating the + test with [@tags "fast-flambda"]). + *) + let compiler_eliminates_the_allocation = Config.flambda2 in + (if compiler_eliminates_the_allocation + then assert (require_no_allocation [%here] get_some) + else + let module Gc = Core.Gc.For_testing in + let _, { Gc.Allocation_report.minor_words_allocated; _ } = + Gc.measure_allocation get_some + in + assert (minor_words_allocated = 2)); + [%expect {||}] +;; diff --git a/test/allocation/test_option_array_allocation.mli b/test/allocation/test_option_array_allocation.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/allocation/test_option_array_allocation.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/allocation/test_string_allocation.ml b/test/allocation/test_string_allocation.ml new file mode 100644 index 0000000..83a87d3 --- /dev/null +++ b/test/allocation/test_string_allocation.ml @@ -0,0 +1,178 @@ +open! Base +open Expect_test_helpers_core + +let%expect_test _ = + let x = Sys.opaque_identity "one string" in + let y = Sys.opaque_identity "another" in + require_no_allocation [%here] (fun () -> + ignore (Sys.opaque_identity (String.Caseless.equal x y) : bool)); + [%expect {||}] +;; + +let%expect_test "empty substring" = + let string = String.init 10 ~f:Char.of_int_exn in + let test here f = + let substring = require_no_allocation here f in + assert (String.is_empty substring) + in + test [%here] (fun () -> String.sub string ~pos:0 ~len:0); + test [%here] (fun () -> String.prefix string 0); + test [%here] (fun () -> String.suffix string 0); + test [%here] (fun () -> String.drop_prefix string 10); + test [%here] (fun () -> String.drop_suffix string 10); + [%expect {| |}] +;; + +let%expect_test "mem does not allocate" = + let string = Sys.opaque_identity "abracadabra" in + let char = Sys.opaque_identity 'd' in + require_no_allocation [%here] (fun () -> ignore (String.mem string char : bool)); + [%expect {||}] +;; + +let%expect_test "fold does not allocate" = + let string = Sys.opaque_identity "abracadabra" in + let char = Sys.opaque_identity 'd' in + let f acc c = if Char.equal c char then true else acc in + require_no_allocation [%here] (fun () -> + ignore (String.fold string ~init:false ~f : bool)); + [%expect {||}] +;; + +let%expect_test "foldi does not allocate" = + let string = Sys.opaque_identity "abracadabra" in + let char = Sys.opaque_identity 'd' in + let f _i acc c = if Char.equal c char then true else acc in + require_no_allocation [%here] (fun () -> + ignore (String.foldi string ~init:false ~f : bool)); + [%expect {||}] +;; + +let%test_module "common prefix and suffix" = + (module struct + let require_int_equal a b ~message = require_equal [%here] (module Int) a b ~message + + let require_string_equal a b ~message = + require_equal [%here] (module String) a b ~message + ;; + + let simulate_common_length ~get_common2_length list = + let rec loop acc prev list ~get_common2_length = + match list with + | [] -> acc + | head :: tail -> + loop (Int.min acc (get_common2_length prev head)) head tail ~get_common2_length + in + match list with + | [] -> 0 + | [ head ] -> String.length head + | head :: tail -> loop Int.max_value head tail ~get_common2_length + ;; + + let get_shortest_and_longest list = + let compare_by_length = Comparable.lift Int.compare ~f:String.length in + Option.both + (List.min_elt list ~compare:compare_by_length) + (List.max_elt list ~compare:compare_by_length) + ;; + + let test_generic get_common get_common2 get_common_length get_common2_length = + Staged.stage (fun list -> + let common = get_common list in + print_s [%sexp (common : string)]; + let len = get_common_length list in + require_int_equal len (String.length common) ~message:"wrong length"; + let common2 = List.reduce list ~f:get_common2 |> Option.value ~default:"" in + require_string_equal common common2 ~message:"pairwise result mismatch"; + let len2 = simulate_common_length ~get_common2_length list in + require_int_equal len len2 ~message:"pairwise length mismatch"; + if not (String.is_empty common || List.mem list common ~equal:String.equal) + then print_endline "(may allocate)" + else ( + ignore (require_no_allocation [%here] (fun () -> get_common list) : string); + Option.iter (get_shortest_and_longest list) ~f:(fun (shortest, longest) -> + ignore + (require_no_allocation [%here] (fun () -> get_common2 shortest longest) + : string); + ignore + (require_no_allocation [%here] (fun () -> get_common2 longest shortest) + : string)))) + ;; + + let test_prefix = + test_generic + String.common_prefix + String.common_prefix2 + String.common_prefix_length + String.common_prefix2_length + |> Staged.unstage + ;; + + let test_suffix = + test_generic + String.common_suffix + String.common_suffix2 + String.common_suffix_length + String.common_suffix2_length + |> Staged.unstage + ;; + + let%expect_test "empty" = + test_prefix []; + [%expect {| "" |}]; + test_suffix []; + [%expect {| "" |}] + ;; + + let%expect_test "singleton" = + test_prefix [ "abut" ]; + [%expect {| abut |}]; + test_suffix [ "tuba" ]; + [%expect {| tuba |}] + ;; + + let%expect_test "doubleton, alloc" = + test_prefix [ "hello"; "help"; "hex" ]; + [%expect {| + he + (may allocate) |}]; + test_suffix [ "crest"; "zest"; "1st" ]; + [%expect {| + st + (may allocate) |}] + ;; + + let%expect_test "doubleton, no alloc" = + test_prefix [ "hello"; "help"; "he" ]; + [%expect {| he |}]; + test_suffix [ "crest"; "zest"; "st" ]; + [%expect {| st |}] + ;; + + let%expect_test "many, alloc" = + test_prefix [ "this"; "that"; "the other"; "these"; "those"; "thy"; "thou" ]; + [%expect {| + th + (may allocate) |}]; + test_suffix [ "fourth"; "fifth"; "sixth"; "seventh"; "eleventh"; "twelfth" ]; + [%expect {| + th + (may allocate) |}] + ;; + + let%expect_test "many, no alloc" = + test_prefix [ "inconsequential"; "invariant"; "in"; "inner"; "increment" ]; + [%expect {| in |}]; + test_suffix [ "fat"; "cat"; "sat"; "at"; "bat" ]; + [%expect {| at |}] + ;; + + let%expect_test "many, nothing in common" = + let lorem_ipsum = [ "lorem"; "ipsum"; "dolor"; "sit"; "amet" ] in + test_prefix lorem_ipsum; + [%expect {| "" |}]; + test_suffix lorem_ipsum; + [%expect {| "" |}] + ;; + end) +;; diff --git a/test/allocation/test_string_allocation.mli b/test/allocation/test_string_allocation.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/allocation/test_string_allocation.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/allocation/test_type_equal_allocation.ml b/test/allocation/test_type_equal_allocation.ml new file mode 100644 index 0000000..c7d2fcd --- /dev/null +++ b/test/allocation/test_type_equal_allocation.ml @@ -0,0 +1,9 @@ +open! Base +open Expect_test_helpers_core + +let t1 = Type_equal.Id.create ~name:"t1" [%sexp_of: _] + +let%expect_test "Type_equal.Id.to_sexp allocation" = + require_no_allocation [%here] (fun () -> + ignore (Type_equal.Id.to_sexp t1 : 'a -> Sexp.t)) +;; diff --git a/test/allocation/test_type_equal_allocation.mli b/test/allocation/test_type_equal_allocation.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/allocation/test_type_equal_allocation.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) @@ -1,4 +1,5 @@ (library (name base_test) - (libraries base core_kernel.base_for_tests base_test_helpers caml sexplib - num expect_test_helpers_core stdio) + (libraries base core.base_for_tests base_test_helpers caml + expect_test_helpers_core.expect_test_helpers_base sexplib sexp_grammar num + stdio uutf) (preprocess (pps ppx_jane -dont-apply=pipebang)))
\ No newline at end of file diff --git a/test/hashtbl_tests.ml b/test/hashtbl_tests.ml index 3f68ac3..f292039 100644 --- a/test/hashtbl_tests.ml +++ b/test/hashtbl_tests.ml @@ -46,7 +46,7 @@ module Make (Hashtbl : Hashtbl_for_testing) = struct ;; (* In js_of_ocaml, strings can be hashconst-ed. *) - let%test ("findi_and_call"[@tags "no-js"]) = + let%test ("findi_and_call" [@tags "no-js"]) = let our_hash = Hashtbl.copy test_hash in let test_string = "test string" in Hashtbl.add_exn our_hash ~key:test_string ~data:10; @@ -331,8 +331,7 @@ module Make (Hashtbl : Hashtbl_for_testing) = struct let t1 = make [ 1, 111; 2, 222; 3, 333 ] in let t2 = make [ 1, 123; 2, 222; 4, 444 ] in [%test_result: (int * [ `Left of int | `Right of int | `Both of int * int ]) List.t] - (Hashtbl.merge t1 t2 ~f:(fun ~key:_ -> - function + (Hashtbl.merge t1 t2 ~f:(fun ~key:_ -> function | `Left x -> Some (`Left x) | `Right y -> Some (`Right y) | `Both (x, y) -> if x = y then None else Some (`Both (x, y))) @@ -341,3 +340,34 @@ module Make (Hashtbl : Hashtbl_for_testing) = struct ~expect:[ 1, `Both (111, 123); 3, `Left 333; 4, `Right 444 ] ;; end + +(* typechecking this code is a compile-time test that [Creators] is a specialization of + [Creators_generic]. *) +module _ : sig end = struct + module Make_creators_check + (Type : T.T2) + (Key : T.T1) + (Options : T.T3) + (_ : Hashtbl.Private.Creators_generic + with type ('a, 'b) t := ('a, 'b) Type.t + with type 'a key := 'a Key.t + with type ('a, 'b, 'z) create_options := ('a, 'b, 'z) Options.t) = + struct end + + module _ (M : Hashtbl.Creators) = + Make_creators_check + (struct + type ('a, 'b) t = ('a, 'b) M.t + end) + (struct + type 'a t = 'a + end) + (struct + type ('a, 'b, 'z) t = ('a, 'b, 'z) Hashtbl.create_options + end) + (struct + include M + + let create ?growth_allowed ?size m () = create ?growth_allowed ?size m + end) +end diff --git a/test/helpers/test_container.ml b/test/helpers/test_container.ml index 8888b21..1848447 100644 --- a/test/helpers/test_container.ml +++ b/test/helpers/test_container.ml @@ -57,11 +57,9 @@ struct sorts_are_equal list (Container.fold c ~init:[] ~f:(fun ac e -> e :: ac))); assert (sorts_are_equal list (Container.to_list c)); assert (sorts_are_equal list (Array.to_list (Container.to_array c))); + assert (n > 0 = Option.is_some (Container.find c ~f:(fun e -> Elt.to_int e = 0))); assert ( - n > 0 = Option.is_some (Container.find c ~f:(fun e -> Elt.to_int e = 0))); - assert ( - n > 0 = Option.is_some (Container.find c ~f:(fun e -> Elt.to_int e = n - 1)) - ); + n > 0 = Option.is_some (Container.find c ~f:(fun e -> Elt.to_int e = n - 1))); assert (Option.is_none (Container.find c ~f:(fun e -> Elt.to_int e = n))); assert (n > 0 = Container.mem c (Elt.of_int 0) ~equal:( = )); assert (n > 0 = Container.mem c (Elt.of_int (n - 1)) ~equal:( = )); @@ -134,8 +132,7 @@ struct let forall_should_be = List.fold bools ~init:true ~f:(fun ac b -> b && ac) in let exists_should_be = List.fold bools ~init:false ~f:(fun ac b -> b || ac) in match - Container.of_list - (List.map bools ~f:(fun b -> Elt.of_int (if b then 1 else 0))) + Container.of_list (List.map bools ~f:(fun b -> Elt.of_int (if b then 1 else 0))) with | `Skip_test -> () | `Ok container -> @@ -155,7 +152,8 @@ module Test_S1_allow_skipping_tests (Container : sig val of_list : 'a list -> [ `Ok of 'a t | `Skip_test ] end) = struct - include Test_generic + include + Test_generic (struct type 'a t = 'a diff --git a/test/helpers/test_stack.ml b/test/helpers/test_stack.ml index 6fa0be7..5ec6087 100644 --- a/test/helpers/test_stack.ml +++ b/test/helpers/test_stack.ml @@ -7,6 +7,7 @@ module Debug (Stack : S) : S with type 'a t = 'a Stack.t = struct type nonrec 'a t = 'a t let invariant = invariant + let t_sexp_grammar = t_sexp_grammar let check_and_return t = invariant ignore t; @@ -64,6 +65,7 @@ struct include Test_container.Test_S1 (Stack) + let t_sexp_grammar = t_sexp_grammar let invariant = invariant let create = create let is_empty = is_empty diff --git a/test/import.ml b/test/import.ml index 52dfdb6..184abf9 100644 --- a/test/import.ml +++ b/test/import.ml @@ -3,10 +3,7 @@ include Stdio include Base_for_tests include Base_test_helpers include Base_quickcheck.Export -include Expect_test_helpers_core - -module Core_kernel = struct end -[@@deprecated "[since 1970-01] Don't use Core_kernel in Base tests. Use Base."] +include Expect_test_helpers_base let () = Int_conversions.sexp_of_int_style := `Underscores let is_none = Option.is_none diff --git a/test/interfaces_tests.ml b/test/interfaces_tests.ml index 38405de..fa7ada8 100644 --- a/test/interfaces_tests.ml +++ b/test/interfaces_tests.ml @@ -1,61 +1,53 @@ +(* Typechecking this code is a compile-time check that the specific interfaces have not + drifted apart from each other. *) + open Base -let () = - let module M : sig - open Set - - type ('a, 'b) t - - include - Accessors2 - with type ('a, 'b) t := ('a, 'b) t - with type ('a, 'b) tree := ('a, 'b) Set.Using_comparator.Tree.t - with type ('a, 'b) named := ('a, 'b) Set.Named.t - - include - Creators_generic - with type ('a, 'b, 'c) options := ('a, 'b, 'c) With_first_class_module.t - with type ('a, 'b) set := ('a, 'b) t - with type ('a, 'b) t := ('a, 'b) t - with type ('a, 'b) tree := ('a, 'b) Set.Using_comparator.Tree.t - end = struct - type 'a elt = 'a - type _ cmp - - include Set - - let of_tree _ = assert false - let to_tree _ = assert false - end - in - () -;; - -let () = - let module M : sig - open Map - - 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) Map.Using_comparator.Tree.t - - include - Creators_generic - with type ('a, 'b, 'c) options := ('a, 'b, 'c) With_first_class_module.t - with type ('a, 'b, 'c) t := ('a, 'b, 'c) t - with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Map.Using_comparator.Tree.t - end = struct - type 'a key = 'a - type 'a cmp = 'a - - include Map - - let of_tree _ = assert false - let to_tree _ = assert false - end - in - () -;; +module _ : sig + open Set + + type ('a, 'b) t + + include + Accessors2 + with type ('a, 'b) t := ('a, 'b) t + with type ('a, 'b) tree := ('a, 'b) Set.Using_comparator.Tree.t + with type ('a, 'b) named := ('a, 'b) Set.Named.t + + include + Creators_generic + with type ('a, 'b, 'c) options := ('a, 'b, 'c) With_first_class_module.t + with type ('a, 'b) set := ('a, 'b) t + with type ('a, 'b) t := ('a, 'b) t + with type ('a, 'b) tree := ('a, 'b) Set.Using_comparator.Tree.t +end = struct + type 'a elt = 'a + type _ cmp + + include Set + + let of_tree _ = assert false + let to_tree _ = assert false +end + +module _ : sig + open Map + + 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) Map.Using_comparator.Tree.t + + include + Creators_generic + with type ('a, 'b, 'c) options := ('a, 'b, 'c) With_first_class_module.t + with type ('a, 'b, 'c) t := ('a, 'b, 'c) t + with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Map.Using_comparator.Tree.t +end = struct + type 'a key = 'a + type 'a cmp = 'a + + include Map +end diff --git a/test/test_am_testing.mlt b/test/test_am_testing.mlt index e8de68b..f752d67 100644 --- a/test/test_am_testing.mlt +++ b/test/test_am_testing.mlt @@ -1,5 +1,4 @@ open! Base - open! Expect_test_helpers_base let () = print_s [%sexp (Exported_for_specific_uses.am_testing : bool)] diff --git a/test/test_applicative.ml b/test/test_applicative.ml index 7488824..df82e2d 100644 --- a/test/test_applicative.ml +++ b/test/test_applicative.ml @@ -1,407 +1,328 @@ open! Import -let%test_module "Make" = - (module struct - module A = Applicative.Make (struct - type 'a t = 'a Or_error.t +module Test_applicative_s (A : Applicative.S with type 'a t := 'a Or_error.t) : + Applicative.S with type 'a t := 'a Or_error.t = struct + let error = Or_error.error_string + let return = A.return + + let%expect_test _ = + print_s [%sexp (return "okay" : string Or_error.t)]; + [%expect {| (Ok okay) |}] + ;; + + let apply = A.apply + + let%expect_test _ = + let test x y = print_s [%sexp (apply x y : string Or_error.t)] in + test (Ok String.capitalize) (Ok "okay"); + [%expect {| (Ok Okay) |}]; + test (error "not okay") (Ok "okay"); + [%expect {| (Error "not okay") |}]; + test (Ok String.capitalize) (error "not okay"); + [%expect {| (Error "not okay") |}]; + test (error "no fun") (error "no arg"); + [%expect {| (Error ("no fun" "no arg")) |}] + ;; + + let ( <*> ) = A.( <*> ) + + let%expect_test _ = + let test x y = print_s [%sexp (x <*> y : string Or_error.t)] in + test (Ok String.capitalize) (Ok "okay"); + [%expect {| (Ok Okay) |}]; + test (error "not okay") (Ok "okay"); + [%expect {| (Error "not okay") |}]; + test (Ok String.capitalize) (error "not okay"); + [%expect {| (Error "not okay") |}]; + test (error "no fun") (error "no arg"); + [%expect {| (Error ("no fun" "no arg")) |}] + ;; + + let ( *> ) = A.( *> ) + + let%expect_test _ = + let test x y = print_s [%sexp (x *> y : string Or_error.t)] in + test (Ok ()) (Ok "kay"); + [%expect {| (Ok kay) |}]; + test (error "not okay") (Ok "kay"); + [%expect {| (Error "not okay") |}]; + test (Ok ()) (error "not okay"); + [%expect {| (Error "not okay") |}]; + test (error "no fst") (error "no snd"); + [%expect {| (Error ("no fst" "no snd")) |}] + ;; + + let ( <* ) = A.( <* ) + + let%expect_test _ = + let test x y = print_s [%sexp (x <* y : string Or_error.t)] in + test (Ok "okay") (Ok ()); + [%expect {| (Ok okay) |}]; + test (error "not okay") (Ok ()); + [%expect {| (Error "not okay") |}]; + test (Ok "okay") (error "not okay"); + [%expect {| (Error "not okay") |}]; + test (error "no fst") (error "no snd"); + [%expect {| (Error ("no fst" "no snd")) |}] + ;; + + let both = A.both + + let%expect_test _ = + let test x y = print_s [%sexp (both x y : (string * string) Or_error.t)] in + test (Ok "o") (Ok "kay"); + [%expect {| (Ok (o kay)) |}]; + test (error "not okay") (Ok "kay"); + [%expect {| (Error "not okay") |}]; + test (Ok "o") (error "not okay"); + [%expect {| (Error "not okay") |}]; + test (error "no fst") (error "no snd"); + [%expect {| (Error ("no fst" "no snd")) |}] + ;; + + let map = A.map + + let%expect_test _ = + let test x = print_s [%sexp (map x ~f:String.capitalize : string Or_error.t)] in + test (Ok "okay"); + [%expect {| (Ok Okay) |}]; + test (error "not okay"); + [%expect {| (Error "not okay") |}] + ;; + + let ( >>| ) = A.( >>| ) + + let%expect_test _ = + let test x = print_s [%sexp (x >>| String.capitalize : string Or_error.t)] in + test (Ok "okay"); + [%expect {| (Ok Okay) |}]; + test (error "not okay"); + [%expect {| (Error "not okay") |}] + ;; + + let map2 = A.map2 + + let%expect_test _ = + let test x y = print_s [%sexp (map2 x y ~f:( ^ ) : string Or_error.t)] in + test (Ok "o") (Ok "kay"); + [%expect {| (Ok okay) |}]; + test (error "not okay") (Ok "kay"); + [%expect {| (Error "not okay") |}]; + test (Ok "o") (error "not okay"); + [%expect {| (Error "not okay") |}]; + test (error "no fst") (error "no snd"); + [%expect {| (Error ("no fst" "no snd")) |}] + ;; + + let map3 = A.map3 + + let%expect_test _ = + let test x y z = + print_s [%sexp (map3 x y z ~f:(fun a b c -> a ^ b ^ c) : string Or_error.t)] + in + test (Ok "o") (Ok "k") (Ok "ay"); + [%expect {| (Ok okay) |}]; + test (error "not okay") (Ok "k") (Ok "ay"); + [%expect {| (Error "not okay") |}]; + test (Ok "o") (error "not okay") (Ok "ay"); + [%expect {| (Error "not okay") |}]; + test (Ok "o") (Ok "k") (error "not okay"); + [%expect {| (Error "not okay") |}]; + test (error "no 1st") (error "no 2nd") (error "no 3rd"); + [%expect {| (Error ("no 1st" "no 2nd" "no 3rd")) |}] + ;; + + let all = A.all + + let%expect_test _ = + let test list = print_s [%sexp (all list : string list Or_error.t)] in + test []; + [%expect {| (Ok ()) |}]; + test [ Ok "okay" ]; + [%expect {| (Ok (okay)) |}]; + test [ Ok "o"; Ok "kay" ]; + [%expect {| (Ok (o kay)) |}]; + test [ Ok "o"; Ok "k"; Ok "ay" ]; + [%expect {| (Ok (o k ay)) |}]; + test [ error "oh no!" ]; + [%expect {| (Error "oh no!") |}]; + test [ error "oh no!"; Ok "okay" ]; + [%expect {| (Error "oh no!") |}]; + test [ Ok "okay"; error "oh no!" ]; + [%expect {| (Error "oh no!") |}]; + test [ error "oh no!"; Ok "o"; Ok "kay" ]; + [%expect {| (Error "oh no!") |}]; + test [ Ok "o"; error "oh no!"; Ok "aay" ]; + [%expect {| (Error "oh no!") |}]; + test [ Ok "o"; Ok "kay"; error "oh no!" ]; + [%expect {| (Error "oh no!") |}]; + test [ error "oh"; error "no"; error "!" ]; + [%expect {| (Error (oh no !)) |}] + ;; + + let all_unit = A.all_unit + + let%expect_test _ = + let test list = print_s [%sexp (all_unit list : unit Or_error.t)] in + test []; + [%expect {| (Ok ()) |}]; + test [ Ok () ]; + [%expect {| (Ok ()) |}]; + test [ Ok (); Ok () ]; + [%expect {| (Ok ()) |}]; + test [ Ok (); Ok (); Ok () ]; + [%expect {| (Ok ()) |}]; + test [ error "oh no!" ]; + [%expect {| (Error "oh no!") |}]; + test [ error "oh no!"; Ok () ]; + [%expect {| (Error "oh no!") |}]; + test [ Ok (); error "oh no!" ]; + [%expect {| (Error "oh no!") |}]; + test [ error "oh no!"; Ok (); Ok () ]; + [%expect {| (Error "oh no!") |}]; + test [ Ok (); error "oh no!"; Ok () ]; + [%expect {| (Error "oh no!") |}]; + test [ Ok (); Ok (); error "oh no!" ]; + [%expect {| (Error "oh no!") |}]; + test [ error "oh"; error "no"; error "!" ]; + [%expect {| (Error (oh no !)) |}] + ;; + + module Applicative_infix = A.Applicative_infix +end - let return = Or_error.return - let apply = Or_error.apply - let map = `Define_using_apply - end) +let%test_module "Make" = + (module Test_applicative_s (Applicative.Make (struct + type 'a t = 'a Or_error.t - let error = Or_error.error_string - - module Tests : module type of A = struct - let return = A.return - - let%expect_test _ = - print_s [%sexp (return "okay" : string Or_error.t)]; - [%expect {| (Ok okay) |}] - ;; - - let apply = A.apply - - let%expect_test _ = - let test x y = print_s [%sexp (apply x y : string Or_error.t)] in - test (Ok String.capitalize) (Ok "okay"); - [%expect {| (Ok Okay) |}]; - test (error "not okay") (Ok "okay"); - [%expect {| (Error "not okay") |}]; - test (Ok String.capitalize) (error "not okay"); - [%expect {| (Error "not okay") |}]; - test (error "no fun") (error "no arg"); - [%expect {| (Error ("no fun" "no arg")) |}] - ;; - - let ( <*> ) = A.( <*> ) - - let%expect_test _ = - let test x y = print_s [%sexp (x <*> y : string Or_error.t)] in - test (Ok String.capitalize) (Ok "okay"); - [%expect {| (Ok Okay) |}]; - test (error "not okay") (Ok "okay"); - [%expect {| (Error "not okay") |}]; - test (Ok String.capitalize) (error "not okay"); - [%expect {| (Error "not okay") |}]; - test (error "no fun") (error "no arg"); - [%expect {| (Error ("no fun" "no arg")) |}] - ;; - - let ( *> ) = A.( *> ) - - let%expect_test _ = - let test x y = print_s [%sexp (x *> y : string Or_error.t)] in - test (Ok ()) (Ok "kay"); - [%expect {| (Ok kay) |}]; - test (error "not okay") (Ok "kay"); - [%expect {| (Error "not okay") |}]; - test (Ok ()) (error "not okay"); - [%expect {| (Error "not okay") |}]; - test (error "no fst") (error "no snd"); - [%expect {| (Error ("no fst" "no snd")) |}] - ;; - - let ( <* ) = A.( <* ) - - let%expect_test _ = - let test x y = print_s [%sexp (x <* y : string Or_error.t)] in - test (Ok "okay") (Ok ()); - [%expect {| (Ok okay) |}]; - test (error "not okay") (Ok ()); - [%expect {| (Error "not okay") |}]; - test (Ok "okay") (error "not okay"); - [%expect {| (Error "not okay") |}]; - test (error "no fst") (error "no snd"); - [%expect {| (Error ("no fst" "no snd")) |}] - ;; - - let both = A.both - - let%expect_test _ = - let test x y = print_s [%sexp (both x y : (string * string) Or_error.t)] in - test (Ok "o") (Ok "kay"); - [%expect {| (Ok (o kay)) |}]; - test (error "not okay") (Ok "kay"); - [%expect {| (Error "not okay") |}]; - test (Ok "o") (error "not okay"); - [%expect {| (Error "not okay") |}]; - test (error "no fst") (error "no snd"); - [%expect {| (Error ("no fst" "no snd")) |}] - ;; - - let map = A.map - - let%expect_test _ = - let test x = print_s [%sexp (map x ~f:String.capitalize : string Or_error.t)] in - test (Ok "okay"); - [%expect {| (Ok Okay) |}]; - test (error "not okay"); - [%expect {| (Error "not okay") |}] - ;; - - let ( >>| ) = A.( >>| ) - - let%expect_test _ = - let test x = print_s [%sexp (x >>| String.capitalize : string Or_error.t)] in - test (Ok "okay"); - [%expect {| (Ok Okay) |}]; - test (error "not okay"); - [%expect {| (Error "not okay") |}] - ;; - - let map2 = A.map2 - - let%expect_test _ = - let test x y = print_s [%sexp (map2 x y ~f:( ^ ) : string Or_error.t)] in - test (Ok "o") (Ok "kay"); - [%expect {| (Ok okay) |}]; - test (error "not okay") (Ok "kay"); - [%expect {| (Error "not okay") |}]; - test (Ok "o") (error "not okay"); - [%expect {| (Error "not okay") |}]; - test (error "no fst") (error "no snd"); - [%expect {| (Error ("no fst" "no snd")) |}] - ;; - - let map3 = A.map3 - - let%expect_test _ = - let test x y z = - print_s [%sexp (map3 x y z ~f:(fun a b c -> a ^ b ^ c) : string Or_error.t)] - in - test (Ok "o") (Ok "k") (Ok "ay"); - [%expect {| (Ok okay) |}]; - test (error "not okay") (Ok "k") (Ok "ay"); - [%expect {| (Error "not okay") |}]; - test (Ok "o") (error "not okay") (Ok "ay"); - [%expect {| (Error "not okay") |}]; - test (Ok "o") (Ok "k") (error "not okay"); - [%expect {| (Error "not okay") |}]; - test (error "no 1st") (error "no 2nd") (error "no 3rd"); - [%expect {| (Error ("no 1st" "no 2nd" "no 3rd")) |}] - ;; - - let all = A.all - - let%expect_test _ = - let test list = print_s [%sexp (all list : string list Or_error.t)] in - test []; - [%expect {| (Ok ()) |}]; - test [ Ok "okay" ]; - [%expect {| (Ok (okay)) |}]; - test [ Ok "o"; Ok "kay" ]; - [%expect {| (Ok (o kay)) |}]; - test [ Ok "o"; Ok "k"; Ok "ay" ]; - [%expect {| (Ok (o k ay)) |}]; - test [ error "oh no!" ]; - [%expect {| (Error "oh no!") |}]; - test [ error "oh no!"; Ok "okay" ]; - [%expect {| (Error "oh no!") |}]; - test [ Ok "okay"; error "oh no!" ]; - [%expect {| (Error "oh no!") |}]; - test [ error "oh no!"; Ok "o"; Ok "kay" ]; - [%expect {| (Error "oh no!") |}]; - test [ Ok "o"; error "oh no!"; Ok "aay" ]; - [%expect {| (Error "oh no!") |}]; - test [ Ok "o"; Ok "kay"; error "oh no!" ]; - [%expect {| (Error "oh no!") |}]; - test [ error "oh"; error "no"; error "!" ]; - [%expect {| (Error (oh no !)) |}] - ;; - - let all_unit = A.all_unit - - let%expect_test _ = - let test list = print_s [%sexp (all_unit list : unit Or_error.t)] in - test []; - [%expect {| (Ok ()) |}]; - test [ Ok () ]; - [%expect {| (Ok ()) |}]; - test [ Ok (); Ok () ]; - [%expect {| (Ok ()) |}]; - test [ Ok (); Ok (); Ok () ]; - [%expect {| (Ok ()) |}]; - test [ error "oh no!" ]; - [%expect {| (Error "oh no!") |}]; - test [ error "oh no!"; Ok () ]; - [%expect {| (Error "oh no!") |}]; - test [ Ok (); error "oh no!" ]; - [%expect {| (Error "oh no!") |}]; - test [ error "oh no!"; Ok (); Ok () ]; - [%expect {| (Error "oh no!") |}]; - test [ Ok (); error "oh no!"; Ok () ]; - [%expect {| (Error "oh no!") |}]; - test [ Ok (); Ok (); error "oh no!" ]; - [%expect {| (Error "oh no!") |}]; - test [ error "oh"; error "no"; error "!" ]; - [%expect {| (Error (oh no !)) |}] - ;; - - module Applicative_infix = A.Applicative_infix - end - end) + let return = Or_error.return + let apply = Or_error.apply + let map = `Define_using_apply + end))) ;; -let%test_module "Make_using_map2" = - (module struct - module A = Applicative.Make_using_map2 (struct - type 'a t = 'a Or_error.t +let%test_module "Make" = + (module Test_applicative_s (Applicative.Make_using_map2 (struct + type 'a t = 'a Or_error.t + + let return = Or_error.return + let map2 = Or_error.map2 + let map = `Define_using_map2 + end))) +;; - let return = Or_error.return - let map2 = Or_error.map2 - let map = `Define_using_map2 +(* While law-abiding applicatives shouldn't be relying functions being called + the minimal number of times, it is good for performance that things be this + way. For many applicatives this will not matter very much, but for others, + like Bonsai, it is a little more significant, since extra calls construct + more Incremental nodes, yielding more strain on the Incremental stabilizer. + + The point is that we should not assume that the input applicative instance + can be frivolous in creating nodes in the applicative call-tree. +*) +let%expect_test _ = + let module A = struct + type 'a t = + | Other of string + | Return : 'a -> 'a t + | Map : ('a -> 'b) * 'a t -> 'b t + | Map2 : ('a -> 'b -> 'c) * 'a t * 'b t -> 'c t + + include Applicative.Make_using_map2 (struct + type nonrec 'a t = 'a t + + let return x = Return x + let map2 a b ~f = Map2 (f, a, b) + let map = `Custom (fun a ~f -> Map (f, a)) end) - let error = Or_error.error_string - - module Tests : module type of A = struct - let return = A.return - - let%expect_test _ = - print_s [%sexp (return "okay" : string Or_error.t)]; - [%expect {| (Ok okay) |}] - ;; - - let apply = A.apply - - let%expect_test _ = - let test x y = print_s [%sexp (apply x y : string Or_error.t)] in - test (Ok String.capitalize) (Ok "okay"); - [%expect {| (Ok Okay) |}]; - test (error "not okay") (Ok "okay"); - [%expect {| (Error "not okay") |}]; - test (Ok String.capitalize) (error "not okay"); - [%expect {| (Error "not okay") |}]; - test (error "no fun") (error "no arg"); - [%expect {| (Error ("no fun" "no arg")) |}] - ;; - - let ( <*> ) = A.( <*> ) - - let%expect_test _ = - let test x y = print_s [%sexp (x <*> y : string Or_error.t)] in - test (Ok String.capitalize) (Ok "okay"); - [%expect {| (Ok Okay) |}]; - test (error "not okay") (Ok "okay"); - [%expect {| (Error "not okay") |}]; - test (Ok String.capitalize) (error "not okay"); - [%expect {| (Error "not okay") |}]; - test (error "no fun") (error "no arg"); - [%expect {| (Error ("no fun" "no arg")) |}] - ;; - - let ( *> ) = A.( *> ) - - let%expect_test _ = - let test x y = print_s [%sexp (x *> y : string Or_error.t)] in - test (Ok ()) (Ok "kay"); - [%expect {| (Ok kay) |}]; - test (error "not okay") (Ok "kay"); - [%expect {| (Error "not okay") |}]; - test (Ok ()) (error "not okay"); - [%expect {| (Error "not okay") |}]; - test (error "no fst") (error "no snd"); - [%expect {| (Error ("no fst" "no snd")) |}] - ;; - - let ( <* ) = A.( <* ) - - let%expect_test _ = - let test x y = print_s [%sexp (x <* y : string Or_error.t)] in - test (Ok "okay") (Ok ()); - [%expect {| (Ok okay) |}]; - test (error "not okay") (Ok ()); - [%expect {| (Error "not okay") |}]; - test (Ok "okay") (error "not okay"); - [%expect {| (Error "not okay") |}]; - test (error "no fst") (error "no snd"); - [%expect {| (Error ("no fst" "no snd")) |}] - ;; - - let both = A.both - - let%expect_test _ = - let test x y = print_s [%sexp (both x y : (string * string) Or_error.t)] in - test (Ok "o") (Ok "kay"); - [%expect {| (Ok (o kay)) |}]; - test (error "not okay") (Ok "kay"); - [%expect {| (Error "not okay") |}]; - test (Ok "o") (error "not okay"); - [%expect {| (Error "not okay") |}]; - test (error "no fst") (error "no snd"); - [%expect {| (Error ("no fst" "no snd")) |}] - ;; - - let map = A.map - - let%expect_test _ = - let test x = print_s [%sexp (map x ~f:String.capitalize : string Or_error.t)] in - test (Ok "okay"); - [%expect {| (Ok Okay) |}]; - test (error "not okay"); - [%expect {| (Error "not okay") |}] - ;; - - let ( >>| ) = A.( >>| ) - - let%expect_test _ = - let test x = print_s [%sexp (x >>| String.capitalize : string Or_error.t)] in - test (Ok "okay"); - [%expect {| (Ok Okay) |}]; - test (error "not okay"); - [%expect {| (Error "not okay") |}] - ;; - - let map2 = A.map2 - - let%expect_test _ = - let test x y = print_s [%sexp (map2 x y ~f:( ^ ) : string Or_error.t)] in - test (Ok "o") (Ok "kay"); - [%expect {| (Ok okay) |}]; - test (error "not okay") (Ok "kay"); - [%expect {| (Error "not okay") |}]; - test (Ok "o") (error "not okay"); - [%expect {| (Error "not okay") |}]; - test (error "no fst") (error "no snd"); - [%expect {| (Error ("no fst" "no snd")) |}] - ;; - - let map3 = A.map3 - - let%expect_test _ = - let test x y z = - print_s [%sexp (map3 x y z ~f:(fun a b c -> a ^ b ^ c) : string Or_error.t)] - in - test (Ok "o") (Ok "k") (Ok "ay"); - [%expect {| (Ok okay) |}]; - test (error "not okay") (Ok "k") (Ok "ay"); - [%expect {| (Error "not okay") |}]; - test (Ok "o") (error "not okay") (Ok "ay"); - [%expect {| (Error "not okay") |}]; - test (Ok "o") (Ok "k") (error "not okay"); - [%expect {| (Error "not okay") |}]; - test (error "no 1st") (error "no 2nd") (error "no 3rd"); - [%expect {| (Error ("no 1st" "no 2nd" "no 3rd")) |}] - ;; - - let all = A.all - - let%expect_test _ = - let test list = print_s [%sexp (all list : string list Or_error.t)] in - test []; - [%expect {| (Ok ()) |}]; - test [ Ok "okay" ]; - [%expect {| (Ok (okay)) |}]; - test [ Ok "o"; Ok "kay" ]; - [%expect {| (Ok (o kay)) |}]; - test [ Ok "o"; Ok "k"; Ok "ay" ]; - [%expect {| (Ok (o k ay)) |}]; - test [ error "oh no!" ]; - [%expect {| (Error "oh no!") |}]; - test [ error "oh no!"; Ok "okay" ]; - [%expect {| (Error "oh no!") |}]; - test [ Ok "okay"; error "oh no!" ]; - [%expect {| (Error "oh no!") |}]; - test [ error "oh no!"; Ok "o"; Ok "kay" ]; - [%expect {| (Error "oh no!") |}]; - test [ Ok "o"; error "oh no!"; Ok "aay" ]; - [%expect {| (Error "oh no!") |}]; - test [ Ok "o"; Ok "kay"; error "oh no!" ]; - [%expect {| (Error "oh no!") |}]; - test [ error "oh"; error "no"; error "!" ]; - [%expect {| (Error (oh no !)) |}] - ;; - - let all_unit = A.all_unit - - let%expect_test _ = - let test list = print_s [%sexp (all_unit list : unit Or_error.t)] in - test []; - [%expect {| (Ok ()) |}]; - test [ Ok () ]; - [%expect {| (Ok ()) |}]; - test [ Ok (); Ok () ]; - [%expect {| (Ok ()) |}]; - test [ Ok (); Ok (); Ok () ]; - [%expect {| (Ok ()) |}]; - test [ error "oh no!" ]; - [%expect {| (Error "oh no!") |}]; - test [ error "oh no!"; Ok () ]; - [%expect {| (Error "oh no!") |}]; - test [ Ok (); error "oh no!" ]; - [%expect {| (Error "oh no!") |}]; - test [ error "oh no!"; Ok (); Ok () ]; - [%expect {| (Error "oh no!") |}]; - test [ Ok (); error "oh no!"; Ok () ]; - [%expect {| (Error "oh no!") |}]; - test [ Ok (); Ok (); error "oh no!" ]; - [%expect {| (Error "oh no!") |}]; - test [ error "oh"; error "no"; error "!" ]; - [%expect {| (Error (oh no !)) |}] - ;; - - module Applicative_infix = A.Applicative_infix - end - end) + let rec sexp_of_t : type a. a t -> Sexp.t = function + | Other x -> Atom x + | Return _ -> Atom "Return" + | Map (_, a) -> List [ Atom "Map"; sexp_of_t a ] + | Map2 (_, a, b) -> List [ Atom "Map2"; sexp_of_t a; sexp_of_t b ] + ;; + end + in + let open A in + let test x = print_s [%sexp (x : A.t)] in + let a, b, c, d = Other "A", Other "B", Other "C", Other "D" in + test (map2 a b ~f:(fun a b -> a, b)); + [%expect {| (Map2 A B) |}]; + test (both a b); + [%expect {| (Map2 A B) |}]; + test (all_unit [ a; b; c; d ]); + [%expect {| + (Map2 (Map2 (Map2 (Map2 Return A) B) C) D) |}]; + test (a *> b); + [%expect {| (Map2 A B) |}] ;; + +(* These functors serve only to check that the signatures for various Foo and Foo2 module + types don't drift apart over time. *) +module _ = struct + open Applicative + + (* Applicative_infix to Applicative_infix2 *) + + module _ (X : Applicative_infix) : Applicative_infix2 with type ('a, 'e) t = 'a X.t = + struct + include X + + type ('a, 'e) t = 'a X.t + end + + (* Applicative_infix2 to Applicative_infix *) + module _ (X : Applicative_infix2) : Applicative_infix with type 'a t = ('a, unit) X.t = + struct + include X + + type 'a t = ('a, unit) X.t + end + + (* Applicative_infix2 to Applicative_infix3 *) + module _ (X : Applicative_infix2) : + Applicative_infix3 with type ('a, 'd, 'e) t = ('a, 'd) X.t = struct + include X + + type ('a, 'd, 'e) t = ('a, 'd) X.t + end + + (* Applicative_infix3 to Applicative_infix2 *) + module _ (X : Applicative_infix3) : + Applicative_infix2 with type ('a, 'd) t = ('a, 'd, unit) X.t = struct + include X + + type ('a, 'd) t = ('a, 'd, unit) X.t + end + + (* Let_syntax to Let_syntax2 *) + module _ (X : Let_syntax) : Let_syntax2 with type ('a, 'e) t = 'a X.t = struct + include X + + type ('a, 'e) t = 'a X.t + end + + (* Let_syntax2 to Let_syntax *) + module _ (X : Let_syntax2) : Let_syntax with type 'a t = ('a, unit) X.t = struct + include X + + type 'a t = ('a, unit) X.t + end + + (* Let_syntax2 to Let_syntax3 *) + module _ (X : Let_syntax2) : Let_syntax3 with type ('a, 'd, 'e) t = ('a, 'd) X.t = + struct + include X + + type ('a, 'd, 'e) t = ('a, 'd) X.t + end + + (* Let_syntax3 to Let_syntax2 *) + module _ (X : Let_syntax3) : Let_syntax2 with type ('a, 'd) t = ('a, 'd, unit) X.t = + struct + include X + + type ('a, 'd) t = ('a, 'd, unit) X.t + end +end diff --git a/test/test_array.ml b/test/test_array.ml index d5c2426..06d4271 100644 --- a/test/test_array.ml +++ b/test/test_array.ml @@ -23,6 +23,21 @@ let%test_module "Blit" = (Array)) ;; +module List_helpers = struct + let rec sprinkle x xs = + (x :: xs) + :: + (match xs with + | [] -> [] + | x' :: xs' -> List.map (sprinkle x xs') ~f:(fun sprinkled -> x' :: sprinkled)) + ;; + + let rec permutations = function + | [] -> [ [] ] + | x :: xs -> List.concat_map (permutations xs) ~f:(fun perms -> sprinkle x perms) + ;; +end + let%test_module "Sort" = (module struct open Private.Sort @@ -31,21 +46,7 @@ let%test_module "Sort" = (module struct (* run [five_element_sort] on all permutations of an array of five elements *) - let rec sprinkle x xs = - (x :: xs) - :: - (match xs with - | [] -> [] - | x' :: xs' -> List.map (sprinkle x xs') ~f:(fun sprinkled -> x' :: sprinkled)) - ;; - - let rec permutations = function - | [] -> [ [] ] - | x :: xs -> - List.concat_map (permutations xs) ~f:(fun perms -> sprinkle x perms) - ;; - - let all_perms = permutations [ 1; 2; 3; 4; 5 ] + let all_perms = List_helpers.permutations [ 1; 2; 3; 4; 5 ] let%test _ = List.length all_perms = 120 let%test _ = not (List.contains_dup ~compare:[%compare: int list] all_perms) @@ -72,11 +73,7 @@ let%test_module "Sort" = M.sort arr ~left:0 ~right:(Array.length arr - 1) ~compare:[%compare: int]; let len = Array.length arr in let rec loop i prev = - if i = len - then true - else if arr.(i) < prev - then false - else loop (i + 1) arr.(i) + if i = len then true else if arr.(i) < prev then false else loop (i + 1) arr.(i) in loop 0 (-1) ;; @@ -92,20 +89,6 @@ let%test_module "Sort" = let%test_module _ = (module Test (Insertion_sort)) let%test_module _ = (module Test (Heap_sort)) let%test_module _ = (module Test (Intro_sort)) - - let%expect_test "Array.sort [||] only allocates when computing bounds" = - require_allocation_does_not_exceed (Minor_words 3) [%here] (fun () -> - Array.sort ~compare:Int.compare [||]); - [%expect {||}] - ;; - - let%expect_test "Array.sort [| 5; 2; 3; 4; 1 |] only allocates when computing bounds" - = - let arr = [| 5; 2; 3; 4; 1 |] in - require_allocation_does_not_exceed (Minor_words 3) [%here] (fun () -> - Array.sort ~compare:Int.compare arr); - [%expect {||}] - ;; end) ;; @@ -129,6 +112,85 @@ let%test_unit _ = ] ;; +let%expect_test "merge" = + let test a1 a2 = + let res = merge a1 a2 ~compare:Int.compare in + print_s ([%sexp_of: int array] res); + require_equal + [%here] + (module struct + type t = int list [@@deriving equal, sexp_of] + end) + (to_list res) + (List.merge (to_list a1) (to_list a2) ~compare:Int.compare) + in + test [||] [||]; + [%expect {| () |}]; + test [| 1; 2; 3 |] [||]; + [%expect {| (1 2 3) |}]; + test [||] [| 1; 2; 3 |]; + [%expect {| (1 2 3) |}]; + test [| 1; 2; 3 |] [| 1; 2; 3 |]; + [%expect {| (1 1 2 2 3 3) |}]; + test [| 1; 2; 3 |] [| 4; 5; 6 |]; + [%expect {| (1 2 3 4 5 6) |}]; + test [| 4; 5; 6 |] [| 1; 2; 3 |]; + [%expect {| (1 2 3 4 5 6) |}]; + test [| 3; 5 |] [| 1; 2; 4; 6 |]; + [%expect {| (1 2 3 4 5 6) |}]; + test [| 1; 3; 7; 8; 9 |] [| 2; 4; 5; 6 |]; + [%expect {| (1 2 3 4 5 6 7 8 9) |}]; + test [| 1; 2; 2; 3 |] [| 2; 2; 3; 4 |]; + [%expect {| (1 2 2 2 2 3 3 4) |}] +;; + +let%expect_test "merge with duplicates" = + (* Testing that equal elements from a1 come before equal elements from a2 *) + let test a1 a2 = + let compare = Comparable.lift Int.compare ~f:fst in + let res = merge a1 a2 ~compare in + print_s ([%sexp_of: (int * string) array] res); + require_equal + [%here] + (module struct + type t = (int * string) list [@@deriving equal, sexp_of] + end) + (to_list res) + (List.merge (to_list a1) (to_list a2) ~compare) + in + test [| 1, "a1" |] [| 1, "a2" |]; + [%expect {| + ((1 a1) + (1 a2)) |}]; + test [| 1, "a1"; 2, "a1"; 3, "a1" |] [| 3, "a2"; 4, "a2"; 5, "a2" |]; + [%expect {| + ((1 a1) + (2 a1) + (3 a1) + (3 a2) + (4 a2) + (5 a2)) |}]; + test [| 3, "a1"; 4, "a1"; 5, "a1" |] [| 1, "a2"; 2, "a2"; 3, "a2" |]; + [%expect {| + ((1 a2) + (2 a2) + (3 a1) + (3 a2) + (4 a1) + (5 a1)) |}]; + test [| 1, "a1"; 3, "a1"; 3, "a1"; 5, "a1" |] [| 2, "a2"; 3, "a2"; 3, "a2"; 4, "a2" |]; + [%expect + {| + ((1 a1) + (2 a2) + (3 a1) + (3 a1) + (3 a2) + (3 a2) + (4 a2) + (5 a1)) |}] +;; + let%test _ = foldi [||] ~init:13 ~f:(fun _ _ _ -> failwith "bad") = 13 let%test _ = foldi [| 13 |] ~init:17 ~f:(fun i ac x -> ac + i + x) = 30 let%test _ = foldi [| 13; 17 |] ~init:19 ~f:(fun i ac x -> ac + i + x) = 50 @@ -392,14 +454,80 @@ let%test_unit _ = ~expect:(0, [||]) ;; -let%test "equal does not allocate" = - let arr1 = [| 1; 2; 3; 4 |] in - let arr2 = [| 1; 2; 4; 3 |] in - require_no_allocation [%here] (fun () -> not (equal Int.equal arr1 arr2)) +let%test_module "permute" = + (module struct + module Int_list = struct + type t = int list [@@deriving compare, sexp_of] + + include (val Comparator.make ~compare ~sexp_of_t) + end + + let test_permute initial_contents ~pos ~len = + let all_permutations = + let pos, len = + Ordered_collection_common.get_pos_len_exn + ?pos + ?len + ~total_length:(List.length initial_contents) + () + in + let left = List.take initial_contents pos in + let middle = List.sub initial_contents ~pos ~len in + let right = List.drop initial_contents (pos + len) in + Set.of_list + (module Int_list) + (List_helpers.permutations middle + |> List.map ~f:(fun middle -> left @ middle @ right)) + in + let not_yet_seen = ref all_permutations in + while not (Set.is_empty !not_yet_seen) do + let array = of_list initial_contents in + permute ?pos ?len array; + let permutation = to_list array in + if not (Set.mem all_permutations permutation) + then + raise_s + [%sexp + "invalid permutation" + , { array_length = (List.length initial_contents : int) + ; permutation : int list + ; pos : int option + ; len : int option + }]; + not_yet_seen := Set.remove !not_yet_seen permutation + done + ;; + + let%expect_test "permute different array lengths and subranges" = + let indices = None :: List.map [ 0; 1; 2; 3; 4 ] ~f:Option.some in + for array_length = 0 to 4 do + let initial_contents = List.init array_length ~f:Int.succ in + List.iter indices ~f:(fun pos -> + List.iter indices ~f:(fun len -> + match + Ordered_collection_common.get_pos_len + ?pos + ?len + ~total_length:array_length + () + with + | Ok _ -> test_permute initial_contents ~pos ~len + | Error _ -> + require + [%here] + (Exn.does_raise (fun () -> + permute ?pos ?len (Array.of_list initial_contents))))) + done; + [%expect {| |}] + ;; + end) ;; -let%test "foldi does not allocate" = - let arr = [| 1; 2; 3; 4 |] in - let f i x y = i + x + y in - require_no_allocation [%here] (fun () -> 16 = foldi ~init:0 ~f arr) +let%expect_test "create_float_uninitialized" = + let array = create_float_uninitialized ~len:10 in + (* make sure reading/writing the array is safe *) + Array.permute array; + (* sanity check without depending on specific contents *) + print_s [%sexp (Array.length array : int)]; + [%expect {| 10 |}] ;; diff --git a/test/test_backtrace.ml b/test/test_backtrace.ml index c9d1f96..439e7f3 100644 --- a/test/test_backtrace.ml +++ b/test/test_backtrace.ml @@ -1,12 +1,13 @@ open! Import open! Backtrace -let%test_unit (_[@tags "no-js"]) = +let%test_unit (_ [@tags "no-js"]) = let t = get () in assert (String.length (to_string t) > 0) ;; let%expect_test _ = + Backtrace.elide := true; Stdio.Out_channel.(output_string stdout) (Sexp.to_string (sexp_of_t (Exn.with_recording false ~f:Exn.most_recent))); [%expect {| diff --git a/test/test_base_containers.ml b/test/test_base_containers.ml index 9c9b695..7bc96f4 100644 --- a/test/test_base_containers.ml +++ b/test/test_base_containers.ml @@ -3,3 +3,67 @@ open Test_container include (Test_S1 (Array) : sig end) include (Test_S1 (List) : sig end) include (Test_S1 (Queue) : sig end) +open Container +open T + + +(* The following functors exist as a consistency check among all the various [S?] + interfaces. They ensure that each particular [S?] is an instance of a more generic + signature. *) +module Check + (T : T1) + (Elt : T1) + (_ : Generic with type 'a t := 'a T.t with type 'a elt := 'a Elt.t) = +struct end + +module _ (M : S0) = + Check + (struct + type 'a t = M.t + end) + (struct + type 'a t = M.elt + end) + (M) + +module _ (M : S0_phantom) = + Check + (struct + type 'a t = 'a M.t + end) + (struct + type 'a t = M.elt + end) + (M) + +module _ (M : S1) = + Check + (struct + type 'a t = 'a M.t + end) + (struct + type 'a t = 'a + end) + (M) + +type phantom + +module _ (M : S1_phantom) = + Check + (struct + type 'a t = ('a, phantom) M.t + end) + (struct + type 'a t = 'a + end) + (M) + +module _ (M : S1_phantom_invariant) = + Check + (struct + type 'a t = ('a, phantom) M.t + end) + (struct + type 'a t = 'a + end) + (M) diff --git a/test/test_char.ml b/test/test_char.ml index b0acd47..b62a152 100644 --- a/test/test_char.ml +++ b/test/test_char.ml @@ -54,494 +54,87 @@ let%test_module "int to char conversion" = ;; let%expect_test "all" = - print_s [%sexp (all : t list)]; + Ref.set_temporarily sexp_style To_string_hum ~f:(fun () -> + print_s [%sexp (all : t list)]); [%expect {| - ("\000" - "\001" - "\002" - "\003" - "\004" - "\005" - "\006" - "\007" - "\b" - "\t" - "\n" - "\011" - "\012" - "\r" - "\014" - "\015" - "\016" - "\017" - "\018" - "\019" - "\020" - "\021" - "\022" - "\023" - "\024" - "\025" - "\026" - "\027" - "\028" - "\029" - "\030" - "\031" - " " - ! - "\"" - # - $ - % - & - ' - "(" - ")" - * - + - , - - - . - / - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - : - ";" - < - = - > - ? - @ - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - [ - \ - ] - ^ - _ - ` - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - z - { - | - } - ~ - "\127" - "\128" - "\129" - "\130" - "\131" - "\132" - "\133" - "\134" - "\135" - "\136" - "\137" - "\138" - "\139" - "\140" - "\141" - "\142" - "\143" - "\144" - "\145" - "\146" - "\147" - "\148" - "\149" - "\150" - "\151" - "\152" - "\153" - "\154" - "\155" - "\156" - "\157" - "\158" - "\159" - "\160" - "\161" - "\162" - "\163" - "\164" - "\165" - "\166" - "\167" - "\168" - "\169" - "\170" - "\171" - "\172" - "\173" - "\174" - "\175" - "\176" - "\177" - "\178" - "\179" - "\180" - "\181" - "\182" - "\183" - "\184" - "\185" - "\186" - "\187" - "\188" - "\189" - "\190" - "\191" - "\192" - "\193" - "\194" - "\195" - "\196" - "\197" - "\198" - "\199" - "\200" - "\201" - "\202" - "\203" - "\204" - "\205" - "\206" - "\207" - "\208" - "\209" - "\210" - "\211" - "\212" - "\213" - "\214" - "\215" - "\216" - "\217" - "\218" - "\219" - "\220" - "\221" - "\222" - "\223" - "\224" - "\225" - "\226" - "\227" - "\228" - "\229" - "\230" - "\231" - "\232" - "\233" - "\234" - "\235" - "\236" - "\237" - "\238" - "\239" - "\240" - "\241" - "\242" - "\243" - "\244" - "\245" - "\246" - "\247" - "\248" - "\249" - "\250" - "\251" - "\252" - "\253" - "\254" - "\255") |}] + ("\000" "\001" "\002" "\003" "\004" "\005" "\006" "\007" "\b" "\t" "\n" + "\011" "\012" "\r" "\014" "\015" "\016" "\017" "\018" "\019" "\020" "\021" + "\022" "\023" "\024" "\025" "\026" "\027" "\028" "\029" "\030" "\031" " " ! + "\"" # $ % & ' "(" ")" * + , - . / 0 1 2 3 4 5 6 7 8 9 : ";" < = > ? @ A B C + D E F G H I J K L M N O P Q R S T U V W X Y Z [ "\\" ] ^ _ ` a b c d e f g h + i j k l m n o p q r s t u v w x y z { | } ~ "\127" "\128" "\129" "\130" + "\131" "\132" "\133" "\134" "\135" "\136" "\137" "\138" "\139" "\140" "\141" + "\142" "\143" "\144" "\145" "\146" "\147" "\148" "\149" "\150" "\151" "\152" + "\153" "\154" "\155" "\156" "\157" "\158" "\159" "\160" "\161" "\162" "\163" + "\164" "\165" "\166" "\167" "\168" "\169" "\170" "\171" "\172" "\173" "\174" + "\175" "\176" "\177" "\178" "\179" "\180" "\181" "\182" "\183" "\184" "\185" + "\186" "\187" "\188" "\189" "\190" "\191" "\192" "\193" "\194" "\195" "\196" + "\197" "\198" "\199" "\200" "\201" "\202" "\203" "\204" "\205" "\206" "\207" + "\208" "\209" "\210" "\211" "\212" "\213" "\214" "\215" "\216" "\217" "\218" + "\219" "\220" "\221" "\222" "\223" "\224" "\225" "\226" "\227" "\228" "\229" + "\230" "\231" "\232" "\233" "\234" "\235" "\236" "\237" "\238" "\239" "\240" + "\241" "\242" "\243" "\244" "\245" "\246" "\247" "\248" "\249" "\250" "\251" + "\252" "\253" "\254" "\255") |}] ;; let%expect_test "predicates" = - print_s [%sexp (List.filter all ~f:is_digit : t list)]; - [%expect {| (0 1 2 3 4 5 6 7 8 9) |}]; - print_s [%sexp (List.filter all ~f:is_lowercase : t list)]; - [%expect {| (a b c d e f g h i j k l m n o p q r s t u v w x y z) |}]; - print_s [%sexp (List.filter all ~f:is_uppercase : t list)]; - [%expect {| (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z) |}]; - print_s [%sexp (List.filter all ~f:is_alpha : t list)]; - [%expect - {| - (A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - z) |}]; - print_s [%sexp (List.filter all ~f:is_alphanum : t list)]; - [%expect - {| - (0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - z) |}]; - print_s [%sexp (List.filter all ~f:is_print : t list)]; - [%expect - {| - (" " - ! - "\"" - # - $ - % - & - ' - "(" - ")" - * - + - , - - - . - / - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - : - ";" - < - = - > - ? - @ - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - [ - \ - ] - ^ - _ - ` - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - z - { - | - } - ~) |}]; - print_s [%sexp (List.filter all ~f:is_whitespace : t list)]; - [%expect {| ("\t" "\n" "\011" "\012" "\r" " ") |}] + Ref.set_temporarily sexp_style To_string_hum ~f:(fun () -> + print_s [%sexp (List.filter all ~f:is_digit : t list)]; + [%expect {| (0 1 2 3 4 5 6 7 8 9) |}]; + print_s [%sexp (List.filter all ~f:is_lowercase : t list)]; + [%expect {| (a b c d e f g h i j k l m n o p q r s t u v w x y z) |}]; + print_s [%sexp (List.filter all ~f:is_uppercase : t list)]; + [%expect {| (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z) |}]; + print_s [%sexp (List.filter all ~f:is_alpha : t list)]; + [%expect + {| + (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z a b c d e f g h i j k l + m n o p q r s t u v w x y z) |}]; + print_s [%sexp (List.filter all ~f:is_alphanum : t list)]; + [%expect + {| + (0 1 2 3 4 5 6 7 8 9 A B C D E F G H I J K L M N O P Q R S T U V W X Y Z a b + c d e f g h i j k l m n o p q r s t u v w x y z) |}]; + print_s [%sexp (List.filter all ~f:is_print : t list)]; + [%expect + {| + (" " ! "\"" # $ % & ' "(" ")" * + , - . / 0 1 2 3 4 5 6 7 8 9 : ";" < = > ? @ + A B C D E F G H I J K L M N O P Q R S T U V W X Y Z [ "\\" ] ^ _ ` a b c d e + f g h i j k l m n o p q r s t u v w x y z { | } ~) |}]; + print_s [%sexp (List.filter all ~f:is_whitespace : t list)]; + [%expect {| ("\t" "\n" "\011" "\012" "\r" " ") |}]; + print_s [%sexp (List.filter all ~f:is_hex_digit : t list)]; + [%expect {| (0 1 2 3 4 5 6 7 8 9 A B C D E F a b c d e f) |}]; + print_s [%sexp (List.filter all ~f:is_hex_digit_lower : t list)]; + [%expect {| (0 1 2 3 4 5 6 7 8 9 a b c d e f) |}]; + print_s [%sexp (List.filter all ~f:is_hex_digit_upper : t list)]; + [%expect {| (0 1 2 3 4 5 6 7 8 9 A B C D E F) |}]) +;; + +let%expect_test "get_hex_digit" = + Ref.set_temporarily sexp_style To_string_hum ~f:(fun () -> + let hex_digit_alist = + List.filter_map Char.all ~f:(fun char -> + Option.map (get_hex_digit char) ~f:(fun digit -> char, digit)) + in + print_s [%sexp (hex_digit_alist : (char * int) list)]; + [%expect + {| + ((0 0) (1 1) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9) (A 10) (B 11) + (C 12) (D 13) (E 14) (F 15) (a 10) (b 11) (c 12) (d 13) (e 14) (f 15)) |}]; + require_equal + [%here] + (module struct + type t = (char * int) list [@@deriving equal, sexp_of] + end) + (Char.all + |> List.filter ~f:is_hex_digit + |> List.map ~f:(fun char -> char, get_hex_digit_exn char)) + hex_digit_alist; + [%expect {| |}]; + require_does_raise [%here] (fun () -> get_hex_digit_exn Char.min_value); + [%expect {| ("Char.get_hex_digit_exn: not a hexadecimal digit" (char "\000")) |}]) ;; let%test_module "Caseless Comparable" = @@ -551,13 +144,5 @@ let%test_module "Caseless Comparable" = let%test _ = Caseless.('a' < 'B') let%test _ = Int.( <> ) (Caseless.compare 'a' 'B') (compare 'a' 'B') let%test _ = List.is_sorted ~compare:Caseless.compare [ 'A'; 'b'; 'C' ] - - let%expect_test _ = - let x = Sys.opaque_identity 'a' in - let y = Sys.opaque_identity 'b' in - require_no_allocation [%here] (fun () -> - ignore (Sys.opaque_identity (Caseless.equal x y) : bool)); - [%expect {||}] - ;; end) ;; diff --git a/test/test_compare.ml b/test/test_compare.ml index 4e55a04..af943df 100644 --- a/test/test_compare.ml +++ b/test/test_compare.ml @@ -1,5 +1,5 @@ open! Base -open Expect_test_helpers_core +open Expect_test_helpers_base module type S = sig type t [@@deriving sexp_of] @@ -39,11 +39,7 @@ let test (type a) here (module T : S with type t = a) list = op (module Bool) "(<>)" ~actual:T.( <> ) ~expect:C.( <> ); op (module Bool) "(<=)" ~actual:T.( <= ) ~expect:C.( <= ); op (module Bool) "(>=)" ~actual:T.( >= ) ~expect:C.( >= ); - op - (module Bool) - "Comparable.equal" - ~actual:(Comparable.equal T.compare) - ~expect:C.equal; + op (module Bool) "Comparable.equal" ~actual:(Comparable.equal T.compare) ~expect:C.equal; op (module T) "Comparable.min" ~actual:(Comparable.min T.compare) ~expect:C.min; op (module T) "Comparable.max" ~actual:(Comparable.max T.compare) ~expect:C.max ;; @@ -96,10 +92,7 @@ let%expect_test "Int64" = ;; let%expect_test "Nativeint" = - test - [%here] - (module Nativeint) - Nativeint.[ min_value; minus_one; zero; one; max_value ]; + test [%here] (module Nativeint) Nativeint.[ min_value; minus_one; zero; one; max_value ]; [%expect {||}] ;; diff --git a/test/test_exn_reraise.ml b/test/test_exn_reraise.ml new file mode 100644 index 0000000..be88701 --- /dev/null +++ b/test/test_exn_reraise.ml @@ -0,0 +1,193 @@ +open! Import + +(* These methods miss part of the backtrace. *) + +let clobber_most_recent_backtrace () = + try failwith "clobbering" with + | _ -> () +;; + +let _Base_Exn_reraise exn = Exn.reraise exn "reraised" + +let _Base_Exn_reraise_after_clobbering_most_recent_backtrace exn = + clobber_most_recent_backtrace (); + Exn.reraise exn "reraised" +;; + +external reraiser_raw : exn -> 'a = "%reraise" + +let external_reraise_unequal exn = reraiser_raw (Exn.Reraised ("reraised", exn)) +let vanilla_raise_unequal exn = raise (Exn.Reraised ("reraised", exn)) + +(* These methods produce the full, desired backtrace. *) + +let vanilla_raise exn = raise exn + +let raise_with_original_backtrace exn = + let backtrace = Backtrace.Exn.most_recent () in + Exn.raise_with_original_backtrace (Exn.Reraised ("reraised", exn)) backtrace +;; + +(* This ref causes [check_value] to appear in the backtrace, because the [raise_s] call is + no longer in tail position. *) +let setter = ref 0 + +let check_value x = + if x < 0 then raise_s [%message "bad value" (x : int)]; + setter := x +;; + +(* This function duplicates the functionality of [Exn.reraise_uncaught] with a custom + [reraiser] *) +let reraise_uncaught reraiser f = + try f () with + | exn -> reraiser exn +;; + +let callstacker ~reraise_uncaught = + let rec loop reraise_uncaught x = + reraise_uncaught (fun () -> check_value x); + loop reraise_uncaught (x - 1); + reraise_uncaught (fun () -> check_value x) + in + loop reraise_uncaught 1 +;; + +let with_backtraces_enabled f = + Backtrace.Exn.with_recording true ~f:(fun () -> + Ref.set_temporarily Backtrace.elide false ~f) +;; + +let test_reraise_uncaught ~reraise_uncaught = + with_backtraces_enabled (fun () -> + Exn.handle_uncaught ~exit:false (fun () -> callstacker ~reraise_uncaught)) +;; + +let test_reraiser reraiser = + test_reraise_uncaught ~reraise_uncaught:(reraise_uncaught reraiser) +;; + +(* If you want to see what the underlying backtraces look like, set this to true. + Otherwise, these tests extract small snippets from the backtraces so that they are + robust to compiler changes. *) +let just_print = false + +let really_show_backtrace s = + if just_print + then print_endline s + else + printf + "Before re-raise: %b\nAfter re-raise: %b" + (String.is_substring s ~substring:"check_value") + (String.is_substring s ~substring:"handle_uncaught") +;; + +let%test_module ("Show native backtraces" [@tags "no-js"]) = + (module struct + (* good *) + let%expect_test "Base.Exn.reraise" = + test_reraiser _Base_Exn_reraise; + really_show_backtrace [%expect.output]; + [%expect {| + Before re-raise: true + After re-raise: true |}] + ;; + + (* bad, because the backtrace was clobbered *) + let%expect_test "Base.Exn.reraise" = + test_reraiser _Base_Exn_reraise_after_clobbering_most_recent_backtrace; + really_show_backtrace [%expect.output]; + [%expect {| + Before re-raise: false + After re-raise: true |}] + ;; + + (* bad, missing the backtrace before the reraise *) + let%expect_test "%reraise unequal" = + test_reraiser external_reraise_unequal; + really_show_backtrace [%expect.output]; + [%expect {| + Before re-raise: false + After re-raise: true |}] + ;; + + (* bad, missing the backtrace before the reraise *) + let%expect_test "raise unequal" = + test_reraiser vanilla_raise_unequal; + really_show_backtrace [%expect.output]; + [%expect {| + Before re-raise: false + After re-raise: true |}] + ;; + + (* good, but no additional info attached *) + let%expect_test "raise equal" = + test_reraiser vanilla_raise; + really_show_backtrace [%expect.output]; + [%expect {| + Before re-raise: true + After re-raise: true |}] + ;; + + (* good *) + let%expect_test "Caml.Printexc.raise_with_backtrace" = + test_reraiser raise_with_original_backtrace; + really_show_backtrace [%expect.output]; + [%expect {| + Before re-raise: true + After re-raise: true |}] + ;; + + (* good *) + let%expect_test "Exn.reraise_uncaught" = + test_reraise_uncaught ~reraise_uncaught:(Exn.reraise_uncaught "reraised"); + really_show_backtrace [%expect.output]; + [%expect {| + Before re-raise: true + After re-raise: true |}] + ;; + end) +;; + +(* An example bad backtrace: + {v + Uncaught exception: + + (exn.ml.Reraised reraised ("bad value" (x -1))) + + Raised at Base_test__Test_exn_reraise.vanilla_raise_unequal in file "test_exn_reraise.ml" (inlined), line 10, characters 32-70 + Called from Base_test__Test_exn_reraise.reraise_uncaught in file "test_exn_reraise.ml" (inlined), line 34, characters 11-23 + Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml", line 39, characters 4-55 + Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml" (inlined), line 38, characters 15-167 + Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml" (inlined), line 40, characters 4-25 + Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml" (inlined), line 38, characters 15-167 + Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml" (inlined), line 40, characters 4-25 + Called from Base_test__Test_exn_reraise.callstacker in file "test_exn_reraise.ml" (inlined), line 43, characters 2-17 + Called from Base__Exn.handle_uncaught_aux in file "exn.ml" (inlined), line 113, characters 6-10 + Called from Base__Exn.handle_uncaught in file "exn.ml" (inlined), line 139, characters 2-88 + Called from Base_test__Test_exn_reraise.test.(fun) in file "test_exn_reraise.ml", line 53, characters 4-68 + v} +*) + +(* An example good backtrace: + {v + Uncaught exception: + + (exn.ml.Reraised reraised ("bad value" (x -1))) + + Raised at Base__Error.raise in file "error.ml" (inlined), line 9, characters 14-30 + Called from Base__Error.raise_s in file "error.ml" (inlined), line 10, characters 19-40 + Called from Base_test__Test_exn_reraise.check_value in file "test_exn_reraise.ml", line 26, characters 16-56 + Called from Base_test__Test_exn_reraise.callstacker.loop.(fun) in file "test_exn_reraise.ml" (inlined), line 39, characters 41-54 + Called from Base_test__Test_exn_reraise.reraise_uncaught in file "test_exn_reraise.ml" (inlined), line 33, characters 6-10 + Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml", line 39, characters 4-55 + Re-raised at Base_test__Test_exn_reraise._Caml_Printexc_raise_with_backtrace in file "test_exn_reraise.ml", line 18, characters 2-79 + Called from Base_test__Test_exn_reraise.reraise_uncaught in file "test_exn_reraise.ml" (inlined), line 34, characters 11-23 + Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml", line 39, characters 4-55 + Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml" (inlined), line 40, characters 4-25 + Called from Base_test__Test_exn_reraise.callstacker.loop in file "test_exn_reraise.ml" (inlined), line 40, characters 4-25 + Called from Base_test__Test_exn_reraise.callstacker in file "test_exn_reraise.ml" (inlined), line 43, characters 2-17 + Called from Base__Exn.handle_uncaught_aux in file "exn.ml" (inlined), line 113, characters 6-10 + Called from Base__Exn.handle_uncaught in file "exn.ml" (inlined), line 139, characters 2-88 + Called from Base_test__Test_exn_reraise.test.(fun) in file "test_exn_reraise.ml", line 53, characters 4-68 + v}*) diff --git a/test/test_exn_reraise.mli b/test/test_exn_reraise.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/test_exn_reraise.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/test_float.ml b/test/test_float.ml index e8eca1c..3b6260e 100644 --- a/test/test_float.ml +++ b/test/test_float.ml @@ -2,7 +2,7 @@ open! Import open! Float open! Float.Private -let%expect_test ("hash coherence"[@tags "64-bits-only"]) = +let%expect_test ("hash coherence" [@tags "64-bits-only"]) = check_hash_coherence [%here] (module Float) [ min_value; 0.; 37.; max_value ]; [%expect {| |}] ;; @@ -267,11 +267,11 @@ let%test_module _ = http://www.exploringbinary.com/inconsistent-rounding-of-printed-floating-point-numbers/ Ties are resolved differently in JavaScript - mark some tests as no running with JavaScript. *) - let%test_unit (_[@tags "no-js"]) = + let%test_unit (_ [@tags "no-js"]) = boundary (* tie *) 0.25 ~closer_to_zero:"0.2" ~at:"0.2" ;; - let%test_unit (_[@tags "no-js"]) = + let%test_unit (_ [@tags "no-js"]) = boundary (incr 0.25) ~closer_to_zero:"0.2" ~at:"0.3" ;; @@ -285,9 +285,9 @@ let%test_module _ = let%test_unit _ = boundary 0.85 ~closer_to_zero:"0.8" ~at:"0.9" let%test_unit _ = boundary 0.95 ~closer_to_zero:"0.9" ~at:"1 " let%test_unit _ = boundary 1.05 ~closer_to_zero:"1 " ~at:"1.1" - let%test_unit (_[@tags "no-js"]) = boundary 3.25 ~closer_to_zero:"3.2" ~at:"3.2" + let%test_unit (_ [@tags "no-js"]) = boundary 3.25 ~closer_to_zero:"3.2" ~at:"3.2" - let%test_unit (_[@tags "no-js"]) = + let%test_unit (_ [@tags "no-js"]) = boundary (incr 3.25) ~closer_to_zero:"3.2" ~at:"3.3" ;; @@ -296,11 +296,11 @@ let%test_module _ = let%test_unit _ = boundary 10.05 ~closer_to_zero:"10 " ~at:"10.1" let%test_unit _ = boundary 100.05 ~closer_to_zero:"100 " ~at:"100.1" - let%test_unit (_[@tags "no-js"]) = + let%test_unit (_ [@tags "no-js"]) = boundary (* tie *) 999.25 ~closer_to_zero:"999.2" ~at:"999.2" ;; - let%test_unit (_[@tags "no-js"]) = + let%test_unit (_ [@tags "no-js"]) = boundary (incr 999.25) ~closer_to_zero:"999.2" ~at:"999.3" ;; @@ -374,7 +374,7 @@ let%test "int_pow misc" = ;; (* some ugly corner cases with extremely large exponents and some serious precision loss *) -let%test ("int_pow bad cases"[@tags "64-bits-only"]) = +let%test ("int_pow bad cases" [@tags "64-bits-only"]) = let a = one_ulp `Down 1. in let b = one_ulp `Up 1. in let large = 1 lsl 61 in @@ -407,26 +407,6 @@ let%test_unit "sign_or_nan" = 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 - (* Some of the following tests used to live in lib_test/core_float_test.ml. *) let () = Random.init 137 @@ -939,6 +919,19 @@ let%test _ = round_nearest_half_to_even 5.5 = 6. let%test _ = round_nearest_half_to_even 6.5 = 6. let%test _ = round_nearest_half_to_even (one_ulp `Up (-.(2. **. 52.))) = -.(2. **. 52.) let%test _ = round_nearest (one_ulp `Up (-.(2. **. 52.))) = 1. -. (2. **. 52.) +let%test _ = is_integer 1. +let%test _ = is_integer 0. +let%test _ = is_integer (-0.) +let%test _ = is_integer (-1.) +let%test _ = is_integer 8.98e307 +let%test _ = is_integer ((2. ** 53.) -. 0.5) +let%test _ = not (is_integer ((2. ** 52.) -. 0.5)) +let%test _ = not (is_integer 0.0000000000000001) +let%test _ = not (is_integer (-0.0000000000000001)) +let%test _ = not (is_integer 0.9999999999999999) +let%test _ = not (is_integer nan) +let%test _ = not (is_integer infinity) +let%test _ = not (is_integer neg_infinity) let%test_module _ = (module struct @@ -955,11 +948,7 @@ let%test_module _ = let%test _ = must_fail int63_round_nearest_portable_alloc_exn min_value let%test _ = must_fail int63_round_nearest_portable_alloc_exn (2. **. 63.) let%test _ = must_fail int63_round_nearest_portable_alloc_exn ~-.(2. **. 63.) - - let%test _ = - must_succeed int63_round_nearest_portable_alloc_exn ((2. **. 62.) -. 512.) - ;; - + let%test _ = must_succeed int63_round_nearest_portable_alloc_exn ((2. **. 62.) -. 512.) let%test _ = must_fail int63_round_nearest_portable_alloc_exn (2. **. 62.) let%test _ = @@ -1007,11 +996,7 @@ let%test_module _ = let%test_unit _ = test ~decimals:3 0.99999 "1.000" "1" let%test_unit _ = test ~decimals:3 0.00001 "0.000" "0" let%test_unit _ = test ~decimals:3 ~-.12345.1 "-12_345.100" "-12_345.1" - - let%test_unit _ = - test ~delimiter:',' ~decimals:3 ~-.12345.1 "-12,345.100" "-12,345.1" - ;; - + let%test_unit _ = test ~delimiter:',' ~decimals:3 ~-.12345.1 "-12,345.100" "-12,345.1" let%test_unit _ = test ~decimals:0 0.99999 "1" "1" let%test_unit _ = test ~decimals:0 0.00001 "0" "0" let%test_unit _ = test ~decimals:0 ~-.12345.1 "-12_345" "-12_345" @@ -1092,13 +1077,6 @@ let%test _ = not (is_negative Float.nan) let%test _ = not (is_non_positive Float.nan) let%test _ = is_non_negative (-0.) -let%expect_test "iround_nearest_exn noalloc" = - let t = Sys.opaque_identity 205.414 in - Expect_test_helpers_core.require_no_allocation [%here] (fun () -> iround_nearest_exn t) - |> printf "%d\n"; - [%expect {| 205 |}] -;; - let%test_unit "int to float conversion consistency" = let test_int63 x = [%test_result: float] (Float.of_int63 x) ~expect:(Float.of_int64 (Int63.to_int64 x)) @@ -1115,9 +1093,7 @@ let%test_unit "int to float conversion consistency" = test_int63 Int63.zero; test_int63 Int63.min_value; test_int63 Int63.max_value; - let rand = - Random.State.make [| Hashtbl.hash "int to float conversion consistency" |] - in + let rand = Random.State.make [| Hashtbl.hash "int to float conversion consistency" |] in for _i = 0 to 100 do let x = Random.State.int rand Int.max_value in test_int x @@ -1152,3 +1128,39 @@ let%expect_test "min and max" = 0 -0 -0 0 -0 0 |}] ;; + +let%expect_test "is_nan, is_inf, and is_finite" = + List.iter + ~f:(fun x -> + printf + !"%24s %5s %5s %5s\n" + (to_string x) + (Bool.to_string (is_nan x)) + (Bool.to_string (is_inf x)) + (Bool.to_string (is_finite x))) + [ nan + ; neg_infinity + ; -.max_finite_value + ; -1. + ; -.min_positive_subnormal_value + ; -0. + ; 0. + ; min_positive_subnormal_value + ; 1. + ; max_finite_value + ; infinity + ]; + [%expect + {| + nan true false false + -inf false true false + -1.7976931348623157e+308 false false true + -1. false false true + -4.94065645841247e-324 false false true + -0. false false true + 0. false false true + 4.94065645841247e-324 false false true + 1. false false true + 1.7976931348623157e+308 false false true + inf false true false |}] +;; diff --git a/test/test_hash_set.ml b/test/test_hash_set.ml index ed2bdd6..f35e9bb 100644 --- a/test/test_hash_set.ml +++ b/test/test_hash_set.ml @@ -73,3 +73,28 @@ let%expect_test "union" = print_union [ 0; 1; 2 ] [ 1; 2; 3 ]; [%expect {| (0 1 2 3) |}] ;; + +let%expect_test "deriving equal" = + let module Hs = struct + type t = { hs : Hash_set.M(Int).t } [@@deriving equal] + + let of_list lst = { hs = Hash_set.of_list (module Int) lst } + end + in + require [%here] (Hs.equal (Hs.of_list []) (Hs.of_list [])); + require [%here] (not (Hs.equal (Hs.of_list [ 1 ]) (Hs.of_list []))); + require [%here] (not (Hs.equal (Hs.of_list [ 1 ]) (Hs.of_list [ 2 ]))); + require [%here] (Hs.equal (Hs.of_list [ 1 ]) (Hs.of_list [ 1 ])) +;; + +(* This module exists to check, at compile-time, that [Creators] is a subset of + [Creators_generic]. *) +module _ (M : Creators) : + Creators_generic + with type 'a t := 'a M.t + with type 'a elt := 'a + with type ('a, 'z) create_options := ('a, 'z) create_options = struct + include M + + let create ?growth_allowed ?size m () = create ?growth_allowed ?size m +end diff --git a/test/test_hashtbl.ml b/test/test_hashtbl.ml index 52d08e6..ab96c99 100644 --- a/test/test_hashtbl.ml +++ b/test/test_hashtbl.ml @@ -1,5 +1,5 @@ open! Base -open Expect_test_helpers_core +open Expect_test_helpers_base type int_hashtbl = int Hashtbl.M(Int).t [@@deriving sexp] @@ -7,8 +7,7 @@ let%test "Hashtbl.merge succeeds with first-class-module interface" = let t1 = Hashtbl.create (module Int) in let t2 = Hashtbl.create (module Int) in let result = - Hashtbl.merge t1 t2 ~f:(fun ~key:_ -> - function + Hashtbl.merge t1 t2 ~f:(fun ~key:_ -> function | `Left x -> x | `Right x -> x | `Both _ -> assert false) @@ -59,9 +58,7 @@ let%expect_test "[t_of_sexp] error on duplicate" = let%expect_test "[choose], [choose_exn]" = let test ?size l = - let t = - l |> List.map ~f:(fun i -> i, i) |> Hashtbl.of_alist_exn ?size (module Int) - in + let t = l |> List.map ~f:(fun i -> i, i) |> Hashtbl.of_alist_exn ?size (module Int) in print_s [%message "" @@ -112,79 +109,18 @@ let%expect_test "[choose], [choose_exn]" = (choose_exn (Ok (_ _)))) |}] ;; -let%expect_test "find_and_call_1_and_2" = - let test x = - let t = Hashtbl.create (module Int) ~size:16 ~growth_allowed:false in - for i = 0 to x - 1 do - Hashtbl.add_exn t ~key:i ~data:(i * 7) - done; - let if_found a b = assert (a = b) in - let if_not_found a b = - assert (a = x); - assert (b = x * 7) - in - require_no_allocation [%here] (fun () -> - for i = 0 to x do - Hashtbl.find_and_call1 t i ~a:(i * 7) ~if_found ~if_not_found - done); - let if_found ~key ~data:a b = - assert (a = b); - assert (key = a / 7) - in - let if_not_found a b = - assert (a = x); - assert (b = x * 7) - in - require_no_allocation [%here] (fun () -> - for i = 0 to x do - Hashtbl.findi_and_call1 t i ~a:(i * 7) ~if_found ~if_not_found - done); - let if_found a b c = - assert (a = b); - assert (b = c / 2) - in - let if_not_found a b c = - assert (a = x); - assert (b = x * 7); - assert (c = x * 14) - in - require_no_allocation [%here] (fun () -> - for i = 0 to x do - Hashtbl.find_and_call2 t i ~a:(i * 7) ~b:(i * 14) ~if_found ~if_not_found - done); - let if_found ~key ~data:a b c = - assert (a = b); - assert (b = c / 2); - assert (key = a / 7) - in - let if_not_found a b c = - assert (a = x); - assert (b = x * 7); - assert (c = x * 14) - in - require_no_allocation [%here] (fun () -> - for i = 0 to x do - Hashtbl.findi_and_call2 t i ~a:(i * 7) ~b:(i * 14) ~if_found ~if_not_found - done); - print_s (Int.sexp_of_t x) +let%expect_test "update_and_return" = + let t = Hashtbl.create (module String) in + let update_and_return str ~f = + let x = Hashtbl.update_and_return t str ~f in + print_s [%message (t : (string, int) Hashtbl.t) (x : int)] in - (* try various load factors, to exercise all branches of matching on the structure of - the avl tree *) - test 1; - test 3; - test 10; - test 17; - test 25; - test 29; - test 33; - test 3133; - [%expect {| - 1 - 3 - 10 - 17 - 25 - 29 - 33 - 3_133 |}] + update_and_return "foo" ~f:(function + | None -> 1 + | Some _ -> failwith "no"); + [%expect {| ((t ((foo 1))) (x 1)) |}]; + update_and_return "foo" ~f:(function + | Some 1 -> 2 + | _ -> failwith "no"); + [%expect {| ((t ((foo 2))) (x 2)) |}] ;; diff --git a/test/test_identifiable.ml b/test/test_identifiable.ml index 3d9eb71..304bc3b 100644 --- a/test/test_identifiable.ml +++ b/test/test_identifiable.ml @@ -11,7 +11,7 @@ module T = struct end) end -let%expect_test ("hash coherence"[@tags "64-bits-only"]) = +let%expect_test ("hash coherence" [@tags "64-bits-only"]) = check_hash_coherence [%here] (module T) ([ ""; "a"; "foo" ] |> List.map ~f:T.of_string); [%expect {| |}] ;; diff --git a/test/test_indexed_container.ml b/test/test_indexed_container.ml index 0c7e971..45b556c 100644 --- a/test/test_indexed_container.ml +++ b/test/test_indexed_container.ml @@ -36,8 +36,7 @@ module Int_option = struct type t = int option [@@deriving compare, sexp_of] end -let check (type a) here examples ~actual ~expect (module Output : Output with type t = a) - = +let check (type a) here examples ~actual ~expect (module Output : Output with type t = a) = List.iter examples ~f:(fun example -> let actual = actual example in let expect = expect example in diff --git a/test/test_info.ml b/test/test_info.ml index b9dfc7b..b16001d 100644 --- a/test/test_info.ml +++ b/test/test_info.ml @@ -17,8 +17,7 @@ let%expect_test _ = ;; let%expect_test _ = - print_endline - (to_string_hum (tag_s ~tag:[%message "tag"] (create_s [%message "info"]))); + print_endline (to_string_hum (tag_s ~tag:[%message "tag"] (create_s [%message "info"]))); [%expect {| (tag info) |}] ;; diff --git a/test/test_int.ml b/test/test_int.ml index b00ccd1..79ceaaa 100644 --- a/test/test_int.ml +++ b/test/test_int.ml @@ -1,7 +1,7 @@ open! Import open! Int -let%expect_test ("hash coherence"[@tags "64-bits-only"]) = +let%expect_test ("hash coherence" [@tags "64-bits-only"]) = check_int_hash_coherence [%here] (module Int); [%expect {| |}] ;; @@ -131,3 +131,19 @@ let%expect_test "bswap16" = 0x1122_331f --> 0x1f33 0x1122_3344 --> 0x4433 |}] ;; + +include ( +struct + (** Various functors whose type-correctness ensures desired relationships between + interfaces. *) + + (* O contained in S *) + module _ (M : S) : module type of M.O = M + + (* O contained in S_unbounded *) + module _ (M : S_unbounded) : module type of M.O = M + + (* S_unbounded in S *) + module _ (M : S) : S_unbounded = M +end : +sig end) diff --git a/test/test_int32_pow2.ml b/test/test_int32_pow2.ml index 9ebef33..d85bccc 100644 --- a/test/test_int32_pow2.ml +++ b/test/test_int32_pow2.ml @@ -31,7 +31,7 @@ let%expect_test "[floor_log2]" = (65 (Ok 6)) |}] ;; -let%expect_test ("[floor_log2]"[@tags "64-bits-only"]) = +let%expect_test ("[floor_log2]" [@tags "64-bits-only"]) = print_for examples_64_bit floor_log2; [%expect {| @@ -60,7 +60,7 @@ let%expect_test "[ceil_log2]" = (65 (Ok 7)) |}] ;; -let%expect_test ("[ceil_log2]"[@tags "64-bits-only"]) = +let%expect_test ("[ceil_log2]" [@tags "64-bits-only"]) = print_for examples_64_bit ceil_log2; [%expect {| diff --git a/test/test_int63.ml b/test/test_int63.ml index 58aed90..b22640c 100644 --- a/test/test_int63.ml +++ b/test/test_int63.ml @@ -1,7 +1,7 @@ open! Import open! Int63 -let%expect_test ("hash coherence"[@tags "64-bits-only"]) = +let%expect_test ("hash coherence" [@tags "64-bits-only"]) = check_int_hash_coherence [%here] (module Int63); [%expect {| |}] ;; @@ -60,6 +60,35 @@ let%test_module "Overflow_exn" = ;; end) ;; + + let is_overflow = Exn.does_raise + + let%test_module "( * )" = + (module struct + let%test "1 * 1" = one * one = one + let%test "1 * 0" = one * zero = zero + let%test "0 * 1" = zero * one = zero + let%test "min_value * -1" = is_overflow (fun () -> min_value * neg one) + let%test "-1 * min_value" = is_overflow (fun () -> neg one * min_value) + + let%test "46116860184273879 * 100" = + of_int64_exn 46116860184273879L * of_int 100 = of_int64_exn 4611686018427387900L + ;; + + let%test "46116860184273879 * 101" = + is_overflow (fun () -> of_int64_exn 46116860184273879L * of_int 101) + ;; + end) + ;; + + let%test_module "( / )" = + (module struct + let%test "1 / 1" = one / one = one + let%test "min_value / -1" = is_overflow (fun () -> min_value / neg one) + let%test "min_value / 1" = min_value / one = min_value + let%test "max_value / -1" = max_value / neg one = min_value + one + end) + ;; end) ;; diff --git a/test/test_int63_emul.ml b/test/test_int63_emul.ml index 73bfca0..b1f496c 100644 --- a/test/test_int63_emul.ml +++ b/test/test_int63_emul.ml @@ -6,8 +6,7 @@ let%expect_test _ = let s63_emul = Int63_emul.(Hex.to_string min_value) in print_s [%message (s63 : string) (s63_emul : string)]; require [%here] (String.equal s63 s63_emul); - [%expect - {| + [%expect {| ((s63 -0x4000000000000000) (s63_emul -0x4000000000000000)) |}] ;; diff --git a/test/test_int64_pow2.ml b/test/test_int64_pow2.ml index 26e1d61..0a98573 100644 --- a/test/test_int64_pow2.ml +++ b/test/test_int64_pow2.ml @@ -30,7 +30,7 @@ let%expect_test "[floor_log2]" = (65 (Ok 6)) |}] ;; -let%expect_test ("[floor_log2]"[@tags "64-bits-only"]) = +let%expect_test ("[floor_log2]" [@tags "64-bits-only"]) = print_for examples_64_bit floor_log2; [%expect {| @@ -61,7 +61,7 @@ let%expect_test "[ceil_log2]" = (65 (Ok 7)) |}] ;; -let%expect_test ("[ceil_log2]"[@tags "64-bits-only"]) = +let%expect_test ("[ceil_log2]" [@tags "64-bits-only"]) = print_for examples_64_bit ceil_log2; [%expect {| diff --git a/test/test_int_hash.ml b/test/test_int_hash.ml index 033d083..eaccd44 100644 --- a/test/test_int_hash.ml +++ b/test/test_int_hash.ml @@ -1,7 +1,7 @@ open! Base open! Import -let%expect_test ("int hash is not ident"[@tags "64-bits-only"]) = +let%expect_test ("int hash is not ident" [@tags "64-bits-only"]) = print_s [%message "hash of 10" (Int.hash 10 : int)]; [%expect {| ("hash of 10" ("Int.hash 10" 1_579_120_067_278_557_813)) |}] ;; diff --git a/test/test_int_math.ml b/test/test_int_math.ml index 526bea8..792261a 100644 --- a/test/test_int_math.ml +++ b/test/test_int_math.ml @@ -291,7 +291,7 @@ let%test_module "int rounding quickcheck tests" = test_direction m ~dir) ;; - let%expect_test ("int"[@tags "no-js", "64-bits-only"]) = + let%expect_test ("int" [@tags "no-js", "64-bits-only"]) = test (module struct include Int @@ -364,7 +364,7 @@ let%test_module "int rounding quickcheck tests" = (testing Nearest) |}] ;; - let%expect_test ("nativeint"[@tags "no-js", "64-bits-only"]) = + let%expect_test ("nativeint" [@tags "no-js", "64-bits-only"]) = test (module struct include Nativeint diff --git a/test/test_int_pow2.ml b/test/test_int_pow2.ml index 0a9d1ca..679b1ba 100644 --- a/test/test_int_pow2.ml +++ b/test/test_int_pow2.ml @@ -10,8 +10,7 @@ let examples_64_bit = let print_for ints f = List.iter ints ~f:(fun i -> print_s - [%message - "" ~_:(i : int) ~_:(Or_error.try_with (fun () -> f i) : int Or_error.t)]) + [%message "" ~_:(i : int) ~_:(Or_error.try_with (fun () -> f i) : int Or_error.t)]) ;; let%expect_test "[floor_log2]" = @@ -33,7 +32,7 @@ let%expect_test "[floor_log2]" = (65 (Ok 6)) |}] ;; -let%expect_test ("[floor_log2]"[@tags "64-bits-only"]) = +let%expect_test ("[floor_log2]" [@tags "64-bits-only"]) = print_for examples_64_bit floor_log2; [%expect {| @@ -64,7 +63,7 @@ let%expect_test "[ceil_log2]" = (65 (Ok 7)) |}] ;; -let%expect_test ("[ceil_log2]"[@tags "64-bits-only"]) = +let%expect_test ("[ceil_log2]" [@tags "64-bits-only"]) = print_for examples_64_bit ceil_log2; [%expect {| diff --git a/test/test_lazy.ml b/test/test_lazy.ml index 3da0aa4..53f8daf 100644 --- a/test/test_lazy.ml +++ b/test/test_lazy.ml @@ -58,3 +58,35 @@ let%test_module _ = ;; end) ;; + +let%expect_test "equal" = + let lazy_a = + lazy + (print_endline "force lazy_a"; + 1) + in + let lazy_b = + lazy + (print_endline "force lazy_b"; + 1) + in + let lazy_c = + lazy + (print_endline "force lazy_c"; + 2) + in + (* [phys_equal] short-circuiting without [force] *) + print_s [%sexp (equal Int.equal lazy_a lazy_a : bool)]; + [%expect {| true |}]; + (* [force], resulting in [true] *) + print_s [%sexp (equal Int.equal lazy_a lazy_b : bool)]; + [%expect {| + force lazy_b + force lazy_a + true |}]; + (* [force], resulting in [false] *) + print_s [%sexp (equal Int.equal lazy_b lazy_c : bool)]; + [%expect {| + force lazy_c + false |}] +;; diff --git a/test/test_list.ml b/test/test_list.ml index 2ff1d6a..972aaf4 100644 --- a/test/test_list.ml +++ b/test/test_list.ml @@ -391,15 +391,20 @@ let%expect_test _ = [%expect {| (raised (Invalid_argument "length mismatch in zip_exn: 1 <> 3")) |}] ;; +let%expect_test _ = + show_raise (fun () -> + rev_map3_exn [ 1 ] [ 4; 5; 6 ] [ 2; 3 ] ~f:(fun a b c -> a + b + c)); + [%expect + {| (raised (Invalid_argument "length mismatch in rev_map3_exn: 1 <> 3 || 3 <> 2")) |}] +;; + let%test_unit _ = [%test_result: (int * string) list] (mapi ~f:(fun i x -> i, x) [ "one"; "two"; "three"; "four" ]) ~expect:[ 0, "one"; 1, "two"; 2, "three"; 3, "four" ] ;; -let%test_unit _ = - [%test_result: (int * _) list] (mapi ~f:(fun i x -> i, x) []) ~expect:[] -;; +let%test_unit _ = [%test_result: (int * _) list] (mapi ~f:(fun i x -> i, x) []) ~expect:[] let%test_module "group" = (module struct @@ -451,6 +456,92 @@ let%test_module "group" = end) ;; +let%test_module "sort_and_group" = + (module struct + let%expect_test _ = + let compare = + Comparable.lift String.compare ~f:(String.rstrip ~drop:Char.is_digit) + in + [%test_result: string list list] + (sort_and_group [ "b1"; "c1"; "a1"; "a2"; "b2"; "a3" ] ~compare) + ~expect:[ [ "a1"; "a2"; "a3" ]; [ "b1"; "b2" ]; [ "c1" ] ] + ;; + end) +;; + +let%test_module "Assoc.group" = + (module struct + let%expect_test _ = + let test alist = + let multi = Assoc.group alist ~equal:String.Caseless.equal in + print_s [%sexp (multi : (string * int list) list)]; + let round_trip = + List.concat_map multi ~f:(fun (key, data) -> + List.map data ~f:(fun datum -> key, datum)) + in + require_equal + [%here] + (module struct + type t = (String.Caseless.t * int) list [@@deriving equal, sexp_of] + end) + alist + round_trip + in + test []; + [%expect {| () |}]; + test [ "a", 1; "A", 2 ]; + [%expect {| ((a (1 2))) |}]; + test [ "a", 1; "b", 2 ]; + [%expect {| + ((a (1)) + (b (2))) |}]; + test [ "odd", 1; "even", 2; "Odd", 3; "Even", 4; "ODD", 5; "EVEN", 6 ]; + [%expect + {| + ((odd (1)) + (even (2)) + (Odd (3)) + (Even (4)) + (ODD (5)) + (EVEN (6))) |}]; + test [ "odd", 1; "Odd", 3; "ODD", 5; "even", 2; "Even", 4; "EVEN", 6 ]; + [%expect {| + ((odd (1 3 5)) + (even (2 4 6))) |}] + ;; + end) +;; + +let%test_module "Assoc.sort_and_group" = + (module struct + let%expect_test _ = + let test alist = + let multi = Assoc.sort_and_group alist ~compare:String.Caseless.compare in + print_s [%sexp (multi : (string * int list) list)]; + require_equal + [%here] + (module struct + type t = (string * int list) list [@@deriving equal, sexp_of] + end) + multi + (Map.to_alist (Map.of_alist_multi (module String.Caseless) alist)) + in + test []; + [%expect {| () |}]; + test [ "a", 1; "A", 2 ]; + [%expect {| ((a (1 2))) |}]; + test [ "a", 1; "b", 2 ]; + [%expect {| + ((a (1)) + (b (2))) |}]; + test [ "odd", 1; "even", 2; "Odd", 3; "Even", 4; "ODD", 5; "EVEN", 6 ]; + [%expect {| + ((even (2 4 6)) + (odd (1 3 5))) |}] + ;; + end) +;; + let%test_module "chunks_of" = (module struct let test length break_every = @@ -498,26 +589,6 @@ let%test _ = not (is_suffix [ 1 ] ~suffix:[ 1; 2 ] ~equal:( = )) let%test _ = not (is_suffix [ 1; 3 ] ~suffix:[ 1; 2 ] ~equal:( = )) let%test _ = is_suffix [ 1; 2; 3 ] ~suffix:[ 2; 3 ] ~equal:( = ) -let%expect_test "is_prefix does not allocate" = - let list = Sys.opaque_identity [ 1; 2; 3 ] in - let prefix = Sys.opaque_identity [ 1; 2 ] in - let equal = Int.equal in - let (_ : bool) = - require_no_allocation [%here] (fun () -> is_prefix list ~equal ~prefix) - in - [%expect {| |}] -;; - -let%expect_test "is_suffix does not allocate" = - let list = Sys.opaque_identity [ 1; 2; 3 ] in - let suffix = Sys.opaque_identity [ 2; 3 ] in - let equal = Int.equal in - let (_ : bool) = - require_no_allocation [%here] (fun () -> is_suffix list ~equal ~suffix) - in - [%expect {| |}] -;; - let%test_unit _ = List.iter ~f:(fun (t, expect) -> @@ -792,9 +863,7 @@ let%test_unit _ = ;; let%test_unit _ = - [%test_result: bool] - (contains_dup ~compare:Int.compare [ 3; 5; 4; 5; 12 ]) - ~expect:true + [%test_result: bool] (contains_dup ~compare:Int.compare [ 3; 5; 4; 5; 12 ]) ~expect:true ;; let%test_unit _ = @@ -886,9 +955,7 @@ let%test_unit _ = ~expect:Test_values.l1 ;; -let%test_unit _ = - [%test_result: int list] (filter_map ~f:(fun x -> Some x) []) ~expect:[] -;; +let%test_unit _ = [%test_result: int list] (filter_map ~f:(fun x -> Some x) []) ~expect:[] let%test_unit _ = [%test_result: int list] (filter_map ~f:(fun _x -> None) [ 1.; 2.; 3. ]) ~expect:[] @@ -1020,10 +1087,7 @@ let%test_unit _ = ;; let%test_unit _ = [%test_result: bool] (is_sorted [] ~compare:Int.compare) ~expect:true - -let%test_unit _ = - [%test_result: bool] (is_sorted [ 1 ] ~compare:Int.compare) ~expect:true -;; +let%test_unit _ = [%test_result: bool] (is_sorted [ 1 ] ~compare:Int.compare) ~expect:true let%test_unit _ = [%test_result: bool] (is_sorted [ 1; 2; 3; 4 ] ~compare:Int.compare) ~expect:true @@ -1086,6 +1150,30 @@ let%test_module "transpose" = ;; let%test_unit _ = + round_trip + [ [ 1; 2; 3 ]; [ 4; 5; 6 ]; [ 7; 8; 9 ] ] + [ [ 1; 4; 7 ]; [ 2; 5; 8 ]; [ 3; 6; 9 ] ] + ;; + + let%test_unit _ = + round_trip + [ [ 1; 2; 3; 4 ]; [ 5; 6; 7; 8 ]; [ 9; 10; 11; 12 ] ] + [ [ 1; 5; 9 ]; [ 2; 6; 10 ]; [ 3; 7; 11 ]; [ 4; 8; 12 ] ] + ;; + + let%test_unit _ = + round_trip + [ [ 1; 2; 3; 4 ]; [ 5; 6; 7; 8 ]; [ 9; 10; 11; 12 ]; [ 13; 14; 15; 16 ] ] + [ [ 1; 5; 9; 13 ]; [ 2; 6; 10; 14 ]; [ 3; 7; 11; 15 ]; [ 4; 8; 12; 16 ] ] + ;; + + let%test_unit _ = + round_trip + [ [ 1; 2; 3 ]; [ 4; 5; 6 ]; [ 7; 8; 9 ]; [ 10; 11; 12 ] ] + [ [ 1; 4; 7; 10 ]; [ 2; 5; 8; 11 ]; [ 3; 6; 9; 12 ] ] + ;; + + let%test_unit _ = [%test_result: int list list option] (transpose [ []; [ 1 ] ]) ~expect:None ;; @@ -1173,3 +1261,89 @@ let%expect_test "drop_last_exn" = require_does_not_raise [%here] (fun () -> print_drop_last_exn [ 1 ]); [%expect {| () |}] ;; + +let%expect_test "[all_equal]" = + let test list = + print_s [%sexp (all_equal list ~equal:Char.Caseless.equal : char option)] + in + (* empty list *) + test []; + [%expect {| () |}]; + (* singleton *) + test [ 'a' ]; + [%expect {| (a) |}]; + (* homogenous pairs (up to [equal]) *) + test [ 'a'; 'a' ]; + [%expect {| (a) |}]; + test [ 'a'; 'A' ]; + [%expect {| (a) |}]; + test [ 'A'; 'a' ]; + [%expect {| (A) |}]; + (* heterogenous pairs *) + test [ 'a'; 'b' ]; + [%expect {| () |}]; + test [ 'b'; 'a' ]; + [%expect {| () |}]; + (* heterogenous lists *) + test [ 'a'; 'b'; 'a'; 'b'; 'a'; 'b' ]; + [%expect {| () |}]; + test [ 'a'; 'b'; 'c'; 'd'; 'e'; 'f' ]; + [%expect {| () |}]; + (* homogenous lists (up to [equal]) *) + test [ 'a'; 'a'; 'a'; 'a'; 'a'; 'a' ]; + [%expect {| (a) |}]; + test [ 'A'; 'a'; 'A'; 'a'; 'A'; 'a' ]; + [%expect {| (A) |}] +;; + +let%expect_test "[Cartesian_product.apply] identity" = + let test list = + require_equal + [%here] + (module struct + type t = char list [@@deriving equal, sexp_of] + end) + list + (List.Cartesian_product.apply (return Fn.id) list) + in + test []; + test [ 'a'; 'b'; 'c' ]; + test [ 'a'; 'z'; 'd'; 'b' ] +;; + +let%expect_test "[Cartesian_product]" = + (let%map.List.Cartesian_product letter = [ 'a'; 'b'; 'c' ] + and number = [ 1; 2; 3 ] + and solfege = [ "do"; "re"; "mi" ] in + [%sexp (letter : char), (number : int), (solfege : string)]) + |> List.iter ~f:print_s; + [%expect + {| + (a 1 do) + (a 1 re) + (a 1 mi) + (a 2 do) + (a 2 re) + (a 2 mi) + (a 3 do) + (a 3 re) + (a 3 mi) + (b 1 do) + (b 1 re) + (b 1 mi) + (b 2 do) + (b 2 re) + (b 2 mi) + (b 3 do) + (b 3 re) + (b 3 mi) + (c 1 do) + (c 1 re) + (c 1 mi) + (c 2 do) + (c 2 re) + (c 2 mi) + (c 3 do) + (c 3 re) + (c 3 mi) |}] +;; diff --git a/test/test_map.ml b/test/test_map.ml index 193d165..38d3344 100644 --- a/test/test_map.ml +++ b/test/test_map.ml @@ -25,11 +25,7 @@ let%test _ = invariants (of_increasing_iterator_unchecked (module Int) ~len:20 ~f:(fun x -> x, x)) ;; -let%test _ = - invariants (Poly.of_increasing_iterator_unchecked ~len:20 ~f:(fun x -> x, x)) -;; - -module M = M +let%test _ = invariants (Poly.of_increasing_iterator_unchecked ~len:20 ~f:(fun x -> x, x)) let add12 t = add_exn t ~key:1 ~data:2 @@ -153,20 +149,22 @@ let%expect_test "combine_errors" = (2 two))) |}] ;; -module Poly = struct - let%test _ = length Poly.empty = 0 +let%test_module "Poly" = + (module struct + let%test _ = length Poly.empty = 0 - let%test _ = - let a = Poly.of_alist_exn [] in - Poly.equal Base.Poly.equal a Poly.empty - ;; + let%test _ = + let a = Poly.of_alist_exn [] in + Poly.equal Base.Poly.equal a Poly.empty + ;; - let%test _ = - let a = Poly.of_alist_exn [ "a", 1 ] in - let b = Poly.of_alist_exn [ 1, "b" ] in - length a = length b - ;; -end + let%test _ = + let a = Poly.of_alist_exn [ "a", 1 ] in + let b = Poly.of_alist_exn [ 1, "b" ] in + length a = length b + ;; + end) +;; let%test_module "[symmetric_diff]" = (module struct @@ -293,3 +291,46 @@ let%test_module "of_alist_multi key equality" = ;; end) ;; + +let%expect_test "remove returns the same object if there's nothing to do" = + let map1 = Map.of_alist_exn (module Int) [ 1, "one"; 3, "three" ] in + let map2 = Map.remove map1 2 in + require [%here] (phys_equal map1 map2) +;; + +let%expect_test "[map_keys]" = + let test m c ~f = + print_s + [%sexp + (Map.map_keys c ~f m + : [ `Duplicate_key of string | `Ok of string Map.M(String).t ])] + in + let map = Map.of_alist_exn (module Int) [ 1, "one"; 2, "two"; 3, "three" ] in + test map (module String) ~f:Int.to_string; + [%expect {| + (Ok ( + (1 one) + (2 two) + (3 three))) |}]; + test map (module String) ~f:(fun x -> Int.to_string (x / 2)); + [%expect {| (Duplicate_key 1) |}] +;; + +let%expect_test "[fold_until]" = + let test t = + print_s + [%sexp + (Map.fold_until + t + ~init:0 + ~f:(fun ~key ~data acc -> if key > 2 then Stop data else Continue (acc + key)) + ~finish:Int.to_string + : string)] + in + let map = Map.of_alist_exn (module Int) [ 1, "one"; 2, "two"; 3, "three" ] in + test map; + [%expect {| three |}]; + let map = Map.of_alist_exn (module Int) [ -1, "minus-one"; 1, "one"; 2, "two" ] in + test map; + [%expect {| 2 |}] +;; diff --git a/test/test_map_comprehensive.ml b/test/test_map_comprehensive.ml new file mode 100644 index 0000000..2c6df1c --- /dev/null +++ b/test/test_map_comprehensive.ml @@ -0,0 +1,1850 @@ +(** Comprehensive testing of [Base.Map]. + + This file tests all exports of [Base.Map]. Every time a new export is added, we have + to add a new definition somewhere here. Every time we add a definition, we should add + a test unless the definition is untestable (e.g., a module type) or trivial (e.g., a + module containing only ppx-derived definitions). We should document categories of + untested definitions, mark them as untested, and keep them separate from definitions + that need tests. *) + +open! Import + +open struct + (** quickcheck configuration *) + + let quickcheck_config = + let test_count = + (* In js_of_ocaml, quickcheck is slow due to 64-bit arithmetic, and some map + operations are especially slow due to use of exceptions and exception handlers. + So on "other" backends, we turn the test count down. *) + match Sys.backend_type with + | Native | Bytecode -> 10_000 + | Other _ -> 1_000 + in + { Base_quickcheck.Test.default_config with test_count } + ;; + + let quickcheck_m here m ~f = quickcheck_m here m ~f ~config:quickcheck_config +end + +(** The types that distinguish instances of [Map.Creators_and_accessors_generic]. *) +module type Types = sig + type 'k key + type 'c cmp + type ('k, 'v, 'c) t + type ('k, 'v, 'c) tree + type ('k, 'c, 'a) create_options + type ('k, 'c, 'a) access_options +end + +(** Like [Map.Creators_and_accessors_generic], but based on [Types] for easier + instantiation. *) +module type S = sig + module Types : Types + + include + Map.Creators_generic + with type ('a, 'b, 'c) t := ('a, 'b, 'c) Types.t + with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Types.tree + with type 'a key := 'a Types.key + with type 'a cmp := 'a Types.cmp + with type ('a, 'b, 'c) options := ('a, 'b, 'c) Types.create_options + + include + Map.Accessors_generic + with type ('a, 'b, 'c) t := ('a, 'b, 'c) Types.t + with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Types.tree + with type 'a key := 'a Types.key + with type 'a cmp := 'a Types.cmp + with type ('a, 'b, 'c) options := ('a, 'b, 'c) Types.access_options +end + +(** Helpers for testing a tree or map type that is an instance of [S]. *) +module type Instance = sig + module Types : Types + + module Key : sig + type t = int Types.key [@@deriving compare, equal, quickcheck, sexp_of] + + include Comparable.Infix with type t := t + end + + type 'a t = (int, 'a, Int.comparator_witness) Types.t + [@@deriving equal, quickcheck, sexp_of] + + (** Construct a [Key.t]. *) + val key : int -> Key.t + + (** Extract an int from a [Key.t]. *) + val int : Key.t -> int + + (** Extract a tree (without a comparator) from [t]. *) + val tree + : (Key.t, 'a, Int.comparator_witness) Types.tree + -> (Key.t, 'a, Int.comparator_witness Types.cmp) Map.Using_comparator.Tree.t + + (** Pass a comparator to a creator function, if necessary. *) + val create : (int, Int.comparator_witness, 'a) Types.create_options -> 'a + + (** Pass a comparator to an accessor function, if necessary *) + val access : (int, Int.comparator_witness, 'a) Types.access_options -> 'a +end + +(** A functor to generate all of [Instance] but [create] and [access] for a map type. *) +module Instance (Cmp : sig + type comparator_witness + + val comparator : (int, comparator_witness) Comparator.t + end) = +struct + module Key = struct + type t = int [@@deriving quickcheck, sexp_of] + type comparator_witness = Cmp.comparator_witness + + let comparator = Cmp.comparator + let compare = comparator.compare + let equal = [%compare.equal: t] + let quickcheck_generator = Base_quickcheck.Generator.small_strictly_positive_int + + include Comparable.Infix (struct + type nonrec t = t + + let compare = compare + end) + end + + type 'a t = 'a Map.M(Key).t [@@deriving equal, sexp_of] + + let key x = x + let int x = x + let tree x = x + + let quickcheck_generator gen = + Base_quickcheck.Generator.map_t_m + (module Key) + Base_quickcheck.Generator.small_strictly_positive_int + gen + ;; + + let quickcheck_observer obs = + Base_quickcheck.Observer.map_t Base_quickcheck.Observer.int obs + ;; + + let quickcheck_shrinker shr = + Base_quickcheck.Shrinker.map_t Base_quickcheck.Shrinker.int shr + ;; +end + +(** Instantiating key and data both as [int]. *) +module Instance_int = struct + module I = Instance (Int) + + type t = int I.t [@@deriving equal, quickcheck, sexp_of] +end + +(** A functor like [Instance], but for tree types. *) +module Instance_tree (Cmp : sig + type comparator_witness + + val comparator : (int, comparator_witness) Comparator.t + end) = +struct + module M = Instance (Cmp) + include M + + type 'a t = (int, 'a, Cmp.comparator_witness) Map.Using_comparator.Tree.t + + let of_tree tree = Map.Using_comparator.of_tree ~comparator:Cmp.comparator tree + let to_tree t = Map.Using_comparator.to_tree t + + let quickcheck_generator gen = + Base_quickcheck.Generator.map (M.quickcheck_generator gen) ~f:to_tree + ;; + + let quickcheck_observer obs = + Base_quickcheck.Observer.unmap (M.quickcheck_observer obs) ~f:of_tree + ;; + + let quickcheck_shrinker shr = + Base_quickcheck.Shrinker.map (M.quickcheck_shrinker shr) ~f:to_tree ~f_inverse:of_tree + ;; + + let equal equal_a = Map.Using_comparator.Tree.equal ~comparator:Int.comparator equal_a + let sexp_of_t sexp_of_a t = M.sexp_of_t sexp_of_a (of_tree t) +end + +(** Functor for [List.t] *) +module Lst (T : sig + type t [@@deriving equal, sexp_of] + end) = +struct + type t = T.t list [@@deriving equal, sexp_of] +end + +(** Functor for [Or_error], ignoring error contents when comparing. *) +module Ok (T : sig + type t [@@deriving equal, sexp_of] + end) = +struct + type t = (T.t, (Error.t[@equal.ignore])) Result.t [@@deriving equal, sexp_of] +end + +(** Functor for [Option.t] *) +module Opt (T : sig + type t [@@deriving equal, sexp_of] + end) = +struct + type t = T.t option [@@deriving equal, sexp_of] +end + +(** Functor for pairs of a single type. Random generation frequently generates pairs of + identical values. *) +module Pair (T : sig + type t [@@deriving equal, quickcheck, sexp_of] + end) = +struct + type t = T.t * T.t [@@deriving equal, quickcheck, sexp_of] + + let quickcheck_generator = + let open Base_quickcheck.Generator.Let_syntax in + match%bind Base_quickcheck.Generator.bool with + | true -> [%generator: t] + | false -> + let%map x = [%generator: T.t] in + x, x + ;; +end + +(** Expect tests for everything exported from [Map.Creators_and_accessors_generic]. *) +module Test_creators_and_accessors + (Types : Types) + (Impl : S with module Types := Types) + (Instance : Instance with module Types := Types) : S with module Types := Types = +struct + open Instance + open Impl + + open struct + (** Test helpers, not to be exported. *) + + module Alist = struct + type t = (Key.t * int) list [@@deriving compare, equal, quickcheck, sexp_of] + end + + module Alist_merge = struct + type t = (Key.t * (int, int) Map.Merge_element.t) list [@@deriving equal, sexp_of] + end + + module Alist_multi = struct + type t = (Key.t * int list) list [@@deriving equal, quickcheck, sexp_of] + end + + module Diff = struct + type t = (Key.t, int) Map.Symmetric_diff_element.t list [@@deriving equal, sexp_of] + end + + module Inst = struct + type t = int Instance.t [@@deriving equal, quickcheck, sexp_of] + end + + module Inst_and_key = struct + type t = Inst.t * Key.t [@@deriving quickcheck, sexp_of] + end + + module Inst_and_key_and_data = struct + type t = Inst.t * Key.t * int [@@deriving quickcheck, sexp_of] + end + + module Inst_multi = struct + type t = int list Instance.t [@@deriving equal, quickcheck, sexp_of] + end + + module Key_and_data = struct + type t = Key.t * int [@@deriving equal, sexp_of] + end + + module Maybe_bound = struct + include Maybe_bound + + type 'a t = 'a Maybe_bound.t = + | Incl of 'a + | Excl of 'a + | Unbounded + [@@deriving quickcheck, sexp_of] + end + end + + (** creators *) + + let empty = empty + + let%expect_test _ = + print_s [%sexp (create empty : int t)]; + [%expect {| () |}] + ;; + + let singleton = singleton + + let%expect_test _ = + print_s [%sexp (create singleton (key 1) 2 : int t)]; + [%expect {| ((1 2)) |}] + ;; + + let of_alist = of_alist + let of_alist_or_error = of_alist_or_error + let of_alist_exn = of_alist_exn + + let%expect_test _ = + quickcheck_m + [%here] + (module Alist) + ~f:(fun alist -> + let t_or_error = create of_alist_or_error alist in + let t_exn = Or_error.try_with (fun () -> create of_alist_exn alist) in + let t_or_duplicate = + match create of_alist alist with + | `Ok t -> Ok t + | `Duplicate_key key -> Or_error.error_s [%sexp (key : Key.t)] + in + require_equal + [%here] + (module Ok (Alist)) + (Or_error.map t_or_error ~f:to_alist) + (let compare = Comparable.lift Key.compare ~f:fst in + if List.contains_dup alist ~compare + then Or_error.error_string "duplicate" + else Ok (List.sort alist ~compare)); + require_equal [%here] (module Ok (Inst)) t_exn t_or_error; + require_equal [%here] (module Ok (Inst)) t_or_duplicate t_or_error); + [%expect {| |}] + ;; + + let of_alist_multi = of_alist_multi + let of_alist_fold = of_alist_fold + let of_alist_reduce = of_alist_reduce + + let%expect_test _ = + quickcheck_m + [%here] + (module Alist) + ~f:(fun alist -> + let t_multi = create of_alist_multi alist in + let t_fold = + create of_alist_fold alist ~init:[] ~f:(fun xs x -> x :: xs) |> map ~f:List.rev + in + let t_reduce = + create of_alist_reduce (List.Assoc.map alist ~f:List.return) ~f:( @ ) + in + require_equal + [%here] + (module Alist_multi) + (to_alist t_multi) + (List.Assoc.sort_and_group alist ~compare:Key.compare); + require_equal [%here] (module Inst_multi) t_fold t_multi; + require_equal [%here] (module Inst_multi) t_reduce t_multi); + [%expect {| |}] + ;; + + let of_sequence = of_sequence + let of_sequence_or_error = of_sequence_or_error + let of_sequence_exn = of_sequence_exn + + let%expect_test _ = + quickcheck_m + [%here] + (module Alist) + ~f:(fun alist -> + let seq = Sequence.of_list alist in + let t_or_error = create of_sequence_or_error seq in + let t_exn = Or_error.try_with (fun () -> create of_sequence_exn seq) in + let t_or_duplicate = + match create of_sequence seq with + | `Ok t -> Ok t + | `Duplicate_key key -> Or_error.error_s [%sexp (key : Key.t)] + in + let expect = create of_alist_or_error alist in + require_equal [%here] (module Ok (Inst)) t_or_error expect; + require_equal [%here] (module Ok (Inst)) t_exn expect; + require_equal [%here] (module Ok (Inst)) t_or_duplicate expect); + [%expect {| |}] + ;; + + let of_sequence_multi = of_sequence_multi + let of_sequence_fold = of_sequence_fold + let of_sequence_reduce = of_sequence_reduce + + let%expect_test _ = + quickcheck_m + [%here] + (module Alist) + ~f:(fun alist -> + let seq = Sequence.of_list alist in + let t_multi = create of_sequence_multi seq in + let t_fold = + create of_sequence_fold seq ~init:[] ~f:(fun xs x -> x :: xs) |> map ~f:List.rev + in + let t_reduce = + create + of_sequence_reduce + (alist |> List.Assoc.map ~f:List.return |> Sequence.of_list) + ~f:( @ ) + in + let expect = create of_alist_multi alist in + require_equal [%here] (module Inst_multi) t_multi expect; + require_equal [%here] (module Inst_multi) t_fold expect; + require_equal [%here] (module Inst_multi) t_reduce expect); + [%expect {| |}] + ;; + + let of_increasing_sequence = of_increasing_sequence + + let%expect_test _ = + quickcheck_m + [%here] + (module Alist) + ~f:(fun alist -> + let seq = Sequence.of_list alist in + let actual = create of_increasing_sequence seq in + let expect = + if List.is_sorted alist ~compare:(Comparable.lift Key.compare ~f:fst) + then create of_alist_or_error alist + else Or_error.error_string "decreasing keys" + in + require_equal [%here] (module Ok (Inst)) actual expect); + [%expect {| |}] + ;; + + let of_sorted_array = of_sorted_array + + let%expect_test _ = + quickcheck_m + [%here] + (module Alist) + ~f:(fun alist -> + let actual = create of_sorted_array (Array.of_list alist) in + let expect = + let compare = Comparable.lift Key.compare ~f:fst in + if List.is_sorted_strictly ~compare alist + || List.is_sorted_strictly ~compare (List.rev alist) + then create of_alist_or_error alist + else Or_error.error_string "unsorted" + in + require_equal [%here] (module Ok (Inst)) actual expect); + [%expect {| |}] + ;; + + let of_sorted_array_unchecked = of_sorted_array_unchecked + + let%expect_test _ = + quickcheck_m + [%here] + (module Alist) + ~f:(fun alist -> + let alist = + List.dedup_and_sort alist ~compare:(Comparable.lift Key.compare ~f:fst) + in + let actual_fwd = create of_sorted_array_unchecked (Array.of_list alist) in + let actual_rev = create of_sorted_array_unchecked (Array.of_list_rev alist) in + let expect = create of_alist_exn alist in + require_equal [%here] (module Inst) actual_fwd expect; + require_equal [%here] (module Inst) actual_rev expect); + [%expect {| |}] + ;; + + let of_increasing_iterator_unchecked = of_increasing_iterator_unchecked + + let%expect_test _ = + quickcheck_m + [%here] + (module Alist) + ~f:(fun alist -> + let alist = + List.dedup_and_sort alist ~compare:(Comparable.lift Key.compare ~f:fst) + in + let actual = + let array = Array.of_list alist in + create + of_increasing_iterator_unchecked + ~len:(Array.length array) + ~f:(Array.get array) + in + let expect = create of_alist_exn alist in + require_equal [%here] (module Inst) actual expect); + [%expect {| |}] + ;; + + let of_iteri = of_iteri + let of_iteri_exn = of_iteri_exn + + let%expect_test _ = + quickcheck_m + [%here] + (module Alist) + ~f:(fun alist -> + let iteri ~f = List.iter alist ~f:(fun (key, data) -> f ~key ~data) in + let actual_or_duplicate = + match create of_iteri ~iteri with + | `Ok t -> Ok t + | `Duplicate_key key -> Or_error.error_s [%sexp (key : Key.t)] + in + let actual_exn = Or_error.try_with (fun () -> create of_iteri_exn ~iteri) in + let expect = create of_alist_or_error alist in + require_equal [%here] (module Ok (Inst)) actual_or_duplicate expect; + require_equal [%here] (module Ok (Inst)) actual_exn expect); + [%expect {| |}] + ;; + + let map_keys = map_keys + let map_keys_exn = map_keys_exn + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key) + ~f:(fun (t, k) -> + let f key = Comparable.min Key.compare k key in + let actual_or_duplicate = + match create map_keys t ~f with + | `Ok t -> Ok t + | `Duplicate_key key -> Or_error.error_s [%sexp (key : Key.t)] + in + let actual_exn = Or_error.try_with (fun () -> create map_keys_exn t ~f) in + let expect = + to_alist t + |> List.map ~f:(fun (key, data) -> f key, data) + |> create of_alist_or_error + in + require_equal [%here] (module Ok (Inst)) actual_or_duplicate expect; + require_equal [%here] (module Ok (Inst)) actual_exn expect); + [%expect {| |}] + ;; + + (** accessors *) + + let invariants = invariants + + let%expect_test _ = + quickcheck_m [%here] (module Inst) ~f:(fun t -> require [%here] (access invariants t)); + [%expect {| |}] + ;; + + let is_empty = is_empty + let length = length + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst) + ~f:(fun t -> + let len = length t in + require_equal [%here] (module Bool) (is_empty t) (len = 0); + require_equal [%here] (module Int) len (List.length (to_alist t))); + [%expect {| |}] + ;; + + let mem = mem + let find = find + let find_exn = find_exn + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key) + ~f:(fun (t, key) -> + let expect = List.Assoc.find (to_alist t) key ~equal:Key.equal in + require_equal [%here] (module Bool) (access mem t key) (Option.is_some expect); + require_equal [%here] (module Opt (Int)) (access find t key) expect; + require_equal + [%here] + (module Opt (Int)) + (Option.try_with (fun () -> access find_exn t key)) + expect); + [%expect {| |}] + ;; + + let set = set + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key_and_data) + ~f:(fun (t, key, data) -> + require_equal + [%here] + (module Alist) + (to_alist (access set t ~key ~data)) + (List.sort + ~compare:(Comparable.lift Key.compare ~f:fst) + ((key, data) :: List.Assoc.remove (to_alist t) key ~equal:Key.equal))); + [%expect {| |}] + ;; + + let add = add + let add_exn = add_exn + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key_and_data) + ~f:(fun (t, key, data) -> + let t_add = + match access add t ~key ~data with + | `Ok t -> Ok t + | `Duplicate -> Or_error.error_string "duplicate" + in + let t_add_exn = Or_error.try_with (fun () -> access add_exn t ~key ~data) in + let expect = + if access mem t key + then Or_error.error_string "duplicate" + else Ok (access set t ~key ~data) + in + require_equal [%here] (module Ok (Inst)) t_add expect; + require_equal [%here] (module Ok (Inst)) t_add_exn expect); + [%expect {| |}] + ;; + + let remove = remove + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key) + ~f:(fun (t, key) -> + require_equal + [%here] + (module Alist) + (to_alist (access remove t key)) + (List.Assoc.remove (to_alist t) key ~equal:Key.equal)); + [%expect {| |}] + ;; + + let change = change + + let%expect_test _ = + quickcheck_m + [%here] + (module struct + type t = Inst.t * Key.t * int option [@@deriving quickcheck, sexp_of] + end) + ~f:(fun (t, key, maybe_data) -> + let actual = + access change t key ~f:(fun previous -> + require_equal [%here] (module Opt (Int)) previous (access find t key); + [%expect {| |}]; + maybe_data) + in + let expect = + match maybe_data with + | None -> access remove t key + | Some data -> access set t ~key ~data + in + require_equal [%here] (module Inst) actual expect); + [%expect {| |}] + ;; + + let update = update + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key_and_data) + ~f:(fun (t, key, data) -> + let actual = + access update t key ~f:(fun previous -> + require_equal [%here] (module Opt (Int)) previous (access find t key); + [%expect {| |}]; + data) + in + let expect = access set t ~key ~data in + require_equal [%here] (module Inst) actual expect); + [%expect {| |}] + ;; + + let find_multi = find_multi + let add_multi = add_multi + let remove_multi = remove_multi + + let%expect_test _ = + quickcheck_m + [%here] + (module struct + type t = Inst_multi.t * Key.t * int [@@deriving quickcheck, sexp_of] + end) + ~f:(fun (t, key, data) -> + require_equal + [%here] + (module Lst (Int)) + (access find_multi t key) + (access find t key |> Option.value ~default:[]); + require_equal + [%here] + (module Inst_multi) + (access add_multi t ~key ~data) + (access update t key ~f:(fun option -> data :: Option.value option ~default:[])); + require_equal + [%here] + (module Inst_multi) + (access remove_multi t key) + (access change t key ~f:(function + | None | Some ([] | [ _ ]) -> None + | Some (_ :: (_ :: _ as rest)) -> Some rest))); + [%expect {| |}] + ;; + + let iter_keys = iter_keys + let iter = iter + let iteri = iteri + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst) + ~f:(fun t -> + let actuali = + let q = Queue.create () in + iteri t ~f:(fun ~key ~data -> Queue.enqueue q (key, data)); + Queue.to_list q + in + let actual_keys = + let q = Queue.create () in + iter_keys t ~f:(Queue.enqueue q); + Queue.to_list q + in + let actual = + let q = Queue.create () in + iter t ~f:(Queue.enqueue q); + Queue.to_list q + in + require_equal [%here] (module Alist) actuali (to_alist t); + require_equal [%here] (module Lst (Key)) actual_keys (keys t); + require_equal [%here] (module Lst (Int)) actual (data t)); + [%expect {| |}] + ;; + + let map = map + let mapi = mapi + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst) + ~f:(fun t -> + require_equal + [%here] + (module Inst) + (map t ~f:Int.succ) + (t |> to_alist |> List.Assoc.map ~f:Int.succ |> create of_alist_exn); + require_equal + [%here] + (module struct + type t = (Key.t * int) Instance.t [@@deriving equal, sexp_of] + end) + (mapi t ~f:(fun ~key ~data -> key, data)) + (t |> to_alist |> List.map ~f:(fun (k, v) -> k, (k, v)) |> create of_alist_exn)); + [%expect {| |}] + ;; + + let filter_keys = filter_keys + let filter = filter + let filteri = filteri + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key_and_data) + ~f:(fun (t, k, d) -> + require_equal + [%here] + (module Alist) + (to_alist (access filter_keys t ~f:(fun key -> Key.( <= ) key k))) + (List.filter (to_alist t) ~f:(fun (key, _) -> Key.( <= ) key k)); + require_equal + [%here] + (module Alist) + (to_alist (access filter t ~f:(fun data -> data <= d))) + (List.filter (to_alist t) ~f:(fun (_, data) -> data <= d)); + require_equal + [%here] + (module Alist) + (to_alist + (access filteri t ~f:(fun ~key ~data -> Key.( <= ) key k && data <= d))) + (List.filter (to_alist t) ~f:(fun (key, data) -> Key.( <= ) key k && data <= d))); + [%expect {| |}] + ;; + + let filter_map = filter_map + let filter_mapi = filter_mapi + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key_and_data) + ~f:(fun (t, k, d) -> + require_equal + [%here] + (module Alist) + (to_alist + (access filter_map t ~f:(fun data -> Option.some_if (data >= d) (data - d)))) + (List.filter_map (to_alist t) ~f:(fun (key, data) -> + Option.some_if (data >= d) (key, data - d))); + require_equal + [%here] + (module Alist) + (to_alist + (access filter_mapi t ~f:(fun ~key ~data -> + Option.some_if (Key.( <= ) key k && data >= d) (data - d)))) + (List.filter_map (to_alist t) ~f:(fun (key, data) -> + Option.some_if (Key.( <= ) key k && data >= d) (key, data - d)))); + [%expect {| |}] + ;; + + let partition_mapi = partition_mapi + let partition_map = partition_map + let partitioni_tf = partitioni_tf + let partition_tf = partition_tf + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key_and_data) + ~f:(fun (t, k, d) -> + require_equal + [%here] + (module Pair (Alist)) + (let a, b = access partition_tf t ~f:(fun data -> data <= d) in + to_alist a, to_alist b) + (List.partition_tf (to_alist t) ~f:(fun (_, data) -> data <= d)); + require_equal + [%here] + (module Pair (Alist)) + (let a, b = + access partitioni_tf t ~f:(fun ~key ~data -> Key.( <= ) key k && data <= d) + in + to_alist a, to_alist b) + (List.partition_tf (to_alist t) ~f:(fun (key, data) -> + Key.( <= ) key k && data <= d)); + require_equal + [%here] + (module Pair (Alist)) + (let a, b = + access partition_map t ~f:(fun data -> + if data >= d then First (data - d) else Second d) + in + to_alist a, to_alist b) + (List.partition_map (to_alist t) ~f:(fun (key, data) -> + if data >= d then First (key, data - d) else Second (key, d))); + require_equal + [%here] + (module Pair (Alist)) + (let a, b = + access partition_mapi t ~f:(fun ~key ~data -> + if Key.( <= ) key k && data >= d then First (data - d) else Second d) + in + to_alist a, to_alist b) + (List.partition_map (to_alist t) ~f:(fun (key, data) -> + if Key.( <= ) key k && data >= d + then First (key, data - d) + else Second (key, d)))); + [%expect {| |}] + ;; + + let fold = fold + let fold_right = fold_right + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst) + ~f:(fun t -> + require_equal + [%here] + (module Alist) + (fold t ~init:[] ~f:(fun ~key ~data list -> (key, data) :: list)) + (List.rev (to_alist t)); + require_equal + [%here] + (module Alist) + (fold_right t ~init:[] ~f:(fun ~key ~data list -> (key, data) :: list)) + (to_alist t)); + [%expect {| |}] + ;; + + let fold_until = fold_until + let iteri_until = iteri_until + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key) + ~f:(fun (t, threshold) -> + require_equal + [%here] + (module struct + type t = int list * Base.Map.Finished_or_unfinished.t + [@@deriving equal, sexp_of] + end) + (let q = Queue.create () in + let status = + iteri_until t ~f:(fun ~key ~data -> + if Key.( >= ) key threshold + then Stop + else ( + Queue.enqueue q data; + Continue)) + in + Queue.to_list q, status) + (let list = + to_alist t + |> List.take_while ~f:(fun (key, _) -> Key.( < ) key threshold) + |> List.map ~f:snd + in + list, if List.length list = length t then Finished else Unfinished)); + [%expect {| |}] + ;; + + let combine_errors = combine_errors + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key) + ~f:(fun (t, threshold) -> + let t = + mapi t ~f:(fun ~key ~data -> + if Key.( <= ) key threshold + then Ok data + else Or_error.error_string "too big") + in + require_equal + [%here] + (module Ok (Inst)) + (access combine_errors t) + (to_alist t + |> List.map ~f:(fun (key, result) -> + Or_error.map result ~f:(fun data -> key, data)) + |> Or_error.combine_errors + |> Or_error.map ~f:(create of_alist_exn))); + [%expect {| |}] + ;; + + let equal = equal + let compare_direct = compare_direct + + let%expect_test _ = + quickcheck_m + [%here] + (module Pair (Inst)) + ~f:(fun (a, b) -> + require_equal + [%here] + (module Ordering) + (Ordering.of_int (access compare_direct Int.compare a b)) + (Ordering.of_int (Alist.compare (to_alist a) (to_alist b))); + require_equal + [%here] + (module Bool) + (access compare_direct Int.compare a b = 0) + (access equal Int.equal a b)); + [%expect {| |}] + ;; + + let keys = keys + let data = data + let to_alist = to_alist + let to_sequence = to_sequence + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst) + ~f:(fun t -> + let alist = to_alist t in + require_equal [%here] (module Inst) (create of_alist_exn alist) t; + require_equal [%here] (module Lst (Key)) (keys t) (List.map alist ~f:fst); + require_equal [%here] (module Lst (Int)) (data t) (List.map alist ~f:snd); + require_equal + [%here] + (module Alist) + (Sequence.to_list ((access to_sequence) t)) + alist); + [%expect {| |}] + ;; + + let%expect_test _ = + quickcheck_m + [%here] + (module struct + type t = Inst.t * [ `Decreasing | `Increasing ] [@@deriving quickcheck, sexp_of] + end) + ~f:(fun (t, key_order) -> + let alist = to_alist t ~key_order in + require_equal + [%here] + (module Lst (Key_and_data)) + alist + (match key_order with + | `Increasing -> to_alist t + | `Decreasing -> List.rev (to_alist t)); + require_equal + [%here] + (module Lst (Key_and_data)) + alist + (Sequence.to_list + ((access to_sequence) + t + ~order: + (match key_order with + | `Decreasing -> `Decreasing_key + | `Increasing -> `Increasing_key)))); + [%expect {| |}] + ;; + + let%expect_test _ = + quickcheck_m + [%here] + (module struct + type t = Inst.t * [ `Decreasing_key | `Increasing_key ] * Key.t * Key.t + [@@deriving quickcheck, sexp_of] + end) + ~f:(fun (t, order, keys_greater_or_equal_to, keys_less_or_equal_to) -> + let alist = + Sequence.to_list + ((access to_sequence) + t + ~order + ~keys_greater_or_equal_to + ~keys_less_or_equal_to) + in + require_equal + [%here] + (module Lst (Key_and_data)) + alist + (List.filter + (match order with + | `Decreasing_key -> List.rev (to_alist t) + | `Increasing_key -> to_alist t) + ~f:(fun (key, _) -> + Key.( <= ) keys_greater_or_equal_to key + && Key.( <= ) key keys_less_or_equal_to))); + [%expect {| |}] + ;; + + let merge = merge + let iter2 = iter2 + let fold2 = fold2 + + let%expect_test _ = + quickcheck_m + [%here] + (module struct + module Inst2 = Pair (Inst) + + type t = Inst2.t * Key.t [@@deriving quickcheck, sexp_of] + end) + ~f:(fun ((a, b), k) -> + let merge_alist = + access merge a b ~f:(fun ~key elt -> + Option.some_if (Key.( > ) key k) (key, elt)) + |> data + in + let iter2_alist = + let q = Queue.create () in + access iter2 a b ~f:(fun ~key ~data:elt -> + if Key.( > ) key k then Queue.enqueue q (key, elt)); + Queue.to_list q + in + let fold2_alist = + access fold2 a b ~init:[] ~f:(fun ~key ~data:elt acc -> + if Key.( > ) key k then (key, elt) :: acc else acc) + |> List.rev + in + let expect = + [ map a ~f:Either.first; map b ~f:Either.second ] + |> List.concat_map ~f:to_alist + |> List.Assoc.sort_and_group ~compare:Key.compare + |> List.filter_map ~f:(fun (key, list) -> + let elt = + match (list : _ Either.t list) with + | [ First x ] -> `Left x + | [ Second y ] -> `Right y + | [ First x; Second y ] -> `Both (x, y) + | _ -> assert false + in + Option.some_if (Key.( > ) key k) (key, elt)) + in + require_equal [%here] (module Alist_merge) merge_alist expect; + require_equal [%here] (module Alist_merge) iter2_alist expect; + require_equal [%here] (module Alist_merge) fold2_alist expect); + [%expect {| |}] + ;; + + let merge_skewed = merge_skewed + + let%expect_test _ = + quickcheck_m + [%here] + (module Pair (Inst)) + ~f:(fun (a, b) -> + let actual = access merge_skewed a b ~combine:(fun ~key a b -> int key + a + b) in + let expect = + access merge a b ~f:(fun ~key elt -> + match elt with + | `Left a -> Some a + | `Right b -> Some b + | `Both (a, b) -> Some (int key + a + b)) + in + require_equal [%here] (module Inst) actual expect); + [%expect {| |}] + ;; + + let symmetric_diff = symmetric_diff + let fold_symmetric_diff = fold_symmetric_diff + + let%expect_test _ = + quickcheck_m + [%here] + (module Pair (Inst)) + ~f:(fun (a, b) -> + let diff_alist = + access symmetric_diff a b ~data_equal:Int.equal |> Sequence.to_list + in + let fold_alist = + access + fold_symmetric_diff + a + b + ~data_equal:Int.equal + ~init:[] + ~f:(fun acc pair -> pair :: acc) + |> List.rev + in + let expect = + access merge a b ~f:(fun ~key:_ elt -> + match elt with + | `Left x -> Some (`Left x) + | `Right y -> Some (`Right y) + | `Both (x, y) -> if x = y then None else Some (`Unequal (x, y))) + |> to_alist + in + require_equal [%here] (module Diff) diff_alist expect; + require_equal [%here] (module Diff) fold_alist expect); + [%expect {| |}] + ;; + + let min_elt = min_elt + let max_elt = max_elt + let min_elt_exn = min_elt_exn + let max_elt_exn = max_elt_exn + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst) + ~f:(fun t -> + require_equal + [%here] + (module Opt (Key_and_data)) + (min_elt t) + (List.hd (to_alist t)); + require_equal + [%here] + (module Opt (Key_and_data)) + (max_elt t) + (List.last (to_alist t)); + require_equal + [%here] + (module Opt (Key_and_data)) + (Option.try_with (fun () -> min_elt_exn t)) + (List.hd (to_alist t)); + require_equal + [%here] + (module Opt (Key_and_data)) + (Option.try_with (fun () -> max_elt_exn t)) + (List.last (to_alist t))); + [%expect {| |}] + ;; + + let for_all = for_all + let for_alli = for_alli + let exists = exists + let existsi = existsi + let count = count + let counti = counti + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key_and_data) + ~f:(fun (t, k, d) -> + let f data = data <= d in + let fi ~key ~data = Key.( <= ) key k && data <= d in + let fp (key, data) = fi ~key ~data in + let data = data t in + let alist = to_alist t in + require_equal [%here] (module Bool) (for_all t ~f) (List.for_all data ~f); + require_equal [%here] (module Bool) (for_alli t ~f:fi) (List.for_all alist ~f:fp); + require_equal [%here] (module Bool) (exists t ~f) (List.exists data ~f); + require_equal [%here] (module Bool) (existsi t ~f:fi) (List.exists alist ~f:fp); + require_equal [%here] (module Int) (count t ~f) (List.count data ~f); + require_equal [%here] (module Int) (counti t ~f:fi) (List.count alist ~f:fp)); + [%expect {| |}] + ;; + + let split = split + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key) + ~f:(fun (t, k) -> + require_equal + [%here] + (module struct + type t = Inst.t * (Key.t * int) option * Inst.t [@@deriving equal, sexp_of] + end) + (access split t k) + (let before, equal, after = + List.partition3_map (to_alist t) ~f:(fun (key, data) -> + match Ordering.of_int (Key.compare key k) with + | Less -> `Fst (key, data) + | Equal -> `Snd (key, data) + | Greater -> `Trd (key, data)) + in + create of_alist_exn before, List.hd equal, create of_alist_exn after)); + [%expect {| |}] + ;; + + let append = append + + let%expect_test _ = + quickcheck_m + [%here] + (module Pair (Inst)) + ~f:(fun (a, b) -> + require_equal + [%here] + (module Ok (Inst)) + (match access append ~lower_part:a ~upper_part:b with + | `Ok t -> Ok t + | `Overlapping_key_ranges -> Or_error.error_string "overlap") + (match max_elt a, min_elt b with + | Some (x, _), Some (y, _) when Key.( >= ) x y -> + Or_error.error_string "overlap" + | _ -> Ok (create of_alist_exn (to_alist a @ to_alist b))); + let a' = + (* we rely on the fact that the [Inst] generator uses positive keys *) + create map_keys_exn a ~f:(fun k -> key (-int k)) + in + require_equal + [%here] + (module Ok (Inst)) + (match access append ~lower_part:a' ~upper_part:b with + | `Ok t -> Ok t + | `Overlapping_key_ranges -> Or_error.error_string "overlap") + (Ok (create of_alist_exn (to_alist a' @ to_alist b)))); + [%expect {| |}] + ;; + + let subrange = subrange + let fold_range_inclusive = fold_range_inclusive + let range_to_alist = range_to_alist + + let%expect_test _ = + quickcheck_m + [%here] + (module struct + type t = Inst.t * Key.t Maybe_bound.t * Key.t Maybe_bound.t + [@@deriving quickcheck, sexp_of] + end) + ~f:(fun (t, lower_bound, upper_bound) -> + let subrange_alist = access subrange t ~lower_bound ~upper_bound |> to_alist in + let min = + match lower_bound with + | Unbounded -> key Int.min_value + | Incl min -> min + | Excl too_small -> + (* key generator does not generate [max_value], so this cannot overflow *) + key (int too_small + 1) + in + let max = + match upper_bound with + | Unbounded -> key Int.max_value + | Incl max -> max + | Excl too_large -> + (* key generator does not generate [min_value], so this cannot overflow *) + key (int too_large - 1) + in + let fold_alist = + access fold_range_inclusive t ~min ~max ~init:[] ~f:(fun ~key ~data acc -> + (key, data) :: acc) + |> List.rev + in + let range_alist = access range_to_alist t ~min ~max in + let expect = + if Maybe_bound.bounds_crossed + ~lower:lower_bound + ~upper:upper_bound + ~compare:Key.compare + then [] + else + List.filter (to_alist t) ~f:(fun (key, _) -> + Maybe_bound.interval_contains_exn + key + ~lower:lower_bound + ~upper:upper_bound + ~compare:Key.compare) + in + require_equal [%here] (module Alist) subrange_alist expect; + require_equal [%here] (module Alist) fold_alist expect; + require_equal [%here] (module Alist) range_alist expect); + [%expect {| |}] + ;; + + let closest_key = closest_key + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key) + ~f:(fun (t, k) -> + let alist = to_alist t in + let rev_alist = List.rev alist in + require_equal + [%here] + (module Opt (Key_and_data)) + (access closest_key t `Less_than k) + (List.find rev_alist ~f:(fun (key, _) -> Key.( < ) key k)); + require_equal + [%here] + (module Opt (Key_and_data)) + (access closest_key t `Less_or_equal_to k) + (List.find rev_alist ~f:(fun (key, _) -> Key.( <= ) key k)); + require_equal + [%here] + (module Opt (Key_and_data)) + (access closest_key t `Greater_or_equal_to k) + (List.find alist ~f:(fun (key, _) -> Key.( >= ) key k)); + require_equal + [%here] + (module Opt (Key_and_data)) + (access closest_key t `Greater_than k) + (List.find alist ~f:(fun (key, _) -> Key.( > ) key k))); + [%expect {| |}] + ;; + + let nth = nth + let nth_exn = nth_exn + let rank = rank + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key) + ~f:(fun (t, k) -> + List.iteri (to_alist t) ~f:(fun i (key, data) -> + require_equal [%here] (module Opt (Key_and_data)) (nth t i) (Some (key, data)); + require_equal + [%here] + (module Opt (Key_and_data)) + (Option.try_with (fun () -> nth_exn t i)) + (nth t i); + require_equal [%here] (module Opt (Int)) (access rank t key) (Some i)); + require_equal [%here] (module Opt (Key_and_data)) (nth t (length t)) None; + require_equal + [%here] + (module Opt (Int)) + (access rank t k) + (List.find_mapi (to_alist t) ~f:(fun i (key, _) -> + Option.some_if (Key.equal key k) i))); + [%expect {| |}] + ;; + + let binary_search = binary_search + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key) + ~f:(fun (t, k) -> + let targets = [%all: Binary_searchable.Which_target_by_key.t] in + let compare (key, _) k = Key.compare key k in + List.iter targets ~f:(fun which_target -> + require_equal + [%here] + (module Opt (Key_and_data)) + (access + binary_search + t + ~compare:(fun ~key ~data k' -> + require_equal [%here] (module Key) k' k; + require_equal + [%here] + (module Opt (Int)) + (access find t key) + (Some data); + [%expect {| |}]; + compare (key, data) k') + which_target + k) + (let array = Array.of_list (to_alist t) in + Array.binary_search array ~compare which_target k + |> Option.map ~f:(Array.get array)))); + [%expect {| |}] + ;; + + let binary_search_segmented = binary_search_segmented + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst_and_key) + ~f:(fun (t, k) -> + let targets = [%all: Binary_searchable.Which_target_by_segment.t] in + let segment_of (key, _) = if Key.( <= ) key k then `Left else `Right in + List.iter targets ~f:(fun which_target -> + require_equal + [%here] + (module Opt (Key_and_data)) + (access + binary_search_segmented + t + ~segment_of:(fun ~key ~data -> + require_equal + [%here] + (module Opt (Int)) + (access find t key) + (Some data); + [%expect {| |}]; + segment_of (key, data)) + which_target) + (let array = Array.of_list (to_alist t) in + Array.binary_search_segmented array ~segment_of which_target + |> Option.map ~f:(Array.get array)))); + [%expect {| |}] + ;; + + let binary_search_subrange = binary_search_subrange + + let%expect_test _ = + quickcheck_m + [%here] + (module struct + type t = Inst.t * Key.t Maybe_bound.t * Key.t Maybe_bound.t + [@@deriving quickcheck, sexp_of] + end) + ~f:(fun (t, lower_bound, upper_bound) -> + require_equal + [%here] + (module Inst) + (access + binary_search_subrange + t + ~compare:(fun ~key ~data bound -> + require_equal [%here] (module Opt (Int)) (access find t key) (Some data); + [%expect {| |}]; + Key.compare key bound) + ~lower_bound + ~upper_bound) + (access subrange t ~lower_bound ~upper_bound)); + [%expect {| |}] + ;; + + (** tree conversion *) + + let to_tree = to_tree + let of_tree = of_tree + + let%expect_test _ = + quickcheck_m + [%here] + (module Inst) + ~f:(fun t -> + let tree = to_tree t in + let round_trip = create of_tree tree in + require_equal [%here] (module Inst) t round_trip; + require_equal + [%here] + (module Alist) + (to_alist t) + (Map.Using_comparator.Tree.to_alist (Instance.tree tree))); + [%expect {| |}] + ;; +end + +(** Expect tests for all of [Base.Map]'s exports. *) +module _ : module type of struct + include Base.Map +end [@ocaml.remove_aliases] = struct + open Base.Map + + (** module types *) + + module type Accessors1 = Accessors1 + module type Accessors2 = Accessors2 + module type Accessors3 = Accessors3 + module type Accessors3_with_comparator = Accessors3_with_comparator + module type Accessors_generic = Accessors_generic + module type Creators1 = Creators1 + module type Creators2 = Creators2 + module type Creators3_with_comparator = Creators3_with_comparator + module type Creators_and_accessors1 = Creators_and_accessors1 + module type Creators_and_accessors2 = Creators_and_accessors2 + + module type Creators_and_accessors3_with_comparator = + Creators_and_accessors3_with_comparator + + module type Creators_and_accessors_generic = Creators_and_accessors_generic + module type Creators_generic = Creators_generic + module type For_deriving = For_deriving + module type S_poly = S_poly + + (** type-only modules for module type instantiation - untested *) + + module With_comparator = With_comparator + module With_first_class_module = With_first_class_module + module Without_comparator = Without_comparator + + (** supporting datatypes - untested *) + + module Continue_or_stop = Continue_or_stop + module Finished_or_unfinished = Finished_or_unfinished + module Merge_element = Merge_element + module Or_duplicate = Or_duplicate + module Symmetric_diff_element = Symmetric_diff_element + + (** types *) + + type nonrec ('k, 'v, 'c) t = ('k, 'v, 'c) t + type nonrec ('k, 'c) comparator = ('k, 'c) Comparator.Module.t + + (** module types for ppx deriving *) + + module type Compare_m = Compare_m + module type Equal_m = Equal_m + module type Hash_fold_m = Hash_fold_m + module type M_sexp_grammar = M_sexp_grammar + module type M_of_sexp = M_of_sexp + module type Sexp_of_m = Sexp_of_m + + (** functor for ppx deriving - tested below *) + + module M = M + + (** sexp conversions and grammar *) + + let sexp_of_m__t = sexp_of_m__t + let m__t_of_sexp = m__t_of_sexp + + let%expect_test _ = + quickcheck_m + [%here] + (module Instance_int) + ~f:(fun t -> + let sexp = [%sexp_of: int M(Int).t] t in + require_equal [%here] (module Sexp) sexp [%sexp (to_alist t : (int * int) list)]; + let round_trip = [%of_sexp: int M(Int).t] sexp in + require_equal [%here] (module Instance_int) round_trip t); + [%expect {| |}] + ;; + + let m__t_sexp_grammar = m__t_sexp_grammar + + let%expect_test _ = + print_s [%sexp ([%sexp_grammar: int M(Int).t] : _ Sexp_grammar.t)]; + [%expect {| (List (Many (List (Cons Integer (Cons Integer Empty))))) |}] + ;; + + (** comparisons *) + + let compare_m__t = compare_m__t + let equal_m__t = equal_m__t + + let%expect_test _ = + quickcheck_m + [%here] + (module Pair (Instance_int)) + ~f:(fun (a, b) -> + require_equal + [%here] + (module Ordering) + (Ordering.of_int ([%compare: int M(Int).t] a b)) + (Ordering.of_int ([%compare: (int * int) list] (to_alist a) (to_alist b))); + require_equal + [%here] + (module Bool) + ([%equal: int M(Int).t] a b) + ([%equal: (int * int) list] (to_alist a) (to_alist b))); + [%expect {| |}] + ;; + + (** hash functions *) + + let hash_fold_m__t = hash_fold_m__t + let hash_fold_direct = hash_fold_direct + + let%expect_test _ = + quickcheck_m + [%here] + (module Instance_int) + ~f:(fun t -> + let actual_m = Hash.run [%hash_fold: int M(Int).t] t in + let actual_direct = + Hash.run (hash_fold_direct Int.hash_fold_t Int.hash_fold_t) t + in + let expect = Hash.run [%hash_fold: (int * int) list] (to_alist t) in + require_equal [%here] (module Int) actual_m expect; + require_equal [%here] (module Int) actual_direct expect); + [%expect {| |}] + ;; + + (** comparator accessors - untested *) + + let comparator_s = comparator_s + let comparator = comparator + + (** creators and accessors *) + + include + Test_creators_and_accessors + (struct + type 'k key = 'k + type 'c cmp = 'c + type ('k, 'v, 'c) tree = ('k, 'v, 'c) Using_comparator.Tree.t + type ('k, 'c, 'a) create_options = ('k, 'c) comparator -> 'a + type ('k, 'c, 'a) access_options = 'a + + include Base.Map + end) + (struct + include Base.Map + end) + (struct + include Instance (Int) + + let create f = f ((module Int) : _ Comparator.Module.t) + let access x = x + end) + + (** polymorphic comparison interface *) + module Poly = struct + open Poly + + type nonrec ('k, 'v) t = ('k, 'v) t + type nonrec ('k, 'v) tree = ('k, 'v) tree + type nonrec comparator_witness = comparator_witness + + include + Test_creators_and_accessors + (struct + type 'k key = 'k + type 'c cmp = comparator_witness + type nonrec ('k, 'v, _) t = ('k, 'v) t + type nonrec ('k, 'v, _) tree = ('k, 'v) tree + type ('k, 'c, 'a) create_options = 'a + type ('k, 'c, 'a) access_options = 'a + end) + (struct + include Poly + end) + (struct + include Instance (Comparator.Poly) + + let create x = x + let access x = x + end) + end + + (** comparator interface *) + + module Using_comparator = struct + open Using_comparator + + (** type *) + + type nonrec ('k, 'v, 'c) t = ('k, 'v, 'c) t + + (** comparator accessor - untested *) + + let comparator = comparator + + (** sexp conversions *) + + let sexp_of_t = sexp_of_t + let t_of_sexp_direct = t_of_sexp_direct + + let%expect_test _ = + quickcheck_m + [%here] + (module Instance_int) + ~f:(fun t -> + let sexp = sexp_of_t Int.sexp_of_t Int.sexp_of_t [%sexp_of: _] t in + require_equal [%here] (module Sexp) sexp ([%sexp_of: int Map.M(Int).t] t); + let round_trip = + t_of_sexp_direct ~comparator:Int.comparator Int.t_of_sexp Int.t_of_sexp sexp + in + require_equal [%here] (module Instance_int) round_trip t); + [%expect {| |}] + ;; + + (** hash function *) + + let hash_fold_direct = hash_fold_direct + + let%expect_test _ = + quickcheck_m + [%here] + (module Instance_int) + ~f:(fun t -> + require_equal + [%here] + (module Int) + (Hash.run (hash_fold_direct Int.hash_fold_t Int.hash_fold_t) t) + (Hash.run [%hash_fold: int Map.M(Int).t] t)); + [%expect {| |}] + ;; + + (** functor for polymorphic definition - untested *) + + module Empty_without_value_restriction (Cmp : Comparator.S1) = struct + open Empty_without_value_restriction (Cmp) + + let empty = empty + end + + (** creators and accessors *) + + include + Test_creators_and_accessors + (struct + type 'k key = 'k + type 'c cmp = 'c + type ('k, 'v, 'c) tree = ('k, 'v, 'c) Tree.t + type ('k, 'c, 'a) create_options = comparator:('k, 'c) Comparator.t -> 'a + type ('k, 'c, 'a) access_options = 'a + + include Using_comparator + end) + (struct + include Using_comparator + end) + (struct + include Instance (Int) + + let create f = f ~comparator:Int.comparator + let access x = x + end) + + (** tree interface *) + + module Tree = struct + open Tree + + (** type *) + + type nonrec ('k, 'v, 'c) t = ('k, 'v, 'c) t + + (** sexp conversions *) + + let sexp_of_t = sexp_of_t + let t_of_sexp_direct = t_of_sexp_direct + + let%expect_test _ = + let module Tree_int = struct + module I = Instance_tree (Int) + + type t = int I.t [@@deriving equal, quickcheck, sexp_of] + end + in + quickcheck_m + [%here] + (module Tree_int) + ~f:(fun tree -> + let sexp = sexp_of_t Int.sexp_of_t Int.sexp_of_t [%sexp_of: _] tree in + require_equal + [%here] + (module Sexp) + sexp + ([%sexp_of: int Map.M(Int).t] + (Using_comparator.of_tree tree ~comparator:Int.comparator)); + let round_trip = + t_of_sexp_direct ~comparator:Int.comparator Int.t_of_sexp Int.t_of_sexp sexp + in + require_equal [%here] (module Tree_int) round_trip tree); + [%expect {| |}] + ;; + + (** polymorphic constructor - untested *) + + let empty_without_value_restriction = empty_without_value_restriction + + (** builders *) + + module Build_increasing = struct + open Build_increasing + + type nonrec ('k, 'v, 'c) t = ('k, 'v, 'c) t + + (** tree builder functions *) + + let empty = empty + let add_exn = add_exn + let to_tree = to_tree + + let%expect_test _ = + let module Tree_int = struct + module I = Instance_tree (Int) + + type t = int I.t [@@deriving equal, quickcheck, sexp_of] + end + in + quickcheck_m + [%here] + (module struct + type t = + ((int[@generator Base_quickcheck.Generator.small_strictly_positive_int]) + * int) + list + [@@deriving quickcheck, sexp_of] + end) + ~f:(fun alist -> + let actual = + List.fold_result alist ~init:empty ~f:(fun builder (key, data) -> + Or_error.try_with (fun () -> + add_exn builder ~comparator:Int.comparator ~key ~data)) + |> Or_error.map ~f:Build_increasing.to_tree + in + let expect = + Map.Using_comparator.Tree.of_increasing_sequence + ~comparator:Int.comparator + (Sequence.of_list alist) + in + require_equal [%here] (module Ok (Tree_int)) actual expect); + [%expect {| |}] + ;; + end + + (** creators and accessors *) + + include + Test_creators_and_accessors + (struct + type 'k key = 'k + type 'c cmp = 'c + type ('k, 'v, 'c) tree = ('k, 'v, 'c) t + type ('k, 'c, 'a) create_options = comparator:('k, 'c) Comparator.t -> 'a + type ('k, 'c, 'a) access_options = comparator:('k, 'c) Comparator.t -> 'a + + include Tree + end) + (struct + include Tree + end) + (struct + include Instance_tree (Int) + + let create f = f ~comparator:Int.comparator + let access f = f ~comparator:Int.comparator + end) + end + end +end diff --git a/test/test_map_comprehensive.mli b/test/test_map_comprehensive.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/test_map_comprehensive.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/test_nativeint_pow2.ml b/test/test_nativeint_pow2.ml index c5dd3d3..cda6a1e 100644 --- a/test/test_nativeint_pow2.ml +++ b/test/test_nativeint_pow2.ml @@ -30,7 +30,7 @@ let%expect_test "[floor_log2]" = (65 (Ok 6)) |}] ;; -let%expect_test ("[floor_log2]"[@tags "64-bits-only"]) = +let%expect_test ("[floor_log2]" [@tags "64-bits-only"]) = print_for examples_64_bit floor_log2; [%expect {| @@ -61,7 +61,7 @@ let%expect_test "[ceil_log2]" = (65 (Ok 7)) |}] ;; -let%expect_test ("[ceil_log2]"[@tags "64-bits-only"]) = +let%expect_test ("[ceil_log2]" [@tags "64-bits-only"]) = print_for examples_64_bit ceil_log2; [%expect {| diff --git a/test/test_not_found.mlt b/test/test_not_found.mlt index 9e8ccca..4225716 100644 --- a/test/test_not_found.mlt +++ b/test/test_not_found.mlt @@ -1,13 +1,10 @@ open Base +open Expect_test_helpers_base;; -open Expect_test_helpers_core - -;; print_s [%sexp (Not_found_s [%message "foo"] : exn)] -[%%expect {| (Not_found_s foo) |}] +[%%expect {| (Not_found_s foo) |}];; -;; Not_found [%%expect diff --git a/test/test_option.ml b/test/test_option.ml index de9f20d..8d78b8c 100644 --- a/test/test_option.ml +++ b/test/test_option.ml @@ -7,3 +7,28 @@ let%test _ = [%compare.equal: int t] (merge None None ~f) None let%test _ = [%compare.equal: int t] (merge (Some 3) None ~f) (Some 3) let%test _ = [%compare.equal: int t] (merge None (Some 3) ~f) (Some 3) let%test _ = [%compare.equal: int t] (merge (Some 1) (Some 3) ~f) (Some 4) + +let%expect_test "[value_or_thunk]" = + let default () = + print_endline "THUNK!"; + 0 + in + let value_or_thunk = value_or_thunk ~default in + let test t = print_s [%sexp (value_or_thunk t : int)] in + (* trigger the thunk *) + test None; + [%expect {| + THUNK! + 0 |}]; + (* same value, no trigger *) + test (Some 0); + [%expect {| 0 |}]; + (* different value *) + test (Some 1); + [%expect {| 1 |}]; + (* trigger the thunk again: no memoization *) + test None; + [%expect {| + THUNK! + 0 |}] +;; diff --git a/test/test_option_array.ml b/test/test_option_array.ml index 6900f75..a14c3c7 100644 --- a/test/test_option_array.ml +++ b/test/test_option_array.ml @@ -35,7 +35,8 @@ module Sequence = struct let set = set end -include Base_for_tests.Test_blit.Test1_generic +include + Base_for_tests.Test_blit.Test1_generic (struct include Option @@ -91,3 +92,30 @@ let%expect_test _ = check X.magic_value; check X.some_other_value ;; + +let%test _ = foldi (of_array_some [||]) ~init:13 ~f:(fun _ _ _ -> failwith "bad") = 13 + +let%test _ = + foldi (of_array_some [| 13 |]) ~init:17 ~f:(fun i ac x -> ac + i + Option.value_exn x) + = 30 +;; + +let%test _ = + foldi + (of_array_some [| 13; 17 |]) + ~init:19 + ~f:(fun i ac x -> ac + i + Option.value_exn x) + = 50 +;; + +let%test _ = + counti (of_array_some [| 0; 1; 2; 3; 4 |]) ~f:(fun idx x -> idx = Option.value_exn x) + = 5 +;; + +let%test _ = + counti + (of_array_some [| 0; 1; 2; 3; 4 |]) + ~f:(fun idx x -> idx = 4 - Option.value_exn x) + = 1 +;; diff --git a/test/test_ordered_collection_common.ml b/test/test_ordered_collection_common.ml index 0415239..55d038d 100644 --- a/test/test_ordered_collection_common.ml +++ b/test/test_ordered_collection_common.ml @@ -37,8 +37,7 @@ let%test_unit "fast check_pos_len_exn is correct" = Bool.equal (Exn.does_raise (fun () -> Private.slow_check_pos_len_exn ~pos ~len ~total_length)) - (Exn.does_raise (fun () -> check_pos_len_exn ~pos ~len ~total_length)) - )))) + (Exn.does_raise (fun () -> check_pos_len_exn ~pos ~len ~total_length)))))) ;; let%test_unit _ = diff --git a/test/test_pp.ml b/test/test_pp.ml new file mode 100644 index 0000000..612377d --- /dev/null +++ b/test/test_pp.ml @@ -0,0 +1,46 @@ +open! Import + +let to_string pp v = + pp Caml.Format.str_formatter v; + Caml.Format.flush_str_formatter () +;; + +let print pp v = Caml.Printf.printf "%s\n" (to_string pp v) +let print_all pp vs = List.iter ~f:(print pp) vs + +let%expect_test "pretty-printers" = + print_all Char.pp [ '\000'; '\r'; 'a' ]; + [%expect {| + '\000' + '\r' + 'a' |}]; + print_all String.pp [ ""; "foo"; "abc\tdef" ]; + [%expect {| + "" + "foo" + "abc\tdef" |}]; + print_all Sign.pp Sign.all; + [%expect {| + Neg + Zero + Pos |}]; + print_all Bool.pp Bool.all; + [%expect {| + false + true |}]; + print_all Unit.pp Unit.all; + [%expect {| () |}]; + print_all Nothing.pp Nothing.all; + [%expect {| |}]; + print_all Float.pp [ 0.; 3.14; 1.0 /. 0.0 ]; + [%expect {| + 0. + 3.14 + inf |}]; + print_all Int.pp [ 0; 1 ]; + [%expect {| + 0 + 1 |}]; + print Info.pp (Info.create_s [%sexp "hello", "world"]); + [%expect {| (hello world) |}] +;; diff --git a/test/test_pp.mli b/test/test_pp.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/test_pp.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/test_printexc.ml b/test/test_printexc.ml new file mode 100644 index 0000000..5845911 --- /dev/null +++ b/test/test_printexc.ml @@ -0,0 +1,19 @@ +open! Import +module Printexc = Caml.Printexc + +let%expect_test "Printexc: built-in exception" = + print_endline (Printexc.to_string (Invalid_argument "bad")); + [%expect {| Invalid_argument("bad") |}] +;; + +let%expect_test "Sexp conversion of built-in exceptions" = + print_endline (Sexp.to_string (sexp_of_exn (Invalid_argument "bad"))); + [%expect {| (Invalid_argument bad) |}] +;; + +exception My_invalid_argument of string [@@deriving sexp] + +let%expect_test "Printexc: an exception with deriving sexp" = + print_endline (Printexc.to_string (My_invalid_argument "bad")); + [%expect {| (test_printexc.ml.My_invalid_argument bad) |}] +;; diff --git a/test/test_printexc.mli b/test/test_printexc.mli new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/test/test_printexc.mli diff --git a/test/test_queue.ml b/test/test_queue.ml index dc5ee59..3393b63 100644 --- a/test/test_queue.ml +++ b/test/test_queue.ml @@ -1,4 +1,4 @@ -open! Core_kernel +open! Base open Base_test_helpers let%test_module _ = @@ -10,7 +10,7 @@ let%test_module _ = let does_raise = Exn.does_raise - type nonrec 'a t = 'a t [@@deriving bin_io, sexp] + type nonrec 'a t = 'a t [@@deriving sexp, sexp_grammar] let capacity = capacity let set_capacity = set_capacity @@ -71,7 +71,7 @@ let%test_module _ = ;; let%test_unit _ = - assert (does_raise (fun () -> (create ~capacity:(-1) () : _ Queue.t))) + assert (does_raise (fun () : _ Queue.t -> create ~capacity:(-1) ())) ;; let singleton = singleton @@ -104,8 +104,7 @@ let%test_module _ = ;; let%test_unit _ = - assert ( - does_raise (fun () -> (init (-1) ~f:(fun _ -> ()) : unit Queue.t))) + assert (does_raise (fun () : unit Queue.t -> init (-1) ~f:(fun _ -> ()))) ;; let get = get @@ -262,8 +261,7 @@ let%test_module _ = ~expect:(List.equal Int.equal (to_list t1) (to_list t2)); [%test_result: int] (sign (compare Int.compare t1 t2)) - ~expect: - (sign (List.compare Int.compare (to_list t1) (to_list t2))) + ~expect:(sign (List.compare Int.compare (to_list t1) (to_list t2))) ;; let lists = @@ -415,7 +413,7 @@ let%test_module _ = let end_b = That_queue.to_array t_b in if not ([%equal: int array] end_a end_b) then - failwithf + Printf.failwithf "enqueue transition failure of: %s -> %s vs. %s -> %s" (array_string start_a) (array_string end_a) @@ -430,7 +428,7 @@ let%test_module _ = That_queue.iter t_b ~f:(fun x -> r_b := !r_b + x); if !r_a <> !r_b then - failwithf + Printf.failwithf "error in iter: %s (from %s) <> %s (from %s)" (Int.to_string !r_a) (this_to_string t_a) @@ -445,7 +443,7 @@ let%test_module _ = That_queue.iteri t_b ~f:(fun i x -> r_b := !r_b + (x lxor i)); if !r_a <> !r_b then - failwithf + Printf.failwithf "error in iteri: %s (from %s) <> %s (from %s)" (Int.to_string !r_a) (this_to_string t_a) @@ -463,7 +461,7 @@ let%test_module _ = if (not ([%equal: int option] a b)) || not ([%equal: int array] end_a end_b) then - failwithf + Printf.failwithf "error in dequeue: %s (%s -> %s) <> %s (%s -> %s)" (Option.value ~default:"None" (Option.map a ~f:Int.to_string)) (array_string start_a) @@ -489,7 +487,7 @@ let%test_module _ = (This_queue.to_array t_a') (That_queue.to_array t_b')) then - failwithf + Printf.failwithf "error in filter: %s -> %s vs. %s -> %s" (this_to_string t_a) (this_to_string t_a') @@ -512,7 +510,7 @@ let%test_module _ = (This_queue.to_array t_a') (That_queue.to_array t_b')) then - failwithf + Printf.failwithf "error in filteri: %s -> %s vs. %s -> %s" (this_to_string t_a) (this_to_string t_a') @@ -530,7 +528,7 @@ let%test_module _ = let end_b = That_queue.to_array t_b in if not ([%equal: int array] end_a end_b) then - failwithf + Printf.failwithf "error in filter_inplace: %s -> %s vs. %s -> %s" (array_string start_a) (array_string end_a) @@ -549,7 +547,7 @@ let%test_module _ = let end_b = That_queue.to_array t_b in if not ([%equal: int array] end_a end_b) then - failwithf + Printf.failwithf "error in filteri_inplace: %s -> %s vs. %s -> %s" (array_string start_a) (array_string end_a) @@ -567,7 +565,7 @@ let%test_module _ = (This_queue.to_array t_a') (That_queue.to_array t_b')) then - failwithf + Printf.failwithf "error in concat_map: %s (for %s) <> %s (for %s)" (this_to_string t_a') (this_to_string t_a) @@ -585,7 +583,7 @@ let%test_module _ = (This_queue.to_array t_a') (That_queue.to_array t_b')) then - failwithf + Printf.failwithf "error in concat_mapi: %s (for %s) <> %s (for %s)" (this_to_string t_a') (this_to_string t_a) @@ -603,7 +601,7 @@ let%test_module _ = (This_queue.to_array t_a') (That_queue.to_array t_b')) then - failwithf + Printf.failwithf "error in filter_map: %s (for %s) <> %s (for %s)" (this_to_string t_a') (this_to_string t_a) @@ -625,7 +623,7 @@ let%test_module _ = (This_queue.to_array t_a') (That_queue.to_array t_b')) then - failwithf + Printf.failwithf "error in filter_mapi: %s (for %s) <> %s (for %s)" (this_to_string t_a') (this_to_string t_a) @@ -643,7 +641,7 @@ let%test_module _ = (This_queue.to_array t_a') (That_queue.to_array t_b')) then - failwithf + Printf.failwithf "error in map: %s (for %s) <> %s (for %s)" (this_to_string t_a') (this_to_string t_a) @@ -661,7 +659,7 @@ let%test_module _ = (This_queue.to_array t_a') (That_queue.to_array t_b')) then - failwithf + Printf.failwithf "error in mapi: %s (for %s) <> %s (for %s)" (this_to_string t_a') (this_to_string t_a) @@ -676,7 +674,7 @@ let%test_module _ = let b' = That_queue.counti t_b ~f in if a' <> b' then - failwithf + Printf.failwithf "error in counti: %d (for %s) <> %d (for %s)" a' (this_to_string t_a) @@ -691,7 +689,7 @@ let%test_module _ = let b' = That_queue.existsi t_b ~f in if not ([%equal: bool] a' b') then - failwithf + Printf.failwithf "error in existsi: %b (for %s) <> %b (for %s)" a' (this_to_string t_a) @@ -706,7 +704,7 @@ let%test_module _ = let b' = That_queue.for_alli t_b ~f in if not ([%equal: bool] a' b') then - failwithf + Printf.failwithf "error in for_alli: %b (for %s) <> %b (for %s)" a' (this_to_string t_a) @@ -721,7 +719,7 @@ let%test_module _ = let b' = That_queue.findi t_b ~f in if not ([%equal: (int * int) option] a' b') then - failwithf + Printf.failwithf "error in findi: %s (for %s) <> %s (for %s)" (Sexp.to_string ([%sexp_of: (int * int) option] a')) (this_to_string t_a) @@ -736,7 +734,7 @@ let%test_module _ = let b' = That_queue.find_mapi t_b ~f in if not ([%equal: int option] a' b') then - failwithf + Printf.failwithf "error in find_mapi: %s (for %s) <> %s (for %s)" (Sexp.to_string ([%sexp_of: int option] a')) (this_to_string t_a) @@ -754,7 +752,7 @@ let%test_module _ = let end_b = That_queue.to_array copy_b in if not ([%equal: int array] end_a end_b) then - failwithf + Printf.failwithf "error in copy: %s -> %s vs. %s -> %s" (array_string start_a) (array_string end_a) @@ -783,7 +781,7 @@ let%test_module _ = if (not ([%equal: int array] end_a' end_b')) || not ([%equal: int array] end_a end_b) then - failwithf + Printf.failwithf "error in transfer: %s -> (%s, %s) vs. %s -> (%s, %s)" (array_string start_a) (array_string end_a) @@ -800,7 +798,7 @@ let%test_module _ = let that_l = make_list That_queue.fold t_b in if not ([%equal: int list] this_l that_l) then - failwithf + Printf.failwithf "error in fold: %s (from %s) <> %s (from %s)" (Sexp.to_string (this_l |> [%sexp_of: int list])) (this_to_string t_a) @@ -817,7 +815,7 @@ let%test_module _ = let that_l = make_list That_queue.foldi t_b in if not ([%equal: (int * int) list] this_l that_l) then - failwithf + Printf.failwithf "error in foldi: %s (from %s) <> %s (from %s)" (Sexp.to_string (this_l |> [%sexp_of: (int * int) list])) (this_to_string t_a) @@ -831,7 +829,7 @@ let%test_module _ = let that_len = That_queue.length t_b in if this_len <> that_len then - failwithf + Printf.failwithf "error in length: %i (for %s) <> %i (for %s)" this_len (this_to_string t_a) @@ -850,7 +848,7 @@ let%test_module _ = let arr_b = That_queue.to_array t_b in if not ([%equal: int array] arr_a arr_b) then - failwithf + Printf.failwithf "queue final states not equal: %s vs. %s" (array_string arr_a) (array_string arr_b) @@ -921,9 +919,6 @@ let%test_module _ = end) ;; - let binary_search = binary_search - let binary_search_segmented = binary_search_segmented - let%test_unit "modification-during-iteration" = let x = `A 0 in let t = of_list [ x; x ] in @@ -994,29 +989,8 @@ let%test_module _ = assert (does_raise (fun () -> iter t ~f)); assert (not !reached_unreachable) ;; - - 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 [Core_queue]. *) : + change [Queue]. *) : module type of Queue)) ;; diff --git a/test/test_random.ml b/test/test_random.ml index 8830811..6dbc421 100644 --- a/test/test_random.ml +++ b/test/test_random.ml @@ -1,20 +1,22 @@ open! Import open! Random -module State = struct - include State +let%test_module "State" = + (module struct + include State - let%test_unit ("random int above 2^30"[@tags "64-bits-only"]) = - let state = make [| 1; 2; 3; 4; 5 |] in - for _ = 1 to 100 do - let bound = Int.shift_left 1 40 in - let n = int state bound in - if n < 0 || n >= bound - then - failwith (Printf.sprintf "random result %d out of bounds (0,%d)" n (bound - 1)) - done - ;; -end + let%test_unit ("random int above 2^30" [@tags "64-bits-only"]) = + let state = make [| 1; 2; 3; 4; 5 |] in + for _ = 1 to 100 do + let bound = Int.shift_left 1 40 in + let n = int state bound in + if n < 0 || n >= bound + then + failwith (Printf.sprintf "random result %d out of bounds (0,%d)" n (bound - 1)) + done + ;; + end) +;; external random_seed : unit -> Caml.Obj.t = "caml_sys_random_seed" @@ -294,8 +296,7 @@ let%expect_test "int63_incl" = (fun () -> Int63.random_incl Int63.min_value Int63.max_value) ~min:Int63.min_value ~max:Int63.max_value - ~check_range: - (Int63.( / ) Int63.min_value (i 100), Int63.( / ) Int63.max_value (i 100)); + ~check_range:(Int63.( / ) Int63.min_value (i 100), Int63.( / ) Int63.max_value (i 100)); [%expect {||}] ;; @@ -339,10 +340,7 @@ let%test_module "float upper bound is inclusive despite docs" = st.(2) <- 0b11111__11111__11111__11111__11111__00000; (Caml.Obj.magic (st, 0) : Random.State.t) in - require - [%here] - ~cr:CR_someday - (Float.( < ) (Random.State.float random_state 1.) 1.); + require [%here] ~cr:CR_someday (Float.( < ) (Random.State.float random_state 1.) 1.); [%expect {| |}] ;; diff --git a/test/test_result.ml b/test/test_result.ml new file mode 100644 index 0000000..f97f6a3 --- /dev/null +++ b/test/test_result.ml @@ -0,0 +1,60 @@ +open! Base +open! Import + +let%test_module "Result.Error" = + (module struct + open Result.Error.Let_syntax + + module Int_or_string = struct + type t = (int, string) Result.t [@@deriving equal, sexp_of] + end + + let%expect_test "return" = + require_equal [%here] (module Int_or_string) (return "error") (Error "error"); + [%expect {| |}] + ;; + + let%expect_test "bind Error" = + let result = + let%bind e1 = Error "e1" in + let%bind e2 = Error "e2" in + let%bind e3 = Error "e3" in + return (String.concat ~sep:"," [ e1; e2; e3 ]) + in + require_equal [%here] (module Int_or_string) result (Error "e1,e2,e3"); + [%expect {| |}] + ;; + + let%expect_test "bind Ok" = + let result = + let%bind e1 = Error "e1" in + let%bind e2 = Ok 1 in + let%bind e3 = Error "e3" in + return (String.concat ~sep:"," [ e1; e2; e3 ]) + in + require_equal [%here] (module Int_or_string) result (Ok 1); + [%expect {| |}] + ;; + + let%expect_test "map Error" = + let result = + let%map e1 = Error "e1" in + e1 ^ "!" + in + require_equal [%here] (module Int_or_string) result (Error "e1!"); + [%expect {| |}] + ;; + + let%expect_test "map Ok" = + let result = + let%map e1 = Ok 1 in + e1 ^ "!" + in + require_equal [%here] (module Int_or_string) result (Ok 1); + [%expect {| |}] + ;; + + (* The rest of the Monad functions are derived using the Monad.Make functor, which is + well-tested. *) + end) +;; diff --git a/test/test_result.mli b/test/test_result.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/test_result.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/test_sequence.ml b/test/test_sequence.ml index 9e0143e..7f602ec 100644 --- a/test/test_sequence.ml +++ b/test/test_sequence.ml @@ -58,14 +58,41 @@ let%test_module "Sequence.merge*" = [ Both (2, 2); Left 1; Right 3 ] ;; - let%test_unit _ = - [%test_eq: (int * string) list] - (to_list - (merge - (of_list [ 0, "A"; 1, "A" ]) - (of_list [ 1, "B"; 2, "B" ]) - ~compare:(fun a b -> [%compare: int] (fst a) (fst b)))) - [ 0, "A"; 1, "A"; 2, "B" ] + let test_merge_semantics ~merge ~normalize_list = + Base_quickcheck.Test.run_exn + (module struct + module Deduped_and_sorted_int_list = struct + type t = int list [@@deriving quickcheck, sexp_of] + + let sort t = normalize_list t ~compare:Int.compare + + let quickcheck_generator = + Base_quickcheck.Generator.map quickcheck_generator ~f:sort + ;; + + let quickcheck_shrinker = + Base_quickcheck.Shrinker.map quickcheck_shrinker ~f:sort ~f_inverse:sort + ;; + end + + type t = Deduped_and_sorted_int_list.t * Deduped_and_sorted_int_list.t + [@@deriving quickcheck, sexp_of] + end) + ~f:(fun (xs, ys) -> + [%test_result: int list] + (Sequence.to_list + (merge (Sequence.of_list xs) (Sequence.of_list ys) ~compare:Int.compare)) + ~expect:(normalize_list (xs @ ys) ~compare:Int.compare)) + ;; + + let%test_unit "merge_deduped_and_sorted" = + test_merge_semantics + ~merge:Sequence.merge_deduped_and_sorted + ~normalize_list:List.dedup_and_sort + ;; + + let%test_unit "merge_sorted" = + test_merge_semantics ~merge:Sequence.merge_sorted ~normalize_list:List.sort ;; end) ;; @@ -352,10 +379,7 @@ let%test_unit _ = [%test_result: int list] (to_list (sub s12345 ~pos:1 ~len:2)) ~expect:[ 2; 3 ] ;; -let%test_unit _ = - [%test_result: int list] (to_list (sub s12345 ~pos:0 ~len:0)) ~expect:[] -;; - +let%test_unit _ = [%test_result: int list] (to_list (sub s12345 ~pos:0 ~len:0)) ~expect:[] let%test_unit _ = [%test_result: int list] (to_list (take s12345 2)) ~expect:[ 1; 2 ] let%test_unit _ = [%test_result: int list] (to_list (take s12345 0)) ~expect:[] diff --git a/test/test_set.ml b/test/test_set.ml index 906aa27..796d13d 100644 --- a/test/test_set.ml +++ b/test/test_set.ml @@ -6,13 +6,15 @@ type int_set = Set.M(Int).t [@@deriving compare, equal, hash, sexp] let%test _ = invariants (of_increasing_iterator_unchecked (module Int) ~len:20 ~f:Fn.id) let%test _ = invariants (Poly.of_increasing_iterator_unchecked ~len:20 ~f:Fn.id) -module Poly = struct - let%test _ = length Poly.empty = 0 - let%test _ = Poly.equal (Poly.of_list []) Poly.empty +let%test_module "Poly" = + (module struct + let%test _ = length Poly.empty = 0 + let%test _ = Poly.equal (Poly.of_list []) Poly.empty - let%test _ = - let a = Poly.of_list [ 1; 1 ] in - let b = Poly.of_list [ "a" ] in - length a = length b - ;; -end + let%test _ = + let a = Poly.of_list [ 1; 1 ] in + let b = Poly.of_list [ "a" ] in + length a = length b + ;; + end) +;; diff --git a/test/test_sexp.ml b/test/test_sexp.ml deleted file mode 100644 index a733599..0000000 --- a/test/test_sexp.ml +++ /dev/null @@ -1,44 +0,0 @@ -open! Import - -let%expect_test "[sexp_array]" = - let module M = struct - type t = { x : int sexp_array [@ocaml.warning "-3"] } [@@deriving sexp_of] - end - in - List.iter [ [||]; [| 13 |] ] ~f:(fun x -> print_s [%sexp ({ x } : M.t)]); - [%expect {| - () - ((x (13))) |}] -;; - -let%expect_test "[sexp_list]" = - let module M = struct - type t = { x : int sexp_list [@ocaml.warning "-3"] } [@@deriving sexp_of] - end - in - List.iter [ []; [ 13 ] ] ~f:(fun x -> print_s [%sexp ({ x } : M.t)]); - [%expect {| - () - ((x (13))) |}] -;; - -let%expect_test "[sexp_opaque]" = - let module M = struct - type t = { x : int sexp_opaque [@ocaml.warning "-3"] } [@@deriving sexp_of] - end - in - print_s [%sexp ({ x = 13 } : M.t)]; - [%expect {| - ((x <opaque>)) |}] -;; - -let%expect_test "[sexp_option]" = - let module M = struct - type t = { x : int sexp_option [@ocaml.warning "-3"] } [@@deriving sexp_of] - end - in - List.iter [ None; Some 13 ] ~f:(fun x -> print_s [%sexp ({ x } : M.t)]); - [%expect {| - () - ((x 13)) |}] -;; diff --git a/test/test_sexp_deprecation.mlt b/test/test_sexp_deprecation.mlt deleted file mode 100644 index 4982fb5..0000000 --- a/test/test_sexp_deprecation.mlt +++ /dev/null @@ -1,45 +0,0 @@ -open! Base - -type t = unit sexp_array - -[%%expect - {| -Line _, characters _-_: -Error (alert deprecated): Base.sexp_array -[since 2019-03] use [@sexp.array] instead -|}] - -type t = sexp_bool - -[%%expect - {| -Line _, characters _-_: -Error: Unbound type constructor sexp_bool -|}] - -type t = unit sexp_list - -[%%expect - {| -Line _, characters _-_: -Error (alert deprecated): Base.sexp_list -[since 2019-03] use [@sexp.list] instead -|}] - -type t = unit sexp_option - -[%%expect - {| -Line _, characters _-_: -Error (alert deprecated): Base.sexp_option -[since 2019-03] use [@sexp.option] instead -|}] - -type t = unit sexp_opaque - -[%%expect - {| -Line _, characters _-_: -Error (alert deprecated): Base.sexp_opaque -[since 2019-03] use [@sexp.opaque] instead -|}] diff --git a/test/test_sign.ml b/test/test_sign.ml index 4c6a531..a797608 100644 --- a/test/test_sign.ml +++ b/test/test_sign.ml @@ -11,7 +11,7 @@ let%test_unit "( * )" = ~expect:(Int.( * ) (to_int s1) (to_int s2))) ;; -let%expect_test ("hash coherence"[@tags "64-bits-only"]) = +let%expect_test ("hash coherence" [@tags "64-bits-only"]) = check_hash_coherence [%here] (module Sign) all; [%expect {| |}] ;; diff --git a/test/test_sign_or_nan.ml b/test/test_sign_or_nan.ml index d5d1de4..0840111 100644 --- a/test/test_sign_or_nan.ml +++ b/test/test_sign_or_nan.ml @@ -3,7 +3,7 @@ open! Sign_or_nan let%test "of_int" = of_int 37 = Pos && of_int (-22) = Neg && of_int 0 = Zero -let%expect_test ("hash coherence"[@tags "64-bits-only"]) = +let%expect_test ("hash coherence" [@tags "64-bits-only"]) = check_hash_coherence [%here] (module Sign_or_nan) all; [%expect {| |}] ;; diff --git a/test/test_string.ml b/test/test_string.ml index a248965..90fd3e0 100644 --- a/test/test_string.ml +++ b/test/test_string.ml @@ -1,7 +1,7 @@ open! Import open! String -let%expect_test ("hash coherence"[@tags "64-bits-only"]) = +let%expect_test ("hash coherence" [@tags "64-bits-only"]) = check_hash_coherence [%here] (module String) [ ""; "a"; "foo" ]; [%expect {| |}] ;; @@ -51,11 +51,7 @@ let%test_module "Caseless Comparable" = let%test _ = Caseless.equal "OCaml" "ocaml" let%test _ = Caseless.("apple" < "Banana") let%test _ = Caseless.("aa" < "aaa") - - let%test _ = - Int.( <> ) (Caseless.compare "apple" "Banana") (compare "apple" "Banana") - ;; - + let%test _ = Int.( <> ) (Caseless.compare "apple" "Banana") (compare "apple" "Banana") let%test _ = Caseless.equal "XxX" "xXx" let%test _ = Caseless.("XxX" < "xXxX") let%test _ = Caseless.("XxXx" > "xXx") @@ -63,14 +59,6 @@ let%test_module "Caseless Comparable" = let%test _ = List.is_sorted ~compare:Caseless.compare [ "Apples"; "bananas"; "Carrots" ] ;; - - let%expect_test _ = - let x = Sys.opaque_identity "one string" in - let y = Sys.opaque_identity "another" in - require_no_allocation [%here] (fun () -> - ignore (Sys.opaque_identity (Caseless.equal x y) : bool)); - [%expect {||}] - ;; end) ;; @@ -131,8 +119,7 @@ let%test_module "Search_pattern" = ({ pattern; kmp_array; case_sensitive } : Private.t) ;; - let test_both - ({ pattern; case_sensitive; kmp_array = _ } as expected : Private.t) + let test_both ({ pattern; case_sensitive; kmp_array = _ } as expected : Private.t) = let create_repr = Private.representation (create pattern ~case_sensitive) in let slow_create_repr = slow_create pattern ~case_sensitive in @@ -154,10 +141,7 @@ let%test_module "Search_pattern" = let%expect_test _ = List.iter [%all: bool] ~f:(fun case_sensitive -> test_both - { pattern = "ababab" - ; case_sensitive - ; kmp_array = [| 0; 0; 1; 2; 3; 4 |] - }) + { pattern = "ababab"; case_sensitive; kmp_array = [| 0; 0; 1; 2; 3; 4 |] }) ;; let%expect_test _ = @@ -216,8 +200,7 @@ let%test_module "Search_pattern" = ;; let%expect_test _ = - test_both - { pattern = "aaA"; case_sensitive = false; kmp_array = [| 0; 1; 2 |] } + test_both { pattern = "aaA"; case_sensitive = false; kmp_array = [| 0; 1; 2 |] } ;; let%expect_test _ = @@ -361,6 +344,33 @@ let%test_module "Search_pattern" = (* a doc comment in core_string.mli gives this as an example *) let%test _ = replace_all (create "bc") ~in_:"aabbcc" ~with_:"cb" = "aabcbc" + + let%test _ = + [%compare.equal: string list] + (split_on (create "====") "aa====bbb====c=====d======e========fff") + [ "aa"; "bbb"; "c"; "=d"; "==e"; ""; "fff" ] + ;; + + let%test _ = + [%compare.equal: string list] + (split_on (create "XYXYX") "XYXYXaaXYXYXYXbbXYXYXYXYXYX") + [ ""; "aa"; "YXbb"; "Y"; "" ] + ;; + + let%test _ = + [%compare.equal: string list] + (split_on (create "") "abcd") + (* [index_all (create "")] includes the occurrences at index 0 and at the end of + the string, and the result of [split_on (create "")] is a consequence of this + *) + [ ""; "a"; "b"; "c"; "d"; "" ] + ;; + + let%test _ = + [%compare.equal: string list] + (split_on (create "not present") "here is a string with no matches") + [ "here is a string with no matches" ] + ;; end) ;; @@ -590,12 +600,21 @@ let%test_unit _ = ~expect:(List.rev [ 0, 'h'; 1, 'e'; 2, 'l'; 3, 'l'; 4, 'o' ]) ;; +let%expect_test "iteri" = + iteri "hello" ~f:(fun i ch -> printf "%d%c " i ch); + [%expect {| 0h 1e 2l 3l 4o |}] +;; + let%test_unit _ = [%test_result: t] (filter "hello" ~f:(Char.( <> ) 'h')) ~expect:"ello" let%test_unit _ = [%test_result: t] (filter "hello" ~f:(Char.( <> ) 'l')) ~expect:"heo" let%test_unit _ = [%test_result: t] (filter "hello" ~f:(fun _ -> false)) ~expect:"" let%test_unit _ = [%test_result: t] (filter "hello" ~f:(fun _ -> true)) ~expect:"hello" let%test_unit _ = + [%test_result: t] (filteri "hello" ~f:(fun i _ -> Int.(i % 2 = 0))) ~expect:"hlo" +;; + +let%test_unit _ = let s = "hello" in [%test_result: bool] ~expect:true (phys_equal (filter s ~f:(fun _ -> true)) s) ;; @@ -635,13 +654,6 @@ let%test_module "Hash" = let%test _ = of_char_list [ 'a'; 'b'; 'c' ] = "abc" let%test _ = of_char_list [] = "" -let%expect_test "mem does not allocate" = - let string = Sys.opaque_identity "abracadabra" in - let char = Sys.opaque_identity 'd' in - require_no_allocation [%here] (fun () -> ignore (String.mem string char : bool)); - [%expect {||}] -;; - let%expect_test "is_substring_at" = let string = "lorem ipsum dolor sit amet" in let test pos substring = @@ -992,7 +1004,6 @@ let%test_module "Escaping" = let%test_unit _ = [%test_result: bool] (is "___" 1) ~expect:false let%test_unit _ = [%test_result: bool] (is "___" 2) ~expect:true (* considered escaping, though there's nothing to escape *) - let%test_unit _ = [%test_result: bool] (is "a_b__c" 0) ~expect:false let%test_unit _ = [%test_result: bool] (is "a_b__c" 1) ~expect:true let%test_unit _ = [%test_result: bool] (is "a_b__c" 2) ~expect:false @@ -1019,14 +1030,8 @@ let%test_module "Escaping" = let is_char_literal = is_char_literal ~escape_char:'_' let%test_unit _ = [%test_result: bool] (is_char_literal "123456" 4) ~expect:true - - let%test_unit _ = - [%test_result: bool] (is_char_literal "12345_6" 6) ~expect:false - ;; - - let%test_unit _ = - [%test_result: bool] (is_char_literal "12345_6" 5) ~expect:false - ;; + let%test_unit _ = [%test_result: bool] (is_char_literal "12345_6" 6) ~expect:false + let%test_unit _ = [%test_result: bool] (is_char_literal "12345_6" 5) ~expect:false let%test_unit _ = [%test_result: bool] (is_char_literal "123__456" 4) ~expect:false @@ -1044,9 +1049,7 @@ let%test_module "Escaping" = [%test_result: bool] (is_char_literal "__123456" 0) ~expect:false ;; - let%test_unit _ = - [%test_result: bool] (is_char_literal "__123456" 2) ~expect:true - ;; + let%test_unit _ = [%test_result: bool] (is_char_literal "__123456" 2) ~expect:true end) ;; @@ -1081,13 +1084,8 @@ let%test_module "Escaping" = [%test_result: int option] (f "123456_37839" 9 '3') ~expect:(Some 2) ;; - let%test_unit _ = - [%test_result: int option] (f "123_2321" 6 '2') ~expect:(Some 6) - ;; - - let%test_unit _ = - [%test_result: int option] (f "123_2321" 5 '2') ~expect:(Some 1) - ;; + let%test_unit _ = [%test_result: int option] (f "123_2321" 6 '2') ~expect:(Some 6) + let%test_unit _ = [%test_result: int option] (f "123_2321" 5 '2') ~expect:(Some 1) let%test_unit _ = [%test_result: int option] (rindex "" ~escape_char:'_' 'x') ~expect:None @@ -1237,9 +1235,6 @@ let%test_module "Escaping" = ;; let%test _ = lstrip_literal ~drop:Char.is_alpha ~escape_char:'b' "foo boar" = " boar" - - let%test _ = - rstrip_literal ~drop:Char.is_alpha ~escape_char:'b' "foo boar" = "foo bo" - ;; + let%test _ = rstrip_literal ~drop:Char.is_alpha ~escape_char:'b' "foo boar" = "foo bo" end) ;; diff --git a/test/test_type_equal.ml b/test/test_type_equal.ml index 4be458f..540e089 100644 --- a/test/test_type_equal.ml +++ b/test/test_type_equal.ml @@ -21,10 +21,6 @@ let%test_module "Type_equal.Id" = let%test _ = Option.is_none (same_witness t1 t2) let%test_unit _ = ignore (same_witness_exn t1 t1 : (_, _) Type_equal.equal) let%test _ = Result.is_error (Result.try_with (fun () -> same_witness_exn t1 t2)) - - let%expect_test "to_sexp allocation" = - require_no_allocation [%here] (fun () -> ignore (to_sexp t1 : 'a -> Sexp.t)) - ;; end) ;; diff --git a/test/test_uchar.ml b/test/test_uchar.ml index fa89632..6e0d751 100644 --- a/test/test_uchar.ml +++ b/test/test_uchar.ml @@ -87,3 +87,44 @@ let%test_module "test_compare" = let%test _ = Uchar.(compare max_value min_value) = 1 end) ;; + +let%expect_test "utf8_byte_length" = + let test codepoint = + let uchar = Uchar.of_scalar_exn codepoint in + let utf8 = + let buf = Buffer.create 4 in + Uutf.Buffer.add_utf_8 buf uchar; + Buffer.contents buf + in + let computed_byte_length = Uchar.utf8_byte_length uchar in + if computed_byte_length <> String.length utf8 + then + print_cr + [%here] + [%message + "utf8_byte_length does not match encoded string" + (computed_byte_length : int) + ~actual_byte_length:(String.length utf8 : int) + (utf8 : string)] + else print_s [%sexp (computed_byte_length : int)] + in + test (Char.to_int 'A'); + [%expect {| 1 |}]; + test (* Copyright symbol *) 0x00a9; + [%expect {| 2 |}]; + test (* Check mark *) 0x2713; + [%expect {| 3 |}]; + test (* Cuneiform Sign A *) 0x12000; + [%expect {| 4 |}]; + (* Sanity check: all of ASCII fits in one byte *) + for i = 0 to 127 do + let char = Char.of_int_exn i in + require_equal + [%here] + (module Int) + Uchar.(utf8_byte_length (of_char char)) + 1 + ~if_false_then_print_s:(lazy [%message "counterexample" (char : char)]) + done; + [%expect {| |}] +;; diff --git a/test/test_uniform_array.ml b/test/test_uniform_array.ml index 8428679..a037273 100644 --- a/test/test_uniform_array.ml +++ b/test/test_uniform_array.ml @@ -44,7 +44,8 @@ let%test_unit _ = assert (Poly.equal (Caml.Obj.repr f) (get t 0)) ;; -(* [get], [unsafe_get], [set], [unsafe_set], [unsafe_set_assuming_currently_int] *) +(* [get], [unsafe_get], [set], [unsafe_set], [unsafe_set_assuming_currently_int], + [set_with_caml_modify] *) let%test_unit _ = let t = create_obj_array ~len:1 in assert (length t = 1); @@ -60,7 +61,9 @@ let%test_unit _ = unsafe_set t 0 zero_obj; check_get zero_obj; unsafe_set_assuming_currently_int t 0 one_obj; - check_get one_obj + check_get one_obj; + set_with_caml_modify t 0 zero_obj; + check_get zero_obj ;; let%expect_test "exists" = @@ -74,6 +77,17 @@ let%expect_test "exists" = [%expect {| |}] ;; +let%expect_test "for_all" = + let test arr f = of_list arr |> for_all ~f in + let r here = require_equal here (module Bool) in + r [%here] true (test [] Fn.id); + r [%here] true (test [ true ] Fn.id); + r [%here] false (test [ false; false; false; false; true ] Fn.id); + r [%here] false (test [ 0; 1; 2; 3; 4 ] (fun i -> i % 2 = 1)); + r [%here] true (test [ 0; 2; 4; 6; 8 ] (fun i -> i % 2 = 0)); + [%expect {| |}] +;; + let%expect_test "iteri" = let test arr = of_list arr |> iteri ~f:(printf "(%d %c)") in test []; @@ -108,3 +122,16 @@ let%expect_test "map2_exn" = require_does_raise [%here] (fun () -> test [ 1 ] [] (fun _ _ -> 0)); [%expect {| (Invalid_argument Array.map2_exn) |}] ;; + +let%expect_test "mapi" = + let test arr = + let mapped = of_list arr |> mapi ~f:(fun i str -> i, String.capitalize str) in + print_s [%sexp (mapped : (int * string) t)] + in + test []; + [%expect {| () |}]; + test [ "foo"; "bar" ]; + [%expect {| + ((0 Foo) + (1 Bar)) |}] +;; diff --git a/test/test_validate.ml b/test/test_validate.ml deleted file mode 100644 index 51d9fb2..0000000 --- a/test/test_validate.ml +++ /dev/null @@ -1,90 +0,0 @@ -open! Import -open! Validate - -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)) -;; diff --git a/test/validate_fields_folder.mlt b/test/validate_fields_folder.mlt deleted file mode 100644 index d85ac52..0000000 --- a/test/validate_fields_folder.mlt +++ /dev/null @@ -1,102 +0,0 @@ -open! 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 t f 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 t f 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 t field check :: 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 t field check :: acc in - Fields.fold ~init:[] ~a:(w (fun _ -> Validate.pass)) |> Validate.of_list - ;; -end - -[%%expect {| -|}] |