feat: add CCAtomic.update_cas

Patch CBor round-trip QCheck test to hold for nan's too

.github/workflows/format.yml

@@ -0,0 +1,28 @@
+name: format
+
+on:
+  push:
+    branches:
+      - main
+  pull_request:
+
+jobs:
+  format:
+    name: format
+    strategy:
+      matrix:
+        ocaml-compiler:
+            - '5.3'
+    runs-on: 'ubuntu-latest'
+    steps:
+      - uses: actions/checkout@main
+      - name: Use OCaml ${{ matrix.ocaml-compiler }}
+        uses: ocaml/setup-ocaml@v3
+        with:
+          ocaml-compiler: ${{ matrix.ocaml-compiler }}
+          dune-cache: true
+          allow-prerelease-opam: true
+
+      - run: opam install ocamlformat.0.27.0
+      - run: opam exec -- make format-check
+

.github/workflows/gh-pages.yml

@@ -13,9 +13,9 @@ jobs:
       - uses: actions/checkout@main
 
       - name: Use OCaml
-        uses: ocaml/setup-ocaml@v2
+        uses: ocaml/setup-ocaml@v3
         with:
-          ocaml-compiler: '4.14'
+          ocaml-compiler: '5.2'
           dune-cache: false
 
       - name: Deps

.github/workflows/main.yml

@@ -19,14 +19,14 @@ jobs:
             - '4.08'
             - '4.10'
             - '4.14'
-            - '5.2'
+            - '5.3'
             - 'ocaml-variants.5.0.0+options,ocaml-option-bytecode-only'
 
     runs-on: ${{ matrix.os }}
     steps:
       - uses: actions/checkout@main
       - name: Use OCaml ${{ matrix.ocaml-compiler }}
-        uses: ocaml/setup-ocaml@v2
+        uses: ocaml/setup-ocaml@v3
         with:
           ocaml-compiler: ${{ matrix.ocaml-compiler }}
           dune-cache: true
@@ -52,7 +52,7 @@ jobs:
     steps:
       - uses: actions/checkout@main
       - name: Use OCaml ${{ matrix.ocaml-compiler }}
-        uses: ocaml/setup-ocaml@v2
+        uses: ocaml/setup-ocaml@v3
         with:
           ocaml-compiler: ${{ matrix.ocaml-compiler }}
           dune-cache: true
@@ -62,23 +62,3 @@ jobs:
           opam install containers-data --deps-only  # no test deps
       - run: opam exec -- dune build '@install'
       - run: opam exec -- dune runtest -j 1 -p containers --profile=release # test only core on non-ubuntu platform
-
-  format:
-    name: format
-    strategy:
-      matrix:
-        ocaml-compiler:
-            - '5.1'
-    runs-on: 'ubuntu-latest'
-    steps:
-      - uses: actions/checkout@main
-      - name: Use OCaml ${{ matrix.ocaml-compiler }}
-        uses: ocaml/setup-ocaml@v2
-        with:
-          ocaml-compiler: ${{ matrix.ocaml-compiler }}
-          dune-cache: true
-          allow-prerelease-opam: true
-
-      - run: opam install ocamlformat.0.24.1
-      - run: opam exec -- make format-check
-

.ocamlformat

@@ -1,4 +1,4 @@
-version = 0.24.1
+version = 0.27.0
 profile=conventional
 margin=80
 if-then-else=k-r
@@ -12,3 +12,4 @@ field-space=tight-decl
 leading-nested-match-parens=true
 module-item-spacing=compact
 quiet=true
+parse-docstrings=false

CHANGELOG.md

@@ -1,6 +1,17 @@
-# Changelog
 
-## main
+## 3.16
+
+
+- breaking: Renamed predicate parameter of `take_while`, `rtake_while` from `p` to `f`, aligining it with pre-existing `drop_while`.
+
+- feat: add `containers.leb128` library
+- feat: add `CCFun.with_return`
+- Added functions to the `Char` module to check common character properties.
+- feat: add `CCVector.findi`
+
+
+- fix: compat with OCaml 5.4
+- fix: oob(!!) in CCHash.bytes
 
 ## 3.15
 

benchs/ref_impl.ml

@@ -128,8 +128,9 @@ module PersistentHashtbl (H : Hashtbl.HashedType) = struct
       t := Add (k, v', t');
       Table.remove tbl k;
       t'
-    with Not_found -> (* not member, nothing to do *)
+    with Not_found ->
-                      t
+      (* not member, nothing to do *)
+      t
 
   (*$R
     let h = H.of_seq my_seq in

benchs/run_benchs.ml

@@ -97,6 +97,14 @@ module L = struct
     else
       Sek.Persistent.of_list 0 [ x; x + 1; x + 2; x + 3 ]
 
+  let f_pvec x =
+    if x mod 10 = 0 then
+      Pvec.empty
+    else if x mod 5 = 1 then
+      Pvec.of_list [ x; x + 1 ]
+    else
+      Pvec.of_list [ x; x + 1; x + 2; x + 3 ]
+
   let flat_map_kont f l =
     let rec aux f l kont =
       match l with
@@ -118,6 +126,7 @@ module L = struct
     let l = CCList.(1 -- n) in
     let ral = CCRAL.of_list l in
     let sek = Sek.Persistent.of_list 0 l in
+    let pvec = Pvec.of_list l in
     let flatten_map_ l () =
       ignore @@ Sys.opaque_identity @@ List.flatten (CCList.map f_ l)
     and flatmap_kont l () = ignore @@ Sys.opaque_identity @@ flat_map_kont f_ l
@@ -128,6 +137,8 @@ module L = struct
       ignore @@ Sys.opaque_identity @@ CCRAL.flat_map f_ral_ l
     and flatmap_sek s () =
       ignore @@ Sys.opaque_identity @@ Sek.Persistent.flatten_map 0 f_sek_ s
+    and flat_map_pvec v () =
+      ignore @@ Sys.opaque_identity @@ Pvec.flat_map f_pvec v
     in
     B.throughputN time ~repeat
       [
@@ -137,6 +148,7 @@ module L = struct
         "flatten o map", flatten_map_ l, ();
         "ral_flatmap", flatmap_ral_ ral, ();
         "sek_flatmap", flatmap_sek sek, ();
+        "pvec.flatmap", flat_map_pvec pvec, ();
       ]
 
   (* APPEND *)
@@ -284,7 +296,7 @@ module L = struct
       for i = 0 to n - 1 do
         opaque_ignore (CCRAL.set l i (-i))
       done
-      (* TODO: implement set
+    (* TODO: implement set
          and bench_funvec l () =
            for _i = 0 to n-1 do opaque_ignore (CCFun_vec.set (* TODO *)) done
       *)
@@ -810,8 +822,8 @@ module Tbl = struct
     end in
     (module T)
 
-  let persistent_hashtbl_ref :
+  let persistent_hashtbl_ref : type a.
-      type a. a key_type -> (module MUT with type key = a) =
+      a key_type -> (module MUT with type key = a) =
    fun key ->
     let (module Key), name = arg_make key in
     let module T = Ref_impl.PersistentHashtbl (Key) in

src/codegen/containers_codegen.ml

@@ -108,7 +108,8 @@ module Bitfield = struct
     if self.emit_failure_if_too_wide then
       fpf out
         "(* check that int size is big enough *)@,\
-         @[let () = assert (Sys.int_size >= %d);;@]" (total_width self);
+         @[let () = assert (Sys.int_size >= %d);;@]"
+        (total_width self);
     fpf out "@]"
 
   let gen_mli self : code =

src/core/CCArray.ml

@@ -93,7 +93,7 @@ let sort_indices cmp a =
   Array.sort (fun k1 k2 -> cmp a.(k1) a.(k2)) b;
   b
 
-let sort_ranking cmp a = sort_indices compare (sort_indices cmp a)
+let sort_ranking cmp a = sort_indices CCInt.compare (sort_indices cmp a)
 
 let rev a =
   let b = Array.copy a in

src/core/CCAtomic.ml

@@ -46,3 +46,24 @@ let[@inline never] decr r =
 (* atomic *)
 
 [@@@endif]
+
+(** Update loop with a compare-and-swap, and some basic backoff behavior.
+    [update_cas atomic f] is, in essence,
+    [let res, x = f !atomic in atomic := x; res]
+    done atomically. [f] might be called multiple times and must be as cheap
+    as possible.
+    @since NEXT_RELEASE *)
+let update_cas (type res) (self : 'a t) (f : 'a -> res * 'a) : res =
+  let exception Ret of res in
+  let backoff = ref 1 in
+  try
+    while true do
+      let old_val = get self in
+      let res, new_val = f old_val in
+      if compare_and_set self old_val new_val then raise_notrace (Ret res);
+
+      Containers_domain.relax_loop !backoff;
+      backoff := min 128 (2 * !backoff)
+    done;
+    assert false
+  with Ret r -> r

src/core/CCChar.ml

@@ -23,3 +23,12 @@ module Infix = struct
 end
 
 include Infix
+
+let is_uppercase_ascii c = c > '\064' && c < '\091'
+let is_lowercase_ascii c = c > '\096' && c < '\123'
+
+let is_letter_ascii c =
+  (is_lowercase_ascii [@inlined]) c || (is_uppercase_ascii [@inlined]) c
+
+let is_digit_ascii c = c > '\047' && c < '\058'
+let is_whitespace_ascii c = c = '\032' || (c > '\008' && c < '\014')

src/core/CCChar.mli

@@ -40,6 +40,32 @@ val pp_buf : Buffer.t -> t -> unit
 val pp : Format.formatter -> t -> unit
 (** Renamed from [print] since 2.0. *)
 
+val is_uppercase_ascii : t -> bool
+(** [is_uppercase_ascii c] is true exactly when  [c] is an
+    uppercase ASCII character, i.e. ['\064'] < [c] < ['\091'].
+    @since 3.16 *)
+
+val is_lowercase_ascii : t -> bool
+(** [is_lowercase_ascii c] is true exactly when [c] is a
+    lowercase ASCII character, i.e. ['\096'] < [c] < ['\123'].
+    @since 3.16 *)
+
+val is_letter_ascii : t -> bool
+(** [is_letter_ascii c] is true exactly when [c] is an ASCII
+    letter, i.e. [is_uppercase_ascii c || is_lowercase_ascii c].
+    @since 3.16 *)
+
+val is_digit_ascii : t -> bool
+(** [is_digit_ascii c] is true exactly when [c] is an
+    ASCII digit, i.e. ['\047'] < [c] < ['\058'].
+    @since 3.16 *)
+
+val is_whitespace_ascii : t -> bool
+(** [is_whitespace_ascii c] is true exactly when [c] is an ASCII
+    whitespace character as defined by Unicode, i.e. either [c = ' ']
+    or ['\008'] < [c] < ['\014'].
+    @since 3.16 *)
+
 (** {2 Infix Operators}
 
     @since 3.3 *)

src/core/CCEither.mli

@@ -2,7 +2,7 @@
 
 (** Either Monad
 
-    Module that is compatible with Either form OCaml 4.12 but can be use with any
+    Module that is compatible with Either from OCaml 4.12 but can be use with any
     ocaml version compatible with container
 
     @since 3.2

src/core/CCFun.ml

@@ -61,6 +61,13 @@ let rec iterate n f x =
   else
     iterate (n - 1) f (f x)
 
+let[@inline] with_return (type ret) f : ret =
+  let exception E of ret in
+  let return x = raise_notrace (E x) in
+  match f return with
+  | res -> res
+  | exception E res -> res
+
 module Infix = struct
   (* default implem for some operators *)
   let ( %> ) = compose

src/core/CCFun.mli

@@ -78,6 +78,22 @@ val iterate : int -> ('a -> 'a) -> 'a -> 'a
     [x], [iterate 1 f x] is [f x], [iterate 2 f x] is [f (f x)], etc.
     @since 2.1 *)
 
+val with_return : (('ret -> 'a) -> 'ret) -> 'ret
+(** [with_return f] is [f return], where [return] is a function
+  that can be invoked to exit the scope early.
+
+  For example:
+{[
+let find_array arr x =
+  let@ return = with_return in
+  for i = 0 to Array.length arr-1 do
+    if arr.(i) = x then return i;
+  done;
+  -1
+]}
+
+  @since 3.15 *)
+
 (** {2 Infix}
 
     Infix operators. *)

src/core/CCHash.ml

@@ -77,9 +77,9 @@ let int = hash_int_
 let bool b =
   hash_int_
     (if b then
-      1
+       1
-    else
+     else
-      2)
+       2)
 
 let char x = hash_int_ (Char.code x)
 
@@ -101,7 +101,7 @@ let max_len_b_ = 128
 
 let bytes (x : bytes) =
   let h = ref fnv_offset_basis in
-  for i = 0 to min max_len_b_ (Bytes.length x) do
+  for i = 0 to min max_len_b_ (Bytes.length x - 1) do
     (h := Int64.(mul !h fnv_prime));
     let byte = Char.code (Bytes.unsafe_get x i) in
     h := Int64.(logxor !h (of_int byte))

src/core/CCList.mli

@@ -248,7 +248,7 @@ val partition_map :
   ('a -> [< `Left of 'b | `Right of 'c | `Drop ]) ->
   'a list ->
   'b list * 'c list
-  [@@ocaml.deprecated "use CCList.partition_filter_map instead"]
+[@@ocaml.deprecated "use CCList.partition_filter_map instead"]
 (** @deprecated use {!partition_filter_map} instead
     @since 0.11 *)
 
@@ -384,7 +384,7 @@ val mguard : bool -> unit t
     @since 3.1 *)
 
 val return : 'a -> 'a t
-(** [return x] is [x]. *)
+(** [return x] is [[x]]. *)
 
 val take : int -> 'a t -> 'a t
 (** [take n l] takes the [n] first elements of the list [l], drop the rest. *)

src/core/CCListLabels.mli

@@ -281,7 +281,7 @@ val partition_map :
   f:('a -> [< `Left of 'b | `Right of 'c | `Drop ]) ->
   'a list ->
   'b list * 'c list
-  [@@ocaml.deprecated "use CCList.partition_filter_map instead"]
+[@@ocaml.deprecated "use CCList.partition_filter_map instead"]
 (** @deprecated use {!partition_filter_map} instead *)
 
 val group_by : ?hash:('a -> int) -> ?eq:('a -> 'a -> bool) -> 'a t -> 'a list t

src/core/CCOption.mli

@@ -107,7 +107,7 @@ val value : 'a t -> default:'a -> 'a
     @since 2.8 *)
 
 val get_exn : 'a t -> 'a
-  [@@ocaml.deprecated "use CCOption.get_exn_or instead"]
+[@@ocaml.deprecated "use CCOption.get_exn_or instead"]
 (** [get_exn o] returns [x] if [o] is [Some x] or fails if [o] is [None].
     @raise Invalid_argument if the option is [None].
     @deprecated use {!get_exn_or} instead

src/core/CCOrd.mli

@@ -13,7 +13,7 @@ val poly : 'a t
     @since 3.6 *)
 
 val compare : 'a t
-  [@@deprecated "use CCOrd.poly instead, this name is too general"]
+[@@deprecated "use CCOrd.poly instead, this name is too general"]
 (** Polymorphic "magic" comparison.
     @deprecated since 3.6 in favor of {!poly}. The reason is that
     [compare] is easily shadowed, can shadow other comparators, and is just

src/core/CCParse.mli

@@ -404,7 +404,7 @@ val optional : _ t -> unit t
     @since 3.6 *)
 
 val try_ : 'a t -> 'a t
-  [@@deprecated "plays no role anymore, just replace [try foo] with [foo]"]
+[@@deprecated "plays no role anymore, just replace [try foo] with [foo]"]
 (** [try_ p] is just like [p] (it used to play a role in backtracking
     semantics but no more).
 

src/core/CCSeq.mli

@@ -183,7 +183,7 @@ val ( -- ) : int -> int -> int t
     [a] and [b] (therefore, never empty). *)
 
 val ( --^ ) : int -> int -> int t
-(** [a -- b] is the integer range from [a] to [b], where [b] is excluded. *)
+(** [a --^ b] is the integer range from [a] to [b], where [b] is excluded. *)
 
 (** {2 Operations on two Collections} *)
 

src/core/CCString.ml

@@ -585,6 +585,24 @@ let take n s =
   else
     s
 
+let take_while f s =
+  let i = ref 0 in
+  while !i < String.length s && f (String.unsafe_get s !i) do
+    incr i
+  done;
+  String.sub s 0 !i
+
+let rtake_while f s =
+  let s_len_pred = String.length s - 1 in
+  let i = ref s_len_pred in
+  while !i >= 0 && f (String.unsafe_get s !i) do
+    decr i
+  done;
+  if !i < s_len_pred then
+    String.sub s (!i + 1) (s_len_pred - !i)
+  else
+    ""
+
 let drop n s =
   if n < String.length s then
     String.sub s n (String.length s - n)

src/core/CCString.mli

@@ -182,6 +182,16 @@ val take : int -> string -> string
 (** [take n s] keeps only the [n] first chars of [s].
     @since 0.17 *)
 
+val take_while : (char -> bool) -> string -> string
+(** [take_while f s] keeps only the longest prefix [t] of [s] such that every
+    character [c] in [t] satisfies [f c].
+    @since 3.16 *)
+
+val rtake_while : (char -> bool) -> string -> string
+(** [rtake_while f s] keeps only the longest suffix [t] of [s] such that every
+    character [c] in [t] satisfies [f c].
+    @since 3.16 *)
+
 val drop : int -> string -> string
 (** [drop n s] removes the [n] first chars of [s].
     @since 0.17 *)

src/core/CCStringLabels.mli

@@ -193,6 +193,16 @@ val take : int -> string -> string
 (** [take n s] keeps only the [n] first chars of [s].
     @since 0.17 *)
 
+val take_while : f:(char -> bool) -> string -> string
+(** [take_while ~f s] keeps only the longest prefix [t] of [s] such that every
+    character [c] in [t] satisfies [f c].
+    @since 3.16 *)
+
+val rtake_while : f:(char -> bool) -> string -> string
+(** [rtake_while ~f s] keeps only the longest suffix [t] of [s] such that every
+    character [c] in [t] satisfies [f c].
+    @since 3.16 *)
+
 val drop : int -> string -> string
 (** [drop n s] removes the [n] first chars of [s].
     @since 0.17 *)

src/core/CCUtf8_string.ml

@@ -65,8 +65,10 @@ let next_ (type a) (st : Dec.t) ~(yield : uchar -> a) ~(stop : unit -> a) () : a
       (* except for first, each char gives 6 bits *)
       let next = (acc lsl 6) lor (c land 0b111111) in
       if j = n_bytes then
-        if (* done reading the codepoint *)
+        if
-           Uchar.is_valid next then (
+          (* done reading the codepoint *)
+          Uchar.is_valid next
+        then (
           st.i <- st.i + j + 1;
           (* +1 for first char *)
           yield (Uchar.unsafe_of_int next)

src/core/CCVector.ml

@@ -475,7 +475,7 @@ let for_all p v =
 
 let member ~eq x v = exists (eq x) v
 
-let find_internal_ p v =
+let find_internal_i_ p v =
   let n = v.size in
   let rec check i =
     if i = n then
@@ -483,15 +483,18 @@ let find_internal_ p v =
     else (
       let x = v.vec.(i) in
       if p x then
-        x
+        i, x
       else
         check (i + 1)
     )
   in
   check 0
 
-let find_exn p v = try find_internal_ p v with Not_found -> raise Not_found
+let find_exn p v =
-let find p v = try Some (find_internal_ p v) with Not_found -> None
+  try snd (find_internal_i_ p v) with Not_found -> raise Not_found
+
+let find p v = try Some (snd @@ find_internal_i_ p v) with Not_found -> None
+let findi p v = try Some (find_internal_i_ p v) with Not_found -> None
 
 let find_map f v =
   let n = v.size in

src/core/CCVector.mli

@@ -220,6 +220,10 @@ val for_all : ('a -> bool) -> ('a, _) t -> bool
 val find : ('a -> bool) -> ('a, _) t -> 'a option
 (** Find an element that satisfies the predicate. *)
 
+val findi : ('a -> bool) -> ('a, _) t -> (int * 'a) option
+(** Find an element and its index that satisfies the predicate.
+    @since 3.15 *)
+
 val find_exn : ('a -> bool) -> ('a, _) t -> 'a
 (** Find an element that satisfies the predicate, or
     @raise Not_found if no element does. *)

src/core/dune

@@ -6,7 +6,7 @@
   (action
    (run %{project_root}/src/core/cpp/cpp.exe %{input-file})))
  (flags :standard -nolabels -open CCMonomorphic)
- (libraries either containers.monomorphic))
+ (libraries either containers.monomorphic containers.domain))
 
 (ocamllex
  (modules CCSexp_lex))

src/data/CCBV.ml

@@ -407,9 +407,9 @@ let pp out bv =
   iter bv (fun _i b ->
       Format.pp_print_char out
         (if b then
-          '1'
+           '1'
-        else
+         else
-          '0'));
+           '0'));
   Format.pp_print_string out "}"
 
 module Internal_ = struct

src/data/CCFQueue.ml

@@ -37,8 +37,7 @@ let _empty = Shallow Zero
 let _single x = Shallow (One x)
 let _double x y = Shallow (Two (x, y))
 
-let _deep :
+let _deep : type l0 l1.
-    type l0 l1.
     int ->
     ('a, l0 succ) digit ->
     ('a * 'a) t lazy_t ->

src/data/CCFQueue.mli

@@ -139,7 +139,7 @@ val ( -- ) : int -> int -> int t
     @since 0.10 *)
 
 val ( --^ ) : int -> int -> int t
-(** [a -- b] is the integer range from [a] to [b], where [b] is excluded.
+(** [a --^ b] is the integer range from [a] to [b], where [b] is excluded.
     @since 0.17 *)
 
 val pp : 'a printer -> 'a t printer

src/data/CCGraph.ml

@@ -221,8 +221,7 @@ module Traverse = struct
       ]
 
     type ('v, 'e) t =
-      [ `Enter of
+      [ `Enter of 'v * int * ('v, 'e) path
-        'v * int * ('v, 'e) path
         (* unique index in traversal, path from start *)
       | `Exit of 'v
       | `Edge of 'v * 'e * 'v * edge_kind

src/data/CCGraph.mli

@@ -150,8 +150,7 @@ module Traverse : sig
       ]
 
     type ('v, 'e) t =
-      [ `Enter of
+      [ `Enter of 'v * int * ('v, 'e) path
-        'v * int * ('v, 'e) path
         (* unique index in traversal, path from start *)
       | `Exit of 'v
       | `Edge of 'v * 'e * 'v * edge_kind

src/data/CCHashTrie.ml

@@ -199,11 +199,13 @@ module A_SPARSE = struct
       arr.(real_idx) <- x;
       if real_idx > 0 then Array.blit a.arr 0 arr 0 real_idx;
       (if real_idx < n then
-        let open Stdlib in
+         let open Stdlib in
-        Array.blit a.arr real_idx arr (real_idx + 1) (n - real_idx));
+         Array.blit a.arr real_idx arr (real_idx + 1) (n - real_idx));
       { a with bits; arr }
-    ) else if (* replace element at [real_idx] *)
+    ) else if
-              mut then (
+        (* replace element at [real_idx] *)
+        mut
+      then (
       a.arr.(real_idx) <- x;
       a
     ) else (
@@ -230,8 +232,8 @@ module A_SPARSE = struct
       let arr = Array.make Stdlib.(n + 1) x in
       if real_idx > 0 then Array.blit a.arr 0 arr 0 real_idx;
       (if real_idx < n then
-        let open Stdlib in
+         let open Stdlib in
-        Array.blit a.arr real_idx arr (real_idx + 1) (n - real_idx));
+         Array.blit a.arr real_idx arr (real_idx + 1) (n - real_idx));
       { a with bits; arr }
     ) else (
       let x = f a.arr.(real_idx) in

src/data/CCKTree.ml

@@ -66,11 +66,10 @@ let rec cut_depth n t () =
 (** {2 Graph Traversals} *)
 
 (** Abstract Set structure *)
-class type ['a] pset =
+class type ['a] pset = object
-  object
+  method add : 'a -> 'a pset
-    method add : 'a -> 'a pset
+  method mem : 'a -> bool
-    method mem : 'a -> bool
+end
-  end
 
 let set_of_cmp (type elt) ~cmp () =
   let module S = Set.Make (struct

src/data/CCKTree.mli

@@ -49,11 +49,10 @@ val cut_depth : int -> 'a t -> 'a t
 (** {2 Graph Traversals} *)
 
 (** Abstract Set structure *)
-class type ['a] pset =
+class type ['a] pset = object
-  object
+  method add : 'a -> 'a pset
-    method add : 'a -> 'a pset
+  method mem : 'a -> bool
-    method mem : 'a -> bool
+end
-  end
 
 val set_of_cmp : cmp:('a -> 'a -> int) -> unit -> 'a pset
 (** Build a set structure given a total ordering. *)

src/data/CCPersistentHashtbl.ml

@@ -295,9 +295,9 @@ module Make (H : HashedType) : S with type key = H.t = struct
           {
             length =
               (if is_new then
-                t.length + 1
+                 t.length + 1
-              else
+               else
-                t.length);
+                 t.length);
             arr = Arr a;
           }
         in

src/data/CCTrie.ml

@@ -225,12 +225,12 @@ module Make (W : WORD) : S with type char_ = W.char_ and type key = W.t = struct
           let rebuild' new_child =
             rebuild
               (if is_empty new_child then
-                t
+                 t
-              else (
+               else (
-                let map = M.singleton c new_child in
+                 let map = M.singleton c new_child in
-                let map = M.add c' t' map in
+                 let map = M.add c' t' map in
-                _mk_node None map
+                 _mk_node None map
-              ))
+               ))
           in
           empty, rebuild'
         )
@@ -242,9 +242,9 @@ module Make (W : WORD) : S with type char_ = W.char_ and type key = W.t = struct
            let rebuild' new_child =
              rebuild
                (if is_empty new_child then
-                 _mk_node value (M.remove c map)
+                  _mk_node value (M.remove c map)
-               else
+                else
-                 _mk_node value (M.add c new_child map))
+                  _mk_node value (M.add c new_child map))
            in
            t', rebuild'
          with Not_found ->

src/domain/containers_domain.mli

@@ -0,0 +1,7 @@
+(** A partial stub for {!Domain}. *)
+
+val is_main_domain : unit -> bool
+val cpu_relax : unit -> unit
+
+val relax_loop : int -> unit
+(** Call {!cpu_relax} n times *)

src/domain/dune

@@ -0,0 +1,14 @@
+(library
+ (name containers_domain)
+ (synopsis "Compatibility library for the Domain module")
+ (public_name containers.domain)
+ (modules containers_domain))
+
+(executable
+ (modules gen)
+ (name gen))
+
+(rule
+ (targets containers_domain.ml)
+ (action
+  (run ./gen.exe)))

src/domain/gen.ml

@@ -0,0 +1,28 @@
+let domain_4 =
+  {|
+let is_main_domain () = true
+let cpu_relax = ignore
+let relax_loop : int -> unit = ignore
+  |}
+
+let domain_5 =
+  {|
+let is_main_domain = Domain.is_main_domain
+let cpu_relax = Domain.cpu_relax
+let relax_loop i =
+  for _j = 1 to i do cpu_relax () done
+|}
+
+let write_file file s =
+  let oc = open_out file in
+  output_string oc s;
+  close_out oc
+
+let () =
+  let version = Scanf.sscanf Sys.ocaml_version "%d.%d.%s" (fun x y _ -> x, y) in
+  write_file "containers_domain.ml"
+    (if version >= (5, 0) then
+       domain_5
+     else
+       domain_4);
+  ()

src/leb128/containers_leb128.ml

@@ -0,0 +1,98 @@
+(* adapted from ocaml-protoc from code by c-cube *)
+
+module Byte_slice = CCByte_slice
+module Byte_buffer = CCByte_buffer
+
+module Decode = struct
+  let skip (sl : Byte_slice.t) off : int =
+    let shift = ref 0 in
+    let continue = ref true in
+
+    let off = ref off in
+    let n_consumed = ref 0 in
+
+    while !continue do
+      if sl.len <= 0 then invalid_arg "out of bound";
+      incr n_consumed;
+      let b = Char.code (Bytes.get sl.bs !off) in
+      let cur = b land 0x7f in
+      if cur <> b then (
+        (* at least one byte follows this one *)
+        incr off;
+        shift := !shift + 7
+      ) else if !shift < 63 || b land 0x7f <= 1 then
+        continue := false
+      else
+        invalid_arg "leb128 varint is too long"
+    done;
+
+    !n_consumed
+
+  let u64 (sl : Byte_slice.t) (off : int) : int64 * int =
+    let shift = ref 0 in
+    let res = ref 0L in
+    let continue = ref true in
+
+    let off = ref off in
+    let n_consumed = ref 0 in
+
+    while !continue do
+      if sl.len <= 0 then invalid_arg "out of bound";
+      incr n_consumed;
+      let b = Char.code (Bytes.get sl.bs !off) in
+      let cur = b land 0x7f in
+      if cur <> b then (
+        (* at least one byte follows this one *)
+        (res := Int64.(logor !res (shift_left (of_int cur) !shift)));
+        incr off;
+        shift := !shift + 7
+      ) else if !shift < 63 || b land 0x7f <= 1 then (
+        (res := Int64.(logor !res (shift_left (of_int b) !shift)));
+        continue := false
+      ) else
+        invalid_arg "leb128 varint is too long"
+    done;
+
+    !res, !n_consumed
+
+  let[@inline] uint_truncate sl off =
+    let v, n_consumed = u64 sl off in
+    Int64.to_int v, n_consumed
+
+  let[@inline] decode_zigzag (v : int64) : int64 =
+    Int64.(logxor (shift_right v 1) (neg (logand v Int64.one)))
+
+  let[@inline] i64 sl off : int64 * int =
+    let v, n_consumed = u64 sl off in
+    decode_zigzag v, n_consumed
+
+  let[@inline] int_truncate sl off =
+    let v, n_consumed = u64 sl off in
+    Int64.to_int (decode_zigzag v), n_consumed
+end
+
+module Encode = struct
+  let[@inline] encode_zigzag (i : int64) : int64 =
+    Int64.(logxor (shift_left i 1) (shift_right i 63))
+
+  external varint_size : (int64[@unboxed]) -> int
+    = "caml_cc_leb128_varint_size_byte" "caml_cc_leb128_varint_size"
+  [@@noalloc]
+  (** Compute how many bytes this int would occupy as varint *)
+
+  external varint_slice : bytes -> (int[@untagged]) -> (int64[@unboxed]) -> unit
+    = "caml_cc_leb128_varint_byte" "caml_cc_leb128_varint"
+  [@@noalloc]
+  (** Write this int as varint into the given slice *)
+
+  let[@inline] u64 (buf : Byte_buffer.t) (i : int64) =
+    let n = varint_size i in
+    Byte_buffer.ensure_free buf n;
+    assert (buf.len + n <= Bytes.length buf.bs);
+    varint_slice buf.bs buf.len i;
+    buf.len <- buf.len + n
+
+  let[@inline] i64 buf i : unit = u64 buf (encode_zigzag i)
+  let[@inline] uint buf i : unit = u64 buf (Int64.of_int i)
+  let[@inline] int buf i : unit = u64 buf (encode_zigzag (Int64.of_int i))
+end

src/leb128/containers_leb128.mli

@@ -0,0 +1,49 @@
+(** LEB128 encoding and decoding.
+
+    See https://en.wikipedia.org/wiki/LEB128 . *)
+
+module Byte_slice = CCByte_slice
+module Byte_buffer = CCByte_buffer
+
+module Decode : sig
+  val decode_zigzag : int64 -> int64
+  (** Turn an unsigned integer into a signed one.
+
+      See https://en.wikipedia.org/wiki/Variable-length_quantity#Zigzag_encoding
+  *)
+
+  val skip : Byte_slice.t -> int -> int
+  (** [skip slice off] reads an integer at offset [off], and returns how many
+      bytes the integer occupies. *)
+
+  val u64 : Byte_slice.t -> int -> int64 * int
+  (** [u64 slice off] reads an integer at offset [off], and returns a pair
+      [v, n_consumed]. [v] is the read integer, [n_consumed] is the number of
+      bytes consumed during reading. *)
+
+  val i64 : Byte_slice.t -> int -> int64 * int
+  (** Read a signed int64 by reading a u64 and zigzag decoding it *)
+
+  val int_truncate : Byte_slice.t -> int -> int * int
+  (** Like {!i64} but truncates to integer. Returns a pair [v, n_consumed]. *)
+
+  val uint_truncate : Byte_slice.t -> int -> int * int
+  (** Like {!u64} but truncates to integer. *)
+end
+
+module Encode : sig
+  val encode_zigzag : int64 -> int64
+  (** Turn a signed int64 into a u64 via zigzag encoding. *)
+
+  val u64 : Byte_buffer.t -> int64 -> unit
+  (** Write a unsigned int *)
+
+  val i64 : Byte_buffer.t -> int64 -> unit
+  (** Write a signed int via zigzag encoding *)
+
+  val uint : Byte_buffer.t -> int -> unit
+  (** Turn an uint into a u64 and write it *)
+
+  val int : Byte_buffer.t -> int -> unit
+  (** Turn an int into a int64 and write it *)
+end

src/leb128/dune

@@ -0,0 +1,11 @@
+(library
+ (name containers_leb128)
+ (public_name containers.leb128)
+ (synopsis
+  "LEB128 encoding (https://en.wikipedia.org/wiki/LEB128) for cephalopod")
+ (libraries containers)
+ (foreign_stubs
+  (language c)
+  (flags :standard -std=c99 -O2)
+  (names stubs))
+ (ocamlopt_flags :standard -inline 100))

src/leb128/stubs.c

@@ -0,0 +1,73 @@
+
+// readapted from ocaml-protoc, original code also from c-cube
+
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/mlvalues.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+static inline int ix_leb128_varint_size(uint64_t i) {
+/* generated with:
+for i in range(1,10):
+  ceiling = (1 << (i*7))-1
+  print(f'if (i <= {ceiling}L) return {i};')
+*/
+
+  if (i <= 127L) return 1;
+  if (i <= 16383L) return 2;
+  if (i <= 2097151L) return 3;
+  if (i <= 268435455L) return 4;
+  if (i <= 34359738367L) return 5;
+  if (i <= 4398046511103L) return 6;
+  if (i <= 562949953421311L) return 7;
+  if (i <= 72057594037927935L) return 8;
+  if (i <= 9223372036854775807L) return 9;
+  return 10;
+}
+
+// number of bytes for i
+CAMLprim value caml_cc_leb128_varint_size(int64_t i) {
+  int res = ix_leb128_varint_size(i);
+  return Val_int(res);
+}
+
+// boxed version, for bytecode
+CAMLprim value caml_cc_leb128_varint_size_byte(value v_i) {
+  CAMLparam1(v_i);
+
+  int64_t i = Int64_val(v_i);
+  int res = ix_leb128_varint_size(i);
+  CAMLreturn(Val_int(res));
+}
+
+// write i at str[idx…] in varint
+static inline void ix_leb128_varint(unsigned char *str, uint64_t i) {
+  while (true) {
+    uint64_t cur = i & 0x7f;
+    if (cur == i) {
+      *str = (unsigned char)cur;
+      break;
+    } else {
+      *str = (unsigned char)(cur | 0x80);
+      i = i >> 7;
+      ++str;
+    }
+  }
+}
+
+// write `i` starting at `idx`
+CAMLprim value caml_cc_leb128_varint(value _str, intnat idx, int64_t i) {
+  unsigned char *str = Bytes_val(_str);
+  ix_leb128_varint(str + idx, i);
+  return Val_unit;
+}
+
+CAMLprim value caml_cc_leb128_varint_byte(value _str, value _idx, value _i) {
+  CAMLparam3(_str, _idx, _i);
+  unsigned char *str = Bytes_val(_str);
+  int idx = Int_val(_idx);
+  int64_t i = Int64_val(_i);
+  ix_leb128_varint(str + idx, i);
+  CAMLreturn(Val_unit);
+}

src/monomorphic/CCMonomorphic.mli

@@ -37,9 +37,8 @@ val ( >=. ) : float -> float -> bool
 (** {2 Shadow Dangerous Operators} *)
 
 val ( == ) : [ `Consider_using_CCEqual_physical ]
-  [@@ocaml.deprecated "Please use CCEqual.physical or Stdlib.(==) instead."]
+[@@ocaml.deprecated "Please use CCEqual.physical or Stdlib.(==) instead."]
 
 val ( != ) : [ `Consider_using_CCEqual_physical ]
-  [@@ocaml.deprecated
+[@@ocaml.deprecated "Please use [not CCEqual.physical] or Stdlib.(!=) instead."]
-    "Please use [not CCEqual.physical] or Stdlib.(!=) instead."]
 (** @since 2.1 *)

src/pp/containers_pp.ml

@@ -455,9 +455,9 @@ let of_seq ?(sep = nil) f seq : t =
     | Seq.Cons (x, tl) ->
       let x = f x in
       (if first then
-        x
+         x
-      else
+       else
-        sep ^ x)
+         sep ^ x)
       ^ loop false tl
   in
   loop true seq

src/pvec/containers_pvec.ml

@@ -352,6 +352,8 @@ let append a b =
   else
     fold_left push a b
 
+let flat_map f v : _ t = fold_left (fun acc x -> append acc (f x)) empty v
+
 let rec equal_tree eq t1 t2 =
   match t1, t2 with
   | Empty, Empty -> true

src/pvec/containers_pvec.mli

@@ -84,6 +84,11 @@ val append : 'a t -> 'a t -> 'a t
 
 val map : ('a -> 'b) -> 'a t -> 'b t
 
+val flat_map : ('a -> 'b t) -> 'a t -> 'b t
+(** A basic, fairly slow [flat_map] operation like {!CCList.flat_map}.
+    It exists for convenience but is not where this data structure shines.
+    @since NEXT_RELEASE *)
+
 val choose : 'a t -> 'a option
 (** Return an element. It is unspecified which one is returned. *)
 

tests/core/t_cbor.ml

@@ -61,9 +61,9 @@ let gen_c : Cbor.t Q.Gen.t =
   in
   frequency
     (if size > 0 then
-      base @ rec_
+       base @ rec_
-    else
+     else
-      base)
+       base)
 
 let rec shrink (c : Cbor.t) : Cbor.t Q.Iter.t =
   let open Q.Iter in
@@ -99,12 +99,28 @@ let rec shrink (c : Cbor.t) : Cbor.t Q.Iter.t =
     let+ s = Q.Shrink.string s in
     `Bytes s
 
-let arb = Q.make ~shrink ~print:Cbor.to_string_diagnostic gen_c;;
+let arb = Q.make ~shrink ~print:Cbor.to_string_diagnostic gen_c
+
+let rec eq_c c c' =
+  match c, c' with
+  | `Null, `Null | `Undefined, `Undefined -> true
+  | `Simple i, `Simple i' -> Int.equal i i'
+  | `Bool b, `Bool b' -> Bool.equal b b'
+  | `Int i, `Int i' -> Int64.equal i i'
+  | `Float f, `Float f' -> Float.equal f f'
+  | `Bytes s, `Bytes s' -> String.equal s s'
+  | `Text t, `Text t' -> String.equal t t'
+  | `Array a, `Array a' -> CCList.equal eq_c a a'
+  | `Map m, `Map m' ->
+    CCList.equal (fun (t0, t1) (t0', t1') -> eq_c t0 t0' && eq_c t1 t1') m m'
+  | `Tag (i, t), `Tag (i', t') -> Int.equal i i' && eq_c t t'
+  | _ -> false
+;;
 
 q ~count:1_000 ~long_factor:10 arb @@ fun c ->
 let s = Cbor.encode c in
 let c' = Cbor.decode_exn s in
-if not (c = c') then
+if not (eq_c c c') then
   Q.Test.fail_reportf "@[<hv2>roundtrip failed:@ from %a@ to %a@]"
     Cbor.pp_diagnostic c Cbor.pp_diagnostic c';
 true

tests/core/t_char.ml

@@ -8,3 +8,76 @@ eq None (of_int 257);;
 q
   (Q.string_of_size (Q.Gen.return 1))
   (fun s -> Stdlib.( = ) (to_string s.[0]) s)
+;;
+
+q (Q.int_range 65 90 |> Q.map Char.chr) CCChar.is_uppercase_ascii;;
+
+q
+  (Q.int_range 0 64 |> Q.map Char.chr)
+  (fun c -> not @@ CCChar.is_uppercase_ascii c)
+;;
+
+q
+  (Q.int_range 91 127 |> Q.map Char.chr)
+  (fun c -> not @@ CCChar.is_uppercase_ascii c)
+;;
+
+q (Q.int_range 97 122 |> Q.map Char.chr) CCChar.is_lowercase_ascii;;
+
+q
+  (Q.int_range 0 96 |> Q.map Char.chr)
+  (fun c -> not @@ CCChar.is_lowercase_ascii c)
+;;
+
+q
+  (Q.int_range 123 127 |> Q.map Char.chr)
+  (fun c -> not @@ CCChar.is_lowercase_ascii c)
+;;
+
+q (Q.int_range 48 57 |> Q.map Char.chr) CCChar.is_digit_ascii;;
+q (Q.int_range 0 47 |> Q.map Char.chr) (fun c -> not @@ CCChar.is_digit_ascii c)
+;;
+
+q
+  (Q.int_range 58 127 |> Q.map Char.chr)
+  (fun c -> not @@ CCChar.is_digit_ascii c)
+;;
+
+eq true
+  (Stdlib.List.for_all CCChar.is_whitespace_ascii
+     [ '\n'; '\t'; ' '; '\010'; '\011'; '\012'; '\013' ])
+;;
+
+eq false
+  (Stdlib.List.exists CCChar.is_whitespace_ascii
+     [
+       'H';
+       'e';
+       'l';
+       'l';
+       'o';
+       '!';
+       '-';
+       '-';
+       'N';
+       'O';
+       't';
+       'h';
+       'i';
+       'n';
+       'a';
+       '\055';
+       'k';
+       'a';
+       'g';
+       '$';
+       '$';
+       '$';
+       '%';
+       '^';
+       'b';
+       'c';
+       'h';
+       '\008';
+       'h';
+     ])

tests/core/t_fun.ml

@@ -21,3 +21,15 @@ true
 t @@ fun () -> CCFun.((succ %> string_of_int) 2 = "3");;
 t @@ fun () -> CCFun.((( * ) 3 % succ) 5 = 18);;
 t @@ fun () -> CCFun.(succ @@ ( * ) 2 @@ pred @@ 3 = 5)
+
+let find_array arr x =
+  let@ return = with_return in
+  for i = 0 to Array.length arr - 1 do
+    if arr.(i) = x then return i
+  done;
+  -1
+;;
+
+eq 1 @@ find_array [| "a"; "b"; "c" |] "b";;
+eq 2 @@ find_array [| "a"; "b"; "c" |] "c";;
+eq (-1) @@ find_array [| "a"; "b"; "c" |] "hello"

tests/core/t_hash.ml

@@ -11,6 +11,8 @@ t @@ fun () -> char 'c' >= 0;;
 t @@ fun () -> int 152352 = int 152352;;
 t @@ fun () -> list_comm int [ 1; 2 ] = list_comm int [ 2; 1 ];;
 t @@ fun () -> list_comm int [ 1; 2 ] <> list_comm int [ 2; 3 ];;
+t @@ fun () -> string "abcd" >= 0;;
+t @@ fun () -> string "abc" <> string "abcd";;
 
 q Q.int (fun i ->
     Q.assume (i >= 0);

tests/core/t_sexp.ml

@@ -183,10 +183,11 @@ let arb_csexp_arb =
   let genstr = Q.Gen.(string_size ~gen:genchar (0 -- 15)) in
   Q.make ~print:Sexp0.to_string ~shrink:shrink_csexp (gen_csexp genstr)
 
-module Make (X : sig
+module Make
-  val arb : Csexp.t Q.arbitrary
+    (X : sig
-end)
+      val arb : Csexp.t Q.arbitrary
-() =
+    end)
+    () =
 struct
   open X;;
 

tests/core/t_string.ml

@@ -162,9 +162,9 @@ q
     let e = edit_distance s1 s2 in
     let e' = edit_distance ~cutoff:3 s1 s2 in
     (if e' < 3 then
-      e = e'
+       e = e'
-    else
+     else
-      e >= 3)
+       e >= 3)
     &&
     if e <= 3 then
       e = e'
@@ -229,7 +229,28 @@ t @@ fun () -> not (suffix ~suf:"cd" "abcde");;
 t @@ fun () -> not (suffix ~suf:"abcd" "cd");;
 eq ("ab", "cd") (take_drop 2 "abcd");;
 eq ("abc", "") (take_drop 3 "abc");;
-eq ("abc", "") (take_drop 5 "abc")
+eq ("abc", "") (take_drop 5 "abc");;
+
+q
+  Q.(printable_string)
+  (fun s ->
+    let predicate c = Char.code c mod 2 = 0 in
+    let prefix = take_while predicate s in
+    let suffix = drop_while predicate s in
+    if prefix ^ suffix <> s then
+      Q.Test.fail_reportf "s=%S, pre=%S, post=%S" s prefix suffix;
+    true)
+;;
+
+q
+  Q.(printable_string)
+  (fun s ->
+    let predicate c = Char.code c mod 2 = 0 in
+    let prefix = rdrop_while predicate s in
+    let suffix = rtake_while predicate s in
+    if prefix ^ suffix <> s then
+      Q.Test.fail_reportf "s=%S, pre=%S, post=%S" s prefix suffix;
+    true)
 
 let eq' = eq ~printer:Q.Print.(option string);;
 
@@ -280,6 +301,23 @@ eq ~printer:CCFun.id "" (unlines []);;
 eq ~printer:CCFun.id "ab\nc\n" (unlines [ "ab"; "c" ]);;
 q Q.printable_string (fun s -> trim (unlines (lines s)) = trim s);;
 q Q.printable_string (fun s -> trim (unlines_gen (lines_gen s)) = trim s);;
+eq ~printer:CCFun.id "" (take_while (Char.equal 'c') "heloo_cc");;
+eq ~printer:CCFun.id "" (take_while (Char.equal 'c') "");;
+eq ~printer:CCFun.id "c" (take_while (Char.equal 'c') "c");;
+eq ~printer:CCFun.id "ccc" (take_while (Char.equal 'c') "cccujsuy");;
+
+eq ~printer:CCFun.id "THIS"
+  (take_while (fun c -> Char.code c < 91) "THISisNotWHAtIwANTED")
+;;
+
+eq ~printer:CCFun.id "cc" (rtake_while (Char.equal 'c') "heloo_cc");;
+eq ~printer:CCFun.id "" (rtake_while (Char.equal 'c') "");;
+eq ~printer:CCFun.id "c" (rtake_while (Char.equal 'c') "c");;
+eq ~printer:CCFun.id "" (rtake_while (Char.equal 'c') "cccujsuy");;
+
+eq ~printer:CCFun.id "ANTED"
+  (rtake_while (fun c -> Char.code c < 91) "THISisNotWHAtIwANTED")
+;;
 
 q
   Q.(small_list small_string)

tests/core/t_utf8string.ml

@@ -26,8 +26,8 @@ let arb_uchar =
   let rec gen =
     lazy
       (let open Q.Gen in
-      Q.Gen.int_range Uchar.(to_int min) Uchar.(to_int max) >>= fun n ->
+       Q.Gen.int_range Uchar.(to_int min) Uchar.(to_int max) >>= fun n ->
-      try return (Uchar.of_int n) with _ -> Lazy.force gen)
+       try return (Uchar.of_int n) with _ -> Lazy.force gen)
   in
   Q.make
     ~print:(fun c -> Printf.sprintf "<uchar '%d'>" (Uchar.to_int c))

tests/data/t_bv.ml

@@ -640,9 +640,9 @@ module Op = struct
     @@ List.flatten
          [
            (if size > 0 then
-             nonzero
+              nonzero
-           else
+            else
-             []);
+              []);
            [
              1, return Clear;
              1, return Clear_and_shrink;
@@ -747,16 +747,16 @@ module Ref_ = struct
     | Set_bool (i, b) ->
       apply_op self
         (if b then
-          Set i
+           Set i
-        else
+         else
-          Reset i)
+           Reset i)
     | Flip i ->
       self.size <- max self.size (i + 1);
       apply_op self
         (if Intset.mem i self.set then
-          Reset i
+           Reset i
-        else
+         else
-          Set i)
+           Set i)
     | Clear -> self.set <- Intset.empty
     | Clear_and_shrink ->
       self.set <- Intset.empty;

tests/data/t_fun_vec.ml

@@ -173,12 +173,12 @@ module Op = struct
                    1, return (Check_to_gen, size);
                  ];
                  (if size > 0 then
-                   [
+                    [
-                     1, return (Pop, size - 1);
+                      1, return (Pop, size - 1);
-                     (1, 0 -- (size - 1) >|= fun x -> Check_get x, size);
+                      (1, 0 -- (size - 1) >|= fun x -> Check_get x, size);
-                   ]
+                    ]
-                 else
+                  else
-                   []);
+                    []);
                  [
                    ( 1,
                      small_list gen_x >|= fun l ->

tests/data/t_persistenthashtbl.ml

@@ -108,15 +108,14 @@ let t1 = H.of_list [ 1, "a"; 2, "b1" ] in
 let t2 = H.of_list [ 2, "b2"; 3, "c" ] in
 let t =
   H.merge
-    ~f:
+    ~f:(fun _ -> function
-      (fun _ -> function
+      | `Right v2 -> Some v2
-        | `Right v2 -> Some v2
+      | `Left v1 -> Some v1
-        | `Left v1 -> Some v1
+      | `Both (s1, s2) ->
-        | `Both (s1, s2) ->
+        if s1 < s2 then
-          if s1 < s2 then
+          Some s1
-            Some s1
+        else
-          else
+          Some s2)
-            Some s2)
     t1 t2
 in
 assert_equal ~printer:string_of_int 3 (H.length t);

tests/data/t_trie.ml

@@ -118,9 +118,9 @@ let rec sorted ~rev = function
   | [] | [ _ ] -> true
   | x :: (y :: _ as tl) ->
     (if rev then
-      x >= y
+       x >= y
-    else
+     else
-      x <= y)
+       x <= y)
     && sorted ~rev tl
 
 let gen_str = Q.small_printable_string;;

tests/pvec/t_pvec.ml

@@ -119,6 +119,8 @@ module Ref_impl = struct
   let to_list l = l
   let to_seq = CCSeq.of_list
   let add_list l l2 : _ t = List.append l l2
+  let append self l2 : _ t = List.append self l2
+  let flat_map sub l : _ t = CCList.flat_map (fun x -> sub @ [ x ]) l
 
   let to_list_via_reviter m =
     let l = ref [] in
@@ -159,7 +161,9 @@ module Op = struct
     | Push of 'a
     | Pop
     (* TODO: set *)
+    | Append of 'a list
     | Add_list of 'a list
+    | Flat_map of 'a list
     | Check_get of int
     | Check_choose
     | Check_is_empty
@@ -176,6 +180,8 @@ module Op = struct
       | Push _ :: tl -> loop (size + 1) tl
       | Pop :: tl -> size >= 0 && loop (size - 1) tl
       | Add_list l :: tl -> loop (size + List.length l) tl
+      | Append l :: tl -> loop (size + List.length l) tl
+      | Flat_map sub :: tl -> loop (size * (1 + List.length sub)) tl
       | Check_get x :: tl -> x < size && loop size tl
       | Check_choose :: tl
       | Check_is_empty :: tl
@@ -194,6 +200,8 @@ module Op = struct
     | Push x -> spf "push %s" (show_x x)
     | Pop -> "pop"
     | Add_list l -> spf "add_list [%s]" (String.concat ";" @@ List.map show_x l)
+    | Append l -> spf "append [%s]" (String.concat ";" @@ List.map show_x l)
+    | Flat_map l -> spf "flat_map [%s]" (String.concat ";" @@ List.map show_x l)
     | Check_get i -> spf "check_get %d" i
     | Check_choose -> "check_choose"
     | Check_is_empty -> "check_is_empty"
@@ -211,6 +219,8 @@ module Op = struct
     | Push x -> shrink_x x >|= fun x -> Push x
     | Pop -> empty
     | Add_list l -> list ~shrink:shrink_x l >|= fun x -> Add_list x
+    | Append l -> list ~shrink:shrink_x l >|= fun x -> Append x
+    | Flat_map l -> list ~shrink:shrink_x l >|= fun x -> Flat_map x
     | Check_get _ | Check_choose | Check_is_empty | Check_len | Check_to_list
     | Check_to_gen | Check_last | Check_rev_iter | Check_iter ->
       empty
@@ -242,16 +252,22 @@ module Op = struct
                    1, return (Check_rev_iter, size);
                  ];
                  (if size > 0 then
-                   [
+                    [
-                     1, return (Pop, size - 1);
+                      1, return (Pop, size - 1);
-                     (1, 0 -- (size - 1) >|= fun x -> Check_get x, size);
+                      (1, 0 -- (size - 1) >|= fun x -> Check_get x, size);
-                   ]
+                    ]
-                 else
+                  else
-                   []);
+                    []);
                  [
                    ( 1,
                      small_list gen_x >|= fun l ->
                      Add_list l, size + List.length l );
+                   ( 1,
+                     small_list gen_x >|= fun l ->
+                     Append l, size + List.length l );
+                   ( 1,
+                     list_size (0 -- 5) gen_x >|= fun l ->
+                     Flat_map l, size * (1 + List.length l) );
                  ];
                ]
         in
@@ -292,6 +308,12 @@ let check_ops ~show_x (ops : 'a Op.t list) : unit =
       | Op.Add_list l ->
         cur := add_list !cur l;
         cur_ref := Ref_impl.add_list !cur_ref l
+      | Op.Append l ->
+        cur := append !cur (of_list l);
+        cur_ref := Ref_impl.append !cur_ref l
+      | Op.Flat_map sub ->
+        cur := flat_map (fun x -> push (of_list sub) x) !cur;
+        cur_ref := Ref_impl.flat_map sub !cur_ref
       | Op.Check_get i -> if get !cur i <> Ref_impl.get i !cur_ref then fail ()
       | Op.Check_is_empty ->
         if is_empty !cur <> Ref_impl.is_empty !cur_ref then fail ()