v0.18~preview.130.05+548

composition_infix/README.md

@@ -0,0 +1,2 @@
+A single-module library for defining infix composition operators `<<`
+and `>>`.

composition_infix/src/composition_infix.ml

@@ -0,0 +1,2 @@
+let ( >> ) f g x = g (f x)
+let ( << ) f g x = f (g x)

composition_infix/src/composition_infix.mli

@@ -0,0 +1,7 @@
+(** Infix composition operators.
+
+    - [ a |> (f >> g) = a |> f |> g ]
+    - [ (f << g) a = f (g a) ] *)
+
+val ( >> ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c
+val ( << ) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c

composition_infix/src/dune

@@ -0,0 +1,5 @@
+(library
+ (name composition_infix)
+ (public_name base.composition_infix)
+ (preprocess no_preprocessing)
+ (libraries))

lint/ppx_base_lint.ml

@@ -181,9 +181,10 @@ let () =
       | { pstr_loc = loc; _ } :: _ as st ->
         (check (module_of_loc loc))#structure st;
         st)
-    ~intf:(function
-      | [] -> []
-      | { psig_loc = loc; _ } :: _ as sg ->
+    ~intf:(fun sg ->
+      match sg.psg_items with
+      | [] -> sg
+      | { psig_loc = loc; _ } :: _ ->
         (check (module_of_loc loc))#signature sg;
         sg)
 ;;

ppx/src/ppx_base_internal.ml

@@ -3,7 +3,7 @@ open Ppxlib
 
 module Specialize_polymorphic_compare = struct
   let signature ~loc =
-    [%sig:
+    [%sigil:
       [@@@ocaml.ppwarning "ppx_base_internal: intended only for use inside Base"]
 
       external ( = ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%equal"

src/comparable_intf.ml

@@ -75,7 +75,9 @@ module type With_zero = sig
 end
 
 module type S = sig
-  include Comparisons
+  type t
+
+  include Comparisons with type t := t
 
   (** [ascending] is identical to [compare]. [descending x y = ascending y x].  These are
       intended to be mnemonic when used like [List.sort ~compare:ascending] and [List.sort

src/comparisons.ml

@@ -2,8 +2,8 @@
 
 open! Import
 
-(** [Infix] lists the typical infix comparison operators.  These functions are provided by
-    [<M>.O] modules, i.e., modules that expose monomorphic infix comparisons over some
+(** [Infix] lists the typical infix comparison operators. These functions are provided
+    by [<M>.O] modules, i.e., modules that expose monomorphic infix comparisons over some
     [<M>.t]. *)
 module type Infix = sig
   type t

src/dictionary_immutable_intf.ml

@@ -284,6 +284,17 @@ module Definitions = struct
           , 'phantom )
           transformer
 
+    (** Like [update]. Returns the new value. *)
+    val update_and_return
+      : ( ('key, 'data, 'phantom) t
+          -> 'key key
+          -> f:('data option -> 'data)
+          -> 'data * ('key, 'data, 'phantom) t
+          , 'key
+          , 'data
+          , 'phantom )
+          transformer
+
     (** Adds [data] to the existing key/value pair for [key]. Interprets a missing key as
         having an empty list. *)
     val add_multi

src/hash_set.ml

@@ -14,6 +14,7 @@ module Accessors = struct
   let hashable = hashable
   let clear = Hashtbl.clear
   let length = Hashtbl.length
+  let capacity = Hashtbl.capacity
   let mem = Hashtbl.mem
   let is_empty t = Hashtbl.is_empty t
 

src/hash_set_intf.ml

@@ -40,6 +40,7 @@ module type Accessors = sig
   val diff : 'a t -> 'a t -> 'a t
   val of_hashtbl_keys : ('a, _) Hashtbl.t -> 'a t
   val to_hashtbl : 'key t -> f:('key -> 'data) -> ('key, 'data) Hashtbl.t
+  val capacity : _ t -> int
 end
 
 type ('key, 'z) create_options = ('key, unit, 'z) Hashtbl_intf.create_options

src/int.ml

@@ -346,6 +346,14 @@ include O
 
 (* [Int] and [Int.O] agree value-wise *)
 
+module Summable = struct
+  type nonrec t = t
+
+  let zero = zero
+  let[@inline] ( + ) x y = x + y
+  let[@inline] ( - ) x y = x - y
+end
+
 module Private = struct
   module O_F = O.F
 end

src/int32.ml

@@ -332,3 +332,11 @@ end
 include O
 
 (* [Int32] and [Int32.O] agree value-wise *)
+
+module Summable = struct
+  type nonrec t = t
+
+  let zero = zero
+  let[@inline] ( + ) x y = x + y
+  let[@inline] ( - ) x y = x - y
+end

src/int63_emul.ml

@@ -483,6 +483,14 @@ include Int_string_conversions.Make_binary (struct
 
 (* [Int63] and [Int63.O] agree value-wise *)
 
+module Summable = struct
+  type nonrec t = t
+
+  let zero = zero
+  let[@inline] ( + ) x y = x + y
+  let[@inline] ( - ) x y = x - y
+end
+
 module Repr = struct
   type emulated = t
 

src/int64.ml

@@ -60,7 +60,6 @@ let pred = pred
 let succ = succ
 let pow = Int_math.Private.int64_pow
 let rem = rem
-let neg = neg
 let minus_one = minus_one
 let one = one
 let zero = zero
@@ -168,19 +167,82 @@ let of_nativeint_exn = of_nativeint
 let to_nativeint = Conv.int64_to_nativeint
 let to_nativeint_exn = Conv.int64_to_nativeint_exn
 
+module Pre_O = struct
+  external ( + ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_add"
+  external ( - ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_sub"
+  external ( * ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_mul"
+  external ( / ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_div"
+  external ( ~- ) : (t[@local_opt]) -> (t[@local_opt]) = "%int64_neg"
+
+  let ( ** ) = ( ** )
+
+  include Int64_replace_polymorphic_compare
+
+  let abs = abs
+
+  external neg : (t[@local_opt]) -> (t[@local_opt]) = "%int64_neg"
+
+  let zero = zero
+  let of_int_exn = of_int_exn
+end
+
+module O = struct
+  include Pre_O
+
+  include Int_math.Make (struct
+      type nonrec t = t
+
+      include Pre_O
+
+      let rem = rem
+      let to_float = to_float
+      let of_float = of_float
+      let of_string = T.of_string
+      let to_string = T.to_string
+    end)
+
+  external ( land ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_and"
+  external ( lor ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_or"
+  external ( lxor ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_xor"
+
+  let lnot = bit_not
+
+  external ( lsl )
+    :  (t[@local_opt])
+    -> (int[@local_opt])
+    -> (t[@local_opt])
+    = "%int64_lsl"
+
+  external ( asr )
+    :  (t[@local_opt])
+    -> (int[@local_opt])
+    -> (t[@local_opt])
+    = "%int64_asr"
+
+  external ( lsr )
+    :  (t[@local_opt])
+    -> (int[@local_opt])
+    -> (t[@local_opt])
+    = "%int64_lsr"
+end
+
+include O
+
 module Pow2 = struct
   open! Import
   open Int64_replace_polymorphic_compare
 
-  let raise_s = Error.raise_s
+  open struct
+    let raise_s = Error.raise_s
 
-  let non_positive_argument () =
-    Printf.invalid_argf "argument must be strictly positive" ()
-  ;;
+    let non_positive_argument () =
+      Printf.invalid_argf "argument must be strictly positive" ()
+    ;;
 
-  let ( lor ) = Stdlib.Int64.logor
-  let ( lsr ) = Stdlib.Int64.shift_right_logical
-  let ( land ) = Stdlib.Int64.logand
+    let ( lor ) = Stdlib.Int64.logor
+    let ( lsr ) = Stdlib.Int64.shift_right_logical
+    let ( land ) = Stdlib.Int64.logand
+  end
 
   (** "ceiling power of 2" - Least power of 2 greater than or equal to x. *)
   let ceil_pow2 x =
@@ -296,69 +358,16 @@ include Pretty_printer.Register (struct
     let module_name = "Base.Int64"
   end)
 
-module Pre_O = struct
-  external ( + ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_add"
-  external ( - ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_sub"
-  external ( * ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_mul"
-  external ( / ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_div"
-  external ( ~- ) : (t[@local_opt]) -> (t[@local_opt]) = "%int64_neg"
-
-  let ( ** ) = ( ** )
-
-  include Int64_replace_polymorphic_compare
-
-  let abs = abs
+(* [Int64] and [Int64.O] agree value-wise *)
 
-  external neg : (t[@local_opt]) -> (t[@local_opt]) = "%int64_neg"
+module Summable = struct
+  type nonrec t = t
 
   let zero = zero
-  let of_int_exn = of_int_exn
+  let[@inline] ( + ) x y = x + y
+  let[@inline] ( - ) x y = x - y
 end
 
-module O = struct
-  include Pre_O
-
-  include Int_math.Make (struct
-      type nonrec t = t
-
-      include Pre_O
-
-      let rem = rem
-      let to_float = to_float
-      let of_float = of_float
-      let of_string = T.of_string
-      let to_string = T.to_string
-    end)
-
-  external ( land ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_and"
-  external ( lor ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_or"
-  external ( lxor ) : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) = "%int64_xor"
-
-  let lnot = bit_not
-
-  external ( lsl )
-    :  (t[@local_opt])
-    -> (int[@local_opt])
-    -> (t[@local_opt])
-    = "%int64_lsl"
-
-  external ( asr )
-    :  (t[@local_opt])
-    -> (int[@local_opt])
-    -> (t[@local_opt])
-    = "%int64_asr"
-
-  external ( lsr )
-    :  (t[@local_opt])
-    -> (int[@local_opt])
-    -> (t[@local_opt])
-    = "%int64_lsr"
-end
-
-include O
-
-(* [Int64] and [Int64.O] agree value-wise *)
-
 (* Include type-specific [Replace_polymorphic_compare] at the end, after
    including functor application that could shadow its definitions. This is
    here so that efficient versions of the comparison functions are exported by

src/int_conversions.ml

@@ -71,14 +71,10 @@ let int32_to_int_exn x =
 
 (* int <-> int64 *)
 
-let[@cold] [@inline never] [@local never] [@specialise never] int64_to_int_failure x =
-  convert_failure
-    (Stdlib.Int64.add
-       (globalize_int64 x)
-       0L (* force int64 boxing to be here under flambda2 *))
-    "int64"
-    "int"
-    int64_to_string
+let[@cold] [@inline never] [@local never] [@specialise never] [@zero_alloc] int64_to_int_failure
+  x
+  =
+  convert_failure x "int64" "int" int64_to_string
 ;;
 
 let () = assert (num_bits_int < num_bits_int64)
@@ -96,7 +92,15 @@ 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 (
+    let x =
+      Stdlib.Int64.add
+        (globalize_int64 x)
+        0L (* force int64 boxing to be here under flambda2 *)
+    in
+    int64_to_int_failure x)
 ;;
 
 (* int <-> nativeint *)

src/int_intf.ml

@@ -249,6 +249,14 @@ module type S_common = sig
       The result is unspecified if the argument is nan or falls outside the range
       of representable integers. *)
   val of_float_unchecked : float -> t
+
+  module Summable : sig
+    type nonrec t = t
+
+    val zero : t
+    val ( + ) : t -> t -> t
+    val ( - ) : t -> t -> t
+  end
 end
 
 module type Operators_unbounded = sig