Merge branch 'master' into stable for 1.3

AUTHORS.adoc

@@ -21,3 +21,4 @@
 - Glenn Slotte (glennsl)
 - @LemonBoy
 - Leonid Rozenberg (@rleonid)
+- Bikal Gurung (@bikalgurung)

CHANGELOG.adoc

@@ -1,5 +1,23 @@
 = Changelog
 
+== 1.3
+
+- deprecate `CCBool.negate`
+- add `CCString.compare_natural` (closes #146)
+- add callbacks in `CCCache.with_cache{,_rec}` (closes #140)
+- tail-rec `CCList.split` (by @bikalgurung, see #138)
+- change `CCRingBuffer.peek_{front,back}` to return options (closes #127)
+- add `CCRingBuffer.is_full`
+- add `CCArray.find_map{,_i}`, deprecated older names (closes #129)
+- add `CCList.{keep,all}_{some,ok}` (closes #124)
+- large refactor of `CCSimple_queue` (close #125)
+- add `CCSimple_queue` to containers.data
+- small change for consistency in `CCIntMap`
+
+- bugfix in `CCRingBuffer.skip`, and corresponding tests
+- cleanup and refactor of `CCRingBuffer` (see #126). Add strong tests.
+- add rich testsuite to `CCIntMap`, based on @jmid's work
+
 == 1.2
 
 - make many modules extensions of stdlib (close #109)

README.adoc

@@ -4,6 +4,8 @@
 
 A modular, clean and powerful extension of the OCaml standard library.
 
+https://c-cube.github.io/ocaml-containers/last/[(Jump to the current API documentation)].
+
 Containers is an extension of OCaml's standard library (under BSD license)
 focused on data structures, combinators and iterators, without dependencies on
 unix, str or num. Every module is independent and is prefixed with 'CC' in the
@@ -91,7 +93,7 @@ and <<tutorial,the tutorial below>> for a gentle introduction.
 
 == Documentation
 
-In general, see http://c-cube.github.io/ocaml-containers/ or
+In general, see http://c-cube.github.io/ocaml-containers/last/ or
 http://cedeela.fr/~simon/software/containers for the **API documentation**.
 
 Some examples can be found link:doc/containers.adoc[there].
@@ -135,18 +137,54 @@ To build the small benchmarking suite (requires https://github.com/chris00/ocaml
 
 == Contributing
 
-PRs on github are welcome (patches by email too, if you prefer so).
+PRs on github are very welcome (patches by email too, if you prefer so).
 
-A few guidelines:
+[[first-time-contribute]]
+=== First-Time Contributors
+
+Assuming your are in a clone of the repository:
+
+. Some dependencies are required, you'll need
+  `opam install benchmark qcheck qtest sequence`. 
+. run `make devel` to enable everything (including tests).
+. make your changes, commit, push, and open a PR.
+. use `make test` without moderation! It must pass before a PR
+  is merged.  There are around 900 tests right now, and new
+  features should come with their own tests.
+
+If you feel like writing new tests, that is totally worth a PR
+(and my gratefulness).
+
+=== General Guidelines
+
+A few guidelines to follow the philosophy of containers:
 
 - no dependencies between basic modules (even just for signatures);
 - add `@since` tags for new functions;
-- add tests if possible (using `qtest`).
+- add tests if possible (using https://github.com/vincent-hugot/iTeML/[qtest]). There are numerous inline tests already,
+to see what it looks like search for comments starting with `(*$`
+in source files.
 
-It is helpful to run `make devel` to enable everything. Some dependencies
+=== For Total Beginners
-are required, you'll need `opam install benchmark qcheck qtest sequence`. 
 
-Powered by image:http://oasis.forge.ocamlcore.org/oasis-badge.png[alt="OASIS", style="border: none;", link="http://oasis.forge.ocamlcore.org/"]
+Thanks for wanting to contribute!
+To contribute a change, here are the steps (roughly):
+
+. click "fork" on https://github.com/c-cube/ocaml-containers on the top right of the page. This will create a copy of the repository on your own github account.
+. click the big green "clone or download" button, with "SSH". Copy the URL (which should look like `git@github.com:<your username>/ocaml-containers.git`) into a terminal to enter the command:
++
+[source,sh]
+----
+$ git clone git@github.com:<your username>/ocaml-containers.git
+----
++
+. then, `cd` into the newly created directory.
+. make the changes you want. See <<first-time-contribute>> for
+  more details about what to do in particular.
+. use `git add` and `git commit` to commit these changes.
+. `git push origin master` to push the new change(s) onto your
+  copy of the repository
+. on github, open a "pull request" (PR). Et voilà !
 
 [[tutorial]]
 == Tutorial
@@ -441,3 +479,6 @@ printer:: `'a printer = Format.formatter -> 'a -> unit` is a pretty-printer
 === Extended Documentation
 
 See link:doc/containers.adoc[the extended documentation] for more examples.
+
+Powered by image:http://oasis.forge.ocamlcore.org/oasis-badge.png[alt="OASIS", style="border: none;", link="http://oasis.forge.ocamlcore.org/"]
+

_oasis

@@ -1,6 +1,6 @@
 OASISFormat: 0.4
 Name:        containers
-Version:     1.2
+Version:     1.3
 Homepage:    https://github.com/c-cube/ocaml-containers
 Authors:     Simon Cruanes
 License:     BSD-2-clause
@@ -67,7 +67,7 @@ Library "containers_data"
                     CCPersistentHashtbl, CCDeque, CCFQueue, CCBV, CCMixtbl,
                     CCMixmap, CCRingBuffer, CCIntMap, CCPersistentArray,
                     CCMixset, CCGraph, CCHashSet, CCBitField,
-                    CCHashTrie, CCWBTree, CCRAL,
+                    CCHashTrie, CCWBTree, CCRAL, CCSimple_queue,
                     CCImmutArray, CCHet, CCZipper
   BuildDepends:     bytes
   # BuildDepends:     bytes, bisect_ppx

benchs/run_benchs.ml

@@ -20,16 +20,24 @@ module L = struct
 
   let f_ x = x+1
 
+  let rec map_naive f l = match l with
+    | [] -> []
+    | x :: tail ->
+      let y = f x in
+      y :: map_naive f tail
+
   let bench_map ?(time=2) n =
     let l = CCList.(1 -- n) in
     let ral = CCRAL.of_list l in
     let map_naive () = ignore (try  List.map f_ l with Stack_overflow -> [])
+    and map_naive2 () = ignore (try  map_naive f_ l with Stack_overflow -> [])
     and map_tailrec () = ignore (List.rev (List.rev_map f_ l))
     and ccmap () = ignore (CCList.map f_ l)
     and ralmap () = ignore (CCRAL.map ~f:f_ ral)
     in
     B.throughputN time ~repeat
       [ "List.map", map_naive, ()
+      ; "List.map(inline)", map_naive2, ()
       ; "List.rev_map o rev", map_tailrec, ()
       ; "CCList.map", ccmap, ()
       ; "CCRAL.map", ralmap, ()

containers.odocl

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 97e963a89adef885748c84195b76d95c)
+# DO NOT EDIT (digest: fe2373b07664be05f7322781403afad6)
 src/core/CCVector
 src/core/CCHeap
 src/core/CCList
@@ -53,6 +53,7 @@ src/data/CCBitField
 src/data/CCHashTrie
 src/data/CCWBTree
 src/data/CCRAL
+src/data/CCSimple_queue
 src/data/CCImmutArray
 src/data/CCHet
 src/data/CCZipper

doc/intro.txt

@@ -93,6 +93,7 @@ CCPersistentArray
 CCPersistentHashtbl
 CCRAL
 CCRingBuffer
+CCSimple_queue
 CCTrie
 CCWBTree
 }

myocamlbuild.ml

@@ -1,5 +1,5 @@
 (* OASIS_START *)
-(* DO NOT EDIT (digest: d0913c9409d93aeda14a31d6f9ebb3b2) *)
+(* DO NOT EDIT (digest: 9ebeddeee0d56b1f8c98544fabcbbd9b) *)
 module OASISGettext = struct
 (* # 22 "src/oasis/OASISGettext.ml" *)
 
@@ -105,10 +105,7 @@ module OASISString = struct
         ok := false;
       incr str_idx
     done;
-    if !what_idx = String.length what then
+    !what_idx = String.length what
-      true
-    else
-      false
 
 
   let strip_starts_with ~what str =
@@ -131,10 +128,7 @@ module OASISString = struct
         ok := false;
       decr str_idx
     done;
-    if !what_idx = -1 then
+    !what_idx = -1
-      true
-    else
-      false
 
 
   let strip_ends_with ~what str =
@@ -440,7 +434,7 @@ module OASISExpr = struct
 end
 
 
-# 443 "myocamlbuild.ml"
+# 437 "myocamlbuild.ml"
 module BaseEnvLight = struct
 (* # 22 "src/base/BaseEnvLight.ml" *)
 
@@ -520,7 +514,7 @@ module BaseEnvLight = struct
 end
 
 
-# 523 "myocamlbuild.ml"
+# 517 "myocamlbuild.ml"
 module MyOCamlbuildFindlib = struct
 (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *)
 
@@ -881,7 +875,7 @@ module MyOCamlbuildBase = struct
 end
 
 
-# 884 "myocamlbuild.ml"
+# 878 "myocamlbuild.ml"
 open Ocamlbuild_plugin;;
 let package_default =
   {
@@ -921,7 +915,7 @@ let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false}
 
 let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;;
 
-# 925 "myocamlbuild.ml"
+# 919 "myocamlbuild.ml"
 (* OASIS_STOP *)
 let doc_intro = "doc/intro.txt" ;;
 

opam

@@ -43,12 +43,8 @@ available: [ocaml-version >= "4.01.0"]
 dev-repo: "https://github.com/c-cube/ocaml-containers.git"
 bug-reports: "https://github.com/c-cube/ocaml-containers/issues/"
 post-messages: [
-"Major release, with breaking changes. The APIs are more focused,
+"Small release with many bugfixes and a few new functions.
-more consistent, and some sub-libraries were removed or merged into the core
-ones.
 
-A summary of the changes can be found at
+A summary hub.com/c-cube/ocaml-containers/issues/84
-https://github.com/c-cube/ocaml-containers/issues/84
+changelog: https://github.com/c-cube/ocaml-containers/blob/1.3/CHANGELOG.adoc"
-and in the changelog
-https://github.com/c-cube/ocaml-containers/blob/1.0/CHANGELOG.adoc"
 ]

setup.ml

@@ -1,9 +1,9 @@
 (* setup.ml generated for the first time by OASIS v0.4.4 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: fdb4a0fff7e0145854a42105c9c8afcf) *)
+(* DO NOT EDIT (digest: a62cfaee59320a25dee6d9bbad9cd339) *)
 (*
-   Regenerated by OASIS v0.4.8
+   Regenerated by OASIS v0.4.10
    Visit http://oasis.forge.ocamlcore.org for more information and
    documentation about functions used in this file.
 *)
@@ -112,10 +112,7 @@ module OASISString = struct
         ok := false;
       incr str_idx
     done;
-    if !what_idx = String.length what then
+    !what_idx = String.length what
-      true
-    else
-      false
 
 
   let strip_starts_with ~what str =
@@ -138,10 +135,7 @@ module OASISString = struct
         ok := false;
       decr str_idx
     done;
-    if !what_idx = -1 then
+    !what_idx = -1
-      true
-    else
-      false
 
 
   let strip_ends_with ~what str =
@@ -3162,7 +3156,7 @@ module OASISFileUtil = struct
 end
 
 
-# 3165 "setup.ml"
+# 3159 "setup.ml"
 module BaseEnvLight = struct
 (* # 22 "src/base/BaseEnvLight.ml" *)
 
@@ -3242,7 +3236,7 @@ module BaseEnvLight = struct
 end
 
 
-# 3245 "setup.ml"
+# 3239 "setup.ml"
 module BaseContext = struct
 (* # 22 "src/base/BaseContext.ml" *)
 
@@ -5665,7 +5659,7 @@ module BaseCompat = struct
 end
 
 
-# 5668 "setup.ml"
+# 5662 "setup.ml"
 module InternalConfigurePlugin = struct
 (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *)
 
@@ -6016,17 +6010,14 @@ module InternalInstallPlugin = struct
 
   let install =
 
-    let in_destdir =
+    let in_destdir fn =
       try
-        let destdir =
+        (* Practically speaking destdir is prepended at the beginning of the
-          destdir ()
+           target filename
-        in
-          (* Practically speaking destdir is prepended
-           * at the beginning of the target filename
         *)
-          fun fn -> destdir^fn
+        (destdir ())^fn
       with PropList.Not_set _ ->
-        fun fn -> fn
+        fn
     in
 
     let install_file ~ctxt ?(prepend_destdir=true) ?tgt_fn src_file envdir =
@@ -6471,7 +6462,7 @@ module InternalInstallPlugin = struct
 end
 
 
-# 6474 "setup.ml"
+# 6465 "setup.ml"
 module OCamlbuildCommon = struct
 (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *)
 
@@ -6828,11 +6819,10 @@ module OCamlbuildDocPlugin = struct
     run_ocamlbuild ~ctxt (index_html :: run.extra_args) argv;
     List.iter
       (fun glb ->
-         BaseBuilt.register
+         match OASISFileUtil.glob ~ctxt (Filename.concat tgt_dir glb) with
-           ~ctxt
+         | (_ :: _) as filenames ->
-           BaseBuilt.BDoc
+             BaseBuilt.register ~ctxt BaseBuilt.BDoc cs.cs_name [filenames]
-           cs.cs_name
+         | [] -> ())
-           [OASISFileUtil.glob ~ctxt (Filename.concat tgt_dir glb)])
       ["*.html"; "*.css"]
 
 
@@ -6844,7 +6834,7 @@ module OCamlbuildDocPlugin = struct
 end
 
 
-# 6847 "setup.ml"
+# 6837 "setup.ml"
 module CustomPlugin = struct
 (* # 22 "src/plugins/custom/CustomPlugin.ml" *)
 
@@ -6976,7 +6966,7 @@ module CustomPlugin = struct
 end
 
 
-# 6979 "setup.ml"
+# 6969 "setup.ml"
 open OASISTypes;;
 
 let setup_t =
@@ -7051,7 +7041,7 @@ let setup_t =
        {
           oasis_version = "0.4";
           ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.1");
-          version = "1.2";
+          version = "1.3";
           license =
             OASISLicense.DEP5License
               (OASISLicense.DEP5Unit
@@ -7742,6 +7732,7 @@ let setup_t =
                            "CCHashTrie";
                            "CCWBTree";
                            "CCRAL";
+                           "CCSimple_queue";
                            "CCImmutArray";
                            "CCHet";
                            "CCZipper"
@@ -8908,8 +8899,9 @@ let setup_t =
           plugin_data = []
        };
      oasis_fn = Some "_oasis";
-     oasis_version = "0.4.8";
+     oasis_version = "0.4.10";
-     oasis_digest = Some "\214\023V\1858'\142!X\\k\202\255w\167\213";
+     oasis_digest =
+       Some "\164\233\1428\169\160\007\155\182\180\021s\193\n\134-";
      oasis_exec = None;
      oasis_setup_args = [];
      setup_update = false
@@ -8917,7 +8909,7 @@ let setup_t =
 
 let setup () = BaseSetup.setup setup_t;;
 
-# 8921 "setup.ml"
+# 8913 "setup.ml"
 let setup_t = BaseCompat.Compat_0_4.adapt_setup_t setup_t
 open BaseCompat.Compat_0_4
 (* OASIS_STOP *)

src/core/CCArray.ml

@@ -212,11 +212,13 @@ let rec find_aux f a i =
     | Some _ as res -> res
     | None -> find_aux f a (i+1)
 
-let find f a =
+let find_map f a = find_aux (fun _ -> f ) a 0
-  find_aux (fun _ -> f ) a 0
 
-let findi f a =
+let find = find_map
-  find_aux f a 0
+
+let find_map_i f a = find_aux f a 0
+
+let findi = find_map_i
 
 let find_idx p a =
   find_aux (fun i x -> if p x then Some (i,x) else None) a 0

src/core/CCArray.mli

@@ -71,30 +71,44 @@ val sorted : ('a -> 'a -> int) -> 'a t -> 'a array
 
 val sort_indices : ('a -> 'a -> int) -> 'a t -> int array
 (** [sort_indices cmp a] returns a new array [b], with the same length as [a],
-    such that [b.(i)] is the index of the [i]-th element of [a] in [sort cmp a].
+    such that [b.(i)] is the index at which the [i]-th element of [sorted cmp a] 
-    In other words, [map (fun i -> a.(i)) (sort_indices a) = sorted cmp a].
+    appears in [a]. [a] is not modified.
-    [a] is not modified.
+
+    In other words, [map (fun i -> a.(i)) (sort_indices cmp a) = sorted cmp a]. 
+    [sort_indices] yields the inverse permutation of {!sort_ranking}.
+
     @since 1.0 *)
 
 val sort_ranking : ('a -> 'a -> int) -> 'a t -> int array
 (** [sort_ranking cmp a] returns a new array [b], with the same length as [a],
-    such that [b.(i)] is the position in [sorted cmp a] of the [i]-th
+    such that [b.(i)] is the index at which the [i]-the element of [a] appears
-    element of [a].
+    in [sorted cmp a]. [a] is not modified.
-    [a] is not modified.
 
     In other words, [map (fun i -> (sorted cmp a).(i)) (sort_ranking cmp a) = a]. 
+    [sort_ranking] yields the inverse permutation of {!sort_indices}.
 
-    Without duplicates, we also have
+    In the absence of duplicate elements in [a], we also have
     [lookup_exn a.(i) (sorted a) = (sorted_ranking a).(i)]
     @since 1.0 *)
 
+val find_map : ('a -> 'b option) -> 'a t -> 'b option
+(** [find_map f a] returns [Some y] if there is an element [x] such
+    that [f x = Some y], else it returns [None]
+    @since 1.3
+*)
+
 val find : ('a -> 'b option) -> 'a t -> 'b option
-(** [find f a] returns [Some y] if there is an element [x] such
+(** Alias to {!find_map}
-    that [f x = Some y], else it returns [None] *)
+    @deprecated since 1.3 *)
+
+val find_map_i : (int -> 'a -> 'b option) -> 'a t -> 'b option
+(** Like {!find_map}, but also pass the index to the predicate function.
+    @since 1.3 *)
 
 val findi : (int -> 'a -> 'b option) -> 'a t -> 'b option
-(** Like {!find}, but also pass the index to the predicate function.
+(** Alias to {!find_map_i}
-    @since 0.3.4 *)
+    @since 0.3.4
+    @deprecated since 1.3 *)
 
 val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option
 (** [find_idx p x] returns [Some (i,x)] where [x] is the [i]-th element of [l],
@@ -107,7 +121,7 @@ val lookup : ?cmp:'a ord -> 'a -> 'a t -> int option
       [Some i] ([i] the index of the key) otherwise *)
 
 val lookup_exn : ?cmp:'a ord -> 'a -> 'a t -> int
-(** Same as {!lookup_exn}, but
+(** Same as {!lookup}, but
     @raise Not_found if the key is not present *)
 
 val bsearch : ?cmp:('a -> 'a -> int) -> 'a -> 'a t ->

src/core/CCArray_slice.mli

@@ -86,20 +86,23 @@ val sorted : ('a -> 'a -> int) -> 'a t -> 'a array
 
 val sort_indices : ('a -> 'a -> int) -> 'a t -> int array
 (** [sort_indices cmp a] returns a new array [b], with the same length as [a],
-    such that [b.(i)] is the index of the [i]-th element of [a] in [sort cmp a].
+    such that [b.(i)] is the index at which the [i]-th element of [sorted cmp a] 
-    In other words, [map (fun i -> a.(i)) (sort_indices a) = sorted cmp a].
+    appears in [a]. [a] is not modified.
-    [a] is not modified.
+
+    In other words, [map (fun i -> a.(i)) (sort_indices cmp a) = sorted cmp a]. 
+    [sort_indices] yields the inverse permutation of {!sort_ranking}.
+
     @since 1.0 *)
 
 val sort_ranking : ('a -> 'a -> int) -> 'a t -> int array
 (** [sort_ranking cmp a] returns a new array [b], with the same length as [a],
-    such that [b.(i)] is the position in [sorted cmp a] of the [i]-th
+    such that [b.(i)] is the index at which the [i]-the element of [a] appears
-    element of [a].
+    in [sorted cmp a]. [a] is not modified.
-    [a] is not modified.
 
     In other words, [map (fun i -> (sorted cmp a).(i)) (sort_ranking cmp a) = a]. 
+    [sort_ranking] yields the inverse permutation of {!sort_indices}.
 
-    Without duplicates, we also have
+    In the absence of duplicate elements in [a], we also have
     [lookup_exn a.(i) (sorted a) = (sorted_ranking a).(i)]
     @since 1.0 *)
 
@@ -122,7 +125,7 @@ val lookup : ?cmp:'a ord -> 'a -> 'a t -> int option
       [Some i] ([i] the index of the key) otherwise *)
 
 val lookup_exn : ?cmp:'a ord -> 'a -> 'a t -> int
-(** Same as {!lookup_exn}, but
+(** Same as {!lookup}, but
     @raise Not_found if the key is not present *)
 
 val bsearch : ?cmp:('a -> 'a -> int) -> 'a -> 'a t ->

src/core/CCBool.ml

@@ -7,7 +7,7 @@ let equal (a:bool) b = a=b
 
 let compare (a:bool) b = Pervasives.compare a b
 
-let negate x = not x
+let negate = not
 
 type 'a printer = Format.formatter -> 'a -> unit
 

src/core/CCBool.mli

@@ -11,7 +11,8 @@ val compare : t -> t -> int
 val equal : t -> t -> bool
 
 val negate : t -> t
-(** Negation on booleans (functional version of [not]) *)
+(** Negation on booleans (functional version of [not])
+    @deprecate since 1.3, simply use {!not} instead *)
 
 type 'a printer = Format.formatter -> 'a -> unit
 

src/core/CCFormat.ml

@@ -77,7 +77,7 @@ let text out (s:string): unit =
 (*$= & ~printer:(fun s->CCFormat.sprintf "%S" s)
   "a\nb\nc" (sprintf_no_color "@[<v>%a@]%!" text "a b c")
   "a b\nc" (sprintf_no_color "@[<h>%a@]%!" text "a b\nc")
-  *)
+*)
 
 let list ?(sep=return ",@ ") pp fmt l =
   let rec pp_list l = match l with

src/core/CCFormat.mli

@@ -311,5 +311,5 @@ module Dump : sig
   val result : 'a t -> ('a, string) Result.result t
   val result' : 'a t -> 'e t -> ('a, 'e) Result.result t
   val to_string : 'a t -> 'a -> string
-  (** Alias to {!to_string} *)
+  (** Alias to {!CCFormat.to_string} *)
 end

src/core/CCList.ml

@@ -366,7 +366,7 @@ let combine l1 l2 =
     if List.length l1=List.length l2 \
     then CCList.combine l1 l2 = List.combine l1 l2 \
     else Q.assume_fail() )
-  *)
+*)
 
 let combine_gen l1 l2 =
   let l1 = ref l1 in
@@ -385,7 +385,38 @@ let combine_gen l1 l2 =
     let res1 = combine (take n l1) (take n l2) in \
     let res2 = combine_gen l1 l2 |> of_gen in \
     res1 = res2)
-  *)
+*)
+
+let split l = 
+  let rec direct i l = match l with 
+    | [] -> [], []
+    | [x1, y1] -> [x1], [y1]
+    | [x1, y1; x2, y2] -> [x1;x2], [y1;y2]
+    | [x1, y1; x2, y2; x3, y3] -> [x1;x2;x3], [y1;y2;y3]
+    | [x1, y1; x2, y2; x3, y3; x4, y4] -> [x1;x2;x3;x4], [y1;y2;y3;y4]
+    | _ when i=0 -> split_slow [] [] l
+    | (x1, y1) :: (x2, y2) :: (x3, y3) :: (x4, y4) :: (x5, y5) :: l' ->
+      let rx, ry = direct (i-1) l' in 
+      x1 :: x2 :: x3 :: x4 :: x5 :: rx,
+      y1 :: y2 :: y3 :: y4 :: y5 :: ry
+  and split_slow acc1 acc2 l = match l with
+    | [] -> List.rev acc1, List.rev acc2
+    | (x1, x2) :: tail ->
+      let acc1 = x1 :: acc1
+      and acc2 = x2 :: acc2 in 
+      split_slow acc1 acc2 tail
+  in 
+  direct direct_depth_default_ l
+
+(*$Q 
+  (Q.(list_of_size Gen.(0--10_000) (pair small_int small_string))) (fun l -> \
+    let (l1, l2) = split l in \
+    List.length l1 = List.length l \
+    && List.length l2 = List.length l)
+
+  Q.(list_of_size Gen.(0--10_000) (pair small_int small_int)) (fun l -> \
+    split l = List.split l)
+*)
 
 let return x = [x]
 
@@ -688,9 +719,9 @@ let take_while p l =
 *)
 
 (*$Q
-  Q.(pair (fun1 small_int bool) (list small_int)) (fun (f,l) -> \
+  Q.(pair (fun1 Observable.int bool) (list small_int)) (fun (f,l) -> \
-    let l1 = take_while f l in \
+    let l1 = take_while (Q.Fn.apply f) l in \
-    List.for_all f l1)
+    List.for_all (Q.Fn.apply f) l1)
 *)
 
 let rec drop_while p l = match l with
@@ -698,8 +729,8 @@ let rec drop_while p l = match l with
   | x :: l' -> if p x then drop_while p l' else l
 
 (*$Q
-  Q.(pair (fun1 small_int bool) (list small_int)) (fun (f,l) -> \
+  Q.(pair (fun1 Observable.int bool) (list small_int)) (fun (f,l) -> \
-    take_while f l @ drop_while f l = l)
+    take_while (Q.Fn.apply f) l @ drop_while (Q.Fn.apply f) l = l)
 *)
 
 let take_drop_while p l =
@@ -720,9 +751,9 @@ let take_drop_while p l =
   direct direct_depth_default_ p l
 
 (*$Q
-  Q.(pair (fun1 small_int bool) (list small_int)) (fun (f,l) -> \
+  Q.(pair (fun1 Observable.int bool) (list small_int)) (fun (f,l) -> \
-    let l1,l2 = take_drop_while f l in \
+    let l1,l2 = take_drop_while (Q.Fn.apply f) l in \
-    (l1 = take_while f l) && (l2 = drop_while f l))
+    (l1 = take_while (Q.Fn.apply f) l) && (l2 = drop_while (Q.Fn.apply f) l))
 *)
 
 let last n l =
@@ -811,6 +842,48 @@ let filter_map f l =
       [ 1; 2; 3; 4; 5; 6 ])
 *)
 
+let keep_some l = filter_map (fun x->x) l
+
+let keep_ok l =
+  filter_map
+    (function
+      | Result.Ok x -> Some x
+      | Result.Error _ -> None)
+    l
+
+let all_some l =
+  try Some (map (function Some x -> x | None -> raise Exit) l)
+  with Exit -> None
+
+(*$=
+  (Some []) (all_some [])
+  (Some [1;2;3]) (all_some [Some 1; Some 2; Some 3])
+  None (all_some [Some 1; None; None; Some 4])
+*)
+
+let all_ok l =
+  let err = ref None in
+  try
+    Result.Ok
+      (map
+         (function Result.Ok x -> x | Error e -> err := Some e; raise Exit)
+         l)
+  with Exit ->
+    begin match !err with
+      | None -> assert false
+      | Some e -> Result.Error e
+    end
+
+(*$inject
+  open Result
+*)
+
+(*$=
+  (Ok []) (all_ok [])
+  (Ok [1;2;3]) (all_ok [Ok 1; Ok 2; Ok 3])
+  (Error "e2") (all_ok [Ok 1; Error "e2"; Error "e3"; Ok 4])
+*)
+
 let mem ?(eq=(=)) x l =
   let rec search eq x l = match l with
     | [] -> false

src/core/CCList.mli

@@ -92,6 +92,9 @@ val combine_gen : 'a list -> 'b list -> ('a * 'b) gen
     instead, the output has as many pairs as the smallest input list.
     @since 1.2 *)
 
+val split : ('a * 'b) t -> 'a t * 'b t 
+(** A tail-recursive version of {!List.split}. *)
+
 val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
 
 val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
@@ -247,6 +250,26 @@ val remove : ?eq:('a -> 'a -> bool) -> x:'a -> 'a t -> 'a t
 val filter_map : ('a -> 'b option) -> 'a t -> 'b t
 (** Map and remove elements at the same time *)
 
+val keep_some : 'a option t -> 'a t
+(** [filter_some l] retains only elements of the form [Some x].
+    Same as [filter_map CCFun.id]
+    @since 1.3 *)
+
+val keep_ok : ('a, _) Result.result t -> 'a t
+(** [filter_some l] retains only elements of the form [Some x].
+    Same as [filter_map CCFun.id]
+    @since 1.3 *)
+
+val all_some : 'a option t -> 'a t option
+(** [all_some l] returns [Some l'] if all elements of [l] are of the form [Some x],
+    or [None] otherwise.
+    @since 1.3 *)
+
+val all_ok : ('a, 'err) Result.result t -> ('a t, 'err) Result.result
+(** [all_ok l] returns [Ok l'] if all elements of [l] are of the form [Ok x],
+    or [Error e] otherwise (with the first error met).
+    @since 1.3 *)
+
 val sorted_merge : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
 (** Merges elements from both sorted list *)
 
@@ -498,3 +521,5 @@ end
 
 val pp : ?start:string -> ?stop:string -> ?sep:string ->
   'a printer -> 'a t printer
+
+(** {2 Lists of pairs} *)

src/core/CCResult.ml

@@ -129,7 +129,7 @@ let fold_ok f acc r = match r with
 (*$=
   42 (fold_ok (+) 2 (Ok 40))
   40 (fold_ok (+) 40 (Error "foo"))
-  *)
+*)
 
 let is_ok = function
   | Ok _ -> true

src/core/CCString.cppo.ml

@@ -414,6 +414,44 @@ let compare_versions a b =
   in
   cmp_rec (Split.gen_cpy ~by:"." a) (Split.gen_cpy ~by:"." b)
 
+type nat_chunk =
+  | NC_char of char
+  | NC_int of int
+
+let compare_natural a b =
+  (* stream of chunks *)
+  let chunks s : unit -> nat_chunk option =
+    let i = ref 0 in
+    let rec next () =
+      if !i = length s then None
+      else match String.get s !i with
+        | '0'..'9' as c -> incr i; read_int (Char.code c - Char.code '0')
+        | c -> incr i; Some (NC_char c)
+    and read_int n =
+      if !i = length s then Some (NC_int n)
+      else match String.get s !i with
+        | '0'..'9' as c -> incr i; read_int (10 * n + Char.code c - Char.code '0')
+        | _ -> Some (NC_int n)
+    in
+    next
+  in
+  let rec cmp_rec a b = match a(), b() with
+    | None, None -> 0
+    | Some _, None -> 1
+    | None, Some _ -> -1
+    | Some x, Some y ->
+      match x, y with
+        | NC_char x, NC_char y ->
+          let c = Char.compare x y in
+          if c<>0 then c else cmp_rec a b
+        | NC_int _, NC_char _ -> 1
+        | NC_char _, NC_int _ -> -1
+        | NC_int x, NC_int y ->
+          let c = Pervasives.compare x y in
+          if c<>0 then c else cmp_rec a b
+  in
+  cmp_rec (chunks a) (chunks b)
+
 let edit_distance s1 s2 =
   if length s1 = 0
   then length s2

src/core/CCString.mli

@@ -375,7 +375,7 @@ val rtrim : t -> t
   Q.(printable_string) (fun s -> \
     let s' = rtrim s in \
     if s'="" then Q.assume_fail() else s'.[String.length s'-1] <> ' ')
-  *)
+*)
 
 (** {2 Operations on 2 strings} *)
 
@@ -578,6 +578,29 @@ val compare_versions : string -> string -> int
     CCOrd.equiv (compare_versions a b) (CCOrd.opp compare_versions b a))
 *)
 
+val compare_natural : string -> string -> int
+(** Natural Sort Order, comparing chunks of digits as natural numbers.
+    https://en.wikipedia.org/wiki/Natural_sort_order
+    @since 1.3 *)
+
+(*$T
+  compare_natural "foo1" "foo2" < 0
+  compare_natural "foo11" "foo2" > 0
+  compare_natural "foo11" "foo11" = 0
+  compare_natural "foo011" "foo11" = 0
+  compare_natural "foo1a" "foo1b" < 0
+  compare_natural "foo1a1" "foo1a2" < 0
+  compare_natural "foo1a17" "foo1a2" > 0
+*)
+
+(*Q
+  (Q.pair printable_string printable_string) (fun (a,b) -> \
+    CCOrd.opp (compare_natural a b) = compare_natural b a)
+  (Q.printable_string) (fun a -> compare_natural a a = 0)
+  (Q.triple printable_string printable_string printable_string) (fun (a,b,c) -> \
+    if compare_natural a b < 0 && compare_natural b c < 0 \
+    then compare_natural a c < 0 else Q.assume_fail())
+*)
 
 val edit_distance : string -> string -> int
 (** Edition distance between two strings. This satisfies the classical

src/core/META

@@ -1,6 +1,6 @@
 # OASIS_START
-# DO NOT EDIT (digest: 1e93f21c6208d4f0718882bfffe34612)
+# DO NOT EDIT (digest: 2c23f3e7c83e14a0b87e7d6bb7df91bd)
-version = "1.2"
+version = "1.3"
 description = "A modular standard library focused on data structures."
 requires = "bytes result"
 archive(byte) = "containers.cma"
@@ -9,7 +9,7 @@ archive(native) = "containers.cmxa"
 archive(native, plugin) = "containers.cmxs"
 exists_if = "containers.cma"
 package "unix" (
- version = "1.2"
+ version = "1.3"
  description = "A modular standard library focused on data structures."
  requires = "bytes result unix"
  archive(byte) = "containers_unix.cma"
@@ -20,7 +20,7 @@ package "unix" (
 )
 
 package "top" (
- version = "1.2"
+ version = "1.3"
  description = "A modular standard library focused on data structures."
  requires =
  "compiler-libs.common containers containers.data containers.unix containers.sexp containers.iter"
@@ -32,7 +32,7 @@ package "top" (
 )
 
 package "thread" (
- version = "1.2"
+ version = "1.3"
  description = "A modular standard library focused on data structures."
  requires = "containers threads"
  archive(byte) = "containers_thread.cma"
@@ -43,7 +43,7 @@ package "thread" (
 )
 
 package "sexp" (
- version = "1.2"
+ version = "1.3"
  description = "A modular standard library focused on data structures."
  requires = "bytes result"
  archive(byte) = "containers_sexp.cma"
@@ -54,7 +54,7 @@ package "sexp" (
 )
 
 package "iter" (
- version = "1.2"
+ version = "1.3"
  description = "A modular standard library focused on data structures."
  archive(byte) = "containers_iter.cma"
  archive(byte, plugin) = "containers_iter.cma"
@@ -64,7 +64,7 @@ package "iter" (
 )
 
 package "data" (
- version = "1.2"
+ version = "1.3"
  description = "A modular standard library focused on data structures."
  requires = "bytes"
  archive(byte) = "containers_data.cma"

src/data/CCBV.ml

@@ -269,7 +269,7 @@ let iter bv f =
     let bv = create ~size:n true in \
     let l = iter bv |> Sequence.zip |> Sequence.to_list in \
     List.length l = n && List.for_all (fun (_,b) -> b) l)
-  *)
+*)
 
 let iter_true bv f =
   iter bv (fun i b -> if b then f i else ())

src/data/CCBV.mli

@@ -86,7 +86,7 @@ val first : t -> int option
     changed type at 1.2 *)
 
 val first_exn : t -> int
- (** First set bit, or
+(** First set bit, or
     @raise Not_found if all bits are 0
     @since 1.2 *)
 

src/data/CCCache.ml

@@ -1,27 +1,5 @@
-(*
-Copyright (c) 2013, Simon Cruanes
-All rights reserved.
 
-Redistribution and use in source and binary forms, with or without
+(* This file is free software, part of containers. See file "license" for more details. *)
-modification, are permitted provided that the following conditions are met:
-
-Redistributions of source code must retain the above copyright notice, this
-list of conditions and the following disclaimer.  Redistributions in binary
-form must reproduce the above copyright notice, this list of conditions and the
-following disclaimer in the documentation and/or other materials provided with
-the distribution.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*)
 
 (** {1 Caches} *)
 
@@ -48,18 +26,25 @@ type ('a,'b) t = {
   clear : unit -> unit;
 }
 
+type ('a, 'b) callback = in_cache:bool -> 'a -> 'b -> unit
+
 let clear c = c.clear ()
 
-let with_cache c f x =
+let default_callback_ ~in_cache:_ _ _ = ()
+
+let with_cache ?(cb=default_callback_) c f x =
   try
-    c.get x
+    let y = c.get x in
+    cb ~in_cache:true x y;
+    y
   with Not_found ->
     let y = f x in
     c.set x y;
+    cb ~in_cache:false x y;
     y
 
-let with_cache_rec c f =
+let with_cache_rec ?(cb=default_callback_) c f =
-  let rec f' x = with_cache c (f f') x in
+  let rec f' x = with_cache ~cb c (f f') x in
   f'
 
 (*$R

src/data/CCCache.mli

@@ -1,27 +1,5 @@
-(*
-Copyright (c) 2013, Simon Cruanes
-All rights reserved.
 
-Redistribution and use in source and binary forms, with or without
+(* This file is free software, part of containers. See file "license" for more details. *)
-modification, are permitted provided that the following conditions are met:
-
-Redistributions of source code must retain the above copyright notice, this
-list of conditions and the following disclaimer.  Redistributions in binary
-form must reproduce the above copyright notice, this list of conditions and the
-following disclaimer in the documentation and/or other materials provided with
-the distribution.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-*)
 
 (** {1 Caches}
 
@@ -53,13 +31,22 @@ type ('a, 'b) t
 val clear : (_,_) t -> unit
 (** Clear the content of the cache *)
 
-val with_cache : ('a, 'b) t -> ('a -> 'b) -> 'a -> 'b
+type ('a, 'b) callback = in_cache:bool -> 'a -> 'b -> unit
+(** Type of the callback that is called once a cached value is found
+    or not.
+    Should never raise.
+    @param in_cache is [true] if the value was in cache, [false]
+      if the value was just produced.
+    @since 1.3 *)
+
+val with_cache : ?cb:('a, 'b) callback -> ('a, 'b) t -> ('a -> 'b) -> 'a -> 'b
 (** [with_cache c f] behaves like [f], but caches calls to [f] in the
     cache [c]. It always returns the same value as
     [f x], if [f x] returns, or raise the same exception.
-    However, [f] may not be called if [x] is in the cache. *)
+    However, [f] may not be called if [x] is in the cache.
+    @param cb called after the value is generated or retrieved *)
 
-val with_cache_rec : ('a,'b) t -> (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b
+val with_cache_rec : ?cb:('a, 'b) callback -> ('a,'b) t -> (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b
 (** [with_cache_rec c f] is a function that first, applies [f] to
     some [f' = fix f], such that recursive calls to [f'] are cached in [c].
     It is similar to {!with_cache} but with a function that takes as
@@ -74,6 +61,7 @@ val with_cache_rec : ('a,'b) t -> (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b
 
       fib 70;;
     ]}
+    @param cb called after the value is generated or retrieved
 *)
 
 val size : (_,_) t -> int

src/data/CCIntMap.ml

@@ -361,8 +361,8 @@ let rec inter f a b =
         else inter f r1 b
       else if Bit.lt m1 m2 && is_prefix_ ~prefix:p2 p1 ~bit:m2
       then if Bit.is_0 p1 ~bit:m2
-      then inter f l2 a
+        then inter f a l2
-      else inter f r2 a
+        else inter f a r2
       else E
 
 (*$R
@@ -541,3 +541,170 @@ let print pp_x out m =
        Format.pp_print_cut out ()
     ) m;
   Format.fprintf out "}@]"
+
+(* Some thorough tests from Jan Midtgaar
+   https://github.com/jmid/qc-ptrees
+*)
+
+(*$inject
+  let test_count = 2_500
+
+  open QCheck
+
+  type instr_tree =
+    | Empty
+    | Singleton of int * int
+    | Add of int * int * instr_tree
+    | Remove of int * instr_tree
+    | Union of instr_tree * instr_tree
+    | Inter of instr_tree * instr_tree
+
+  let rec to_string (a:instr_tree): string =
+    let int_to_string = string_of_int in
+    match a with
+    | Empty -> "Empty"
+    | Singleton (k,v) -> Printf.sprintf "Singleton(%d,%d)" k v
+    | Add (k,v,t) -> Printf.sprintf "Add(%d,%d," k v ^ (to_string t) ^ ")"
+    | Remove (n,t) -> "Remove (" ^ (int_to_string n) ^ ", " ^ (to_string t) ^ ")"
+    | Union (t,t') -> "Union (" ^ (to_string t) ^ ", " ^ (to_string t') ^ ")"
+    | Inter (t,t') -> "Inter (" ^ (to_string t) ^ ", " ^ (to_string t') ^ ")"
+
+  let merge_f _ x y = min x y
+
+  let rec interpret t : _ t = match t with
+    | Empty -> empty
+    | Singleton (k,v)  -> singleton k v
+    | Add (k,v,t) -> add k v (interpret t)
+    | Remove (n,t) -> remove n (interpret t)
+    | Union (t,t') ->
+      let s  = interpret t in
+      let s' = interpret t' in
+      union merge_f s s'
+    | Inter (t,t') ->
+      let s  = interpret t in
+      let s' = interpret t' in
+      inter merge_f s s'
+
+  let tree_gen int_gen : instr_tree Q.Gen.t =
+    let open Gen in
+    sized
+      (fix (fun recgen n -> match n with
+        | 0 -> oneof [return Empty;
+                      Gen.map2 (fun i j -> Singleton (i,j)) int_gen int_gen]
+        | _ ->
+          frequency
+            [ (1, return Empty);
+              (1, map2 (fun k v -> Singleton (k,v)) int_gen int_gen);
+              (2, map3 (fun i j t -> Add (i,j,t)) int_gen int_gen (recgen (n-1)));
+              (2, map2 (fun i t -> Remove (i,t)) int_gen (recgen (n-1)));
+              (2, map2 (fun l r -> Union (l,r)) (recgen (n/2)) (recgen (n/2)));
+              (2, map2 (fun l r -> Inter (l,r)) (recgen (n/2)) (recgen (n/2)));
+            ]))
+
+  let (<+>) = Q.Iter.(<+>)
+
+  let rec tshrink t : instr_tree Q.Iter.t = match t with
+    | Empty -> Iter.empty
+    | Singleton (k,v) ->
+      (Iter.return Empty)
+      <+> (Iter.map (fun k' -> Singleton (k',v)) (Shrink.int k))
+      <+> (Iter.map (fun v' -> Singleton (k,v')) (Shrink.int v))
+    | Add (k,v,t) ->
+      (Iter.of_list [Empty; t; Singleton (k,v)])
+      <+> (Iter.map (fun t' -> Add (k,v,t')) (tshrink t))
+      <+> (Iter.map (fun k' -> Add (k',v,t)) (Shrink.int k))
+      <+> (Iter.map (fun v' -> Add (k,v',t)) (Shrink.int v))
+    | Remove (i,t) ->
+      (Iter.of_list [Empty; t])
+      <+> (Iter.map (fun t' -> Remove (i,t')) (tshrink t))
+      <+> (Iter.map (fun i' -> Remove (i',t)) (Shrink.int i))
+    | Union (t0,t1) ->
+      (Iter.of_list [Empty;t0;t1])
+      <+> (Iter.map (fun t0' -> Union (t0',t1)) (tshrink t0))
+      <+> (Iter.map (fun t1' -> Union (t0,t1')) (tshrink t1))
+    | Inter (t0,t1) ->
+      (Iter.of_list [Empty;t0;t1])
+      <+> (Iter.map (fun t0' -> Inter (t0',t1)) (tshrink t0))
+      <+> (Iter.map (fun t1' -> Inter (t0,t1')) (tshrink t1))
+
+  let arb_int =
+    frequency
+      [(5,small_signed_int);
+       (3,int);
+       (1, oneofl [min_int;max_int])]
+
+  let arb_tree =
+    make ~print:to_string ~shrink:tshrink
+      (tree_gen arb_int.gen)
+
+  let empty_m = []
+  let singleton_m k v = [k,v]
+  let mem_m i s = List.mem_assoc i s
+  let rec remove_m i s = match s with
+    | [] -> []
+    | (j,v)::s' -> if i=j then s' else (j,v)::(remove_m i s')
+  let add_m k v s = List.sort Pervasives.compare ((k,v)::remove_m k s)
+  let rec union_m s s' = match s,s' with
+    | [], _ -> s'
+    | _, [] -> s
+    | (k1,v1)::is,(k2,v2)::js ->
+        if k1<k2 then (k1,v1)::(union_m is s') else
+        if k1>k2 then (k2,v2)::(union_m s js) else
+        (k1,min v1 v2)::(union_m is js)
+  let rec inter_m s s' = match s with
+    | [] -> []
+    | (k,v)::s ->
+      if List.mem_assoc k s'
+      then (k,min v (List.assoc k s'))::(inter_m s s')
+      else inter_m s s'
+
+  let abstract s = List.sort Pervasives.compare (fold (fun k v acc -> (k,v)::acc) s [])
+*)
+
+(* A bunch of agreement properties *)
+
+(*$=
+  empty_m (let s = empty in abstract s)
+*)
+
+(*$QR & ~count:test_count
+  (Q.pair arb_int arb_int) (fun (k,v) ->
+    abstract (singleton k v) = singleton_m k v)
+*)
+
+(*$QR & ~count:test_count
+  Q.(pair arb_tree arb_int)
+      (fun (t,n) ->
+        let s = interpret t in
+        mem n s = mem_m n (abstract s))
+*)
+
+(*$QR & ~count:test_count
+  (triple arb_tree arb_int arb_int)
+    (fun (t,k,v) ->
+      let s = interpret t in
+      abstract (add k v s) = add_m k v (abstract s))
+*)
+
+(*$QR & ~count:test_count
+  (pair arb_tree arb_int)
+    (fun (t,n) ->
+      let s = interpret t in
+      abstract (remove n s) = remove_m n (abstract s))
+*)
+
+(*$QR & ~count:test_count
+  (pair arb_tree arb_tree)
+  (fun (t,t') ->
+    let s  = interpret t in
+    let s' = interpret t' in
+    abstract (union merge_f s s') = union_m (abstract s) (abstract s'))
+*)
+
+(*$QR & ~count:test_count
+  Q.(pair arb_tree arb_tree)
+    (fun (t,t') ->
+      let s  = interpret t in
+      let s' = interpret t' in
+      abstract (inter merge_f s s') = inter_m (abstract s) (abstract s'))
+*)

src/data/CCRAL.ml

@@ -151,7 +151,8 @@ let mapi ~f l =
 *)
 
 (*$Q
-  Q.(pair (list small_int)(fun2 int int bool)) (fun (l,f) -> \
+  Q.(pair (list small_int)(fun2 Observable.int Observable.int bool)) (fun (l,f) -> \
+    let f = Q.Fn.apply f in \
     mapi ~f (of_list l) |> to_list = List.mapi f l )
 *)
 

src/data/CCRingBuffer.ml

@@ -1,26 +1,13 @@
-(*
- * CCRingBuffer - Polymorphic circular buffer with
- * deque semantics for accessing both the head and tail.
- *
- * Copyright (C) 2015 Simon Cruanes, Carmelo Piccione
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version,
- * with the special exception on linking described in file LICENSE.
- *
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
- *)
 
-(** Polymorphic Circular Buffer for IO *)
+(* This file is free software, part of containers. See file "license" for more details. *)
+
+(* Copyright (C) 2015 Simon Cruanes, Carmelo Piccione *)
+
+(** Generic Circular Buffer for IO, with bulk operations.
+    The bulk operations (e.g. based on {!Array.blit} or {!Bytes.blit})
+    are more efficient than item-by-item copy.
+
+    See https://en.wikipedia.org/wiki/Circular_buffer for an overview. *)
 
 module Array = struct
   (** The abstract type for arrays *)
@@ -31,11 +18,8 @@ module Array = struct
     (** The type of an array instance *)
     type t
 
-    val empty : t
+    val create : int -> t
-    (** The empty array *)
+    (** Make an array of the given size, filled with dummy elements *)
-
-    val make: int -> elt -> t
-    (** [make s e] makes an array of size [s] with [e] elements *)
 
     val length: t -> int
     (** [length t] gets the total number of elements currently in [t] *)
@@ -68,11 +52,11 @@ module Array = struct
     include Bytes
   end
 
-  module Make(Elt:sig type t end) :
+  module Make(Elt:sig type t val dummy : t end) :
     S with type elt = Elt.t and type t = Elt.t array = struct
     type elt = Elt.t
     type t = Elt.t array
-    let make = Array.make
+    let create size = Array.make size Elt.dummy
     let length = Array.length
     let get = Array.get
     let set = Array.set
@@ -80,7 +64,6 @@ module Array = struct
     let blit = Array.blit
     let iter = Array.iter
     let sub = Array.sub
-    let empty = Array.of_list []
   end
 end
 
@@ -88,16 +71,17 @@ module type S = sig
   (** The module type of Array for this ring buffer *)
   module Array : Array.S
 
-  (** Defines the ring buffer type, with both bounded and
+  (** Defines the bounded ring buffer type *)
-      unbounded flavors *)
   type t
 
   (** Raised in querying functions when the buffer is empty *)
   exception Empty
 
-  val create : ?bounded:bool -> int -> t
+  val create : int -> t
-  (** [create ?bounded size] creates a new buffer with given size.
+  (** [create size] creates a new bounded buffer with given size.
-      Defaults to [bounded=false]. *)
+      The underlying array is allocated immediately and no further (large)
+      allocation will happen from now on.
+      @raise Invalid_argument if the arguments is [< 1] *)
 
   val copy : t -> t
   (** Make a fresh copy of the buffer. *)
@@ -105,26 +89,29 @@ module type S = sig
   val capacity : t -> int
   (** Length of the inner buffer. *)
 
-  val max_capacity : t -> int option
-  (** Maximum length of the inner buffer, or [None] if unbounded. *)
-
   val length : t -> int
   (** Number of elements currently stored in the buffer. *)
 
+  val is_full : t -> bool
+  (** true if pushing an element would erase another element.
+      @since 1.3 *)
+
   val blit_from : t -> Array.t -> int -> int -> unit
   (** [blit_from buf from_buf o len] copies the slice [o, ... o + len - 1] from
       a input buffer [from_buf] to the end of the buffer.
+      If the slice is too large for the buffer, only the last part of the array
+      will be copied.
       @raise Invalid_argument if [o,len] is not a valid slice of [s] *)
 
   val blit_into : t -> Array.t -> int -> int -> int
   (** [blit_into buf to_buf o len] copies at most [len] elements from [buf]
       into [to_buf] starting at offset [o] in [s].
       @return the number of elements actually copied ([min len (length buf)]).
-      @raise Invalid_argument if [o,len] is not a valid slice of [s] *)
+      @raise Invalid_argument if [o,len] is not a valid slice of [s]. *)
 
   val append : t -> into:t -> unit
   (** [append b ~into] copies all data from [b] and adds it at the
-      end of [into] *)
+      end of [into]. Erases data of [into] if there is not enough room. *)
 
   val to_list : t -> Array.elt list
   (** Extract the current content into a list *)
@@ -132,9 +119,6 @@ module type S = sig
   val clear : t -> unit
   (** Clear the content of the buffer. Doesn't actually destroy the content. *)
 
-  val reset : t -> unit
-  (** Clear the content of the buffer, and also resize it to a default size *)
-
   val is_empty :t -> bool
   (** Is the buffer empty (i.e. contains no elements)? *)
 
@@ -172,70 +156,74 @@ module type S = sig
       If [t.bounded=false], the buffer will grow as needed,
       otherwise the oldest elements are replaced first. *)
 
-  val peek_front : t -> Array.elt
+  val peek_front : t -> Array.elt option
-  (** First value from front of [t].
+  (** First value from front of [t], without modification. *)
-      @raise Empty if buffer is empty. *)
 
-  val peek_back : t -> Array.elt
+  val peek_front_exn : t -> Array.elt
-  (** Get the last value from back of [t].
+  (** First value from front of [t], without modification.
-      @raise Empty if buffer is empty. *)
+      @raise Empty if buffer is empty.
+      @since 1.3 *)
+
+  val peek_back : t -> Array.elt option
+  (** Get the last value from back of [t], without modification. *)
+
+  val peek_back_exn : t -> Array.elt
+  (** Get the last value from back of [t], without modification.
+      @raise Empty if buffer is empty.
+      @since 1.3 *)
 
   val take_back : t -> Array.elt option
-  (** Take the last value from back of [t], if any *)
+  (** Take and remove the last value from back of [t], if any *)
 
   val take_back_exn : t -> Array.elt
-  (** Take the last value from back of [t].
+  (** Take and remove the last value from back of [t].
       @raise Empty if buffer is already empty. *)
 
   val take_front : t -> Array.elt option
-  (** Take the first value from front of [t], if any *)
+  (** Take and remove the first value from front of [t], if any *)
 
   val take_front_exn : t -> Array.elt
-  (** Take the first value from front of [t].
+  (** Take and remove the first value from front of [t].
       @raise Empty if buffer is already empty. *)
 
   val of_array : Array.t -> t
   (** Create a buffer from an initial array, but doesn't take ownership
-      of it (stills allocates a new internal array) *)
+      of it (stills allocates a new internal array)
+      @since 0.11 *)
 
   val to_array : t -> Array.t
   (** Create an array from the elements, in order.
       @since 0.11 *)
 end
 
-module MakeFromArray(A:Array.S) = struct
+(*$inject
+  open Q.Gen
+  let g_char = map Char.chr (Char.code 'A' -- Char.code 'z')
+  let g_str = string_size ~gen:g_char (0--10)
+  let a_str = {Q.string with Q.gen=g_str}
+*)
+
+module MakeFromArray(A:Array.S) : S with module Array = A = struct
   module Array = A
 
   type t = {
     mutable start : int;
     mutable stop : int; (* excluded *)
-    mutable buf : Array.t;
+    buf : Array.t;
-    bounded : bool;
-    size : int
   }
 
   exception Empty
 
-  let create ?(bounded=false) size =
+  let create size =
+    if size < 1 then invalid_arg "CCRingBuffer.create";
     { start=0;
       stop=0;
-      bounded;
+      buf = A.create (size+1);  (* keep room for extra slot *)
-      size;
-      buf = A.empty
     }
 
   let copy b =
     { b with buf=A.copy b.buf; }
 
-  (*$Q
-    Q.printable_string (fun s -> let s = Bytes.of_string s in \
-    let s_len = Bytes.length s in \
-    let b = Byte.create s_len in \
-    Byte.blit_from b s 0 s_len; \
-    let b' = Byte.copy b in \
-    try Byte.iteri b (fun i c -> if Byte.get_front b' i <> c then raise Exit); true with Exit -> false)
-  *)
-
   (*$T
     let b = Byte.of_array (Bytes.of_string "abc") in \
     let b' = Byte.copy b in \
@@ -248,172 +236,103 @@ module MakeFromArray(A:Array.S) = struct
     match len with 0 -> 0 | l -> l - 1
 
   (*$Q
-    Q.printable_string (fun s -> let s = Bytes.of_string s in \
+    a_str (fun s -> let s = Bytes.of_string s in \
     let s_len = Bytes.length s in \
-    let b = Byte.create s_len in \
+    let b = Byte.create (max s_len 64) in \
     Byte.blit_from b s 0 s_len; \
     Byte.capacity b >= s_len)
   *)
 
-  (*$Q
-    (Q.pair Q.small_int Q.printable_string) (fun (i, s) -> let s = Bytes.of_string s in \
-    let i = abs i in \
-    let s_len = Bytes.length s in \
-    let b = Byte.create ~bounded:true i in \
-    Byte.blit_from b s 0 s_len; \
-    Byte.capacity b <= i)
-  *)
-
-  let max_capacity b = if b.bounded then Some b.size else None
-
-  (*$Q
-    Q.small_int (fun i -> \
-    let i = abs i in \
-    let b = Byte.create i in \
-    Byte.max_capacity b = None)
-  *)
-
-  (*$Q
-    Q.small_int (fun i -> \
-    let i = abs i in \
-    let b = Byte.create ~bounded:true i in \
-    Byte.max_capacity b = Some i)
-  *)
-
   let length b =
     if b.stop >= b.start
     then b.stop - b.start
     else (A.length b.buf - b.start) + b.stop
 
-  (*$Q
+  let is_full b = length b + 1 = Array.length b.buf
-    (Q.pair Q.small_int Q.printable_string) (fun (i, s) -> let s = Bytes.of_string s in \
-    let i = abs i in \
-    let s_len = Bytes.length s in \
-    let b = Byte.create i in \
-    Byte.blit_from b s 0 s_len; \
-    Byte.length b = s_len)
-  *)
 
-  (*$Q
+  let next_ b i =
-    (Q.pair Q.small_int Q.printable_string) (fun (i, s) -> let s = Bytes.of_string s in \
+    let j = i+1 in
-    let i = abs i in \
+    if j = A.length b.buf then 0 else j
-    let s_len = Bytes.length s in \
-    let b = Byte.create ~bounded:true i in \
-    Byte.blit_from b s 0 s_len; \
-    Byte.length b >= 0 && Byte.length b <= i)
-  *)
 
-  (* resize [b] so that inner capacity is [cap] *)
+  let incr_start_ b = b.start <- next_ b b.start
-  let resize b cap elem =
+  let incr_stop_ b = b.stop <- next_ b b.stop
-    assert (cap >= A.length b.buf);
-    let buf' = A.make cap elem in
-    (* copy into buf' *)
-    if b.stop >= b.start
-    then
-      A.blit b.buf b.start buf' 0 (b.stop - b.start)
-    else begin
-      let len_end = A.length b.buf - b.start in
-      A.blit b.buf b.start buf' 0 len_end;
-      A.blit b.buf 0 buf' len_end b.stop;
-    end;
-    b.buf <- buf'
 
-  let blit_from_bounded b from_buf o len =
+  let push_back b e =
-    let cap = capacity b - length b in
+    A.set b.buf b.stop e;
-    (* resize if needed, with a constant to amortize *)
+    incr_stop_ b;
-    if cap < len then (
+    if b.start = b.stop then incr_start_ b; (* overwritten one element *)
-      let new_size =
-        let desired = A.length b.buf + len + 24 in
-        min (b.size+1) desired in
-      resize b new_size (A.get from_buf 0);
-      let good = capacity b = b.size || capacity b - length b >= len in
-      assert good;
-    );
-    let sub = A.sub from_buf o len in
-    let iter x =
-      let capacity = A.length b.buf in
-      A.set b.buf b.stop x;
-      if b.stop = capacity-1 then b.stop <- 0 else b.stop <- b.stop + 1;
-      if b.start = b.stop then
-        if b.start = capacity-1 then b.start <- 0 else b.start <- b.start + 1
-    in
-    A.iter iter sub
-
-
-  let blit_from_unbounded b from_buf o len =
-    let cap = capacity b - length b in
-    (* resize if needed, with a constant to amortize *)
-    if cap < len
-    then resize b (max (b.size+1) (A.length b.buf + len + 24)) (A.get from_buf 0);
-    let good = capacity b - length b >= len in
-    assert good;
-    if b.stop >= b.start
-    then (*  [_______ start xxxxxxxxx stop ______] *)
-      let len_end = A.length b.buf - b.stop in
-      if len_end >= len
-      then (A.blit from_buf o b.buf b.stop len;
-        b.stop <- b.stop + len)
-      else (A.blit from_buf o b.buf b.stop len_end;
-        A.blit from_buf (o+len_end) b.buf 0 (len-len_end);
-        b.stop <- len-len_end)
-    else begin (* [xxxxx stop ____________ start xxxxxx] *)
-      let len_middle = b.start - b.stop in
-      assert (len_middle >= len);
-      A.blit from_buf o b.buf b.stop len;
-      b.stop <- b.stop + len
-    end;
     ()
 
   let blit_from b from_buf o len =
-    if A.length from_buf = 0 then () else
+    if len = 0 then ()
-    if b.bounded then
+    else if o + len > A.length from_buf then invalid_arg "CCRingBuffer.blit_from"
-      blit_from_bounded b from_buf o len
+    else (
-    else
+      for i=o to o+len-1 do
-      blit_from_unbounded b from_buf o len
+        push_back b (A.get from_buf i)
+      done
+    )
 
   (*$Q
-    (Q.pair Q.printable_string Q.printable_string) (fun (s,s') -> \
+    a_str (fun s -> let s = Bytes.of_string s in \
+    let s_len = Bytes.length s in \
+    let b = Byte.create (max s_len 64) in \
+    Byte.blit_from b s 0 s_len; \
+    let b' = Byte.copy b in \
+    try Byte.iteri b (fun i c -> if Byte.get_front b' i <> c then raise Exit); true with Exit -> false)
+  *)
+
+  (*$Q
+    a_str (fun s -> let s = Bytes.of_string s in \
+    let s_len = Bytes.length s in \
+    let b = Byte.create (max s_len 64) in \
+    Byte.blit_from b s 0 s_len; \
+    Byte.push_back b 'X'; \
+    Byte.peek_back_exn b = 'X')
+  *)
+
+  (*$Q
+    (Q.pair a_str a_str) (fun (s,s') -> \
+    let b = Byte.create (max (String.length s+String.length s') 64) in \
     let s = Bytes.of_string s in let s' = Bytes.of_string s' in  \
-    (let b = Byte.create 24 in \
     Byte.blit_from b s 0 (Bytes.length s); \
     Byte.blit_from b s' 0 (Bytes.length s'); \
-    Byte.length b = Bytes.length s + Bytes.length s'))
+    Byte.length b = Bytes.length s + Bytes.length s')
   *)
 
 
   (*$Q
-    (Q.pair Q.printable_string Q.printable_string) (fun (s,s') -> \
+    (Q.pair a_str a_str) (fun (s,s') -> \
     let s = Bytes.of_string s in let s' = Bytes.of_string s' in  \
-    (let b = Byte.create ~bounded:true (Bytes.length s + Bytes.length s') in \
+    let b = Byte.create (max (Bytes.length s + Bytes.length s') 64) in \
     Byte.blit_from b s 0 (Bytes.length s); \
     Byte.blit_from b s' 0 (Bytes.length s'); \
-    Byte.length b = Bytes.length s + Bytes.length s'))
+    Byte.length b = Bytes.length s + Bytes.length s')
   *)
 
 
   let blit_into b to_buf o len =
-    if o+len > A.length to_buf
+    if o+len > A.length to_buf then (
-    then invalid_arg "CCRingBuffer.blit_into";
+      invalid_arg "CCRingBuffer.blit_into";
-    if b.stop >= b.start
+    );
-    then
+    if b.stop >= b.start then (
       let n = min (b.stop - b.start) len in
-      let _ = A.blit b.buf b.start to_buf o n in
+      A.blit b.buf b.start to_buf o n;
       n
-    else begin
+    ) else (
       let len_end = A.length b.buf - b.start in
       A.blit b.buf b.start to_buf o (min len_end len);
       if len_end >= len
       then len  (* done *)
-      else begin
+      else (
         let n = min b.stop (len - len_end) in
         A.blit b.buf 0 to_buf (o+len_end) n;
         n + len_end
-      end
+      )
-    end
+    )
 
   (*$Q
-    Q.printable_string (fun s -> let s = Bytes.of_string s in \
+    a_str (fun s -> let s = Bytes.of_string s in \
-    let b = Byte.create (Bytes.length s) in \
+    let b = Byte.create (max 64 (Bytes.length s)) in \
     Byte.blit_from b s 0 (Bytes.length s); \
     let to_buf = Bytes.create (Bytes.length s) in \
     let len = Byte.blit_into b to_buf 0 (Bytes.length s) in \
@@ -426,35 +345,20 @@ module MakeFromArray(A:Array.S) = struct
     ()
 
   (*$Q
-    Q.printable_string (fun s -> let s = Bytes.of_string s in \
+    a_str (fun s -> let s = Bytes.of_string s in \
     let s_len = Bytes.length s in \
-    let b = Byte.create s_len in \
+    let b = Byte.create (max s_len 64) in \
     Byte.blit_from b s 0 s_len; \
     Byte.clear b; \
     Byte.length b = 0)
   *)
 
-
-  let reset b =
-    clear b;
-    b.buf <- A.empty
-
-  (*$Q
-    Q.printable_string (fun s -> let s = Bytes.of_string s in \
-    let s_len = Bytes.length s in \
-    let b = Byte.create s_len in \
-    Byte.blit_from b s 0 s_len; \
-    Byte.reset b; \
-    Byte.length b = 0 && Byte.capacity b = 0)
-  *)
-
-
   let is_empty b = b.start = b.stop
 
   (*$Q
-    Q.printable_string (fun s -> let s = Bytes.of_string s in \
+    a_str (fun s -> let s = Bytes.of_string s in \
     let s_len = Bytes.length s in \
-    let b = Byte.create s_len in \
+    let b = Byte.create (max s_len 64) in \
     Byte.blit_from b s 0 s_len; \
     Byte.skip b s_len; \
     Byte.is_empty b)
@@ -463,17 +367,15 @@ module MakeFromArray(A:Array.S) = struct
   let take_front_exn b =
     if b.start = b.stop then raise Empty;
     let c = A.get b.buf b.start in
-    if b.start + 1 = A.length b.buf
+    b.start <- next_ b b.start;
-    then b.start <- 0
-    else b.start <- b.start + 1;
     c
 
   let take_front b = try Some (take_front_exn b) with Empty -> None
 
   (*$Q
-    Q.printable_string (fun s -> let s = Bytes.of_string s in \
+    a_str (fun s -> let s = Bytes.of_string s in \
     let s_len = Bytes.length s in \
-    let b = Byte.create s_len in \
+    let b = Byte.create (max s_len 64) in \
     Byte.blit_from b s 0 s_len; \
     try let front = Byte.take_front_exn b in \
     front = Bytes.get s 0 with Byte.Empty -> s_len = 0)
@@ -481,7 +383,7 @@ module MakeFromArray(A:Array.S) = struct
 
   let take_back_exn b =
     if b.start = b.stop then raise Empty;
-    if b.stop - 1 = 0
+    if b.stop = 0
     then b.stop <- A.length b.buf - 1
     else b.stop <- b.stop - 1;
     A.get b.buf b.stop
@@ -489,12 +391,13 @@ module MakeFromArray(A:Array.S) = struct
   let take_back b = try Some (take_back_exn b) with Empty -> None
 
   (*$Q
-    Q.printable_string (fun s -> let s = Bytes.of_string s in \
+    a_str (fun s -> let s = Bytes.of_string s in \
     let s_len = Bytes.length s in \
-    let b = Byte.create s_len in \
+    let b = Byte.create (max s_len 64) in \
     Byte.blit_from b s 0 s_len; \
     try let back = Byte.take_back_exn b in \
-    back = Bytes.get s (Bytes.length s - 1) with Byte.Empty -> s_len = 0)
+        back = Bytes.get s (Bytes.length s - 1) \
+     with Byte.Empty -> s_len = 0)
   *)
 
   let junk_front b =
@@ -504,9 +407,9 @@ module MakeFromArray(A:Array.S) = struct
     else b.start <- b.start + 1
 
   (*$Q
-    Q.printable_string (fun s -> let s = Bytes.of_string s in \
+    a_str (fun s -> let s = Bytes.of_string s in \
     let s_len = Bytes.length s in \
-    let b = Byte.create s_len in \
+    let b = Byte.create (max s_len 64) in \
     Byte.blit_from b s 0 s_len; \
     try let () = Byte.junk_front b in \
     s_len - 1 = Byte.length b with Byte.Empty -> s_len = 0)
@@ -519,35 +422,38 @@ module MakeFromArray(A:Array.S) = struct
     else b.stop <- b.stop - 1
 
   (*$Q
-    Q.printable_string (fun s -> let s = Bytes.of_string s in \
+    a_str (fun s -> let s = Bytes.of_string s in \
     let s_len = Bytes.length s in \
-    let b = Byte.create s_len in \
+    let b = Byte.create (max s_len 64) in \
     Byte.blit_from b s 0 s_len; \
     try let () = Byte.junk_back b in \
     s_len - 1 = Byte.length b with Byte.Empty -> s_len = 0)
   *)
 
   let skip b len =
-    if len > length b then
+    if len > length b then (
-      invalid_arg ("CCRingBuffer.skip: " ^ string_of_int len);
+      invalid_arg "CCRingBuffer.skip";
-    if b.stop >= b.start
+    );
-    then b.start <- b.start + len
+    if b.stop >= b.start then (
-    else
+      b.start <- b.start + len;
+      assert (b.stop >= b.start);
+    ) else (
       let len_end = A.length b.buf - b.start in
-      if len > len_end
+      if len >= len_end
       then b.start <- len-len_end  (* wrap to the beginning *)
       else b.start <- b.start + len
+    )
 
   (*$Q
-    (Q.pair Q.printable_string Q.printable_string) (fun (s,s') -> \
+    (Q.pair a_str a_str) (fun (s,s') -> \
     let s = Bytes.of_string s in let s' = Bytes.of_string s' in  \
-    (let b = Byte.create 24 in \
+    let b = Byte.create (max (Bytes.length s+Bytes.length s') 64) in \
     Byte.blit_from b s 0 (Bytes.length s); \
     Byte.blit_from b s' 0 (Bytes.length s'); \
     let h = Bytes.of_string "hello world" in \
     Byte.blit_from b h 0 (Bytes.length h); (* big enough *) \
     let l = Byte.length b in let l' = l/2 in Byte.skip b l'; \
-    Byte.length b + l' = l))
+    Byte.length b + l' = l)
   *)
 
   let iter b ~f =
@@ -567,9 +473,9 @@ module MakeFromArray(A:Array.S) = struct
     )
 
   (*$Q
-    Q.printable_string (fun s -> let s = Bytes.of_string s in \
+    a_str (fun s -> let s = Bytes.of_string s in \
     let s_len = Bytes.length s in \
-    let b = Byte.create s_len in \
+    let b = Byte.create (max s_len 64) in \
     Byte.blit_from b s 0 s_len; \
     try Byte.iteri b (fun i c -> if Byte.get_front b i <> c then raise Exit); \
       true with Exit -> false)
@@ -577,29 +483,28 @@ module MakeFromArray(A:Array.S) = struct
 
   let get b i =
     if b.stop >= b.start
-    then
+    then (
-      if i >= b.stop - b.start
+      if i >= b.stop - b.start then (
-      then invalid_arg ("CCRingBuffer.get:" ^ string_of_int i)
+        invalid_arg "CCRingBuffer.get"
-      else A.get b.buf (b.start + i)
+      ) else A.get b.buf (b.start + i)
-    else
+    ) else (
       let len_end = A.length b.buf - b.start in
-      if i < len_end
+      if i < len_end then A.get b.buf (b.start + i)
-      then A.get b.buf (b.start + i)
+      else if i - len_end > b.stop then (
-      else if i - len_end > b.stop
+        invalid_arg "CCRingBuffer.get"
-      then invalid_arg ("CCRingBuffer.get: " ^ string_of_int i)
+      ) else A.get b.buf (i - len_end)
-      else A.get b.buf (i - len_end)
+    )
 
   let get_front b i =
-    if is_empty b then
+    if is_empty b then (
-      invalid_arg ("CCRingBuffer.get_front: " ^ string_of_int i)
+      invalid_arg "CCRingBuffer.get_front"
-    else
+    ) else get b i
-      get b i
 
   (*$Q
-    (Q.pair Q.small_int Q.printable_string) (fun (i, s) -> \
+    (Q.pair Q.small_int a_str) (fun (i, s) -> \
     let s = Bytes.of_string (s ^ " ") in \
     let s_len = Bytes.length s in \
-    let b = Byte.create s_len in \
+    let b = Byte.create (max s_len 64) in \
     Byte.blit_from b s 0 s_len; \
     let index = abs (i mod Byte.length b) in \
     let front = Byte.get_front b index in \
@@ -608,15 +513,15 @@ module MakeFromArray(A:Array.S) = struct
 
   let get_back b i =
     let offset = ((length b) - i - 1) in
-    if offset < 0 then
+    if offset < 0 then (
-      raise (Invalid_argument ("CCRingBuffer.get_back:" ^ string_of_int i))
+      invalid_arg "CCRingBuffer.get_back"
-    else get b offset
+    ) else get b offset
 
   (*$Q
-    (Q.pair Q.small_int Q.printable_string) (fun (i, s) -> \
+    (Q.pair Q.small_int a_str) (fun (i, s) -> \
     let s = Bytes.of_string (s ^ " ") in \
     let s_len = Bytes.length s in \
-    let b = Byte.create s_len in \
+    let b = Byte.create (max s_len 64) in \
     Byte.blit_from b s 0 s_len; \
     let index = abs (i mod Byte.length b) in \
     let back = Byte.get_back b index in \
@@ -627,14 +532,14 @@ module MakeFromArray(A:Array.S) = struct
   let to_list b =
     let len = length b in
     let rec build l i =
-      if i < 0 then l else
+      if i < 0 then l else build ((get_front b i)::l) (i-1)
-        build ((get_front b i)::l) (i-1) in
+    in
     build [] (len-1)
 
   (*$Q
-    Q.printable_string (fun s -> let s = Bytes.of_string s in \
+    a_str (fun s -> let s = Bytes.of_string s in \
     let s_len = Bytes.length s in \
-    let b = Byte.create s_len in \
+    let b = Byte.create (max s_len 64) in \
     Byte.blit_from b s 0 s_len; \
     let l = Byte.to_list b in \
     let explode s = let rec exp i l = \
@@ -643,45 +548,40 @@ module MakeFromArray(A:Array.S) = struct
     explode s = l)
   *)
 
-  let push_back b e = blit_from b (A.make 1 e) 0 1
+  (* TODO: more efficient version, with one or two blit *)
-
-  (*$Q
-    Q.printable_string (fun s -> let s = Bytes.of_string s in \
-    let s_len = Bytes.length s in \
-    let b = Byte.create s_len in \
-    Byte.blit_from b s 0 s_len; \
-    Byte.push_back b 'X'; \
-    Byte.peek_back b = 'X')
-  *)
-
-  (* TODO: more efficient version *)
   let append b ~into =
     iter b ~f:(push_back into)
 
-  let peek_front b =
+  let peek_front_exn b =
     if is_empty b then raise Empty
     else A.get b.buf b.start
 
+  let peek_front b = try Some (peek_front_exn b) with Empty -> None
+
   (*$Q
-    Q.printable_string (fun s -> let s = Bytes.of_string s in \
+    a_str (fun s -> let s = Bytes.of_string s in \
     let s_len = Bytes.length s in \
-    let b = Byte.create s_len in \
+    let b = Byte.create (max s_len 64) in \
     Byte.blit_from b s 0 s_len; \
-    try let back = Byte.peek_front b in \
+    try let back = Byte.peek_front_exn b in \
     back = Bytes.get s 0 with Byte.Empty -> s_len = 0)
   *)
 
-  let peek_back b = if is_empty b
+  let peek_back_exn b = if is_empty b
     then raise Empty
-    else A.get b.buf
+    else (
-        (if b.stop = 0 then capacity b - 1 else b.stop-1)
+      let i = if b.stop = 0 then A.length b.buf - 1 else b.stop-1 in
+      A.get b.buf i
+    )
+
+  let peek_back b = try Some (peek_back_exn b) with Empty -> None
 
   (*$Q
-    Q.printable_string (fun s -> let s = Bytes.of_string s in \
+    a_str (fun s -> let s = Bytes.of_string s in \
     let s_len = Bytes.length s in \
-    let b = Byte.create s_len in \
+    let b = Byte.create (max s_len 64) in \
     Byte.blit_from b s 0 s_len; \
-    try let back = Byte.peek_back b in \
+    try let back = Byte.peek_back_exn b in \
     back = Bytes.get s (s_len - 1) with Byte.Empty -> s_len = 0)
   *)
 
@@ -691,16 +591,13 @@ module MakeFromArray(A:Array.S) = struct
     b
 
   let to_array b =
-    if is_empty b then A.empty
+    let a = A.create (length b) in
-    else (
-      let a = A.make (length b) (peek_front b) in
     let n = blit_into b a 0 (length b) in
     assert (n = length b);
     a
-    )
 
   (*$Q
-    Q.printable_string (fun s -> let s = Bytes.of_string s in \
+    a_str (fun s -> let s = Bytes.of_string s in \
       let b = Byte.of_array s in let s' = Byte.to_array b in \
       s = s')
   *)
@@ -708,4 +605,218 @@ end
 
 module Byte = MakeFromArray(Array.Byte)
 
-module Make(Elt:sig type t end) = MakeFromArray(Array.Make(Elt))
+module Make(Elt:sig
+    type t
+    val dummy : t
+  end) = MakeFromArray(Array.Make(Elt))
+
+
+(*$inject
+  module BI = CCRingBuffer.Make(struct type t = int let dummy=0 end)
+*)
+
+(* try to trigger an error on resize
+   see issue #126 *)
+(*$R
+  let b = BI.create 50 in
+  let st = Random.State.make [| 0 |] in
+  for _i = 1 to 100_000 do
+    if Random.State.float st 1.0 < 0.5 then
+      BI.push_back b 0
+    else
+      let _ = BI.take_front b in ()
+  done
+*)
+
+(* Test against reference implementation (lists) on a succession of
+   operations.
+
+   Remarks on semantics:
+
+   JUNK_FRONT/JUNK_BACK: try to remove if not empty
+   SKIP: if at least n elements, skip; else nop
+*)
+
+(*$inject
+  module BS = CCRingBuffer.Byte
+
+  type op =
+  | Push_back of char
+  | Take_front
+  | Take_back
+  | Peek_front
+  | Peek_back
+  | Junk_front
+  | Junk_back
+  | Skip of int
+  | Blit of string * int * int
+  | Z_if_full
+
+  let str_of_op = function
+  | Push_back c -> Printf.sprintf "push_back(%C)" c
+  | Take_front -> Printf.sprintf "take_front"
+  | Take_back -> Printf.sprintf "take_back"
+  | Peek_front -> Printf.sprintf "peek_front"
+  | Peek_back -> Printf.sprintf "peek_back"
+  | Junk_front -> Printf.sprintf "junk_front"
+  | Junk_back -> Printf.sprintf "junk_back"
+  | Skip n -> Printf.sprintf "skip(%d)" n
+  | Blit (s,i,len) -> Printf.sprintf "blit(%S,%d,%d)" s i len
+  | Z_if_full -> "zero_if_full"
+
+  let push_back c = Push_back c
+  let skip n = assert (n>=0); Skip n
+  let blit s i len =
+  if i<0 || len<0 || i+len > String.length s then (
+    failwith ("wrong blit: " ^ str_of_op (Blit (s,i,len)));
+  );
+  Blit (s,i,len)
+
+  let shrink_op =
+  let open Q.Iter in
+  function
+    | Push_back c -> Q.Shrink.char c >|= push_back
+    | Take_front | Take_back | Junk_back | Junk_front
+    | Z_if_full | Peek_front | Peek_back
+    -> empty
+    | Skip n -> Q.Shrink.int n >|= skip
+    | Blit (s,i,len) ->
+      let s_i =
+        Q.Shrink.int i >>= fun i' ->
+        assert (i' <= i && i' + len <= String.length s);
+        if i' <= 0 then empty else return (blit s i' len)
+      and s_len =
+        Q.Shrink.int len >>= fun len'->
+        assert (len' <= len && i + len' <= String.length s);
+        if len' <= 0 then empty else return (blit s i len')
+      and s_s =
+        Q.Shrink.string s >>= fun s' ->
+        if i+len > String.length s' then empty else return (blit s' i len)
+      in
+      append s_i (append s_len s_s)
+
+  let rec len_op size acc = function
+  | Push_back _ -> min size (acc + 1)
+  | Take_front | Take_back | Junk_front | Junk_back -> max (acc-1) 0
+  | Skip n -> if acc >= n then acc-n else acc
+  | Z_if_full | Peek_front | Peek_back -> acc
+  | Blit (_,_,len) -> min size (acc + len)
+
+  let apply_op b = function
+  | Push_back c -> BS.push_back b c; None
+  | Take_front -> BS.take_front b
+  | Take_back -> BS.take_back b
+  | Junk_front -> (try BS.junk_front b with BS.Empty -> ()); None
+  | Junk_back -> (try BS.junk_back b with BS.Empty -> ()); None
+  | Peek_front -> BS.peek_front b
+  | Peek_back -> BS.peek_back b
+  | Skip n -> if n <= BS.length b then BS.skip b n; None
+  | Blit (s,i,len) ->
+    assert(i+len <= String.length s);
+    BS.blit_from b (Bytes.unsafe_of_string s) i len; None
+  | Z_if_full -> if BS.is_full b then Some '0' else None
+
+  let gen_op =
+  let open Q.Gen in
+  let g_blit =
+    string_size ~gen:g_char (5--20) >>= fun s ->
+    (0 -- String.length s) >>= fun len ->
+    assert (len >= 0 && len <= String.length s);
+    (0--(String.length s-len)) >|= fun i ->
+    blit s i len
+  in
+  frequency
+    [ 3, return Take_back;
+      3, return Take_front;
+      1, return Junk_back;
+      1, return Junk_front;
+      1, return Peek_front;
+      1, return Peek_back;
+      2, g_blit;
+      1, (0--5 >|= skip);
+      2, map push_back g_char;
+      1, return Z_if_full;
+    ]
+
+  let arb_op =
+  Q.make
+    ~shrink:shrink_op
+    ~print:str_of_op
+    gen_op
+
+  let arb_ops = Q.list arb_op
+
+  module L_impl = struct
+  type t = {
+    size: int;
+    mutable l: char list;
+  }
+
+  let create size = {size; l=[]}
+
+  let normalize_ b =
+    let n = List.length b.l in
+    if n>b.size then b.l <- CCList.drop (n-b.size) b.l
+
+  let push_back b c = b.l <- b.l @ [c]; normalize_ b
+  let take_front b = match b.l with
+    | [] -> None
+    | c :: l -> b.l <- l; Some c
+  let peek_front b = match b.l with [] -> None | x::_ -> Some x
+  let take_back b =
+    let n = List.length b.l in
+    if n=0 then None
+    else (
+      let init, last = CCList.take_drop (n-1) b.l in
+      let x = List.hd last in
+      b.l <- init;
+      Some x
+    )
+  let peek_back b = match b.l with [] -> None | l -> Some (List.hd (List.rev l))
+  let junk_front b = ignore (take_front b)
+  let junk_back b = ignore (take_back b)
+  let skip b n =
+    if n <= List.length b.l then (
+      CCInt.range' 0 n (fun _ -> junk_front b)
+    )
+
+  let blit b s i len =
+    for j=i to i+len-1 do push_back b (String.get s j) done
+
+  let apply_op b = function
+    | Push_back c -> push_back b c; None
+    | Take_front -> take_front b
+    | Take_back -> take_back b
+    | Peek_front -> peek_front b
+    | Peek_back -> peek_back b
+    | Junk_back -> junk_back b; None
+    | Junk_front -> junk_front b; None
+    | Skip n -> skip b n; None
+    | Blit (s,i,len) -> blit b s i len; None
+    | Z_if_full -> if b.size = List.length b.l then Some '0' else None
+
+  let to_list b = b.l
+  end
+
+*)
+
+(* check that a lot of operations can be applied without failure,
+   and that the result has correct length *)
+(*$QR & ~count:3_000
+  arb_ops (fun ops ->
+    let size = 64 in
+    let b = BS.create size in
+    List.iter (fun o-> ignore (apply_op b o)) ops;
+    BS.length b = List.fold_left (len_op size) 0 ops)
+*)
+
+(* check identical behavior with list implem *)
+(*$QR & ~count:3_000
+  arb_ops (fun ops ->
+    let size = 64 in
+    let b = BS.create size in
+    let l = L_impl.create size in
+    let l1 = CCList.filter_map (apply_op b) ops in
+    let l2 = CCList.filter_map (L_impl.apply_op l) ops in
+    l1=l2 && BS.to_list b = L_impl.to_list l)
+*)

src/data/CCRingBuffer.mli

@@ -1,31 +1,19 @@
-(*
+
- * CCRingBuffer - Polymorphic Circular Buffer
+(* This file is free software, part of containers. See file "license" for more details. *)
- * Copyright (C) 2015 Simon Cruanes, Carmelo Piccione
+
- *
+(* Copyright (C) 2015 Simon Cruanes, Carmelo Piccione *)
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version,
- * with the special exception on linking described in file LICENSE.
- *
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
- *)
 
 (** {1 Circular Buffer (Deque)}
 
-    Useful for IO, or as a general-purpose alternative to {!Queue} when
+    Useful for IO, or as a bounded-size alternative to {!Queue} when
     batch operations are needed.
 
     {b status: experimental}
 
     @since 0.9
+
+    Change in the API to provide only a bounded buffer
+    @since 1.3
 *)
 
 (** {2 Underlying Array} *)
@@ -39,11 +27,8 @@ module Array : sig
     (** The type of an array instance *)
     type t
 
-    val empty : t
+    val create : int -> t
-    (** The empty array *)
+    (** Make an array of the given size, filled with dummy elements *)
-
-    val make: int -> elt -> t
-    (** [make s e] makes an array of size [s] with [e] elements *)
 
     val length: t -> int
     (** [length t] gets the total number of elements currently in [t] *)
@@ -75,7 +60,7 @@ module Array : sig
     S with type elt = char and type t = Bytes.t
 
   (** Makes an array given an arbitrary element type *)
-  module Make(Elt:sig type t end) :
+  module Make(Elt:sig type t val dummy : t end) :
     S with type elt = Elt.t and type t = Elt.t array
 end
 
@@ -87,16 +72,17 @@ module type S = sig
   (** The module type of Array for this ring buffer *)
   module Array : Array.S
 
-  (** Defines the ring buffer type, with both bounded and
+  (** Defines the bounded ring buffer type *)
-      unbounded flavors *)
   type t
 
   (** Raised in querying functions when the buffer is empty *)
   exception Empty
 
-  val create : ?bounded:bool -> int -> t
+  val create : int -> t
-  (** [create ?bounded size] creates a new buffer with given size.
+  (** [create size] creates a new bounded buffer with given size.
-      Defaults to [bounded=false]. *)
+      The underlying array is allocated immediately and no further (large)
+      allocation will happen from now on.
+      @raise Invalid_argument if the arguments is [< 1] *)
 
   val copy : t -> t
   (** Make a fresh copy of the buffer. *)
@@ -104,26 +90,29 @@ module type S = sig
   val capacity : t -> int
   (** Length of the inner buffer. *)
 
-  val max_capacity : t -> int option
-  (** Maximum length of the inner buffer, or [None] if unbounded. *)
-
   val length : t -> int
   (** Number of elements currently stored in the buffer. *)
 
+  val is_full : t -> bool
+  (** true if pushing an element would erase another element.
+      @since 1.3 *)
+
   val blit_from : t -> Array.t -> int -> int -> unit
   (** [blit_from buf from_buf o len] copies the slice [o, ... o + len - 1] from
       a input buffer [from_buf] to the end of the buffer.
+      If the slice is too large for the buffer, only the last part of the array
+      will be copied.
       @raise Invalid_argument if [o,len] is not a valid slice of [s] *)
 
   val blit_into : t -> Array.t -> int -> int -> int
   (** [blit_into buf to_buf o len] copies at most [len] elements from [buf]
       into [to_buf] starting at offset [o] in [s].
       @return the number of elements actually copied ([min len (length buf)]).
-      @raise Invalid_argument if [o,len] is not a valid slice of [s] *)
+      @raise Invalid_argument if [o,len] is not a valid slice of [s]. *)
 
   val append : t -> into:t -> unit
   (** [append b ~into] copies all data from [b] and adds it at the
-      end of [into] *)
+      end of [into]. Erases data of [into] if there is not enough room. *)
 
   val to_list : t -> Array.elt list
   (** Extract the current content into a list *)
@@ -131,9 +120,6 @@ module type S = sig
   val clear : t -> unit
   (** Clear the content of the buffer. Doesn't actually destroy the content. *)
 
-  val reset : t -> unit
-  (** Clear the content of the buffer, and also resize it to a default size *)
-
   val is_empty :t -> bool
   (** Is the buffer empty (i.e. contains no elements)? *)
 
@@ -171,26 +157,34 @@ module type S = sig
       If [t.bounded=false], the buffer will grow as needed,
       otherwise the oldest elements are replaced first. *)
 
-  val peek_front : t -> Array.elt
+  val peek_front : t -> Array.elt option
-  (** First value from front of [t].
+  (** First value from front of [t], without modification. *)
-      @raise Empty if buffer is empty. *)
 
-  val peek_back : t -> Array.elt
+  val peek_front_exn : t -> Array.elt
-  (** Get the last value from back of [t].
+  (** First value from front of [t], without modification.
-      @raise Empty if buffer is empty. *)
+      @raise Empty if buffer is empty.
+      @since 1.3 *)
+
+  val peek_back : t -> Array.elt option
+  (** Get the last value from back of [t], without modification. *)
+
+  val peek_back_exn : t -> Array.elt
+  (** Get the last value from back of [t], without modification.
+      @raise Empty if buffer is empty.
+      @since 1.3 *)
 
   val take_back : t -> Array.elt option
-  (** Take the last value from back of [t], if any *)
+  (** Take and remove the last value from back of [t], if any *)
 
   val take_back_exn : t -> Array.elt
-  (** Take the last value from back of [t].
+  (** Take and remove the last value from back of [t].
       @raise Empty if buffer is already empty. *)
 
   val take_front : t -> Array.elt option
-  (** Take the first value from front of [t], if any *)
+  (** Take and remove the first value from front of [t], if any *)
 
   val take_front_exn : t -> Array.elt
-  (** Take the first value from front of [t].
+  (** Take and remove the first value from front of [t].
       @raise Empty if buffer is already empty. *)
 
   val of_array : Array.t -> t
@@ -210,4 +204,7 @@ module Byte : S with module Array = Array.Byte
 module MakeFromArray(A : Array.S) : S with module Array = A
 
 (** Buffer using regular arrays *)
-module Make(X : sig type t end) : S with type Array.elt = X.t and type Array.t = X.t array
+module Make(X : sig
+    type t
+    val dummy : t
+  end) : S with type Array.elt = X.t and type Array.t = X.t array

src/data/CCSimple_queue.ml

@@ -0,0 +1,201 @@
+
+(* This file is free software, part of containers. See file "license" for more details. *)
+
+(** {1 Functional queues (fifo)} *)
+
+type 'a sequence = ('a -> unit) -> unit
+type 'a printer = Format.formatter -> 'a -> unit
+type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
+type 'a gen = unit -> 'a option
+
+type 'a t = {
+  hd : 'a list;
+  tl : 'a list;
+} (** Queue containing elements of type 'a *)
+
+let empty = {
+  hd = [];
+  tl = [];
+}
+
+(* invariant: if hd=[], then tl=[] *)
+let make_ hd tl = match hd with
+  | [] -> {hd=List.rev tl; tl=[] }
+  | _::_ -> {hd; tl; }
+
+let is_empty q = q.hd = []
+
+let push x q = make_ q.hd (x :: q.tl)
+
+let snoc q x = push x q
+
+let peek_exn q =
+  match q.hd with
+    | [] -> assert (q.tl = []); invalid_arg "Queue.peek"
+    | x::_ -> x
+
+let peek q = match q.hd with
+  | [] -> None
+  | x::_ -> Some x
+
+let pop_exn q =
+  match q.hd with
+    | [] -> assert (q.tl = []); invalid_arg "Queue.peek"
+    | x::hd' ->
+      let q' = make_ hd' q.tl in
+      x, q'
+
+let pop q =
+  try Some (pop_exn q)
+  with Invalid_argument _ -> None
+
+(*$Q
+  Q.(list small_int) (fun l -> \
+    let q = of_list l in \
+    equal CCInt.equal (Gen.unfold pop q |> of_gen) q)
+*)
+
+let junk q =
+  try
+    let _, q' = pop_exn q in
+    q'
+  with Invalid_argument _ -> q
+
+let map f q = { hd=List.map f q.hd; tl=List.map f q.tl; }
+
+let rev q = make_ q.tl q.hd
+
+(*$Q
+  Q.(list small_int) (fun l -> \
+    equal CCInt.equal (of_list l |> rev) (of_list (List.rev l)))
+  Q.(list small_int) (fun l -> \
+    let q = of_list l in \
+    equal CCInt.equal q (q |> rev |> rev))
+*)
+
+let length q = List.length q.hd + List.length q.tl
+
+(*$Q
+  Q.(list small_int)(fun l -> \
+    length (of_list l) = List.length l)
+*)
+
+(*$Q
+  Q.(list small_int)(fun l -> \
+    equal CCInt.equal (of_list l) (List.fold_left snoc empty l))
+*)
+
+let fold f acc q =
+  let acc' = List.fold_left f acc q.hd in
+  List.fold_right (fun x acc -> f acc x) q.tl acc'
+
+(* iterate on a list in reverse order *)
+let rec rev_iter_ f l = match l with
+  | [] -> ()
+  | x :: tl -> rev_iter_ f tl; f x
+
+let iter f q =
+  List.iter f q.hd;
+  rev_iter_ f q.tl
+
+let to_list q = fold (fun acc x->x::acc) [] q |> List.rev
+
+let add_list q l = List.fold_left snoc q l
+let of_list l = add_list empty l
+
+let to_seq q = fun k -> iter k q
+
+let add_seq q seq =
+  let q = ref q in
+  seq (fun x -> q := push x !q);
+  !q
+
+let of_seq s = add_seq empty s
+
+(*$Q
+  Q.(list small_int) (fun l -> \
+    equal CCInt.equal \
+      (of_seq (Sequence.of_list l)) \
+      (of_list l))
+  Q.(list small_int) (fun l -> \
+    l = (of_list l |> to_seq |> Sequence.to_list))
+*)
+
+let rec klist_iter_ k f = match k() with
+  | `Nil -> ()
+  | `Cons (x,tl) -> f x; klist_iter_ tl f
+
+let add_klist q l = add_seq q (klist_iter_ l)
+let of_klist l = add_klist empty l
+
+let to_klist q =
+  let rec aux1 l () = match l with
+    | [] -> aux2 (List.rev q.tl) ()
+    | x :: tl -> `Cons (x, aux1 tl)
+  and aux2 l () = match l with
+    | [] -> `Nil
+    | x :: tl -> `Cons (x, aux2 tl)
+  in
+  aux1 q.hd
+
+let rec gen_iter g f = match g() with
+  | None -> ()
+  | Some x -> f x; gen_iter g f
+
+let add_gen q g = add_seq q (gen_iter g)
+let of_gen g = add_gen empty g
+
+let to_gen q =
+  let st = ref (`Left q.hd) in
+  let rec aux () = match !st with
+    | `Stop -> None
+    | `Left [] -> st := `Right q.tl; aux()
+    | `Left (x::tl) -> st := `Left tl; Some x
+    | `Right [] -> st := `Stop; None
+    | `Right (x::tl) -> st := `Right tl; Some x
+  in
+  aux
+
+let rec klist_equal eq l1 l2 = match l1(), l2() with
+  | `Nil, `Nil -> true
+  | `Nil, _
+  | _, `Nil -> false
+  | `Cons (x1,l1'), `Cons (x2,l2') ->
+    eq x1 x2 && klist_equal eq l1' l2'
+
+let equal eq q1 q2 = klist_equal eq (to_klist q1) (to_klist q2)
+
+(*$Q
+  Q.(pair (list small_int)(list small_int)) (fun (l1,l2) -> \
+    equal CCInt.equal (of_list l1)(of_list l2) = (l1=l2))
+*)
+
+let append q1 q2 =
+  add_seq q1
+    (fun yield ->
+       to_seq q2 yield)
+
+(*$Q
+  Q.(pair (list small_int)(list small_int)) (fun (l1,l2) -> \
+    equal CCInt.equal \
+      (append (of_list l1)(of_list l2)) \
+      (of_list (List.append l1 l2)))
+*)
+
+module Infix = struct
+  let (>|=) q f = map f q
+  let (<::) = snoc
+  let (@) = append
+end
+
+include Infix
+
+(** {2 IO} *)
+
+let pp ?(sep=fun out () -> Format.fprintf out ",@ ") pp_item out l =
+  let first = ref true in
+  iter
+    (fun x ->
+       if !first then first := false else sep out ();
+       pp_item out x)
+    l

src/data/CCSimple_queue.mli

@@ -0,0 +1,90 @@
+
+(* This file is free software, part of containers. See file "license" for more details. *)
+
+(** {1 Functional queues (fifo)} *)
+
+(** Simple implementation of functional queues
+    @since 1.3 *)
+
+type 'a sequence = ('a -> unit) -> unit
+type 'a printer = Format.formatter -> 'a -> unit
+type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
+type 'a gen = unit -> 'a option
+
+type +'a t
+(** Queue containing elements of type 'a *)
+
+val empty : 'a t
+
+val is_empty : 'a t -> bool
+
+val push : 'a -> 'a t -> 'a t
+(** Push element at the end of the queue *)
+
+val snoc : 'a t -> 'a -> 'a t
+(** Flip version of {!push} *)
+
+val peek : 'a t -> 'a option
+(** First element of the queue *)
+
+val peek_exn : 'a t -> 'a
+(** Same as {!peek} but
+    @raise Invalid_argument if the queue is empty *)
+
+val pop : 'a t -> ('a * 'a t) option
+(** Get and remove the first element *)
+
+val pop_exn : 'a t -> ('a * 'a t)
+(** Same as {!pop}, but fails on empty queues.
+    @raise Invalid_argument if the queue is empty *)
+
+val junk : 'a t -> 'a t
+(** Remove first element. If the queue is empty, do nothing. *)
+
+val append : 'a t -> 'a t -> 'a t
+(** Append two queues. Elements from the second one come
+    after elements of the first one.
+    Linear in the size of the second queue. *)
+
+val map : ('a -> 'b) -> 'a t -> 'b t
+(** Map values *)
+
+val rev : 'a t -> 'a t
+(** Reverse the queue. Constant time. *)
+
+val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+
+module Infix : sig
+  val (>|=) : 'a t -> ('a -> 'b) -> 'b t (** Alias to {!map} *)
+  val (@) : 'a t -> 'a t -> 'a t (** Alias to {!append} *)
+  val (<::) : 'a t -> 'a -> 'a t (** Alias to {!snoc} *)
+end
+
+include module type of Infix
+
+val length : 'a t -> int
+(** Number of elements in the queue (linear in time) *)
+
+val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
+
+val iter : ('a -> unit) -> 'a t -> unit
+
+val to_list : 'a t -> 'a list
+val add_list : 'a t -> 'a list -> 'a t
+val of_list : 'a list -> 'a t
+
+val to_seq : 'a t -> 'a sequence
+val add_seq : 'a t -> 'a sequence -> 'a t
+val of_seq : 'a sequence -> 'a t
+
+val to_klist : 'a t -> 'a klist
+val add_klist : 'a t -> 'a klist -> 'a t
+val of_klist : 'a klist -> 'a t
+
+val of_gen : 'a gen -> 'a t
+val add_gen : 'a t -> 'a gen -> 'a t
+val to_gen : 'a t -> 'a gen
+
+(** {2 IO} *)
+
+val pp : ?sep:unit printer -> 'a printer -> 'a t printer

src/data/CCTrie.ml

@@ -684,25 +684,27 @@ module Make(W : WORD)
       | [] | [_] -> true
       | x :: ((y ::_) as tl) ->
         (if rev then x >= y else x <= y) && sorted ~rev tl
+
+    let gen_str = Q.small_printable_string
   *)
 
   (*$Q & ~count:200
-    Q.(list_of_size Gen.(1 -- 20) (pair printable_string small_int)) \
+    Q.(list_of_size Gen.(1 -- 20) (pair gen_str small_int)) \
       (fun l -> let t = String.of_list l in \
         List.for_all (fun (k,_) -> \
           String.above k t |> Sequence.for_all (fun (k',v) -> k' >= k)) \
           l)
-    Q.(list_of_size Gen.(1 -- 20) (pair printable_string small_int)) \
+    Q.(list_of_size Gen.(1 -- 20) (pair gen_str small_int)) \
       (fun l -> let t = String.of_list l in \
         List.for_all (fun (k,_) -> \
           String.below k t |> Sequence.for_all (fun (k',v) -> k' <= k)) \
           l)
-    Q.(list_of_size Gen.(1 -- 20) (pair printable_string small_int)) \
+    Q.(list_of_size Gen.(1 -- 20) (pair gen_str small_int)) \
       (fun l -> let t = String.of_list l in \
         List.for_all (fun (k,_) -> \
           String.above k t |> Sequence.to_list |> sorted ~rev:false) \
           l)
-    Q.(list_of_size Gen.(1 -- 20) (pair printable_string small_int)) \
+    Q.(list_of_size Gen.(1 -- 20) (pair gen_str small_int)) \
       (fun l -> let t = String.of_list l in \
         List.for_all (fun (k,_) -> \
           String.below k t |> Sequence.to_list |> sorted ~rev:true) \

src/data/CCZipper.ml

@@ -17,7 +17,7 @@ let to_rev_list (l,r) = List.rev_append r l
 
 (*$inject
   let zip_gen = Q.(pair (small_list int)(small_list int))
-  *)
+*)
 
 (*$Q
   zip_gen (fun z -> \

src/data/containers_data.mldylib

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: faa1bae1054c39ac202fac31d38a084e)
+# DO NOT EDIT (digest: d1bab4c4f6793f682baaf28f0865fa42)
 CCMultiMap
 CCMultiSet
 CCTrie
@@ -21,6 +21,7 @@ CCBitField
 CCHashTrie
 CCWBTree
 CCRAL
+CCSimple_queue
 CCImmutArray
 CCHet
 CCZipper

src/data/containers_data.mllib

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: faa1bae1054c39ac202fac31d38a084e)
+# DO NOT EDIT (digest: d1bab4c4f6793f682baaf28f0865fa42)
 CCMultiMap
 CCMultiSet
 CCTrie
@@ -21,6 +21,7 @@ CCBitField
 CCHashTrie
 CCWBTree
 CCRAL
+CCSimple_queue
 CCImmutArray
 CCHet
 CCZipper