diff --git a/AUTHORS.adoc b/AUTHORS.adoc index 007ed5ce..c4c632bc 100644 --- a/AUTHORS.adoc +++ b/AUTHORS.adoc @@ -18,3 +18,6 @@ - Roma Sokolov (@little-arhat) - Malcolm Matalka (`orbitz`) - David Sheets (@dsheets) +- Glenn Slotte (glennsl) +- @LemonBoy +- Leonid Rozenberg (@rleonid) \ No newline at end of file diff --git a/CHANGELOG.adoc b/CHANGELOG.adoc index 65cc9a2c..9a36f8c5 100644 --- a/CHANGELOG.adoc +++ b/CHANGELOG.adoc @@ -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**: diff --git a/Makefile b/Makefile index a654330d..e55727c8 100644 --- a/Makefile +++ b/Makefile @@ -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: diff --git a/README.adoc b/README.adoc index 23e5502b..41b378f3 100644 --- a/README.adoc +++ b/README.adoc @@ -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]] diff --git a/_oasis b/_oasis index 2b22996a..b8b271a6 100644 --- a/_oasis +++ b/_oasis @@ -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 diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index 9fb59a6c..c6a59626 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -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 diff --git a/containers.odocl b/containers.odocl index 0bf169b2..8cd51a0d 100644 --- a/containers.odocl +++ b/containers.odocl @@ -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 diff --git a/doc/intro.txt b/doc/intro.txt index 461a5ece..72eb19d2 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -30,6 +30,7 @@ CCArrayLabels CCArray_slice CCBool CCChar +CCEqual CCFloat CCFormat CCFun diff --git a/opam b/opam index 826cbb77..a789d92f 100644 --- a/opam +++ b/opam @@ -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: [ diff --git a/setup.ml b/setup.ml index bc9ad8af..a49334b5 100644 --- a/setup.ml +++ b/setup.ml @@ -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 *) diff --git a/src/core/CCArray.ml b/src/core/CCArray.ml index 85e152c8..44d93b16 100644 --- a/src/core/CCArray.ml +++ b/src/core/CCArray.ml @@ -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) diff --git a/src/core/CCArray.mli b/src/core/CCArray.mli index 611d7b9f..e8d5c8e2 100644 --- a/src/core/CCArray.mli +++ b/src/core/CCArray.mli @@ -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 diff --git a/src/core/CCArrayLabels.ml b/src/core/CCArrayLabels.ml index 85e152c8..f6573cb8 100644 --- a/src/core/CCArrayLabels.ml +++ b/src/core/CCArrayLabels.ml @@ -18,6 +18,8 @@ type 'a printer = Format.formatter -> 'a -> unit (** {2 Arrays} *) +include ArrayLabels + type 'a t = 'a array let empty = [| |] diff --git a/src/core/CCArrayLabels.mli b/src/core/CCArrayLabels.mli index 36f3d4ea..fdf3784b 100644 --- a/src/core/CCArrayLabels.mli +++ b/src/core/CCArrayLabels.mli @@ -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 diff --git a/src/core/CCArray_slice.ml b/src/core/CCArray_slice.ml index e8ddac56..fcbe1204 100644 --- a/src/core/CCArray_slice.ml +++ b/src/core/CCArray_slice.ml @@ -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 \ diff --git a/src/core/CCChar.ml b/src/core/CCChar.ml index 848594a0..55900bd6 100644 --- a/src/core/CCChar.ml +++ b/src/core/CCChar.ml @@ -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 diff --git a/src/core/CCChar.mli b/src/core/CCChar.mli index 55ebca0d..2100a900 100644 --- a/src/core/CCChar.mli +++ b/src/core/CCChar.mli @@ -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 diff --git a/src/core/CCEqual.ml b/src/core/CCEqual.ml new file mode 100644 index 00000000..f879bd05 --- /dev/null +++ b/src/core/CCEqual.ml @@ -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 diff --git a/src/core/CCEqual.mli b/src/core/CCEqual.mli new file mode 100644 index 00000000..94230bfa --- /dev/null +++ b/src/core/CCEqual.mli @@ -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 diff --git a/src/core/CCFloat.ml b/src/core/CCFloat.ml index c835b400..2e7fcc41 100644 --- a/src/core/CCFloat.ml +++ b/src/core/CCFloat.ml @@ -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 diff --git a/src/core/CCFloat.mli b/src/core/CCFloat.mli index 92cc925b..a0c25034 100644 --- a/src/core/CCFloat.mli +++ b/src/core/CCFloat.mli @@ -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 *) diff --git a/src/core/CCFormat.ml b/src/core/CCFormat.ml index a4850947..431f7850 100644 --- a/src/core/CCFormat.ml +++ b/src/core/CCFormat.ml @@ -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 j1CCFormat.sprintf "%S" s) + "a\nb\nc" (sprintf_no_color "@[%a@]%!" text "a b c") + "a b\nc" (sprintf_no_color "@[%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 diff --git a/src/core/CCFormat.mli b/src/core/CCFormat.mli index 3880dcfd..f55662e4 100644 --- a/src/core/CCFormat.mli +++ b/src/core/CCFormat.mli @@ -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 diff --git a/src/core/CCInt.ml b/src/core/CCInt.ml index d4a3bae4..eb37fccc 100644 --- a/src/core/CCInt.ml +++ b/src/core/CCInt.ml @@ -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 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 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 diff --git a/src/core/CCInt.mli b/src/core/CCInt.mli index 88d4abd7..30f9dddc 100644 --- a/src/core/CCInt.mli +++ b/src/core/CCInt.mli @@ -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 diff --git a/src/core/CCInt64.mli b/src/core/CCInt64.mli index f53b2a5f..fbec7199 100644 --- a/src/core/CCInt64.mli +++ b/src/core/CCInt64.mli @@ -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 diff --git a/src/core/CCList.ml b/src/core/CCList.ml index d5bb6fad..82eb60a9 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -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 diff --git a/src/core/CCList.mli b/src/core/CCList.mli index 3d5a316b..686d154c 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -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 diff --git a/src/core/CCListLabels.ml b/src/core/CCListLabels.ml index d5bb6fad..61df2913 100644 --- a/src/core/CCListLabels.ml +++ b/src/core/CCListLabels.ml @@ -7,6 +7,8 @@ let lsort l = List.sort Pervasives.compare l *) +include ListLabels + type 'a t = 'a list let empty = [] diff --git a/src/core/CCListLabels.mli b/src/core/CCListLabels.mli index bfa81d21..09125956 100644 --- a/src/core/CCListLabels.mli +++ b/src/core/CCListLabels.mli @@ -3,6 +3,8 @@ (** {1 complements to list} *) +include module type of ListLabels + type 'a t = 'a list val empty : 'a t diff --git a/src/core/CCOpt.ml b/src/core/CCOpt.ml index 355473c2..36154caf 100644 --- a/src/core/CCOpt.ml +++ b/src/core/CCOpt.ml @@ -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 (>>=) = (>>=) diff --git a/src/core/CCOpt.mli b/src/core/CCOpt.mli index 1281fbe1..c5caa5a6 100644 --- a/src/core/CCOpt.mli +++ b/src/core/CCOpt.mli @@ -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 diff --git a/src/core/CCRandom.ml b/src/core/CCRandom.ml index be36f30e..bcc83111 100644 --- a/src/core/CCRandom.ml +++ b/src/core/CCRandom.ml @@ -3,6 +3,8 @@ (** {1 Random Generators} *) +include Random + type state = Random.State.t type 'a t = state -> 'a diff --git a/src/core/CCRandom.mli b/src/core/CCRandom.mli index e43da782..ffb32cfb 100644 --- a/src/core/CCRandom.mli +++ b/src/core/CCRandom.mli @@ -3,6 +3,8 @@ (** {1 Random Generators} *) +include module type of Random + type state = Random.State.t type 'a t = state -> 'a diff --git a/src/core/CCResult.ml b/src/core/CCResult.ml index 9e4228ea..0d00755c 100644 --- a/src/core/CCResult.ml +++ b/src/core/CCResult.ml @@ -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 diff --git a/src/core/CCResult.mli b/src/core/CCResult.mli index f236274c..c0e7b63e 100644 --- a/src/core/CCResult.mli +++ b/src/core/CCResult.mli @@ -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 diff --git a/src/core/CCString.cppo.ml b/src/core/CCString.cppo.ml index 0758d71c..9fa460c8 100644 --- a/src/core/CCString.cppo.ml +++ b/src/core/CCString.cppo.ml @@ -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 diff --git a/src/core/CCString.mli b/src/core/CCString.mli index 85aa5a6d..83fde8c7 100644 --- a/src/core/CCString.mli +++ b/src/core/CCString.mli @@ -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 diff --git a/src/core/META b/src/core/META index 34265303..2b4a288b 100644 --- a/src/core/META +++ b/src/core/META @@ -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" diff --git a/src/core/containers.ml b/src/core/containers.ml index 1373d929..6c3234b5 100644 --- a/src/core/containers.ml +++ b/src/core/containers.ml @@ -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 diff --git a/src/core/containers.mldylib b/src/core/containers.mldylib index 98fd847b..4a124ca1 100644 --- a/src/core/containers.mldylib +++ b/src/core/containers.mldylib @@ -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 diff --git a/src/core/containers.mllib b/src/core/containers.mllib index 98fd847b..4a124ca1 100644 --- a/src/core/containers.mllib +++ b/src/core/containers.mllib @@ -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 diff --git a/src/data/CCBV.ml b/src/data/CCBV.ml index a9704052..74ea2e7a 100644 --- a/src/data/CCBV.ml +++ b/src/data/CCBV.ml @@ -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); diff --git a/src/data/CCBV.mli b/src/data/CCBV.mli index 36bb217f..247aafee 100644 --- a/src/data/CCBV.mli +++ b/src/data/CCBV.mli @@ -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] diff --git a/src/data/CCIntMap.ml b/src/data/CCIntMap.ml index d076769a..2fde434e 100644 --- a/src/data/CCIntMap.ml +++ b/src/data/CCIntMap.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 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) -> diff --git a/src/data/CCIntMap.mli b/src/data/CCIntMap.mli index 7518fa4d..ab7445ea 100644 --- a/src/data/CCIntMap.mli +++ b/src/data/CCIntMap.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 Map specialized for Int keys} diff --git a/src/data/CCZipper.ml b/src/data/CCZipper.ml index 44a92db4..b978838b 100644 --- a/src/data/CCZipper.ml +++ b/src/data/CCZipper.ml @@ -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 diff --git a/src/threads/CCPool.ml b/src/threads/CCPool.ml index 2bd4101a..1863e2a8 100644 --- a/src/threads/CCPool.ml +++ b/src/threads/CCPool.ml @@ -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); diff --git a/src/unix/CCUnix.ml b/src/unix/CCUnix.ml index 216522a3..4d2b4d55 100644 --- a/src/unix/CCUnix.ml +++ b/src/unix/CCUnix.ml @@ -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 diff --git a/src/unix/CCUnix.mli b/src/unix/CCUnix.mli index 237df841..3515f0de 100644 --- a/src/unix/CCUnix.mli +++ b/src/unix/CCUnix.mli @@ -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