Merge branch 'master' into stable for 0.16

.gitignore

@@ -6,6 +6,6 @@ _build
 .session
 TAGS
 *.docdir
-setup.log
-setup.data
+setup.*
 qtest*
+*.html

.merlin

@@ -12,22 +12,13 @@ S src/bigarray
 S benchs
 S examples
 S tests
-B _build/src/core
-B _build/src/data/
-B _build/src/io
-B _build/src/iter/
-B _build/src/advanced/
-B _build/src/lwt/
-B _build/src/sexp/
-B _build/src/threads/
-B _build/src/misc
-B _build/src/string
-B _build/src/bigarray
+B _build/src/**
 B _build/benchs
 B _build/examples
 B _build/tests
 PKG oUnit
 PKG benchmark
+PKG result
 PKG threads
 PKG threads.posix
 PKG lwt

CHANGELOG.adoc

@@ -1,5 +1,61 @@
 = Changelog
 
+== 0.16
+
+=== breaking
+
+- change the signature of `CCHeap.{of_gen,of_seq,of_klist}`
+- change the API of `CCMixmap`
+- make type `CCHash.state` abstract (used to be `int64`)
+- optional argument `~eq` to `CCGraph.Dot.pp`
+- rename `CCFuture` into `CCPool`
+
+=== deprecations
+
+- deprecate `containers.bigarray`
+- deprecate `CCHashtbl.{Counter,Default}` tables
+- deprecate `CCLinq` in favor of standalone `OLinq` (to be released)
+
+=== bugfixes
+
+- fix wrong signature of `CCHashtbl.Make.{keys,values}_list`
+- missing constraint in `CCSexpM.ID_MONAD`
+
+=== new features
+
+- add a tutorial file
+- add a printer into CCHeap
+- add `{CCList,CCOpt}.Infix` modules
+- add `CCOpt.map_or`, deprecating `CCopt.maybe`
+- add `CCFormat.sprintf_no_color`
+- add `CCFormat.{h,v,hov,hv}box` printer combinators
+- add `CCFormat.{with_color, with_colorf}`
+- add `CCList.hd_tl`
+- add `CCResult.{map_or,get_or}`
+- add `CCGraph.make` and utils
+- add `CCHashtbl.add_list`
+- add counter function in `CCHashtbl`, to replace `CCHashtbl.Counter`
+- add `CCPair.make`
+- add `CCString.Split.{left,right}_exn`
+- add `CCIO.File.{read,write,append}` for quickly handling files
+- add `CCRandom.pick_{list,array}`
+- add `CCList.Assoc.update`
+- add `CCList.Assoc.mem`
+- add `{CCMap,CCHashtbl}.get_or` for lookup with default value
+- add `CCLock.{decr_then_get, get_then_{decr,set,clear}}`
+- rename `CCFuture` into `CCPool`, expose the thread pool
+- split `CCTimer` out of `CCFuture`, a standalone 1-thread timer
+- move `CCThread.Queue` into `CCBlockingQueue`
+- add `CCResult`, with dependency on `result` for retrocompat
+- add `CCThread.spawn{1,2}`
+- add many helpers in `CCUnix` (for sockets, files, and processes)
+- add `CCFun.finally{1,2}`, convenience around `finally`
+- add `CCLock.update_map`
+- add `CCLock.{incr_then_get,get_then_incr}`
+- add breaking space in `CCFormat.{pair,triple,quad}`
+- update `examples/id_sexp` so it can read on stdin
+- add `CCList.fold_map2`
+
 == 0.15
 
 === breaking changes
@@ -15,7 +71,7 @@
 - add `CCMap.{keys,values}`
 - add wip `CCAllocCache`, an allocation cache for short-lived arrays
 - add `CCError.{join,both}` applicative functions for CCError
-- opam: depend on ocamlbuild
+- opam: depend on ecamlbuild
 - work on `CCRandom` by octachron:
   * add an uniformity test
   * Make `split_list` uniform

HOWTO.adoc

@@ -14,7 +14,7 @@ can be removed.
 6. commit the changes
 7. `git checkout stable`
 8. `git merge master`
-9. `oasis setup; make tests doc`
+9. `oasis setup; make test doc`
 10. tag, and push both to github
 11. new opam package
 

README.adoc

@@ -4,7 +4,7 @@
 
 image::media/logo.png[logo]
 
-What is _containers_?
+What is _containers_? (take a look at the link:TUTORIAL.adoc[tutorial]!)
 
 - A usable, reasonably well-designed library that extends OCaml's standard
   library (in 'src/core/', packaged under `containers` in ocamlfind. Modules
@@ -31,7 +31,7 @@ What is _containers_?
   a LINQ-like query module, batch operations using GADTs, and others).
 - Utilities around the `unix` library in `containers.unix` (mainly to spawn
   sub-processes)
-- A bigstring module using `bigarray` in `containers.bigarray`
+- A bigstring module using `bigarray` in `containers.bigarray` (*deprecated*)
 - A lightweight S-expression printer and streaming parser in `containers.sexp`
 
 Some of the modules have been moved to their own repository (e.g. `sequence`,
@@ -55,6 +55,8 @@ See link:CHANGELOG.adoc[this file].
 
 == Use
 
+Start with the link:TUTORIAL.adoc[tutorial]
+
 You can either build and install the library (see <<build>>), or just copy
 files to your own project. The last solution has the benefits that you
 don't have additional dependencies nor build complications (and it may enable

TUTORIAL.adoc

@@ -0,0 +1,177 @@
+= Tutorial
+:source-highlighter: pygments
+
+This tutorial contains a few examples to illustrate the features and
+usage of containers. We assume containers is installed and that
+the library is loaded, e.g. with:
+
+[source,OCaml]
+----
+#require "containers";;
+----
+
+== Basics
+
+We will start with a few list helpers, then look at other parts of
+the library, including printers, maps, etc.
+
+[source,OCaml]
+----
+
+(* quick reminder of this awesome standard operator *)
+# (|>) ;;
+- : 'a -> ('a -> 'b) -> 'b = <fun>
+
+# open CCList.Infix;;
+
+# let l = 1 -- 100;;
+val l : int list = [1; 2; .....]
+
+# l
+  |> CCList.filter_map
+     (fun x-> if x mod 3=0 then Some (float x) else None)
+  |> CCList.take 5 ;;
+- : float list = [3.; 6.; 9.; 12.; 15.]
+
+# let l2 = l |> CCList.take_while (fun x -> x<10) ;;
+val l2 : int list = [1; 2; 3; 4; 5; 6; 7; 8; 9]
+
+(* an extension of Map.Make, compatible with Map.Make(CCInt) *)
+# module IntMap = CCMap.Make(CCInt);;
+
+(* conversions using the "sequence" type, fast iterators that are
+   pervasively used in containers. Combinators can be found
+   in the opam library "sequence". *)
+# let map =
+    l2
+    |> List.map (fun x -> x, string_of_int x)
+    |> CCList.to_seq
+    |> IntMap.of_seq;;
+val map : string CCIntMap.t = <abstr>
+
+(* check the type *)
+# CCList.to_seq ;;
+- : 'a list -> 'a sequence = <fun>
+# IntMap.of_seq ;;
+- : (int * 'a) CCMap.sequence -> 'a IntMap.t = <fun>
+
+(* we can print, too *)
+# Format.printf "@[<2>map =@ @[<hov>%a@]@]@."
+    (IntMap.print CCFormat.int CCFormat.string_quoted)
+    map;;
+map =
+  [1 --> "1", 2 --> "2", 3 --> "3", 4 --> "4", 5 --> "5", 6 --> "6",
+   7 --> "7", 8 --> "8", 9 --> "9"]
+- : unit = ()
+
+(* options are good *)
+# IntMap.get 3 map |> CCOpt.map (fun s->s ^ s);;
+- : string option = Some "33"
+
+----
+
+== New types: `CCVector`, `CCHeap`, `CCError`, `CCResult`
+
+Containers also contains (!) a few datatypes that are not from the standard
+library but that are useful in a lot of situations:
+
+CCVector::
+  A resizable array, with a mutability parameter. A value of type
+  `('a, CCVector.ro) CCVector.t` is an immutable vector of values of type `'a`,
+  whereas a `('a, CCVector.rw) CCVector.t` is a mutable vector that
+  can be modified. This way, vectors can be used in a quite functional
+  way, using operations such as `map` or `flat_map`, or in a more
+  imperative way.
+CCHeap::
+  A priority queue (currently, leftist heaps) functorized over
+  a module `sig val t val leq : t -> t -> bool` that provides a type `t`
+  and a partial order `leq` on `t`.
+CCError::
+  An error type for making error handling more explicit (an error monad,
+  really, if you're not afraid of the "M"-word). It is similar to the
+  more recent `CCResult`, but works with polymorphic variants for
+  compatibility with the numerous libraries that use the same type,
+  that is, `type ('a, 'b) CCError.t = [`Ok of 'a | `Error of 'b]`.
+CCResult::
+  It uses the new `result` type from the standard library (or from
+  the retrocompatibility package on opam), and presents an interface
+  similar to `CCError`. In an indeterminate amount of time, it will
+  totally replace `CCError`.
+
+Now for a few examples:
+
+[source,OCaml]
+----
+
+(* create a new empty vector. It is mutable, for otherwise it would
+   not be very useful. *)
+# CCVector.create;;
+- : unit -> ('a, CCVector.rw) CCVector.t = <fun>
+
+(* init, similar to Array.init, can be used to produce a
+   vector that is mutable OR immutable (see the 'mut parameter?) *)
+# CCVector.init ;;
+- : int -> (int -> 'a) -> ('a, 'mut) CCVector.t = <fun>c
+
+(* use the infix (--) operator for creating a range. Notice
+   that v is a vector of integer but its mutability is not
+   decided yet. *)
+# let v = CCVector.(1 -- 10);;
+val v : (int, '_a) CCVector.t = <abstr> 
+
+# Format.printf "v = @[%a@]@." (CCVector.print CCInt.print) v;;
+v = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]
+
+(* now let's mutate v *)
+# CCVector.push v 42;;
+- : unit = ()
+
+(* now v is a mutable vector *)
+# v;;
+- : (int, CCVector.rw) CCVector.t = <abstr>
+
+(* functional combinators! *)
+# let v2 = v
+  |> CCVector.map (fun x-> x+1)
+  |> CCVector.filter (fun x-> x mod 2=0)
+  |> CCVector.rev ;;
+val v2 : (int, '_a) CCVector.t = <abstr>
+
+# Format.printf "v2 = @[%a@]@." (CCVector.print CCInt.print) v2;;
+v2 = [10, 8, 6, 4, 2]
+
+(* let's transfer to a heap *)
+# module IntHeap = CCHeap.Make(struct type t = int let leq = (<=) end);;
+
+# let h = v2 |> CCVector.to_seq |> IntHeap.of_seq ;;
+val h : IntHeap.t = <abstr>
+
+(* We can print the content of h
+  (printing is not necessarily in order, though) *)
+# Format.printf "h = [@[%a@]]@." (IntHeap.print CCInt.print) h;;
+h = [2,4,6,8,10]
+
+(* we can remove the first element, which also returns a new heap
+   that does not contain it — CCHeap is a functional data structure *)
+# IntHeap.take h;;
+- : (IntHeap.t * int) option = Some (<abstr>, 2) 
+
+# let h', x = IntHeap.take_exn h ;;
+val h' : IntHeap.t = <abstr>
+val x : int = 2 
+
+(* see, 2 is removed *)
+# IntHeap.to_list h' ;;
+- : int list = [4; 6; 8; 10]
+
+----
+
+== To go further: containers.data
+
+There is also a sub-library called `containers.data`, with lots of
+more specialized data-structures.
+The documentation contains the API for all the modules
+(see link:README.adoc[the readme]); they also provide
+interface to `sequence` and, as the rest of containers, minimize
+dependencies over other modules.
+

_oasis

@@ -1,6 +1,6 @@
 OASISFormat: 0.4
 Name:        containers
-Version:     0.15
+Version:     0.16
 Homepage:    https://github.com/c-cube/ocaml-containers
 Authors:     Simon Cruanes
 License:     BSD-2-clause
@@ -46,8 +46,8 @@ Library "containers"
   Modules:          CCVector, CCPrint, CCError, CCHeap, CCList, CCOpt, CCPair,
                     CCFun, CCHash, CCInt, CCBool, CCFloat, CCArray, CCRef, CCSet,
                     CCOrd, CCRandom, CCString, CCHashtbl, CCMap, CCFormat, CCIO,
-                    CCInt64, CCChar, Containers
-  BuildDepends:     bytes
+                    CCInt64, CCChar, CCResult, Containers
+  BuildDepends:     bytes, result
   # BuildDepends:     bytes, bisect_ppx
 
 Library "containers_io"
@@ -114,7 +114,8 @@ Library "containers_bigarray"
 
 Library "containers_thread"
   Path:             src/threads/
-  Modules:          CCFuture, CCLock, CCSemaphore, CCThread
+  Modules:          CCPool, CCLock, CCSemaphore, CCThread, CCBlockingQueue,
+                    CCTimer
   FindlibName:      thread
   FindlibParent:    containers
   Build$:           flag(thread)

_tags

@@ -17,6 +17,7 @@ true: annot, bin_annot
 # Library containers
 "src/core/containers.cmxs": use_containers
 <src/core/*.ml{,i,y}>: package(bytes)
+<src/core/*.ml{,i,y}>: package(result)
 # Library containers_io
 "src/io/containers_io.cmxs": use_containers_io
 <src/io/*.ml{,i,y}>: package(bytes)
@@ -38,16 +39,19 @@ true: annot, bin_annot
 # Library containers_advanced
 "src/advanced/containers_advanced.cmxs": use_containers_advanced
 <src/advanced/*.ml{,i,y}>: package(bytes)
+<src/advanced/*.ml{,i,y}>: package(result)
 <src/advanced/*.ml{,i,y}>: package(sequence)
 <src/advanced/*.ml{,i,y}>: use_containers
 # Library containers_bigarray
 "src/bigarray/containers_bigarray.cmxs": use_containers_bigarray
 <src/bigarray/*.ml{,i,y}>: package(bigarray)
 <src/bigarray/*.ml{,i,y}>: package(bytes)
+<src/bigarray/*.ml{,i,y}>: package(result)
 <src/bigarray/*.ml{,i,y}>: use_containers
 # Library containers_thread
 "src/threads/containers_thread.cmxs": use_containers_thread
 <src/threads/*.ml{,i,y}>: package(bytes)
+<src/threads/*.ml{,i,y}>: package(result)
 <src/threads/*.ml{,i,y}>: package(threads)
 <src/threads/*.ml{,i,y}>: use_containers
 # Library containers_top
@@ -55,6 +59,7 @@ true: annot, bin_annot
 <src/top/*.ml{,i,y}>: package(bigarray)
 <src/top/*.ml{,i,y}>: package(bytes)
 <src/top/*.ml{,i,y}>: package(compiler-libs.common)
+<src/top/*.ml{,i,y}>: package(result)
 <src/top/*.ml{,i,y}>: package(unix)
 <src/top/*.ml{,i,y}>: use_containers
 <src/top/*.ml{,i,y}>: use_containers_bigarray
@@ -68,6 +73,7 @@ true: annot, bin_annot
 <benchs/run_benchs.{native,byte}>: package(bytes)
 <benchs/run_benchs.{native,byte}>: package(gen)
 <benchs/run_benchs.{native,byte}>: package(hamt)
+<benchs/run_benchs.{native,byte}>: package(result)
 <benchs/run_benchs.{native,byte}>: package(sequence)
 <benchs/run_benchs.{native,byte}>: package(threads)
 <benchs/run_benchs.{native,byte}>: use_containers
@@ -85,6 +91,7 @@ true: annot, bin_annot
 <benchs/*.ml{,i,y}>: use_containers_thread
 # Executable run_bench_hash
 <benchs/run_bench_hash.{native,byte}>: package(bytes)
+<benchs/run_bench_hash.{native,byte}>: package(result)
 <benchs/run_bench_hash.{native,byte}>: use_containers
 # Executable run_qtest
 <qtest/run_qtest.{native,byte}>: package(QTest2Lib)
@@ -92,6 +99,7 @@ true: annot, bin_annot
 <qtest/run_qtest.{native,byte}>: package(bytes)
 <qtest/run_qtest.{native,byte}>: package(gen)
 <qtest/run_qtest.{native,byte}>: package(oUnit)
+<qtest/run_qtest.{native,byte}>: package(result)
 <qtest/run_qtest.{native,byte}>: package(sequence)
 <qtest/run_qtest.{native,byte}>: package(threads)
 <qtest/run_qtest.{native,byte}>: package(unix)
@@ -110,6 +118,7 @@ true: annot, bin_annot
 <qtest/*.ml{,i,y}>: package(bytes)
 <qtest/*.ml{,i,y}>: package(gen)
 <qtest/*.ml{,i,y}>: package(oUnit)
+<qtest/*.ml{,i,y}>: package(result)
 <qtest/*.ml{,i,y}>: package(sequence)
 <qtest/*.ml{,i,y}>: package(threads)
 <qtest/*.ml{,i,y}>: package(unix)
@@ -126,12 +135,14 @@ true: annot, bin_annot
 # Executable mem_measure
 "benchs/mem_measure.native": package(bytes)
 "benchs/mem_measure.native": package(hamt)
+"benchs/mem_measure.native": package(result)
 "benchs/mem_measure.native": package(sequence)
 "benchs/mem_measure.native": package(unix)
 "benchs/mem_measure.native": use_containers
 "benchs/mem_measure.native": use_containers_data
 <benchs/*.ml{,i,y}>: package(bytes)
 <benchs/*.ml{,i,y}>: package(hamt)
+<benchs/*.ml{,i,y}>: package(result)
 <benchs/*.ml{,i,y}>: package(sequence)
 <benchs/*.ml{,i,y}>: package(unix)
 <benchs/*.ml{,i,y}>: use_containers

benchs/run_benchs.ml

@@ -954,7 +954,7 @@ module Deque = struct
 end
 
 module Thread = struct
-  module Q = CCThread.Queue
+  module Q = CCBlockingQueue
 
   module type TAKE_PUSH = sig
     val take : 'a Q.t -> 'a
@@ -1009,6 +1009,50 @@ module Thread = struct
       ; "naive", make naive, ()
       ]
 
+  let fib_pool_ ~size n =
+    let module P = CCPool.Make(struct let min_size = 0 let max_size = size end) in
+    let open P.Fut.Infix in
+    let rec fib n =
+      if n<=1 then P.Fut.return 1
+      else
+        let f1 = fib (n-1)
+        and f2 = fib (n-2) in
+        P.Fut.return (+) <*> f1 <*> f2
+    in
+    P.Fut.get (fib n)
+
+  let fib_manual n =
+    let rec fib n =
+      if n<= 1  then 1
+      else fib (n-1) + fib (n-2)
+    in
+    fib n
+
+  (* pool of size [size] *)
+  let bench_pool ~size n =
+    assert (fib_manual n = fib_pool_ ~size n);
+    B.throughputN 3 ~repeat
+      [ "sequential", fib_manual, n
+      ; "pool", fib_pool_ ~size, n
+      ]
+
+  let bench_sequence ~size n =
+    let module P = CCPool.Make(struct let min_size = 0 let max_size = size end) in
+    let id_ x = Thread.delay 0.0001; x in
+    let mk_list() = CCList.init n (P.Fut.make1 id_) in
+    let mk_sequence () =
+      let l = mk_list() in
+      P.Fut.sequence_l l |> P.Fut.get
+    (* reserves a thread for the computation *)
+    and mk_blocking () =
+      let l = mk_list() in
+      P.Fut.make (fun () -> List.map P.Fut.get l) |> P.Fut.get
+    in
+    B.throughputN 3 ~repeat
+      [ "sequence", mk_sequence, ()
+      ; "blocking", mk_blocking, ()
+      ]
+
   let () = B.Tree.register (
     let take_push = CCList.map
       (fun (size,senders,receivers) ->
@@ -1028,7 +1072,10 @@ module Thread = struct
 
     "thread" @>>>
       ( take_push @
-      []
+      [ "fib_size5" @>> app_ints (bench_pool ~size:5) [10; 15; 30; 35]
+      ; "fib_size15" @>> app_ints (bench_pool ~size:15) [10; 15; 30; 35]
+      ; "sequence" @>> app_ints (bench_sequence ~size:15) [100; 500; 10_000; 100_000]
+      ]
       )
   )
 end

doc/intro.txt

@@ -44,6 +44,7 @@ CCPair
 CCPrint
 CCRandom
 CCRef
+CCResult
 CCSet
 CCString
 CCVector
@@ -125,6 +126,7 @@ CCParse
 
 {4 Bigarrays}
 
+{b deprecated} (use package bigstring instead)
 Use bigarrays to hold large strings and map files directly into memory.
 
 {!modules: CCBigstring CCArray1}
@@ -147,10 +149,12 @@ Moved to its own repository
 {4 Others}
 
 {!modules:
-CCFuture
+CCBlockingQueue
 CCLock
+CCPool
 CCSemaphore
 CCThread
+CCTimer
 }
 
 

examples/id_sexp.ml

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

opam

@@ -27,6 +27,7 @@ remove: [
 depends: [
     "ocamlfind" {build}
     "base-bytes"
+    "result"
     "cppo" {build}
     "oasis" {build}
     "ocamlbuild" {build}

src/advanced/CCLinq.mli

@@ -56,7 +56,9 @@ CCLinq.(
 - :  `Ok ()
 ]}
 
-{b status: experimental}
+{b DEPRECATED, use "OLinq" (standalone library) instead}
+
+{b status: deprecated}
 
 *)
 
@@ -76,8 +78,6 @@ module PMap : sig
 
   val to_seq : ('a, 'b) t -> ('a * 'b) sequence
 
-  val to_list : ('a, 'b) t -> ('a * 'b) list
-
   val map : ('b -> 'c) -> ('a, 'b) t -> ('a, 'c) t
   (** Transform values *)
 

src/bigarray/CCArray1.mli

@@ -25,7 +25,9 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 (** {1 Bigarrays of dimension 1}
 
-    {b status: experimental}
+    {b NOTE this module will be removed soon and should not be depended upon}
+
+    {b status: deprecated}
     @since 0.12 *)
 
 (** {2 used types} *)

src/bigarray/CCBigstring.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Interface to 1-dimension Bigarrays of bytes (char)} *)
 

src/bigarray/CCBigstring.mli

@@ -1,31 +1,13 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Interface to 1-dimension Bigarrays of bytes (char)}
 
-@since 0.7 *)
+    @deprecated use the package [bigstring] instead.
+
+    {b status: deprecated, do not use anymore}
+
+    @since 0.7 *)
 
 type t = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
 

src/core/CCArray.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Array utils} *)
 

src/core/CCArray.mli

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Array utils} *)
 

src/core/CCBool.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 type t = bool
 

src/core/CCBool.mli

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Basic Bool functions} *)
 

src/core/CCError.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Error Monad} *)
 

src/core/CCError.mli

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Error Monad}
 

src/core/CCFloat.ml

@@ -1,27 +1,5 @@
-(*
-copyright (c) 2014, Carmelo Piccione
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 type t = float
 type fpclass = Pervasives.fpclass =

src/core/CCFloat.mli

@@ -1,27 +1,5 @@
-(*
-copyright (c) 2014, Carmelo Piccione
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Basic Float functions}
 @since 0.6.1 *)

src/core/CCFormat.ml

@@ -1,27 +1,5 @@
-(*
-copyright (c) 2013, 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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Helpers for Format} *)
 
@@ -99,18 +77,38 @@ let opt pp fmt x = match x with
   | Some x -> Format.fprintf fmt "some %a" pp x
 
 let pair ppa ppb fmt (a, b) =
-  Format.fprintf fmt "(%a, %a)" ppa a ppb b
+  Format.fprintf fmt "(%a,@ %a)" ppa a ppb b
 
 let triple ppa ppb ppc fmt (a, b, c) =
-  Format.fprintf fmt "(%a, %a, %a)" ppa a ppb b ppc c
+  Format.fprintf fmt "(%a,@ %a,@ %a)" ppa a ppb b ppc c
 
 let quad ppa ppb ppc ppd fmt (a, b, c, d) =
-  Format.fprintf fmt "(%a, %a, %a, %a)" ppa a ppb b ppc c ppd d
+  Format.fprintf fmt "(%a,@ %a,@ %a,@ %a)" ppa a ppb b ppc c ppd d
 
 let map f pp fmt x =
   pp fmt (f x);
   ()
 
+let vbox ?(i=0) pp out x =
+  Format.pp_open_vbox out i;
+  pp out x;
+  Format.pp_close_box out ()
+
+let hovbox ?(i=0) pp out x =
+  Format.pp_open_hovbox out i;
+  pp out x;
+  Format.pp_close_box out ()
+
+let hvbox ?(i=0) pp out x =
+  Format.pp_open_hvbox out i;
+  pp out x;
+  Format.pp_close_box out ()
+
+let hbox pp out x =
+  Format.pp_open_hbox out ();
+  pp out x;
+  Format.pp_close_box out ()
+
 (** {2 IO} *)
 
 let output fmt pp x = pp fmt x
@@ -197,7 +195,8 @@ let style_of_tag_ s = match String.trim s with
   | "magenta" -> [`FG `Magenta]
   | "cyan" -> [`FG `Cyan]
   | "white" -> [`FG `White]
-  | "Black" -> [`FG `Black]
+  | "bold" -> [`Bold]
+  | "Black" -> [`FG `Black; `Bold]
   | "Red" -> [`FG `Red; `Bold]
   | "Green" -> [`FG `Green; `Bold]
   | "Yellow" -> [`FG `Yellow; `Bold]
@@ -210,25 +209,34 @@ let style_of_tag_ s = match String.trim s with
 let color_enabled = ref false
 
 (* either prints the tag of [s] or delegate to [or_else] *)
-let mark_open_tag ~or_else s =
+let mark_open_tag st ~or_else s =
   try
     let style = style_of_tag_ s in
+    Stack.push style st;
     if !color_enabled then ansi_l_to_str_ style else ""
   with Not_found -> or_else s
 
-let mark_close_tag ~or_else s =
+let mark_close_tag st ~or_else s =
   try
     let _ = style_of_tag_ s in (* check if it's indeed about color *)
-    if !color_enabled then ansi_l_to_str_ [`Reset] else ""
+    let style =
+      try
+        ignore (Stack.pop st); (* pop current style (if well-scoped...) *)
+        Stack.top st (* look at previous style *)
+      with Stack.Empty ->
+        [`Reset]
+    in
+    if !color_enabled then ansi_l_to_str_ style else ""
   with Not_found -> or_else s
 
 (* add color handling to formatter [ppf] *)
 let set_color_tag_handling ppf =
   let open Format in
   let functions = pp_get_formatter_tag_functions ppf () in
+  let st = Stack.create () in (* stack of styles *)
   let functions' = {functions with
-    mark_open_tag=(mark_open_tag ~or_else:functions.mark_open_tag);
-    mark_close_tag=(mark_close_tag ~or_else:functions.mark_close_tag);
+    mark_open_tag=(mark_open_tag st ~or_else:functions.mark_open_tag);
+    mark_close_tag=(mark_close_tag st ~or_else:functions.mark_close_tag);
   } in
   pp_set_mark_tags ppf true; (* enable tags *)
   pp_set_formatter_tag_functions ppf functions'
@@ -255,18 +263,40 @@ let set_color_default =
     s
 *)
 
-let sprintf format =
+let with_color s pp out x =
+  Format.pp_open_tag out s;
+  pp out x;
+  Format.pp_close_tag out ()
+
+let with_colorf s out fmt =
+  Format.pp_open_tag out s;
+  Format.kfprintf
+    (fun out -> Format.pp_close_tag out ())
+    out fmt
+
+(* c: whether colors are enabled *)
+let sprintf_ c format =
   let buf = Buffer.create 64 in
   let fmt = Format.formatter_of_buffer buf in
-  if !color_enabled then set_color_tag_handling fmt;
+  if c && !color_enabled then set_color_tag_handling fmt;
   Format.kfprintf
     (fun _fmt -> Format.pp_print_flush fmt (); Buffer.contents buf)
     fmt
     format
 
+let sprintf fmt = sprintf_ true fmt
+let sprintf_no_color fmt = sprintf_ false fmt
+
 (*$T
   sprintf "yolo %s %d" "a b" 42 = "yolo a b 42"
   sprintf "%d " 0 = "0 "
+  sprintf_no_color "%d " 0 = "0 "
+*)
+
+(*$R
+  set_color_default true;
+  assert_equal "\027[31myolo\027[0m" (sprintf "@{<red>yolo@}");
+  assert_equal "yolo" (sprintf_no_color "@{<red>yolo@}");
 *)
 
 let ksprintf ~f fmt =

src/core/CCFormat.mli

@@ -1,27 +1,5 @@
-(*
-copyright (c) 2013, 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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Helpers for Format}
 
@@ -66,12 +44,31 @@ val quad : 'a printer -> 'b printer -> 'c printer -> 'd printer -> ('a * 'b * 'c
 
 val map : ('a -> 'b) -> 'b printer -> 'a printer
 
-(** {2 ASCII codes}
+val vbox : ?i:int -> 'a printer -> 'a printer
+(** Wrap the printer in a vertical box
+    @param i level of indentation within the box (default 0)
+    @since 0.16 *)
+
+val hvbox : ?i:int -> 'a printer -> 'a printer
+(** Wrap the printer in a horizontal/vertical box
+    @param i level of indentation within the box (default 0)
+    @since 0.16 *)
+
+val hovbox : ?i:int -> 'a printer -> 'a printer
+(** Wrap the printer in a horizontal or vertical box
+    @param i level of indentation within the box (default 0)
+    @since 0.16 *)
+
+val hbox : 'a printer -> 'a printer
+(** Wrap the printer in an horizontal box
+    @since 0.16 *)
+
+(** {2 ANSI codes}
 
   Use ANSI escape codes https://en.wikipedia.org/wiki/ANSI_escape_code
   to put some colors on the terminal.
 
-  This uses {b tags} in format strings to specify  the style. Current styles
+  This uses {b tags} in format strings to specify the style. Current styles
   are the following:
 
   {ul
@@ -84,6 +81,7 @@ val map : ('a -> 'b) -> 'b printer -> 'a printer
     {- "magenta" }
     {- "cyan" }
     {- "white" }
+    {- "bold" bold font}
     {- "Black" bold black}
     {- "Red" bold red }
     {- "Green" bold green }
@@ -115,6 +113,18 @@ val set_color_default : bool -> unit
     (stdout, stderr) if [b = true] as well as on {!sprintf} formatters;
     it disables the color handling if [b = false]. *)
 
+val with_color : string -> 'a printer -> 'a printer
+(** [with_color "Blue" pp] behaves like the printer [pp], but with the given
+    style.
+    {b status: experimental}
+    @since 0.16 *)
+
+val with_colorf : string -> t -> ('a, t, unit, unit) format4 -> 'a
+(** [with_colorf "Blue" out "%s %d" "yolo" 42] will behave like {!Format.fprintf},
+    but wrapping the content with the given style
+    {b status: experimental}
+    @since 0.16 *)
+
 (** {2 IO} *)
 
 val output : t -> 'a printer -> 'a -> unit
@@ -127,6 +137,10 @@ val sprintf : ('a, t, unit, string) format4 -> 'a
 (** Print into a string any format string that would usually be compatible
     with {!fprintf}. Similar to {!Format.asprintf}. *)
 
+val sprintf_no_color : ('a, t, unit, string) format4 -> 'a
+(** Similar to {!sprintf} but never prints colors
+    @since 0.16 *)
+
 val fprintf : t -> ('a, t, unit ) format -> 'a
 (** Alias to {!Format.fprintf}
     @since 0.14 *)

src/core/CCFun.cppo.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Basic Functions} *)
 
@@ -64,10 +42,28 @@ let lexicographic f1 f2 x y =
 let finally ~h ~f =
   try
     let x = f () in
-    h ();
+    ignore (h ());
     x
   with e ->
-    h ();
+    ignore (h ());
+    raise e
+
+let finally1 ~h f x =
+  try
+    let res = f x in
+    ignore (h ());
+    res
+  with e ->
+    ignore (h ());
+    raise e
+
+let finally2 ~h f x y =
+  try
+    let res = f x y in
+    ignore (h ());
+    res
+  with e ->
+    ignore (h ());
     raise e
 
 module Monad(X : sig type t end) = struct

src/core/CCFun.mli

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Basic Functions} *)
 
@@ -57,7 +35,7 @@ val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c
 
 val uncurry : ('a -> 'b -> 'c) -> ('a * 'b) -> 'c
 
-val tap : ('a -> 'b) -> 'a -> 'a
+val tap : ('a -> _) -> 'a -> 'a
 (** [tap f x] evaluates [f x], discards it, then returns [x]. Useful
     in a pipeline, for instance:
     {[CCArray.(1 -- 10)
@@ -72,11 +50,21 @@ val (%) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c
 val lexicographic : ('a -> 'a -> int) -> ('a -> 'a -> int) -> 'a -> 'a -> int
 (** Lexicographic combination of comparison functions *)
 
-val finally : h:(unit -> unit) -> f:(unit -> 'a) -> 'a
+val finally : h:(unit -> _) -> f:(unit -> 'a) -> 'a
 (** [finally h f] calls [f ()] and returns its result. If it raises, the
     same exception is raised; in {b any} case, [h ()] is called after
     [f ()] terminates. *)
 
+val finally1 : h:(unit -> _) -> ('a -> 'b) -> 'a -> 'b
+(** [finally1 ~h f x] is the same as [f x], but after the computation,
+    [h ()] is called whether [f x] rose an exception or not.
+    @since 0.16 *)
+
+val finally2 : h:(unit -> _) -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c
+(** [finally2 ~h f x y] is the same as [f x y], but after the computation,
+    [h ()] is called whether [f x y] rose an exception or not.
+    @since 0.16 *)
+
 (** {2 Monad}
 
 Functions with a fixed domain are monads in their codomain *)

src/core/CCHash.ml

@@ -1,27 +1,5 @@
-(*
-Copyright (c) 2013, 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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Hash combinators} *)
 

src/core/CCHash.mli

@@ -1,47 +1,22 @@
-(*
-Copyright (c) 2013, 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:
+(* This file is free software, part of containers. See file "license" for more details. *)
 
-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 Hash combinators}
-
-Combination of hashes based on the Murmur Hash (64 bits). See
-{{: https://sites.google.com/site/murmurhash/MurmurHash2_64.cpp?attredirects=0} this page}
-*)
+(** {1 Hash combinators} *)
 
 (** {2 Definitions} *)
 
 type t = int
 (** A hash value is a positive integer *)
 
-type state = int64
-(** State required by the hash function *)
+type state
+(** State required by the hash function.
+    @since 0.16 the state is abstract, for more flexibility *)
 
 type 'a hash_fun = 'a -> state -> state
 (** Hash function for values of type ['a], merging a fingerprint of the
     value into the state of type [t] *)
 
-(** {2 Applying Murmur Hash} *)
+(** {2 Applying Hash} *)
 
 val init : state
 (** Initial value *)
@@ -55,11 +30,11 @@ val apply : 'a hash_fun -> 'a -> int
 
 (** {2 Basic Combinators}
 
- Those combinators have been renamed in 0.13, so as to
- remove the trailing "_".
- They are now defined by the application of {!Make}
+    Those combinators have been renamed in 0.13, so as to
+    remove the trailing "_".
+    They are now defined by the application of {!Make}
 
- *)
+*)
 
 val bool_ : bool hash_fun
 (** @deprecated use {!bool} *)
@@ -108,11 +83,11 @@ val klist : 'a hash_fun -> 'a klist hash_fun
 
 (** {2 Generic Hashing}
 
-  Parametrize over the state, and some primitives to hash basic types.
-  This can for instance be used for cryptographic hashing or
-  checksums such as MD5.
+    Parametrize over the state, and some primitives to hash basic types.
+    This can for instance be used for cryptographic hashing or
+    checksums such as MD5.
 
-  @since 0.13 *)
+    @since 0.13 *)
 
 module type HASH = sig
   type state

src/core/CCHashtbl.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Extension to the standard Hashtbl}  *)
 
@@ -36,6 +14,15 @@ let get tbl x =
   try Some (Hashtbl.find tbl x)
   with Not_found -> None
 
+let get_or tbl x ~or_ =
+  try Hashtbl.find tbl x
+  with Not_found -> or_
+
+(*$=
+  "c" (let tbl = of_list [1,"a"; 2,"b"] in get_or tbl 3 ~or_:"c")
+  "b" (let tbl = of_list [1,"a"; 2,"b"] in get_or tbl 2 ~or_:"c")
+*)
+
 let keys tbl k = Hashtbl.iter (fun key _ -> k key) tbl
 
 let values tbl k = Hashtbl.iter (fun _ v -> k v) tbl
@@ -43,6 +30,24 @@ let values tbl k = Hashtbl.iter (fun _ v -> k v) tbl
 let keys_list tbl = Hashtbl.fold (fun k _ a -> k::a) tbl []
 let values_list tbl = Hashtbl.fold (fun _ v a -> v::a) tbl []
 
+let add_list tbl k v =
+  let l = try Hashtbl.find tbl k with Not_found -> [] in
+  Hashtbl.replace tbl k (v::l)
+
+let incr ?(by=1) tbl x =
+  let n = get_or tbl x ~or_:0 in
+  if n+by <= 0
+  then Hashtbl.remove tbl x
+  else Hashtbl.replace tbl x (n+by)
+
+let decr ?(by=1) tbl x =
+  try
+    let n = Hashtbl.find tbl x in
+    if n-by <= 0
+    then Hashtbl.remove tbl x
+    else Hashtbl.replace tbl x (n-by)
+  with Not_found -> ()
+
 let map_list f h =
   Hashtbl.fold
     (fun x y acc -> f x y :: acc)
@@ -55,9 +60,18 @@ let map_list f h =
 
 let to_seq tbl k = Hashtbl.iter (fun key v -> k (key,v)) tbl
 
+let add_seq tbl seq = seq (fun (k,v) -> Hashtbl.add tbl k v)
+
 let of_seq seq =
   let tbl = Hashtbl.create 32 in
-  seq (fun (k,v) -> Hashtbl.add tbl k v);
+  add_seq tbl seq;
+  tbl
+
+let add_seq_count tbl seq = seq (fun k -> incr tbl k)
+
+let of_seq_count seq =
+  let tbl = Hashtbl.create 32 in
+  add_seq_count tbl seq;
   tbl
 
 let to_list tbl =
@@ -110,18 +124,41 @@ module type S = sig
   val get : 'a t -> key -> 'a option
   (** Safe version of {!Hashtbl.find} *)
 
+  val get_or : 'a t -> key -> or_:'a -> 'a
+  (** [get_or tbl k ~or_] returns the value associated to [k] if present,
+      and returns [or_] otherwise (if [k] doesn't belong in [tbl])
+      @since 0.16 *)
+
+  val add_list : 'a list t -> key -> 'a -> unit
+  (** [add_list tbl x y] adds [y] to the list [x] is bound to. If [x] is
+      not bound, it becomes bound to [[y]].
+      @since 0.16 *)
+
+  val incr : ?by:int -> int t -> key -> unit
+  (** [incr ?by tbl x] increments or initializes the counter associated with [x].
+      If [get tbl x = None], then after update, [get tbl x = Some 1];
+      otherwise, if [get tbl x = Some n], now [get tbl x = Some (n+1)].
+      @param by if specified, the int value is incremented by [by] rather than 1
+      @since 0.16 *)
+
+  val decr : ?by:int -> int t -> key -> unit
+  (** Same as {!incr} but substract 1 (or the value of [by]).
+      If the value reaches 0, the key is removed from the table.
+      This does nothing if the key is not already present in the table.
+      @since 0.16 *)
+
   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 keys_list : ('a, 'b) Hashtbl.t -> 'a list
-  (** [keys_list t] is the list of keys in [t].
+  val keys_list : _ t -> key list
+  (** [keys t] is the list of keys in [t].
       @since 0.8 *)
 
-  val values_list : ('a, 'b) Hashtbl.t -> 'b list
-  (** [values_list t] is the list of values in [t].
+  val values_list : 'a t -> 'a list
+  (** [values t] is the list of values in [t].
       @since 0.8 *)
 
   val map_list : (key -> 'a -> 'b) -> 'a t -> 'b list
@@ -133,6 +170,20 @@ module type S = sig
   val of_seq : (key * 'a) sequence -> 'a t
   (** From the given bindings, added in order *)
 
+  val add_seq : 'a t -> (key * 'a) sequence -> unit
+  (** Add the corresponding pairs to the table, using {!Hashtbl.add}.
+      @since 0.16 *)
+
+  val add_seq_count : int t -> key sequence -> unit
+  (** [add_seq_count tbl seq] increments the count of each element of [seq]
+      by calling {!incr}. This is useful for counting how many times each
+      element of [seq] occurs.
+      @since 0.16 *)
+
+  val of_seq_count : key sequence -> int t
+  (** Similar to {!add_seq_count}, but allocates a new table and returns it
+      @since 0.16 *)
+
   val to_list : 'a t -> (key * 'a) list
   (** List of bindings (order unspecified)  *)
 
@@ -152,6 +203,10 @@ module type S = sig
       @since 0.13 *)
 end
 
+(*$inject
+  module T = Make(CCInt)
+*)
+
 module Make(X : Hashtbl.HashedType)
   : S with type key = X.t and type 'a t = 'a Hashtbl.Make(X).t
 = struct
@@ -161,12 +216,53 @@ module Make(X : Hashtbl.HashedType)
     try Some (find tbl x)
     with Not_found -> None
 
+  let get_or tbl x ~or_ =
+    try find tbl x
+    with Not_found -> or_
+
+  (*$=
+    "c" (let tbl = T.of_list [1,"a"; 2,"b"] in T.get_or tbl 3 ~or_:"c")
+    "b" (let tbl = T.of_list [1,"a"; 2,"b"] in T.get_or tbl 2 ~or_:"c")
+  *)
+
+  let incr ?(by=1) tbl x =
+    let n = get_or tbl x ~or_:0 in
+    if n+by <= 0
+    then remove tbl x
+    else replace tbl x (n+by)
+
+  (*$R
+    let tbl = T.create 32 in
+    T.incr tbl 1 ;
+    T.incr tbl 2;
+    T.incr tbl 1;
+    assert_equal 2 (T.find tbl 1);
+    assert_equal 1 (T.find tbl 2);
+    assert_equal 2 (T.length tbl);
+    T.decr tbl 2;
+    assert_equal 0 (T.get_or tbl 2 ~or_:0);
+    assert_equal 1 (T.length tbl);
+    assert_bool "2 removed" (not (T.mem tbl 2));
+  *)
+
+  let add_list tbl k v =
+    let l = try find tbl k with Not_found -> [] in
+    replace tbl k (v::l)
+
+  let decr ?(by=1) tbl x =
+    try
+      let n = find tbl x in
+      if n-by <= 0
+      then remove tbl x
+      else replace tbl x (n-by)
+    with Not_found -> ()
+
   let keys tbl k = iter (fun key _ -> k key) tbl
 
   let values tbl k = iter (fun _ v -> k v) tbl
 
-  let keys_list tbl = Hashtbl.fold (fun k _ a -> k::a) tbl []
-  let values_list tbl = Hashtbl.fold (fun _ v a -> v::a) tbl []
+  let keys_list tbl = fold (fun k _ a -> k::a) tbl []
+  let values_list tbl = fold (fun _ v a -> v::a) tbl []
 
   let map_list f h =
     fold
@@ -183,9 +279,18 @@ module Make(X : Hashtbl.HashedType)
 
   let to_seq tbl k = iter (fun key v -> k (key,v)) tbl
 
+  let add_seq tbl seq = seq (fun (k,v) -> add tbl k v)
+
   let of_seq seq =
     let tbl = create 32 in
-    seq (fun (k,v) -> add tbl k v);
+    add_seq tbl seq;
+    tbl
+
+  let add_seq_count tbl seq = seq (fun k -> incr tbl k)
+
+  let of_seq_count seq =
+    let tbl = create 32 in
+    add_seq_count tbl seq;
     tbl
 
   let to_list tbl =

src/core/CCHashtbl.mli

@@ -1,28 +1,5 @@
-(*
-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.
-*)
 
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Extension to the standard Hashtbl}
 
@@ -38,6 +15,11 @@ type 'a printer = Format.formatter -> 'a -> unit
 val get : ('a,'b) Hashtbl.t -> 'a -> 'b option
 (** Safe version of {!Hashtbl.find} *)
 
+val get_or : ('a,'b) Hashtbl.t -> 'a -> or_:'b -> 'b
+(** [get_or tbl k ~or_] returns the value associated to [k] if present,
+    and returns [or_] otherwise (if [k] doesn't belong in [tbl])
+    @since 0.16 *)
+
 val keys : ('a,'b) Hashtbl.t -> 'a sequence
 (** Iterate on keys (similar order as {!Hashtbl.iter}) *)
 
@@ -55,12 +37,44 @@ val values_list : ('a, 'b) Hashtbl.t -> 'b list
 val map_list : ('a -> 'b -> 'c) -> ('a, 'b) Hashtbl.t -> 'c list
 (** Map on a hashtable's items, collect into a list *)
 
+val incr : ?by:int -> ('a, int) Hashtbl.t -> 'a -> unit
+(** [incr ?by tbl x] increments or initializes the counter associated with [x].
+    If [get tbl x = None], then after update, [get tbl x = Some 1];
+    otherwise, if [get tbl x = Some n], now [get tbl x = Some (n+1)].
+    @param by if specified, the int value is incremented by [by] rather than 1
+    @since 0.16 *)
+
+val decr : ?by:int -> ('a, int) Hashtbl.t -> 'a -> unit
+(** Same as {!incr} but substract 1 (or the value of [by]).
+    If the value reaches 0, the key is removed from the table.
+    This does nothing if the key is not already present in the table.
+    @since 0.16 *)
+
 val to_seq : ('a,'b) Hashtbl.t -> ('a * 'b) sequence
 (** Iterate on bindings in the table *)
 
+val add_list : ('a, 'b list) Hashtbl.t -> 'a -> 'b -> unit
+(** [add_list tbl x y] adds [y] to the list [x] is bound to. If [x] is
+    not bound, it becomes bound to [[y]].
+    @since 0.16 *)
+
+val add_seq : ('a,'b) Hashtbl.t -> ('a * 'b) sequence -> unit
+(** Add the corresponding pairs to the table, using {!Hashtbl.add}.
+    @since 0.16 *)
+
 val of_seq : ('a * 'b) sequence -> ('a,'b) Hashtbl.t
 (** From the given bindings, added in order *)
 
+val add_seq_count : ('a, int) Hashtbl.t -> 'a sequence -> unit
+(** [add_seq_count tbl seq] increments the count of each element of [seq]
+    by calling {!incr}. This is useful for counting how many times each
+    element of [seq] occurs.
+    @since 0.16 *)
+
+val of_seq_count : 'a sequence -> ('a, int) Hashtbl.t
+(** Similar to {!add_seq_count}, but allocates a new table and returns it
+    @since 0.16 *)
+
 val to_list : ('a,'b) Hashtbl.t -> ('a * 'b) list
 (** List of bindings (order unspecified)  *)
 
@@ -87,17 +101,40 @@ module type S = sig
   val get : 'a t -> key -> 'a option
   (** Safe version of {!Hashtbl.find} *)
 
+  val get_or : 'a t -> key -> or_:'a -> 'a
+  (** [get_or tbl k ~or_] returns the value associated to [k] if present,
+      and returns [or_] otherwise (if [k] doesn't belong in [tbl])
+      @since 0.16 *)
+
+  val add_list : 'a list t -> key -> 'a -> unit
+  (** [add_list tbl x y] adds [y] to the list [x] is bound to. If [x] is
+      not bound, it becomes bound to [[y]].
+      @since 0.16 *)
+
+  val incr : ?by:int -> int t -> key -> unit
+  (** [incr ?by tbl x] increments or initializes the counter associated with [x].
+      If [get tbl x = None], then after update, [get tbl x = Some 1];
+      otherwise, if [get tbl x = Some n], now [get tbl x = Some (n+1)].
+      @param by if specified, the int value is incremented by [by] rather than 1
+      @since 0.16 *)
+
+  val decr : ?by:int -> int t -> key -> unit
+  (** Same as {!incr} but substract 1 (or the value of [by]).
+      If the value reaches 0, the key is removed from the table.
+      This does nothing if the key is not already present in the table.
+      @since 0.16 *)
+
   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 keys_list : ('a, 'b) Hashtbl.t -> 'a list
+  val keys_list : _ t -> key list
   (** [keys t] is the list of keys in [t].
       @since 0.8 *)
 
-  val values_list : ('a, 'b) Hashtbl.t -> 'b list
+  val values_list : 'a t -> 'a list
   (** [values t] is the list of values in [t].
       @since 0.8 *)
 
@@ -110,6 +147,20 @@ module type S = sig
   val of_seq : (key * 'a) sequence -> 'a t
   (** From the given bindings, added in order *)
 
+  val add_seq : 'a t -> (key * 'a) sequence -> unit
+  (** Add the corresponding pairs to the table, using {!Hashtbl.add}.
+      @since 0.16 *)
+
+  val add_seq_count : int t -> key sequence -> unit
+  (** [add_seq_count tbl seq] increments the count of each element of [seq]
+      by calling {!incr}. This is useful for counting how many times each
+      element of [seq] occurs.
+      @since 0.16 *)
+
+  val of_seq_count : key sequence -> int t
+  (** Similar to {!add_seq_count}, but allocates a new table and returns it
+      @since 0.16 *)
+
   val to_list : 'a t -> (key * 'a) list
   (** List of bindings (order unspecified)  *)
 
@@ -134,7 +185,9 @@ module Make(X : Hashtbl.HashedType) :
 
 (** {2 Default Table}
 
-A table with a default element for keys that were never added. *)
+    A table with a default element for keys that were never added.
+
+    @deprecated since 0.16, should be merged into [Make] itself *)
 
 module type DEFAULT = sig
   type key
@@ -168,7 +221,9 @@ end
 
 module MakeDefault(X : Hashtbl.HashedType) : DEFAULT with type key = X.t
 
-(** {2 Count occurrences using a Hashtbl} *)
+(** {2 Count occurrences using a Hashtbl}
+
+    @deprecated since 0.16, should be merged into [Make] itself *)
 
 module type COUNTER = sig
   type elt

src/core/CCHeap.ml

@@ -1,32 +1,11 @@
-(*
-Copyright (c) 2013, 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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Leftist Heaps} *)
 
 type 'a sequence = ('a -> unit) -> unit
 type 'a gen = unit -> 'a option
+type 'a printer = Format.formatter -> 'a -> unit
 type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
 type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list]
 
@@ -78,7 +57,7 @@ end
 (*$QR & ~count:30
   Q.(list_of_size Gen.(return 1_000) int) (fun l ->
     (* put elements into a heap *)
-    let h = H.of_seq H.empty (Sequence.of_list l) in
+    let h = H.of_seq (Sequence.of_list l) in
     OUnit.assert_equal 1_000 (H.size h);
     let l' = extract_list h in
     is_sorted l'
@@ -134,21 +113,40 @@ module type S = sig
   val size : t -> int
   (** Number of elements (linear complexity) *)
 
-  (** {2 Conversions} *)
+  (** {2 Conversions}
+      
+      The interface of [of_gen], [of_seq], [of_klist]
+      has changed @since 0.16 (the old signatures
+      are now [add_seq], [add_gen], [add_klist]) *)
 
   val to_list : t -> elt list
+
+  val add_list : t -> elt list -> t (** @since 0.16 *)
+
   val of_list : elt list -> t
 
-  val of_seq : t -> elt sequence -> t
+  val add_seq : t -> elt sequence -> t (** @since 0.16 *)
+
+  val of_seq : elt sequence -> t
+
   val to_seq : t -> elt sequence
 
-  val of_klist : t -> elt klist -> t
+  val add_klist : t -> elt klist -> t (** @since 0.16 *)
+
+  val of_klist : elt klist -> t
+
   val to_klist : t -> elt klist
 
-  val of_gen : t -> elt gen -> t
+  val add_gen : t -> elt gen -> t (** @since 0.16 *)
+
+  val of_gen : elt gen -> t
+
   val to_gen : t -> elt gen
 
   val to_tree : t -> elt ktree
+
+  val print : ?sep:string -> elt printer -> t printer
+  (** @since 0.16 *)
 end
 
 module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct
@@ -240,20 +238,26 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct
           x::aux (aux acc l) r
     in aux [] h
 
-  let of_list l = List.fold_left add empty l
+  let add_list h l = List.fold_left add h l
 
-  let of_seq h seq =
+  let of_list l = add_list empty l
+
+  let add_seq h seq =
     let h = ref h in
     seq (fun x -> h := insert x !h);
     !h
 
+  let of_seq seq = add_seq empty seq
+
   let to_seq h k = iter k h
 
-  let rec of_klist h l = match l() with
+  let rec add_klist h l = match l() with
     | `Nil -> h
     | `Cons (x, l') ->
         let h' = add h x in
-        of_klist h' l'
+        add_klist h' l'
+
+  let of_klist l = add_klist empty l
 
   let to_klist h =
     let rec next stack () = match stack with
@@ -264,10 +268,12 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct
     in
     next [h]
 
-  let rec of_gen h g = match g () with
+  let rec add_gen h g = match g () with
     | None -> h
     | Some x ->
-        of_gen (add h x) g
+        add_gen (add h x) g
+
+  let of_gen g = add_gen empty g
 
   let to_gen h =
     let stack = Stack.create () in
@@ -285,7 +291,8 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct
 
   (*$Q
     Q.(list int) (fun l -> \
-      extract_list (H.of_list l) = extract_list (H.of_gen H.empty (CCList.to_gen l)))
+      extract_list (H.of_list l) = \
+        extract_list (H.of_gen (CCList.to_gen l)))
     Q.(list int) (fun l -> \
       let h = H.of_list l in \
       (H.to_gen h |> CCList.of_gen |> List.sort Pervasives.compare) \
@@ -295,4 +302,12 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct
   let rec to_tree h () = match h with
     | E -> `Nil
     | N (_, x, l, r) -> `Node(x, [to_tree l; to_tree r])
+
+  let print ?(sep=",") pp_elt out h =
+    let first=ref true in
+    iter
+      (fun x ->
+        if !first then first := false else Format.fprintf out "%s@," sep;
+        pp_elt out x)
+      h
 end

src/core/CCHeap.mli

@@ -1,27 +1,5 @@
-(*
-Copyright (c) 2013, 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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Leftist Heaps} following Okasaki *)
 
@@ -29,6 +7,7 @@ type 'a sequence = ('a -> unit) -> unit
 type 'a gen = unit -> 'a option
 type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
 type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list]
+type 'a printer = Format.formatter -> 'a -> unit
 
 module type PARTIAL_ORD = sig
   type t
@@ -85,21 +64,40 @@ module type S = sig
   val size : t -> int
   (** Number of elements (linear complexity) *)
 
-  (** {2 Conversions} *)
+  (** {2 Conversions}
+      
+      The interface of [of_gen], [of_seq], [of_klist]
+      has changed @since 0.16 (the old signatures
+      are now [add_seq], [add_gen], [add_klist]) *)
 
   val to_list : t -> elt list
+
+  val add_list : t -> elt list -> t (** @since 0.16 *)
+
   val of_list : elt list -> t
 
-  val of_seq : t -> elt sequence -> t
+  val add_seq : t -> elt sequence -> t (** @since 0.16 *)
+
+  val of_seq : elt sequence -> t
+
   val to_seq : t -> elt sequence
 
-  val of_klist : t -> elt klist -> t
+  val add_klist : t -> elt klist -> t (** @since 0.16 *)
+
+  val of_klist : elt klist -> t
+
   val to_klist : t -> elt klist
 
-  val of_gen : t -> elt gen -> t
+  val add_gen : t -> elt gen -> t (** @since 0.16 *)
+
+  val of_gen : elt gen -> t
+
   val to_gen : t -> elt gen
 
   val to_tree : t -> elt ktree
+
+  val print : ?sep:string -> elt printer -> t printer
+  (** @since 0.16 *)
 end
 
 module Make(E : PARTIAL_ORD) : S with type elt = E.t

src/core/CCIO.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 IO Utils} *)
 
@@ -282,6 +260,22 @@ module File = struct
     with exn ->
       `Error (Printexc.to_string exn)
 
+  let read_exn f = with_in f (read_all_ ~op:Ret_string ~size:4096)
+
+  let read f = try `Ok (read_exn f) with e -> `Error (Printexc.to_string e)
+
+  let append_exn f x =
+    with_out ~flags:[Open_append; Open_creat; Open_text] f
+      (fun oc -> output_string oc x; flush oc)
+
+  let append f x = try `Ok (append_exn f x) with e -> `Error (Printexc.to_string e)
+
+  let write_exn f x =
+    with_out f
+      (fun oc -> output_string oc x; flush oc)
+
+  let write f x = try `Ok (write_exn f x) with e -> `Error (Printexc.to_string e)
+
   let remove_noerr f = try Sys.remove f with _ -> ()
 
   let read_dir_base d =

src/core/CCIO.mli

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 IO Utils}
 
@@ -184,6 +162,30 @@ module File : sig
       @param recurse if true (default [false]), sub-directories are also
         explored *)
 
+  val read_exn : t -> string
+  (** Read the content of the given file, or raises some exception
+      @since 0.16 *)
+
+  val read : t -> string or_error
+  (** Read the content of the given file
+      @since 0.16 *)
+
+  val append_exn : t -> string -> unit
+  (** Append the given string into the given file, possibly raising
+      @since 0.16 *)
+
+  val append : t -> string -> unit or_error
+  (** Append the given string into the given file
+      @since 0.16 *)
+
+  val write_exn : t -> string -> unit
+  (** Write the given string into the given file, possibly raising
+      @since 0.16 *)
+
+  val write : t -> string -> unit or_error
+  (** Write the given string into the given file
+      @since 0.16 *)
+
   type walk_item = [`File | `Dir] * t
 
   val walk : t -> walk_item gen

src/core/CCInt.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 type t = int
 

src/core/CCInt.mli

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Basic Int functions} *)
 

src/core/CCList.ml

@@ -1,30 +1,12 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 complements to list} *)
 
+(*$inject
+  let lsort l = List.sort Pervasives.compare l
+*)
+
 type 'a t = 'a list
 
 let empty = []
@@ -170,6 +152,28 @@ let fold_map f acc l =
     fold_map (fun acc x -> x::acc, x) [] l = (List.rev l, l))
 *)
 
+let fold_map2 f acc l1 l2 =
+  let rec aux f acc map_acc l1 l2 = match l1, l2 with
+    | [], [] -> acc, List.rev map_acc
+    | [], _
+    | _, [] -> invalid_arg "fold_map2"
+    | x1 :: l1', x2 :: l2' ->
+        let acc, y = f acc x1 x2 in
+        aux f acc (y :: map_acc) l1' l2'
+  in
+  aux f acc [] l1 l2
+
+(*$=
+  (310, ["1 10"; "2 0"; "3 100"]) \
+    (fold_map2 (fun acc x y->acc+x*y, string_of_int x ^ " " ^ string_of_int y) \
+    0 [1;2;3] [10;0;100])
+*)
+
+(*$T
+  (try ignore (fold_map2 (fun _ _ _ -> assert false) 42 [] [1]); false \
+   with Invalid_argument _ -> true)
+*)
+
 let fold_flat_map f acc l =
   let rec aux f acc map_acc l = match l with
     | [] -> acc, List.rev map_acc
@@ -450,6 +454,15 @@ let rec drop n l = match l with
   | _ when n=0 -> l
   | _::l' -> drop (n-1) l'
 
+let hd_tl = function
+  | [] -> failwith "hd_tl"
+  | x :: l -> x, l
+
+(*$T
+  try ignore (hd_tl []); false with Failure _ -> true
+  hd_tl [1;2;3] = (1, [2;3])
+*)
+
 let take_drop n l = take n l, drop n l
 
 let split = take_drop
@@ -771,15 +784,15 @@ let repeat i l =
 module Assoc = struct
   type ('a, 'b) t = ('a*'b) list
 
-  let get_exn ?(eq=(=)) l x =
-    let rec search eq l x = match l with
-      | [] -> raise Not_found
-      | (y,z)::l' ->
-          if eq x y then z else search eq l' x
-    in search eq l x
+  let rec search_exn eq l x = match l with
+    | [] -> raise Not_found
+    | (y,z)::l' ->
+        if eq x y then z else search_exn eq l' x
 
-  let get ?eq l x =
-    try Some (get_exn ?eq l x)
+  let get_exn ?(eq=(=)) l x = search_exn eq l x
+
+  let get ?(eq=(=)) l x =
+    try Some (search_exn eq l x)
     with Not_found -> None
 
   (*$T
@@ -789,14 +802,19 @@ module Assoc = struct
     Assoc.get [] 42 = None
   *)
 
+  (* search for a binding for [x] in [l], and calls [f x (Some v) rest]
+     or [f x None rest] depending on whether it finds the binding.
+     [rest] is the list of the other bindings *)
+  let rec search_set eq acc l x ~f = match l with
+    | [] -> f x None acc
+    | (x',y')::l' ->
+        if eq x x'
+          then f x (Some y') (List.rev_append acc l')
+          else search_set eq ((x',y')::acc) l' x ~f
+
   let set ?(eq=(=)) l x y =
-    let rec search eq acc l x y = match l with
-      | [] -> (x,y)::acc
-      | (x',y')::l' ->
-          if eq x x'
-            then (x,y)::List.rev_append acc l'
-            else search eq ((x',y')::acc) l' x y
-    in search eq [] l x y
+    search_set eq [] l x
+      ~f:(fun x _ l -> (x,y)::l)
 
   (*$T
     Assoc.set [1,"1"; 2, "2"] 2 "two" |> List.sort Pervasives.compare \
@@ -804,6 +822,33 @@ module Assoc = struct
     Assoc.set [1,"1"; 2, "2"] 3 "3" |> List.sort Pervasives.compare \
       = [1, "1"; 2, "2"; 3, "3"]
   *)
+
+  let mem ?(eq=(=)) l x =
+    try ignore (search_exn eq l x); true
+    with Not_found -> false
+
+  (*$T
+    Assoc.mem [1,"1"; 2,"2"; 3, "3"] 1
+    not (Assoc.mem [1,"1"; 2,"2"; 3, "3"] 4)
+  *)
+
+  let update ?(eq=(=)) l x ~f =
+    search_set eq [] l x
+      ~f:(fun x opt_y rest ->
+        match f opt_y with
+        | None -> rest (* drop *)
+        | Some y' -> (x,y') :: rest)
+  (*$=
+    [1,"1"; 2,"22"] \
+      (Assoc.update [1,"1"; 2,"2"] 2 \
+        ~f:(function Some "2" -> Some "22" | _ -> assert false) |> lsort)
+    [1,"1"; 3,"3"] \
+      (Assoc.update [1,"1"; 2,"2"; 3,"3"] 2 \
+        ~f:(function Some "2" -> None | _ -> assert false) |> lsort)
+    [1,"1"; 2,"2"; 3,"3"] \
+      (Assoc.update [1,"1"; 2,"2"] 3 \
+        ~f:(function None -> Some "3" | _ -> assert false) |> lsort)
+  *)
 end
 
 (** {2 Zipper} *)
@@ -1036,6 +1081,15 @@ let of_klist l =
   in
   direct direct_depth_default_ l
 
+module Infix = struct
+  let (>|=) = (>|=)
+  let (@) = (@)
+  let (<*>) = (<*>)
+  let (<$>) = (<$>)
+  let (>>=) = (>>=)
+  let (--) = (--)
+end
+
 (** {2 IO} *)
 
 let pp ?(start="[") ?(stop="]") ?(sep=", ") pp_item buf l =

src/core/CCList.mli

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 complements to list} *)
 
@@ -70,6 +48,11 @@ val fold_map : ('acc -> 'a -> 'acc * 'b) -> 'acc -> 'a list -> 'acc * 'b list
     list to another list.
     @since 0.14 *)
 
+val fold_map2 : ('acc -> 'a -> 'b -> 'acc * 'c) -> 'acc -> 'a list -> 'b list -> 'acc * 'c list
+(** [fold_map2] is to [fold_map] what [List.map2] is to [List.map].
+    @raise Invalid_argument if the lists do not have the same length
+    @since 0.16 *)
+
 val fold_flat_map : ('acc -> 'a -> 'acc * 'b list) -> 'acc -> 'a list -> 'acc * 'b list
 (** [fold_flat_map f acc l] is a [fold_left]-like function, but it also maps the
     list to a list of lists that is then [flatten]'d..
@@ -123,6 +106,11 @@ val take : int -> 'a t -> 'a t
 val drop : int -> 'a t -> 'a t
 (** Drop the [n] first elements, keep the rest *)
 
+val hd_tl : 'a t -> 'a * 'a t
+(** [hd_tl (x :: l)] returns [hd, l].
+    @raise Failure if the list is empty
+    @since 0.16 *)
+
 val take_drop : int -> 'a t -> 'a t * 'a t
 (** [take_drop n l] returns [l1, l2] such that [l1 @ l2 = l] and
     [length l1 = min (length l) n] *)
@@ -295,6 +283,17 @@ module Assoc : sig
 
   val set : ?eq:('a->'a->bool) -> ('a,'b) t -> 'a -> 'b -> ('a,'b) t
   (** Add the binding into the list (erase it if already present) *)
+
+  val mem : ?eq:('a->'a->bool) -> ('a,_) t -> 'a -> bool
+  (** [mem l x] returns [true] iff [x] is a key in [l]
+      @since 0.16 *)
+
+  val update :
+    ?eq:('a->'a->bool) -> ('a,'b) t -> 'a -> f:('b option -> 'b option) -> ('a,'b) t
+  (** [update l k ~f] updates [l] on the key [k], by calling [f (get l k)]
+      and removing [k] if it returns [None], mapping [k] to [v'] if it
+      returns [Some v']
+      @since 0.16 *)
 end
 
 (** {2 Zipper} *)
@@ -466,6 +465,21 @@ val of_gen : 'a gen -> 'a t
 val to_klist : 'a t -> 'a klist
 val of_klist : 'a klist -> 'a t
 
+(** {2 Infix Operators}
+    It is convenient to {!open CCList.Infix} to access the infix operators
+    without cluttering  the scope too much.
+
+    @since 0.16 *)
+
+module Infix : sig
+  val (>|=) : 'a t -> ('a -> 'b) -> 'b t
+  val (@) : 'a t -> 'a t -> 'a t
+  val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
+  val (<$>) : ('a -> 'b) -> 'a t -> 'b t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+  val (--) : int -> int -> int t
+end
+
 (** {2 IO} *)
 
 val pp : ?start:string -> ?stop:string -> ?sep:string ->

src/core/CCMap.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Extensions of Standard Map} *)
 
@@ -35,6 +13,11 @@ module type S = sig
   val get : key -> 'a t -> 'a option
   (** Safe version of {!find} *)
 
+  val get_or : key -> 'a t -> or_:'a -> 'a
+  (** [get_or k m ~or_] returns the value associated to [k] if present,
+      and returns [or_] otherwise (if [k] doesn't belong in [m])
+      @since 0.16 *)
+
   val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
   (** [update k f m] calls [f (Some v)] if [find k m = v],
       otherwise it calls [f None]. In any case, if the result is [None]
@@ -63,11 +46,13 @@ module type S = sig
 
   val to_list : 'a t -> (key * 'a) list
 
-  val pp : ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string ->
-            key printer -> 'a printer -> 'a t printer
+  val pp :
+    ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string ->
+    key printer -> 'a printer -> 'a t printer
 
-  val print : ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string ->
-              key formatter -> 'a formatter -> 'a t formatter
+  val print :
+    ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string ->
+    key formatter -> 'a formatter -> 'a t formatter
 end
 
 module Make(O : Map.OrderedType) = struct
@@ -77,14 +62,18 @@ module Make(O : Map.OrderedType) = struct
     try Some (find k m)
     with Not_found -> None
 
+  let get_or k m ~or_ =
+    try find k m
+    with Not_found -> or_
+
   let update k f m =
     let x =
       try f (Some (find k m))
       with Not_found -> f None
     in
     match x with
-      | None -> remove k m
-      | Some v' -> add k v' m
+    | None -> remove k m
+    | Some v' -> add k v' m
 
   let add_seq m s =
     let m = ref m in
@@ -114,11 +103,11 @@ module Make(O : Map.OrderedType) = struct
     Buffer.add_string buf start;
     iter
       (fun k v ->
-        if !first then first := false else Buffer.add_string buf sep;
-        pp_k buf k;
-        Buffer.add_string buf arrow;
-        pp_v buf v
-      ) m;
+         if !first then first := false else Buffer.add_string buf sep;
+         pp_k buf k;
+         Buffer.add_string buf arrow;
+         pp_v buf v)
+      m;
     Buffer.add_string buf stop
 
   let print ?(start="[") ?(stop="]") ?(arrow="->") ?(sep=", ") pp_k pp_v fmt m =
@@ -126,13 +115,14 @@ module Make(O : Map.OrderedType) = struct
     let first = ref true in
     iter
       (fun k v ->
-        if !first then first := false else (
-          Format.pp_print_string fmt sep;
-          Format.pp_print_cut fmt ()
-        );
-        pp_k fmt k;
-        Format.pp_print_string fmt arrow;
-        pp_v fmt v;
-      ) m;
+         if !first then first := false
+         else (
+           Format.pp_print_string fmt sep;
+           Format.pp_print_cut fmt ()
+         );
+         pp_k fmt k;
+         Format.pp_print_string fmt arrow;
+         pp_v fmt v)
+      m;
     Format.pp_print_string fmt stop
 end

src/core/CCMap.mli

@@ -1,32 +1,10 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Extensions of Standard Map}
 
-Provide useful functions and iterators on [Map.S]
-@since 0.5 *)
+    Provide useful functions and iterators on [Map.S]
+    @since 0.5 *)
 
 type 'a sequence = ('a -> unit) -> unit
 type 'a printer = Buffer.t -> 'a -> unit
@@ -38,6 +16,11 @@ module type S = sig
   val get : key -> 'a t -> 'a option
   (** Safe version of {!find} *)
 
+  val get_or : key -> 'a t -> or_:'a -> 'a
+  (** [get_or k m ~or_] returns the value associated to [k] if present,
+      and returns [or_] otherwise (if [k] doesn't belong in [m])
+      @since 0.16 *)
+
   val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
   (** [update k f m] calls [f (Some v)] if [find k m = v],
       otherwise it calls [f None]. In any case, if the result is [None]
@@ -66,13 +49,15 @@ module type S = sig
 
   val to_list : 'a t -> (key * 'a) list
 
-  val pp : ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string ->
-            key printer -> 'a printer -> 'a t printer
+  val pp :
+    ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string ->
+    key printer -> 'a printer -> 'a t printer
 
-  val print : ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string ->
-              key formatter -> 'a formatter -> 'a t formatter
+  val print :
+    ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string ->
+    key formatter -> 'a formatter -> 'a t formatter
 end
 
 module Make(O : Map.OrderedType) : S
   with type 'a t = 'a Map.Make(O).t
-  and type key = O.t
+   and type key = O.t

src/core/CCOpt.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Options} *)
 
@@ -31,10 +9,12 @@ let map f = function
   | None -> None
   | Some x -> Some (f x)
 
-let maybe f d = function
-  | None -> d
+let map_or ~default f = function
+  | None -> default
   | Some x -> f x
 
+let maybe f default = map_or ~default f
+
 let is_some = function
   | None -> false
   | Some _ -> true
@@ -143,6 +123,14 @@ let of_list = function
   | x::_ -> Some x
   | [] -> None
 
+module Infix = struct
+  let (>|=) = (>|=)
+  let (>>=) = (>>=)
+  let (<*>) = (<*>)
+  let (<$>) = (<$>)
+  let (<+>) = (<+>)
+end
+
 type 'a sequence = ('a -> unit) -> unit
 type 'a gen = unit -> 'a option
 type 'a printer = Buffer.t -> 'a -> unit

src/core/CCOpt.mli

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Options} *)
 
@@ -31,7 +9,13 @@ val map : ('a -> 'b) -> 'a t -> 'b t
 (** Transform the element inside, if any *)
 
 val maybe : ('a -> 'b) -> 'b -> 'a t -> 'b
-(** [maybe f x o] is [x] if [o] is [None], otherwise it's [f y] if [o = Some y] *)
+(** [maybe f x o] is [x] if [o] is [None],
+    otherwise it's [f y] if [o = Some y]
+    @deprecated, use {!map_or} *)
+
+val map_or : default:'b -> ('a -> 'b) -> 'a t -> 'b
+(** [map_or ~default f o] is [f x] if [o = Some x], [default otherwise]
+    @since 0.16 *)
 
 val is_some : _ t -> bool
 
@@ -109,6 +93,16 @@ val (<+>) : 'a t -> 'a t -> 'a t
 
 val choice : 'a t list -> 'a t
 (** [choice] returns the first non-[None] element of the list, or [None] *)
+(** {2 Infix Operators}
+    @since 0.16 *)
+
+module Infix : sig
+  val (>|=) : 'a t -> ('a -> 'b) -> 'b t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+  val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
+  val (<$>) : ('a -> 'b) -> 'a t -> 'b t
+  val (<+>) : 'a t -> 'a t -> 'a t
+end
 
 (** {2 Conversion and IO} *)
 

src/core/CCOrd.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Comparisons} *)
 
@@ -52,6 +30,13 @@ let string_ (x:string) y = Pervasives.compare x y
 let bool_ (x:bool) y = Pervasives.compare x y
 let float_ (x:float) y = Pervasives.compare x y
 
+(*$T
+  bool_ true false > 0
+  bool_ false true < 0
+  bool_ true true = 0
+  bool_ false false = 0
+*)
+
 (** {2 Lexicographic Combination} *)
 
 let (<?>) c (ord,x,y) =

src/core/CCOrd.mli

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Comparisons} *)
 

src/core/CCPair.ml

@@ -1,32 +1,12 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Tuple Functions} *)
 
 type ('a,'b) t = ('a * 'b)
 
+let make x y = x,y
+
 let map1 f (x,y) = f x,y
 
 let map2 f (x,y) = x,f y

src/core/CCPair.mli

@@ -1,32 +1,14 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Tuple Functions} *)
 
 type ('a,'b) t = ('a * 'b)
 
+val make : 'a -> 'b -> ('a, 'b) t
+(** Make a tuple from its components
+    @since 0.16 *)
+
 val map1 : ('a -> 'b) -> ('a * 'c) -> ('b * 'c)
 
 val map2 : ('a -> 'b) -> ('c * 'a) -> ('c * 'b)

src/core/CCPrint.ml

@@ -1,27 +1,5 @@
-(*
-copyright (c) 2013, 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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Printer Combinators}
 

src/core/CCPrint.mli

@@ -1,27 +1,5 @@
-(*
-copyright (c) 2013, 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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Printer Combinators}
 

src/core/CCRandom.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Random Generators} *)
 
@@ -59,6 +37,24 @@ let choose_exn l =
 
 let choose_return l = _choose_array (Array.of_list l)
 
+exception Pick_from_empty
+
+let pick_list l =
+  let n = List.length l in
+  if n=0 then raise Pick_from_empty;
+  fun st ->
+    List.nth l (Random.State.int st n)
+
+(*$Q
+  Q.(list small_int) (fun l -> \
+    l=[] || List.mem (run (pick_list l)) l)
+*)
+
+let pick_array a =
+  let n = Array.length a in
+  if n=0 then raise Pick_from_empty;
+  fun st -> Array.get a (Random.State.int st n)
+
 let int i st = Random.State.int st i
 
 let small_int = int 100

src/core/CCRandom.mli

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Random Generators} *)
 
@@ -56,8 +34,7 @@ val delay : (unit -> 'a t) -> 'a t
       small_int >>= fun i -> return (name,i)
     )
     ]}
-    @since 0.4
-*)
+    @since 0.4 *)
 
 val choose : 'a t list -> 'a option t
 (** Choose a generator within the list. *)
@@ -81,13 +58,25 @@ val sample_without_replacement:
 (** [sample_without_replacement n g] makes a list of [n] elements which are all
     generated randomly using [g] with the added constraint that none of the generated
     random values are equal
-    @since 0.15
- *)
+    @since 0.15 *)
 
 val list_seq : 'a t list -> 'a list t
 (** Build random lists from lists of random generators
     @since 0.4 *)
 
+exception Pick_from_empty
+(** @since 0.16 *)
+
+val pick_list : 'a list -> 'a t
+(** Pick an element at random from the list
+    @raise Pick_from_empty if the list is empty
+    @since 0.16 *)
+
+val pick_array : 'a array -> 'a t
+(** Pick an element at random from the array
+    @raise Pick_from_empty if the array is empty
+    @since 0.16 *)
+
 val small_int : int t
 
 val int : int -> int t

src/core/CCRef.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 References}
 

src/core/CCRef.mli

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 References}
 @since 0.9 *)

src/core/CCResult.ml

@@ -0,0 +1,256 @@
+
+(* This file is free software, part of containers. See file "license" for more details. *)
+
+(** {1 Error Monad} *)
+
+type 'a sequence = ('a -> unit) -> unit
+type 'a equal = 'a -> 'a -> bool
+type 'a ord = 'a -> 'a -> int
+type 'a printer = Buffer.t -> 'a -> unit
+type 'a formatter = Format.formatter -> 'a -> unit
+
+(** {2 Basics} *)
+
+type (+'good, +'bad) t = ('good, 'bad) Result.result =
+  | Ok of 'good
+  | Error of 'bad
+
+let return x = Ok x
+
+let fail s = Error s
+
+let fail_printf format =
+  let buf = Buffer.create 64 in
+  Printf.kbprintf
+    (fun buf -> fail (Buffer.contents buf))
+    buf format
+
+let fail_fprintf format =
+  let buf = Buffer.create 64 in
+  let out = Format.formatter_of_buffer buf in
+  Format.kfprintf
+    (fun out -> Format.pp_print_flush out (); fail (Buffer.contents buf))
+    out format
+
+let of_exn e =
+  let msg = Printexc.to_string e in
+  Error msg
+
+let of_exn_trace e =
+  let res = Printf.sprintf "%s\n%s"
+    (Printexc.to_string e) (Printexc.get_backtrace ())
+  in
+  Error res
+
+let map f e = match e with
+  | Ok x -> Ok (f x)
+  | Error s -> Error s
+
+let map_err f e = match e with
+  | Ok _ as res -> res
+  | Error y -> Error (f y)
+
+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 _ -> ()
+
+exception Get_error
+
+let get_exn = function
+  | Ok x -> x
+  | Error _ -> raise Get_error
+
+let get_or e ~default = match e with
+  | Ok x -> x
+  | Error _ -> default
+
+let map_or f e ~default = match e with
+  | Ok x -> f x
+  | Error _ -> default
+
+let catch e ~ok ~err = match e with
+  | Ok x -> ok x
+  | Error y -> err y
+
+let flat_map f e = match e with
+  | Ok x -> f x
+  | Error s -> Error s
+
+let (>|=) e f = map f e
+
+let (>>=) e f = flat_map f e
+
+let equal ?(err=Pervasives.(=)) eq a b = match a, b with
+  | Ok x, Ok y -> eq x y
+  | Error s, Error s' -> err s s'
+  | _ -> false
+
+let compare ?(err=Pervasives.compare) cmp a b = match a, b with
+  | Ok x, Ok y -> cmp x y
+  | Ok _, _  -> 1
+  | _, Ok _ -> -1
+  | Error s, Error s' -> err s s'
+
+let fold ~ok ~error x = match x with
+  | Ok x -> ok x
+  | Error s -> error s
+
+(** {2 Wrappers} *)
+
+let guard f =
+  try Ok (f ())
+  with e -> Error e
+
+let guard_str f =
+  try Ok (f())
+  with e -> of_exn e
+
+let guard_str_trace f =
+  try Ok (f())
+  with e -> of_exn_trace e
+
+let wrap1 f x =
+  try return (f x)
+  with e -> Error e
+
+let wrap2 f x y =
+  try return (f x y)
+  with e -> Error e
+
+let wrap3 f x y z =
+  try return (f x y z)
+  with e -> Error e
+
+(** {2 Applicative} *)
+
+let pure = return
+
+let (<*>) f x = match f with
+  | Error s -> fail s
+  | Ok f -> map f x
+
+let join t = match t with
+  | Ok (Ok o) -> Ok o
+  | Ok (Error e) -> Error e
+  | (Error _) as e -> e
+
+let both x y = match x,y with
+   | Ok o, Ok o' -> Ok (o, o')
+   | Ok _, Error e -> Error e
+   | Error e, _  -> Error e
+
+(** {2 Collections} *)
+
+let map_l f l =
+  let rec map acc l = match l with
+  | [] -> Ok (List.rev acc)
+  | x::l' ->
+      match f x with
+      | Error s -> Error s
+      | Ok y -> map (y::acc) l'
+  in map [] l
+
+exception LocalExit
+
+let fold_seq f acc seq =
+  let err = ref None in
+  try
+    let acc = ref acc in
+    seq
+      (fun x -> match f !acc x with
+        | Error s -> err := Some s; raise LocalExit
+        | Ok y -> acc := y);
+    Ok !acc
+  with LocalExit ->
+    match !err with None -> assert false | Some s -> Error s
+
+let fold_l f acc l = fold_seq f acc (fun k -> List.iter k l)
+
+(** {2 Misc} *)
+
+let choose l =
+  let rec find_ = function
+    | [] -> raise Not_found
+    | ((Ok _) as res) :: _ -> res
+    | (Error _) :: l' -> find_ l'
+  in
+  try find_ l
+  with Not_found ->
+    let l' = List.map (function Error s -> s | Ok _ -> assert false) l in
+    Error l'
+
+let retry n f =
+  let rec retry n acc = match n with
+  | 0 -> fail (List.rev acc)
+  | _ ->
+      match f () with
+      | Ok _ as res -> res
+      | Error e -> retry (n-1) (e::acc)
+  in retry n []
+
+(** {2 Infix} *)
+
+module Infix = struct
+  let (>>=) = (>>=)
+  let (>|=) = (>|=)
+  let (<*>) = (<*>)
+end
+
+(** {2 Monadic Operations} *)
+
+module type MONAD = sig
+  type 'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+module Traverse(M : MONAD) = struct
+  let (>>=) = M.(>>=)
+
+  let map_m f e = match e with
+    | Error s -> M.return (Error s)
+    | Ok x -> f x >>= fun y -> M.return (Ok y)
+
+  let sequence_m m = map_m (fun x->x) m
+
+  let fold_m f acc e = match e with
+    | Error _ -> M.return acc
+    | Ok x -> f acc x >>= fun y -> M.return y
+
+  let retry_m n f =
+    let rec retry n acc = match n with
+    | 0 -> M.return (fail (List.rev acc))
+    | _ ->
+        f () >>= function
+        | Ok x -> M.return (Ok x)
+        | Error e -> retry (n-1) (e::acc)
+    in retry n []
+end
+
+(** {2 Conversions} *)
+
+let to_opt = function
+  | Ok x -> Some x
+  | Error _ -> None
+
+let of_opt = function
+  | None -> Error "of_opt"
+  | Some x -> Ok x
+
+let to_seq e k = match e with
+  | Ok x -> k x
+  | Error _ -> ()
+
+(** {2 IO} *)
+
+let pp pp_x buf e = match e with
+  | Ok x -> Printf.bprintf buf "ok(%a)" pp_x x
+  | Error s -> Printf.bprintf buf "error(%s)" s
+
+let print pp_x fmt e = match e with
+  | Ok x -> Format.fprintf fmt "@[ok(@,%a)@]" pp_x x
+  | Error s -> Format.fprintf fmt "@[error(@,%s)@]" s

src/core/CCResult.mli

@@ -0,0 +1,188 @@
+
+(* This file is free software, part of containers. See file "license" for more details. *)
+
+(** {1 Error Monad}
+
+    Uses the new "result" type from OCaml 4.03.
+
+    @since 0.16 *)
+
+type 'a sequence = ('a -> unit) -> unit
+type 'a equal = 'a -> 'a -> bool
+type 'a ord = 'a -> 'a -> int
+type 'a printer = Buffer.t -> 'a -> unit
+type 'a formatter = Format.formatter -> 'a -> unit
+
+(** {2 Basics} *)
+
+type (+'good, +'bad) t = ('good, 'bad) Result.result =
+  | Ok of 'good
+  | Error of 'bad
+
+val return : 'a -> ('a, 'err) t
+(** Successfully return a value *)
+
+val fail : 'err -> ('a, 'err) t
+(** Fail with an error *)
+
+val of_exn : exn -> ('a, string) t
+(** [of_exn e] uses {!Printexc} to print the exception as a string *)
+
+val of_exn_trace : exn -> ('a, string) t
+(** [of_exn_trace e] is similar to [of_exn e], but it adds the stacktrace
+    to the error message.
+
+    Remember to call [Printexc.record_backtrace true] and compile with the
+    debug flag for this to work. *)
+
+val fail_printf : ('a, Buffer.t, unit, ('a, string) t) format4 -> 'a
+(** [fail_printf format] uses [format] to obtain an error message
+    and then returns [Error msg] *)
+
+val fail_fprintf : ('a, Format.formatter, unit, ('a, string) t) format4 -> 'a
+(** [fail_printf format] uses [format] to obtain an error message
+    and then returns [Error msg] *)
+
+val map : ('a -> 'b) -> ('a, 'err) t -> ('b, 'err) t
+(** Map on success *)
+
+val map_err : ('err1 -> 'err2) -> ('a, 'err1) t -> ('a, 'err2) t
+(** Map on the error variant *)
+
+val map2 : ('a -> 'b) -> ('err1 -> 'err2) -> ('a, 'err1) t -> ('b, 'err2) 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 *)
+
+exception Get_error
+
+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 Get_error if the value is an error. *)
+
+val get_or : ('a, _) t -> default:'a -> 'a
+(** [get_or e ~default] returns [x] if [e = Ok x], [default] otherwise *)
+
+val map_or : ('a -> 'b) ->  ('a, 'b) t -> default:'b -> 'b
+(** [map_or f e ~default] returns [f x] if [e = Ok x], [default] otherwise *)
+
+val catch : ('a, 'err) t -> ok:('a -> 'b) -> err:('err -> 'b) -> 'b
+(** [catch e ~ok ~err] calls either [ok] or [err] depending on
+    the value of [e]. *)
+
+val flat_map : ('a -> ('b, 'err) t) -> ('a, 'err) t -> ('b, 'err) t
+
+val (>|=) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t
+
+val (>>=) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t
+
+val equal : ?err:'err equal -> 'a equal -> ('a, 'err) t equal
+
+val compare : ?err:'err ord -> 'a ord -> ('a, 'err) t ord
+
+val fold : ok:('a -> 'b) -> error:('err -> 'b) -> ('a, 'err) t -> 'b
+(** [fold ~ok ~error e] opens [e] and, if [e = Ok x], returns
+    [ok x], otherwise [e = Error s] and it returns [error s]. *)
+
+(** {2 Wrappers} *)
+
+val guard : (unit -> 'a) -> ('a, exn) t
+(** [guard f] runs [f ()] and returns its result wrapped in [Ok]. If
+    [f ()] raises some exception [e], then it fails with [Error e] *)
+
+val guard_str : (unit -> 'a) -> ('a, string) t
+(** Same as {!guard} but uses {!of_exn} to print the exception. *)
+
+val guard_str_trace : (unit -> 'a) -> ('a, string) t
+(** Same as {!guard_str} but uses {!of_exn_trace} instead of {!of_exn} so
+    that the stack trace is printed. *)
+
+val wrap1 : ('a -> 'b) -> 'a -> ('b, exn) t
+(** Same as {!guard} but gives the function one argument. *)
+
+val wrap2 : ('a -> 'b -> 'c) -> 'a -> 'b -> ('c, exn) t
+(** Same as {!guard} but gives the function two arguments. *)
+
+val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> ('d, exn) t
+(** Same as {!guard} but gives the function three arguments. *)
+
+(** {2 Applicative} *)
+
+val pure : 'a -> ('a, 'err) t
+(** Synonym of {!return} *)
+
+val (<*>) : ('a -> 'b, 'err) t -> ('a, 'err) t -> ('b, 'err) t
+(** [a <*> b] evaluates [a] and [b], and, in case of success, returns
+    [Ok (a b)]. Otherwise, it fails, and the error of [a] is chosen
+    over the error of [b] if both fail. *)
+
+val join : (('a, 'err) t, 'err) t -> ('a, 'err) t
+(** [join t], in case of success, returns [Ok o] from [Ok (Ok o)]. Otherwise,
+    it fails with [Error e] where [e] is the unwrapped error of [t]. *)
+
+val both : ('a, 'err) t  -> ('b, 'err) t -> (('a * 'b), 'err) t
+(** [both a b], in case of success, returns [Ok (o, o')] with the ok values
+    of [a] and [b]. Otherwise, it fails, and the error of [a] is chosen over the
+    error of [b] if both fail. *)
+
+(** {2 Infix} *)
+
+module Infix : sig
+  val (>|=) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t
+  val (>>=) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t
+  val (<*>) : ('a -> 'b, 'err) t -> ('a, 'err) t -> ('b, 'err) t
+end
+
+(** {2 Collections} *)
+
+val map_l : ('a -> ('b, 'err) t) -> 'a list -> ('b list, 'err) t
+
+val fold_l : ('b -> 'a -> ('b, 'err) t) -> 'b -> 'a list -> ('b, 'err) t
+
+val fold_seq : ('b -> 'a -> ('b, 'err) t) -> 'b -> 'a sequence -> ('b, 'err) t
+
+(** {2 Misc} *)
+
+val choose : ('a, 'err) t list -> ('a, 'err list) t
+(** [choose l] selects a member of [l] that is a [Ok _] value,
+    or returns [Error l] otherwise, where [l] is the list of errors. *)
+
+val retry : int -> (unit -> ('a, 'err) t) -> ('a, 'err list) t
+(** [retry n f] calls [f] at most [n] times, returning the first result
+    of [f ()] that doesn't fail. If [f] fails [n] times, [retry n f] fails
+    with the list of successive errors. *)
+
+(** {2 Monadic Operations} *)
+module type MONAD = sig
+  type 'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+module Traverse(M : MONAD) : sig
+  val sequence_m : ('a M.t, 'err) t -> ('a, 'err) t M.t
+
+  val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> ('a, 'err) t -> 'b M.t
+
+  val map_m : ('a -> 'b M.t) -> ('a, 'err) t -> ('b, 'err) t M.t
+
+  val retry_m : int -> (unit -> ('a, 'err) t M.t) -> ('a, 'err list) t M.t
+end
+
+(** {2 Conversions} *)
+
+val to_opt : ('a, _) t -> 'a option
+
+val of_opt : 'a option -> ('a, string) t
+
+val to_seq : ('a, _) t -> 'a sequence
+
+(** {2 IO} *)
+
+val pp : 'a printer -> ('a, string) t printer
+
+val print : 'a formatter -> ('a, string) t formatter

src/core/CCSet.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Wrapper around Set} *)
 
@@ -46,11 +24,13 @@ module type S = sig
 
   val to_list : t -> elt list
 
-  val pp : ?start:string -> ?stop:string -> ?sep:string ->
-            elt printer -> t printer
+  val pp :
+    ?start:string -> ?stop:string -> ?sep:string ->
+    elt printer -> t printer
 
-  val print : ?start:string -> ?stop:string -> ?sep:string ->
-              elt formatter -> t formatter
+  val print :
+    ?start:string -> ?stop:string -> ?sep:string ->
+    elt formatter -> t formatter
 end
 
 module Make(O : Map.OrderedType) = struct
@@ -76,9 +56,9 @@ module Make(O : Map.OrderedType) = struct
     Buffer.add_string buf start;
     iter
       (fun x ->
-        if !first then first := false else Buffer.add_string buf sep;
-        pp_x buf x;
-      ) m;
+         if !first then first := false else Buffer.add_string buf sep;
+         pp_x buf x)
+      m;
     Buffer.add_string buf stop
 
   let print ?(start="[") ?(stop="]") ?(sep=", ") pp_x fmt m =
@@ -86,11 +66,12 @@ module Make(O : Map.OrderedType) = struct
     let first = ref true in
     iter
       (fun x ->
-        if !first then first := false else (
-          Format.pp_print_string fmt sep;
-          Format.pp_print_cut fmt ()
-        );
-        pp_x fmt x;
-      ) m;
+         if !first then first := false
+         else (
+           Format.pp_print_string fmt sep;
+           Format.pp_print_cut fmt ()
+         );
+         pp_x fmt x)
+      m;
     Format.pp_print_string fmt stop
 end

src/core/CCSet.mli

@@ -1,31 +1,9 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Wrapper around Set}
 
-@since 0.9 *)
+    @since 0.9 *)
 
 type 'a sequence = ('a -> unit) -> unit
 type 'a printer = Buffer.t -> 'a -> unit
@@ -48,13 +26,15 @@ module type S = sig
 
   val to_list : t -> elt list
 
-  val pp : ?start:string -> ?stop:string -> ?sep:string ->
-            elt printer -> t printer
+  val pp :
+    ?start:string -> ?stop:string -> ?sep:string ->
+    elt printer -> t printer
 
-  val print : ?start:string -> ?stop:string -> ?sep:string ->
-              elt formatter -> t formatter
+  val print :
+    ?start:string -> ?stop:string -> ?sep:string ->
+    elt formatter -> t formatter
 end
 
 module Make(O : Set.OrderedType) : S
   with type t = Set.Make(O).t
-  and type elt = O.t
+   and type elt = O.t

src/core/CCString.cppo.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Basic String Utils} *)
 
@@ -221,15 +199,19 @@ module Split = struct
   let seq ~by s = _mkseq ~by s _tuple3
   let seq_cpy ~by s = _mkseq ~by s String.sub
 
-  let left ~by s =
+  let left_exn ~by s =
     let i = find ~sub:by s in
-    if i = ~-1 then None
-    else Some (String.sub s 0 i, String.sub s (i+1) (String.length s - i - 1))
+    if i = ~-1 then raise Not_found
+    else String.sub s 0 i, String.sub s (i+1) (String.length s - i - 1)
 
-  let right ~by s =
+  let left ~by s = try Some (left_exn ~by s) with Not_found -> None
+
+  let right_exn ~by s =
     let i = rfind ~sub:by s in
-    if i = ~-1 then None
-    else Some (String.sub s 0 i, String.sub s (i+1) (String.length s - i - 1))
+    if i = ~-1 then raise Not_found
+    else String.sub s 0 i, String.sub s (i+1) (String.length s - i - 1)
+
+  let right ~by s = try Some (right_exn ~by s) with Not_found -> None
 end
 
 let compare_versions a b =

src/core/CCString.mli

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Basic String Utils}
 
@@ -321,6 +299,11 @@ module Split : sig
       the string
       @since 0.12 *)
 
+  val left_exn : by:string -> string -> string * string
+  (** Split on the first occurrence of [by] from the leftmost part of the string
+      @raise Not_found if [by] is not part of the string
+      @since 0.16 *)
+
   (*$T
     Split.left ~by:" " "ab cde f g " = Some ("ab", "cde f g ")
     Split.left ~by:"_" "abcde" = None
@@ -331,6 +314,11 @@ module Split : sig
       the string
       @since 0.12 *)
 
+  val right_exn : by:string -> string -> string * string
+  (** Split on the first occurrence of [by] from the rightmost part of the string
+      @raise Not_found if [by] is not part of the string
+      @since 0.16 *)
+
   (*$T
     Split.right ~by:" " "ab cde f g" = Some ("ab cde f", "g")
     Split.right ~by:"_" "abcde" = None

src/core/CCVector.ml

@@ -1,27 +1,5 @@
-(*
-Copyright (c) 2013, 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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Growable, mutable vector} *)
 

src/core/CCVector.mli

@@ -1,27 +1,5 @@
-(*
-Copyright (c) 2013, 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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Growable, mutable vector} *)
 

src/core/containers.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Drop-In replacement to Stdlib}
 

src/data/CCGraph.ml

@@ -56,6 +56,16 @@ type ('v, 'e) t = {
 
 type ('v, 'e) graph = ('v, 'e) t
 
+let make ~origin ~dest f = {origin; dest; children=f; }
+
+let make_labelled_tuple f =
+  make ~origin:(fun (x,_,_) -> x) ~dest:(fun (_,_,x) -> x)
+    (fun v yield -> f v (fun (l,v') -> yield (v,l,v')))
+
+let make_tuple f =
+  make ~origin:fst ~dest:snd
+    (fun v yield -> f v (fun v' -> yield (v,v')))
+
 (** Mutable bitset for values of type ['v] *)
 type 'v tag_set = {
   get_tag: 'v -> bool;
@@ -519,10 +529,11 @@ module Dot = struct
 
   let pp_list pp_x out l =
     Format.pp_print_string out "[";
-    List.iteri (fun i x ->
+    List.iteri
+      (fun i x ->
         if i > 0 then Format.fprintf out ",@;";
-        pp_x out x
-      ) l;
+        pp_x out x)
+      l;
     Format.pp_print_string out "]"
 
   type vertex_state = {
@@ -533,6 +544,7 @@ module Dot = struct
   (** Print an enum of Full.traverse_event *)
   let pp_seq
       ?(tbl=mk_table 128)
+      ?(eq=(=))
       ?(attrs_v=fun _ -> [])
       ?(attrs_e=fun _ -> [])
       ?(name="graph")
@@ -570,18 +582,18 @@ module Dot = struct
       get_tag=vertex_explored;
       set_tag=set_explored; (* allocate new ID *)
     } in
-    let events = Traverse.Event.dfs_tag ~tags ~graph seq in
+    let events = Traverse.Event.dfs_tag ~eq ~tags ~graph seq in
     Seq.iter
       (function
         | `Enter (v, _n, _path) ->
           let attrs = attrs_v v in
-          Format.fprintf out "  @[<h>%a %a;@]@." pp_vertex v (pp_list pp_attr) attrs
+          Format.fprintf out "@[<h>%a %a;@]@," pp_vertex v (pp_list pp_attr) attrs
         | `Exit _ -> ()
         | `Edge (e, _) ->
           let v1 = graph.origin e in
           let v2 = graph.dest e in
           let attrs = attrs_e e in
-          Format.fprintf out "  @[<h>%a -> %a %a;@]@."
+          Format.fprintf out "@[<h>%a -> %a %a;@]@,"
             pp_vertex v1 pp_vertex v2
             (pp_list pp_attr)
             attrs
@@ -590,8 +602,8 @@ module Dot = struct
     Format.fprintf out "}@]@;@?";
     ()
 
-  let pp ?tbl ?attrs_v ?attrs_e ?name ~graph fmt v =
-    pp_seq ?tbl ?attrs_v ?attrs_e ?name ~graph fmt (Seq.return v)
+  let pp ?tbl ?eq ?attrs_v ?attrs_e ?name ~graph fmt v =
+    pp_seq ?tbl ?eq ?attrs_v ?attrs_e ?name ~graph fmt (Seq.return v)
 
   let with_out filename f =
     let oc = open_out filename in

src/data/CCGraph.mli

@@ -76,6 +76,23 @@ type ('v, 'e) t = {
 
 type ('v, 'e) graph = ('v, 'e) t
 
+val make :
+  origin:('e -> 'v) ->
+  dest:('e -> 'v) ->
+  ('v -> 'e sequence) -> ('v, 'e) t
+(** Make a graph by providing its fields
+    @since 0.16 *)
+
+val make_labelled_tuple :
+  ('v -> ('a * 'v) sequence) -> ('v, ('v * 'a * 'v)) t
+(** Make a graph with edges being triples [(origin,label,dest)]
+    @since 0.16 *)
+
+val make_tuple :
+  ('v -> 'v sequence) -> ('v, ('v * 'v)) t
+(** Make a graph with edges being pairs [(origin,dest)]
+    @since 0.16 *)
+
 (** Mutable tags from values of type ['v] to tags of type [bool] *)
 type 'v tag_set = {
   get_tag: 'v -> bool;
@@ -307,6 +324,7 @@ module Dot : sig
   (** Hidden state associated to a vertex *)
 
   val pp : ?tbl:('v,vertex_state) table ->
+           ?eq:('v -> 'v -> bool) ->
            ?attrs_v:('v -> attribute list) ->
            ?attrs_e:('e -> attribute list) ->
            ?name:string ->
@@ -320,6 +338,7 @@ module Dot : sig
       @param name name of the graph *)
 
   val pp_seq : ?tbl:('v,vertex_state) table ->
+               ?eq:('v -> 'v -> bool) ->
                ?attrs_v:('v -> attribute list) ->
                ?attrs_e:('e -> attribute list) ->
                ?name:string ->

src/data/CCMixmap.ml

@@ -1,30 +1,30 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Maps with Heterogeneous Values} *)
 
+(*$R
+  let module M = CCMixmap.Make(CCInt) in
+
+  let inj_int = CCMixmap.create_inj() in
+  let inj_str = CCMixmap.create_inj() in
+  let inj_list_int = CCMixmap.create_inj() in
+
+  let m =
+    M.empty
+    |> M.add ~inj:inj_int 1 1
+    |> M.add ~inj:inj_str 2 "2"
+    |> M.add ~inj:inj_list_int 3 [3;3;3]
+  in
+
+  assert_equal (M.get ~inj:inj_int 1 m) (Some 1) ;
+  assert_equal (M.get ~inj:inj_str 1 m) None ;
+  assert_equal (M.get ~inj:inj_str 2 m) (Some "2") ;
+  assert_equal (M.get ~inj:inj_int 2 m) None ;
+  assert_equal (M.get ~inj:inj_list_int 3 m) (Some [3;3;3]) ;
+  assert_equal (M.get ~inj:inj_str 3 m) None ;
+*)
+
 type 'b injection = {
   get : (unit -> unit) -> 'b option;
   set : 'b -> (unit -> unit);
@@ -50,14 +50,14 @@ module type S = sig
   val empty : t
   (** Empty map *)
 
-  val get : inj:'a injection -> t  -> key -> 'a option
+  val get : inj:'a injection -> key -> t -> 'a option
   (** Get the value corresponding to this key, if it exists and
       belongs to the same key *)
 
-  val add : inj:'a injection -> t -> key -> 'a -> t
+  val add : inj:'a injection -> key -> 'a -> t -> t
   (** Bind the key to the value, using [inj] *)
 
-  val find : inj:'a injection -> t -> key -> 'a
+  val find : inj:'a injection -> key -> t -> 'a
   (** Find the value for the given key, which must be of the right type.
       @raise Not_found if either the key is not found, or if its value
         doesn't belong to the right type *)
@@ -65,10 +65,10 @@ module type S = sig
   val cardinal : t -> int
   (** Number of bindings *)
 
-  val remove : t -> key -> t
+  val remove : key -> t -> t
   (** Remove the binding for this key *)
 
-  val mem : inj:_ injection-> t -> key -> bool
+  val mem : inj:_ injection-> key -> t -> bool
   (** Is the given key in the map, with the right type? *)
 
   val iter_keys : f:(key -> unit) -> t -> unit
@@ -107,23 +107,23 @@ module Make(X : ORD) : S with type key = X.t = struct
 
   let empty = M.empty
 
-  let find ~inj map x =
+  let find ~inj x map =
     match inj.get (M.find x map) with
       | None -> raise Not_found
       | Some v -> v
 
-  let get ~inj map x =
+  let get ~inj x map =
     try inj.get (M.find x map)
     with Not_found -> None
 
-  let add ~inj map x y =
+  let add ~inj x y map =
     M.add x (inj.set y) map
 
   let cardinal = M.cardinal
 
-  let remove map x = M.remove x map
+  let remove = M.remove
 
-  let mem ~inj map x =
+  let mem ~inj x map =
     try
       inj.get (M.find x map) <> None
     with Not_found -> false

src/data/CCMixmap.mli

@@ -1,33 +1,34 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Maps with Heterogeneous Values}
 
-{b status: experimental}
+    {b status: experimental}
 
-@since 0.9 *)
+    {[
+      module M = CCMixmap.Make(CCInt)
+
+      let inj_int = CCMixmap.create_inj()
+      let inj_str = CCMixmap.create_inj()
+      let inj_list_int = CCMixmap.create_inj()
+
+      let m =
+        M.empty
+        |> M.add ~inj:inj_int 1 1
+        |> M.add ~inj:inj_str 2 "2"
+        |> M.add ~inj:inj_list_int 3 [3;3;3]
+
+      assert (M.get ~inj:inj_int 1 m = Some 1)
+      assert (M.get ~inj:inj_str 1 m = None)
+      assert (M.get ~inj:inj_str 2 m = Some "2")
+      assert (M.get ~inj:inj_int 2 m = None)
+      assert (M.get ~inj:inj_list_int 3 m = Some [3;3;3])
+      assert (M.get ~inj:inj_str 3 m = None)
+    ]}
+
+    @since 0.9
+    @since 0.16 change of API, the map is last argument to
+      make piping with [|>] easier. *)
 
 type 'a injection
 (** An accessor for values of type 'a in any map. Values put
@@ -50,14 +51,14 @@ module type S = sig
   val empty : t
   (** Empty map *)
 
-  val get : inj:'a injection -> t  -> key -> 'a option
+  val get : inj:'a injection -> key -> t -> 'a option
   (** Get the value corresponding to this key, if it exists and
       belongs to the same key *)
 
-  val add : inj:'a injection -> t -> key -> 'a -> t
+  val add : inj:'a injection -> key -> 'a -> t -> t
   (** Bind the key to the value, using [inj] *)
 
-  val find : inj:'a injection -> t -> key -> 'a
+  val find : inj:'a injection -> key -> t -> 'a
   (** Find the value for the given key, which must be of the right type.
       @raise Not_found if either the key is not found, or if its value
         doesn't belong to the right type *)
@@ -65,10 +66,10 @@ module type S = sig
   val cardinal : t -> int
   (** Number of bindings *)
 
-  val remove : t -> key -> t
+  val remove : key -> t -> t
   (** Remove the binding for this key *)
 
-  val mem : inj:_ injection-> t -> key -> bool
+  val mem : inj:_ injection-> key -> t -> bool
   (** Is the given key in the map, with the right type? *)
 
   val iter_keys : f:(key -> unit) -> t -> unit

src/data/CCMixset.ml

@@ -1,27 +1,5 @@
-(*
-copyright (c) 2013-2015, 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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Set of Heterogeneous Values} *)
 

src/data/CCMixset.mli

@@ -1,27 +1,5 @@
-(*
-copyright (c) 2013-2015, 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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Set of Heterogeneous Values}
 

src/data/CCMixtbl.ml

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Hash Table with Heterogeneous Keys} *)
 

src/data/CCMixtbl.mli

@@ -1,27 +1,5 @@
-(*
-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.
-*)
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Hash Table with Heterogeneous Keys}
 

src/sexp/CCSexpM.mli

@@ -86,9 +86,10 @@ module MakeDecode(M : MONAD) : sig
       long enough or isn't a proper S-expression *)
 end
 
-module ID_MONAD : MONAD
+module ID_MONAD : MONAD with type 'a t = 'a
 (** The monad that just uses blocking calls as bind
-    @since 0.14 *)
+    @since 0.14
+    ['a t = 'a] contraint is @since 0.16 *)
 
 module D : module type of MakeDecode(ID_MONAD)
 (** Decoder that just blocks when input is not available

src/threads/CCBlockingQueue.ml

@@ -0,0 +1,191 @@
+
+(* This file is free software, part of containers. See file "license" for more details. *)
+
+(** {1 Blocking Queue} *)
+
+type 'a t = {
+  q : 'a Queue.t;
+  lock : Mutex.t;
+  cond : Condition.t;
+  capacity : int;
+  mutable size : int;
+}
+
+let create n =
+  if n < 1 then invalid_arg "BloquingQueue.create";
+  let q = {
+    q=Queue.create();
+    lock=Mutex.create();
+    cond=Condition.create();
+    capacity=n;
+    size=0;
+  } in
+  q
+
+let incr_size_ q = assert(q.size < q.capacity); q.size <- q.size + 1
+let decr_size_ q = assert(q.size > 0); q.size <- q.size - 1
+
+let finally_ f x ~h =
+  try
+    let res = f x in
+    ignore (h ());
+    res
+  with e ->
+    ignore (h());
+    raise e
+
+let with_lock_ q f =
+  Mutex.lock q.lock;
+  finally_ f () ~h:(fun () -> Mutex.unlock q.lock)
+
+let push q x =
+  with_lock_ q
+    (fun () ->
+      while q.size = q.capacity do
+        Condition.wait q.cond q.lock
+      done;
+      assert (q.size < q.capacity);
+      Queue.push x q.q;
+      (* if there are blocked receivers, awake one of them *)
+      incr_size_ q;
+      Condition.broadcast q.cond)
+
+let take q =
+  with_lock_ q
+    (fun () ->
+      while q.size = 0 do
+        Condition.wait q.cond q.lock
+      done;
+      let x = Queue.take q.q in
+      (* if there are blocked senders, awake one of them *)
+      decr_size_ q;
+      Condition.broadcast q.cond;
+      x)
+
+(*$R
+  let q = create 1 in
+  let t1 = CCThread.spawn (fun () -> push q 1; push q 2) in
+  let t2 = CCThread.spawn (fun () -> push q 3; push q 4) in
+  let l = CCLock.create [] in
+  let t3 = CCThread.spawn (fun () -> for i = 1 to 4 do
+      let x = take q in
+      CCLock.update l (fun l -> x :: l)
+    done)
+  in
+  Thread.join t1; Thread.join t2; Thread.join t3;
+  assert_equal [1;2;3;4] (List.sort Pervasives.compare (CCLock.get l))
+*)
+
+let push_list q l =
+  (* push elements until it's not possible.
+     Assumes the lock is acquired. *)
+  let rec push_ q l = match l with
+    | [] -> l
+    | _::_ when q.size = q.capacity -> l (* no room remaining *)
+    | x :: tl ->
+        Queue.push x q.q;
+        incr_size_ q;
+        push_ q tl
+  in
+  (* push chunks of [l] in [q] until [l] is empty *)
+  let rec aux q l = match l with
+  | [] -> ()
+  | _::_ ->
+      let l = with_lock_ q
+        (fun () ->
+          while q.size = q.capacity do
+            Condition.wait q.cond q.lock
+          done;
+          let l = push_ q l in
+          Condition.broadcast q.cond;
+          l)
+      in
+      aux q l
+  in aux q l
+
+let take_list q n =
+  (* take at most [n] elements of [q] and prepend them to [acc] *)
+  let rec pop_ acc q n =
+    if n=0 || Queue.is_empty q.q then acc, n
+    else ( (* take next element *)
+      let x = Queue.take q.q in
+      decr_size_ q;
+      pop_ (x::acc) q (n-1)
+    )
+  in
+  (* call [pop_] until [n] elements have been gathered *)
+  let rec aux acc q n =
+    if n=0 then List.rev acc
+    else
+      let acc, n = with_lock_ q
+        (fun () ->
+          while q.size = 0 do
+            Condition.wait q.cond q.lock
+          done;
+          let acc, n = pop_ acc q n in
+          Condition.broadcast q.cond;
+          acc, n
+        )
+      in
+      aux acc q n
+  in
+  aux [] q n
+
+(*$R
+  let n = 1000 in
+  let lists = [| CCList.(1 -- n) ; CCList.(n+1 -- 2*n); CCList.(2*n+1 -- 3*n) |] in
+  let q = create 2 in
+  let senders = CCThread.Arr.spawn 3
+    (fun i ->
+      if i=1
+      then push_list q lists.(i)  (* test push_list *)
+      else List.iter (push q) lists.(i)
+    )
+  in
+  let res = CCLock.create [] in
+  let receivers = CCThread.Arr.spawn 3
+    (fun i ->
+      if i=1 then
+        let l = take_list q n in
+        CCLock.update res (fun acc -> l @ acc)
+      else
+        for _j = 1 to n do
+          let x = take q in
+          CCLock.update res (fun acc -> x::acc)
+        done
+    )
+  in
+  CCThread.Arr.join senders; CCThread.Arr.join receivers;
+  let l = CCLock.get res |> List.sort Pervasives.compare in
+  assert_equal CCList.(1 -- 3*n) l
+*)
+
+let try_take q =
+  with_lock_ q
+    (fun () ->
+      if q.size = 0 then None
+      else (
+        decr_size_ q;
+        Some (Queue.take q.q)
+      ))
+
+let try_push q x =
+  with_lock_ q
+    (fun () ->
+      if q.size = q.capacity then false
+      else (
+        incr_size_ q;
+        Queue.push x q.q;
+        Condition.signal q.cond;
+        true
+      ))
+
+let peek q =
+  with_lock_ q
+    (fun () ->
+      try Some (Queue.peek q.q)
+      with Queue.Empty -> None)
+
+let size q = with_lock_ q (fun () -> q.size)
+
+let capacity q = q.capacity

src/threads/CCBlockingQueue.mli

@@ -0,0 +1,50 @@
+
+(* This file is free software, part of containers. See file "license" for more details. *)
+
+(** {1 Blocking Queue}
+
+    This queue has a limited size. Pushing a value on the queue when it
+    is full will block.
+
+    @since 0.16 *)
+
+type 'a t
+(** Safe-thread queue for values of type ['a] *)
+
+val create : int -> 'a t
+(** Create a new queue of size [n]. Using [n=max_int] amounts to using
+    an infinite queue (2^61 items is a lot to fit in memory); using [n=1]
+    amounts to using a box with 0 or 1 elements inside.
+    @raise Invalid_argument if [n < 1] *)
+
+val push : 'a t -> 'a -> unit
+(** [push q x] pushes [x] into [q], blocking if the queue is full *)
+
+val take : 'a t -> 'a
+(** Take the first element, blocking if needed *)
+
+val push_list : 'a t -> 'a list -> unit
+(** Push items of the list, one by one *)
+
+val take_list : 'a t -> int -> 'a list
+(** [take_list n q] takes [n] elements out of [q] *)
+
+val try_take : 'a t -> 'a option
+(** Take the first element if the queue is not empty, return [None]
+    otherwise *)
+
+val try_push : 'a t -> 'a -> bool
+(** [try_push q x] pushes [x] into [q] if [q] is not full, in which
+    case it returns [true].
+    If it fails because [q] is full, it returns [false] *)
+
+val peek : 'a t -> 'a option
+(** [peek q] returns [Some x] if [x] is the first element of [q],
+    otherwise it returns [None] *)
+
+val size : _ t -> int
+(** Number of elements currently in the queue *)
+
+val capacity : _ t -> int
+(** Number of values the queue can hold *)
+

src/threads/CCFuture.ml

@@ -1,617 +0,0 @@
-(*
-Copyright (c) 2013, 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 Futures for concurrency} *)
-
-type 'a state =
-  | Done of 'a
-  | Waiting
-  | Failed of exn
-
-(** {2 Thread pool} *)
-module Pool = struct
-  type job =
-    | Job : ('a -> unit) * 'a -> job
-
-  type t = {
-    mutable stop : bool;  (* indicate that threads should stop *)
-    mutex : Mutex.t;
-    jobs : job Queue.t;  (* waiting jobs *)
-    mutable cur_size : int;  (* total number of threads *)
-    max_size : int;
-  } (** Dynamic, growable thread pool *)
-
-  let with_lock_ t f =
-    Mutex.lock t.mutex;
-    try
-      let x = f t in
-      Mutex.unlock t.mutex;
-      x
-    with e ->
-      Mutex.unlock t.mutex;
-      raise e
-
-  type command =
-    | Process of job
-    | Die (* thread has no work to do *)
-
-  let die pool =
-    assert (pool.cur_size > 0);
-    pool.cur_size <- pool.cur_size - 1;
-    Die
-
-  (** Thread: entry point. They seek jobs in the queue *)
-  let rec serve pool =
-    match with_lock_ pool get_next with
-    | Die -> ()
-    | Process (Job (f, x)) ->
-        f x;
-        serve pool
-
-  (* thread: seek what to do next (including dying) *)
-  and get_next pool =
-    if pool.stop then die pool
-    else if Queue.is_empty pool.jobs then die pool
-    else (
-      let job = Queue.pop pool.jobs in
-      Process job
-    )
-
-  (** Create a pool with at most the given number of threads. [timeout]
-      is the time after which idle threads are killed. *)
-  let create ~max_size () =
-    let pool = {
-      stop = false;
-      cur_size = 0;
-      max_size;
-      jobs = Queue.create ();
-      mutex = Mutex.create ();
-    } in
-    pool
-
-  exception PoolStopped
-
-  let run_job pool job =
-    (* heuristic criterion for starting a new thread. We try to assess
-        whether there are many busy threads and many waiting tasks.
-        If there are many threads, it's less likely to start a new one *)
-    let should_start_thread p =
-      let num_q = Queue.length p.jobs in
-      let num_busy = p.cur_size in
-      let reached_max = p.cur_size = p.max_size in
-      num_q > 0 && not reached_max && (num_q > 2 * num_busy)
-    in
-    (* acquire lock and push job in queue *)
-    with_lock_ pool
-      (fun pool ->
-        if pool.stop then raise PoolStopped;
-        Queue.push job pool.jobs;
-        (* maybe start a thread *)
-        if should_start_thread pool then (
-          pool.cur_size <- pool.cur_size + 1;
-          ignore (Thread.create serve pool)
-        )
-      )
-
-  (* run the function on the argument in the given pool *)
-  let run pool f x = run_job pool (Job (f, x))
-
-  (* kill threads in the pool *)
-  let stop pool =
-    with_lock_ pool
-      (fun p ->
-        p.stop <- true;
-        Queue.clear p.jobs
-      )
-end
-
-(*$inject
-  open Infix
-*)
-
-let pool = Pool.create ~max_size:50 ()
-(** Default pool of threads, should be ok for most uses. *)
-
-(** {2 Futures} *)
-
-type 'a handler = 'a state -> unit
-
-(** A proper future, with a delayed computation *)
-type 'a cell = {
-  mutable state : 'a state;
-  mutable handlers : 'a handler list;   (* handlers *)
-  mutex : Mutex.t;
-  condition : Condition.t;
-}
-
-(** A future value of type 'a *)
-type 'a t =
-  | Return of 'a
-  | FailNow of exn
-  | Run of 'a cell
-
-type 'a future = 'a t
-
-(** {2 Basic Future functions} *)
-
-let return x = Return x
-
-let fail e = FailNow e
-
-let create_cell () = {
-  state = Waiting;
-  handlers = [];
-  mutex = Mutex.create ();
-  condition = Condition.create ();
-}
-
-let with_lock_ cell f =
-  Mutex.lock cell.mutex;
-  try
-    let x = f cell in
-    Mutex.unlock cell.mutex;
-    x
-  with e ->
-    Mutex.unlock cell.mutex;
-    raise e
-
-let set_done_ cell x =
-  with_lock_ cell
-    (fun cell -> match cell.state with
-    | Waiting ->  (* set state and signal *)
-        cell.state <- Done x;
-        Condition.broadcast cell.condition;
-        List.iter (fun f -> f cell.state) cell.handlers
-    | _ -> assert false
-    )
-
-let set_fail_ cell e =
-  with_lock_ cell
-    (fun cell -> match cell.state with
-    | Waiting ->
-        cell.state <- Failed e;
-        Condition.broadcast cell.condition;
-        List.iter (fun f -> f cell.state) cell.handlers
-    | _ -> assert false
-    )
-
-let run_and_set1 cell f x =
-  try
-    let y = f x in
-    set_done_ cell y
-  with e ->
-    set_fail_ cell e
-
-let run_and_set2 cell f x y =
-  try
-    let z = f x y in
-    set_done_ cell z
-  with e ->
-    set_fail_ cell e
-
-let make1 f x =
-  let cell = create_cell() in
-  Pool.run pool (run_and_set1 cell f) x;
-  Run cell
-
-let make f = make1 f ()
-
-(*$R
-  List.iter
-    (fun n ->
-      let l = Sequence.(1 -- n) |> Sequence.to_list in
-      let l = List.map (fun i ->
-        make
-          (fun () ->
-            Thread.delay 0.1;
-            1
-        )) l in
-      let l' = List.map get l in
-      OUnit.assert_equal n (List.fold_left (+) 0 l');
-    )
-    [ 10; 300 ]
-*)
-
-let make2 f x y =
-  let cell = create_cell() in
-  Pool.run pool (run_and_set2 cell f x) y;
-  Run cell
-
-let get = function
-  | Return x -> x
-  | FailNow e -> raise e
-  | Run cell ->
-      let rec get_cell cell = match cell.state with
-        | Waiting ->
-            Condition.wait cell.condition cell.mutex; (* wait *)
-            get_cell cell
-        | Done x -> Mutex.unlock cell.mutex; x
-        | Failed e -> Mutex.unlock cell.mutex; raise e
-      in
-      Mutex.lock cell.mutex;
-      get_cell cell
-
-let state = function
-  | Return x -> Done x
-  | FailNow e -> Failed e
-  | Run cell ->
-      with_lock_ cell (fun cell -> cell.state)
-
-let is_done = function
-  | Return _
-  | FailNow _ -> true
-  | Run cell ->
-      with_lock_ cell (fun c -> c.state <> Waiting)
-
-(** {2 Combinators *)
-
-let add_handler_ cell f =
-  with_lock_ cell
-    (fun cell -> match cell.state with
-      | Waiting -> cell.handlers <- f :: cell.handlers
-      | Done _ | Failed _ -> f cell.state
-    )
-
-let on_finish fut k = match fut with
-  | Return x -> k (Done x)
-  | FailNow e -> k (Failed e)
-  | Run cell -> add_handler_ cell k
-
-let on_success fut k =
-  on_finish fut
-    (function
-      | Done x -> k x
-      | _ -> ()
-    )
-
-let on_failure fut k =
-  on_finish fut
-    (function
-      | Failed e -> k e
-      | _ -> ()
-    )
-
-let map f fut = match fut with
-  | Return x -> make1 f x
-  | FailNow e -> FailNow e
-  | Run cell ->
-      let cell' = create_cell() in
-      add_handler_ cell
-        (function
-          | Done x -> run_and_set1 cell' f x
-          | Failed e -> set_fail_ cell' e
-          | Waiting -> assert false
-        );
-      Run cell'
-
-(*$R
-  let a = make (fun () -> 1) in
-  let b = map (fun x -> x+1) a in
-  let c = map (fun x -> x-1) b in
-  OUnit.assert_equal 1 (get c)
-*)
-
-let flat_map f fut = match fut with
-  | Return x -> f x
-  | FailNow e -> FailNow e
-  | Run cell ->
-      let cell' = create_cell() in
-      add_handler_ cell
-        (function
-          | Done x ->
-              let fut' = f x in
-              on_finish fut'
-                (function
-                  | Done y -> set_done_ cell' y
-                  | Failed e -> set_fail_ cell' e
-                  | Waiting -> assert false
-                )
-          | Failed e -> set_fail_ cell' e
-          | Waiting -> assert false
-        );
-      Run cell'
-
-let and_then fut f = flat_map (fun _ -> f ()) fut
-
-let sequence futures =
-  let n = List.length futures in
-  let state = CCLock.create (`WaitFor n) in
-  let results = Array.make n None in
-  let cell = create_cell() in
-  (* when all futures returned, collect results for future' *)
-  let send_result () =
-    let l = Array.map
-      (function
-        | None -> assert false
-        | Some x -> x
-      ) results
-    in
-    set_done_ cell (Array.to_list l)
-  in
-  (* wait for all to succeed or fail *)
-  List.iteri
-    (fun i fut ->
-      on_finish fut
-        (fun res ->
-          CCLock.update state
-            (fun st -> match res, st with
-            | Done _, `Failed -> st
-            | Done x, `WaitFor 1 -> results.(i) <- Some x; send_result (); `Done
-            | Done x, `WaitFor n -> results.(i) <- Some x; `WaitFor (n-1)
-            | Failed _, `Failed -> st
-            | Failed e, `WaitFor _ -> set_fail_ cell e; `Failed
-            | _, `Done -> assert false
-            | Waiting, _ -> assert false
-            )
-        )
-    ) futures;
-  Run cell
-
-(*$R
-  let l = CCList.(1 -- 10) in
-  let l' = l
-    |> List.map
-      (fun x -> make (fun () -> Thread.delay 0.2; x*10))
-    |> sequence
-    |> map (List.fold_left (+) 0)
-  in
-  let expected = List.fold_left (fun acc x -> acc + 10 * x) 0 l in
-  OUnit.assert_equal expected (get l')
-*)
-
-(*$R
-  let l = CCList.(1 -- 10) in
-  let l' = l
-    |> List.map
-      (fun x -> make (fun () -> Thread.delay 0.2; if x = 5 then raise Exit; x))
-    |> sequence
-    |> map (List.fold_left (+) 0)
-  in
-  OUnit.assert_raises Exit (fun () -> get l')
-*)
-
-let choose futures =
-  let cell = create_cell() in
-  let state = ref `Waiting in
-  (* add handlers to all futures *)
-  List.iter
-    (fun fut ->
-      on_finish fut
-        (fun res -> match res, !state with
-          | Done x, `Waiting -> state := `Done; set_done_ cell x
-          | Failed e, `Waiting -> state := `Done; set_fail_ cell e
-          | Waiting, _ -> assert false
-          | _, `Done -> ()
-        )
-    ) futures;
-  Run cell
-
-(** slurp the entire state of the file_descr into a string *)
-let slurp ic = CCIO.read_all_bytes ic
-
-let read_chan ic = make1 slurp ic
-
-type subprocess_res = <
-  errcode : int;
-  stdout : Bytes.t;
-  stderr : Bytes.t;
->
-
-(** Spawn a sub-process with the given command [cmd] (and possibly input);
-    returns a future containing (returncode, stdout, stderr) *)
-let spawn_process ?(stdin="") cmd : subprocess_res t =
-   make
-    (fun () ->
-      (* spawn subprocess *)
-      let out, inp, err = Unix.open_process_full cmd (Unix.environment ()) in
-      output_string inp stdin;
-      (* send stdin to command *)
-      flush inp;
-      close_out inp;
-      (* read output of process *)
-      let out' = slurp out in
-      let err' = slurp err in
-      (* wait for termination *)
-      let status = Unix.close_process_full (out,inp,err) in
-      (* get return code *)
-      let returncode = match status with
-        | Unix.WEXITED i -> i
-        | Unix.WSIGNALED i -> i
-        | Unix.WSTOPPED i -> i in
-      object
-        method errcode = returncode
-        method stdout = out'
-        method stderr = err'
-      end
-    )
-
-let sleep time = make (fun () -> Thread.delay time)
-
-(*$R
-  let start = Unix.gettimeofday () in
-  let pause = 0.2 and n = 10 in
-  let l = CCList.(1 -- n)
-    |> List.map (fun _ -> make (fun () -> Thread.delay pause))
-  in
-  List.iter get l;
-  let stop = Unix.gettimeofday () in
-  OUnit.assert_bool "some_parallelism" (stop -. start < float_of_int n *. pause);
-*)
-
-(** {2 Event timer} *)
-
-module Timer = struct
-  module TaskHeap = CCHeap.Make(struct
-    type t = (float * unit cell)
-    let leq (f1,_)(f2,_) = f1 <= f2
-  end)
-
-  type t = {
-    mutable stop : bool;
-    mutable thread : Thread.t option;  (* thread dedicated to the timer *)
-    mutable tasks : TaskHeap.t;
-    t_mutex : Mutex.t;
-    fifo_in : Unix.file_descr;
-    fifo_out : Unix.file_descr;
-  } (** A timer for events *)
-
-  let standby_wait = 10.    (* when no task is scheduled *)
-  let epsilon = 0.0001      (* accepted time diff for actions *)
-
-  let with_lock_ t f =
-    Mutex.lock t.t_mutex;
-    try
-      let x = f t in
-      Mutex.unlock t.t_mutex;
-      x
-    with e ->
-      Mutex.unlock t.t_mutex;
-      raise e
-
-  type command =
-    | Loop
-    | Wait of float
-
-  let pop_task_ t =
-    let tasks, _ = TaskHeap.take_exn t.tasks in
-    t.tasks <- tasks
-
-  (** Wait for next event, run it, and loop *)
-  let serve timer =
-    let buf = Bytes.make 1 '_' in
-    (* acquire lock, call [process_task] and do as it commands *)
-    let rec next () = match with_lock_ timer process_task with
-      | Loop -> next ()
-      | Wait delay -> wait delay
-    (* check next task *)
-    and process_task timer = match TaskHeap.find_min timer.tasks with
-      | None -> Wait standby_wait
-      | Some (time, cell) ->
-          let now = Unix.gettimeofday () in
-          if now +. epsilon > time then (
-            (* now! *)
-            pop_task_ timer;
-            set_done_ cell ();
-            Loop
-          ) else Wait (time -. now)
-    (* wait for [delay] seconds, or until something happens on fifo_in *)
-    and wait delay =
-      let read = Thread.wait_timed_read timer.fifo_in delay in
-      if read
-        then ignore (Unix.read timer.fifo_in buf 0 1);  (* remove char *)
-      next ()
-    in
-    next ()
-
-  (** A timer that runs in the given thread pool *)
-  let create () =
-    let fifo_in, fifo_out = Unix.pipe () in
-    let timer = {
-      stop = false;
-      thread = None;
-      tasks = TaskHeap.empty;
-      t_mutex = Mutex.create ();
-      fifo_in;
-      fifo_out;
-    } in
-    (* start a thread to process tasks *)
-    let t = Thread.create serve timer in
-    timer.thread <- Some t;
-    timer
-
-  let underscore_ = Bytes.make 1 '_'
-
-  (** [timerule_at s t act] will run [act] at the Unix echo [t] *)
-  let at timer time =
-    let now = Unix.gettimeofday () in
-    if now >= time
-    then return ()
-    else (
-      let cell = create_cell() in
-      with_lock_ timer
-        (fun timer ->
-          (* time of the next scheduled event *)
-          let next_time = match TaskHeap.find_min timer.tasks with
-            | None -> max_float
-            | Some (f, _) -> f
-          in
-          (* insert task *)
-          timer.tasks <- TaskHeap.insert (time, cell) timer.tasks;
-          (* see if the timer thread needs to be awaken earlier *)
-          if time < next_time
-            then ignore (Unix.single_write timer.fifo_out underscore_ 0 1)
-        );
-      Run cell
-    )
-
-  let after timer delay =
-    assert (delay >= 0.);
-    let now = Unix.gettimeofday () in
-    at timer (now +. delay)
-
-  (** Stop the given timer, cancelling pending tasks *)
-  let stop timer =
-    with_lock_ timer
-      (fun timer ->
-        if not timer.stop then (
-          timer.stop <- true;
-          (* empty heap of tasks *)
-          timer.tasks <- TaskHeap.empty;
-          (* kill the thread *)
-          match timer.thread with
-          | None -> ()
-          | Some t ->
-            Thread.kill t;
-            timer.thread <- None
-        )
-      )
-end
-
-(*$R
-  let timer = Timer.create () in
-  let n = CCLock.create 1 in
-  let getter = make (fun () -> Thread.delay 0.8; CCLock.get n) in
-  let _ =
-    Timer.after timer 0.6
-    >>= fun () -> CCLock.update n (fun x -> x+2); return()
-  in
-  let _ =
-    Timer.after timer 0.4
-    >>= fun () -> CCLock.update n (fun x -> x * 4); return()
-  in
-  OUnit.assert_equal 6 (get getter);
-*)
-
-module Infix = struct
-  let (>>=) x f = flat_map f x
-  let (>>) a f = and_then a f
-  let (>|=) a f = map f a
-end
-
-include Infix
-
-(** {2 Low Level } *)
-
-let stop_pool () = Pool.stop pool

src/threads/CCFuture.mli

@@ -1,148 +0,0 @@
-(*
-Copyright (c) 2013, 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 Futures for concurrency} *)
-
-type 'a state =
-  | Done of 'a
-  | Waiting
-  | Failed of exn
-
-type 'a t
-(** A future value of type 'a *)
-
-type 'a future = 'a t
-
-(** {2 Constructors} *)
-
-val return : 'a -> 'a t
-(** Future that is already computed *)
-
-val fail : exn -> 'a t
-(** Future that fails immediately *)
-
-val make : (unit -> 'a) -> 'a t
-(** Create a future, representing a value that will be computed by
-      the function. If the function raises, the future will fail. *)
-
-val make1 : ('a -> 'b) -> 'a -> 'b t
-val make2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t
-
-(** {2 Basics} *)
-
-val get : 'a t -> 'a
-(** Blocking get: wait for the future to be evaluated, and get the value,
-    or the exception that failed the future is returned.
-    raise e if the future failed with e *)
-
-val state : 'a t -> 'a state
-(** State of the future *)
-
-val is_done : 'a t -> bool
-(** Is the future evaluated (success/failure)? *)
-
-(** {2 Combinators} *)
-
-val on_success : 'a t -> ('a -> unit) -> unit
-(** Attach a handler to be called upon success *)
-
-val on_failure : _ t -> (exn -> unit) -> unit
-(** Attach a handler to be called upon failure *)
-
-val on_finish : 'a t -> ('a state -> unit) -> unit
-(** Attach a handler to be called when the future is evaluated *)
-
-val flat_map : ('a -> 'b t) -> 'a t -> 'b t
-(** Monadic combination of futures *)
-
-val and_then : 'a t -> (unit -> 'b t) -> 'b t
-(** Wait for the first future to succeed, then launch the second *)
-
-val sequence : 'a t list -> 'a list t
-(** Future that waits for all previous sequences to terminate. If any future
-    in the list fails, [sequence l] fails too. *)
-
-val choose : 'a t list -> 'a t
-(** Choose among those futures (the first to terminate). Behaves like
-    the first future that terminates, by failing if the future fails *)
-
-val map : ('a -> 'b) -> 'a t -> 'b t
-(** Maps the value inside the future. The function doesn't run in its
-    own task; if it can take time, use {!flat_map} *)
-
-(** {2 Helpers} *)
-
-val read_chan : in_channel -> Bytes.t t
-(** Read the whole channel *)
-
-type subprocess_res = <
-  errcode : int;
-  stdout : Bytes.t;
-  stderr : Bytes.t;
->
-
-val spawn_process : ?stdin:string -> string -> subprocess_res t
-(** Spawn a sub-process with the given command (and possibly input);
-      returns a future containing [(returncode, stdout, stderr)] *)
-
-val sleep : float -> unit t
-(** Future that returns with success in the given amount of seconds. Blocks
-    the thread! If you need to wait on many events, consider
-    using {!Timer} *)
-
-(** {2 Event timer} *)
-
-module Timer : sig
-  type t
-  (** A scheduler for events. It runs in its own thread. *)
-
-  val create : unit -> t
-  (** A new timer. *)
-
-  val after : t -> float -> unit future
-  (** Create a future that waits for the given number of seconds, then
-      awakens with [()] *)
-
-  val at : t -> float -> unit future
-  (** Create a future that evaluates to [()] at the given Unix timestamp *)
-
-  val stop : t -> unit
-  (** Stop the given timer, cancelling pending tasks *)
-end
-
-module Infix : sig
-  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
-  val (>>) : 'a t -> (unit -> 'b t) -> 'b t
-  val (>|=) : 'a t -> ('a -> 'b) -> 'b t
-end
-
-val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
-val (>>) : 'a t -> (unit -> 'b t) -> 'b t
-val (>|=) : 'a t -> ('a -> 'b) -> 'b t
-
-(** {2 Low level} *)
-
-val stop_pool : unit -> unit
-(** Stop the thread pool *)

src/threads/CCLock.ml

@@ -1,28 +1,5 @@
-(*
-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.
-*)
 
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Utils around Mutex} *)
 
@@ -80,11 +57,14 @@ let with_lock_as_ref l ~f =
   let test_it l =
     with_lock_as_ref l
       ~f:(fun r ->
-        let x = LockRef.get r in
-        LockRef.set r (x+10);
-        Thread.yield ();
-        let y = LockRef.get r in
-        LockRef.set r (y - 10);
+        (* increment and decrement *)
+        for j = 0 to 100 do
+          let x = LockRef.get r in
+          LockRef.set r (x+10);
+          if j mod 5=0 then Thread.yield ();
+          let y = LockRef.get r in
+          LockRef.set r (y - 10);
+        done
       )
   in
   for i = 1 to 100 do ignore (Thread.create test_it l) done;
@@ -101,6 +81,17 @@ let update l f =
   let l = create 5 in update l (fun x->x+1); get l = 6
   *)
 
+let update_map l f =
+  with_lock l
+    (fun x ->
+      let x', y = f x in
+      l.content <- x';
+      y)
+
+(*$T
+  let l = create 5 in update_map l (fun x->x+1, string_of_int x) = "5" && get l = 6
+  *)
+
 let get l =
   Mutex.lock l.mutex;
   let x = l.content in
@@ -117,9 +108,9 @@ let set l x =
   let l = create 0 in set l 4; set l 5; get l = 5
 *)
 
-let incr l = update l (fun x -> x+1)
+let incr l = update l Pervasives.succ
 
-let decr l = update l (fun x -> x-1)
+let decr l = update l Pervasives.pred
 
 
 (*$R
@@ -133,3 +124,53 @@ let decr l = update l (fun x -> x-1)
   let l = create 0 in incr l ; get l = 1
   let l = create 0 in decr l ; get l = ~-1
   *)
+
+let incr_then_get l =
+  Mutex.lock l.mutex;
+  l.content <- l.content + 1;
+  let x = l.content in
+  Mutex.unlock l.mutex;
+  x
+
+let get_then_incr l =
+  Mutex.lock l.mutex;
+  let x = l.content in
+  l.content <- l.content + 1;
+  Mutex.unlock l.mutex;
+  x
+
+let decr_then_get l =
+  Mutex.lock l.mutex;
+  l.content <- l.content - 1;
+  let x = l.content in
+  Mutex.unlock l.mutex;
+  x
+
+let get_then_decr l =
+  Mutex.lock l.mutex;
+  let x = l.content in
+  l.content <- l.content - 1;
+  Mutex.unlock l.mutex;
+  x
+
+(*$T
+  let l = create 0 in 1 = incr_then_get l && 1 = get l
+  let l = create 0 in 0 = get_then_incr l && 1 = get l
+  let l = create 10 in 9 = decr_then_get l && 9 = get l
+  let l = create 10 in 10 = get_then_decr l && 9 = get l
+*)
+
+let get_then_set l =
+  Mutex.lock l.mutex;
+  let x = l.content in
+  l.content <- true;
+  Mutex.unlock l.mutex;
+  x
+
+let get_then_clear l =
+  Mutex.lock l.mutex;
+  let x = l.content in
+  l.content <- false;
+  Mutex.unlock l.mutex;
+  x
+

src/threads/CCLock.mli

@@ -1,32 +1,11 @@
-(*
-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.
-*)
 
+(* This file is free software, part of containers. See file "license" for more details. *)
 
 (** {1 Utils around Mutex}
 
-@since 0.8 *)
+    A value wrapped into a Mutex, for more safety.
+
+    @since 0.8 *)
 
 type 'a t
 (** A value surrounded with a lock *)
@@ -60,6 +39,11 @@ val with_lock_as_ref : 'a t -> f:('a LockRef.t -> 'b) -> 'b
 val update : 'a t -> ('a -> 'a) -> unit
 (** [update l f] replaces the content [x] of [l] with [f x], atomically *)
 
+val update_map : 'a t -> ('a -> 'a * 'b) -> 'b
+(** [update_map l f] computes [x', y = f (get l)], then puts [x'] in [l]
+    and returns [y]
+    @since 0.16 *)
+
 val mutex : _ t -> Mutex.t
 (** Underlying mutex *)
 
@@ -77,3 +61,27 @@ val incr : int t -> unit
 val decr : int t -> unit
 (** Atomically decrement the value
     @since 0.13 *)
+
+val incr_then_get : int t -> int
+(** [incr_then_get x] increments [x], and return its new value
+    @since 0.16 *)
+
+val get_then_incr : int t -> int
+(** [get_then_incr x] increments [x], and return its previous value
+    @since 0.16 *)
+
+val decr_then_get : int t -> int
+(** [decr_then_get x] decrements [x], and return its new value
+    @since 0.16 *)
+
+val get_then_decr : int t -> int
+(** [get_then_decr x] decrements [x], and return its previous value
+    @since 0.16 *)
+
+val get_then_set : bool t -> bool
+(** [get_then_set b] sets [b] to [true], and return the old value
+    @since 0.16 *)
+
+val get_then_clear : bool t -> bool
+(** [get_then_clear b] sets [b] to [false], and return the old value
+    @since 0.16 *)

src/threads/CCPool.ml

@@ -0,0 +1,545 @@
+
+(* This file is free software, part of containers. See file "license" for more details. *)
+
+(** {1 Thread Pool, and Futures} *)
+
+type +'a state =
+  | Done of 'a
+  | Waiting
+  | Failed of exn
+
+module type PARAM = sig
+  val min_size : int
+  (** Minimum number of threads in the pool *)
+
+  val max_size : int
+  (** Maximum number of threads in the pool *)
+end
+
+exception Stopped
+
+(*$inject
+  module P = Make(struct let min_size = 0 let max_size = 30 end)
+  module Fut = P.Fut
+  open Fut.Infix
+*)
+
+(** {2 Thread pool} *)
+module Make(P : PARAM) = struct
+  type job =
+    | Job1 : ('a -> _) * 'a -> job
+    | Job2 : ('a -> 'b -> _) * 'a * 'b -> job
+    | Job3 : ('a -> 'b -> 'c -> _) * 'a * 'b * 'c -> job
+    | Job4 : ('a -> 'b -> 'c -> 'd -> _) * 'a * 'b * 'c * 'd -> job
+
+  type t = {
+    mutable stop : bool;  (* indicate that threads should stop *)
+    mutable exn_handler: (exn -> unit);
+    mutex : Mutex.t;
+    cond : Condition.t;
+    jobs : job Queue.t;  (* waiting jobs *)
+    mutable cur_size : int; (* total number of threads *)
+    mutable cur_idle : int; (* number of idle threads *)
+  } (** Dynamic, growable thread pool *)
+
+  let nop_ _ = ()
+
+  (* singleton pool *)
+  let pool = {
+    stop = false;
+    exn_handler = nop_;
+    cond = Condition.create();
+    cur_size = 0;
+    cur_idle = 0;
+    jobs = Queue.create ();
+    mutex = Mutex.create ();
+  }
+
+  let set_exn_handler f = pool.exn_handler <- f
+
+  let with_lock_ t f =
+    Mutex.lock t.mutex;
+    try
+      let x = f t in
+      Mutex.unlock t.mutex;
+      x
+    with e ->
+      Mutex.unlock t.mutex;
+      raise e
+
+  let incr_size_ p = p.cur_size <- p.cur_size + 1
+  let decr_size_ p = p.cur_size <- p.cur_size - 1
+
+  (* next thing a thread should do *)
+  type command =
+    | Process of job
+    | Wait (* wait on condition *)
+    | Die (* thread has no work to do *)
+
+  (* thread: seek what to do next (including dying).
+     Assumes the pool is locked. *)
+  let get_next_ pool =
+    if pool.stop
+    || (Queue.is_empty pool.jobs && pool.cur_size > P.min_size) then (
+      (* die: the thread would be idle otherwise  *)
+      assert (pool.cur_size > 0);
+      decr_size_ pool;
+      Die
+    )
+    else if Queue.is_empty pool.jobs then Wait
+    else (
+      let job = Queue.pop pool.jobs in
+      Process job
+    )
+
+  (* Thread: entry point. They seek jobs in the queue *)
+  let rec serve pool =
+    let cmd = with_lock_ pool get_next_ in
+    run_cmd cmd
+
+  (* run a command *)
+  and run_cmd = function
+    | Die -> ()
+    | Wait ->
+        with_lock_ pool (fun p -> Condition.wait p.cond p.mutex)
+    | Process (Job1 (f, x)) ->
+        begin try ignore (f x) with e -> pool.exn_handler e end; serve pool
+    | Process (Job2 (f, x, y)) ->
+        begin try ignore (f x y) with e -> pool.exn_handler e end; serve pool
+    | Process (Job3 (f, x, y, z)) ->
+        begin try ignore (f x y z) with e -> pool.exn_handler e end; serve pool
+    | Process (Job4 (f, x, y, z, w)) ->
+        begin try ignore (f x y z w) with e -> pool.exn_handler e end; serve pool
+
+  (* create a new worker thread *)
+  let launch_worker_ pool = ignore (Thread.create serve pool)
+
+  (* launch the minimum required number of threads *)
+  let () =
+    for _i = 1 to P.min_size do launch_worker_ pool done
+
+  (* heuristic criterion for starting a new thread. *)
+  let can_start_thread_ p = p.cur_size < P.max_size
+
+  let run_job job =
+    (* acquire lock and push job in queue, or start thread directly
+       if the queue is empty *)
+    with_lock_ pool
+      (fun pool ->
+        if pool.stop then raise Stopped;
+        if Queue.is_empty pool.jobs && can_start_thread_ pool && pool.cur_idle = 0
+        then (
+          (* create the thread now, on [job], as it will not break order of
+             jobs. We do not want to wait for the busy threads to do our task
+             if we are allowed to spawn a new thread. *)
+          incr_size_ pool;
+          ignore (Thread.create run_cmd (Process job))
+        ) else (
+          (* cannot start thread, push and wait for some worker to pick it up *)
+          Queue.push job pool.jobs;
+          Condition.signal pool.cond; (* wake up *)
+          (* might want to process in the background, if all threads are busy *)
+          if pool.cur_idle = 0 && can_start_thread_ pool then (
+            incr_size_ pool;
+            launch_worker_ pool;
+          )
+        ))
+
+  (* run the function on the argument in the given pool *)
+  let run1 f x = run_job (Job1 (f, x))
+
+  let run f = run1 f ()
+
+  let run2 f x y = run_job (Job2 (f, x, y))
+
+  let run3 f x y z = run_job (Job3 (f, x, y, z))
+
+  let run4 f x y z w = run_job (Job4 (f, x, y, z, w))
+
+  let active () = not pool.stop
+
+  (* kill threads in the pool *)
+  let stop () =
+    with_lock_ pool
+      (fun p ->
+        p.stop <- true;
+        Queue.clear p.jobs)
+
+  (* stop threads if pool is GC'd *)
+  let () = Gc.finalise (fun _ -> stop ()) pool
+
+  (** {6 Futures} *)
+  module Fut = struct
+    type 'a handler = 'a state -> unit
+
+    (** A proper future, with a delayed computation *)
+    type 'a cell = {
+      mutable state : 'a state;
+      mutable handlers : 'a handler list;   (* handlers *)
+      f_mutex : Mutex.t;
+      condition : Condition.t;
+    }
+
+    (** A future value of type 'a *)
+    type 'a t =
+      | Return of 'a
+      | FailNow of exn
+      | Run of 'a cell
+
+    type 'a future = 'a t
+
+    (** {2 Basic Future functions} *)
+
+    let return x = Return x
+
+    let fail e = FailNow e
+
+    let create_cell () = {
+      state = Waiting;
+      handlers = [];
+      f_mutex = Mutex.create ();
+      condition = Condition.create ();
+    }
+
+    let with_lock_ cell f =
+      Mutex.lock cell.f_mutex;
+      try
+        let x = f cell in
+        Mutex.unlock cell.f_mutex;
+        x
+      with e ->
+        Mutex.unlock cell.f_mutex;
+        raise e
+
+    (* TODO: exception handler for handler errors *)
+
+    let set_done_ cell x =
+      with_lock_ cell
+        (fun cell -> match cell.state with
+        | Waiting ->  (* set state and signal *)
+            cell.state <- Done x;
+            Condition.broadcast cell.condition;
+            List.iter
+              (fun f -> try f cell.state with e -> pool.exn_handler e)
+              cell.handlers
+        | _ -> assert false)
+
+    let set_fail_ cell e =
+      with_lock_ cell
+        (fun cell -> match cell.state with
+        | Waiting ->
+            cell.state <- Failed e;
+            Condition.broadcast cell.condition;
+            List.iter
+              (fun f -> try f cell.state with e -> pool.exn_handler e)
+              cell.handlers
+        | _ -> assert false)
+
+    (* calls [f x], and put result or exception in [cell] *)
+    let run_and_set1 cell f x =
+      try
+        let y = f x in
+        set_done_ cell y
+      with e ->
+        set_fail_ cell e
+
+    let run_and_set2 cell f x y =
+      try
+        let z = f x y in
+        set_done_ cell z
+      with e ->
+        set_fail_ cell e
+
+    let make1 f x =
+      let cell = create_cell() in
+      run3 run_and_set1 cell f x;
+      Run cell
+
+    let make f = make1 f ()
+
+    (*$R
+      List.iter
+        (fun n ->
+          let l = Sequence.(1 -- n) |> Sequence.to_list in
+          let l = List.rev_map (fun i ->
+            Fut.make
+              (fun () ->
+                Thread.delay 0.1;
+                1
+            )) l in
+          let l' = List.map Fut.get l in
+          OUnit.assert_equal n (List.fold_left (+) 0 l');
+        )
+        [ 10; 300; ]
+    *)
+
+    let make2 f x y =
+      let cell = create_cell() in
+      run4 run_and_set2 cell f x y;
+      Run cell
+
+    let get = function
+      | Return x -> x
+      | FailNow e -> raise e
+      | Run cell ->
+          let rec get_ cell = match cell.state with
+            | Waiting ->
+                Condition.wait cell.condition cell.f_mutex; (* wait *)
+                get_ cell
+            | Done x -> x
+            | Failed e -> raise e
+          in
+          with_lock_ cell get_
+
+    (* access the result without locking *)
+    let get_nolock_ = function
+      | Return x
+      | Run {state=Done x; _} -> x
+      | FailNow _
+      | Run {state=(Failed _ | Waiting); _} -> assert false
+
+    let state = function
+      | Return x -> Done x
+      | FailNow e -> Failed e
+      | Run cell ->
+          with_lock_ cell (fun cell -> cell.state)
+
+    let is_done = function
+      | Return _
+      | FailNow _ -> true
+      | Run cell ->
+          with_lock_ cell (fun c -> c.state <> Waiting)
+
+    (** {2 Combinators *)
+
+    let add_handler_ cell f =
+      with_lock_ cell
+        (fun cell -> match cell.state with
+          | Waiting -> cell.handlers <- f :: cell.handlers
+          | Done _ | Failed _ -> f cell.state)
+
+    let on_finish fut k = match fut with
+      | Return x -> k (Done x)
+      | FailNow e -> k (Failed e)
+      | Run cell -> add_handler_ cell k
+
+    let on_success fut k =
+      on_finish fut
+        (function
+          | Done x -> k x
+          | _ -> ())
+
+    let on_failure fut k =
+      on_finish fut
+        (function
+          | Failed e -> k e
+          | _ -> ())
+
+    let map_cell_ ~async f cell ~into:cell' =
+      add_handler_ cell
+        (function
+          | Done x ->
+              if async
+              then run3 run_and_set1 cell' f x
+              else run_and_set1 cell' f x
+          | Failed e -> set_fail_ cell' e
+          | Waiting -> assert false);
+      Run cell'
+
+    let map_ ~async f fut = match fut with
+      | Return x ->
+          if async
+          then make1 f x
+          else Return (f x)
+      | FailNow e -> FailNow e
+      | Run cell -> map_cell_ ~async f cell ~into:(create_cell())
+
+    let map f fut = map_ ~async:false f fut
+
+    let map_async f fut = map_ ~async:true f fut
+
+    (*$R
+      let a = Fut.make (fun () -> 1) in
+      let b = Fut.map (fun x -> x+1) a in
+      let c = Fut.map (fun x -> x-1) b in
+      OUnit.assert_equal 1 (Fut.get c)
+    *)
+
+    let app_ ~async f x = match f, x with
+      | Return f, Return x ->
+          if async
+          then make1 f x
+          else Return (f x)
+      | FailNow e, _
+      | _, FailNow e -> FailNow e
+      | Return f, Run x ->
+          map_cell_ ~async (fun x -> f x) x ~into:(create_cell())
+      | Run f, Return x ->
+          map_cell_ ~async (fun f -> f x) f ~into:(create_cell())
+      | Run f, Run x ->
+          let cell' = create_cell () in
+          add_handler_ f
+            (function
+              | Done f -> ignore (map_cell_ ~async f x ~into:cell')
+              | Failed e -> set_fail_ cell' e
+              | Waiting -> assert false);
+          Run cell'
+
+    let app f x = app_ ~async:false f x
+
+    let app_async f x = app_ ~async:true f x
+
+    let flat_map f fut = match fut with
+      | Return x -> f x
+      | FailNow e -> FailNow e
+      | Run cell ->
+          let cell' = create_cell() in
+          add_handler_ cell
+            (function
+              | Done x ->
+                  let fut' = f x in
+                  on_finish fut'
+                    (function
+                      | Done y -> set_done_ cell' y
+                      | Failed e -> set_fail_ cell' e
+                      | Waiting -> assert false
+                    )
+              | Failed e -> set_fail_ cell' e
+              | Waiting -> assert false
+            );
+          Run cell'
+
+    let and_then fut f = flat_map (fun _ -> f ()) fut
+
+    type _ array_or_list =
+      | A_ : 'a array -> 'a array_or_list
+      | L_ : 'a list -> 'a array_or_list
+
+    let iter_aol
+    : type a. a array_or_list -> (a -> unit) -> unit
+    = fun aol f -> match aol with
+      | A_ a -> Array.iter f a
+      | L_ l -> List.iter f l
+
+    (* [sequence_ l f] returns a future that waits for every element of [l]
+       to return of fail, and call [f ()] to obtain the result (as a closure)
+       in case every element succeeded (otherwise a failure is
+       returned automatically) *)
+    let sequence_
+    : type a res. a t array_or_list -> (unit -> res) -> res t
+    = fun aol f ->
+      let n = match aol with
+        | A_ a -> Array.length a
+        | L_ l -> List.length l
+      in
+      assert (n>0);
+      let cell = create_cell() in
+      let n_err = CCLock.create 0 in (* number of failed threads *)
+      let n_ok = CCLock.create 0 in (* number of succeeding threads *)
+      iter_aol aol
+        (fun fut ->
+          on_finish fut
+            (function
+              | Failed e ->
+                  let x = CCLock.incr_then_get n_err in
+                  (* if first failure, then seal [cell]'s fate now *)
+                  if x=1 then set_fail_ cell e
+              | Done _ ->
+                  let x = CCLock.incr_then_get n_ok in
+                  (* if [n] successes, then [cell] succeeds. Otherwise, some
+                     job has not finished or some job has failed. *)
+                  if x = n then (
+                    let res = f () in
+                    set_done_ cell res
+                  )
+              | Waiting -> assert false));
+      Run cell
+
+    (* map an array of futures to a future array *)
+    let sequence_a a = match a with
+    | [||] -> return [||]
+    | _ ->
+        sequence_ (A_ a)
+          (fun () -> Array.map get_nolock_ a)
+
+    let map_a f a = sequence_a (Array.map f a)
+
+    let sequence_l l = match l with
+    | [] -> return []
+    | _ :: _ ->
+        sequence_ (L_ l) (fun () -> List.map get_nolock_ l)
+
+    (* reverse twice *)
+    let map_l f l =
+      let l = List.rev_map f l in
+      sequence_ (L_ l)
+        (fun () -> List.rev_map get_nolock_ l)
+
+    (*$R
+      let l = CCList.(1 -- 50) in
+      let l' = l
+        |> List.map
+          (fun x -> Fut.make (fun () -> Thread.delay 0.1; x*10))
+        |> Fut.sequence_l
+        |> Fut.map (List.fold_left (+) 0)
+      in
+      let expected = List.fold_left (fun acc x -> acc + 10 * x) 0 l in
+      OUnit.assert_equal expected (Fut.get l')
+    *)
+
+    (*$R
+      let l = CCList.(1 -- 50) in
+      let l' = l
+        |> List.map
+          (fun x -> Fut.make (fun () -> Thread.delay 0.1; if x = 5 then raise Exit; x))
+        |> Fut.sequence_l
+        |> Fut.map (List.fold_left (+) 0)
+      in
+      OUnit.assert_raises Exit (fun () -> Fut.get l')
+    *)
+
+    let choose_
+    : type a. a t array_or_list -> a t
+    = fun aol ->
+      let cell = create_cell() in
+      let is_done = CCLock.create false in
+      iter_aol aol
+        (fun fut ->
+          on_finish fut
+            (fun res -> match res with
+              | Waiting -> assert false
+              | Done x ->
+                  let was_done = CCLock.get_then_clear is_done in
+                  if not was_done then set_done_ cell x
+              | Failed e ->
+                  let was_done = CCLock.get_then_clear is_done in
+                  if not was_done then set_fail_ cell e));
+      Run cell
+
+    let choose_a a = choose_ (A_ a)
+
+    let choose_l l = choose_ (L_ l)
+
+    let sleep time = make1 Thread.delay time
+
+    (*$R
+      let start = Unix.gettimeofday () in
+      let pause = 0.2 and n = 10 in
+      let l = CCList.(1 -- n)
+        |> List.map (fun _ -> Fut.make (fun () -> Thread.delay pause))
+      in
+      List.iter Fut.get l;
+      let stop = Unix.gettimeofday () in
+      OUnit.assert_bool "some_parallelism" (stop -. start < float_of_int n *. pause);
+    *)
+
+    module Infix = struct
+      let (>>=) x f = flat_map f x
+      let (>>) a f = and_then a f
+      let (>|=) a f = map f a
+      let (<*>) = app
+    end
+
+    include Infix
+  end
+end

src/threads/CCPool.mli

@@ -0,0 +1,167 @@
+
+(* This file is free software, part of containers. See file "license" for more details. *)
+
+(** {1 Thread Pool, and Futures}
+
+    Renamed and heavily updated from [CCFuture]
+    @since 0.16 *)
+
+type +'a state =
+  | Done of 'a
+  | Waiting
+  | Failed of exn
+
+module type PARAM = sig
+  val min_size : int
+  (** Minimum number of threads in the pool *)
+
+  val max_size : int
+  (** Maximum number of threads in the pool *)
+end
+
+exception Stopped
+
+(** {2 Create a new Pool} *)
+module Make(P : PARAM) : sig
+  val run : (unit -> _) -> unit
+  (** [run f] schedules [f] for being executed in the thread pool *)
+
+  val run1 : ('a -> _) -> 'a -> unit
+  (** [run1 f x] is similar to [run (fun () -> f x)] *)
+
+  val run2 : ('a -> 'b -> _) -> 'a -> 'b -> unit
+
+  val run3 : ('a -> 'b -> 'c -> _) -> 'a -> 'b -> 'c -> unit
+
+  val set_exn_handler : (exn -> unit) -> unit
+
+  val active : unit -> bool
+  (** [active ()] is true as long as [stop()] has not been called yet *)
+
+  val stop : unit -> unit
+  (** After calling [stop ()], Most functions will raise Stopped.
+      This has the effect of preventing new tasks from being executed. *)
+
+  (** {6 Futures}
+
+      The futures are registration points for callbacks, storing a {!state},
+      that are executed in the pool using {!run}. *)
+  module Fut : sig
+    type 'a t
+    (** A future value of type 'a *)
+
+    type 'a future = 'a t
+
+    (** {2 Constructors} *)
+
+    val return : 'a -> 'a t
+    (** Future that is already computed *)
+
+    val fail : exn -> 'a t
+    (** Future that fails immediately *)
+
+    val make : (unit -> 'a) -> 'a t
+    (** Create a future, representing a value that will be computed by
+          the function. If the function raises, the future will fail. *)
+
+    val make1 : ('a -> 'b) -> 'a -> 'b t
+
+    val make2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t
+
+    (** {2 Basics} *)
+
+    val get : 'a t -> 'a
+    (** Blocking get: wait for the future to be evaluated, and get the value,
+        or the exception that failed the future is returned.
+        raise e if the future failed with e *)
+
+    val state : 'a t -> 'a state
+    (** State of the future *)
+
+    val is_done : 'a t -> bool
+    (** Is the future evaluated (success/failure)? *)
+
+    (** {2 Combinators} *)
+
+    val on_success : 'a t -> ('a -> unit) -> unit
+    (** Attach a handler to be called upon success.
+        The handler should not call functions on the future.
+        Might be evaluated now if the future is already done. *)
+
+    val on_failure : _ t -> (exn -> unit) -> unit
+    (** Attach a handler to be called upon failure.
+        The handler should not call any function on the future.
+        Might be evaluated now if the future is already done. *)
+
+    val on_finish : 'a t -> ('a state -> unit) -> unit
+    (** Attach a handler to be called when the future is evaluated.
+        The handler should not call functions on the future.
+        Might be evaluated now if the future is already done. *)
+
+    val flat_map : ('a -> 'b t) -> 'a t -> 'b t
+    (** Monadic combination of futures *)
+
+    val and_then : 'a t -> (unit -> 'b t) -> 'b t
+    (** Wait for the first future to succeed, then launch the second *)
+
+    val sequence_a : 'a t array -> 'a array t
+    (** Future that waits for all previous futures to terminate. If any future
+        in the array fails, [sequence_a l] fails too. *)
+
+    val map_a : ('a -> 'b t) -> 'a array -> 'b array t
+    (** [map_l f a] maps [f] on every element of [a], and will return
+        the array of every result if all calls succeed, or an error otherwise. *)
+
+    val sequence_l : 'a t list -> 'a list t
+    (** Future that waits for all previous futures to terminate. If any future
+        in the list fails, [sequence_l l] fails too. *)
+
+    val map_l : ('a -> 'b t) -> 'a list -> 'b list t
+    (** [map_l f l] maps [f] on every element of [l], and will return
+        the list of every result if all calls succeed, or an error otherwise. *)
+
+    val choose_a : 'a t array -> 'a t
+    (** Choose among those futures (the first to terminate). Behaves like
+        the first future that terminates, by failing if the future fails *)
+
+    val choose_l : 'a t list -> 'a t
+    (** Choose among those futures (the first to terminate). Behaves like
+        the first future that terminates, by failing if the future fails *)
+
+    val map : ('a -> 'b) -> 'a t -> 'b t
+    (** Maps the value inside the future. The function doesn't run in its
+        own task; if it can take time, use {!flat_map} or {!map_async} *)
+
+    val map_async : ('a -> 'b) -> 'a t -> 'b t
+    (** Maps the value inside the future, to be computed in a separated job. *)
+
+    val app : ('a -> 'b) t -> 'a t -> 'b t
+    (** [app f x] applies the result of [f] to the result of [x] *)
+
+    val app_async : ('a -> 'b) t -> 'a t -> 'b t
+    (** [app f x] applies the result of [f] to the result of [x], in
+        a separated job scheduled in the pool *)
+
+    val sleep : float -> unit t
+    (** Future that returns with success in the given amount of seconds. Blocks
+        the thread! If you need to wait on many events, consider
+        using {!CCTimer}. *)
+
+    module Infix : sig
+      val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+      val (>>) : 'a t -> (unit -> 'b t) -> 'b t
+      val (>|=) : 'a t -> ('a -> 'b) -> 'b t
+      val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
+    end
+
+    val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+
+    val (>>) : 'a t -> (unit -> 'b t) -> 'b t
+
+    val (>|=) : 'a t -> ('a -> 'b) -> 'b t
+    (** Alias to {!map} *)
+
+    val (<*>): ('a -> 'b) t -> 'a t -> 'b t
+    (** Alias to {!app} *)
+  end
+end

src/threads/CCSemaphore.ml

@@ -6,11 +6,12 @@ type t = {
   cond : Condition.t;
 }
 
-let create n = {
-  n;
-  mutex=Mutex.create();
-  cond=Condition.create();
-}
+let create n =
+  if n <= 0 then invalid_arg "Semaphore.create";
+  { n;
+    mutex=Mutex.create();
+    cond=Condition.create();
+  }
 
 let get t = t.n
 

src/threads/CCSemaphore.mli

@@ -9,13 +9,13 @@ type t
 
 val create : int -> t
 (** [create n] creates a semaphore with initial value [n]
-    @raise Invalid_argument if [n < 0] *)
+    @raise Invalid_argument if [n <= 0] *)
 
 val get : t -> int
 (** Current value *)
 
 val acquire : int -> t -> unit
-(** [acquire n s] blocks until [get s > n], then atomically
+(** [acquire n s] blocks until [get s >= n], then atomically
     sets [s := !s - n] *)
 
 val release : int -> t -> unit

src/threads/CCThread.ml

@@ -6,8 +6,21 @@ type t = Thread.t
 
 let spawn f = Thread.create f ()
 
+let spawn1 f x = Thread.create f x
+
+let spawn2 f x y = Thread.create (fun () -> f x y) ()
+
 let detach f = ignore (Thread.create f ())
 
+let finally_ f x ~h =
+  try
+    let res = f x in
+    ignore (h ());
+    res
+  with e ->
+    ignore (h());
+    raise e
+
 module Arr = struct
   let spawn n f =
     Array.init n (fun i -> Thread.create f i)
@@ -38,13 +51,7 @@ module Barrier = struct
 
   let with_lock_ b f =
     Mutex.lock b.lock;
-    try
-      let x = f () in
-      Mutex.unlock b.lock;
-      x
-    with e ->
-      Mutex.unlock b.lock;
-      raise e
+    finally_ f () ~h:(fun () -> Mutex.unlock b.lock)
 
   let reset b = with_lock_ b (fun () -> b.activated <- false)
 
@@ -53,17 +60,14 @@ module Barrier = struct
       (fun () ->
         while not b.activated do
           Condition.wait b.cond b.lock
-        done
-      )
+        done)
 
   let activate b =
     with_lock_ b
       (fun () ->
         if not b.activated then (
           b.activated <- true;
-          Condition.broadcast b.cond
-        )
-      )
+          Condition.broadcast b.cond))
 
   let activated b = with_lock_ b (fun () -> b.activated)
 end
@@ -79,194 +83,3 @@ end
   Thread.join t1; Thread.join t2;
   assert_equal 2 (CCLock.get res)
 *)
-
-module Queue = struct
-  type 'a t = {
-    q : 'a Queue.t;
-    lock : Mutex.t;
-    cond : Condition.t;
-    capacity : int;
-    mutable size : int;
-  }
-
-  let create n =
-    if n < 1 then invalid_arg "CCThread.Queue.create";
-    let q = {
-      q=Queue.create();
-      lock=Mutex.create();
-      cond=Condition.create();
-      capacity=n;
-      size=0;
-    } in
-    q
-
-  let incr_size_ q = assert(q.size < q.capacity); q.size <- q.size + 1
-  let decr_size_ q = assert(q.size > 0); q.size <- q.size - 1
-
-  let with_lock_ q f =
-    Mutex.lock q.lock;
-    try
-      let x = f () in
-      Mutex.unlock q.lock;
-      x
-    with e ->
-      Mutex.unlock q.lock;
-      raise e
-
-  let push q x =
-    with_lock_ q
-      (fun () ->
-        while q.size = q.capacity do
-          Condition.wait q.cond q.lock
-        done;
-        assert (q.size < q.capacity);
-        Queue.push x q.q;
-        (* if there are blocked receivers, awake one of them *)
-        incr_size_ q;
-        Condition.broadcast q.cond;
-      )
-
-  let take q =
-    with_lock_ q
-      (fun () ->
-        while q.size = 0 do
-          Condition.wait q.cond q.lock
-        done;
-        let x = Queue.take q.q in
-        (* if there are blocked senders, awake one of them *)
-        decr_size_ q;
-        Condition.broadcast q.cond;
-        x
-      )
-
-  (*$R
-    let q = Queue.create 1 in
-    let t1 = spawn (fun () -> Queue.push q 1; Queue.push q 2) in
-    let t2 = spawn (fun () -> Queue.push q 3; Queue.push q 4) in
-    let l = CCLock.create [] in
-    let t3 = spawn (fun () -> for i = 1 to 4 do
-        let x = Queue.take q in
-        CCLock.update l (fun l -> x :: l)
-      done)
-    in
-    Thread.join t1; Thread.join t2; Thread.join t3;
-    assert_equal [1;2;3;4] (List.sort Pervasives.compare (CCLock.get l))
-  *)
-
-  let push_list q l =
-    let is_empty_ = function [] -> true | _::_ -> false in
-    (* push elements until it's not possible *)
-    let rec push_ q l = match l with
-      | [] -> l
-      | _::_ when q.size = q.capacity -> l (* no room remaining *)
-      | x :: tl ->
-          Queue.push x q.q;
-          incr_size_ q;
-          push_ q tl
-    in
-    (* push chunks of [l] in [q] until [l] is empty *)
-    let rec aux q l =
-      if not (is_empty_ l)
-      then
-        let l = with_lock_ q
-          (fun () ->
-            while q.size = q.capacity do
-              Condition.wait q.cond q.lock
-            done;
-            let l = push_ q l in
-            Condition.broadcast q.cond;
-            l
-          )
-        in
-        aux q l
-    in aux q l
-
-  let take_list q n =
-    (* take at most [n] elements of [q] and prepend them to [acc] *)
-    let rec pop_ acc q n =
-      if n=0 || Queue.is_empty q.q then acc, n
-      else ( (* take next element *)
-        let x = Queue.take q.q in
-        decr_size_ q;
-        pop_ (x::acc) q (n-1)
-      )
-    in
-    (* call [pop_] until [n] elements have been gathered *)
-    let rec aux acc q n =
-      if n=0 then List.rev acc
-      else
-        let acc, n = with_lock_ q
-          (fun () ->
-            while q.size = 0 do
-              Condition.wait q.cond q.lock
-            done;
-            let acc, n = pop_ acc q n in
-            Condition.broadcast q.cond;
-            acc, n
-          )
-        in
-        aux acc q n
-    in
-    aux [] q n
-
-  (*$R
-    let n = 1000 in
-    let lists = [| CCList.(1 -- n) ; CCList.(n+1 -- 2*n); CCList.(2*n+1 -- 3*n) |] in
-    let q = Queue.create 2 in
-    let senders = Arr.spawn 3
-      (fun i ->
-        if i=1
-        then Queue.push_list q lists.(i)  (* test push_list *)
-        else List.iter (Queue.push q) lists.(i)
-      )
-    in
-    let res = CCLock.create [] in
-    let receivers = Arr.spawn 3
-      (fun i ->
-        if i=1 then
-          let l = Queue.take_list q n in
-          CCLock.update res (fun acc -> l @ acc)
-        else
-          for _j = 1 to n do
-            let x = Queue.take q in
-            CCLock.update res (fun acc -> x::acc)
-          done
-      )
-    in
-    Arr.join senders; Arr.join receivers;
-    let l = CCLock.get res |> List.sort Pervasives.compare in
-    assert_equal CCList.(1 -- 3*n) l
-  *)
-
-  let try_take q =
-    with_lock_ q
-      (fun () ->
-        if q.size > 0
-          then (
-            decr_size_ q;
-            Some (Queue.take q.q)
-          ) else None
-      )
-
-  let try_push q x =
-    with_lock_ q
-      (fun () ->
-        if q.size < q.capacity
-          then (
-            incr_size_ q;
-            Queue.push x q.q;
-            Condition.signal q.cond;
-            true
-          ) else false
-      )
-
-  let peek q =
-    with_lock_ q
-      (fun () ->
-         try Some (Queue.peek q.q) with Queue.Empty -> None
-      )
-
-  let size q = with_lock_ q (fun () -> q.size)
-
-  let capacity q = q.capacity
-end

src/threads/CCThread.mli

@@ -7,9 +7,17 @@
 
 type t = Thread.t
 
-val spawn : (unit -> 'a) -> t
+val spawn : (unit -> _) -> t
 (** [spawn f] creates a new thread that runs [f ()] *)
 
+val spawn1 : ('a -> _) -> 'a -> t
+(** [spawn1 f x] is like [spawn (fun () -> f x)].
+    @since 0.16 *)
+
+val spawn2 : ('a -> 'b -> _) -> 'a -> 'b -> t
+(** [spawn2 f x y] is like [spawn (fun () -> f x y)].
+    @since 0.16 *)
+
 val detach : (unit -> 'a) -> unit
 (** [detach f] is the same as [ignore (spawn f)] *)
 
@@ -48,48 +56,3 @@ module Barrier : sig
       was not called since. In other words, [activated b = true] means
       [wait b] will not block. *)
 end
-
-(** {2 Blocking Queue}
-
-    This queue has a limited size. Pushing a value on the queue when it
-    is full will block *)
-module Queue : sig
-  type 'a t
-  (** Safe-thread queue for values of type ['a] *)
-
-  val create : int -> 'a t
-  (** Create a new queue of size [n]. Using [n=max_int] amounts to using
-      an infinite queue (2^61 items is a lot to fit in memory).
-      @raise Invalid_argument if [n < 1] *)
-
-  val push : 'a t -> 'a -> unit
-  (** [push q x] pushes [x] into [q], blocking if the queue is full *)
-
-  val take : 'a t -> 'a
-  (** Take the first element, blocking if needed *)
-
-  val push_list : 'a t -> 'a list -> unit
-  (** Push items of the list, one by one *)
-
-  val take_list : 'a t -> int -> 'a list
-  (** [take_list n q] takes [n] elements out of [q] *)
-
-  val try_take : 'a t -> 'a option
-  (** Take the first element if the queue is not empty, return [None]
-      otherwise *)
-
-  val try_push : 'a t -> 'a -> bool
-  (** [try_push q x] pushes [x] into [q] if [q] is not full, in which
-      case it returns [true].
-      If it fails because [q] is full, it returns [false] *)
-
-  val peek : 'a t -> 'a option
-  (** [peek q] returns [Some x] if [x] is the first element of [q],
-      otherwise it returns [None] *)
-
-  val size : _ t -> int
-  (** Number of elements currently in the queue *)
-
-  val capacity : _ t -> int
-  (** Number of values the queue can hold *)
-end

src/threads/CCTimer.ml

@@ -0,0 +1,195 @@
+
+(* This file is free software, part of containers. See file "license" for more details. *)
+
+(** {1 Event timer} *)
+
+type job =
+  | Job : float * (unit -> 'a) -> job
+
+module TaskHeap = CCHeap.Make(struct
+  type t = job
+  let leq (Job(f1,_)) (Job (f2,_)) = f1 <= f2
+end)
+
+exception Stopped
+
+type t = {
+  mutable stop : bool;
+  mutable tasks : TaskHeap.t;
+  mutable exn_handler : (exn -> unit);
+  t_mutex : Mutex.t;
+  fifo_in : Unix.file_descr;
+  fifo_out : Unix.file_descr;
+}
+
+let set_exn_handler timer f = timer.exn_handler <- f
+
+let standby_wait = 10.
+(* when no task is scheduled, this is the amount of time that is waited
+   in a row for something to happen. This is also the maximal delay
+   between the call to {!stop} and the actual termination of the
+   thread. *)
+
+let epsilon = 0.0001
+(* accepted time diff for actions. *)
+
+let with_lock_ t f =
+  Mutex.lock t.t_mutex;
+  try
+    let x = f t in
+    Mutex.unlock t.t_mutex;
+    x
+  with e ->
+    Mutex.unlock t.t_mutex;
+    raise e
+
+type command =
+  | Quit
+  | Run : (unit -> _) -> command
+  | Wait of float
+
+let pop_task_ t =
+  let tasks, _ = TaskHeap.take_exn t.tasks in
+  t.tasks <- tasks
+
+let call_ timer f =
+  try ignore (f ())
+  with e -> timer.exn_handler e
+
+(* check next task *)
+let next_task_ timer = match TaskHeap.find_min timer.tasks with
+  | _ when timer.stop -> Quit
+  | None -> Wait standby_wait
+  | Some Job (time, f) ->
+      let now = Unix.gettimeofday () in
+      if now +. epsilon > time then (
+        (* now! *)
+        pop_task_ timer;
+        Run f
+      ) else Wait (time -. now)
+
+(* The main thread function: wait for next event, run it, and loop *)
+let serve timer =
+  let buf = Bytes.make 1 '_' in
+  (* acquire lock, call [process_task] and do as it commands *)
+  let rec next () = match with_lock_ timer next_task_ with
+    | Quit -> ()
+    | Run f ->
+        call_ timer f; (* call outside of any lock *)
+        next ()
+    | Wait delay -> wait delay
+  (* wait for [delay] seconds, or until something happens on [fifo_in] *)
+  and wait delay =
+    let read = Thread.wait_timed_read timer.fifo_in delay in
+    (* remove char from fifo, so that next write can happen *)
+    if read then ignore (Unix.read timer.fifo_in buf 0 1);
+    next ()
+  in
+  next ()
+
+let nop_handler_ _ = ()
+
+let create () =
+  let fifo_in, fifo_out = Unix.pipe () in
+  let timer = {
+    stop = false;
+    tasks = TaskHeap.empty;
+    exn_handler = nop_handler_;
+    t_mutex = Mutex.create ();
+    fifo_in;
+    fifo_out;
+  } in
+  (* start a thread to process tasks *)
+  let _t = Thread.create serve timer in
+  timer
+
+let underscore_ = Bytes.make 1 '_'
+
+(* awake the thread *)
+let awaken_ timer =
+  ignore (Unix.single_write timer.fifo_out underscore_ 0 1)
+
+(** [at s t ~f] will run [f ()] at the Unix echo [t] *)
+let at timer time ~f =
+  if timer.stop then raise Stopped;
+  let now = Unix.gettimeofday () in
+  if now >= time
+  then call_ timer f
+  else
+    with_lock_ timer
+      (fun timer ->
+        if timer.stop then raise Stopped;
+        (* time of the next scheduled event *)
+        let next_time = match TaskHeap.find_min timer.tasks with
+          | None -> max_float
+          | Some Job (d, _) -> d
+        in
+        (* insert task *)
+        timer.tasks <- TaskHeap.insert (Job (time, f)) timer.tasks;
+        (* see if the timer thread needs to be awaken earlier *)
+        if time < next_time then awaken_ timer
+      )
+
+let after timer delay ~f =
+  assert (delay >= 0.);
+  let now = Unix.gettimeofday () in
+  at timer (now +. delay) ~f
+
+exception ExitEvery
+
+let every ?delay timer d ~f =
+  let rec run () =
+    try
+      ignore (f ());
+      schedule()
+    with ExitEvery -> () (* stop *)
+  and schedule () = after timer d ~f:run in
+  match delay with
+  | None -> run()
+  | Some d -> after timer d ~f:run
+
+(*$R
+  let start = Unix.gettimeofday() in
+  let timer = create() in
+  let res = CCLock.create 0 in
+  let stop = ref 0. in
+  every timer 0.1
+    ~f:(fun () ->
+      if CCLock.incr_then_get res > 5 then (
+        stop := Unix.gettimeofday();
+        raise ExitEvery
+      ));
+  Thread.delay 0.7;
+  OUnit.assert_equal ~printer:CCInt.to_string 6 (CCLock.get res);
+  OUnit.assert_bool "estimate delay" (abs_float (!stop -. start -. 0.5) < 0.1);
+*)
+
+let active timer = not timer.stop
+
+(** Stop the given timer, cancelling pending tasks *)
+let stop timer =
+  with_lock_ timer
+    (fun timer ->
+      if not timer.stop then (
+        timer.stop <- true;
+        (* empty heap of tasks *)
+        timer.tasks <- TaskHeap.empty;
+        (* tell the thread to stop *)
+        awaken_ timer;
+      )
+    )
+
+(*$R
+  (* scenario:  n := 1; n := n*4 ; n := n+2; res := n *)
+  let timer = create () in
+  let n = CCLock.create 1 in
+  let res = CCLock.create 0 in
+  after timer 0.6
+    ~f:(fun () -> CCLock.update n (fun x -> x+2));
+  ignore (Thread.create
+    (fun _ -> Thread.delay 0.8; CCLock.set res (CCLock.get n)) ());
+  after timer 0.4
+    ~f:(fun () -> CCLock.update n (fun x -> x * 4));
+  Thread.delay 1. ;
+  OUnit.assert_equal 6 (CCLock.get res);
+*)

src/threads/CCTimer.mli

@@ -0,0 +1,43 @@
+
+(* This file is free software, part of containers. See file "license" for more details. *)
+
+(** {1 Event timer}
+
+    Used to be part of [CCFuture]
+    @since 0.16 *)
+
+type t
+(** A scheduler for events. It runs in its own thread. *)
+
+val create : unit -> t
+(** A new timer. *)
+
+val set_exn_handler : t -> (exn -> unit) -> unit
+(** [set_exn_handler timer f] registers [f] so that any exception
+    raised by a task scheduled in [timer] is given to [f] *)
+
+exception Stopped
+
+val after : t -> float -> f:(unit -> _) -> unit
+(** Call the callback [f] after the given number of seconds.
+    @raise Stopped if the timer was stopped *)
+
+val at : t -> float -> f:(unit -> _) -> unit
+(** Create a future that evaluates to [()] at the given Unix timestamp
+    @raise Stopped if the timer was stopped *)
+
+exception ExitEvery
+
+val every : ?delay:float -> t -> float -> f:(unit -> _) -> unit
+(** [every timer n ~f] calls [f ()] every [n] seconds.
+    [f()] can raise ExitEvery to stop the cycle.
+    @param delay if provided, the first call to [f ()] is delayed by
+      that many seconds.
+    @raise Stopped if the timer was stopped *)
+
+val stop : t -> unit
+(** Stop the given timer, cancelling pending tasks. Idempotent.
+    From now on, calling most other operations on the timer will raise Stopped. *)
+
+val active : t -> bool
+(** Returns [true] until [stop t] has been called. *)

src/unix/CCUnix.ml

@@ -46,6 +46,15 @@ let rec iter_gen f g = match g() with
   | None -> ()
   | Some x -> f x; iter_gen f g
 
+let finally_ f x ~h =
+  try
+    let y = f x in
+    ignore (h());
+    y
+  with e ->
+    ignore (h ());
+    raise e
+
 (* print a string, but escaped if required *)
 let escape_str buf s =
   if str_exists s
@@ -155,6 +164,72 @@ let stderr x = x#stderr
 let status x = x#status
 let errcode x = x#errcode
 
+let with_in ?(mode=0o644) ?(flags=[]) file ~f =
+  let fd = Unix.openfile file (Unix.O_RDONLY::flags) mode in
+  let ic = Unix.in_channel_of_descr fd in
+  finally_ f ic
+    ~h:(fun () -> Unix.close fd)
+
+let with_out ?(mode=0o644) ?(flags=[Unix.O_CREAT; Unix.O_TRUNC]) file ~f =
+  let fd = Unix.openfile file (Unix.O_WRONLY::flags) mode in
+  let oc = Unix.out_channel_of_descr fd in
+  finally_ f oc
+    ~h:(fun () -> flush oc; Unix.close fd)
+
+let with_process_in cmd ~f =
+  let ic = Unix.open_process_in cmd in
+  finally_ f ic
+    ~h:(fun () -> ignore (Unix.close_process_in ic))
+
+let with_process_out cmd ~f =
+  let oc = Unix.open_process_out cmd in
+  finally_ f oc
+    ~h:(fun () -> ignore (Unix.close_process_out oc))
+
+type process_full = <
+  stdin: out_channel;
+  stdout: in_channel;
+  stderr: in_channel;
+  close: Unix.process_status;
+>
+
+let with_process_full ?env cmd ~f =
+  let env = match env with None -> Unix.environment () | Some e -> e in
+  let oc, ic, err = Unix.open_process_full cmd env in
+  let close = lazy (Unix.close_process_full (oc,ic,err)) in
+  let p = object
+    method stdin = ic
+    method stdout = oc
+    method stderr = err
+    method close = Lazy.force close
+  end in
+  finally_ f p ~h:(fun () -> p#close)
+
+let with_connection addr ~f =
+  let ic, oc = Unix.open_connection addr in
+  finally_ (fun () -> f ic oc) ()
+    ~h:(fun () -> Unix.shutdown_connection ic)
+
+exception ExitServer
+
+(* version of {!Unix.establish_server} that doesn't fork *)
+let establish_server sockaddr ~f =
+  let sock =
+    Unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 in
+  Unix.setsockopt sock Unix.SO_REUSEADDR true;
+  Unix.bind sock sockaddr;
+  Unix.listen sock 5;
+  let continue = ref true in
+  while !continue do
+    try
+      let s, _ = Unix.accept sock in
+      let ic = Unix.in_channel_of_descr s in
+      let oc = Unix.out_channel_of_descr s in
+      ignore (f ic oc)
+    with ExitServer ->
+      continue := false
+  done
+
 module Infix = struct
   let (?|) fmt = call fmt
 

src/unix/CCUnix.mli

@@ -36,8 +36,7 @@ type 'a gen = unit -> 'a option
 (** {2 Calling Commands} *)
 
 val escape_str : Buffer.t -> string -> unit
-(** Escape a string so it can be a shell argument.
-*)
+(** Escape a string so it can be a shell argument. *)
 
 (*$T
   CCPrint.sprintf "%a" escape_str "foo" = "foo"
@@ -107,6 +106,57 @@ val stderr : < stderr : 'a; .. > -> 'a
 val status : < status : 'a; .. > -> 'a
 val errcode : < errcode : 'a; .. > -> 'a
 
+(** {2 Simple IO} *)
+
+val with_in : ?mode:int -> ?flags:Unix.open_flag list ->
+              string -> f:(in_channel -> 'a) -> 'a
+(** Open an input file with the given optional flag list, calls the function
+    on the input channel. When the function raises or returns, the
+    channel is closed.
+    @param flags opening flags. [Unix.O_RDONLY] is used in any cases
+    @since 0.16 *)
+
+val with_out : ?mode:int -> ?flags:Unix.open_flag list ->
+               string -> f:(out_channel -> 'a) -> 'a
+(** Same as {!with_in} but for an output channel
+    @param flags opening flags (default [[Unix.O_CREAT; Unix.O_TRUNC]])
+      [Unix.O_WRONLY] is used in any cases.
+    @since 0.16 *)
+
+val with_process_in : string -> f:(in_channel -> 'a) -> 'a
+(** Open a subprocess and obtain a handle to its stdout
+    @since 0.16 *)
+
+val with_process_out : string -> f:(out_channel -> 'a) -> 'a
+(** Open a subprocess and obtain a handle to its stdin
+    @since 0.16 *)
+
+(** Handle to a subprocess.
+    @since 0.16 *)
+type process_full = <
+  stdin: out_channel;
+  stdout: in_channel;
+  stderr: in_channel;
+  close: Unix.process_status;
+>
+
+val with_process_full : ?env:string array -> string -> f:(process_full -> 'a) -> 'a
+(** Open a subprocess and obtain a handle to its channels.
+    @param env environment to pass to the subprocess.
+    @since 0.16 *)
+
+val with_connection : Unix.sockaddr -> f:(in_channel -> out_channel -> 'a) -> 'a
+(** Wrap {!Unix.open_connection} with a handler
+    @since 0.16 *)
+
+exception ExitServer
+
+val establish_server : Unix.sockaddr -> f:(in_channel -> out_channel -> _) -> unit
+(** Listen on the address and calls the handler in a blocking fashion.
+    Using {!Thread} is recommended if handlers might take time.
+    The callback should raise {!ExitServer} to stop the loop.
+    @since 0.16 *)
+
 (** {2 Infix Functions} *)
 
 module Infix : sig