simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2026-01-23 09:36:41 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge branch 'master' into stable for 1.2

Browse source
This commit is contained in:
Simon Cruanes 2017-05-01 17:00:24 +02:00
commit 32bc0450dc
50 changed files with 1371 additions and 281 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
AUTHORS.adoc
View file

@ -18,3 +18,6 @@
- Roma Sokolov (@little-arhat)
- Malcolm Matalka (`orbitz`)
- David Sheets (@dsheets)
- Glenn Slotte (glennsl)
- @LemonBoy
- Leonid Rozenberg (@rleonid)

36
CHANGELOG.adoc
View file

@ -1,5 +1,41 @@
= Changelog
== 1.2
- make many modules extensions of stdlib (close #109)
the modules are: `String List ListLabels Array ArrayLabels Char Random`
- add `CCString.{l,r}trim` (close #121)
- add `CCInt.floor_div` and `CCInt.rem`
- add test and bugfix for `CCBV`
- add `CCList.take_drop_while` (close #120)
- add `CCstring.equal_caseless` (close #112)
- add alias `CCString.split` (close #115)
- add `CCFormat.text` (close #111)
- add `CCFormat.{newline,substring}`
- add `CCList.combine_gen` (close #110)
- add module `CCEqual`
- add `CCResult.fold_ok` (closes #107)
- add `CCFormat.with_color_ksf` for colored printing
- add `CCInt.range{,',by}` for iterating on integer ranges
- add `CCString.Sub.get`
- add `CCResult.add_ctx{,f}` for replacing stack traces
- add `CCString.split_on_char`
- add `CCArray.{fold_map,scan_left}` (close #101)
- add `CCList.scan_left`
- add `CCList.{cartesian_product,map_product_l}`
- add `CCUnix.with_file_lock` for locking whole files
- add `CCFormat.of_chan`
- add `CCFormat.flush`
- Add `{map_lazy, or_, or_lazy, to_result, to_result_lazy, of_result}` to `CCOpt`
- annotations in `CCEqual`, for optimization
- Add a tail-recursive implementation of `List.combine`
- fix too restrictive type in `CCResult`
- build unix support by default
- bugfix and test for `CCZipper.is_focused` (closes #102)
- use boxes in `CCFormat.Dump` for tuples
- update header, and use more `(==)` in `CCIntMap`
== 1.1
**bugfixes**:

2
Makefile
View file

@ -123,7 +123,7 @@ update_next_tag:
devel:
./configure --enable-bench --enable-tests --enable-unix \
--enable-bigarray --enable-thread --enable-advanced
--enable-thread
make all
watch:

7
README.adoc
View file

@ -12,7 +12,7 @@ map/fold_right/append, and additional functions on lists).
Alternatively, `open Containers` will bring enhanced versions of the standard
modules into scope.
image:https://ci.cedeela.fr/buildStatus/icon?job=containers[alt="Build Status", link="http://ci.cedeela.fr/job/containers/"]
image::https://ci.cedeela.fr/buildStatus/icon?job=containers[alt="Build Status", link="http://ci.cedeela.fr/job/containers/"]
toc::[]
@ -23,7 +23,7 @@ Containers is:
- A usable, reasonably well-designed library that extends OCaml's standard
library (in 'src/core/', packaged under `containers` in ocamlfind. Modules
are totally independent and are prefixed with `CC` (for "containers-core"
or "companion-cube" because I'm megalomaniac). This part should be
or "companion-cube" because I'm a megalomaniac). This part should be
usable and should work. For instance, `CCList` contains functions and
lists including safe versions of `map` and `append`. It also
provides a drop-in replacement to the standard library, in the module
@ -143,6 +143,9 @@ A few guidelines:
- add `@since` tags for new functions;
- add tests if possible (using `qtest`).
It is helpful to run `make devel` to enable everything. Some dependencies
are required, you'll need `opam install benchmark qcheck qtest sequence`.
Powered by image:http://oasis.forge.ocamlcore.org/oasis-badge.png[alt="OASIS", style="border: none;", link="http://oasis.forge.ocamlcore.org/"]
[[tutorial]]

6
_oasis
View file

@ -1,6 +1,6 @@
OASISFormat: 0.4
Name: containers
Version: 1.1
Version: 1.2
Homepage: https://github.com/c-cube/ocaml-containers
Authors: Simon Cruanes
License: BSD-2-clause
@ -26,7 +26,7 @@ Description:
Flag "unix"
Description: Build the containers.unix library (depends on Unix)
Default: false
Default: true
Flag "thread"
Description: Build modules that depend on threads
@ -42,7 +42,7 @@ Library "containers"
CCFun, CCHash, CCInt, CCBool, CCFloat, CCArray, CCRef, CCSet,
CCOrd, CCRandom, CCString, CCHashtbl, CCMap, CCFormat, CCIO,
CCInt64, CCChar, CCResult, CCParse, CCArray_slice,
CCListLabels, CCArrayLabels,
CCListLabels, CCArrayLabels, CCEqual,
Containers
BuildDepends: bytes, result
# BuildDepends: bytes, bisect_ppx

4
benchs/run_benchs.ml
View file

@ -432,9 +432,7 @@ module Tbl = struct
let arg_make : type a. a key_type -> (module KEY with type t = a) * string
= function
| Int -> (module CCInt), "int"
| Str ->
let module S = struct type t = string include CCString end in
(module S : KEY with type t = string), "string"
| Str -> (module CCString : KEY with type t = string), "string"
let sprintf = Printf.sprintf

3
containers.odocl
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: 00cb4b9b72c4140588c3e040b056e79e)
# DO NOT EDIT (digest: 97e963a89adef885748c84195b76d95c)
src/core/CCVector
src/core/CCHeap
src/core/CCList
@ -27,6 +27,7 @@ src/core/CCParse
src/core/CCArray_slice
src/core/CCListLabels
src/core/CCArrayLabels
src/core/CCEqual
src/core/Containers
src/iter/CCKTree
src/iter/CCKList

1
doc/intro.txt
View file

@ -30,6 +30,7 @@ CCArrayLabels
CCArray_slice
CCBool
CCChar
CCEqual
CCFloat
CCFormat
CCFun

2
opam
View file

@ -1,6 +1,6 @@
opam-version: "1.2"
name: "containers"
version: "1.1"
version: "1.2"
author: "Simon Cruanes"
maintainer: "simon.cruanes@inria.fr"
build: [

11
setup.ml
View file

@ -1,7 +1,7 @@
(* setup.ml generated for the first time by OASIS v0.4.4 *)
(* OASIS_START *)
(* DO NOT EDIT (digest: 03bc063e279594293a833a839f411843) *)
(* DO NOT EDIT (digest: fdb4a0fff7e0145854a42105c9c8afcf) *)
(*
Regenerated by OASIS v0.4.8
Visit http://oasis.forge.ocamlcore.org for more information and
@ -7051,7 +7051,7 @@ let setup_t =
{
oasis_version = "0.4";
ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.1");
version = "1.1";
version = "1.2";
license =
OASISLicense.DEP5License
(OASISLicense.DEP5Unit
@ -7092,7 +7092,7 @@ let setup_t =
flag_description =
Some
"Build the containers.unix library (depends on Unix)";
flag_default = [(OASISExpr.EBool true, false)]
flag_default = [(OASISExpr.EBool true, true)]
});
Flag
({
@ -7282,6 +7282,7 @@ let setup_t =
"CCArray_slice";
"CCListLabels";
"CCArrayLabels";
"CCEqual";
"Containers"
];
lib_pack = false;
@ -8908,7 +8909,7 @@ let setup_t =
};
oasis_fn = Some "_oasis";
oasis_version = "0.4.8";
oasis_digest = Some "L,\200\197\175g\230y\154\151\019\190-\138-\158";
oasis_digest = Some "\214\023V\1858'\142!X\\k\202\255w\167\213";
oasis_exec = None;
oasis_setup_args = [];
setup_update = false
@ -8916,7 +8917,7 @@ let setup_t =
let setup () = BaseSetup.setup setup_t;;
# 8920 "setup.ml"
# 8921 "setup.ml"
let setup_t = BaseCompat.Compat_0_4.adapt_setup_t setup_t
open BaseCompat.Compat_0_4
(* OASIS_STOP *)

46
src/core/CCArray.ml
View file

@ -18,6 +18,8 @@ type 'a printer = Format.formatter -> 'a -> unit
(** {2 Arrays} *)
include Array
type 'a t = 'a array
let empty = [| |]
@ -71,6 +73,48 @@ let fold_while f acc a =
fold_while (fun acc b -> if b then acc+1, `Continue else acc, `Stop) 0 (Array.of_list [true;true;false;true]) = 2
*)
let fold_map f acc a =
let n = length a in
(* need special case for initializing the result *)
if n = 0 then acc, [||]
else (
let acc, b0 = f acc a.(0) in
let res = Array.make n b0 in
let acc = ref acc in
for i = 1 to n-1 do
let new_acc, b = f !acc a.(i) in
acc := new_acc;
res.(i) <- b;
done;
!acc, res
)
(*$=
(6, [|"1"; "2"; "3"|]) \
(fold_map (fun acc x->acc+x, string_of_int x) 0 [|1;2;3|])
*)
(*$Q
Q.(array int) (fun a -> \
fold_map (fun acc x -> x::acc, x) [] a = (List.rev @@ Array.to_list a, a))
*)
let scan_left f acc a =
let n = length a in
let res = Array.make (n+1) acc in
Array.iteri
(fun i x ->
let new_acc = f res.(i) x in
res.(i+1) <- new_acc)
a;
res
(*$= & ~printer:Q.Print.(array int)
[|0;1;3;6|] (scan_left (+) 0 [|1;2;3|])
[|0|] (scan_left (+) 0 [||])
*)
let iter = Array.iter
let iteri = Array.iteri
@ -141,7 +185,7 @@ let sort_ranking cmp a =
*)
(*$Q
Q.(array printable_string) (fun a -> \
Q.(array_of_size Gen.(0--50) printable_string) (fun a -> \
let b = sort_ranking String.compare a in \
let a_sorted = sorted String.compare a in \
a = Array.map (Array.get a_sorted) b)

13
src/core/CCArray.mli
View file

@ -13,6 +13,8 @@ type 'a printer = Format.formatter -> 'a -> unit
(** {2 Arrays} *)
include module type of Array
type 'a t = 'a array
val empty : 'a t
@ -41,6 +43,17 @@ val fold_while : ('a -> 'b -> 'a * [`Stop | `Continue]) -> 'a -> 'b t -> 'a
indicated by the accumulator
@since 0.8 *)
val fold_map : ('acc -> 'a -> 'acc * 'b) -> 'acc -> 'a t -> 'acc * 'b t
(** [fold_map f acc a] is a [fold_left]-like function, but it also maps the
array to another array.
@since 1.2 *)
val scan_left : ('acc -> 'a -> 'acc) -> 'acc -> 'a t -> 'acc t
(** [scan_left f acc a] returns the array
[ [|acc; f acc x0; f (f acc a.(0)) a.(1); …|] ]
@since 1.2 *)
val iter : ('a -> unit) -> 'a t -> unit
val iteri : (int -> 'a -> unit) -> 'a t -> unit

2
src/core/CCArrayLabels.ml
View file

@ -18,6 +18,8 @@ type 'a printer = Format.formatter -> 'a -> unit
(** {2 Arrays} *)
include ArrayLabels
type 'a t = 'a array
let empty = [| |]

2
src/core/CCArrayLabels.mli
View file

@ -13,6 +13,8 @@ type 'a printer = Format.formatter -> 'a -> unit
(** {2 Arrays} *)
include module type of ArrayLabels
type 'a t = 'a array
val empty : 'a t

4
src/core/CCArray_slice.ml
View file

@ -306,7 +306,7 @@ let sort_ranking cmp a =
*)
(*$Q
Q.(array printable_string) (fun a -> \
Q.(array_of_size Gen.(0--50) printable_string) (fun a -> \
Array.length a > 10 ==> ( Array.length a > 10 && \
let s = make a 5 ~len:5 in \
let b = sort_indices String.compare s in \
@ -325,7 +325,7 @@ let sort_indices cmp a = _sort_indices cmp a.arr a.i a.j
*)
(*$Q
Q.(array printable_string) (fun a -> \
Q.(array_of_size Gen.(0--60) printable_string) (fun a -> \
Array.length a > 10 ==> ( Array.length a > 10 && \
let s = make a 5 ~len:5 in \
let b = sort_ranking String.compare s in \

3
src/core/CCChar.ml
View file

@ -4,10 +4,9 @@
@since 0.14 *)
type t = char
include Char
let equal (a:char) b = a=b
let compare = Char.compare
let pp = Buffer.add_char
let print = Format.pp_print_char

2
src/core/CCChar.mli
View file

@ -4,7 +4,7 @@
@since 0.14 *)
type t = char
include module type of Char
val equal : t -> t -> bool
val compare : t -> t -> int

50
src/core/CCEqual.ml Normal file
View file

@ -0,0 +1,50 @@
(* This file is free software, part of containers. See file "license" for more details. *)
(** {1 Equality Combinators} *)
type 'a t = 'a -> 'a -> bool
let poly = (=)
let int : int t = (=)
let string : string t = (=)
let bool : bool t = (=)
let float : float t = (=)
let unit () () = true
let rec list f l1 l2 = match l1, l2 with
| [], [] -> true
| [], _ | _, [] -> false
| x1::l1', x2::l2' -> f x1 x2 && list f l1' l2'
let array eq a b =
let rec aux i =
if i = Array.length a then true
else eq a.(i) b.(i) && aux (i+1)
in
Array.length a = Array.length b
&&
aux 0
let option f o1 o2 = match o1, o2 with
| None, None -> true
| Some _, None
| None, Some _ -> false
| Some x, Some y -> f x y
let pair f g (x1,y1)(x2,y2) = f x1 x2 && g y1 y2
let triple f g h (x1,y1,z1)(x2,y2,z2) = f x1 x2 && g y1 y2 && h z1 z2
let map f eq x y = eq (f x) (f y)
(*$Q
Q.(let p = small_list (pair small_int bool) in pair p p) (fun (l1,l2) -> \
CCEqual.(list (pair int bool)) l1 l2 = (l1=l2))
*)
module Infix = struct
let (>|=) x f = map f x
end
include Infix

40
src/core/CCEqual.mli Normal file
View file

@ -0,0 +1,40 @@
(* This file is free software, part of containers. See file "license" for more details. *)
(** {1 Equality Combinators} *)
(** @since 1.2 *)
type 'a t = 'a -> 'a -> bool
(** Equality function. Must be transitive, symmetric, and reflexive. *)
val poly : 'a t
(** Standard polymorphic equality *)
val int : int t
val string : string t
val bool : bool t
val float : float t
val unit : unit t
val list : 'a t -> 'a list t
val array : 'a t -> 'a array t
val option : 'a t -> 'a option t
val pair : 'a t -> 'b t -> ('a * 'b) t
val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
val map : ('a -> 'b) -> 'b t -> 'a t
(** [map f eq] is the equality function that, given objects [x] and [y],
projects [x] and [y] using [f] (e.g. using a record field) and then
compares those projections with [eq].
Example:
[map fst int] compares values of type [(int * 'a)] by their
first component. *)
val (>|=) : 'b t -> ('a -> 'b) -> 'a t
(** Infix equivalent of {!map} *)
module Infix : sig
val (>|=) : 'b t -> ('a -> 'b) -> 'a t
end

1
src/core/CCFloat.ml
View file

@ -73,6 +73,7 @@ let to_int (a:float) = Pervasives.int_of_float a
let of_int (a:int) = Pervasives.float_of_int a
let to_string (a:float) = Pervasives.string_of_float a
let of_string_exn (a:string) = Pervasives.float_of_string a
let of_string (a:string) = Pervasives.float_of_string a

14
src/core/CCFloat.mli
View file

@ -68,11 +68,23 @@ val sign_exn : t -> int
@since 0.7 *)
val to_int : t -> int
(** Alias to {!int_of_float}.
Unspecified if outside of the range of integers. *)
val of_int : int -> t
(** Alias to {!float_of_int} *)
val to_string : t -> string
val of_string : string -> t
val of_string_exn : string -> t
(** Alias to {!float_of_string}
@raise Failure in case of failure
@since 1.2 *)
val of_string : string -> t
(** Alias to {!float_of_string}.
@deprecated since 1.2, use {!of_string_exn} instead
@raise Failure in case of failure *)
val equal_precision : epsilon:t -> t -> t -> bool
(** Equality with allowed error up to a non negative epsilon value *)

69
src/core/CCFormat.ml
View file

@ -37,6 +37,47 @@ let int32 fmt n = Format.fprintf fmt "%ld" n
let int64 fmt n = Format.fprintf fmt "%Ld" n
let nativeint fmt n = Format.fprintf fmt "%nd" n
let string_quoted fmt s = Format.fprintf fmt "\"%s\"" s
let flush = Format.pp_print_flush
let newline = Format.pp_force_newline
let substring out (s,i,len): unit =
string out (String.sub s i len)
let text out (s:string): unit =
let len = String.length s in
let i = ref 0 in
let search_ c =
try Some (String.index_from s !i c) with Not_found -> None
in
while !i < len do
let j_newline = search_ '\n' in
let j_space = search_ ' ' in
let on_newline j =
substring out (s, !i, j - !i);
newline out ();
i := j + 1
and on_space j =
substring out (s, !i, j - !i);
Format.pp_print_space out ();
i := j + 1
in
begin match j_newline, j_space with
| None, None ->
(* done *)
substring out (s, !i, len - !i);
i := len
| Some j, None -> on_newline j
| None, Some j -> on_space j
| Some j1, Some j2 ->
if j1<j2 then on_newline j1 else on_space j2
end
done
(*$= & ~printer:(fun s->CCFormat.sprintf "%S" s)
"a\nb\nc" (sprintf_no_color "@[<v>%a@]%!" text "a b c")
"a b\nc" (sprintf_no_color "@[<h>%a@]%!" text "a b\nc")
*)
let list ?(sep=return ",@ ") pp fmt l =
let rec pp_list l = match l with
@ -134,6 +175,18 @@ let fprintf = Format.fprintf
let stdout = Format.std_formatter
let stderr = Format.err_formatter
let of_chan = Format.formatter_of_out_channel
let with_out_chan oc f =
let fmt = of_chan oc in
try
let x = f fmt in
Format.pp_print_flush fmt ();
x
with e ->
Format.pp_print_flush fmt ();
raise e
let tee a b =
let fa = Format.pp_get_formatter_out_functions a () in
let fb = Format.pp_get_formatter_out_functions b () in
@ -311,7 +364,7 @@ let sprintf_ c format =
fmt
format
let with_color_sf s fmt =
let with_color_ksf ~f s fmt =
let buf = Buffer.create 64 in
let out = Format.formatter_of_buffer buf in
if !color_enabled then set_color_tag_handling out;
@ -320,9 +373,11 @@ let with_color_sf s fmt =
(fun out ->
Format.pp_close_tag out ();
Format.pp_print_flush out ();
Buffer.contents buf)
f (Buffer.contents buf))
out fmt
let with_color_sf s fmt = with_color_ksf ~f:(fun s->s) s fmt
let sprintf fmt = sprintf_ true fmt
let sprintf_no_color fmt = sprintf_ false fmt
let sprintf_dyn_color ~colors fmt = sprintf_ colors fmt
@ -371,12 +426,12 @@ module Dump = struct
let option pp out x = match x with
| None -> Format.pp_print_string out "None"
| Some x -> Format.fprintf out "Some %a" pp x
let pair p1 p2 = within "(" ")" (pair p1 p2)
let triple p1 p2 p3 = within "(" ")" (triple p1 p2 p3)
let quad p1 p2 p3 p4 = within "(" ")" (quad p1 p2 p3 p4)
let pair p1 p2 = within "(" ")" (hovbox (pair p1 p2))
let triple p1 p2 p3 = within "(" ")" (hovbox (triple p1 p2 p3))
let quad p1 p2 p3 p4 = within "(" ")" (hovbox (quad p1 p2 p3 p4))
let result' pok perror out = function
| Result.Ok x -> Format.fprintf out "(Ok %a)" pok x
| Result.Error e -> Format.fprintf out "(Error %a)" perror e
| Result.Ok x -> Format.fprintf out "(@[Ok %a@])" pok x
| Result.Error e -> Format.fprintf out "(@[Error %a@])" perror e
let result pok = result' pok string
let to_string = to_string
end

41
src/core/CCFormat.mli
View file

@ -23,11 +23,32 @@ val bool : bool printer
val float3 : float printer (* 3 digits after . *)
val float : float printer
val newline : unit printer
(** Force newline (see {!Format.pp_force_newline})
@since 1.2 *)
val substring : (string * int * int) printer
(** Print the substring [(s,i,len)], where [i] is the offset
in [s] and [len] the number of bytes in the substring.
@raise Invalid_argument if the triple [(s,i,len)] does not
describe a proper substring.
@since 1.2 *)
val text : string printer
(** Print string, but replacing spaces with breaks and newlines
with {!newline}.
See [pp_print_text] on recent versions of OCaml.
@since 1.2 *)
val char : char printer (** @since 0.14 *)
val int32 : int32 printer (** @since 0.14 *)
val int64 : int64 printer (** @since 0.14 *)
val nativeint : nativeint printer (** @since 0.14 *)
val flush : unit printer
(** Alias to {!Format.pp_print_flush}.
@since 1.2 *)
val string_quoted : string printer
(** Similar to {!CCString.print}.
@since 0.14 *)
@ -175,11 +196,31 @@ val with_color_sf : string -> ('a, t, unit, string) format4 -> 'a
{b status: experimental}
@since 0.21 *)
val with_color_ksf : f:(string -> 'b) -> string -> ('a, t, unit, 'b) format4 -> 'a
(** [with_color_ksf "Blue" ~f "%s %d" "yolo" 42] will behave like
{!ksprintf}, but wrapping the content with the given style
Example:
the following with raise [Failure] with a colored message
{[
CCFormat.with_color_ksf "red" ~f:failwith "%a" CCFormat.Dump.(list int) [1;2;3];;
]}
@since 1.2 *)
(** {2 IO} *)
val output : t -> 'a printer -> 'a -> unit
val to_string : 'a printer -> 'a -> string
val of_chan : out_channel -> t
(** Alias to {!Format.formatter_of_out_channel}
@since 1.2 *)
val with_out_chan : out_channel -> (t -> 'a) -> 'a
(** [with_out_chan oc f] turns [oc] into a formatter [fmt], and call [f fmt].
Behaves like [f fmt] from then on, but whether the call to [f] fails
or returns, [fmt] is flushed before the call terminates.
@since 1.2 *)
val stdout : t
val stderr : t

150
src/core/CCInt.ml
View file

@ -37,8 +37,86 @@ let pow a b =
pow 0 1 = 0
*)
let floor_div a n =
if a < 0 && n >= 0 then
(a + 1) / n - 1
else if a > 0 && n < 0 then
(a - 1) / n - 1
else
a / n
(*$T
(floor_div 3 5 = 0)
(floor_div 5 5 = 1)
(floor_div 20 5 = 4)
(floor_div 12 5 = 2)
(floor_div 0 5 = 0)
(floor_div (-1) 5 = -1)
(floor_div (-5) 5 = -1)
(floor_div (-12) 5 = -3)
(floor_div 0 (-5) = 0)
(floor_div 3 (-5) = -1)
(floor_div 5 (-5) = -1)
(floor_div 9 (-5) = -2)
(floor_div 20 (-5) = -4)
(floor_div (-2) (-5) = 0)
(floor_div (-8) (-5) = 1)
(floor_div (-35) (-5) = 7)
try ignore (floor_div 12 0); false with Division_by_zero -> true
try ignore (floor_div (-12) 0); false with Division_by_zero -> true
*)
(*$Q
(Q.pair Q.small_signed_int Q.pos_int) \
(fun (n, m) -> floor_div n m = int_of_float @@ floor (float n /. float m))
(Q.pair Q.small_signed_int Q.pos_int) \
(fun (n, m) -> floor_div n (-m) = int_of_float @@ floor (float n /. float (-m)))
*)
let rem a n =
let y = a mod n in
if (y < 0) <> (n < 0) && y <> 0 then
y + n
else
y
(*$T
(rem 3 5 = 3)
(rem 5 5 = 0)
(rem 9 5 = 4)
(rem (-1) 5 = 4)
(rem (-5) 5 = 0)
(rem (-20) 5 = 0)
(rem (-9) 5 = 1)
(rem 0 5 = 0)
(rem 0 (-5) = 0)
(rem 3 (-5) = -2)
(rem 5 (-5) = 0)
(rem 9 (-5) = -1)
(rem (-2) (-5) = -2)
(rem (-8) (-5) = -3)
(rem (-35) (-5) = 0)
try ignore (rem 12 0); false with Division_by_zero -> true
try ignore (rem (-12) 0); false with Division_by_zero -> true
*)
(*$Q
(Q.pair Q.int Q.pos_int) (fun (n, m) -> let y = rem n m in y >= 0 && y < m)
(Q.pair Q.int Q.pos_int) (fun (n, m) -> let y = rem n (-m) in y > (-m) && y <= 0)
*)
(*$Q
(Q.pair Q.int Q.pos_int) (fun (n, m) -> n = m * floor_div n m + rem n m)
(Q.pair Q.int Q.pos_int) (fun (n, m) -> n = (-m) * floor_div n (-m) + rem n (-m))
*)
type 'a printer = Format.formatter -> 'a -> unit
type 'a random_gen = Random.State.t -> 'a
type 'a sequence = ('a -> unit) -> unit
let random n st = Random.State.int st n
let random_small = random 100
@ -96,6 +174,76 @@ let to_string_binary n =
Q.int (fun n -> n = int_of_string (to_string_binary n))
*)
let range_by ~step i j yield =
let rec range i j yield =
if i=j then yield i
else (
yield i;
range (i+step) j yield
)
in
if step = 0 then
raise (Invalid_argument "CCList.range_by")
else if (if step > 0 then i>j else i<j) then ()
else range i ((j-i)/step*step + i) yield
(* note: the last test checks that no error occurs due to overflows. *)
(*$= & ~printer:Q.Print.(list int)
[0] (range_by ~step:1 0 0 |> Sequence.to_list)
[] (range_by ~step:1 5 0 |> Sequence.to_list)
[] (range_by ~step:2 1 0 |> Sequence.to_list)
[0;2;4] (range_by ~step:2 0 4 |> Sequence.to_list)
[0;2;4] (range_by ~step:2 0 5 |> Sequence.to_list)
[0] (range_by ~step:~-1 0 0 |> Sequence.to_list)
[] (range_by ~step:~-1 0 5 |> Sequence.to_list)
[] (range_by ~step:~-2 0 1 |> Sequence.to_list)
[5;3;1] (range_by ~step:~-2 5 1 |> Sequence.to_list)
[5;3;1] (range_by ~step:~-2 5 0 |> Sequence.to_list)
[0] (range_by ~step:max_int 0 2 |> Sequence.to_list)
*)
(*$Q
Q.(pair small_int small_int) (fun (i,j) -> \
let i = min i j and j = max i j in \
CCList.equal CCInt.equal \
(CCInt.range_by ~step:1 i j |> Sequence.to_list) \
(CCInt.range i j |> Sequence.to_list) )
*)
let range i j yield =
let rec up i j yield =
if i=j then yield i
else (
yield i;
up (i+1) j yield
)
and down i j yield =
if i=j then yield i
else (
yield i;
down (i-1) j yield
)
in
if i<=j then up i j yield else down i j yield
(*$= & ~printer:Q.Print.(list int)
[0;1;2;3;4;5] (range 0 5 |> Sequence.to_list)
[0] (range 0 0 |> Sequence.to_list)
[5;4;3;2] (range 5 2 |> Sequence.to_list)
*)
let range' i j yield =
if i<j then range i (j-1) yield
else if i=j then ()
else range i (j+1) yield
(*$= & ~printer:Q.Print.(list int)
[] (range' 0 0 |> Sequence.to_list)
[0;1;2;3;4] (range' 0 5 |> Sequence.to_list)
[5;4;3] (range' 5 2 |> Sequence.to_list)
*)
module Infix = struct
let (=) = Pervasives.(=)
let (<>) = Pervasives.(<>)
@ -103,6 +251,8 @@ module Infix = struct
let (>) = Pervasives.(>)
let (<=) = Pervasives.(<=)
let (>=) = Pervasives.(>=)
let (--) = range
let (--^) = range'
end
include Infix
let min = min

36
src/core/CCInt.mli
View file

@ -23,8 +23,19 @@ val pow : t -> t -> t
Raises [Invalid_argument] if [a = b = 0] or [b] < 0.
@since 0.11 *)
val floor_div : t -> t -> t
(** [floor_div a n] is integer division rounding towards negative infinity.
It satisfies [a = m * floor_div a n + rem a n].
@since 1.2 *)
val rem : t -> t -> t
(** [rem a n] is the remainder of dividing [a] by [n], with the same
sign as [n].
@since 1.2 *)
type 'a printer = Format.formatter -> 'a -> unit
type 'a random_gen = Random.State.t -> 'a
type 'a sequence = ('a -> unit) -> unit
val random : int -> t random_gen
val random_small : t random_gen
@ -51,6 +62,23 @@ val min : t -> t -> t
val max : t -> t -> t
(** @since 0.17 *)
val range_by : step:t -> t -> t -> t sequence
(** [range_by ~step i j] iterates on integers from [i] to [j] included,
where the difference between successive elements is [step].
use a negative [step] for a decreasing list.
@raise Invalid_argument if [step=0]
@since 1.2 *)
val range : t -> t -> t sequence
(** [range i j] iterates on integers from [i] to [j] included . It works
both for decreasing and increasing ranges
@since 1.2 *)
val range' : t -> t -> t sequence
(** Same as {!range} but the second bound is excluded.
For instance [range' 0 5 = Sequence.of_list [0;1;2;3;4]]
@since 1.2 *)
(** {2 Infix Operators}
@since 0.17 *)
@ -72,6 +100,14 @@ module Infix : sig
val (>=) : t -> t -> bool
(** @since 0.17 *)
val (--) : t -> t -> t sequence
(** Alias to {!range}
@since 1.2 *)
val (--^) : t -> t -> t sequence
(** Alias to {!range'}
@since 1.2 *)
end
include module type of Infix

8
src/core/CCInt64.mli
View file

@ -53,24 +53,32 @@ val to_int : t -> int
val of_int : int -> t option
val of_int_exn : int -> t
(** Alias to {!Int64.of_int}
@raise Failure in case of failure *)
val to_int32 : t -> int32
val of_int32 : int32 -> t option
val of_int32_exn : int32 -> t
(** Alias to {!Int64.of_int32}
@raise Failure in case of failure *)
val to_nativeint : t -> nativeint
val of_nativeint : nativeint -> t option
val of_nativeint_exn : nativeint -> t
(** Alias to {!Int64.of_nativeint}
@raise Failure in case of failure *)
val to_float : t -> float
val of_float : float -> t option
val of_float_exn : float -> t
(** Alias to {!Int64.of_float}
@raise Failure in case of failure *)
val to_string : t -> string

133
src/core/CCList.ml
View file

@ -9,6 +9,8 @@
type 'a t = 'a list
include List
let empty = []
let is_empty = function
@ -152,6 +154,26 @@ let fold_map f acc l =
fold_map (fun acc x -> x::acc, x) [] l = (List.rev l, l))
*)
let scan_left f acc l =
let rec aux f acc l_acc l = match l with
| [] -> List.rev l_acc
| x :: tail ->
let acc = f acc x in
let l_acc = acc :: l_acc in
aux f acc l_acc tail
in
aux f acc [acc] l
(*$= & ~printer:Q.Print.(list int)
[0;1;3;6] (scan_left (+) 0 [1;2;3])
[0] (scan_left (+) 0 [])
*)
(*$Q
Q.(list int) (fun l -> \
List.length l + 1 = List.length (scan_left (+) 0 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
@ -277,8 +299,8 @@ let fold_product f acc l1 l2 =
(fun acc x1 ->
List.fold_left
(fun acc x2 -> f acc x1 x2)
acc l2
) acc l1
acc l2)
acc l1
let diagonal l =
let rec gen acc l = match l with
@ -319,6 +341,52 @@ let partition_map f l =
assert_equal [1;3] l2
*)
let combine l1 l2 =
let rec direct i l1 l2 = match l1, l2 with
| ([], []) -> []
| _ when i=0 -> safe l1 l2 []
| (x1::l1', x2::l2') -> (x1, x2) :: direct (i-1) l1' l2'
| (_, _) -> invalid_arg "CCList.combine"
and safe l1 l2 acc = match l1, l2 with
| ([], []) -> List.rev acc
| (x1::l1', x2::l2') -> safe l1' l2' @@ (x1, x2) :: acc
| (_, _) -> invalid_arg "CCList.combine"
in
direct direct_depth_default_ l1 l2
(*$T
try ignore (combine [1] []); false with Invalid_argument _ -> true
try ignore (combine (1--1001) (1--1002)); false with Invalid_argument _ -> true
combine [1;2;3] [3;2;1] = List.combine [1;2;3] [3;2;1]
combine (1 -- 100_000) (1 -- 100_000) = List.combine (1 -- 100_000) (1 -- 100_000)
*)
(*$Q
Q.(let p = small_list int in pair p p)(fun (l1,l2) -> \
if List.length l1=List.length l2 \
then CCList.combine l1 l2 = List.combine l1 l2 \
else Q.assume_fail() )
*)
let combine_gen l1 l2 =
let l1 = ref l1 in
let l2 = ref l2 in
fun () -> match !l1, !l2 with
| [], _
| _, [] -> None
| x1 :: tail1, x2 :: tail2 ->
l1 := tail1;
l2 := tail2;
Some (x1,x2)
(*$Q
Q.(let p = small_list int in pair p p)(fun (l1,l2) -> \
let n = min (List.length l1) (List.length l2) in \
let res1 = combine (take n l1) (take n l2) in \
let res2 = combine_gen l1 l2 |> of_gen in \
res1 = res2)
*)
let return x = [x]
let (>>=) l f = flat_map f l
@ -329,6 +397,44 @@ let pure = return
let (<*>) funs l = product (fun f x -> f x) funs l
let cartesian_product l =
(* [left]: elements picked so far
[right]: sets to pick elements from
[acc]: accumulator for the result, to pass to continuation
[k]: continuation *)
let rec prod_rec left right k acc = match right with
| [] -> k acc (List.rev left)
| l1 :: tail ->
List.fold_left
(fun acc x -> prod_rec (x::left) tail k acc)
acc l1
in
prod_rec [] l (fun acc l' -> l' :: acc) []
(*$inject
let cmp_lii_unord l1 l2 : bool =
List.sort CCOrd.compare l1 = List.sort CCOrd.compare l2
*)
(*$= & ~printer:Q.Print.(list (list int)) ~cmp:cmp_lii_unord
[[1;3;4];[1;3;5];[1;3;6];[2;3;4];[2;3;5];[2;3;6]] \
(cartesian_product [[1;2];[3];[4;5;6]])
[] (cartesian_product [[1;2];[];[4;5;6]])
[[]] (cartesian_product [])
[[1;3;4;5;6];[2;3;4;5;6]] \
(cartesian_product [[1;2];[3];[4];[5];[6]])
*)
(* cartesian product of lists of lists *)
let map_product_l f l =
let l = List.map f l in
cartesian_product l
(*$Q
Q.(list_of_size Gen.(1--4) (list_of_size Gen.(0--4) small_int)) (fun l-> \
cmp_lii_unord (cartesian_product l) (map_product_l CCFun.id l))
*)
let sorted_merge ?(cmp=Pervasives.compare) l1 l2 =
let rec recurse cmp acc l1 l2 = match l1,l2 with
| [], _ -> List.rev_append acc l2
@ -596,6 +702,29 @@ let rec drop_while p l = match l with
take_while f l @ drop_while f l = l)
*)
let take_drop_while p l =
let rec direct i p l = match l with
| [] -> [], []
| _ when i=0 -> safe p [] l
| x :: tail ->
if p x
then
let l1, l2 = direct (i-1) p tail in
x :: l1, l2
else [], l
and safe p acc l = match l with
| [] -> List.rev acc, []
| x :: tail ->
if p x then safe p (x::acc) tail else List.rev acc, l
in
direct direct_depth_default_ p l
(*$Q
Q.(pair (fun1 small_int bool) (list small_int)) (fun (f,l) -> \
let l1,l2 = take_drop_while f l in \
(l1 = take_while f l) && (l2 = drop_while f l))
*)
let last n l =
let len = List.length l in
if len < n then l else drop (len-n) l

55
src/core/CCList.mli
View file

@ -3,6 +3,14 @@
(** {1 complements to list} *)
type 'a sequence = ('a -> unit) -> unit
type 'a gen = unit -> 'a option
type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
type 'a printer = Format.formatter -> 'a -> unit
type 'a random_gen = Random.State.t -> 'a
include module type of List
type 'a t = 'a list
val empty : 'a t
@ -48,6 +56,11 @@ val fold_map : ('acc -> 'a -> 'acc * 'b) -> 'acc -> 'a list -> 'acc * 'b list
list to another list.
@since 0.14 *)
val scan_left : ('acc -> 'a -> 'acc) -> 'acc -> 'a list -> 'acc list
(** [scan_left f acc l] returns the list [[acc; f acc x0; f (f acc x0) x1; …]]
where [x0], [x1], etc. are the elements of [l]
@since 1.2 *)
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
@ -67,6 +80,18 @@ val init : int -> (int -> 'a) -> 'a t
(** Similar to {!Array.init}
@since 0.6 *)
val combine : 'a list -> 'b list -> ('a * 'b) list
(** Similar to {!List.combine} but tail-recursive.
@raise Invalid_argument if the lists have distinct lengths.
@since 1.2 *)
val combine_gen : 'a list -> 'b list -> ('a * 'b) gen
(** Lazy version of {!combine}.
Unlike {!combine}, it does not fail if the lists have different
lengths;
instead, the output has as many pairs as the smallest input list.
@since 1.2 *)
val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
@ -83,6 +108,26 @@ val product : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
val fold_product : ('c -> 'a -> 'b -> 'c) -> 'c -> 'a t -> 'b t -> 'c
(** Fold on the cartesian product *)
val cartesian_product : 'a t t -> 'a t t
(**
For example:
{[
# cartesian_product [[1;2];[3];[4;5;6]] =
[[1;3;4];[1;3;5];[1;3;6];[2;3;4];[2;3;5];[2;3;6]];;
# cartesian_product [[1;2];[];[4;5;6]] = [];;
# cartesian_product [[1;2];[3];[4];[5];[6]] =
[[1;3;4;5;6];[2;3;4;5;6]];;
]}
invariant: [cartesian_product l = map_product id l].
@since 1.2 *)
val map_product_l : ('a -> 'b list) -> 'a list -> 'b list list
(** [map_product_l f l] maps each element of [l] to a list of
objects of type ['b] using [f].
We obtain [[l1;l2;…;ln]] where [length l=n] and [li : 'b list].
Then, it returns all the ways of picking exactly one element per [li].
@since 1.2 *)
val diagonal : 'a t -> ('a * 'a) t
(** All pairs of distinct positions of the list. [list_diagonal l] will
return the list of [List.nth i l, List.nth j l] if [i < j]. *)
@ -154,6 +199,10 @@ val take_while : ('a -> bool) -> 'a t -> 'a t
val drop_while : ('a -> bool) -> 'a t -> 'a t
(** @since 0.13 *)
val take_drop_while : ('a -> bool) -> 'a t -> 'a t * 'a t
(** [take_drop_while p l = take_while p l, drop_while p l]
@since 1.2 *)
val last : int -> 'a t -> 'a t
(** [last n l] takes the last [n] elements of [l] (or less if
[l] doesn't have that many elements *)
@ -408,12 +457,6 @@ end
(** {2 Conversions} *)
type 'a sequence = ('a -> unit) -> unit
type 'a gen = unit -> 'a option
type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
type 'a printer = Format.formatter -> 'a -> unit
type 'a random_gen = Random.State.t -> 'a
val random : 'a random_gen -> 'a t random_gen
val random_non_empty : 'a random_gen -> 'a t random_gen
val random_len : int -> 'a random_gen -> 'a t random_gen

2
src/core/CCListLabels.ml
View file

@ -7,6 +7,8 @@
let lsort l = List.sort Pervasives.compare l
*)
include ListLabels
type 'a t = 'a list
let empty = []

2
src/core/CCListLabels.mli
View file

@ -3,6 +3,8 @@
(** {1 complements to list} *)
include module type of ListLabels
type 'a t = 'a list
val empty : 'a t

26
src/core/CCOpt.ml
View file

@ -13,6 +13,10 @@ let map_or ~default f = function
| None -> default
| Some x -> f x
let map_lazy default_fn f = function
| None -> default_fn ()
| Some x -> f x
let is_some = function
| None -> false
| Some _ -> true
@ -54,10 +58,16 @@ let (<*>) f x = match f, x with
let (<$>) = map
let (<+>) a b = match a with
| None -> b
let or_ ~else_ a = match a with
| None -> else_
| Some _ -> a
let or_lazy ~else_ a = match a with
| None -> else_ ()
| Some _ -> a
let (<+>) a b = or_ ~else_:b a
let choice l = List.fold_left (<+>) None l
let map2 f o1 o2 = match o1, o2 with
@ -137,6 +147,18 @@ let of_list = function
| x::_ -> Some x
| [] -> None
let to_result err = function
| None -> Result.Error err
| Some x -> Result.Ok x
let to_result_lazy err_fn = function
| None -> Result.Error (err_fn ())
| Some x -> Result.Ok x
let of_result = function
| Result.Error _ -> None
| Result.Ok x -> Some x
module Infix = struct
let (>|=) = (>|=)
let (>>=) = (>>=)

23
src/core/CCOpt.mli
View file

@ -9,9 +9,13 @@ val map : ('a -> 'b) -> 'a t -> 'b t
(** Transform the element inside, if any *)
val map_or : default:'b -> ('a -> 'b) -> 'a t -> 'b
(** [map_or ~default f o] is [f x] if [o = Some x], [default otherwise]
(** [map_or ~default f o] is [f x] if [o = Some x], [default] otherwise
@since 0.16 *)
val map_lazy : (unit -> 'b) -> ('a -> 'b) -> 'a t -> 'b
(** [map_lazy default_fn f o] if [f o] if [o = Some x], [default_fn ()] otherwise
@since 1.2 *)
val is_some : _ t -> bool
val is_none : _ t -> bool
@ -94,6 +98,14 @@ val (<$>) : ('a -> 'b) -> 'a t -> 'b t
(** {2 Alternatives} *)
val or_ : else_:('a t) -> 'a t -> 'a t
(** [or_ ~else_ a] is [a] if [a] is [Some _], [else_] otherwise
@since 1.2 *)
val or_lazy : else_:(unit -> 'a t) -> 'a t -> 'a t
(** [or_lazy else_ a] is [a] if [a] is [Some _], [else_ ()] otherwise
@since 1.2 *)
val (<+>) : 'a t -> 'a t -> 'a t
(** [a <+> b] is [a] if [a] is [Some _], [b] otherwise *)
@ -118,6 +130,15 @@ val to_list : 'a t -> 'a list
val of_list : 'a list -> 'a t
(** Head of list, or [None] *)
val to_result : 'e -> 'a t -> ('a, 'e) Result.result
(** @since 1.2 *)
val to_result_lazy : (unit -> 'e) -> 'a t -> ('a, 'e) Result.result
(** @since 1.2 *)
val of_result : ('a, _) Result.result -> 'a t
(** @since 1.2 *)
type 'a sequence = ('a -> unit) -> unit
type 'a gen = unit -> 'a option
type 'a printer = Format.formatter -> 'a -> unit

2
src/core/CCRandom.ml
View file

@ -3,6 +3,8 @@
(** {1 Random Generators} *)
include Random
type state = Random.State.t
type 'a t = state -> 'a

2
src/core/CCRandom.mli
View file

@ -3,6 +3,8 @@
(** {1 Random Generators} *)
include module type of Random
type state = Random.State.t
type 'a t = state -> 'a

33
src/core/CCResult.ml
View file

@ -24,6 +24,10 @@ let fail_printf format =
(fun buf -> fail (Buffer.contents buf))
buf format
(*$T
(Error "ohno 42") = (fail_printf "ohno %d" 42)
*)
let fail_fprintf format =
let buf = Buffer.create 64 in
let out = Format.formatter_of_buffer buf in
@ -31,6 +35,26 @@ let fail_fprintf format =
(fun out -> Format.pp_print_flush out (); fail (Buffer.contents buf))
out format
(*$T
(Error "ohno 42") = (fail_fprintf "ohno %d" 42)
*)
let add_ctx msg x = match x with
| Error e -> Error (e ^ "\ncontext:" ^ msg)
| Ok x -> Ok x
let add_ctxf msg =
let buf = Buffer.create 64 in
let out = Format.formatter_of_buffer buf in
Format.kfprintf
(fun out e -> Format.pp_print_flush out (); add_ctx (Buffer.contents buf) e)
out msg
(*$=
(Error "error\ncontext:message(number 42, foo: true)") \
(add_ctxf "message(number %d, foo: %B)" 42 true (Error "error"))
*)
let of_exn e =
let msg = Printexc.to_string e in
Error msg
@ -98,6 +122,15 @@ let fold ~ok ~error x = match x with
| Ok x -> ok x
| Error s -> error s
let fold_ok f acc r = match r with
| Ok x -> f acc x
| Error _ -> acc
(*$=
42 (fold_ok (+) 2 (Ok 40))
40 (fold_ok (+) 40 (Error "foo"))
*)
let is_ok = function
| Ok _ -> true
| Error _ -> false

26
src/core/CCResult.mli
View file

@ -34,14 +34,28 @@ val of_exn_trace : exn -> ('a, string) t
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
val fail_printf : ('a, Buffer.t, unit, ('b, 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
val fail_fprintf : ('a, Format.formatter, unit, ('b, string) t) format4 -> 'a
(** [fail_printf format] uses [format] to obtain an error message
and then returns [Error msg] *)
val add_ctx : string -> ('a, string) t -> ('a, string) t
(** [add_ctx msg] leaves [Ok x] untouched, but transforms
[Error s] into [Error s'] where [s'] contains the additional
context given by [msg]
@since 1.2 *)
val add_ctxf : ('a, Format.formatter, unit, ('b, string) t -> ('b, string) t) format4 -> 'a
(** [add_ctxf format_message] is similar to {!add_ctx} but with
{!Format} for printing the message (eagerly).
Example: {[
add_ctxf "message(number %d, foo: %B)" 42 true (Error "error)"
]}
@since 1.2 *)
val map : ('a -> 'b) -> ('a, 'err) t -> ('b, 'err) t
(** Map on success *)
@ -87,9 +101,13 @@ 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]. *)
val is_ok : ('a, 'err) t -> bool
(** Return true if Ok/
val fold_ok : ('a -> 'b -> 'a) -> 'a -> ('b, _) t -> 'a
(** [fold_ok f acc r] will compute [f acc x] if [r=Ok x],
and return [acc] otherwise, as if the result were a mere option.
@since 1.2 *)
val is_ok : ('a, 'err) t -> bool
(** Return true if Ok
@since 1.0 *)
val is_error : ('a, 'err) t -> bool

37
src/core/CCString.cppo.ml
View file

@ -7,6 +7,8 @@ type 'a gen = unit -> 'a option
type 'a sequence = ('a -> unit) -> unit
type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
include String
module type S = sig
type t
@ -388,6 +390,11 @@ module Split = struct
let right ~by s = try Some (right_exn ~by s) with Not_found -> None
end
let split_on_char c s: _ list =
Split.list_cpy ~by:(String.make 1 c) s
let split = Split.list_cpy
let compare_versions a b =
let of_int s = try Some (int_of_string s) with _ -> None in
let rec cmp_rec a b = match a(), b() with
@ -645,6 +652,21 @@ let exists p s =
try iter (fun c -> if p c then raise MyExit) s; false
with MyExit -> true
(* notion of whitespace for trim *)
let is_space_ = function
| ' ' | '\012' | '\n' | '\r' | '\t' -> true
| _ -> false
let ltrim s =
let i = ref 0 in
while !i < length s && is_space_ (unsafe_get s !i) do incr i done;
if !i > 0 then sub s !i (length s - !i) else s
let rtrim s =
let i = ref (length s-1) in
while !i >= 0 && is_space_ (unsafe_get s !i) do decr i done;
if !i < length s-1 then sub s 0 (!i+1) else s
let map2 f s1 s2 =
if length s1 <> length s2 then invalid_arg "CCString.map2";
init (String.length s1) (fun i -> f s1.[i] s2.[i])
@ -705,7 +727,16 @@ let lowercase_ascii = map CCChar.lowercase_ascii
#endif
let equal_caseless s1 s2: bool =
let char_lower c =
if c >= 'A' && c <= 'Z'
then Char.unsafe_chr (Char. code c + 32)
else c
in
String.length s1 = String.length s2 &&
for_all2
(fun c1 c2 -> char_lower c1 = char_lower c2)
s1 s2
let pp buf s =
Buffer.add_char buf '"';
@ -734,6 +765,10 @@ module Sub = struct
let length (_,_,l) = l
let get (s,i,l) j =
if j<0 || j>= l then invalid_arg "CCString.Sub.get";
String.unsafe_get s (i+j)
let blit (a1,i1,len1) o1 a2 o2 len =
if o1+len>len1 then invalid_arg "CCString.Sub.blit";
blit a1 (i1+o1) a2 o2 len

89
src/core/CCString.mli
View file

@ -48,6 +48,8 @@ end
(** {2 Strings} *)
include module type of String
val equal : string -> string -> bool
val compare : string -> string -> int
@ -112,8 +114,7 @@ val of_array : char array -> string
val to_array : string -> char array
val find : ?start:int -> sub:string -> string -> int
(** Find [sub] in string, returns its first index or [-1].
Should only be used with very small [sub] *)
(** Find [sub] in string, returns its first index or [-1]. *)
(*$= & ~printer:string_of_int
1 (find ~sub:"bc" "abcd")
@ -350,6 +351,32 @@ val exists : (char -> bool) -> string -> bool
include S with type t := string
val ltrim : t -> t
(** trim space on the left (see {!String.trim} for more details)
@since 1.2 *)
val rtrim : t -> t
(** trim space on the right (see {!String.trim} for more details)
@since 1.2 *)
(*$= & ~printer:id
"abc " (ltrim " abc ")
" abc" (rtrim " abc ")
*)
(*$Q
Q.(printable_string) (fun s -> \
String.trim s = (s |> ltrim |> rtrim))
Q.(printable_string) (fun s -> ltrim s = ltrim (ltrim s))
Q.(printable_string) (fun s -> rtrim s = rtrim (rtrim s))
Q.(printable_string) (fun s -> \
let s' = ltrim s in \
if s'="" then Q.assume_fail() else s'.[0] <> ' ')
Q.(printable_string) (fun s -> \
let s' = rtrim s in \
if s'="" then Q.assume_fail() else s'.[String.length s'-1] <> ' ')
*)
(** {2 Operations on 2 strings} *)
val map2 : (char -> char -> char) -> string -> string -> string
@ -399,6 +426,22 @@ val uppercase_ascii : string -> string
val lowercase_ascii : string -> string
(** See {!String}. @since 0.18 *)
val equal_caseless : string -> string -> bool
(** Comparison without respect to {b ascii} lowercase.
@since 1.2 *)
(*$T
equal_caseless "foo" "FoO"
equal_caseless "helLo" "HEllO"
*)
(*$Q
Q.(pair printable_string printable_string) (fun (s1,s2) -> \
equal_caseless s1 s2 = (lowercase_ascii s1=lowercase_ascii s2))
Q.(printable_string) (fun s -> equal_caseless s s)
Q.(printable_string) (fun s -> equal_caseless (uppercase_ascii s) s)
*)
(** {2 Finding}
A relatively efficient algorithm for finding sub-strings
@ -495,6 +538,25 @@ module Split : sig
*)
end
val split_on_char : char -> string -> string list
(** Split the string along the given char
@since 1.2 *)
(*$= & ~printer:Q.Print.(list string)
["a"; "few"; "words"; "from"; "our"; "sponsors"] \
(split_on_char ' ' "a few words from our sponsors")
*)
(*$Q
Q.(printable_string) (fun s -> \
let s = split_on_char ' ' s |> String.concat " " in \
s = (split_on_char ' ' s |> String.concat " "))
*)
val split : by:string -> string -> string list
(** Alias to {!Split.list_cpy}
@since 1.2 *)
(** {2 Utils} *)
val compare_versions : string -> string -> int
@ -570,6 +632,11 @@ module Sub : sig
val sub : t -> int -> int -> t
(** Sub-slice *)
val get : t -> int -> char
(** [get s i] gets the [i]-th element, or fails
@raise Invalid_argument if the index is not within [0... length -1]
@since 1.2 *)
include S with type t := t
(*$T
@ -583,4 +650,22 @@ module Sub : sig
let sub = Sub.make " abc " 1 ~len:3 in \
"\"abc\"" = (CCFormat.to_string Sub.print sub)
*)
(*$= & ~printer:(String.make 1)
'b' Sub.(get (make "abc" 1 ~len:2) 0)
'c' Sub.(get (make "abc" 1 ~len:2) 1)
*)
(*$QR
Q.(printable_string_of_size Gen.(3--10)) (fun s ->
let open Sequence.Infix in
begin
(0 -- (length s-2)
>|= fun i -> i, Sub.make s i ~len:(length s-i))
>>= fun (i,sub) ->
(0 -- (Sub.length sub-1) >|= fun j -> i,j,sub)
end
|> Sequence.for_all
(fun (i,j,sub) -> Sub.get sub j = s.[i+j]))
*)
end

16
src/core/META
View file

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

42
src/core/containers.ml
View file

@ -1,31 +1,17 @@
(* This file is free software, part of containers. See file "license" for more details. *)
(** {1 Drop-In replacement to Stdlib}
(** {1 Drop-In replacement to Stdlib} *)
This module is meant to be opened if one doesn't want to use both, say,
[List] and [CCList]. Instead, [List] is now an alias to
{[struct
include List
include CCList
end
]}
*)
module Array = struct
include Array
include CCArray
end
module ArrayLabels = struct
include ArrayLabels
include CCArrayLabels
end
module Array = CCArray
module ArrayLabels = CCArrayLabels
module Array_slice = CCArray_slice
module Bool = CCBool
module Char = struct
include Char
include (CCChar : module type of CCChar with type t := t)
end
module Equal = CCEqual
module Float = CCFloat
module Format = struct
include Format
@ -49,14 +35,8 @@ module Hashtbl = struct
module Make' = CCHashtbl.Make
end
module Heap = CCHeap
module List = struct
include List
include CCList
end
module ListLabels = struct
include ListLabels
include CCListLabels
end
module List = CCList
module ListLabels = CCListLabels
module Map = struct
module type OrderedType = Map.OrderedType
include CCMap
@ -65,10 +45,7 @@ module Option = CCOpt
module Ord = CCOrd
module Pair = CCPair
module Parse = CCParse
module Random = struct
include Random
include CCRandom
end
module Random = CCRandom
module Ref = CCRef
module Result = struct
include Result
@ -78,8 +55,5 @@ module Set = struct
module type OrderedType = Set.OrderedType
include CCSet
end
module String = struct
include String
include CCString
end
module String = CCString
module Vector = CCVector

3
src/core/containers.mldylib
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: dbfe65c79fab2a752c0ce01bf92e9b0d)
# DO NOT EDIT (digest: c777330f5cf164f02058ae02e3afa987)
CCVector
CCHeap
CCList
@ -27,5 +27,6 @@ CCParse
CCArray_slice
CCListLabels
CCArrayLabels
CCEqual
Containers
# OASIS_STOP

3
src/core/containers.mllib
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: dbfe65c79fab2a752c0ce01bf92e9b0d)
# DO NOT EDIT (digest: c777330f5cf164f02058ae02e3afa987)
CCVector
CCHeap
CCList
@ -27,5 +27,6 @@ CCParse
CCArray_slice
CCListLabels
CCArrayLabels
CCEqual
Containers
# OASIS_STOP

397
src/data/CCBV.ml
View file

@ -1,79 +1,124 @@
(* This file is free software, part of containers. See file "license" for more details. *)
(** {2 Imperative Bitvectors} *)
let __width = Sys.word_size - 2
let width_ = Sys.word_size - 1
(* int with [n] ones *)
let rec __shift bv n =
if n = 0
then bv
else __shift ((bv lsl 1) lor 1) (n-1)
(** We use OCamls ints to store the bits. We index them from the
least significant bit. We create masks to zero out the most significant
bits that aren't used to store values. This is necessary when we are
constructing or negating a bit vector. *)
let lsb_masks_ =
let a = Array.make (width_ + 1) 0 in
for i = 1 to width_ do
a.(i) <- a.(i-1) lor (1 lsl (i - 1))
done;
a
(* only ones *)
let __all_ones = __shift 0 __width
let all_ones_ = lsb_masks_.(width_)
(* count the 1 bits in [n]. See https://en.wikipedia.org/wiki/Hamming_weight *)
let count_bits_ n =
let rec recurse count n =
if n = 0 then count else recurse (count+1) (n land (n-1))
in
recurse 0 n
(* Can I access the "private" members in testing? $Q
(Q.int_bound (Sys.word_size - 1)) (fun i -> count_bits_ lsb_masks_.(i) = i)
*)
type t = {
mutable a : int array;
mutable size : int;
}
let empty () = { a = [| |] }
let length t = t.size
let empty () = { a = [| |] ; size = 0 }
let array_length_of_size size =
if size mod width_ = 0 then size / width_ else (size / width_) + 1
let create ~size default =
if size = 0 then { a = [| |] }
else begin
let n = if size mod __width = 0 then size / __width else (size / __width) + 1 in
let arr = if default
then Array.make n __all_ones
if size = 0 then { a = [| |]; size }
else (
let n = array_length_of_size size in
let a = if default
then Array.make n all_ones_
else Array.make n 0
in
(* adjust last bits *)
if default && (size mod __width) <> 0
then arr.(n-1) <- __shift 0 (size - (n-1) * __width);
{ a = arr }
end
let r = size mod width_ in
if default && r <> 0 then (
Array.unsafe_set a (n-1) lsb_masks_.(r);
);
{ a; size }
)
(*$Q
(Q.pair Q.small_int Q.bool) (fun (size, b) -> create ~size b |> length = size)
*)
(*$T
create ~size:17 true |> cardinal = 17
create ~size:32 true |> cardinal= 32
create ~size:32 true |> cardinal = 32
create ~size:132 true |> cardinal = 132
create ~size:200 false |> cardinal = 0
create ~size:29 true |> to_sorted_list = CCList.range 0 28
*)
let copy bv = { a=Array.copy bv.a; }
let copy bv = { bv with a = Array.copy bv.a }
(*$Q
(Q.list Q.small_int) (fun l -> \
let bv = of_list l in to_list bv = to_list (copy bv))
*)
let length bv = Array.length bv.a
let resize bv len =
if len > Array.length bv.a
then begin
let a' = Array.make len 0 in
Array.blit bv.a 0 a' 0 (Array.length bv.a);
bv.a <- a'
end
(* count the 1 bits in [n]. See https://en.wikipedia.org/wiki/Hamming_weight *)
let __count_bits n =
let rec recurse count n =
if n = 0 then count else recurse (count+1) (n land (n-1))
in
if n < 0
then recurse 1 (n lsr 1) (* only on unsigned *)
else recurse 0 n
let capacity bv = width_ * Array.length bv.a
let cardinal bv =
let n = ref 0 in
for i = 0 to length bv - 1 do
n := !n + __count_bits bv.a.(i)
done;
!n
if bv.size = 0 then 0
else (
let n = ref 0 in
for i = 0 to Array.length bv.a - 1 do
n := !n + count_bits_ bv.a.(i) (* MSB of last element are all 0 *)
done;
!n
)
(*$Q
Q.small_int (fun size -> create ~size true |> cardinal = size)
*)
let really_resize_ bv ~desired ~current size =
let a' = Array.make desired 0 in
Array.blit bv.a 0 a' 0 current;
bv.a <- a';
bv.size <- size
let grow_ bv size =
if size <= capacity bv (* within capacity *)
then bv.size <- size
else (
(* beyond capacity *)
let desired = array_length_of_size size in
let current = Array.length bv.a in
assert (desired > current);
really_resize_ bv ~desired ~current size
)
let shrink_ bv size =
let desired = array_length_of_size size in
let current = Array.length bv.a in
really_resize_ bv ~desired ~current size
let resize bv size =
if size < 0 then invalid_arg "resize: negative size";
if size < bv.size (* shrink *)
then shrink_ bv size
else if size = bv.size
then ()
else grow_ bv size
(*$R
let bv1 = CCBV.create ~size:87 true in
@ -87,18 +132,18 @@ let cardinal bv =
let is_empty bv =
try
for i = 0 to Array.length bv.a - 1 do
if bv.a.(i) <> 0 then raise Exit
if bv.a.(i) <> 0 then raise Exit (* MSB of last element are all 0 *)
done;
true
with Exit ->
false
let get bv i =
let n = i / __width in
if i < 0 then invalid_arg "get: negative index";
let n = i / width_ in
let i = i mod width_ in
if n < Array.length bv.a
then
let i = i - n * __width in
bv.a.(n) land (1 lsl i) <> 0
then (Array.unsafe_get bv.a n) land (1 lsl i) <> 0
else false
(*$R
@ -118,11 +163,13 @@ let get bv i =
*)
let set bv i =
let n = i / __width in
if n >= Array.length bv.a
then resize bv (n+1);
let i = i - n * __width in
bv.a.(n) <- bv.a.(n) lor (1 lsl i)
if i < 0 then invalid_arg "set: negative index"
else (
let n = i / width_ in
let j = i mod width_ in
if i >= bv.size then grow_ bv (i+1);
Array.unsafe_set bv.a n ((Array.unsafe_get bv.a n) lor (1 lsl j))
)
(*$T
let bv = create ~size:3 false in set bv 0; get bv 0
@ -130,40 +177,44 @@ let set bv i =
*)
let reset bv i =
let n = i / __width in
if n >= Array.length bv.a
then resize bv (n+1);
let i = i - n * __width in
bv.a.(n) <- bv.a.(n) land (lnot (1 lsl i))
if i < 0 then invalid_arg "reset: negative index"
else (
let n = i / width_ in
let j = i mod width_ in
if i >= bv.size then grow_ bv (i+1);
Array.unsafe_set bv.a n ((Array.unsafe_get bv.a n) land (lnot (1 lsl j)))
)
(*$T
let bv = create ~size:3 false in set bv 0; reset bv 0; not (get bv 0)
*)
let flip bv i =
let n = i / __width in
if n >= Array.length bv.a
then resize bv (n+1);
let i = i - n * __width in
bv.a.(n) <- bv.a.(n) lxor (1 lsl i)
if i < 0 then invalid_arg "reset: negative index"
else (
let n = i / width_ in
let j = i mod width_ in
if i >= bv.size then grow_ bv (i+1);
Array.unsafe_set bv.a n ((Array.unsafe_get bv.a n) lxor (1 lsl j))
)
(*$R
let bv = of_list [1;10; 11; 30] in
flip bv 10;
assert_equal [1;11;30] (to_sorted_list bv);
assert_equal false (get bv 10);
assert_equal ~printer:Q.Print.(list int) [1;11;30] (to_sorted_list bv);
assert_equal ~printer:Q.Print.bool false (get bv 10);
flip bv 10;
assert_equal true (get bv 10);
assert_equal ~printer:Q.Print.bool true (get bv 10);
flip bv 5;
assert_equal [1;5;10;11;30] (to_sorted_list bv);
assert_equal true (get bv 5);
assert_equal ~printer:Q.Print.(list int) [1;5;10;11;30] (to_sorted_list bv);
assert_equal ~printer:Q.Print.bool true (get bv 5);
flip bv 100;
assert_equal [1;5;10;11;30;100] (to_sorted_list bv);
assert_equal true (get bv 100);
assert_equal ~printer:Q.Print.(list int) [1;5;10;11;30;100] (to_sorted_list bv);
assert_equal ~printer:Q.Print.bool true (get bv 100);
*)
let clear bv =
Array.iteri (fun i _ -> bv.a.(i) <- 0) bv.a
Array.fill bv.a 0 (Array.length bv.a) 0
(*$T
let bv = create ~size:37 true in cardinal bv = 37 && (clear bv; cardinal bv= 0)
@ -178,31 +229,50 @@ let clear bv =
*)
let iter bv f =
let len = Array.length bv.a in
for n = 0 to len - 1 do
let j = __width * n in
for i = 0 to __width - 1 do
let len = array_length_of_size bv.size in
assert (len <= Array.length bv.a);
for n = 0 to len - 2 do
let j = width_ * n in
for i = 0 to width_ - 1 do
f (j+i) (bv.a.(n) land (1 lsl i) <> 0)
done
done
done;
if bv.size > 0 then (
let j = width_ * (len - 1) in
let r = bv.size mod width_ in
let final_length = if r = 0 then width_ else r in
for i = 0 to final_length - 1 do
f (j + i) (bv.a.(len - 1) land (1 lsl i) <> 0)
done
)
(*$R
let bv = create ~size:30 false in
set bv 5;
let n = ref 0 in
iter bv (fun i b -> incr n; assert_equal b (i=5));
assert_bool "at least 30" (!n >= 30)
List.iter
(fun size ->
let bv = create ~size false in
set bv 5;
let n = ref 0 in
iter bv (fun i b -> incr n; assert_equal b (i=5));
assert_bool "exactly size" (!n = size))
[30; 100; 255; 256;10_000]
*)
(*$= & ~printer:Q.Print.(list (pair int bool))
[] (iter (create ~size:0 false) |> Sequence.zip |> Sequence.to_list)
[0, false; 1, true; 2, false] \
(iter (let bv = create ~size:3 false in set bv 1; bv) |> Sequence.zip |> Sequence.to_list)
*)
(*$Q
Q.(small_int) (fun n -> \
assert (n >= 0); \
let bv = create ~size:n true in \
let l = iter bv |> Sequence.zip |> Sequence.to_list in \
List.length l = n && List.for_all (fun (_,b) -> b) l)
*)
let iter_true bv f =
let len = Array.length bv.a in
for n = 0 to len - 1 do
let j = __width * n in
for i = 0 to __width - 1 do
if bv.a.(n) land (1 lsl i) <> 0
then f (j+i)
done
done
iter bv (fun i b -> if b then f i else ())
(*$T
of_list [1;5;7] |> iter_true |> Sequence.to_list |> List.sort CCOrd.compare = [1;5;7]
@ -242,8 +312,9 @@ let to_list bv =
let to_sorted_list bv =
List.rev (to_list bv)
(* Interpret these as indices. *)
let of_list l =
let size = List.fold_left max 0 l in
let size = (List.fold_left max 0 l) + 1 in
let bv = create ~size false in
List.iter (fun i -> set bv i) l;
bv
@ -256,15 +327,19 @@ let of_list l =
exception FoundFirst of int
let first bv =
let first_exn bv =
try
iter_true bv (fun i -> raise (FoundFirst i));
raise Not_found
with FoundFirst i ->
i
let first bv =
try Some (first_exn bv)
with Not_found -> None
(*$T
of_list [50; 10; 17; 22; 3; 12] |> first = 3
of_list [50; 10; 17; 22; 3; 12] |> first = Some 3
*)
let filter bv p =
@ -276,18 +351,62 @@ let filter bv p =
to_sorted_list bv = [2;4;6]
*)
let negate_self b =
let len = Array.length b.a in
for n = 0 to len - 1 do
Array.unsafe_set b.a n (lnot (Array.unsafe_get b.a n))
done;
let r = b.size mod width_ in
if r <> 0 then
let l = Array.length b.a - 1 in
Array.unsafe_set b.a l (lsb_masks_.(r) land (Array.unsafe_get b.a l))
(*$T
let v = of_list [1;2;5;7;] in negate_self v; \
cardinal v = (List.length [0;3;4;6])
*)
let negate b =
let a = Array.map (lnot) b.a in
let r = b.size mod width_ in
if r <> 0 then (
let l = Array.length b.a - 1 in
Array.unsafe_set a l (lsb_masks_.(r) land (Array.unsafe_get a l))
);
{ a ; size = b.size }
(*$Q
Q.small_int (fun size -> create ~size false |> negate |> cardinal = size)
*)
(* Underlying size grows for union. *)
let union_into ~into bv =
if length into < length bv
then resize into (length bv);
let len = Array.length bv.a in
for i = 0 to len - 1 do
into.a.(i) <- into.a.(i) lor bv.a.(i)
if into.size < bv.size then (
grow_ into bv.size;
);
for i = 0 to (Array.length into.a) - 1 do
Array.unsafe_set into.a i
((Array.unsafe_get into.a i) lor (Array.unsafe_get bv.a i))
done
let union bv1 bv2 =
let bv = copy bv1 in
union_into ~into:bv bv2;
bv
(* To avoid potentially 2 passes, figure out what we need to copy. *)
let union b1 b2 =
if b1.size <= b2.size
then (
let into = copy b2 in
for i = 0 to (Array.length b1.a) - 1 do
Array.unsafe_set into.a i
((Array.unsafe_get into.a i) lor (Array.unsafe_get b1.a i))
done;
into
) else (
let into = copy b1 in
for i = 0 to (Array.length b1.a) - 1 do
Array.unsafe_set into.a i
((Array.unsafe_get into.a i) lor (Array.unsafe_get b2.a i))
done;
into
)
(*$R
let bv1 = CCBV.of_list [1;2;3;4] in
@ -302,22 +421,33 @@ let union bv1 bv2 =
union (of_list [1;2;3;4;5]) (of_list [7;3;5;6]) |> to_sorted_list = CCList.range 1 7
*)
(* Underlying size shrinks for inter. *)
let inter_into ~into bv =
let n = min (length into) (length bv) in
for i = 0 to n - 1 do
into.a.(i) <- into.a.(i) land bv.a.(i)
if into.size > bv.size then (
shrink_ into bv.size;
);
for i = 0 to (Array.length into.a) - 1 do
Array.unsafe_set into.a i
((Array.unsafe_get into.a i) land (Array.unsafe_get bv.a i))
done
let inter bv1 bv2 =
if length bv1 < length bv2
then
let bv = copy bv1 in
let () = inter_into ~into:bv bv2 in
bv
else
let bv = copy bv2 in
let () = inter_into ~into:bv bv1 in
bv
let inter b1 b2 =
if b1.size <= b2.size
then (
let into = copy b1 in
for i = 0 to (Array.length b1.a) - 1 do
Array.unsafe_set into.a i
((Array.unsafe_get into.a i) land (Array.unsafe_get b2.a i))
done;
into
) else (
let into = copy b2 in
for i = 0 to (Array.length b2.a) - 1 do
Array.unsafe_set into.a i
((Array.unsafe_get into.a i) land (Array.unsafe_get b1.a i))
done;
into
)
(*$T
inter (of_list [1;2;3;4]) (of_list [2;4;6;1]) |> to_sorted_list = [1;2;4]
@ -331,6 +461,28 @@ let inter bv1 bv2 =
assert_equal [3;4] l;
*)
(* Underlying size depends on the 'in_' set for diff, so we don't change
it's size! *)
let diff_into ~into bv =
let n = min (Array.length into.a) (Array.length bv.a) in
for i = 0 to n - 1 do
Array.unsafe_set into.a i
((Array.unsafe_get into.a i) land (lnot (Array.unsafe_get bv.a i)))
done
let diff in_ not_in =
let into = copy in_ in
diff_into ~into not_in;
into
(*$T
diff (of_list [1;2;3]) (of_list [1;2;3]) |> to_list = [];
diff (of_list [1;2;3]) (of_list [1;2;3;4]) |> to_list = [];
diff (of_list [1;2;3;4]) (of_list [1;2;3]) |> to_list = [4];
diff (of_list [1;2;3]) (of_list [1;2;3;400]) |> to_list = [];
diff (of_list [1;2;3;400]) (of_list [1;2;3]) |> to_list = [400];
*)
let select bv arr =
let l = ref [] in
begin try
@ -369,15 +521,22 @@ let selecti bv arr =
assert_equal [("b",1); ("c",2); ("f",5)] l;
*)
(*$T
selecti (of_list [1;4;3]) [| 0;1;2;3;4;5;6;7;8 |] \
|> List.sort CCOrd.compare = [1, 1; 3,3; 4,4]
(*$= & ~printer:Q.Print.(list (pair int int))
[1,1; 3,3; 4,4] (selecti (of_list [1;4;3]) [| 0;1;2;3;4;5;6;7;8 |] \
|> List.sort CCOrd.compare)
*)
type 'a sequence = ('a -> unit) -> unit
let to_seq bv k = iter_true bv k
(*$Q
Q.(small_int) (fun i -> \
let i = max 1 i in \
let bv = create ~size:i true in \
i = (to_seq bv |> Sequence.length))
*)
let of_seq seq =
let l = ref [] and maxi = ref 0 in
seq (fun x -> l := x :: !l; maxi := max !maxi x);

78
src/data/CCBV.mli
View file

@ -3,9 +3,13 @@
(** {2 Imperative Bitvectors}
The size of the bitvector is rounded up to the multiple of 30 or 62.
In other words some functions such as {!iter} might iterate on more
bits than what was originally asked for.
{b BREAKING CHANGES} since 1.2:
size is now stored along with the bitvector. Some functions have
a new signature.
The size of the bitvector used to be rounded up to the multiple of 30 or 62.
In other words some functions such as {!iter} would iterate on more
bits than what was originally asked for. This is not the case anymore.
*)
type t
@ -21,29 +25,39 @@ val copy : t -> t
(** Copy of bitvector *)
val cardinal : t -> int
(** Number of bits set *)
(** Number of bits set to one, seen as a set of bits. *)
val length : t -> int
(** Length of underlying array *)
(** Size of underlying bitvector.
This is not related to the underlying implementation.
Changed at 1.2
*)
val capacity : t -> int
(** The number of bits this bitvector can store without resizing.
@since 1.2 *)
val resize : t -> int -> unit
(** Resize the BV so that it has at least the given physical length
[resize bv n] should make [bv] able to store [(Sys.word_size - 2)* n] bits *)
(** Resize the BV so that it has the specified length. This can grow or shrink
the underlying bitvector.
@raise Invalid_arg on negative sizes. *)
val is_empty : t -> bool
(** Any bit set? *)
(** Are there any true bits? *)
val set : t -> int -> unit
(** Set i-th bit. *)
(** Set i-th bit, extending the bitvector if needed. *)
val get : t -> int -> bool
(** Is the i-th bit true? Returns false if the index is too high*)
val reset : t -> int -> unit
(** Set i-th bit to 0 *)
(** Set i-th bit to 0, extending the bitvector if needed. *)
val flip : t -> int -> unit
(** Flip i-th bit *)
(** Flip i-th bit, extending the bitvector if needed. *)
val clear : t -> unit
(** Set every bit to 0 *)
@ -62,21 +76,41 @@ val to_sorted_list : t -> int list
increasing order *)
val of_list : int list -> t
(** From a list of true bits *)
(** From a list of true bits.
val first : t -> int
(** First set bit, or
@raise Not_found if all bits are 0 *)
The bits are interpreted as indices into the returned bitvector, so the final
bitvector will have [length t] equal to 1 more than max of list indices. *)
val first : t -> int option
(** First set bit, or return None.
changed type at 1.2 *)
val first_exn : t -> int
(** First set bit, or
@raise Not_found if all bits are 0
@since 1.2 *)
val filter : t -> (int -> bool) -> unit
(** [filter bv p] only keeps the true bits of [bv] whose [index]
satisfies [p index] *)
val negate_self : t -> unit
(** [negate_self t] flips all of the bits in [t].
@since 1.2 *)
val negate : t -> t
(** [negate t] returns a copy of [t] with all of the bits flipped. *)
val union_into : into:t -> t -> unit
(** [union ~into bv] sets [into] to the union of itself and [bv]. *)
(** [union ~into bv] sets [into] to the union of itself and [bv].
Also updates the length of [into] to be at least [length bv]. *)
val inter_into : into:t -> t -> unit
(** [inter ~into bv] sets [into] to the intersection of itself and [bv] *)
(** [inter ~into bv] sets [into] to the intersection of itself and [bv]
Also updates the length of [into] to be at most [length bv]. *)
val union : t -> t -> t
(** [union bv1 bv2] returns the union of the two sets *)
@ -84,6 +118,16 @@ val union : t -> t -> t
val inter : t -> t -> t
(** [inter bv1 bv2] returns the intersection of the two sets *)
val diff_into : into:t -> t -> unit
(** [diff ~into t] Modify [into] with only the bits set but not in [t].
@since 1.2 *)
val diff : t -> t -> t
(** [diff t1 t2] Return those bits found [t1] but not in [t2].
@since 1.2 *)
val select : t -> 'a array -> 'a list
(** [select arr bv] selects the elements of [arr] whose index
corresponds to a true bit in [bv]. If [bv] is too short, elements of [arr]

34
src/data/CCIntMap.ml
View file

@ -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 Map specialized for Int keys} *)
@ -259,7 +237,7 @@ let update k f t =
let doubleton k1 v1 k2 v2 = add k1 v1 (singleton k2 v2)
let rec equal ~eq a b = match a, b with
let rec equal ~eq a b = a==b || match a, b with
| E, E -> true
| L (ka, va), L (kb, vb) -> ka = kb && eq va vb
| N (pa, sa, la, ra), N (pb, sb, lb, rb) ->
@ -308,7 +286,9 @@ let choose t =
try Some (choose_exn t)
with Not_found -> None
let rec union f t1 t2 = match t1, t2 with
let rec union f t1 t2 =
if t1==t2 then t1
else match t1, t2 with
| E, o | o, E -> o
| L (k, v), o
| o, L (k, v) ->
@ -361,7 +341,9 @@ let rec union f t1 t2 = match t1, t2 with
equal ~eq:(=) (of_list l) (union (fun _ a _ -> a) (of_list l)(of_list l)))
*)
let rec inter f a b = match a, b with
let rec inter f a b =
if a==b then a
else match a, b with
| E, _ | _, E -> E
| L (k, v), o
| o, L (k, v) ->

24
src/data/CCIntMap.mli
View file

@ -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 Map specialized for Int keys}

15
src/data/CCZipper.ml
View file

@ -15,8 +15,12 @@ let to_list (l,r) = List.rev_append l r
let to_rev_list (l,r) = List.rev_append r l
(*$inject
let zip_gen = Q.(pair (small_list int)(small_list int))
*)
(*$Q
Q.(pair (list small_int)(list small_int)) (fun z -> \
zip_gen (fun z -> \
to_list z = List.rev (to_rev_list z))
*)
@ -51,13 +55,18 @@ let modify f z = match z with
end
let is_focused = function
| _, [] -> true
| _ -> false
| _, _::_ -> true
| _, [] -> false
let focused = function
| _, x::_ -> Some x
| _, [] -> None
(*$Q
zip_gen (fun g -> \
is_focused g = (focused g |> CCOpt.is_some))
*)
let focused_exn = function
| _, x::_ -> x
| _, [] -> raise Not_found

2
src/threads/CCPool.ml
View file

@ -503,7 +503,7 @@ module Make(P : PARAM) = struct
let l =
CCList.(1--10_000)
|> List.rev_map
(fun x-> Fut.make (fun () -> Thread.yield(); fib (x mod 30)))
(fun x-> Fut.make (fun () -> Thread.yield(); fib (x mod 20)))
|> Fut.(map_l (fun x->x>|= fun x->x+1))
in
OUnit.assert_bool "not done" (Fut.state l = Waiting);

43
src/unix/CCUnix.ml
View file

@ -224,6 +224,49 @@ let establish_server sockaddr ~f =
continue := false
done
(** {6 Locking} *)
let with_file_lock ~kind filename f =
let lock_file = Unix.openfile filename [Unix.O_CREAT; Unix.O_WRONLY] 0o644 in
let lock_action = match kind with
| `Read -> Unix.F_RLOCK
| `Write -> Unix.F_LOCK
in
Unix.lockf lock_file lock_action 0;
try
let x = f () in
Unix.lockf lock_file Unix.F_ULOCK 0;
Unix.close lock_file;
x
with e ->
Unix.lockf lock_file Unix.F_ULOCK 0;
Unix.close lock_file;
raise e
(*$R
let m = 200 in
let n = 50 in
let write_atom filename s =
with_file_lock ~kind:`Write filename
(fun () ->
CCIO.with_out ~flags:[Open_append; Open_creat]
filename (fun oc -> output_string oc s; flush oc))
in
let f filename =
for j=1 to m do
write_atom filename "foo\n"
done
in
CCIO.File.with_temp ~prefix:"containers_" ~suffix:".txt"
(fun filename ->
let a = Array.init n (fun _ -> Thread.create f filename) in
Array.iter Thread.join a;
let lines = CCIO.with_in filename CCIO.read_lines_l in
assert_equal ~printer:string_of_int (n * m) (List.length lines);
assert_bool "all valid" (List.for_all ((=) "foo") lines))
*)
module Infix = struct
let (?|) fmt = call_full fmt

9
src/unix/CCUnix.mli
View file

@ -161,6 +161,15 @@ val establish_server : Unix.sockaddr -> f:(in_channel -> out_channel -> _) -> un
The callback should raise {!ExitServer} to stop the loop.
@since 0.16 *)
val with_file_lock : kind:[`Read|`Write] -> string -> (unit -> 'a) -> 'a
(** [with_file_lock ~kind filename f] puts a lock on the offset 0
of the file named [filename], calls [f] and returns its result after
the file is unlocked. If [f ()] raises an exception the exception is
re-raised after the file is unlocked.
@param kind specifies whether the lock is read-only or read-write.
@since 1.2 *)
(** {2 Infix Functions} *)
module Infix : sig