merge from master

.merlin

@@ -1,11 +1,13 @@
 S core
 S misc
 S string
+S pervasives
 S tests
 S examples
 B _build/core
 B _build/misc
 B _build/string
+B _build/pervasives
 B _build/tests
 B _build/examples
 PKG oUnit

.ocamlinit

@@ -2,15 +2,18 @@
 #thread
 #directory "_build/core";;
 #directory "_build/misc";;
+#directory "_build/pervasives/";;
 #directory "_build/string";;
 #directory "_build/threads";;
 #directory "_build/tests/";;
 #load "containers.cma";;
 #load "containers_string.cma";;
+#load "containers_pervasives.cma";;
 #load "containers_misc.cma";;
 #thread;;
 #load "containers_thread.cma";;
 open Containers_misc;;
+#install_printer Sexp.print;;
 #install_printer Bencode.pretty;;
 #install_printer HGraph.Default.fmt;;
 #require "CamlGI";;

README.md

@@ -12,7 +12,10 @@ ocaml-containers
     KMP search algorithm, and a few naive utils). Again, modules are independent
     and sometimes parametric on the string and char types (so they should
     be able to deal with your favorite unicode library).
-3. Random stuff, with *NO* *GUARANTEE* of even being barely usable or tested,
+3. A drop-in replacement to the standard library, `containers.pervasives`,
+    that defined a `CCPervasives` module intented to be opened to extend some
+    modules of the stdlib.
+4. Random stuff, with *NO* *GUARANTEE* of even being barely usable or tested,
     in other dirs (mostly `misc` but also `lwt` and `threads`). It's where I
     tend to write code when I want to test some idea, so half the modules (at
     least) are unfinished or don't really work.
@@ -59,6 +62,8 @@ structures comprise (some modules in `misc/`, some other in `core/`):
 - `CCArray`, utilities on arrays and slices
 - `CCLinq`, high-level query language over collections
 - `CCMultimap` and `CCMultiset`, functors defining persistent structures
+- `CCHashtbl`, an extension of the standard hashtbl module
+- `CCFlatHashtbl`, a flat (open-addressing) hashtable functorial implementation
 - `CCKTree`, an abstract lazy tree structure (similar to what `CCKlist` is to lists)
 - small modules (basic types, utilities):
   - `CCInt`

_oasis

@@ -21,8 +21,7 @@ Description:
     library full of experimental ideas (not stable, not necessarily usable).
 
 Flag "misc"
-  Description:  Build the misc library, containing everything from
+  Description:  Build the misc library, containing everything from the rotating kitchen sink to automatic banana distributors
-                the rotating kitchen sink to automatic banana distributors
   Default:      false
 
 Flag "cgi"
@@ -47,7 +46,8 @@ Library "containers"
                     CCMultiSet, CCBV, CCPrint, CCPersistentHashtbl, CCError,
                     CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash, CCCat,
                     CCKList, CCInt, CCBool, CCArray, CCBatch, CCOrd, CCIO,
-                    CCRandom, CCLinq, CCKTree, CCTrie, CCString, CCHashtbl
+                    CCRandom, CCLinq, CCKTree, CCTrie, CCString, CCHashtbl,
+                    CCFlatHashtbl
   FindlibName:      containers
 
 Library "containers_string"
@@ -57,6 +57,13 @@ Library "containers_string"
   FindlibName:      string
   FindlibParent:    containers
 
+Library "containers_pervasives"
+  Path:             pervasives
+  Modules:          CCPervasives
+  BuildDepends:     containers
+  FindlibName:      pervasives
+  FindlibParent:    containers
+
 Library "containers_misc"
   Path:             misc
   Pack:             true
@@ -128,7 +135,7 @@ Document containers_string
   XOCamlbuildLibraries: containers.string
 
 Executable benchs
-  Path:             tests/
+  Path:             benchs/
   Install:          false
   CompiledObject:   native
   Build$:           flag(bench)
@@ -136,7 +143,7 @@ Executable benchs
   BuildDepends:     containers,containers.string,containers.misc,bench
 
 Executable bench_conv
-  Path: tests/
+  Path:     benchs/
   Install: false
   CompiledObject: native
   Build$: flag(bench)
@@ -144,7 +151,7 @@ Executable bench_conv
   BuildDepends: containers,benchmark
 
 Executable bench_batch
-  Path: tests/
+  Path: benchs/
   Install: false
   CompiledObject: native
   Build$: flag(bench)
@@ -152,7 +159,7 @@ Executable bench_batch
   BuildDepends: containers,benchmark
 
 Executable bench_hash
-  Path: tests/
+  Path: benchs/
   Install: false
   CompiledObject: native
   Build$: flag(bench) && flag(misc)
@@ -165,7 +172,7 @@ Executable test_levenshtein
   CompiledObject: native
   Build$: flag(tests)
   MainIs: test_levenshtein.ml
-  BuildDepends: containers,qcheck
+  BuildDepends: containers,qcheck,containers.string
 
 Executable test_lwt
   Path: tests/lwt/
@@ -193,8 +200,8 @@ Executable run_tests
   Install: false
   CompiledObject: native
   MainIs: run_tests.ml
-  Build$: flag(tests)
+  Build$: flag(tests) && flag(misc)
-  BuildDepends: containers, oUnit, qcheck
+  BuildDepends: containers,oUnit,qcheck,containers.misc
 
 Executable web_pwd
   Path: examples/cgi/
@@ -210,6 +217,14 @@ Executable lambda
   Build$: flag(misc)
   BuildDepends: containers,containers.misc
 
+Executable id_sexp
+  Path:     examples/
+  Install:  false
+  CompiledObject: native
+  MainIs:   id_sexp.ml
+  Build$:   flag(misc)
+  BuildDepends: containers,containers.misc
+
 SourceRepository head
   Type: git
   Location: https://github.com/c-cube/ocaml-containers

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: b056133745a2be24fb08a6580d55ff77)
+# DO NOT EDIT (digest: 4eaa31a9f64d59d82a736ef275c18061)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -19,6 +19,9 @@
 "string/containers_string.cmxs": use_containers_string
 "string/KMP.cmx": for-pack(Containers_string)
 "string/levenshtein.cmx": for-pack(Containers_string)
+# Library containers_pervasives
+"pervasives/containers_pervasives.cmxs": use_containers_pervasives
+<pervasives/*.ml{,i}>: use_containers
 # Library containers_misc
 "misc/containers_misc.cmxs": use_containers_misc
 "misc/cache.cmx": for-pack(Containers_misc)
@@ -79,29 +82,32 @@
 <cgi/*.ml{,i}>: package(CamlGI)
 <cgi/*.ml{,i}>: use_containers
 # Executable benchs
-"tests/benchs.native": package(bench)
+"benchs/benchs.native": package(bench)
-"tests/benchs.native": package(unix)
+"benchs/benchs.native": package(unix)
-"tests/benchs.native": use_containers
+"benchs/benchs.native": use_containers
-"tests/benchs.native": use_containers_misc
+"benchs/benchs.native": use_containers_misc
-"tests/benchs.native": use_containers_string
+"benchs/benchs.native": use_containers_string
-<tests/*.ml{,i}>: package(bench)
+<benchs/*.ml{,i}>: package(bench)
-<tests/*.ml{,i}>: use_containers_string
+<benchs/*.ml{,i}>: use_containers_string
 # Executable bench_conv
-"tests/bench_conv.native": package(benchmark)
+"benchs/bench_conv.native": package(benchmark)
-"tests/bench_conv.native": use_containers
+"benchs/bench_conv.native": use_containers
 # Executable bench_batch
-"tests/bench_batch.native": package(benchmark)
+"benchs/bench_batch.native": package(benchmark)
-"tests/bench_batch.native": use_containers
+"benchs/bench_batch.native": use_containers
-<tests/*.ml{,i}>: package(benchmark)
+<benchs/*.ml{,i}>: package(benchmark)
 # Executable bench_hash
-"tests/bench_hash.native": package(unix)
+"benchs/bench_hash.native": package(unix)
-"tests/bench_hash.native": use_containers
+"benchs/bench_hash.native": use_containers
-"tests/bench_hash.native": use_containers_misc
+"benchs/bench_hash.native": use_containers_misc
-<tests/*.ml{,i}>: package(unix)
+<benchs/*.ml{,i}>: package(unix)
-<tests/*.ml{,i}>: use_containers_misc
+<benchs/*.ml{,i}>: use_containers
+<benchs/*.ml{,i}>: use_containers_misc
 # Executable test_levenshtein
 "tests/test_levenshtein.native": package(qcheck)
 "tests/test_levenshtein.native": use_containers
+"tests/test_levenshtein.native": use_containers_string
+<tests/*.ml{,i}>: use_containers_string
 # Executable test_lwt
 <tests/lwt/test_Behavior.{native,byte}>: package(lwt)
 <tests/lwt/test_Behavior.{native,byte}>: package(lwt.unix)
@@ -130,10 +136,14 @@
 # Executable run_tests
 "tests/run_tests.native": package(oUnit)
 "tests/run_tests.native": package(qcheck)
+"tests/run_tests.native": package(unix)
 "tests/run_tests.native": use_containers
+"tests/run_tests.native": use_containers_misc
 <tests/*.ml{,i}>: package(oUnit)
 <tests/*.ml{,i}>: package(qcheck)
+<tests/*.ml{,i}>: package(unix)
 <tests/*.ml{,i}>: use_containers
+<tests/*.ml{,i}>: use_containers_misc
 # Executable web_pwd
 "examples/cgi/web_pwd.byte": package(CamlGI)
 "examples/cgi/web_pwd.byte": package(threads)
@@ -147,10 +157,15 @@
 "examples/lambda.byte": package(unix)
 "examples/lambda.byte": use_containers
 "examples/lambda.byte": use_containers_misc
+# Executable id_sexp
+"examples/id_sexp.native": package(unix)
+"examples/id_sexp.native": use_containers
+"examples/id_sexp.native": use_containers_misc
 <examples/*.ml{,i}>: package(unix)
 <examples/*.ml{,i}>: use_containers
 <examples/*.ml{,i}>: use_containers_misc
 # OASIS_STOP
 <tests/*.ml{,i}>: thread
 <threads/*.ml{,i}>: thread
+<sequence>: -traverse
 <{string,core}/**/*.ml>: warn_K, warn_Y, warn_X

benchs/benchs.ml

@@ -31,7 +31,7 @@ module IMap = Map.Make(struct
   let compare i j = i - j
 end)
 
-module ICCHashtbl = CCHashtbl.Make(struct
+module ICCHashtbl = CCFlatHashtbl.Make(struct
   type t = int
   let equal i j = i = j
   let hash i = i
@@ -111,7 +111,7 @@ let bench_maps1 () =
      "ipersistenthashtbl_add", (fun n -> ignore (ipersistenthashtbl_add n));
      "skiplist_add", (fun n -> ignore (skiplist_add n));
      "imap_add", (fun n -> ignore (imap_add n));
-     "cchashtbl_add", (fun n -> ignore (icchashtbl_add n))
+     "ccflathashtbl_add", (fun n -> ignore (icchashtbl_add n))
     ]
   in
   Bench.summarize 1. res
@@ -217,7 +217,7 @@ let bench_maps2 () =
      "ipersistenthashtbl_replace", (fun n -> ignore (ipersistenthashtbl_replace n));
      "skiplist_replace", (fun n -> ignore (skiplist_replace n));
      "imap_replace", (fun n -> ignore (imap_replace n));
-     "cchashtbl_replace", (fun n -> ignore (icchashtbl_replace n));
+     "ccflathashtbl_replace", (fun n -> ignore (icchashtbl_replace n));
     ]
   in
   Bench.summarize 1. res

containers.odocl

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 3ce32ab9d93a14d03bdd4e7d7bc097f0)
+# DO NOT EDIT (digest: a6bb53268d7bad1acff03396fa05033b)
 core/CCVector
 core/CCDeque
 core/CCGen
@@ -31,6 +31,7 @@ core/CCKTree
 core/CCTrie
 core/CCString
 core/CCHashtbl
+core/CCFlatHashtbl
 string/KMP
 string/Levenshtein
 # OASIS_STOP

core/CCError.ml

@@ -72,6 +72,14 @@ let map2 f g e = match e with
   | `Ok x -> `Ok (f x)
   | `Error s -> `Error (g s)
 
+let iter f e = match e with
+  | `Ok x -> f x
+  | `Error _ -> ()
+
+let get_exn = function
+  | `Ok x -> x
+  | `Error _ -> raise (Invalid_argument "CCError.get_exn")
+
 let flat_map f e = match e with
   | `Ok x -> f x
   | `Error s -> `Error s

core/CCError.mli

@@ -56,6 +56,15 @@ val map2 : ('a -> 'b) -> (string -> string) -> 'a t -> 'b t
 (** Same as {!map}, but also with a function that can transform
     the error message in case of failure *)
 
+val iter : ('a -> unit) -> 'a t -> unit
+(** Apply the function only in case of `Ok *)
+
+val get_exn : 'a t -> 'a
+(** Extract the value [x] from [`Ok x], fails otherwise.
+    You should be careful with this function, and favor other combinators
+    whenever possible.
+    @raise Invalid_argument if the value is an error. *)
+
 val flat_map : ('a -> 'b t) -> 'a t -> 'b t
 
 val (>|=) : 'a t -> ('a -> 'b) -> 'b t

core/CCFlatHashtbl.ml

@@ -0,0 +1,272 @@
+
+(*
+copyright (c) 2013-2014, simon cruanes
+all rights reserved.
+
+redistribution and use in source and binary forms, with or without
+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 Open-Addressing Hash-table}
+
+We use Robin-Hood hashing as described in
+http://codecapsule.com/2013/11/17/robin-hood-hashing-backward-shift-deletion/
+with backward shift. *)
+
+type 'a sequence = ('a -> unit) -> unit
+
+module type S = sig
+  type key
+  type 'a t
+
+  val create : int -> 'a t
+  (** Create a new table of the given initial capacity *)
+
+  val mem : 'a t -> key -> bool
+  (** [mem tbl k] returns [true] iff [k] is mapped to some value
+      in [tbl] *)
+
+  val find : 'a t -> key -> 'a option
+
+  val find_exn : 'a t -> key -> 'a
+
+  val get : key -> 'a t -> 'a option
+  (** [get k tbl] recovers the value for [k] in [tbl], or
+      returns [None] if [k] doesn't belong *)
+
+  val get_exn : key -> 'a t -> 'a
+
+  val add : 'a t -> key -> 'a -> unit
+  (** [add tbl k v] adds [k -> v] to [tbl], possibly replacing the old
+      value associated with [k]. *)
+
+  val remove : 'a t -> key -> unit
+  (** Remove binding *)
+
+  val size : _ t -> int
+  (** Number of bindings *)
+
+  val of_list : (key * 'a) list -> 'a t
+  val to_list : 'a t -> (key * 'a) list
+
+  val of_seq : (key * 'a) sequence -> 'a t
+  val to_seq : 'a t -> (key * 'a) sequence
+
+  val keys : _ t -> key sequence
+  val values : 'a t -> 'a sequence
+end
+
+module type HASHABLE = sig
+  type t
+  val equal : t -> t -> bool
+  val hash : t -> int
+end
+
+module Make(X : HASHABLE) = struct
+  type key = X.t
+
+  type 'a bucket =
+    | Empty
+    | Key of key * 'a * int   (* store the hash too *)
+
+  type 'a t = {
+    mutable arr : 'a bucket array;
+    mutable size : int;
+  }
+
+  let size tbl = tbl.size
+
+  let _reached_max_load tbl =
+    let n = Array.length tbl.arr in
+    (n - tbl.size) < n/10 (* full at 9/10 *)
+
+  let create i =
+    let i = min Sys.max_array_length (max i 8) in
+    { arr=Array.make i Empty; size=0; }
+
+  (* initial index for a value with hash [h] *)
+  let _initial_idx tbl h =
+    h mod Array.length tbl.arr
+
+  let _succ tbl i =
+    let i' = i+1 in
+    if i' = Array.length tbl.arr then 0 else i'
+
+  let _pred tbl i =
+    if i = 0 then Array.length tbl.arr - 1 else i-1
+
+  (* distance to initial bucket, at index [i] with hash [h] *)
+  let _dib tbl h i =
+    let i0 = _initial_idx tbl h in
+    if i>=i0
+      then i-i0
+      else i+ (Array.length tbl.arr - i0 - 1)
+
+  (* insert k->v in [tbl], currently at index [i] *)
+  let rec _linear_probe tbl k v h_k i =
+    match tbl.arr.(i) with
+    | Empty ->
+        (* add binding *)
+        tbl.size <- 1 + tbl.size;
+        tbl.arr.(i) <- Key (k, v, h_k)
+    | Key (k', _, h_k') when X.equal k k' ->
+        (* replace *)
+        assert (h_k = h_k');
+        tbl.arr.(i) <- Key (k, v, h_k)
+    | Key (k', v', h_k') ->
+        if _dib tbl h_k i < _dib tbl h_k' i
+        then (
+          (* replace *)
+          tbl.arr.(i) <- Key (k, v, h_k);
+          _linear_probe tbl k' v' h_k' (_succ tbl i)
+        ) else
+          (* go further *)
+          _linear_probe tbl k v h_k (_succ tbl i)
+
+  (* resize table: put a bigger array in it, then insert values
+    from the old array *)
+  let _resize tbl =
+    let size' = min Sys.max_array_length (2 * Array.length tbl.arr) in
+    let arr' = Array.make size' Empty in
+    let old_arr = tbl.arr in
+    (* replace with new table *)
+    tbl.size <- 0;
+    tbl.arr <- arr';
+    Array.iter
+      (function
+        | Empty -> ()
+        | Key (k, v, h_k) -> _linear_probe tbl k v h_k (_initial_idx tbl h_k)
+      ) old_arr
+
+  let add tbl k v =
+    if _reached_max_load tbl
+      then _resize tbl;
+    (* insert value *)
+    let h_k = X.hash k in
+    _linear_probe tbl k v h_k (_initial_idx tbl h_k)
+
+  (* shift back elements that have a DIB > 0 until an empty bucket is
+   met, or some element doesn't need shifting *)
+  let rec _backward_shift tbl i =
+    match tbl.arr.(i) with
+    | Empty -> ()
+    | Key (_, _, h_k) when _dib tbl h_k i = 0 ->
+        ()  (* stop *)
+    | Key (k, v, h_k) as bucket ->
+        assert (_dib tbl h_k i > 0);
+        (* shift backward *)
+        tbl.arr.(_pred tbl i) <- bucket;
+        tbl.arr.(i) <- Empty;
+        _backward_shift tbl (_succ tbl i)
+
+  (* linear probing for removal of [k] *)
+  let rec _linear_probe_remove tbl k h_k i =
+    match tbl.arr.(i) with
+    | Empty -> ()
+    | Key (k', _, _) when X.equal k k' ->
+        tbl.arr.(i) <- Empty;
+        tbl.size <- tbl.size - 1;
+        _backward_shift tbl (_succ tbl i)
+    | Key (_, _, h_k') ->
+        if _dib tbl h_k' i < _dib tbl h_k i
+          then ()  (* [k] not present, would be here otherwise *)
+          else _linear_probe_remove tbl k h_k (_succ tbl i)
+
+  let remove tbl k =
+    let h_k = X.hash k in
+    _linear_probe_remove tbl k h_k (_initial_idx tbl h_k)
+
+  let rec _get_exn tbl k h_k i dib =
+    match tbl.arr.(i) with
+    | Empty -> raise Not_found
+    | Key (k', v', _) when X.equal k k' -> v'
+    | Key (_, _, h_k') ->
+        if _dib tbl h_k' i < dib
+          then raise Not_found  (* [k] would be here otherwise *)
+          else _get_exn tbl k h_k (_succ tbl i) (dib+1)
+
+  let get_exn k tbl =
+    let h_k = X.hash k in
+    let i0 = _initial_idx tbl h_k in
+    match tbl.arr.(i0) with
+    | Empty -> raise Not_found
+    | Key (k', v, _) ->
+      if X.equal k k' then v
+      else let i1 = _succ tbl i0 in
+        match  tbl.arr.(i1) with
+        | Empty -> raise Not_found
+        | Key (k', v, _) ->
+          if X.equal k k' then v
+          else
+            let i2 = _succ tbl i1 in
+            match tbl.arr.(i2) with
+            | Empty -> raise Not_found
+            | Key (k', v, _) ->
+              if X.equal k k' then v
+              else _get_exn tbl k h_k (_succ tbl i2) 3
+
+  let get k tbl =
+    try Some (get_exn k tbl)
+    with Not_found -> None
+
+  let find_exn tbl k = get_exn k tbl
+
+  let find tbl k =
+    try Some (get_exn k tbl)
+    with Not_found -> None
+
+  let mem tbl k =
+    try ignore (get_exn k tbl); true
+    with Not_found -> false
+
+  let of_list l =
+    let tbl = create 16 in
+    List.iter (fun (k,v) -> add tbl k v) l;
+    tbl
+
+  let to_list tbl =
+    Array.fold_left
+      (fun acc bucket -> match bucket with
+        | Empty -> acc
+        | Key (k,v,_) -> (k,v)::acc
+      ) [] tbl.arr
+
+  let of_seq seq =
+    let tbl = create 16 in
+    seq (fun (k,v) -> add tbl k v);
+    tbl
+
+  let to_seq tbl yield =
+    Array.iter
+      (function Empty -> () | Key (k, v, _) -> yield (k,v))
+      tbl.arr
+
+  let keys tbl yield =
+    Array.iter
+      (function Empty -> () | Key (k, _, _) -> yield k)
+      tbl.arr
+
+  let values tbl yield =
+    Array.iter
+      (function Empty -> () | Key (_, v, _) -> yield v)
+      tbl.arr
+end
+

core/CCFlatHashtbl.mli

@@ -0,0 +1,84 @@
+
+(*
+copyright (c) 2013-2014, simon cruanes
+all rights reserved.
+
+redistribution and use in source and binary forms, with or without
+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 Open-Addressing Hash-table}
+
+This module was previously named [CCHashtbl], but the name is now used for
+an extension of the standard library's hashtables.
+
+@since NEXT_RELEASE *)
+
+type 'a sequence = ('a -> unit) -> unit
+
+module type S = sig
+  type key
+  type 'a t
+
+  val create : int -> 'a t
+  (** Create a new table of the given initial capacity *)
+
+  val mem : 'a t -> key -> bool
+  (** [mem tbl k] returns [true] iff [k] is mapped to some value
+      in [tbl] *)
+
+  val find : 'a t -> key -> 'a option
+
+  val find_exn : 'a t -> key -> 'a
+
+  val get : key -> 'a t -> 'a option
+  (** [get k tbl] recovers the value for [k] in [tbl], or
+      returns [None] if [k] doesn't belong *)
+
+  val get_exn : key -> 'a t -> 'a
+
+  val add : 'a t -> key -> 'a -> unit
+  (** [add tbl k v] adds [k -> v] to [tbl], possibly replacing the old
+      value associated with [k]. *)
+
+  val remove : 'a t -> key -> unit
+  (** Remove binding *)
+
+  val size : _ t -> int
+  (** Number of bindings *)
+
+  val of_list : (key * 'a) list -> 'a t
+  val to_list : 'a t -> (key * 'a) list
+
+  val of_seq : (key * 'a) sequence -> 'a t
+  val to_seq : 'a t -> (key * 'a) sequence
+
+  val keys : _ t -> key sequence
+  val values : 'a t -> 'a sequence
+end
+
+module type HASHABLE = sig
+  type t
+  val equal : t -> t -> bool
+  val hash : t -> int
+end
+
+module Make(X : HASHABLE) : S with type key = X.t

core/CCHashtbl.ml

@@ -24,249 +24,207 @@ 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 Extension to the standard Hashtbl}  *)
-(** {1 Open-Addressing Hash-table}
-
-We use Robin-Hood hashing as described in
-http://codecapsule.com/2013/11/17/robin-hood-hashing-backward-shift-deletion/
-with backward shift. *)
 
 type 'a sequence = ('a -> unit) -> unit
+type 'a eq = 'a -> 'a -> bool
+type 'a hash = 'a -> int
 
-module type S = sig
+(** {2 Polymorphic tables} *)
-  type key
-  type 'a t
 
-  val create : int -> 'a t
+let get tbl x =
-  (** Create a new table of the given initial capacity *)
+  try Some (Hashtbl.find tbl x)
-
-  val mem : 'a t -> key -> bool
-  (** [mem tbl k] returns [true] iff [k] is mapped to some value
-      in [tbl] *)
-
-  val find : 'a t -> key -> 'a option
-
-  val find_exn : 'a t -> key -> 'a
-
-  val get : key -> 'a t -> 'a option
-  (** [get k tbl] recovers the value for [k] in [tbl], or
-      returns [None] if [k] doesn't belong *)
-
-  val get_exn : key -> 'a t -> 'a
-
-  val add : 'a t -> key -> 'a -> unit
-  (** [add tbl k v] adds [k -> v] to [tbl], possibly replacing the old
-      value associated with [k]. *)
-
-  val remove : 'a t -> key -> unit
-  (** Remove binding *)
-
-  val size : _ t -> int
-  (** Number of bindings *)
-
-  val of_list : (key * 'a) list -> 'a t
-  val to_list : 'a t -> (key * 'a) list
-
-  val of_seq : (key * 'a) sequence -> 'a t
-  val to_seq : 'a t -> (key * 'a) sequence
-
-  val keys : _ t -> key sequence
-  val values : 'a t -> 'a sequence
-end
-
-module type HASHABLE = sig
-  type t
-  val equal : t -> t -> bool
-  val hash : t -> int
-end
-
-module Make(X : HASHABLE) = struct
-  type key = X.t
-
-  type 'a bucket =
-    | Empty
-    | Key of key * 'a * int   (* store the hash too *)
-
-  type 'a t = {
-    mutable arr : 'a bucket array;
-    mutable size : int;
-  }
-
-  let size tbl = tbl.size
-
-  let _reached_max_load tbl =
-    let n = Array.length tbl.arr in
-    (n - tbl.size) < n/10 (* full at 9/10 *)
-
-  let create i =
-    let i = min Sys.max_array_length (max i 8) in
-    { arr=Array.make i Empty; size=0; }
-
-  (* initial index for a value with hash [h] *)
-  let _initial_idx tbl h =
-    h mod Array.length tbl.arr
-
-  let _succ tbl i =
-    let i' = i+1 in
-    if i' = Array.length tbl.arr then 0 else i'
-
-  let _pred tbl i =
-    if i = 0 then Array.length tbl.arr - 1 else i-1
-
-  (* distance to initial bucket, at index [i] with hash [h] *)
-  let _dib tbl h i =
-    let i0 = _initial_idx tbl h in
-    if i>=i0
-      then i-i0
-      else i+ (Array.length tbl.arr - i0 - 1)
-
-  (* insert k->v in [tbl], currently at index [i] *)
-  let rec _linear_probe tbl k v h_k i =
-    match tbl.arr.(i) with
-    | Empty ->
-        (* add binding *)
-        tbl.size <- 1 + tbl.size;
-        tbl.arr.(i) <- Key (k, v, h_k)
-    | Key (k', _, h_k') when X.equal k k' ->
-        (* replace *)
-        assert (h_k = h_k');
-        tbl.arr.(i) <- Key (k, v, h_k)
-    | Key (k', v', h_k') ->
-        if _dib tbl h_k i < _dib tbl h_k' i
-        then (
-          (* replace *)
-          tbl.arr.(i) <- Key (k, v, h_k);
-          _linear_probe tbl k' v' h_k' (_succ tbl i)
-        ) else
-          (* go further *)
-          _linear_probe tbl k v h_k (_succ tbl i)
-
-  (* resize table: put a bigger array in it, then insert values
-    from the old array *)
-  let _resize tbl =
-    let size' = min Sys.max_array_length (2 * Array.length tbl.arr) in
-    let arr' = Array.make size' Empty in
-    let old_arr = tbl.arr in
-    (* replace with new table *)
-    tbl.size <- 0;
-    tbl.arr <- arr';
-    Array.iter
-      (function
-        | Empty -> ()
-        | Key (k, v, h_k) -> _linear_probe tbl k v h_k (_initial_idx tbl h_k)
-      ) old_arr
-
-  let add tbl k v =
-    if _reached_max_load tbl
-      then _resize tbl;
-    (* insert value *)
-    let h_k = X.hash k in
-    _linear_probe tbl k v h_k (_initial_idx tbl h_k)
-
-  (* shift back elements that have a DIB > 0 until an empty bucket is
-   met, or some element doesn't need shifting *)
-  let rec _backward_shift tbl i =
-    match tbl.arr.(i) with
-    | Empty -> ()
-    | Key (_, _, h_k) when _dib tbl h_k i = 0 ->
-        ()  (* stop *)
-    | Key (k, v, h_k) as bucket ->
-        assert (_dib tbl h_k i > 0);
-        (* shift backward *)
-        tbl.arr.(_pred tbl i) <- bucket;
-        tbl.arr.(i) <- Empty;
-        _backward_shift tbl (_succ tbl i)
-
-  (* linear probing for removal of [k] *)
-  let rec _linear_probe_remove tbl k h_k i =
-    match tbl.arr.(i) with
-    | Empty -> ()
-    | Key (k', _, _) when X.equal k k' ->
-        tbl.arr.(i) <- Empty;
-        tbl.size <- tbl.size - 1;
-        _backward_shift tbl (_succ tbl i)
-    | Key (_, _, h_k') ->
-        if _dib tbl h_k' i < _dib tbl h_k i
-          then ()  (* [k] not present, would be here otherwise *)
-          else _linear_probe_remove tbl k h_k (_succ tbl i)
-
-  let remove tbl k =
-    let h_k = X.hash k in
-    _linear_probe_remove tbl k h_k (_initial_idx tbl h_k)
-
-  let rec _get_exn tbl k h_k i dib =
-    match tbl.arr.(i) with
-    | Empty -> raise Not_found
-    | Key (k', v', _) when X.equal k k' -> v'
-    | Key (_, _, h_k') ->
-        if _dib tbl h_k' i < dib
-          then raise Not_found  (* [k] would be here otherwise *)
-          else _get_exn tbl k h_k (_succ tbl i) (dib+1)
-
-  let get_exn k tbl =
-    let h_k = X.hash k in
-    let i0 = _initial_idx tbl h_k in
-    match tbl.arr.(i0) with
-    | Empty -> raise Not_found
-    | Key (k', v, _) ->
-      if X.equal k k' then v
-      else let i1 = _succ tbl i0 in
-        match  tbl.arr.(i1) with
-        | Empty -> raise Not_found
-        | Key (k', v, _) ->
-          if X.equal k k' then v
-          else
-            let i2 = _succ tbl i1 in
-            match tbl.arr.(i2) with
-            | Empty -> raise Not_found
-            | Key (k', v, _) ->
-              if X.equal k k' then v
-              else _get_exn tbl k h_k (_succ tbl i2) 3
-
-  let get k tbl =
-    try Some (get_exn k tbl)
   with Not_found -> None
 
-  let find_exn tbl k = get_exn k tbl
+let keys tbl k = Hashtbl.iter (fun key _ -> k key) tbl
 
-  let find tbl k =
+let values tbl k = Hashtbl.iter (fun _ v -> k v) tbl
-    try Some (get_exn k tbl)
-    with Not_found -> None
 
-  let mem tbl k =
+let to_seq tbl k = Hashtbl.iter (fun key v -> k (key,v)) tbl
-    try ignore (get_exn k tbl); true
-    with Not_found -> false
 
-  let of_list l =
+let of_seq seq =
-    let tbl = create 16 in
+  let tbl = Hashtbl.create 32 in
-    List.iter (fun (k,v) -> add tbl k v) l;
+  seq (fun (k,v) -> Hashtbl.add tbl k v);
   tbl
 
 let to_list tbl =
-    Array.fold_left
+  Hashtbl.fold
-      (fun acc bucket -> match bucket with
+    (fun k v l -> (k,v) :: l)
-        | Empty -> acc
+    tbl []
-        | Key (k,v,_) -> (k,v)::acc
+
-      ) [] tbl.arr
+let of_list l =
+  let tbl = Hashtbl.create 32 in
+  List.iter (fun (k,v) -> Hashtbl.add tbl k v) l;
+  tbl
+
+(** {2 Functor} *)
+
+module type S = sig
+  include Hashtbl.S
+
+  val get : 'a t -> key -> 'a option
+  (** Safe version of {!Hashtbl.find} *)
+
+  val keys : 'a t -> key sequence
+  (** Iterate on keys (similar order as {!Hashtbl.iter}) *)
+
+  val values : 'a t -> 'a sequence
+  (** Iterate on values in the table *)
+
+  val to_seq : 'a t -> (key * 'a) sequence
+  (** Iterate on values in the table *)
+
+  val of_seq : (key * 'a) sequence -> 'a t
+  (** From the given bindings, added in order *)
+
+  val to_list : 'a t -> (key * 'a) list
+  (** List of bindings (order unspecified)  *)
+
+  val of_list : (key * 'a) list -> 'a t
+  (** From the given list of bindings, added in order *)
+end
+
+module Make(X : Hashtbl.HashedType) = struct
+  include Hashtbl.Make(X)
+
+  let get tbl x =
+    try Some (find tbl x)
+    with Not_found -> None
+
+  let keys tbl k = iter (fun key _ -> k key) tbl
+
+  let values tbl k = iter (fun _ v -> k v) tbl
+
+  let to_seq tbl k = iter (fun key v -> k (key,v)) tbl
 
   let of_seq seq =
-    let tbl = create 16 in
+    let tbl = create 32 in
     seq (fun (k,v) -> add tbl k v);
     tbl
 
-  let to_seq tbl yield =
+  let to_list tbl =
-    Array.iter
+    fold
-      (function Empty -> () | Key (k, v, _) -> yield (k,v))
+      (fun k v l -> (k,v) :: l)
-      tbl.arr
+      tbl []
 
-  let keys tbl yield =
+  let of_list l =
-    Array.iter
+    let tbl = create 32 in
-      (function Empty -> () | Key (k, _, _) -> yield k)
+    List.iter (fun (k,v) -> add tbl k v) l;
-      tbl.arr
+    tbl
-
-  let values tbl yield =
-    Array.iter
-      (function Empty -> () | Key (_, v, _) -> yield v)
-      tbl.arr
 end
 
+(** {2 Default Table} *)
+
+module type DEFAULT = sig
+  type key
+
+  type 'a t
+  (** A hashtable for keys of type [key] and values of type ['a] *)
+
+  val create : ?size:int -> 'a -> 'a t
+  (** [create d] makes a new table that maps every key to [d] by default.
+      @param size optional size of the initial table *)
+
+  val create_with : ?size:int -> (key -> 'a) -> 'a t
+  (** Similar to [create d] but here [d] is a function called to obtain a
+      new default value for each distinct key. Useful if the default
+      value is stateful. *)
+
+  val get : 'a t -> key -> 'a
+  (** Unfailing retrieval (possibly returns the default value) *)
+
+  val set : 'a t -> key -> 'a -> unit
+  (** Replace the current binding for this key *)
+
+  val remove : 'a t -> key -> unit
+  (** Remove the binding for this key. If [get tbl k] is called later, the
+      default value for the table will be returned *)
+
+  val to_seq : 'a t -> (key * 'a) sequence
+  (** Pairs of [(elem, count)] for all elements whose count is positive *)
+end
+
+module MakeDefault(X : Hashtbl.HashedType) = struct
+  type key = X.t
+
+  module T = Hashtbl.Make(X)
+
+  type 'a t = {
+    default : key -> 'a;
+    tbl : 'a T.t
+  }
+
+  let create_with ?(size=32) default = { default; tbl=T.create size }
+
+  let create ?size d = create_with ?size (fun _ -> d)
+
+  let get tbl k =
+    try T.find tbl.tbl k
+    with Not_found ->
+      let v = tbl.default k in
+      T.add tbl.tbl k v;
+      v
+
+  let set tbl k v = T.replace tbl.tbl k v
+
+  let remove tbl k = T.remove tbl.tbl k
+
+  let to_seq tbl k = T.iter (fun key v -> k (key,v)) tbl.tbl
+end
+
+(** {2 Count occurrences using a Hashtbl} *)
+
+module type COUNTER = sig
+  type elt
+  (** Elements that are to be counted *)
+
+  type t
+
+  val create : int -> t
+  (** A counter maps elements to natural numbers (the number of times this
+      element occurred) *)
+
+  val incr : t -> elt -> unit
+  (** Increment the counter for the given element *)
+
+  val incr_by : t -> int -> elt -> unit
+  (** Add several occurrences at once *)
+
+  val get : t -> elt -> int
+  (** Number of occurrences for this element *)
+
+  val add_seq : t -> elt sequence -> unit
+  (** Increment each element of the sequence *)
+
+  val of_seq : elt sequence -> t
+  (** [of_seq s] is the same as [add_seq (create ())] *)
+end
+
+module MakeCounter(X : Hashtbl.HashedType) = struct
+  type elt = X.t
+
+  module T = Hashtbl.Make(X)
+
+  type t = int T.t
+
+  let create size = T.create size
+
+  let get tbl x = try T.find tbl x with Not_found -> 0
+
+  let incr tbl x =
+    let n = get tbl x in
+    T.replace tbl x (n+1)
+
+  let incr_by tbl n x = 
+    let n' = get tbl x in
+    if n' + n <= 0
+    then T.remove tbl x
+    else T.replace tbl x (n+n')
+
+  let add_seq tbl seq = seq (incr tbl)
+
+  let of_seq seq =
+    let tbl = create 32 in
+    add_seq tbl seq;
+    tbl
+end

core/CCHashtbl.mli

@@ -25,55 +25,128 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *)
 
 
-(** {1 Open-Addressing Hash-table} *)
+(** {1 Extension to the standard Hashtbl} 
+
+@since NEXT_RELEASE *)
 
 type 'a sequence = ('a -> unit) -> unit
+type 'a eq = 'a -> 'a -> bool
+type 'a hash = 'a -> int
+
+(** {2 Polymorphic tables} *)
+
+val get : ('a,'b) Hashtbl.t -> 'a -> 'b option
+(** Safe version of {!Hashtbl.find} *)
+
+val keys : ('a,'b) Hashtbl.t -> 'a sequence
+(** Iterate on keys (similar order as {!Hashtbl.iter}) *)
+
+val values : ('a,'b) Hashtbl.t -> 'b sequence
+(** Iterate on values in the table *)
+
+val to_seq : ('a,'b) Hashtbl.t -> ('a * 'b) sequence
+(** Iterate on bindings in the table *)
+
+val of_seq : ('a * 'b) sequence -> ('a,'b) Hashtbl.t
+(** From the given bindings, added in order *)
+
+val to_list : ('a,'b) Hashtbl.t -> ('a * 'b) list
+(** List of bindings (order unspecified)  *)
+
+val of_list : ('a * 'b) list -> ('a,'b) Hashtbl.t
+(** From the given list of bindings, added in order *)
+
+(** {2 Functor} *)
 
 module type S = sig
-  type key
+  include Hashtbl.S
-  type 'a t
 
-  val create : int -> 'a t
+  val get : 'a t -> key -> 'a option
-  (** Create a new table of the given initial capacity *)
+  (** Safe version of {!Hashtbl.find} *)
 
-  val mem : 'a t -> key -> bool
+  val keys : 'a t -> key sequence
-  (** [mem tbl k] returns [true] iff [k] is mapped to some value
+  (** Iterate on keys (similar order as {!Hashtbl.iter}) *)
-      in [tbl] *)
 
-  val find : 'a t -> key -> 'a option
+  val values : 'a t -> 'a sequence
+  (** Iterate on values in the table *)
 
-  val find_exn : 'a t -> key -> 'a
+  val to_seq : 'a t -> (key * 'a) sequence
-
+  (** Iterate on values in the table *)
-  val get : key -> 'a t -> 'a option
-  (** [get k tbl] recovers the value for [k] in [tbl], or
-      returns [None] if [k] doesn't belong *)
-
-  val get_exn : key -> 'a t -> 'a
-
-  val add : 'a t -> key -> 'a -> unit
-  (** [add tbl k v] adds [k -> v] to [tbl], possibly replacing the old
-      value associated with [k]. *)
-
-  val remove : 'a t -> key -> unit
-  (** Remove binding *)
-
-  val size : _ t -> int
-  (** Number of bindings *)
-
-  val of_list : (key * 'a) list -> 'a t
-  val to_list : 'a t -> (key * 'a) list
 
   val of_seq : (key * 'a) sequence -> 'a t
+  (** From the given bindings, added in order *)
+
+  val to_list : 'a t -> (key * 'a) list
+  (** List of bindings (order unspecified)  *)
+
+  val of_list : (key * 'a) list -> 'a t
+  (** From the given list of bindings, added in order *)
+end
+
+module Make(X : Hashtbl.HashedType) : S with type key = X.t
+
+(** {2 Default Table}
+
+A table with a default element for keys that were never added. *)
+
+module type DEFAULT = sig
+  type key
+
+  type 'a t
+  (** A hashtable for keys of type [key] and values of type ['a] *)
+
+  val create : ?size:int -> 'a -> 'a t
+  (** [create d] makes a new table that maps every key to [d] by default.
+      @param size optional size of the initial table *)
+
+  val create_with : ?size:int -> (key -> 'a) -> 'a t
+  (** Similar to [create d] but here [d] is a function called to obtain a
+      new default value for each distinct key. Useful if the default
+      value is stateful. *)
+
+  val get : 'a t -> key -> 'a
+  (** Unfailing retrieval (possibly returns the default value). This will
+      modify the table if the key wasn't present. *)
+
+  val set : 'a t -> key -> 'a -> unit
+  (** Replace the current binding for this key *)
+
+  val remove : 'a t -> key -> unit
+  (** Remove the binding for this key. If [get tbl k] is called later, the
+      default value for the table will be returned *)
+
   val to_seq : 'a t -> (key * 'a) sequence
-
+  (** Pairs of [(elem, value)] for all elements on which [get] was called *)
-  val keys : _ t -> key sequence
-  val values : 'a t -> 'a sequence
 end
 
-module type HASHABLE = sig
+module MakeDefault(X : Hashtbl.HashedType) : DEFAULT with type key = X.t
+
+(** {2 Count occurrences using a Hashtbl} *)
+
+module type COUNTER = sig
+  type elt
+  (** Elements that are to be counted *)
+
   type t
-  val equal : t -> t -> bool
+
-  val hash : t -> int
+  val create : int -> t
+  (** A counter maps elements to natural numbers (the number of times this
+      element occurred) *)
+
+  val incr : t -> elt -> unit
+  (** Increment the counter for the given element *)
+
+  val incr_by : t -> int -> elt -> unit
+  (** Add several occurrences at once *)
+
+  val get : t -> elt -> int
+  (** Number of occurrences for this element *)
+
+  val add_seq : t -> elt sequence -> unit
+  (** Increment each element of the sequence *)
+
+  val of_seq : elt sequence -> t
+  (** [of_seq s] is the same as [add_seq (create ())] *)
 end
 
-module Make(X : HASHABLE) : S with type key = X.t
+module MakeCounter(X : Hashtbl.HashedType) : COUNTER with type elt = X.t

core/CCPair.ml

@@ -64,6 +64,10 @@ let compare f g (x1,y1) (x2,y2) =
   if c <> 0 then c else g y1 y2
 
 type 'a printer = Buffer.t -> 'a -> unit
+type 'a formatter = Format.formatter -> 'a -> unit
 
 let pp pp_x pp_y buf (x,y) =
   Printf.bprintf buf "(%a, %a)" pp_x x pp_y y
+
+let print pa pb fmt (x,y) =
+  Format.fprintf fmt "(%a, %a)" pa x pb y

core/CCPair.mli

@@ -83,5 +83,8 @@ val equal : ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a * 'b) -> ('a * 'b) -
 val compare : ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a * 'b) -> ('a * 'b) -> int
 
 type 'a printer = Buffer.t -> 'a -> unit
+type 'a formatter = Format.formatter -> 'a -> unit
 
 val pp : 'a printer -> 'b printer -> ('a*'b) printer
+
+val print : 'a formatter -> 'b formatter -> ('a*'b) formatter

core/CCRandom.ml

@@ -41,6 +41,8 @@ let map f g st = f (g st)
 
 let (>|=) g f st = map f g st
 
+let delay f st = f () st
+
 let _choose_array a st =
   if Array.length a = 0 then invalid_arg "CCRandom.choose_array";
   a.(Random.State.int st (Array.length a))
@@ -69,6 +71,8 @@ let replicate n g st =
     if n = 0 then acc else aux (g st :: acc) (n-1)
   in aux [] n
 
+let list_seq l st = List.map (fun f -> f st) l
+
 exception SplitFail
 
 let _split i st =

core/CCRandom.mli

@@ -45,6 +45,21 @@ val map : ('a -> 'b) -> 'a t -> 'b t
 
 val (>|=) : 'a t -> ('a -> 'b) -> 'b t
 
+val delay : (unit -> 'a t) -> 'a t
+(** Delay evaluation. Useful for side-effectful generators that
+    need some code to run for every call.
+    Example:
+    {[
+    let gensym = let r = ref 0 in fun () -> incr r; !r ;;
+
+    delay (fun () ->
+      let name = gensym() in
+      small_int >>= fun i -> return (name,i)
+    )
+    ]}
+    @since NEXT_RELEASE
+*)
+
 val choose : 'a t list -> 'a option t
 (** Choose a generator within the list. *)
 
@@ -59,6 +74,12 @@ val choose_return : 'a list -> 'a t
     @raise Invalid_argument if the list is empty *)
 
 val replicate : int -> 'a t -> 'a list t
+(** [replace n g] makes a list of [n] elements which are all generated
+    randomly using [g] *)
+
+val list_seq : 'a t list -> 'a list t
+(** Build random lists from lists of random generators
+    @since NEXT_RELEASE *)
 
 val small_int : int t
 

core/CCString.ml

@@ -48,8 +48,6 @@ module type S = sig
   val pp : Buffer.t -> t -> unit
 end
 
-type t = string
-
 let equal (a:string) b = a=b
 
 let compare = String.compare

core/CCString.mli

@@ -54,47 +54,45 @@ end
 
 (** {2 Strings} *)
 
-type t = string
+val equal : string -> string -> bool
 
-val equal : t -> t -> bool
+val compare : string -> string -> int
 
-val compare : t -> t -> int
+val hash : string -> int
 
-val hash : t -> int
+val init : int -> (int -> char) -> string
-
-val init : int -> (int -> char) -> t
 (** Analog to [Array.init].
     @since 0.3.3 *)
 
-val of_gen : char gen -> t
+val of_gen : char gen -> string
-val of_seq : char sequence -> t
+val of_seq : char sequence -> string
-val of_klist : char klist -> t
+val of_klist : char klist -> string
-val of_list : char list -> t
+val of_list : char list -> string
-val of_array : char array -> t
+val of_array : char array -> string
 
-val to_array : t -> char array
+val to_array : string -> char array
 
-val find : ?start:int -> sub:t -> t -> int
+val find : ?start:int -> sub:string -> string -> int
-(** Find [sub] in the string, returns its first index or -1.
+(** Find [sub] in stringhe string, returns its first index or -1.
     Should only be used with very small [sub] *)
 
-val is_sub : sub:t -> int -> t -> int -> len:int -> bool
+val is_sub : sub:string -> int -> string -> int -> len:int -> bool
-(** [is_sub ~sub i s j ~len] returns [true] iff the substring of
+(** [is_sub ~sub i s j ~len] returns [true] iff stringhe substring of
     [sub] starting at position [i] and of length [len],
     is a substring of [s] starting at position [j] *)
 
-val repeat : t -> int -> t
+val repeat : string -> int -> string
-(** The same string, repeated n times *)
+(** The same string, repeated n stringimes *)
 
-val prefix : pre:t -> t -> bool
+val prefix : pre:string -> string -> bool
 (** [str_prefix ~pre s] returns [true] iff [pre] is a prefix of [s] *)
 
-include S with type t := t
+include S with type t := string
 
 (** {2 Splitting} *)
 
 module Split : sig
-  val list_ : by:t -> t -> (t*int*int) list
+  val list_ : by:string -> string -> (string*int*int) list
   (** split the given string along the given separator [by]. Should only
       be used with very small separators, otherwise
       use {!Containers_string.KMP}.
@@ -103,18 +101,18 @@ module Split : sig
       the slice.
       @raise Failure if [by = ""] *)
 
-  val gen : by:t -> t -> (t*int*int) gen
+  val gen : by:string -> string -> (string*int*int) gen
 
-  val seq : by:t -> t -> (t*int*int) sequence
+  val seq : by:string -> string -> (string*int*int) sequence
 
-  val klist : by:t -> t -> (t*int*int) klist
+  val klist : by:string -> string -> (string*int*int) klist
 
   (** {6 Copying functions}
 
   Those split functions actually copy the substrings, which can be
   more convenient but less efficient in general *)
 
-  val list_cpy : by:t -> t -> t list
+  val list_cpy : by:string -> string -> string list
 
   (*$T
     Split.list_cpy ~by:"," "aa,bb,cc" = ["aa"; "bb"; "cc"]
@@ -122,11 +120,11 @@ module Split : sig
     Split.list_cpy ~by:" " "hello  world aie" = ["hello"; ""; "world"; "aie"]
   *)
 
-  val gen_cpy : by:t -> t -> t gen
+  val gen_cpy : by:string -> string -> string gen
 
-  val seq_cpy : by:t -> t -> t sequence
+  val seq_cpy : by:string -> string -> string sequence
 
-  val klist_cpy : by:t -> t -> t klist
+  val klist_cpy : by:string -> string -> string klist
 end
 
 (** {2 Slices} A contiguous part of a string *)

core/CCVector.ml

@@ -86,7 +86,7 @@ let _empty_array v =
 let _resize v newcapacity =
   assert (newcapacity >= v.size);
   assert (not (_empty_array v));
-  let new_vec = Array.create newcapacity v.vec.(0) in
+  let new_vec = Array.make newcapacity v.vec.(0) in
   Array.blit v.vec 0 new_vec 0 v.size;
   v.vec <- new_vec;
   ()

core/META

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: c0cc05feb3c737cd5d151af31c1723c3)
+# DO NOT EDIT (digest: 176a952c03cc29ec8fbecdbfa8ef56f0)
 version = "0.3.4"
 description = "A modular standard library focused on data structures."
 archive(byte) = "containers.cma"
@@ -28,6 +28,17 @@ package "string" (
  exists_if = "containers_string.cma"
 )
 
+package "pervasives" (
+ version = "0.3.4"
+ description = "A modular standard library focused on data structures."
+ requires = "containers"
+ archive(byte) = "containers_pervasives.cma"
+ archive(byte, plugin) = "containers_pervasives.cma"
+ archive(native) = "containers_pervasives.cmxa"
+ archive(native, plugin) = "containers_pervasives.cmxs"
+ exists_if = "containers_pervasives.cma"
+)
+
 package "misc" (
  version = "0.3.4"
  description = "A modular standard library focused on data structures."

core/containers.mldylib

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 5702460a7b213be45526616207085458)
+# DO NOT EDIT (digest: bc148b0cd76b42738441881becfb4513)
 CCVector
 CCDeque
 CCGen
@@ -31,4 +31,5 @@ CCKTree
 CCTrie
 CCString
 CCHashtbl
+CCFlatHashtbl
 # OASIS_STOP

core/containers.mllib

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 5702460a7b213be45526616207085458)
+# DO NOT EDIT (digest: bc148b0cd76b42738441881becfb4513)
 CCVector
 CCDeque
 CCGen
@@ -31,4 +31,5 @@ CCKTree
 CCTrie
 CCString
 CCHashtbl
+CCFlatHashtbl
 # OASIS_STOP

examples/id_sexp.ml

@@ -0,0 +1,13 @@
+
+
+let () =
+  if Array.length Sys.argv <> 2 then failwith "usage: id_sexp file";
+  let f = Sys.argv.(1) in
+  let s = Sexp.L.of_file f in
+  match s with
+  | `Ok l ->
+      List.iter
+        (fun s -> Format.printf "@[%a@]@." Sexp.print s)
+        l
+  | `Error msg ->
+      Format.printf "error: %s@." msg

misc/automaton.ml

@@ -92,7 +92,7 @@ module O = struct
   let create () =
     let s = {
       n = 0;
-      handlers = Array.create 3 nop_handler;
+      handlers = Array.make 3 nop_handler;
       alive = NotAlive;
     } in
     s
@@ -116,7 +116,7 @@ module O = struct
     (* resize handlers if needed *)
     (if s.n = Array.length s.handlers
       then begin
-        let handlers = Array.create (s.n + 4) nop_handler in
+        let handlers = Array.make (s.n + 4) nop_handler in
         Array.blit s.handlers 0 handlers 0 s.n;
         s.handlers <- handlers
       end);

misc/cache.ml

@@ -116,7 +116,7 @@ module Linear(X : EQ) = struct
 
   let create size =
     assert (size >= 1);
-    Array.create size Empty
+    Array.make size Empty
 
   let clear cache =
     Array.fill cache 0 (Array.length cache) Empty
@@ -164,7 +164,7 @@ module Linear2(X : EQ)(Y : EQ) = struct
 
   let create size =
     assert (size >= 1);
-    Array.create size Empty
+    Array.make size Empty
 
   let clear cache =
     Array.fill cache 0 (Array.length cache) Empty
@@ -214,7 +214,7 @@ module Replacing(X : HASH) = struct
   and 'a bucket = Empty | Assoc of key * 'a | AssocRaise of key * exn
 
   let create size =
-    Array.create size Empty
+    Array.make size Empty
 
   let clear c =
     Array.fill c 0 (Array.length c) Empty
@@ -256,7 +256,7 @@ module Replacing2(X : HASH)(Y : HASH) = struct
   and key2 = Y.t
 
   let create size =
-    Array.create size Empty
+    Array.make size Empty
 
   let clear c =
     Array.fill c 0 (Array.length c) Empty

misc/fHashtbl.ml

@@ -80,7 +80,7 @@ module PArray = struct
   (* XXX maybe having a snapshot of the array from point to point may help? *)
 
   let make size elt =
-    let a = Array.create size elt in
+    let a = Array.make size elt in
     ref (Array a)
 
   (** Recover the given version of the shared array. Returns the array

misc/puf.ml

@@ -36,7 +36,7 @@ module PArray = struct
   (* XXX maybe having a snapshot of the array from point to point may help? *)
 
   let make size elt =
-    let a = Array.create size elt in
+    let a = Array.make size elt in
     ref (Array a)
 
   let init size f =

misc/sexp.ml

@@ -25,256 +25,637 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 (** {1 Simple S-expression parsing/printing} *)
 
-type t =
+type 'a or_error = [ `Ok of 'a | `Error of string ]
-  | K of string * t  (* keyword *)
+type 'a sequence = ('a -> unit) -> unit
-  | I of int
+type 'a gen = unit -> 'a option
-  | S of string
-  | L of t list
 
-let eq a b = a = b
+type t =
+  | Atom of string
+  | List of t list
+
+let equal a b = a = b
 
 let compare a b = Pervasives.compare a b
 
 let hash a = Hashtbl.hash a
 
+let of_int x = Atom (string_of_int x)
+let of_float x = Atom (string_of_float x)
+let of_bool x = Atom (string_of_bool x)
+let of_string x = Atom x
+let of_unit = List []
+let of_list l = List l
+let of_pair (x,y) = List[x;y]
+let of_triple (x,y,z) = List[x;y;z]
+
+let of_variant name args = List (Atom name :: args)
+let of_field name t = List [Atom name; t]
+let of_record l =
+  List (List.map (fun (n,x) -> of_field n x) l)
+
+let _with_in filename f =
+  let ic = open_in filename in
+  try
+    let x = f ic in
+    close_in ic;
+    x
+  with e ->
+    close_in ic;
+    `Error (Printexc.to_string e)
+
+let _with_out filename f =
+  let oc = open_out filename in
+  try
+    let x = f oc in
+    close_out oc;
+    x
+  with e ->
+    close_out oc;
+    raise e
+
 (** {2 Serialization (encoding)} *)
 
+(* shall we escape the string because of one of its chars? *)
+let _must_escape s =
+  try
+    for i = 0 to String.length s - 1 do
+      let c = String.unsafe_get s i in
+      match c with
+      | ' ' | ';' | ')' | '(' | '"' | '\n' | '\t' -> raise Exit
+      | _ when Char.code c > 127 -> raise Exit  (* non-ascii *)
+      | _ -> ()
+    done;
+    false
+  with Exit -> true
+
 let rec to_buf b t = match t with
-  | I i -> Printf.bprintf b "%d" i
+  | Atom s when _must_escape s -> Printf.bprintf b "\"%s\"" (String.escaped s)
-  | S s -> Buffer.add_string b (String.escaped s)
+  | Atom s -> Buffer.add_string b s
-  | K (s, t') ->
+  | List [] -> Buffer.add_string b "()"
-    assert (s.[0] = ':');
+  | List [x] -> Printf.bprintf b "(%a)" to_buf x
-    Buffer.add_string b s;
+  | List l ->
-    Buffer.add_char b ' ';
-    to_buf b t'
-  | L l ->
       Buffer.add_char b '(';
-    List.iteri (fun i t' -> (if i > 0 then Buffer.add_char b ' '; to_buf b t')) l;
+      List.iteri
+        (fun i t' -> (if i > 0 then Buffer.add_char b ' '; to_buf b t'))
+        l;
       Buffer.add_char b ')'
 
 let to_string t =
-  let b = Buffer.create 32 in
+  let b = Buffer.create 128 in
   to_buf b t;
   Buffer.contents b
 
-(* TODO: improve (slow and ugly) *)
+let rec print fmt t = match t with
-let fmt fmt t =
+  | Atom s when _must_escape s -> Format.fprintf fmt "\"%s\"" (String.escaped s)
-  let b = Buffer.create 32 in
+  | Atom s -> Format.pp_print_string fmt s
-  to_buf b t;
+  | List [] -> Format.pp_print_string fmt "()"
-  Format.pp_print_string fmt (Buffer.contents b)
+  | List [x] -> Format.fprintf fmt "@[<hov2>(%a)@]" print x
+  | List l ->
+      Format.open_hovbox 2;
+      Format.pp_print_char fmt '(';
+      List.iteri
+        (fun i t' -> (if i > 0 then Format.fprintf fmt "@ "; print fmt t'))
+        l;
+      Format.pp_print_char fmt ')';
+      Format.close_box ()
+
+let rec print_noindent fmt t = match t with
+  | Atom s when _must_escape s -> Format.fprintf fmt "\"%s\"" (String.escaped s)
+  | Atom s -> Format.pp_print_string fmt s
+  | List [] -> Format.pp_print_string fmt "()"
+  | List [x] -> Format.fprintf fmt "(%a)" print_noindent x
+  | List l ->
+      Format.pp_print_char fmt '(';
+      List.iteri
+        (fun i t' -> (if i > 0 then Format.pp_print_char fmt ' '; print_noindent fmt t'))
+        l;
+      Format.pp_print_char fmt ')'
+
+let to_chan oc t =
+  let fmt = Format.formatter_of_out_channel oc in
+  print fmt t;
+  Format.pp_print_flush fmt ()
+
+let to_file_seq filename seq =
+  _with_out filename
+    (fun oc -> 
+      seq (fun t -> to_chan oc t; output_char oc '\n')
+    )
+
+let to_file filename t = to_file_seq filename (fun k -> k t)
 
 (** {2 Deserialization (decoding)} *)
 
-(** Deserialization is based on the {! decoder} type. Parsing can be
+type 'a parse_result = ['a or_error | `End ]
-    incremental, in which case the input is provided chunk by chunk and
+type 'a partial_result = [ 'a parse_result | `Await ]
-    the decoder contains the parsing state. Once a Sexpr value
-    has been parsed, other values can still be read. *)
 
-type decoder = {
+module Source = struct
-  mutable buf : string;  (* input buffer *)
+  type individual_char =
-  mutable i : int;  (* index in buf *)
+    | NC_yield of char
-  mutable len : int;  (* length of substring to read *)
+    | NC_end
-  mutable c : int;  (* line *)
+    | NC_await
-  mutable l : int;  (* column *)
-  mutable state : parse_result;
-  mutable stack : partial_state list;
-} (** Decoding state *)
 
-(** Result of parsing *)
+  type t = unit -> individual_char
-and parse_result =
+  type source = t
-  | ParseOk of t
-  | ParseError of string
-  | ParsePartial
 
-(** Partial state of the parser *)
+  module Manual = struct
-and partial_state =
+    type t = {
-  | PS_I of bool * int (* sign and integer *)
+      mutable i : int;    (* offset *)
-  | PS_S of Buffer.t (* parsing a string *)
+      mutable stop : bool;
-  | PS_S_escape of Buffer.t (* parsing a string; prev char is \ *)
+      buf : Buffer.t;     (* accessible chunk of input *)
-  | PS_L of t list
+    }
-  | PS_key of string  (* key, waiting for value *)
-  | PS_return of t  (* bottom of stack *)
-  | PS_error of string (* error *)
       
-let mk_decoder () =
+    let make() = {
-  let dec = {
-    buf = "";
       i = 0;
-    len = 0;
+      stop = false;
-    c = 0;
+      buf=Buffer.create 32;
-    l = 0;
+    }
-    state = ParsePartial;
-    stack = [];
-  } in
-  dec
 
-let is_empty dec = dec.len = 0
+    let to_src d () =
-let cur dec = dec.buf.[dec.i]
+      if d.i = Buffer.length d.buf
+        then
+          if d.stop then NC_end else NC_await
+        else (
+          let c = Buffer.nth d.buf d.i in
+          d.i <- d.i + 1;
+          NC_yield c
+        )
 
-let junk dec =
+    let feed d s i len =
-  (* update line/column *)
+      if d.stop then failwith "Sexp.Streaming.Manual.feed: reached EOI";
-  (if cur dec = '\n'
+      Buffer.add_substring d.buf s i len
-    then (dec.c <- 0; dec.l <- dec.l + 1)
-    else dec.c <- dec.c + 1);
-  dec.i <- dec.i + 1;
-  dec.len <- dec.len - 1
 
-let next dec =
+    let reached_end d = d.stop <- true
-  let c = cur dec in
-  junk dec;
-  c
-
-(* parse value *)
-let rec parse_rec dec =
-  match dec.stack with
-  | [PS_return v] ->  (* return value *)
-    dec.stack <- [];
-    dec.state <- ParseOk v;
-    dec.state
-  | [PS_error s] -> (* failure *)
-    dec.stack <- [];
-    dec.state <- ParseError s;
-    dec.state
-  | _ ->
-    if is_empty dec then ParsePartial (* wait *)
-    else begin
-      let c = next dec in
-      (match dec.stack, c with
-      | PS_S_escape b :: stack, 'n' ->
-        Buffer.add_char b '\n';
-        dec.stack <- PS_S b :: stack
-      | PS_S_escape b :: stack, 't' ->
-        Buffer.add_char b '\t';
-        dec.stack <- PS_S b :: stack
-      | (PS_S_escape b) :: stack, ('(' | '\\' | ')' | ' ') ->
-        Buffer.add_char b c;
-        dec.stack <- (PS_S b) :: stack;
-      | (PS_key s) :: _, (')' | '\n' | ' ' | '\t') -> (* error *)
-        error dec ("keyword " ^ s ^ " expected value")
-      | _, ')' -> (* special case for ')' *)
-        close_paren dec
-      | ((PS_L _ | PS_key _) :: _ | []), '-' ->  (* negative num *)
-        dec.stack <- PS_I (false, 0) :: dec.stack
-      | ((PS_L _ | PS_key _) :: _ | []), '0' .. '9' ->  (* positive num *)
-        dec.stack <- PS_I (true, Char.code c - Char.code '0') :: dec.stack
-      | (PS_I (sign, i)) :: stack, '0' .. '9' ->
-        dec.stack <- PS_I (sign, (Char.code c - Char.code '0') + 10 * i) :: stack;
-      | (PS_I (sign, i)) :: stack, (' ' | '\t' | '\n') ->
-        terminate_token dec
-      | stack, '(' ->
-        dec.stack <- PS_L [] :: stack  (* push new list *)
-      | PS_S b :: stack, (' ' | '\t' | '\n') -> (* parsed a string *)
-        terminate_token dec
-      | PS_S b :: stack, '\\' ->
-        dec.stack <- PS_S_escape b :: stack  (* escape next char *)
-      | PS_S b :: _, _ ->
-        Buffer.add_char b c  (* just a char of the string *)
-      | _, (' ' | '\t' | '\n') ->  (* skip *)
-        ()
-      | stack, c ->
-        let b = Buffer.create 7 in
-        Buffer.add_char b c;
-        dec.stack <- PS_S b :: stack
-      );
-      parse_rec dec
   end
-(* When a value is parsed, push it on the stack (possibly collapsing it) *)
-and push_value dec v =
-  match v, dec.stack with
-  | _, [] ->
-    dec.stack <- [PS_return v] (* finished *)
-  | _, (PS_L l) :: stack ->
-    (* add to list *)
-    dec.stack <- (PS_L (v :: l)) :: stack;
-  | v, ((PS_key s) :: stack) ->
-    (* parsed a key/value *)
-    dec.stack <- stack;
-    push_value dec (K (s, v))
-  | _ ->
-    error dec "unexpected value"
-(* closing parenthesis: may terminate several states at once *)
-and close_paren dec =
-  match dec.stack with
-  | PS_L l :: stack ->
-    dec.stack <- stack;
-    push_value dec (L (List.rev l))
-  | (PS_I _ | PS_S _) :: stack ->
-    terminate_token dec;
-    close_paren dec  (* parenthesis still not closed *)
-  | _ ->
-    error dec "Sexp: unexpected ')'"
-(* terminate current token *)
-and terminate_token dec =
-  match dec.stack with
-  | [] -> assert false
-  | (PS_I (sign, i)) :: stack ->
-    dec.stack <- stack;
-    push_value dec (I (if sign then i else ~- i))  (* parsed int *)
-  | (PS_S b) :: stack ->
-    dec.stack <- stack;
-    let s = Buffer.contents b in
-    if s.[0] = ':'
-      then dec.stack <- (PS_key s) :: stack  (* keyword, wait for value *)
-      else push_value dec (S s)
-  | _ ->
-    error dec "Sexp: ill-terminated token"
-(* signal error *)
-and error dec msg =
-  let msg = Printf.sprintf "Sexp: error at line %d, column %d: %s"
-    dec.l dec.c msg in
-  dec.stack <- [PS_error msg]
-
-(* exported parse function *)
-let parse dec s i len =
-  (if i < 0 || i+len > String.length s
-    then invalid_arg "Sexp.parse: not a valid substring");
-  (* add the input to [dec] *)
-  if dec.len = 0
-    then begin
-      dec.buf <- s;
-      dec.i <- i;
-      dec.len <- len;
-    end else begin
-      (* use a buffer to merge the stored input and the new input *)
-      let b = Buffer.create (dec.len + len) in
-      Buffer.add_substring b dec.buf dec.i dec.len;
-      Buffer.add_substring b s i len;
-      dec.buf <- Buffer.contents b;
-      dec.i <- 0;
-      dec.len <- dec.len + len;
-    end;
-  (* state machine *)
-  parse_rec dec
-
-let reset dec =
-  dec.l <- 0;
-  dec.c <- 0;
-  dec.i <- 0;
-  dec.len <- 0;
-  dec.state <- ParsePartial;
-  dec.stack <- [];
-  ()
-
-let state dec = dec.state
-
-let rest dec =
-  String.sub dec.buf dec.i dec.len
-
-let rest_size dec =
-  dec.len
-
-let parse_string s =
-  let dec = mk_decoder () in
-  parse dec s 0 (String.length s)
 
   let of_string s =
-  match parse_string s with
+    let i = ref 0 in
-  | ParseOk t -> t
+    fun () ->
-  | ParsePartial -> invalid_arg "Sexp: partial parse"
+      if !i=String.length s
-  | ParseError msg -> invalid_arg msg
+      then NC_end
+      else (
+        let c = String.get s !i in
+        incr i;
+        NC_yield c
+      )
 
-(* tests:
+  let of_chan ?(bufsize=1024) ic =
+    let buf = String.make bufsize ' ' in
+    let i = ref 0 in
+    let n = ref 0 in
+    let stop = ref false in
+    let rec next() =
+      if !stop then NC_end
+      else if !i = !n
+      then ( (* refill *)
+        i := 0;
+        n := input ic buf 0 bufsize;
+        if !n = 0 then (stop := true; NC_end) else next()
+      ) else (  (* yield *)
+        let c = String.get buf !i in
+        incr i;
+        NC_yield c
+      )
+    in next
 
-let s = Sexp.of_string "(0 a b c 42 :foo 45 :bar (hello-world foo\\tb\\na\\(\\)r -421) (41 -52) 0)";;
+  let of_gen g =
-Sexp.to_string s;;
+    let s = ref "" in
-*)
+    let i = ref 0 in
+    let stop = ref false in
+    let rec next() =
+      if !stop then NC_end
+      else if !i = String.length !s
+      then (
+        match g() with
+        | None -> stop := true; NC_end
+        | Some buf -> s := buf; i := 0; next () 
+      ) else (
+        let c = String.get !s !i in
+        incr i;
+        NC_yield c
+      )
+    in next
+end
+
+module Lexer = struct
+  (** An individual character returned by a source *)
+  type token =
+    | Open
+    | Close
+    | Atom of string
+
+  type decode_state =
+    | St_start
+    | St_atom
+    | St_quoted
+    | St_comment
+    | St_escaped
+    | St_raw_char1 of int
+    | St_raw_char2 of int
+    | St_yield of token
+    | St_error of string
+    | St_end
+
+  type t = {
+    src : Source.t;
+    atom : Buffer.t;    (* atom being parsed *)
+    mutable st : decode_state;
+    mutable line : int;
+    mutable col : int;
+  }
+
+  let make src = {
+    src;
+    st = St_start;
+    line = 1;
+    col = 1;
+    atom = Buffer.create 32;
+  }
+
+  let of_string s = make (Source.of_string s)
+
+  let of_chan ic = make (Source.of_chan ic)
+
+  let line t = t.line
+  let col t = t.col
+
+  (* yield [x] with current state [st] *)
+  let _yield d st x =
+    d.st <- st;
+    `Ok x
+
+  let _take_buffer b =
+    let s = Buffer.contents b in
+    Buffer.clear b;
+    s
+
+  (* raise an error *)
+  let _error d msg =
+    let b = Buffer.create 32 in
+    Printf.bprintf b "at %d, %d: " d.line d.col;
+    Printf.kbprintf
+      (fun b ->
+        let msg' = Buffer.contents b in
+        d.st <- St_error msg';
+        `Error msg')
+      b msg
+
+  let _end d =
+    d.st <- St_end;
+    `End
+
+  let _is_digit c = Char.code '0' <= Char.code c && Char.code c <= Char.code '9'
+  let _digit2i c = Char.code c - Char.code '0'
+
+  (* next token *)
+  let rec _next d st : token partial_result =
+    match st with
+    | St_error msg -> `Error msg
+    | St_end -> _end d
+    | St_yield x ->
+        (* yield the given token, then start a fresh one *)
+        _yield d St_start x
+    | _ ->
+        d.st <- st;
+        _process_next d st
+
+  (* read and proces the next character *)
+  and _process_next d st =
+    match d.src () with
+    | Source.NC_end ->
+        begin match st with
+        | St_error _ | St_end | St_yield _ -> assert false
+        | St_start | St_comment -> _end d
+        | St_atom ->
+            let a = _take_buffer d.atom in
+            _yield d St_end (Atom a)
+        | St_quoted ->
+            let a = _take_buffer d.atom in
+            _yield d St_end (Atom a)
+        | (St_escaped | St_raw_char1 _ | St_raw_char2 _) ->
+            _error d "unexpected end of input (escaping)"
+        end
+    | Source.NC_await -> `Await
+    | Source.NC_yield c ->
+        if c='\n'
+          then (d.col <- 1; d.line <- d.line + 1)
+          else (d.col <- d.col + 1);
+        (* use the next char *)
+        match st with
+        | St_error _ | St_end | St_yield _ -> assert false
+        | St_comment ->
+            begin match c with
+            | '\n' -> _next d St_start
+            | _ -> _next d St_comment
+            end
+        | St_start ->
+            begin match c with
+            | ' ' | '\t' | '\n' -> _next d St_start
+            | ';' -> _next d St_comment
+            | '(' -> _yield d St_start Open
+            | ')' -> _yield d St_start Close
+            | '"' -> _next d St_quoted
+            | _ -> (* read regular atom *)
+                Buffer.add_char d.atom c;
+                _next d St_atom
+            end
+        | St_atom ->
+            begin match c with
+            | ' ' | '\t' | '\n' ->
+                let a = _take_buffer d.atom in
+                _yield d St_start (Atom a)
+            | ';' ->
+                let a = _take_buffer d.atom in
+                _yield d St_comment (Atom a)
+            | ')' ->
+                let a = _take_buffer d.atom in
+                _yield d (St_yield Close) (Atom a)
+            | '(' ->
+                let a = _take_buffer d.atom in
+                _yield d (St_yield Open) (Atom a)
+            | '"' -> _error d "unexpected \" (parsing atom %s)" (Buffer.contents d.atom)
+            | '\\' -> _error d "unexpected \\"
+            | _ ->
+                Buffer.add_char d.atom c;
+                _next d St_atom
+            end
+        | St_quoted ->
+            (* reading an unquoted atom *)
+            begin match c with
+            | '\\' -> _next d St_escaped
+            | '"' ->
+                let a = _take_buffer d.atom in
+                _yield d St_start (Atom a)
+            | _ ->
+                Buffer.add_char d.atom c;
+                _next d St_quoted
+            end
+        | St_escaped ->
+            begin match c with
+              | 'n' -> Buffer.add_char d.atom '\n'; _next d St_quoted
+              | 't' -> Buffer.add_char d.atom '\t'; _next d St_quoted
+              | 'r' -> Buffer.add_char d.atom '\r'; _next d St_quoted
+              | 'b' -> Buffer.add_char d.atom '\b'; _next d St_quoted
+              | '"' -> Buffer.add_char d.atom '"'; _next d St_quoted
+              | '\\' -> Buffer.add_char d.atom '\\'; _next d St_quoted
+              | _ when _is_digit c -> _next d (St_raw_char1 (_digit2i c))
+              | _ -> _error d "unexpected escaped character %c" c
+            end
+        | St_raw_char1 i ->
+            begin match c with
+              | _ when _is_digit c -> _next d (St_raw_char2 (i*10 + _digit2i c))
+              | _ -> _error d "expected digit, got %c" c
+            end
+        | St_raw_char2 i ->
+            begin match c with
+              | c when _is_digit c ->
+                  (* read an escaped char *)
+                  Buffer.add_char d.atom (Char.chr (i*10+_digit2i c));
+                  _next d St_quoted
+              | c -> _error d "expected digit, got %c" c
+            end
+
+  let next d = _next d d.st
+end
+
+module ParseGen = struct
+  type 'a t = unit -> 'a parse_result
+
+  let to_list g : 'a list or_error =
+    let rec aux acc = match g() with
+      | `Error e -> `Error e
+      | `Ok x -> aux (x::acc)
+      | `End -> `Ok (List.rev acc)
+    in
+    aux []
+
+  let head g = match g() with
+    | `End -> `Error "expected at least one element"
+    | #or_error as x -> x
+
+  let head_exn g = match g() with
+    | `Ok x -> x
+    | `Error msg -> failwith msg
+    | `End -> failwith "expected at least one element"
+
+  let take n g =
+    assert (n>=0);
+    let n = ref n in
+    fun () ->
+      if !n = 0 then `End
+      else (
+        decr n;
+        g()
+      )
+end
+
+(* hidden parser state *)
+type parser_state = {
+  ps_d : Lexer.t;
+  mutable ps_stack : t list list;
+}
+
+let mk_ps src = {
+  ps_d = Lexer.make src;
+  ps_stack = [];
+}
+
+let _error ps msg =
+  let msg' = Printf.sprintf "at %d,%d: %s" (Lexer.line ps.ps_d) (Lexer.col ps.ps_d) msg in
+  `Error msg'
+
+(* next token, or await *)
+let rec _next ps : t partial_result =
+  match Lexer.next ps.ps_d with
+  | `Ok (Lexer.Atom s) ->
+      _push ps (Atom s)
+  | `Ok Lexer.Open ->
+      ps.ps_stack <- [] :: ps.ps_stack;
+      _next ps
+  | `Ok Lexer.Close ->
+      begin match ps.ps_stack with
+      | [] -> _error ps "unbalanced ')'"
+      | l :: stack ->
+          ps.ps_stack <- stack;
+          _push ps (List (List.rev l))
+      end
+  | `Error msg -> `Error msg
+  | `Await -> `Await
+  | `End -> `End
+
+(* push a S-expr on top of the parser stack *)
+and _push ps e = match ps.ps_stack with
+  | [] ->
+      `Ok e
+  | l :: tl ->
+      ps.ps_stack <- (e :: l) :: tl;
+      _next ps
+
+(* assume [ps] never needs [`Await] *)
+let _never_block ps () = match _next ps with
+  | `Await -> assert false
+  | `Ok x -> `Ok x
+  | `Error e -> `Error e
+  | `End -> `End
+
+(* parse from a generator of string slices *)
+let parse_gen g : t ParseGen.t =
+  let ps = mk_ps (Source.of_gen g) in
+  _never_block ps
+
+let parse_string s =
+  let ps = mk_ps (Source.of_string s) in
+  _never_block ps
+
+let parse_chan ?bufsize ic =
+  let ps = mk_ps (Source.of_chan ?bufsize ic) in
+  _never_block ps
+
+(** {6 Blocking} *)
+
+let of_chan ic =
+  ParseGen.head (parse_chan ic)
+
+let of_string s =
+  ParseGen.head (parse_string s)
+
+let of_file f =
+  _with_in f of_chan
+
+module L = struct
+  let to_buf b l =
+    List.iter (to_buf b) l
+
+  let to_string l =
+    let b = Buffer.create 32 in
+    to_buf b l;
+    Buffer.contents b
+
+  let to_chan oc l =
+    let fmt = Format.formatter_of_out_channel oc in
+    List.iter (Format.fprintf fmt "%a@." print) l;
+    Format.pp_print_flush fmt ()
+
+  let to_file filename l =
+    _with_out filename (fun oc -> to_chan oc l)
+
+  let of_chan ?bufsize ic =
+    ParseGen.to_list (parse_chan ?bufsize ic)
+
+  let of_file ?bufsize filename =
+    _with_in filename
+      (fun ic -> of_chan ?bufsize ic)
+
+  let of_string s =
+    ParseGen.to_list (parse_string s)
+
+  let of_gen g =
+    ParseGen.to_list (parse_gen g)
+
+  exception OhNoes of string
+  exception StopNaow
+
+  let of_seq seq =
+    let src = Source.Manual.make () in
+    let ps = mk_ps (Source.Manual.to_src src) in
+    let l = ref [] in
+    (* read as many expressions as possible *)
+    let rec _nexts () = match _next ps with
+      | `Ok x -> l := x :: !l; _nexts ()
+      | `Error e -> raise (OhNoes e)
+      | `End -> raise StopNaow
+      | `Await -> ()
+    in
+    try
+      seq
+        (fun s -> Source.Manual.feed src s 0 (String.length s); _nexts ());
+      Source.Manual.reached_end src;
+      _nexts ();
+      `Ok (List.rev !l)
+    with
+    | OhNoes msg -> `Error msg
+    | StopNaow -> `Ok (List.rev !l)
+end
+
+(** {6 Traversal of S-exp} *)
+
+module Traverse = struct
+  let return x = Some x
+
+  let (>|=) e f = match e with
+    | None -> None
+    | Some x -> Some (f x)
+
+  let (>>=) e f = match e with
+    | None -> None
+    | Some x -> f x
+
+  let rec _list_any f l = match l with
+    | [] -> None
+    | x::tl ->
+        match f x with
+        | Some _ as res -> res
+        | None -> _list_any f tl
+
+  let list_any f e = match e with
+    | Atom _ -> None
+    | List l -> _list_any f l
+
+  let rec _list_all f acc l = match l with
+    | [] -> List.rev acc
+    | x::tl ->
+        match f x with
+        | Some y -> _list_all f (y::acc) tl
+        | None -> _list_all f acc tl
+
+  let list_all f e = match e with
+    | Atom _ -> []
+    | List l -> _list_all f [] l
+
+  let _try_atom e f = match e with
+    | List _ -> None
+    | Atom x -> try Some (f x) with _ -> None
+
+  let to_int e = _try_atom e int_of_string
+  let to_bool e = _try_atom e bool_of_string
+  let to_float e = _try_atom e float_of_string
+  let to_string e = _try_atom e (fun x->x)
+
+  let to_pair e = match e with
+    | List [x;y] -> Some (x,y)
+    | _ -> None
+
+  let to_triple e = match e with
+    | List [x;y;z] -> Some (x,y,z)
+    | _ -> None
+
+  let to_list e = match e with
+    | List l -> Some l
+    | Atom _ -> None
+
+  let rec _get_field name l = match l with
+    | List [Atom n; x] :: _ when name=n -> Some x
+    | _ :: tl -> _get_field name tl
+    | [] -> None
+
+  let get_field name e = match e with
+    | List l -> _get_field name l
+    | Atom _ -> None
+
+  let field name f e =
+    get_field name e >>= f
+
+  let rec _get_variant s args l = match l with
+    | [] -> None
+    | (s', f) :: _ when s=s' -> f args
+    | _ :: tl -> _get_variant s args tl
+
+  let get_variant l e = match e with
+    | List (Atom s :: args) -> _get_variant s args l
+    | List _ -> None
+    | Atom s -> _get_variant s [] l
+
+  let get_exn e = match e with
+    | None -> failwith "Sexp.Traverse.get_exn"
+    | Some x -> x
+end

misc/sexp.mli

@@ -23,64 +23,270 @@ 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 Simple S-expression parsing/printing} *)
+(** {1 Simple and efficient S-expression parsing/printing}
+
+@since NEXT_RELEASE *)
+
+type 'a or_error = [ `Ok of 'a | `Error of string ]
+type 'a sequence = ('a -> unit) -> unit
+type 'a gen = unit -> 'a option
+
+(** {2 Basics} *)
 
 type t =
-  | K of string * t  (* keyword *)
+  | Atom of string
-  | I of int
+  | List of t list
-  | S of string
-  | L of t list
 
-val eq : t -> t -> bool
+val equal : t -> t -> bool
 val compare : t -> t -> int
 val hash : t -> int
 
+val of_int : int -> t
+val of_bool : bool -> t
+val of_list : t list -> t
+val of_string : string -> t
+val of_float : float -> t
+val of_unit : t
+val of_pair : t * t -> t
+val of_triple : t * t * t -> t
+
+val of_variant : string -> t list -> t
+(** [of_variant name args] is used to encode algebraic variants
+    into a S-expr. For instance [of_variant "some" (of_int 1)]
+    represents the value [Some 1] *)
+
+val of_field : string -> t -> t
+(** Used to represent one record field *)
+
+val of_record : (string * t) list -> t
+(** Represent a record by its named fields *)
+
 (** {2 Serialization (encoding)} *)
 
 val to_buf : Buffer.t -> t -> unit
+
 val to_string : t -> string
-val fmt : Format.formatter -> t -> unit
+
+val to_file : string -> t -> unit
+
+val to_file_seq : string -> t sequence -> unit
+(** Print the given sequence of expressions to a file *)
+
+val to_chan : out_channel -> t -> unit
+
+val print : Format.formatter -> t -> unit
+(** Pretty-printer nice on human eyes (including indentation) *)
+
+val print_noindent : Format.formatter -> t -> unit
+(** Raw, direct printing as compact as possible *)
 
 (** {2 Deserialization (decoding)} *)
 
-(** Deserialization is based on the {! decoder} type. Parsing can be
+type 'a parse_result = ['a or_error | `End ]
-    incremental, in which case the input is provided chunk by chunk and
+type 'a partial_result = [ 'a parse_result | `Await ]
-    the decoder contains the parsing state. Once a Sexpr value
-    has been parsed, other values can still be read. *)
 
-type decoder
+(** {6 Source of characters} *)
-  (** Decoding state *)
+module Source : sig
+  type individual_char =
+    | NC_yield of char
+    | NC_end
+    | NC_await
+  (** An individual character returned by a source *)
 
-val mk_decoder : unit -> decoder
+  type t = unit -> individual_char
-  (** Create a new decoder *)
+  (** A source of characters can yield them one by one, or signal the end,
+      or signal that some external intervention is needed *)
 
-type parse_result =
+  type source = t
-  | ParseOk of t
-  | ParseError of string
-  | ParsePartial
 
-val parse : decoder -> string -> int -> int -> parse_result
+  (** A manual source of individual characters. When it has exhausted its
-  (** [parse dec s i len] uses the partial state stored in [dec] and
+      own input, it asks its caller to provide more or signal that none remains
-      the substring of [s] starting at index [i] with length [len].
+      This is especially useful when the source of data is monadic IO *)
-      It can return an error, a value or just [ParsePartial] if
+  module Manual : sig
-      more input is needed *)
+    type t
 
-val reset : decoder -> unit
+    val make : unit -> t
-  (** Reset the decoder to its pristine state, ready to parse something
+    (** Make a new manual source. It needs to be fed input manually,
-      different. Before that, {! rest} and {! rest_size} can be used
+        using {!feed} *)
-      to recover the part of the input that has not been consumed yet. *)
 
-val state : decoder -> parse_result
+    val to_src : t -> source
-  (** Current state of the decoder *)
+    (** The manual source contains a source! *)
 
-val rest : decoder -> string
+    val feed : t -> string -> int -> int -> unit
-  (** What remains after parsing (the additional, unused input) *)
+    (** Feed a chunk of input to the manual source *)
 
-val rest_size : decoder -> int
+    val reached_end : t -> unit
-  (** Length of [rest d]. 0 indicates that the whole input has been consumed. *)
+    (** Tell the decoder that end of input has been reached. From now
-
+        the source will only yield [NC_end] *)
-val parse_string : string -> parse_result
+  end
-  (** Parse a full value from this string. *)
 
   val of_string : string -> t
-  (** Parse the string. @raise Invalid_argument if it fails to parse. *)
+  (** Use a single string as the source *)
+
+  val of_chan : ?bufsize:int -> in_channel -> t
+  (** Use a channel as the source *)
+
+  val of_gen : string gen -> t
+end
+
+(** {6 Streaming Lexer}
+splits the input into opening parenthesis, closing ones, and atoms *)
+module Lexer : sig
+  type t
+  (** A streaming lexer, that parses atomic chunks of S-expressions (atoms
+      and delimiters) *)
+
+  val make : Source.t -> t
+  (** Create a lexer that uses the given source of characters as an input *)
+
+  val of_string : string -> t
+
+  val of_chan : in_channel -> t
+
+  val line : t -> int
+  val col : t -> int
+
+  (** Obtain next token *)
+
+  type token =
+    | Open
+    | Close
+    | Atom of string
+  (** An individual S-exp token *)
+
+  val next : t -> token partial_result
+  (** Obtain the next token, an error, or block/end stream *)
+end
+
+(** {6 Generator with errors} *)
+module ParseGen : sig
+  type 'a t = unit -> 'a parse_result
+  (** A generator-like structure, but with the possibility of errors.
+      When called, it can yield a new element, signal the end of stream,
+      or signal an error. *)
+
+  val to_list : 'a t -> 'a list or_error
+
+  val head : 'a t -> 'a or_error
+
+  val head_exn : 'a t -> 'a
+
+  val take : int -> 'a t -> 'a t
+end
+
+(** {6 Stream Parser}
+Returns a lazy stream of S-expressions. *)
+
+val parse_string : string -> t ParseGen.t
+(** Parse a string *)
+
+val parse_chan : ?bufsize:int -> in_channel -> t ParseGen.t
+(** Parse a channel *)
+
+val parse_gen : string gen -> t ParseGen.t
+(** Parse chunks of string *)
+
+(** {6 Blocking API}
+Parse one S-expression from some source.  *)
+
+val of_chan : in_channel -> t or_error
+(** Parse a S-expression from the given channel. Can read more data than
+    necessary, so don't use this if you need finer-grained control (e.g.
+    to read something else {b after} the S-exp) *)
+
+val of_string : string -> t or_error
+
+val of_file : string -> t or_error
+(** Open the file and read a S-exp from it *)
+
+(** {6 Lists of S-exps} *)
+
+module L : sig
+  val to_buf : Buffer.t -> t list -> unit
+
+  val to_string : t list -> string
+
+  val to_file : string -> t list -> unit
+
+  val to_chan : out_channel -> t list -> unit
+
+  val of_chan : ?bufsize:int -> in_channel -> t list or_error
+
+  val of_file : ?bufsize:int -> string -> t list or_error
+
+  val of_string : string -> t list or_error
+
+  val of_gen : string gen -> t list or_error
+
+  val of_seq : string sequence -> t list or_error
+end
+
+(** {6 Traversal of S-exp}
+
+Example: serializing 2D points
+{[
+type pt = {x:int; y:int };;
+
+let pt_of_sexp e =
+  Sexp.Traverse.(
+    field "x" to_int e >>= fun x ->
+    field "y" to_int e >>= fun y ->
+    return {x;y}
+  );;
+
+let sexp_of_pt pt = Sexp.(of_record ["x", of_int pt.x; "y", of_int pt.y]);;
+
+let l = [{x=1;y=1}; {x=2;y=10}];;
+
+let sexp = Sexp.(of_list (List.map sexp_of_pt l));;
+
+Sexp.Traverse.list_all pt_of_sexp sexp;;
+]}
+
+*)
+
+module Traverse : sig
+  val list_any : (t -> 'a option) -> t -> 'a option
+  (** [list_any f (List l)] tries [f x] for every element [x] in [List l],
+      and returns the first non-None result (if any). *)
+
+  val list_all : (t -> 'a option) -> t -> 'a list
+  (** [list_all f (List l)] returns the list of all [y] such that [x] in [l]
+      and [f x = Some y] *)
+
+  val to_int : t -> int option
+
+  val to_string : t -> string option
+
+  val to_bool : t -> bool option
+
+  val to_float : t -> float option
+
+  val to_list : t -> t list option
+
+  val to_pair : t -> (t * t) option
+
+  val to_triple : t -> (t * t * t) option
+
+  val get_field : string -> t -> t option
+  (** [get_field name e], when [e = List [(n1,x1); (n2,x2) ... ]], extracts
+      the [xi] such that [name = ni], if it can find it. *)
+
+  val field : string -> (t -> 'a option) -> t -> 'a option
+  (** Enriched version of {!get_field}, with a converter as argument *)
+
+  val get_variant : (string * (t list -> 'a option)) list -> t -> 'a option
+  (** [get_variant l e] checks whether [e = List (Atom s :: args)], and
+      if some pair of [l] is [s, f]. In this case, it calls [f args]
+      and returns its result, otherwise it returns None. *)
+
+  val (>>=) : 'a option -> ('a -> 'b option) -> 'b option
+
+  val (>|=) : 'a option -> ('a -> 'b) -> 'b option
+
+  val return : 'a -> 'a option
+
+  val get_exn : 'a option -> 'a
+  (** Unwrap an option, possibly failing.
+      @raise Invalid_argument if the argument is [None] *)
+end

misc/tTree.ml

@@ -40,7 +40,7 @@ module PArray = struct
   (* XXX maybe having a snapshot of the array from point to point may help? *)
 
   let make size elt =
-    let a = Array.create size elt in
+    let a = Array.make size elt in
     ref (Array a)
 
   (** Recover the given version of the shared array. Returns the array

myocamlbuild.ml

@@ -1,5 +1,5 @@
 (* OASIS_START *)
-(* DO NOT EDIT (digest: 92eca59de110c4aba9cdf64e8cc0f3b5) *)
+(* DO NOT EDIT (digest: 47cdd7e819f798e50723373435866cb7) *)
 module OASISGettext = struct
 (* # 22 "src/oasis/OASISGettext.ml" *)
 
@@ -599,6 +599,7 @@ let package_default =
        [
           ("containers", ["core"], []);
           ("containers_string", ["string"], []);
+          ("containers_pervasives", ["pervasives"], []);
           ("containers_misc", ["misc"], []);
           ("containers_thread", ["threads"], []);
           ("containers_lwt", ["lwt"], []);
@@ -611,17 +612,19 @@ let package_default =
           ("threads", ["core"]);
           ("tests/lwt", ["core"; "lwt"]);
           ("tests", ["core"; "misc"; "string"]);
+          ("pervasives", ["core"]);
           ("misc", ["core"]);
           ("lwt", ["core"; "misc"]);
           ("examples/cgi", ["cgi"; "core"]);
           ("examples", ["core"; "misc"]);
-          ("cgi", ["core"])
+          ("cgi", ["core"]);
+          ("benchs", ["core"; "misc"; "string"])
        ]
   }
   ;;
 
 let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;;
 
-# 626 "myocamlbuild.ml"
+# 629 "myocamlbuild.ml"
 (* OASIS_STOP *)
 Ocamlbuild_plugin.dispatch dispatch_default;;

pervasives/CCPervasives.ml

@@ -0,0 +1,49 @@
+
+(*
+copyright (c) 2013-2014, simon cruanes
+all rights reserved.
+
+redistribution and use in source and binary forms, with or without
+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 Drop-In replacement to Stdlib}
+
+This module is meant to be opened if one doesn't want to use both, say,
+[List] and [CCList]. Instead, [List] is now an alias to
+{[struct
+    include List
+    include CCList
+  end
+]}
+
+@since NEXT_RELEASE
+*)
+
+module Array = struct include Array include CCArray end
+module Bool = CCBool
+module Error = CCError
+module Fun = CCFun
+module Int = CCInt
+module List = struct include List include CCList end
+module Opt = CCOpt
+module Pair = CCPair
+module String = struct include String include CCString end
+module Vector = CCVector

pervasives/containers_pervasives.mldylib

@@ -0,0 +1,4 @@
+# OASIS_START
+# DO NOT EDIT (digest: ea286cccf88f4c81c7b4627216807d4e)
+CCPervasives
+# OASIS_STOP

pervasives/containers_pervasives.mllib

@@ -0,0 +1,4 @@
+# OASIS_START
+# DO NOT EDIT (digest: ea286cccf88f4c81c7b4627216807d4e)
+CCPervasives
+# OASIS_STOP

setup.ml

@@ -1,7 +1,7 @@
 (* setup.ml generated for the first time by OASIS v0.4.4 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: 42feaefec6d88da4eb0905255ba7d50b) *)
+(* DO NOT EDIT (digest: 183eaa6c7caeb5dfeb678eda23eb7dde) *)
 (*
    Regenerated by OASIS v0.4.4
    Visit http://oasis.forge.ocamlcore.org for more information and
@@ -6923,7 +6923,7 @@ let setup_t =
                    {
                       flag_description =
                         Some
-                          "Build the misc library, containing everything from\nthe rotating kitchen sink to automatic banana distributors";
+                          "Build the misc library, containing everything from the rotating kitchen sink to automatic banana distributors";
                       flag_default = [(OASISExpr.EBool true, false)]
                    });
                Flag
@@ -7025,7 +7025,8 @@ let setup_t =
                            "CCKTree";
                            "CCTrie";
                            "CCString";
-                           "CCHashtbl"
+                           "CCHashtbl";
+                           "CCFlatHashtbl"
                         ];
                       lib_pack = false;
                       lib_internal_modules = [];
@@ -7063,6 +7064,36 @@ let setup_t =
                       lib_findlib_name = Some "string";
                       lib_findlib_containers = []
                    });
+               Library
+                 ({
+                     cs_name = "containers_pervasives";
+                     cs_data = PropList.Data.create ();
+                     cs_plugin_data = []
+                  },
+                   {
+                      bs_build = [(OASISExpr.EBool true, true)];
+                      bs_install = [(OASISExpr.EBool true, true)];
+                      bs_path = "pervasives";
+                      bs_compiled_object = Best;
+                      bs_build_depends = [InternalLibrary "containers"];
+                      bs_build_tools = [ExternalTool "ocamlbuild"];
+                      bs_c_sources = [];
+                      bs_data_files = [];
+                      bs_ccopt = [(OASISExpr.EBool true, [])];
+                      bs_cclib = [(OASISExpr.EBool true, [])];
+                      bs_dlllib = [(OASISExpr.EBool true, [])];
+                      bs_dllpath = [(OASISExpr.EBool true, [])];
+                      bs_byteopt = [(OASISExpr.EBool true, [])];
+                      bs_nativeopt = [(OASISExpr.EBool true, [])]
+                   },
+                   {
+                      lib_modules = ["CCPervasives"];
+                      lib_pack = false;
+                      lib_internal_modules = [];
+                      lib_findlib_parent = Some "containers";
+                      lib_findlib_name = Some "pervasives";
+                      lib_findlib_containers = []
+                   });
                Library
                  ({
                      cs_name = "containers_misc";
@@ -7366,7 +7397,7 @@ let setup_t =
                            (OASISExpr.EFlag "bench", true)
                         ];
                       bs_install = [(OASISExpr.EBool true, false)];
-                      bs_path = "tests/";
+                      bs_path = "benchs/";
                       bs_compiled_object = Native;
                       bs_build_depends =
                         [
@@ -7399,7 +7430,7 @@ let setup_t =
                            (OASISExpr.EFlag "bench", true)
                         ];
                       bs_install = [(OASISExpr.EBool true, false)];
-                      bs_path = "tests/";
+                      bs_path = "benchs/";
                       bs_compiled_object = Native;
                       bs_build_depends =
                         [
@@ -7430,7 +7461,7 @@ let setup_t =
                            (OASISExpr.EFlag "bench", true)
                         ];
                       bs_install = [(OASISExpr.EBool true, false)];
-                      bs_path = "tests/";
+                      bs_path = "benchs/";
                       bs_compiled_object = Native;
                       bs_build_depends =
                         [
@@ -7464,7 +7495,7 @@ let setup_t =
                              true)
                         ];
                       bs_install = [(OASISExpr.EBool true, false)];
-                      bs_path = "tests/";
+                      bs_path = "benchs/";
                       bs_compiled_object = Native;
                       bs_build_depends =
                         [
@@ -7500,7 +7531,8 @@ let setup_t =
                       bs_build_depends =
                         [
                            InternalLibrary "containers";
-                           FindlibPackage ("qcheck", None)
+                           FindlibPackage ("qcheck", None);
+                           InternalLibrary "containers_string"
                         ];
                       bs_build_tools = [ExternalTool "ocamlbuild"];
                       bs_c_sources = [];
@@ -7597,7 +7629,10 @@ let setup_t =
                       bs_build =
                         [
                            (OASISExpr.EBool true, false);
-                           (OASISExpr.EFlag "tests", true)
+                           (OASISExpr.EAnd
+                              (OASISExpr.EFlag "tests",
+                                OASISExpr.EFlag "misc"),
+                             true)
                         ];
                       bs_install = [(OASISExpr.EBool true, false)];
                       bs_path = "tests/";
@@ -7606,7 +7641,8 @@ let setup_t =
                         [
                            InternalLibrary "containers";
                            FindlibPackage ("oUnit", None);
-                           FindlibPackage ("qcheck", None)
+                           FindlibPackage ("qcheck", None);
+                           InternalLibrary "containers_misc"
                         ];
                       bs_build_tools = [ExternalTool "ocamlbuild"];
                       bs_c_sources = [];
@@ -7714,6 +7750,37 @@ let setup_t =
                       bs_nativeopt = [(OASISExpr.EBool true, [])]
                    },
                    {exec_custom = false; exec_main_is = "lambda.ml"});
+               Executable
+                 ({
+                     cs_name = "id_sexp";
+                     cs_data = PropList.Data.create ();
+                     cs_plugin_data = []
+                  },
+                   {
+                      bs_build =
+                        [
+                           (OASISExpr.EBool true, false);
+                           (OASISExpr.EFlag "misc", true)
+                        ];
+                      bs_install = [(OASISExpr.EBool true, false)];
+                      bs_path = "examples/";
+                      bs_compiled_object = Native;
+                      bs_build_depends =
+                        [
+                           InternalLibrary "containers";
+                           InternalLibrary "containers_misc"
+                        ];
+                      bs_build_tools = [ExternalTool "ocamlbuild"];
+                      bs_c_sources = [];
+                      bs_data_files = [];
+                      bs_ccopt = [(OASISExpr.EBool true, [])];
+                      bs_cclib = [(OASISExpr.EBool true, [])];
+                      bs_dlllib = [(OASISExpr.EBool true, [])];
+                      bs_dllpath = [(OASISExpr.EBool true, [])];
+                      bs_byteopt = [(OASISExpr.EBool true, [])];
+                      bs_nativeopt = [(OASISExpr.EBool true, [])]
+                   },
+                   {exec_custom = false; exec_main_is = "id_sexp.ml"});
                SrcRepo
                  ({
                      cs_name = "head";
@@ -7741,7 +7808,7 @@ let setup_t =
        };
      oasis_fn = Some "_oasis";
      oasis_version = "0.4.4";
-     oasis_digest = Some "u\218H\140/QR\161\227\201l\128vo\253\189";
+     oasis_digest = Some "\214\176\018E\1355\180\012\196\136b\005\024\030Sz";
      oasis_exec = None;
      oasis_setup_args = [];
      setup_update = false
@@ -7749,6 +7816,6 @@ let setup_t =
 
 let setup () = BaseSetup.setup setup_t;;
 
-# 7753 "setup.ml"
+# 7820 "setup.ml"
 (* OASIS_STOP *)
 let () = setup ();;

tests/test_PiCalculus.ml

@@ -1,6 +1,7 @@
 
 open OUnit
 
+open Containers_misc
 open PiCalculus
 module Pi = PiCalculus
 

tests/test_bencode.ml

@@ -1,5 +1,6 @@
 
 open OUnit
+open Containers_misc
 
 module B = Bencode
 

tests/test_bij.ml

@@ -1,5 +1,6 @@
 
 open OUnit
+open Containers_misc
 
 module Sequence = CCSequence
 

tests/test_fHashtbl.ml

@@ -1,5 +1,6 @@
 
 open OUnit
+open Containers_misc
 
 module Sequence = CCSequence
 

tests/test_flatHashtbl.ml

@@ -1,5 +1,6 @@
 
 open OUnit
+open Containers_misc
 
 module Sequence = CCSequence
 

tests/test_graph.ml

@@ -3,6 +3,7 @@
 
 open OUnit
 open Helpers
+open Containers_misc
 
 module Sequence = CCSequence
 module G = PersistentGraph

tests/test_heap.ml

@@ -2,6 +2,7 @@
 
 open OUnit
 open Helpers
+open Containers_misc
 module Sequence = CCSequence
 
 let test_empty () =

tests/test_levenshtein.ml

@@ -1,5 +1,7 @@
 (* quickcheck for Levenshtein *)
 
+module Levenshtein = Containers_string.Levenshtein
+
 (* test that automaton accepts its string *)
 let test_automaton =
   let gen = QCheck.Arbitrary.(map string (fun s -> s, Levenshtein.of_string ~limit:1 s)) in

tests/test_pHashtbl.ml

@@ -1,5 +1,6 @@
 
 open OUnit
+open Containers_misc
 
 module Sequence = CCSequence
 

tests/test_splayMap.ml

@@ -1,5 +1,6 @@
 
 open OUnit
+open Containers_misc
 
 module Sequence = CCSequence
 

tests/test_univ.ml

@@ -1,5 +1,6 @@
 
 open OUnit
+open Containers_misc
 
 (** Test Univ embedding *)