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

reindentation

Browse source
This commit is contained in:
Simon Cruanes 2017-01-25 00:03:30 +01:00
parent 416d19a763
commit 03fd42e67d
77 changed files with 1673 additions and 1673 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

48
src/core/CCArray.ml
View file

@ -62,8 +62,8 @@ let fold_while f acc a =
if i < Array.length a then
let acc, cont = f acc a.(i) in
match cont with
| `Stop -> acc
| `Continue -> fold_while_i f acc (i+1)
| `Stop -> acc
| `Continue -> fold_while_i f acc (i+1)
else acc
in fold_while_i f acc 0
@ -106,7 +106,7 @@ let sorted cmp a =
(*$= & ~cmp:(=) ~printer:Q.Print.(array int)
[||] (sorted Pervasives.compare [||])
[|0;1;2;3;4|] (sorted Pervasives.compare [|3;2;1;4;0|])
*)
*)
(*$Q
Q.(array int) (fun a -> \
@ -160,7 +160,7 @@ let rev a =
rev [| 1; 2; 3 |] = [| 3; 2; 1 |]
rev [| 1; 2; |] = [| 2; 1 |]
rev [| |] = [| |]
*)
*)
let rec find_aux f a i =
if i = Array.length a then None
@ -229,27 +229,27 @@ let flat_map f a =
let rec _lookup_rec ~cmp k a i j =
if i>j then raise Not_found
else if i=j
then if cmp k a.(i) = 0
then i
else raise Not_found
then if cmp k a.(i) = 0
then i
else raise Not_found
else
let middle = (j+i)/2 in
match cmp k a.(middle) with
| 0 -> middle
| n when n<0 -> _lookup_rec ~cmp k a i (middle-1)
| _ -> _lookup_rec ~cmp k a (middle+1) j
| 0 -> middle
| n when n<0 -> _lookup_rec ~cmp k a i (middle-1)
| _ -> _lookup_rec ~cmp k a (middle+1) j
let _lookup_exn ~cmp k a i j =
if i>j then raise Not_found;
match cmp k a.(i) with
| 0 -> i
| n when n<0 -> raise Not_found (* too low *)
| _ when i=j -> raise Not_found (* too high *)
| _ ->
| 0 -> i
| n when n<0 -> raise Not_found (* too low *)
| _ when i=j -> raise Not_found (* too high *)
| _ ->
match cmp k a.(j) with
| 0 -> j
| n when n<0 -> _lookup_rec ~cmp k a (i+1) (j-1)
| _ -> raise Not_found (* too high *)
| 0 -> j
| n when n<0 -> _lookup_rec ~cmp k a (i+1) (j-1)
| _ -> raise Not_found (* too high *)
let lookup_exn ?(cmp=Pervasives.compare) k a =
_lookup_exn ~cmp k a 0 (Array.length a-1)
@ -371,8 +371,8 @@ let (--) i j =
let (--^) i j =
if i=j then [| |]
else if i>j
then Array.init (i-j) (fun k -> i-k)
else Array.init (j-i) (fun k -> i+k)
then Array.init (i-j) (fun k -> i-k)
else Array.init (j-i) (fun k -> i+k)
(*$Q
Q.(pair small_int small_int) (fun (a,b) -> \
@ -540,7 +540,7 @@ module SortGeneric(A : MONO_ARRAY) = struct
in
let rand = Rand.make seed_ in
(* sort slice.
There is a chance that the two pivots are equal, but it's unlikely. *)
There is a chance that the two pivots are equal, but it's unlikely. *)
let rec sort_slice_ ~st a i j =
if j-i>10 then (
st.l <- i;
@ -565,7 +565,7 @@ module SortGeneric(A : MONO_ARRAY) = struct
swap_ a st.k st.g;
st.g <- st.g - 1;
(* the element swapped from the right might be in the first situation.
that is, < p (we know it's <= q already) *)
that is, < p (we know it's <= q already) *)
if cmp (A.get a st.k) p < 0 then (
if st.k <> st.l then swap_ a st.k st.l;
st.l <- st.l + 1
@ -588,9 +588,9 @@ end
let sort_generic (type arr)(type elt)
(module A : MONO_ARRAY with type t = arr and type elt = elt)
?(cmp=Pervasives.compare) a
=
(module A : MONO_ARRAY with type t = arr and type elt = elt)
?(cmp=Pervasives.compare) a
=
let module S = SortGeneric(A) in
S.sort ~cmp a

64
src/core/CCArray_slice.ml
View file

@ -75,12 +75,12 @@ let rec _compare cmp a1 i1 j1 a2 i2 j2 =
if i1 = j1
then if i2=j2 then 0 else -1
else if i2=j2
then 1
else
let c = cmp a1.(i1) a2.(i2) in
if c = 0
then _compare cmp a1 (i1+1) j1 a2 (i2+1) j2
else c
then 1
else
let c = cmp a1.(i1) a2.(i2) in
if c = 0
then _compare cmp a1 (i1+1) j1 a2 (i2+1) j2
else c
let equal eq a b =
length a = length b && _equal eq a.arr a.i a.j b.arr b.i b.j
@ -105,8 +105,8 @@ let fold_while f acc a =
if i < Array.length a.arr && i < a.j then
let acc, cont = f acc a.arr.(i) in
match cont with
| `Stop -> acc
| `Continue -> fold_while_i f acc (i+1)
| `Stop -> acc
| `Continue -> fold_while_i f acc (i+1)
else acc
in fold_while_i f acc a.i
@ -157,44 +157,44 @@ let rec _find f a i j =
let rec _lookup_rec ~cmp k a i j =
if i>j then raise Not_found
else if i=j
then if cmp k a.(i) = 0
then i
else raise Not_found
then if cmp k a.(i) = 0
then i
else raise Not_found
else
let middle = (j+i)/2 in
match cmp k a.(middle) with
| 0 -> middle
| n when n<0 -> _lookup_rec ~cmp k a i (middle-1)
| _ -> _lookup_rec ~cmp k a (middle+1) j
| 0 -> middle
| n when n<0 -> _lookup_rec ~cmp k a i (middle-1)
| _ -> _lookup_rec ~cmp k a (middle+1) j
let _lookup_exn ~cmp k a i j =
if i>j then raise Not_found;
match cmp k a.(i) with
| 0 -> i
| n when n<0 -> raise Not_found (* too low *)
| _ when i=j -> raise Not_found (* too high *)
| _ ->
| 0 -> i
| n when n<0 -> raise Not_found (* too low *)
| _ when i=j -> raise Not_found (* too high *)
| _ ->
match cmp k a.(j) with
| 0 -> j
| n when n<0 -> _lookup_rec ~cmp k a (i+1) (j-1)
| _ -> raise Not_found (* too high *)
| 0 -> j
| n when n<0 -> _lookup_rec ~cmp k a (i+1) (j-1)
| _ -> raise Not_found (* too high *)
let bsearch_ ~cmp x arr i j =
let rec aux i j =
if i > j
then `Just_after j
else
let middle = i + (j - i) / 2 in (* avoid overflow *)
match cmp x arr.(middle) with
then `Just_after j
else
let middle = i + (j - i) / 2 in (* avoid overflow *)
match cmp x arr.(middle) with
| 0 -> `At middle
| n when n<0 -> aux i (middle - 1)
| _ -> aux (middle + 1) j
in
if i>=j then `Empty
else match cmp arr.(i) x, cmp arr.(j) x with
| n, _ when n>0 -> `All_bigger
| _, n when n<0 -> `All_lower
| _ -> aux i j
| n, _ when n>0 -> `All_bigger
| _, n when n<0 -> `All_lower
| _ -> aux i j
let rec _for_all p a i j =
i = j || (p a.(i) && _for_all p a (i+1) j)
@ -267,7 +267,7 @@ let rec _to_klist a i j () =
let reverse_in_place a = _reverse_in_place a.arr a.i ~len:(length a)
(*$T
let a = 1--6 in let s = make a 2 ~len:3 in \
let a = 1--6 in let s = make a 2 ~len:3 in \
reverse_in_place s; a = [| 1; 2; 5; 4; 3; 6 |]
*)
@ -343,7 +343,7 @@ let find_idx p a =
(*$=
(Some (1,"c")) (find_idx ((=) "c") (make [| "a"; "b"; "c" |] 1 2))
*)
*)
let lookup_exn ?(cmp=Pervasives.compare) k a =
_lookup_exn ~cmp k a.arr a.i (a.j-1) - a.i
@ -354,7 +354,7 @@ let lookup ?(cmp=Pervasives.compare) k a =
(*$=
(Some 1) (lookup "c" (make [| "a"; "b"; "c" |] 1 2))
*)
*)
let bsearch ?(cmp=Pervasives.compare) k a =
match bsearch_ ~cmp k a.arr a.i (a.j - 1) with
@ -373,7 +373,7 @@ let exists2 p a b =
_exists2 p a.arr b.arr a.i b.i ~len:(min (length a) (length b))
(*$T
exists2 (=) (make [| 1;2;3;4 |] 1 ~len:2) (make [| 0;1;3;4 |] 1 ~len:3)
exists2 (=) (make [| 1;2;3;4 |] 1 ~len:2) (make [| 0;1;3;4 |] 1 ~len:3)
*)
let _iter2 f a b i j ~len =

2
src/core/CCChar.ml
View file

@ -2,7 +2,7 @@
(** {1 Utils around char}
@since 0.14 *)
@since 0.14 *)
type t = char

2
src/core/CCChar.mli
View file

@ -2,7 +2,7 @@
(** {1 Utils around char}
@since 0.14 *)
@since 0.14 *)
type t = char

2
src/core/CCFloat.mli
View file

@ -2,7 +2,7 @@
(* This file is free software, part of containers. See file "license" for more details. *)
(** {1 Basic Float functions}
@since 0.6.1 *)
@since 0.6.1 *)
type t = float
type fpclass = Pervasives.fpclass =

20
src/core/CCFormat.ml
View file

@ -40,12 +40,12 @@ let string_quoted fmt s = Format.fprintf fmt "\"%s\"" s
let list ?(sep=return ",@ ") pp fmt l =
let rec pp_list l = match l with
| x::((_::_) as l) ->
pp fmt x;
sep fmt ();
pp_list l
| x::[] -> pp fmt x
| [] -> ()
| x::((_::_) as l) ->
pp fmt x;
sep fmt ();
pp_list l
| x::[] -> pp fmt x
| [] -> ()
in
pp_list l
@ -152,7 +152,7 @@ let tee a b =
Format.fprintf fmt "coucou@.";
assert_equal ~printer:CCFun.id "coucou\n" (Buffer.contents buf1);
assert_equal ~printer:CCFun.id "coucou\n" (Buffer.contents buf2);
*)
*)
let to_file filename format =
let oc = open_out filename in
@ -262,9 +262,9 @@ let set_color_tag_handling ppf =
let functions = pp_get_formatter_tag_functions ppf () in
let st = Stack.create () in (* stack of styles *)
let functions' = {functions with
mark_open_tag=(mark_open_tag st ~or_else:functions.mark_open_tag);
mark_close_tag=(mark_close_tag st ~or_else:functions.mark_close_tag);
} in
mark_open_tag=(mark_open_tag st ~or_else:functions.mark_open_tag);
mark_close_tag=(mark_close_tag st ~or_else:functions.mark_close_tag);
} in
pp_set_mark_tags ppf true; (* enable tags *)
pp_set_formatter_tag_functions ppf functions'

32
src/core/CCFormat.mli
View file

@ -3,7 +3,7 @@
(** {1 Helpers for Format}
@since 0.8 *)
@since 0.8 *)
type 'a sequence = ('a -> unit) -> unit
@ -48,7 +48,7 @@ val opt : 'a printer -> 'a option printer
val pair : ?sep:unit printer -> 'a printer -> 'b printer -> ('a * 'b) printer
val triple : ?sep:unit printer -> 'a printer -> 'b printer -> 'c printer -> ('a * 'b * 'c) printer
val quad : ?sep:unit printer -> 'a printer -> 'b printer ->
'c printer -> 'd printer -> ('a * 'b * 'c * 'd) printer
'c printer -> 'd printer -> ('a * 'b * 'c * 'd) printer
val within : string -> string -> 'a printer -> 'a printer
(** [within a b p] wraps [p] inside the strings [a] and [b]. Convenient,
@ -105,13 +105,13 @@ val some : 'a printer -> 'a option printer
(** {2 ANSI codes}
Use ANSI escape codes https://en.wikipedia.org/wiki/ANSI_escape_code
to put some colors on the terminal.
Use ANSI escape codes https://en.wikipedia.org/wiki/ANSI_escape_code
to put some colors on the terminal.
This uses {b tags} in format strings to specify the style. Current styles
are the following:
This uses {b tags} in format strings to specify the style. Current styles
are the following:
{ul
{ul
{- "reset" resets style}
{- "black" }
{- "red" }
@ -130,19 +130,19 @@ val some : 'a printer -> 'a option printer
{- "Magenta" bold magenta }
{- "Cyan" bold cyan }
{- "White" bold white }
}
}
Example:
Example:
{[
set_color_default true;;
{[
set_color_default true;;
Format.printf
"what is your @{<White>favorite color@}? @{<blue>blue@}! No, @{<red>red@}! Ahhhhhhh@.";;
]}
Format.printf
"what is your @{<White>favorite color@}? @{<blue>blue@}! No, @{<red>red@}! Ahhhhhhh@.";;
]}
{b status: experimental}
@since 0.15 *)
{b status: experimental}
@since 0.15 *)
val set_color_tag_handling : t -> unit
(** adds functions to support color tags to the given formatter.

14
src/core/CCFun.cppo.ml
View file

@ -8,22 +8,22 @@
external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply"
external (@@) : ('a -> 'b) -> 'a -> 'b = "%apply"
#else
#else
let (|>) x f = f x
let (|>) x f = f x
let (@@) f x = f x
#endif
#endif
#if OCAML_MAJOR >= 4 && OCAML_MINOR >= 3
#if OCAML_MAJOR >= 4 && OCAML_MINOR >= 3
let opaque_identity = Sys.opaque_identity
#else
#else
let opaque_identity x = x
let opaque_identity x = x
#endif
#endif
let compose f g x = g (f x)

2
src/core/CCFun.mli
View file

@ -73,7 +73,7 @@ val opaque_identity : 'a -> 'a
(** {2 Monad}
Functions with a fixed domain are monads in their codomain *)
Functions with a fixed domain are monads in their codomain *)
module Monad(X : sig type t end) : sig
type 'a t = X.t -> 'a

36
src/core/CCHashtbl.ml
View file

@ -87,10 +87,10 @@ let of_list l =
let update tbl ~f ~k =
let v = get tbl k in
match v, f k v with
| None, None -> ()
| None, Some v' -> Hashtbl.add tbl k v'
| Some _, Some v' -> Hashtbl.replace tbl k v'
| Some _, None -> Hashtbl.remove tbl k
| None, None -> ()
| None, Some v' -> Hashtbl.add tbl k v'
| Some _, Some v' -> Hashtbl.replace tbl k v'
| Some _, None -> Hashtbl.remove tbl k
(*$R
let tbl = Hashtbl.create 32 in
@ -108,11 +108,11 @@ let print pp_k pp_v fmt m =
let first = ref true in
Hashtbl.iter
(fun k v ->
if !first then first := false else Format.pp_print_string fmt ", ";
pp_k fmt k;
Format.pp_print_string fmt " -> ";
pp_v fmt v;
Format.pp_print_cut fmt ()
if !first then first := false else Format.pp_print_string fmt ", ";
pp_k fmt k;
Format.pp_print_string fmt " -> ";
pp_v fmt v;
Format.pp_print_cut fmt ()
) m;
Format.fprintf fmt "}@]"
@ -272,10 +272,10 @@ module Make(X : Hashtbl.HashedType)
let update tbl ~f ~k =
let v = get tbl k in
match v, f k v with
| None, None -> ()
| None, Some v' -> add tbl k v'
| Some _, Some v' -> replace tbl k v'
| Some _, None -> remove tbl k
| None, None -> ()
| None, Some v' -> add tbl k v'
| Some _, Some v' -> replace tbl k v'
| Some _, None -> remove tbl k
let to_seq tbl k = iter (fun key v -> k (key,v)) tbl
@ -308,11 +308,11 @@ module Make(X : Hashtbl.HashedType)
let first = ref true in
iter
(fun k v ->
if !first then first := false else Format.pp_print_string fmt ", ";
pp_k fmt k;
Format.pp_print_string fmt " -> ";
pp_v fmt v;
Format.pp_print_cut fmt ()
if !first then first := false else Format.pp_print_string fmt ", ";
pp_k fmt k;
Format.pp_print_string fmt " -> ";
pp_v fmt v;
Format.pp_print_cut fmt ()
) m;
Format.fprintf fmt "}@]"
end

2
src/core/CCHashtbl.mli
View file

@ -3,7 +3,7 @@
(** {1 Extension to the standard Hashtbl}
@since 0.4 *)
@since 0.4 *)
type 'a sequence = ('a -> unit) -> unit
type 'a eq = 'a -> 'a -> bool

46
src/core/CCHeap.ml
View file

@ -183,20 +183,20 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct
| N (r, _, _, _) -> r
(* Make a balanced node labelled with [x], and subtrees [a] and [b].
We ensure that the right child's rank is ≤ to the rank of the
left child (leftist property). The rank of the resulting node
is the length of the rightmost path. *)
We ensure that the right child's rank is ≤ to the rank of the
left child (leftist property). The rank of the resulting node
is the length of the rightmost path. *)
let _make_node x a b =
if _rank a >= _rank b
then N (_rank b + 1, x, a, b)
else N (_rank a + 1, x, b, a)
then N (_rank b + 1, x, a, b)
else N (_rank a + 1, x, b, a)
let rec merge t1 t2 =
match t1, t2 with
| t, E -> t
| E, t -> t
| N (_, x, a1, b1), N (_, y, a2, b2) ->
if E.leq x y
| t, E -> t
| E, t -> t
| N (_, x, a1, b1), N (_, y, a2, b2) ->
if E.leq x y
then _make_node x a1 (merge b1 t2)
else _make_node y a2 (merge t1 b2)
@ -209,7 +209,7 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct
| E -> E
| N(_, x, l, r) when p x -> _make_node x (filter p l) (filter p r)
| N(_, _, l, r) ->
merge (filter p l) (filter p r)
merge (filter p l) (filter p r)
let find_min_exn = function
| E -> raise Empty
@ -234,9 +234,9 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct
let rec fold f acc h = match h with
| E -> acc
| N (_, x, a, b) ->
let acc = f acc x in
let acc = fold f acc a in
fold f acc b
let acc = f acc x in
let acc = fold f acc a in
fold f acc b
let rec size = function
| E -> 0
@ -248,7 +248,7 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct
let rec aux acc h = match h with
| E -> acc
| N(_,x,l,r) ->
x::aux (aux acc l) r
x::aux (aux acc l) r
in aux [] h
let add_list h l = List.fold_left add h l
@ -267,8 +267,8 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct
let rec add_klist h l = match l() with
| `Nil -> h
| `Cons (x, l') ->
let h' = add h x in
add_klist h' l'
let h' = add h x in
add_klist h' l'
let of_klist l = add_klist empty l
@ -277,14 +277,14 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct
| [] -> `Nil
| E :: stack' -> next stack' ()
| N (_, x, a, b) :: stack' ->
`Cons (x, next (a :: b :: stack'))
`Cons (x, next (a :: b :: stack'))
in
next [h]
let rec add_gen h g = match g () with
| None -> h
| Some x ->
add_gen (add h x) g
add_gen (add h x) g
let of_gen g = add_gen empty g
@ -297,9 +297,9 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct
else match Stack.pop stack with
| E -> next()
| N (_, x, a, b) ->
Stack.push a stack;
Stack.push b stack;
Some x
Stack.push a stack;
Stack.push b stack;
Some x
in next
(*$Q
@ -320,7 +320,7 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct
let first=ref true in
iter
(fun x ->
if !first then first := false else Format.fprintf out "%s@," sep;
pp_elt out x)
if !first then first := false else Format.fprintf out "%s@," sep;
pp_elt out x)
h
end

112
src/core/CCIO.ml
View file

@ -16,11 +16,11 @@ let gen_filter_map f gen =
(* tailrec *)
let rec next () =
match gen() with
| None -> None
| Some x ->
| None -> None
| Some x ->
match f x with
| None -> next()
| (Some _) as res -> res
| None -> next()
| (Some _) as res -> res
in next
let gen_of_array arr =
@ -37,18 +37,18 @@ let gen_flat_map f next_elem =
let state = ref `Init in
let rec next() =
match !state with
| `Init -> get_next_gen()
| `Run gen ->
begin match gen () with
| None -> get_next_gen ()
| (Some _) as x -> x
end
| `Stop -> None
| `Init -> get_next_gen()
| `Run gen ->
begin match gen () with
| None -> get_next_gen ()
| (Some _) as x -> x
end
| `Stop -> None
and get_next_gen() = match next_elem() with
| None -> state:=`Stop; None
| Some x ->
try state := `Run (f x); next()
with e -> state := `Stop; raise e
try state := `Run (f x); next()
with e -> state := `Stop; raise e
in
next
@ -87,7 +87,7 @@ let read_lines ic =
fun () ->
if !stop then None
else try Some (input_line ic)
with End_of_file -> (stop:=true; None)
with End_of_file -> (stop:=true; None)
let read_lines_l ic =
let l = ref [] in
@ -105,26 +105,26 @@ type _ ret_type =
| Ret_bytes : Bytes.t ret_type
let read_all_
: type a. op:a ret_type -> size:int -> in_channel -> a
= fun ~op ~size ic ->
let buf = ref (Bytes.create size) in
let len = ref 0 in
try
while true do
(* resize *)
if !len = Bytes.length !buf then (
buf := Bytes.extend !buf 0 !len;
);
assert (Bytes.length !buf > !len);
let n = input ic !buf !len (Bytes.length !buf - !len) in
len := !len + n;
if n = 0 then raise Exit; (* exhausted *)
done;
assert false (* never reached*)
with Exit ->
: type a. op:a ret_type -> size:int -> in_channel -> a
= fun ~op ~size ic ->
let buf = ref (Bytes.create size) in
let len = ref 0 in
try
while true do
(* resize *)
if !len = Bytes.length !buf then (
buf := Bytes.extend !buf 0 !len;
);
assert (Bytes.length !buf > !len);
let n = input ic !buf !len (Bytes.length !buf - !len) in
len := !len + n;
if n = 0 then raise Exit; (* exhausted *)
done;
assert false (* never reached*)
with Exit ->
match op with
| Ret_string -> Bytes.sub_string !buf 0 !len
| Ret_bytes -> Bytes.sub !buf 0 !len
| Ret_string -> Bytes.sub_string !buf 0 !len
| Ret_bytes -> Bytes.sub !buf 0 !len
let read_all_bytes ?(size=1024) ic = read_all_ ~op:Ret_bytes ~size ic
@ -158,20 +158,20 @@ let write_gen ?(sep="") oc g =
let rec recurse () = match g() with
| None -> ()
| Some s ->
output_string oc sep;
output_string oc s;
recurse ()
output_string oc sep;
output_string oc s;
recurse ()
in match g() with
| None -> ()
| Some s ->
output_string oc s;
recurse ()
output_string oc s;
recurse ()
let rec write_lines oc g = match g () with
| None -> ()
| Some l ->
write_line oc l;
write_lines oc g
write_line oc l;
write_lines oc g
let write_lines_l oc l =
List.iter (write_line oc) l
@ -221,21 +221,21 @@ let with_in_out ?(mode=0o644) ?(flags=[Open_creat]) filename f =
let tee funs g () = match g() with
| None -> None
| Some x as res ->
List.iter
(fun f ->
try f x
with _ -> ()
) funs;
res
List.iter
(fun f ->
try f x
with _ -> ()
) funs;
res
(* TODO: lines/unlines: string gen -> string gen *)
(* TODO: words: string gen -> string gen,
with a state machine that goes:
- 0: read input chunk
- switch to "search for ' '", and yield word
- goto 0 if no ' ' found
- yield leftover when g returns Stop
with a state machine that goes:
- 0: read input chunk
- switch to "search for ' '", and yield word
- goto 0 if no ' ' found
- yield leftover when g returns Stop
*)
module File = struct
@ -245,8 +245,8 @@ module File = struct
let make f =
if Filename.is_relative f
then Filename.concat (Sys.getcwd()) f
else f
then Filename.concat (Sys.getcwd()) f
else f
let exists f = Sys.file_exists f
@ -303,8 +303,8 @@ module File = struct
let arr = try Sys.readdir d with Sys_error _ -> [||] in
let tail = gen_of_array arr in
let tail = gen_flat_map
(fun s -> walk (Filename.concat d s))
tail
(fun s -> walk (Filename.concat d s))
tail
in cons_ (`Dir,d) tail
)
else gen_singleton (`File, d)
@ -318,7 +318,7 @@ module File = struct
| `Dir, f -> Sys.is_directory f
)
)
*)
*)
type walk_item = [`File | `Dir] * t

86
src/core/CCIO.mli
View file

@ -3,36 +3,36 @@
(** {1 IO Utils}
Simple utilities to deal with basic Input/Output tasks in a resource-safe
way. For advanced IO tasks, the user is advised to use something
like Lwt or Async, that are far more comprehensive.
Simple utilities to deal with basic Input/Output tasks in a resource-safe
way. For advanced IO tasks, the user is advised to use something
like Lwt or Async, that are far more comprehensive.
Examples:
Examples:
- obtain the list of lines of a file:
- obtain the list of lines of a file:
{[
# let l = CCIO.(with_in "/tmp/some_file" read_lines);;
]}
{[
# let l = CCIO.(with_in "/tmp/some_file" read_lines);;
]}
- transfer one file into another:
- transfer one file into another:
{[
# CCIO.(
with_in "/tmp/input"
(fun ic ->
let chunks = read_chunks ic in
with_out ~flags:[Open_binary] ~mode:0o644 "/tmp/output"
(fun oc ->
write_gen oc chunks
)
)
) ;;
]}
{[
# CCIO.(
with_in "/tmp/input"
(fun ic ->
let chunks = read_chunks ic in
with_out ~flags:[Open_binary] ~mode:0o644 "/tmp/output"
(fun oc ->
write_gen oc chunks
)
)
) ;;
]}
@since 0.6
@since 0.6
@before 0.12 was in 'containers.io', now moved into 'containers'
@before 0.12 was in 'containers.io', now moved into 'containers'
*)
@ -42,7 +42,7 @@ type 'a gen = unit -> 'a option (** See {!Gen} in the gen library *)
(** {2 Input} *)
val with_in : ?mode:int -> ?flags:open_flag list ->
string -> (in_channel -> 'a) -> 'a
string -> (in_channel -> 'a) -> 'a
(** Open an input file with the given optional flag list, calls the function
on the input channel. When the function raises or returns, the
channel is closed.
@ -74,13 +74,13 @@ val read_all_bytes : ?size:int -> in_channel -> Bytes.t
(** {2 Output} *)
val with_out : ?mode:int -> ?flags:open_flag list ->
string -> (out_channel -> 'a) -> 'a
string -> (out_channel -> 'a) -> 'a
(** Same as {!with_in} but for an output channel
@param flags opening flags (default [[Open_creat; Open_trunc; Open_text]]).
[Open_wronly] is used in any cases *)
val with_out_a : ?mode:int -> ?flags:open_flag list ->
string -> (out_channel -> 'a) -> 'a
string -> (out_channel -> 'a) -> 'a
(** Similar to {!with_out} but with the [[Open_append; Open_creat; Open_wronly]]
flags activated, to append to the file *)
@ -99,7 +99,7 @@ val write_lines_l : out_channel -> string list -> unit
(** {2 Both} *)
val with_in_out : ?mode:int -> ?flags:open_flag list ->
string -> (in_channel -> out_channel -> 'a) -> 'a
string -> (in_channel -> out_channel -> 'a) -> 'a
(** Combines {!with_in} and {!with_out}.
@param flags opening flags (default [[Open_creat]])
@since 0.12 *)
@ -112,18 +112,18 @@ val tee : ('a -> unit) list -> 'a gen -> 'a gen
(** {2 File and file names}
How to list recursively files in a directory:
{[
# let files = CCIO.File.read_dir ~recurse:true (CCIO.File.make "/tmp");;
# CCIO.write_lines stdout files;;
]}
How to list recursively files in a directory:
{[
# let files = CCIO.File.read_dir ~recurse:true (CCIO.File.make "/tmp");;
# CCIO.write_lines stdout files;;
]}
See {!File.walk} if you also need to list directories:
See {!File.walk} if you also need to list directories:
{[
# let content = CCIO.File.walk (CCIO.File.make "/tmp");;
# Gen.map CCIO.File.show_walk_item content |> CCIO.write_lines stdout;;
]}
{[
# let content = CCIO.File.walk (CCIO.File.make "/tmp");;
# Gen.map CCIO.File.show_walk_item content |> CCIO.write_lines stdout;;
]}
*)
module File : sig
@ -198,10 +198,10 @@ module File : sig
val with_temp :
?temp_dir:string -> prefix:string -> suffix:string ->
(string -> 'a) -> 'a
(** [with_temp ~prefix ~suffix f] will call [f] with the name of a new
temporary file (located in [temp_dir]).
After [f] returns, the file is deleted. Best to be used in
combination with {!with_out}.
See {!Filename.temp_file}
@since 0.17 *)
(** [with_temp ~prefix ~suffix f] will call [f] with the name of a new
temporary file (located in [temp_dir]).
After [f] returns, the file is deleted. Best to be used in
combination with {!with_out}.
See {!Filename.temp_file}
@since 0.17 *)
end

12
src/core/CCInt.ml
View file

@ -20,14 +20,14 @@ let pow a b =
let rec aux acc = function
| 1 -> acc
| n ->
if n mod 2 = 0
then aux (acc*acc) (n/2)
else acc * (aux (acc*acc) (n/2))
if n mod 2 = 0
then aux (acc*acc) (n/2)
else acc * (aux (acc*acc) (n/2))
in
match b with
| 0 -> if a = 0 then raise (Invalid_argument "pow: undefined value 0^0") else 1
| b when b < 0 -> raise (Invalid_argument "pow: can't raise int to negative power")
| b -> aux a b
| 0 -> if a = 0 then raise (Invalid_argument "pow: undefined value 0^0") else 1
| b when b < 0 -> raise (Invalid_argument "pow: can't raise int to negative power")
| b -> aux a b
(*$T
pow 2 10 = 1024

4
src/core/CCInt64.mli
View file

@ -2,9 +2,9 @@
(** {1 Int64}
Helpers for in64.
Helpers for in64.
@since 0.13 *)
@since 0.13 *)
type t = int64

188
src/core/CCList.ml
View file

@ -26,11 +26,11 @@ let map f l =
| [x1;x2;x3] -> let y1 = f x1 in let y2 = f x2 in [y1; y2; f x3]
| _ when i=0 -> List.rev (List.rev_map f l)
| x1::x2::x3::x4::l' ->
let y1 = f x1 in
let y2 = f x2 in
let y3 = f x3 in
let y4 = f x4 in
y1 :: y2 :: y3 :: y4 :: direct f (i-1) l'
let y1 = f x1 in
let y2 = f x2 in
let y3 = f x3 in
let y4 = f x4 in
y1 :: y2 :: y3 :: y4 :: direct f (i-1) l'
in
direct f direct_depth_default_ l
@ -55,10 +55,10 @@ let append l1 l2 =
List.rev_append (List.rev l1) l2
in
match l1 with
| [] -> l2
| [x] -> x::l2
| [x;y] -> x::y::l2
| _ -> direct direct_depth_append_ l1 l2
| [] -> l2
| [x] -> x::l2
| [x;y] -> x::y::l2
| _ -> direct direct_depth_append_ l1 l2
let (@) = append
@ -102,13 +102,13 @@ let fold_right f l acc =
| [] -> acc
| _ when i=0 -> safe f (List.rev l) acc
| x::l' ->
let acc = direct (i-1) f l' acc in
f x acc
let acc = direct (i-1) f l' acc in
f x acc
and safe f l acc = match l with
| [] -> acc
| x::l' ->
let acc = f x acc in
safe f l' acc
let acc = f x acc in
safe f l' acc
in
direct direct_depth_default_ f l acc
@ -126,8 +126,8 @@ let rec fold_while f acc = function
| [] -> acc
| e::l -> let acc, cont = f acc e in
match cont with
| `Stop -> acc
| `Continue -> fold_while f acc l
| `Stop -> acc
| `Continue -> fold_while f acc l
(*$T
fold_while (fun acc b -> if b then acc+1, `Continue else acc, `Stop) 0 [true;true;false;true] = 2
@ -137,8 +137,8 @@ let fold_map f acc l =
let rec aux f acc map_acc l = match l with
| [] -> acc, List.rev map_acc
| x :: l' ->
let acc, y = f acc x in
aux f acc (y :: map_acc) l'
let acc, y = f acc x in
aux f acc (y :: map_acc) l'
in
aux f acc [] l
@ -158,8 +158,8 @@ let fold_map2 f acc l1 l2 =
| [], _
| _, [] -> invalid_arg "fold_map2"
| x1 :: l1', x2 :: l2' ->
let acc, y = f acc x1 x2 in
aux f acc (y :: map_acc) l1' l2'
let acc, y = f acc x1 x2 in
aux f acc (y :: map_acc) l1' l2'
in
aux f acc [] l1 l2
@ -178,8 +178,8 @@ let fold_filter_map f acc l =
let rec aux f acc map_acc l = match l with
| [] -> acc, List.rev map_acc
| x :: l' ->
let acc, y = f acc x in
aux f acc (cons_maybe y map_acc) l'
let acc, y = f acc x in
aux f acc (cons_maybe y map_acc) l'
in
aux f acc [] l
@ -193,8 +193,8 @@ let fold_flat_map f acc l =
let rec aux f acc map_acc l = match l with
| [] -> acc, List.rev map_acc
| x :: l' ->
let acc, y = f acc x in
aux f acc (List.rev_append y map_acc) l'
let acc, y = f acc x in
aux f acc (List.rev_append y map_acc) l'
in
aux f acc [] l
@ -230,8 +230,8 @@ let rec compare f l1 l2 = match l1, l2 with
| _, [] -> 1
| [], _ -> -1
| x1::l1', x2::l2' ->
let c = f x1 x2 in
if c <> 0 then c else compare f l1' l2'
let c = f x1 x2 in
if c <> 0 then c else compare f l1' l2'
let rec equal f l1 l2 = match l1, l2 with
| [], [] -> true
@ -246,14 +246,14 @@ let flat_map f l =
let rec aux f l kont = match l with
| [] -> kont []
| x::l' ->
let y = f x in
let kont' tail = match y with
| [] -> kont tail
| [x] -> kont (x :: tail)
| [x;y] -> kont (x::y::tail)
| l -> kont (append l tail)
in
aux f l' kont'
let y = f x in
let kont' tail = match y with
| [] -> kont tail
| [x] -> kont (x :: tail)
| [x;y] -> kont (x::y::tail)
| l -> kont (append l tail)
in
aux f l' kont'
in
aux f l (fun l->l)
@ -275,17 +275,17 @@ let product f l1 l2 =
let fold_product f acc l1 l2 =
List.fold_left
(fun acc x1 ->
List.fold_left
(fun acc x2 -> f acc x1 x2)
acc l2
List.fold_left
(fun acc x2 -> f acc x1 x2)
acc l2
) acc l1
let diagonal l =
let rec gen acc l = match l with
| [] -> acc
| x::l' ->
let acc = List.fold_left (fun acc y -> (x,y) :: acc) acc l' in
gen acc l'
| [] -> acc
| x::l' ->
let acc = List.fold_left (fun acc y -> (x,y) :: acc) acc l' in
gen acc l'
in
gen [] l
@ -298,12 +298,12 @@ let diagonal l =
let partition_map f l =
let rec iter f l1 l2 l = match l with
| [] -> List.rev l1, List.rev l2
| x :: tl ->
match f x with
| `Left y -> iter f (y :: l1) l2 tl
| `Right y -> iter f l1 (y :: l2) tl
| `Drop -> iter f l1 l2 tl
| [] -> List.rev l1, List.rev l2
| x :: tl ->
match f x with
| `Left y -> iter f (y :: l1) l2 tl
| `Right y -> iter f l1 (y :: l2) tl
| `Drop -> iter f l1 l2 tl
in
iter f [] [] l
@ -354,9 +354,9 @@ let sorted_merge ?(cmp=Pervasives.compare) l1 l2 =
let sort_uniq (type elt) ?(cmp=Pervasives.compare) l =
let module S = Set.Make(struct
type t = elt
let compare = cmp
end) in
type t = elt
let compare = cmp
end) in
let set = fold_right S.add l S.empty in
S.elements set
@ -481,9 +481,9 @@ let take n l =
| [] -> []
| _ when i=0 -> safe n [] l
| x::l' ->
if n > 0
then x :: direct (i-1) (n-1) l'
else []
if n > 0
then x :: direct (i-1) (n-1) l'
else []
and safe n acc l = match l with
| [] -> List.rev acc
| _ when n=0 -> List.rev acc
@ -533,11 +533,11 @@ let take_while p l =
| [] -> []
| _ when i=0 -> safe p [] l
| x :: l' ->
if p x then x :: direct (i-1) p l' else []
if p x then x :: direct (i-1) p l' else []
and safe p acc l = match l with
| [] -> List.rev acc
| x :: l' ->
if p x then safe p (x::acc) l' else List.rev acc
if p x then safe p (x::acc) l' else List.rev acc
in
direct direct_depth_default_ p l
@ -605,9 +605,9 @@ let find_mapi f l =
let rec aux f i = function
| [] -> None
| x::l' ->
match f i x with
| Some _ as res -> res
| None -> aux f (i+1) l'
match f i x with
| Some _ as res -> res
| None -> aux f (i+1) l'
in aux f 0 l
let find_map f l = find_mapi (fun _ -> f) l
@ -634,10 +634,10 @@ let remove ?(eq=(=)) ~x l =
let filter_map f l =
let rec recurse acc l = match l with
| [] -> List.rev acc
| x::l' ->
let acc' = match f x with | None -> acc | Some y -> y::acc in
recurse acc' l'
| [] -> List.rev acc
| x::l' ->
let acc' = match f x with | None -> acc | Some y -> y::acc in
recurse acc' l'
in recurse [] l
(*$=
@ -769,14 +769,14 @@ let set_at_idx i x l0 =
set_at_idx 0 10 [1;2;3] = [10;2;3]
set_at_idx 4 10 [1;2;3] = [1;2;3]
set_at_idx 1 10 [1;2;3] = [1;10;3]
*)
*)
let insert_at_idx i x l =
let rec aux l acc i x = match l with
| [] -> List.rev_append acc [x]
| y::l' when i=0 -> List.rev_append acc (x::y::l')
| y::l' ->
aux l' (y::acc) (i-1) x
aux l' (y::acc) (i-1) x
in
aux l [] i x
@ -784,14 +784,14 @@ let insert_at_idx i x l =
insert_at_idx 0 10 [1;2;3] = [10;1;2;3]
insert_at_idx 4 10 [1;2;3] = [1;2;3;10]
insert_at_idx 1 10 [1;2;3] = [1;10;2;3]
*)
*)
let remove_at_idx i l0 =
let rec aux l acc i = match l with
| [] -> l0
| _::l' when i=0 -> List.rev_append acc l'
| y::l' ->
aux l' (y::acc) (i-1)
aux l' (y::acc) (i-1)
in
aux l0 [] i
@ -891,7 +891,7 @@ module Assoc = struct
let rec search_exn eq l x = match l with
| [] -> raise Not_found
| (y,z)::l' ->
if eq x y then z else search_exn eq l' x
if eq x y then z else search_exn eq l' x
let get_exn ?(eq=(=)) x l = search_exn eq l x
@ -912,9 +912,9 @@ module Assoc = struct
let rec search_set eq acc l x ~f = match l with
| [] -> f x None acc
| (x',y')::l' ->
if eq x x'
then f x (Some y') (List.rev_append acc l')
else search_set eq ((x',y')::acc) l' x ~f
if eq x x'
then f x (Some y') (List.rev_append acc l')
else search_set eq ((x',y')::acc) l' x ~f
let set ?(eq=(=)) x y l =
search_set eq [] l x
@ -940,8 +940,8 @@ module Assoc = struct
search_set eq [] l x
~f:(fun x opt_y rest ->
match f opt_y with
| None -> rest (* drop *)
| Some y' -> (x,y') :: rest)
| None -> rest (* drop *)
| Some y' -> (x,y') :: rest)
(*$=
[1,"1"; 2,"22"] \
(Assoc.update 2 [1,"1"; 2,"2"] \
@ -957,8 +957,8 @@ module Assoc = struct
let remove ?(eq=(=)) x l =
search_set eq [] l x
~f:(fun _ opt_y rest -> match opt_y with
| None -> l (* keep as is *)
| Some _ -> rest)
| None -> l (* keep as is *)
| Some _ -> rest)
(*$=
[1,"1"] \
@ -980,14 +980,14 @@ module Ref = struct
let pop l = match !l with
| [] -> None
| x::tail ->
l := tail;
Some x
l := tail;
Some x
let pop_exn l = match !l with
| [] -> failwith "CCList.Ref.pop_exn"
| x::tail ->
l := tail;
x
l := tail;
x
let create() = ref []
@ -1017,27 +1017,27 @@ module Traverse(M : MONAD) = struct
let rec aux f acc l = match l with
| [] -> return (List.rev acc)
| x::tail ->
f x >>= fun x' ->
aux f (x' :: acc) tail
f x >>= fun x' ->
aux f (x' :: acc) tail
in aux f [] l
let rec map_m_par f l = match l with
| [] -> M.return []
| x::tl ->
let x' = f x in
let tl' = map_m_par f tl in
x' >>= fun x' ->
tl' >>= fun tl' ->
M.return (x'::tl')
let x' = f x in
let tl' = map_m_par f tl in
x' >>= fun x' ->
tl' >>= fun tl' ->
M.return (x'::tl')
let sequence_m l = map_m (fun x->x) l
let rec fold_m f acc l = match l with
| [] -> return acc
| x :: l' ->
f acc x
>>= fun acc' ->
fold_m f acc' l'
f acc x
>>= fun acc' ->
fold_m f acc' l'
end
(** {2 Conversions} *)
@ -1066,10 +1066,10 @@ let random_non_empty g st =
let random_choose l = match l with
| [] -> raise Not_found
| _::_ ->
let len = List.length l in
fun st ->
let i = Random.State.int st len in
List.nth l i
let len = List.length l in
fun st ->
let i = Random.State.int st len in
List.nth l i
let random_sequence l st = map (fun g -> g st) l
@ -1083,8 +1083,8 @@ let to_gen l =
let l = ref l in
fun () ->
match !l with
| [] -> None
| x::l' ->
| [] -> None
| x::l' ->
l := l'; Some x
let of_gen g =
@ -1148,4 +1148,4 @@ let pp ?(start="") ?(stop="") ?(sep=", ") pp_item fmt l =
(CCFormat.to_string \
(CCFormat.hbox(CCList.pp ~start:"[" ~stop:"]" CCFormat.int)) \
[1;2;3])
*)
*)

6
src/core/CCList.mli
View file

@ -88,7 +88,7 @@ val diagonal : 'a t -> ('a * 'a) t
return the list of [List.nth i l, List.nth j l] if [i < j]. *)
val partition_map : ('a -> [<`Left of 'b | `Right of 'c | `Drop]) ->
'a list -> 'b list * 'c list
'a list -> 'b list * 'c list
(** [partition_map f l] maps [f] on [l] and gather results in lists:
- if [f x = `Left y], adds [y] to the first list
- if [f x = `Right z], adds [z] to the second list
@ -331,7 +331,7 @@ module Assoc : sig
end
(** {2 References on Lists}
@since 0.3.3 *)
@since 0.3.3 *)
module Ref : sig
type 'a t = 'a list ref
@ -426,4 +426,4 @@ end
(** {2 IO} *)
val pp : ?start:string -> ?stop:string -> ?sep:string ->
'a printer -> 'a t printer
'a printer -> 'a t printer

6
src/core/CCListLabels.mli
View file

@ -88,7 +88,7 @@ val diagonal : 'a t -> ('a * 'a) t
return the list of [List.nth i l, List.nth j l] if [i < j]. *)
val partition_map : f:('a -> [<`Left of 'b | `Right of 'c | `Drop]) ->
'a list -> 'b list * 'c list
'a list -> 'b list * 'c list
(** [partition_map f l] maps [f] on [l] and gather results in lists:
- if [f x = `Left y], adds [y] to the first list
- if [f x = `Right z], adds [z] to the second list
@ -331,7 +331,7 @@ module Assoc : sig
end
(** {2 References on Lists}
@since 0.3.3 *)
@since 0.3.3 *)
module Ref : sig
type 'a t = 'a list ref
@ -426,4 +426,4 @@ end
(** {2 IO} *)
val pp : ?start:string -> ?stop:string -> ?sep:string ->
'a printer -> 'a t printer
'a printer -> 'a t printer

4
src/core/CCMap.ml
View file

@ -73,8 +73,8 @@ module Make(O : Map.OrderedType) = struct
with Not_found -> f None
in
match x with
| None -> remove k m
| Some v' -> add k v' m
| None -> remove k m
| Some v' -> add k v' m
let merge_safe ~f a b =
merge

18
src/core/CCOpt.ml
View file

@ -158,11 +158,11 @@ exception ExitChoice
let choice_seq s =
let r = ref None in
begin try
s (function
| None -> ()
| (Some _) as o -> r := o; raise ExitChoice
)
with ExitChoice -> ()
s (function
| None -> ()
| (Some _) as o -> r := o; raise ExitChoice
)
with ExitChoice -> ()
end;
!r
@ -174,10 +174,10 @@ let choice_seq s =
let to_gen o =
match o with
| None -> (fun () -> None)
| Some _ ->
let first = ref true in
fun () -> if !first then (first:=false; o) else None
| None -> (fun () -> None)
| Some _ ->
let first = ref true in
fun () -> if !first then (first:=false; o) else None
let to_seq o k = match o with
| None -> ()

42
src/core/CCOrd.ml
View file

@ -41,8 +41,8 @@ let float (x:float) y = Pervasives.compare x y
let (<?>) c (ord,x,y) =
if c = 0
then ord x y
else c
then ord x y
else c
let option c o1 o2 = match o1, o2 with
| None, None -> 0
@ -52,13 +52,13 @@ let option c o1 o2 = match o1, o2 with
(*$Q
Q.(option int) (fun o -> option int None o <= 0)
*)
*)
let pair o_x o_y (x1,y1) (x2,y2) =
let c = o_x x1 x2 in
if c = 0
then o_y y1 y2
else c
then o_y y1 y2
else c
(*$T
pair int string (1, "b") (2, "a") < 0
@ -69,22 +69,22 @@ let pair o_x o_y (x1,y1) (x2,y2) =
let triple o_x o_y o_z (x1,y1,z1) (x2,y2,z2) =
let c = o_x x1 x2 in
if c = 0
then
let c' = o_y y1 y2 in
if c' = 0
then o_z z1 z2
else c'
else c
then
let c' = o_y y1 y2 in
if c' = 0
then o_z z1 z2
else c'
else c
let rec list ord l1 l2 = match l1, l2 with
| [], [] -> 0
| [], _ -> -1
| _, [] -> 1
| x1::l1', x2::l2' ->
let c = ord x1 x2 in
if c = 0
then list ord l1' l2'
else c
let c = ord x1 x2 in
if c = 0
then list ord l1' l2'
else c
(*$T
list int [1;2;3] [1;2;3;4] < 0
@ -100,14 +100,14 @@ let rec list ord l1 l2 = match l1, l2 with
let array ord a1 a2 =
let rec aux i =
if i = Array.length a1
then if Array.length a1 = Array.length a2 then 0
then if Array.length a1 = Array.length a2 then 0
else -1
else if i = Array.length a2
then 1
else
let c = ord a1.(i) a2.(i) in
if c = 0
then aux (i+1) else c
then 1
else
let c = ord a1.(i) a2.(i) in
if c = 0
then aux (i+1) else c
in
aux 0

4
src/core/CCOrd.mli
View file

@ -34,8 +34,8 @@ val (<?>) : int -> ('a t * 'a * 'a) -> int
Same example, using only CCOrd::
{[CCOrd.(int 1 3
<?> (string, "a", "b")
<?> (bool, true, false))]}
<?> (string, "a", "b")
<?> (bool, true, false))]}
*)
val option : 'a t -> 'a option t

30
src/core/CCParse.ml
View file

@ -49,11 +49,11 @@ let rec string_of_branch l =
| Some s -> Format.sprintf "while parsing %s, " s
in
match l with
| [] -> ""
| [l,c,s] ->
Format.sprintf "@[%aat line %d, col %d@]" pp_s s l c
| (l,c,s) :: tail ->
Format.sprintf "@[%aat line %d, col %d@]@,%s" pp_s s l c (string_of_branch tail)
| [] -> ""
| [l,c,s] ->
Format.sprintf "@[%aat line %d, col %d@]" pp_s s l c
| (l,c,s) :: tail ->
Format.sprintf "@[%aat line %d, col %d@]@,%s" pp_s s l c (string_of_branch tail)
let () = Printexc.register_printer
(function
@ -112,7 +112,7 @@ let (>>=) : 'a t -> ('a -> 'b t) -> 'b t
= fun p f st ~ok ~err -> p st ~err ~ok:(fun x -> f x st ~err ~ok)
let (<*>) : ('a -> 'b) t -> 'a t -> 'b t
= fun f x st ~ok ~err ->
f st ~err ~ok:(fun f' -> x st ~err ~ok:(fun x' -> ok (f' x')))
f st ~err ~ok:(fun f' -> x st ~err ~ok:(fun x' -> ok (f' x')))
let (<* ) : 'a t -> _ t -> 'a t
= fun x y st ~ok ~err ->
x st ~err ~ok:(fun res -> y st ~err ~ok:(fun _ -> ok res))
@ -275,8 +275,8 @@ and sep1 ~by p =
let sep ~by p =
(try_ p >>= fun x ->
(sep_rec ~by p >|= fun tl -> x::tl)
<|> return [x])
(sep_rec ~by p >|= fun tl -> x::tl)
<|> return [x])
<|> return []
let fix f =
@ -382,8 +382,8 @@ module U = struct
let list ?(start="[") ?(stop="]") ?(sep=";") p =
string start *> skip_white *>
sep_ ~by:(skip_white *> string sep *> skip_white) p <*
skip_white <* string stop
sep_ ~by:(skip_white *> string sep *> skip_white) p <*
skip_white <* string stop
let int =
chars1_if (fun c -> is_num c || c='-')
@ -398,17 +398,17 @@ module U = struct
let pair ?(start="(") ?(stop=")") ?(sep=",") p1 p2 =
string start *> skip_white *>
p1 >>= fun x1 ->
p1 >>= fun x1 ->
skip_white *> string sep *> skip_white *>
p2 >>= fun x2 ->
p2 >>= fun x2 ->
string stop *> return (x1,x2)
let triple ?(start="(") ?(stop=")") ?(sep=",") p1 p2 p3 =
string start *> skip_white *>
p1 >>= fun x1 ->
p1 >>= fun x1 ->
skip_white *> string sep *> skip_white *>
p2 >>= fun x2 ->
p2 >>= fun x2 ->
skip_white *> string sep *> skip_white *>
p3 >>= fun x3 ->
p3 >>= fun x3 ->
string stop *> return (x1,x2,x3)
end

66
src/core/CCParse.mli
View file

@ -3,48 +3,48 @@
(** {1 Very Simple Parser Combinators}
{[
open CCParse;;
{[
open CCParse;;
type tree = L of int | N of tree * tree;;
type tree = L of int | N of tree * tree;;
let mk_leaf x = L x
let mk_node x y = N(x,y)
let mk_leaf x = L x
let mk_node x y = N(x,y)
let ptree = fix @@ fun self ->
skip_space *>
( (try_ (char '(') *> (pure mk_node <*> self <*> self) <* char ')')
<|>
(U.int >|= mk_leaf) )
;;
let ptree = fix @@ fun self ->
skip_space *>
( (try_ (char '(') *> (pure mk_node <*> self <*> self) <* char ')')
<|>
(U.int >|= mk_leaf) )
;;
parse_string_exn ptree "(1 (2 3))" ;;
parse_string_exn ptree "((1 2) (3 (4 5)))" ;;
parse_string_exn ptree "(1 (2 3))" ;;
parse_string_exn ptree "((1 2) (3 (4 5)))" ;;
]}
]}
{6 Parse a list of words}
{6 Parse a list of words}
{[
open Containers.Parse;;
let p = U.list ~sep:"," U.word;;
parse_string_exn p "[abc , de, hello ,world ]";;
]}
{[
open Containers.Parse;;
let p = U.list ~sep:"," U.word;;
parse_string_exn p "[abc , de, hello ,world ]";;
]}
{6 Stress Test}
This makes a list of 100_000 integers, prints it and parses it back.
{6 Stress Test}
This makes a list of 100_000 integers, prints it and parses it back.
{[
let p = CCParse.(U.list ~sep:"," U.int);;
{[
let p = CCParse.(U.list ~sep:"," U.int);;
let l = CCList.(1 -- 100_000);;
let l_printed =
CCFormat.(to_string (within "[" "]" (list ~sep:(return ",@,") int))) l;;
let l = CCList.(1 -- 100_000);;
let l_printed =
CCFormat.(to_string (within "[" "]" (list ~sep:(return ",@,") int))) l;;
let l' = CCParse.parse_string_exn p l_printed;;
let l' = CCParse.parse_string_exn p l_printed;;
assert (l=l');;
]}
assert (l=l');;
]}
*)
@ -99,7 +99,7 @@ assert (l=l');;
assert_equal ~printer
(Ok ["abc"; "de"; "hello"; "world"])
(parse_string p "[abc , de, hello ,world ]");
*)
*)
(*$R
let test n =
@ -356,12 +356,12 @@ module U : sig
(** non empty string of alpha num, start with alpha *)
val pair : ?start:string -> ?stop:string -> ?sep:string ->
'a t -> 'b t -> ('a * 'b) t
'a t -> 'b t -> ('a * 'b) t
(** Parse a pair using OCaml whitespace conventions.
The default is "(a, b)". *)
val triple : ?start:string -> ?stop:string -> ?sep:string ->
'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
(** Parse a triple using OCaml whitespace conventions.
The default is "(a, b, c)". *)
end

40
src/core/CCRandom.ml
View file

@ -140,10 +140,10 @@ let retry ?(max=10) g st =
let rec try_successively l st = match l with
| [] -> None
| g :: l' ->
begin match g st with
begin match g st with
| None -> try_successively l' st
| Some _ as res -> res
end
end
let (<?>) a b = try_successively [a;b]
@ -165,28 +165,28 @@ let fix ?(sub1=[]) ?(sub2=[]) ?(subn=[]) ~base fuel st =
else
_try_otherwise 0
[| _choose_array_call sub1 (fun f -> f (make (fuel-1)) st)
; _choose_array_call sub2
(fun f ->
match split fuel st with
| None -> raise Backtrack
| Some (i,j) -> f (make i) (make j) st
)
; _choose_array_call subn
(fun (len,f) ->
let len = len st in
match split_list fuel ~len st with
| None -> raise Backtrack
| Some l' ->
f (fun st -> List.map (fun x -> make x st) l') st
)
; base (* base case then *)
; _choose_array_call sub2
(fun f ->
match split fuel st with
| None -> raise Backtrack
| Some (i,j) -> f (make i) (make j) st
)
; _choose_array_call subn
(fun (len,f) ->
let len = len st in
match split_list fuel ~len st with
| None -> raise Backtrack
| Some l' ->
f (fun st -> List.map (fun x -> make x st) l') st
)
; base (* base case then *)
|]
and _try_otherwise i a =
if i=Array.length a then raise Backtrack
else try
a.(i) st
with Backtrack ->
_try_otherwise (i+1) a
a.(i) st
with Backtrack ->
_try_otherwise (i+1) a
in
make (fuel st) st

10
src/core/CCRandom.mli
View file

@ -27,12 +27,12 @@ val delay : (unit -> 'a t) -> 'a t
need some code to run for every call.
Example:
{[
let gensym = let r = ref 0 in fun () -> incr r; !r ;;
let gensym = let r = ref 0 in fun () -> incr r; !r ;;
delay (fun () ->
let name = gensym() in
small_int >>= fun i -> return (name,i)
)
delay (fun () ->
let name = gensym() in
small_int >>= fun i -> return (name,i)
)
]}
@since 0.4 *)

2
src/core/CCRef.ml
View file

@ -3,7 +3,7 @@
(** {1 References}
@since 0.9 *)
@since 0.9 *)
type 'a printer = Format.formatter -> 'a -> unit
type 'a ord = 'a -> 'a -> int

2
src/core/CCRef.mli
View file

@ -2,7 +2,7 @@
(* This file is free software, part of containers. See file "license" for more details. *)
(** {1 References}
@since 0.9 *)
@since 0.9 *)
type 'a printer = Format.formatter -> 'a -> unit
type 'a ord = 'a -> 'a -> int

34
src/core/CCResult.ml
View file

@ -37,7 +37,7 @@ let of_exn e =
let of_exn_trace e =
let res = Printf.sprintf "%s\n%s"
(Printexc.to_string e) (Printexc.get_backtrace ())
(Printexc.to_string e) (Printexc.get_backtrace ())
in
Error res
@ -146,19 +146,19 @@ let join t = match t with
| (Error _) as e -> e
let both x y = match x,y with
| Ok o, Ok o' -> Ok (o, o')
| Ok _, Error e -> Error e
| Error e, _ -> Error e
| Ok o, Ok o' -> Ok (o, o')
| Ok _, Error e -> Error e
| Error e, _ -> Error e
(** {2 Collections} *)
let map_l f l =
let rec map acc l = match l with
| [] -> Ok (List.rev acc)
| x::l' ->
| [] -> Ok (List.rev acc)
| x::l' ->
match f x with
| Error s -> Error s
| Ok y -> map (y::acc) l'
| Error s -> Error s
| Ok y -> map (y::acc) l'
in map [] l
exception LocalExit
@ -169,11 +169,11 @@ let fold_seq f acc seq =
let acc = ref acc in
seq
(fun x -> match f !acc x with
| Error s -> err := Some s; raise LocalExit
| Ok y -> acc := y);
| Error s -> err := Some s; raise LocalExit
| Ok y -> acc := y);
Ok !acc
with LocalExit ->
match !err with None -> assert false | Some s -> Error s
match !err with None -> assert false | Some s -> Error s
let fold_l f acc l = fold_seq f acc (fun k -> List.iter k l)
@ -192,11 +192,11 @@ let choose l =
let retry n f =
let rec retry n acc = match n with
| 0 -> fail (List.rev acc)
| _ ->
| 0 -> fail (List.rev acc)
| _ ->
match f () with
| Ok _ as res -> res
| Error e -> retry (n-1) (e::acc)
| Ok _ as res -> res
| Error e -> retry (n-1) (e::acc)
in retry n []
(** {2 Infix} *)
@ -230,8 +230,8 @@ module Traverse(M : MONAD) = struct
let retry_m n f =
let rec retry n acc = match n with
| 0 -> M.return (fail (List.rev acc))
| _ ->
| 0 -> M.return (fail (List.rev acc))
| _ ->
f () >>= function
| Ok x -> M.return (Ok x)
| Error e -> retry (n-1) (e::acc)

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

@ -36,17 +36,17 @@ let compare = String.compare
let hash s = Hashtbl.hash s
#if OCAML_MAJOR >= 4 && OCAML_MINOR >= 2
#if OCAML_MAJOR >= 4 && OCAML_MINOR >= 2
let init = String.init
#else
#else
let init n f =
let buf = Bytes.init n f in
Bytes.unsafe_to_string buf
let init n f =
let buf = Bytes.init n f in
Bytes.unsafe_to_string buf
#endif
#endif
let length = String.length
@ -61,8 +61,8 @@ let rec _to_list s acc i len =
let _is_sub ~sub i s j ~len =
let rec check k =
if k = len
then true
else sub.[i+k] = s.[j+k] && check (k+1)
then true
else sub.[i+k] = s.[j+k] && check (k+1)
in
j+len <= String.length s && check 0
@ -81,7 +81,7 @@ module Find = struct
str : string;
}
(* invariant: [length failure = length str].
We use a phantom type to avoid mixing the directions. *)
We use a phantom type to avoid mixing the directions. *)
let kmp_pattern_length p = String.length p.str
@ -89,51 +89,51 @@ module Find = struct
let get_
: type a. dir:a direction -> string -> int -> char
= fun ~dir -> match dir with
| Direct -> String.get
| Reverse -> (fun s i -> s.[String.length s - i - 1])
| Direct -> String.get
| Reverse -> (fun s i -> s.[String.length s - i - 1])
let kmp_compile_
: type a. dir:a direction -> string -> a kmp_pattern
= fun ~dir str ->
let len = length str in
let get = get_ ~dir in (* how to read elements of the string *)
match len with
| 0 -> {failure=[| |]; str;}
| 1 -> {failure=[| -1 |]; str;}
| _ ->
(* at least 2 elements, the algorithm can work *)
let failure = Array.make len 0 in
failure.(0) <- -1;
(* i: current index in str *)
let i = ref 2 in
(* j: index of candidate substring *)
let j = ref 0 in
while !i < len do
match !j with
| _ when get str (!i-1) = get str !j ->
(* substring starting at !j continues matching current char *)
incr j;
failure.(!i) <- !j;
incr i;
| 0 ->
(* back to the beginning *)
failure.(!i) <- 0;
incr i;
: type a. dir:a direction -> string -> a kmp_pattern
= fun ~dir str ->
let len = length str in
let get = get_ ~dir in (* how to read elements of the string *)
match len with
| 0 -> {failure=[| |]; str;}
| 1 -> {failure=[| -1 |]; str;}
| _ ->
(* fallback for the prefix string *)
assert (!j > 0);
j := failure.(!j)
done;
(* Format.printf "{@[failure:%a, str:%s@]}@." CCFormat.(array int) failure str; *)
{ failure; str; }
(* at least 2 elements, the algorithm can work *)
let failure = Array.make len 0 in
failure.(0) <- -1;
(* i: current index in str *)
let i = ref 2 in
(* j: index of candidate substring *)
let j = ref 0 in
while !i < len do
match !j with
| _ when get str (!i-1) = get str !j ->
(* substring starting at !j continues matching current char *)
incr j;
failure.(!i) <- !j;
incr i;
| 0 ->
(* back to the beginning *)
failure.(!i) <- 0;
incr i;
| _ ->
(* fallback for the prefix string *)
assert (!j > 0);
j := failure.(!j)
done;
(* Format.printf "{@[failure:%a, str:%s@]}@." CCFormat.(array int) failure str; *)
{ failure; str; }
let kmp_compile s = kmp_compile_ ~dir:Direct s
let kmp_rcompile s = kmp_compile_ ~dir:Reverse s
(* proper search function.
[i] index in [s]
[j] index in [pattern]
[len] length of [s] *)
[i] index in [s]
[j] index in [pattern]
[len] length of [s] *)
let kmp_find ~pattern s idx =
let len = length s in
let i = ref idx in
@ -166,9 +166,9 @@ module Find = struct
else -1
(* proper search function, from the right.
[i] index in [s]
[j] index in [pattern]
[len] length of [s] *)
[i] index in [s]
[j] index in [pattern]
[len] length of [s] *)
let kmp_rfind ~pattern s idx =
let len = length s in
let i = ref (len - idx - 1) in
@ -224,7 +224,7 @@ module Find = struct
let find ?(start=0) ~(pattern:[`Direct] pattern) s = match pattern with
| P_char c ->
(try String.index_from s start c with Not_found -> -1)
(try String.index_from s start c with Not_found -> -1)
| P_KMP pattern -> kmp_find ~pattern s start
let rfind ?start ~(pattern:[`Reverse] pattern) s =
@ -278,13 +278,13 @@ let replace_at_ ~pos ~len ~by s =
let replace ?(which=`All) ~sub ~by s =
if sub="" then invalid_arg "CCString.replace";
match which with
| `Left ->
| `Left ->
let i = find ~sub s ~start:0 in
if i>=0 then replace_at_ ~pos:i ~len:(String.length sub) ~by s else s
| `Right ->
| `Right ->
let i = rfind ~sub s in
if i>=0 then replace_at_ ~pos:i ~len:(String.length sub) ~by s else s
| `All ->
| `All ->
(* compile search pattern only once *)
let pattern = Find.compile sub in
let b = Buffer.create (String.length s) in
@ -315,8 +315,8 @@ module Split = struct
and _split_search ~by s prev =
let j = Find.find ~pattern:by s ~start:prev in
if j < 0
then Some (SplitStop, prev, String.length s - prev)
else Some (SplitAt (j+Find.pattern_length by), prev, j-prev)
then Some (SplitStop, prev, String.length s - prev)
else Some (SplitAt (j+Find.pattern_length by), prev, j-prev)
let _tuple3 x y z = x,y,z
@ -327,8 +327,8 @@ module Split = struct
match _split ~by s !state with
| None -> None
| Some (state', i, len) ->
state := state';
Some (k s i len)
state := state';
Some (k s i len)
let gen ~by s = _mkgen ~by s _tuple3
@ -339,7 +339,7 @@ module Split = struct
let rec build acc state = match _split ~by s state with
| None -> List.rev acc
| Some (state', i, len) ->
build (k s i len ::acc) state'
build (k s i len ::acc) state'
in
build [] (SplitAt 0)
@ -352,7 +352,7 @@ module Split = struct
let rec make state () = match _split ~by s state with
| None -> `Nil
| Some (state', i, len) ->
`Cons (k s i len , make state')
`Cons (k s i len , make state')
in make (SplitAt 0)
let klist ~by s = _mkklist ~by s _tuple3
@ -395,15 +395,15 @@ let compare_versions a b =
| Some _, None -> 1
| None, Some _ -> -1
| Some x, Some y ->
match of_int x, of_int y with
match of_int x, of_int y with
| None, None ->
let c = String.compare x y in
if c<>0 then c else cmp_rec a b
let c = String.compare x y in
if c<>0 then c else cmp_rec a b
| Some _, None -> 1
| None, Some _ -> -1
| Some x, Some y ->
let c = Pervasives.compare x y in
if c<>0 then c else cmp_rec a b
let c = Pervasives.compare x y in
if c<>0 then c else cmp_rec a b
in
cmp_rec (Split.gen_cpy ~by:"." a) (Split.gen_cpy ~by:"." b)
@ -448,16 +448,16 @@ let repeat s n =
let prefix ~pre s =
String.length pre <= String.length s &&
(let i = ref 0 in
while !i < String.length pre && s.[!i] = pre.[!i] do incr i done;
!i = String.length pre
while !i < String.length pre && s.[!i] = pre.[!i] do incr i done;
!i = String.length pre
)
let suffix ~suf s =
String.length suf <= String.length s &&
let off = String.length s - String.length suf in
(let i = ref 0 in
while !i < String.length suf && s.[off + !i] = suf.[!i] do incr i done;
!i = String.length suf
while !i < String.length suf && s.[off + !i] = suf.[!i] do incr i done;
!i = String.length suf
)
let take n s =
@ -535,10 +535,10 @@ let of_klist l =
let b = Buffer.create 15 in
let rec aux l = match l() with
| `Nil ->
Buffer.contents b
Buffer.contents b
| `Cons (x,l') ->
Buffer.add_char b x;
aux l'
Buffer.add_char b x;
aux l'
in aux l
let to_klist s = _to_klist s 0 (String.length s)
@ -580,31 +580,31 @@ let set s i c =
let iter = String.iter
#if OCAML_MAJOR >= 4
#if OCAML_MAJOR >= 4
let map = String.map
let iteri = String.iteri
#else
#else
let map f s = init (length s) (fun i -> f s.[i])
let map f s = init (length s) (fun i -> f s.[i])
let iteri f s =
for i = 0 to String.length s - 1 do
f i s.[i]
done
#endif
#endif
#if OCAML_MAJOR >= 4 && OCAML_MINOR >= 2
#if OCAML_MAJOR >= 4 && OCAML_MINOR >= 2
let mapi = String.mapi
#else
#else
let mapi f s = init (length s) (fun i -> f i s.[i])
let mapi f s = init (length s) (fun i -> f i s.[i])
#endif
#endif
let filter_map f s =
let buf = Buffer.create (String.length s) in
@ -627,9 +627,9 @@ let flat_map ?sep f s =
iteri
(fun i c ->
begin match sep with
| Some _ when i=0 -> ()
| None -> ()
| Some sep -> Buffer.add_string buf sep
| Some _ when i=0 -> ()
| None -> ()
| Some sep -> Buffer.add_string buf sep
end;
Buffer.add_string buf (f c)
) s;
@ -677,21 +677,21 @@ let exists2 p s1 s2 =
try iter2 (fun c1 c2 -> if p c1 c2 then raise MyExit) s1 s2; false
with MyExit -> true
(** {2 Ascii functions} *)
(** {2 Ascii functions} *)
#if OCAML_MAJOR >= 4 && OCAML_MINOR >= 3
#if OCAML_MAJOR >= 4 && OCAML_MINOR >= 3
let capitalize_ascii = String.capitalize_ascii
let uncapitalize_ascii = String.uncapitalize_ascii
let uppercase_ascii = String.uppercase_ascii
let lowercase_ascii = String.lowercase_ascii
#else
#else
let capitalize_ascii s =
mapi
(fun i c -> if i=0 then CCChar.uppercase_ascii c else c)
s
let capitalize_ascii s =
mapi
(fun i c -> if i=0 then CCChar.uppercase_ascii c else c)
s
let uncapitalize_ascii s =
@ -703,7 +703,7 @@ let uppercase_ascii = map CCChar.uppercase_ascii
let lowercase_ascii = map CCChar.lowercase_ascii
#endif
#endif

8
src/core/CCString.mli
View file

@ -3,8 +3,8 @@
(** {1 Basic String Utils}
Consider using {!Containers_string.KMP} for pattern search, or Regex
libraries. *)
Consider using {!Containers_string.KMP} for pattern search, or Regex
libraries. *)
type 'a gen = unit -> 'a option
type 'a sequence = ('a -> unit) -> unit
@ -442,8 +442,8 @@ module Split : sig
(** {6 Copying functions}
Those split functions actually copy the substrings, which can be
more convenient but less efficient in general *)
Those split functions actually copy the substrings, which can be
more convenient but less efficient in general *)
val list_cpy : by:string -> string -> string list

116
src/core/CCVector.ml
View file

@ -88,21 +88,21 @@ let _resize v newcapacity =
(* grow the array, using [x] as a filler if required *)
let _grow v x =
if _empty_array v
then v.vec <- Array.make 32 x
else (
let n = Array.length v.vec in
let size = min (2 * n + 10) Sys.max_array_length in
if size = n then failwith "vec: can't grow any further";
_resize v size
)
then v.vec <- Array.make 32 x
else (
let n = Array.length v.vec in
let size = min (2 * n + 10) Sys.max_array_length in
if size = n then failwith "vec: can't grow any further";
_resize v size
)
(* v is not empty; ensure it has at least [size] slots.
Use a doubling-size strategy so that calling many times [ensure] will
behave well *)
Use a doubling-size strategy so that calling many times [ensure] will
behave well *)
let ensure_not_empty_ v size =
if size > Sys.max_array_length
then failwith "vec.ensure: size too big"
then failwith "vec.ensure: size too big"
else (
let n = ref (max 16 (Array.length v.vec)) in
while !n < size do n := min Sys.max_array_length (2* !n) done;
@ -138,7 +138,7 @@ let push_unsafe_ v x =
let push v x =
if v.size = Array.length v.vec
then _grow v x;
then _grow v x;
push_unsafe_ v x
(*$T
@ -188,7 +188,7 @@ let remove v i =
if i < 0 || i >= v.size then invalid_arg "CCVector.remove";
(* if v.(i) not the last element, then put last element at index i *)
if i < v.size - 1
then v.vec.(i) <- v.vec.(v.size - 1);
then v.vec.(i) <- v.vec.(v.size - 1);
(* remove one element *)
v.size <- v.size - 1
@ -209,12 +209,12 @@ let append_array a b =
let append_list a b = match b with
| [] -> ()
| x :: _ ->
(* need to push at least one elem *)
let len_a = a.size in
let len_b = List.length b in
ensure_with ~init:x a (len_a + len_b);
List.iter (push_unsafe_ a) b;
()
(* need to push at least one elem *)
let len_a = a.size in
let len_b = List.length b in
ensure_with ~init:x a (len_a + len_b);
List.iter (push_unsafe_ a) b;
()
(*$Q
Q.(pair (list int)(list int)) (fun (l1,l2) -> \
@ -280,10 +280,10 @@ let compare cmp v1 v2 =
let n = min v1.size v2.size in
let rec check i =
if i = n
then Pervasives.compare v1.size v2.size
else
let c = cmp (get v1 i) (get v2 i) in
if c = 0 then check (i+1) else c
then Pervasives.compare v1.size v2.size
else
let c = cmp (get v1 i) (get v2 i) in
if c = 0 then check (i+1) else c
in check 0
exception Empty
@ -309,7 +309,7 @@ let top_exn v =
1 -- 10 |> top = Some 10
create () |> top = None
1 -- 10 |> top_exn = 10
*)
*)
let copy v = {
size = v.size;
@ -387,18 +387,18 @@ let uniq_sort cmp v =
let rec traverse prev i j =
if i >= n then () (* done traversing *)
else if cmp prev v.vec.(i) = 0
then (
v.size <- v.size - 1;
traverse prev (i+1) j
) (* duplicate, remove it *)
else (
v.vec.(j) <- v.vec.(i);
traverse v.vec.(i) (i+1) (j+1)
) (* keep it *)
then (
v.size <- v.size - 1;
traverse prev (i+1) j
) (* duplicate, remove it *)
else (
v.vec.(j) <- v.vec.(i);
traverse v.vec.(i) (i+1) (j+1)
) (* keep it *)
in
if v.size > 0
then traverse v.vec.(0) 1 1
(* start at 1, to get the first element in hand *)
then traverse v.vec.(0) 1 1
(* start at 1, to get the first element in hand *)
(*$T
let v = of_list [1;4;5;3;2;4;1] in \
@ -418,7 +418,7 @@ let iteri k v =
(*$T
let v = (0--6) in \
iteri (fun i x -> if i = 3 then remove v i) v; length v = 6
*)
*)
let map f v =
if _empty_array v
@ -431,7 +431,7 @@ let map f v =
(*$T
let v = create() in push v 1; push v 2; push v 3; \
to_list (map string_of_int v) = ["1"; "2"; "3"]
*)
*)
let filter' p v =
let i = ref 0 in (* cur element *)
@ -440,7 +440,7 @@ let filter' p v =
while !i < n do
if p v.vec.(! i) then (
(* move element i at the first empty slot.
invariant: i >= j*)
invariant: i >= j*)
if !i > !j then v.vec.(!j) <- v.vec.(!i);
incr i;
incr j
@ -506,7 +506,7 @@ let find_exn p v =
else
let x = v.vec.(i) in
if p x then x
else check (i+1)
else check (i+1)
in check 0
let find p v =
@ -534,8 +534,8 @@ let filter_map f v =
let v' = create () in
iter
(fun x -> match f x with
| None -> ()
| Some y -> push v' y
| None -> ()
| Some y -> push v' y
) v;
v'
@ -548,8 +548,8 @@ let flat_map_seq f v =
let v' = create () in
iter
(fun x ->
let seq = f x in
append_seq v' seq;
let seq = f x in
append_seq v' seq;
) v;
v'
@ -557,8 +557,8 @@ let flat_map_list f v =
let v' = create () in
iter
(fun x ->
let l = f x in
append_list v' l;
let l = f x in
append_list v' l;
) v;
v'
@ -650,8 +650,8 @@ let slice v = (v.vec, 0, v.size)
let (--) i j =
if i>j
then init (i-j+1) (fun k -> i-k)
else init (j-i+1) (fun k -> i+k)
then init (i-j+1) (fun k -> i-k)
else init (j-i+1) (fun k -> i+k)
(*$T
(1 -- 4) |> to_list = [1;2;3;4]
@ -667,8 +667,8 @@ let (--) i j =
let (--^) i j =
if i=j then create()
else if i>j
then init (i-j) (fun k -> i-k)
else init (j-i) (fun k -> i+k)
then init (i-j) (fun k -> i-k)
else init (j-i) (fun k -> i+k)
(*$Q
Q.(pair small_int small_int) (fun (a,b) -> \
@ -686,9 +686,9 @@ let of_array a =
let of_list l = match l with
| [] -> create()
| x::_ ->
let v = create_with ~capacity:(List.length l + 5) x in
List.iter (push_unsafe_ v) l;
v
let v = create_with ~capacity:(List.length l + 5) x in
List.iter (push_unsafe_ v) l;
v
(*$T
of_list CCList.(1--300_000) |> to_list = CCList.(1--300_000)
@ -710,15 +710,15 @@ let to_gen v =
let i = ref 0 in
fun () ->
if !i < v.size
then (
let x = v.vec.( !i ) in
incr i;
Some x
) else None
then (
let x = v.vec.( !i ) in
incr i;
Some x
) else None
(*$T
let v = (1--10) in to_list v = Gen.to_list (to_gen v)
*)
*)
let of_klist ?(init=create ()) l =
let rec aux l = match l() with
@ -736,7 +736,7 @@ let pp ?(start="") ?(stop="") ?(sep=", ") pp_item fmt v =
Format.pp_print_string fmt start;
iteri
(fun i x ->
if i > 0 then (Format.pp_print_string fmt sep; Format.pp_print_cut fmt());
pp_item fmt x
if i > 0 then (Format.pp_print_string fmt sep; Format.pp_print_cut fmt());
pp_item fmt x
) v;
Format.pp_print_string fmt stop

2
src/core/CCVector.mli
View file

@ -266,4 +266,4 @@ val of_gen : ?init:('a, rw) t -> 'a gen -> ('a, rw) t
val to_gen : ('a,_) t -> 'a gen
val pp : ?start:string -> ?stop:string -> ?sep:string ->
'a printer -> ('a,_) t printer
'a printer -> ('a,_) t printer

18
src/core/containers.ml
View file

@ -3,13 +3,13 @@
(** {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
]}
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
@ -41,8 +41,8 @@ module IO = CCIO
module Hashtbl = struct
include (Hashtbl : module type of Hashtbl
with type statistics = Hashtbl.statistics
and module Make = Hashtbl.Make
and type ('a,'b) t = ('a,'b) Hashtbl.t
and module Make = Hashtbl.Make
and type ('a,'b) t = ('a,'b) Hashtbl.t
)
(* still unable to include CCHashtbl itself, for the polymorphic functions *)
module type S' = CCHashtbl.S

108
src/data/CCBV.ml
View file

@ -8,8 +8,8 @@ let __width = Sys.word_size - 2
(* int with [n] ones *)
let rec __shift bv n =
if n = 0
then bv
else __shift ((bv lsl 1) lor 1) (n-1)
then bv
else __shift ((bv lsl 1) lor 1) (n-1)
(* only ones *)
let __all_ones = __shift 0 __width
@ -22,17 +22,17 @@ let empty () = { a = [| |] }
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
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
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
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
(*$T
create ~size:17 true |> cardinal = 17
@ -53,11 +53,11 @@ 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
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 =
@ -65,8 +65,8 @@ let __count_bits 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
then recurse 1 (n lsr 1) (* only on unsigned *)
else recurse 0 n
let cardinal bv =
let n = ref 0 in
@ -78,11 +78,11 @@ let cardinal bv =
(*$R
let bv1 = CCBV.create ~size:87 true in
assert_equal ~printer:string_of_int 87 (CCBV.cardinal bv1);
*)
*)
(*$Q
Q.small_int (fun n -> CCBV.cardinal (CCBV.create ~size:n true) = n)
*)
*)
let is_empty bv =
try
@ -96,10 +96,10 @@ let is_empty bv =
let get bv i =
let n = i / __width in
if n < Array.length bv.a
then
let i = i - n * __width in
bv.a.(n) land (1 lsl i) <> 0
else false
then
let i = i - n * __width in
bv.a.(n) land (1 lsl i) <> 0
else false
(*$R
let bv = CCBV.create ~size:99 false in
@ -120,7 +120,7 @@ let get bv i =
let set bv i =
let n = i / __width in
if n >= Array.length bv.a
then resize bv (n+1);
then resize bv (n+1);
let i = i - n * __width in
bv.a.(n) <- bv.a.(n) lor (1 lsl i)
@ -132,7 +132,7 @@ let set bv i =
let reset bv i =
let n = i / __width in
if n >= Array.length bv.a
then resize bv (n+1);
then resize bv (n+1);
let i = i - n * __width in
bv.a.(n) <- bv.a.(n) land (lnot (1 lsl i))
@ -143,7 +143,7 @@ let reset bv i =
let flip bv i =
let n = i / __width in
if n >= Array.length bv.a
then resize bv (n+1);
then resize bv (n+1);
let i = i - n * __width in
bv.a.(n) <- bv.a.(n) lxor (1 lsl i)
@ -166,7 +166,7 @@ let clear bv =
Array.iteri (fun i _ -> bv.a.(i) <- 0) bv.a
(*$T
let bv = create ~size:37 true in cardinal bv = 37 && (clear bv; cardinal bv= 0)
let bv = create ~size:37 true in cardinal bv = 37 && (clear bv; cardinal bv= 0)
*)
(*$R
@ -200,7 +200,7 @@ let iter_true bv f =
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)
then f (j+i)
done
done
@ -278,7 +278,7 @@ let filter bv p =
let union_into ~into bv =
if length into < length bv
then resize 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)
@ -299,7 +299,7 @@ let union bv1 bv2 =
*)
(*$T
union (of_list [1;2;3;4;5]) (of_list [7;3;5;6]) |> to_sorted_list = CCList.range 1 7
union (of_list [1;2;3;4;5]) (of_list [7;3;5;6]) |> to_sorted_list = CCList.range 1 7
*)
let inter_into ~into bv =
@ -310,14 +310,14 @@ let inter_into ~into bv =
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
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
(*$T
inter (of_list [1;2;3;4]) (of_list [2;4;6;1]) |> to_sorted_list = [1;2;4]
@ -334,12 +334,12 @@ let inter bv1 bv2 =
let select bv arr =
let l = ref [] in
begin try
iter_true bv
(fun i ->
if i >= Array.length arr
then raise Exit
else l := arr.(i) :: !l)
with Exit -> ()
iter_true bv
(fun i ->
if i >= Array.length arr
then raise Exit
else l := arr.(i) :: !l)
with Exit -> ()
end;
!l
@ -353,12 +353,12 @@ let select bv arr =
let selecti bv arr =
let l = ref [] in
begin try
iter_true bv
(fun i ->
if i >= Array.length arr
then raise Exit
else l := (arr.(i), i) :: !l)
with Exit -> ()
iter_true bv
(fun i ->
if i >= Array.length arr
then raise Exit
else l := (arr.(i), i) :: !l)
with Exit -> ()
end;
!l
@ -394,6 +394,6 @@ let print out bv =
Format.pp_print_string out "bv {";
iter bv
(fun _i b ->
Format.pp_print_char out (if b then '1' else '0')
Format.pp_print_char out (if b then '1' else '0')
);
Format.pp_print_string out "}"

6
src/data/CCBV.mli
View file

@ -3,9 +3,9 @@
(** {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.
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.
*)
type t

2
src/data/CCBitField.ml
View file

@ -99,7 +99,7 @@ let rec all_bits_ acc w =
all_bits_ 0 2 = 3
all_bits_ 0 3 = 7
all_bits_ 0 4 = 15
*)
*)
(* increment and return previous value *)
let get_then_incr n =

6
src/data/CCBitField.mli
View file

@ -2,9 +2,9 @@
(** {1 Bit Field}
This module defines efficient bitfields
up to 30 or 62 bits (depending on the architecture) in
a relatively type-safe way.
This module defines efficient bitfields
up to 30 or 62 bits (depending on the architecture) in
a relatively type-safe way.
{[
module B = CCBitField.Make(struct end);;

48
src/data/CCCache.ml
View file

@ -34,11 +34,11 @@ let default_hash_ = Hashtbl.hash
(** {2 Value interface} *)
(** Invariants:
- after [cache.set x y], [get cache x] must return [y] or raise [Not_found]
- [cache.set x y] is only called if [get cache x] fails, never if [x] is already bound
- [cache.size()] must be positive and correspond to the number of items in [cache.iter]
- [cache.iter f] calls [f x y] with every [x] such that [cache.get x = y]
- after [cache.clear()], [cache.get x] fails for every [x]
- after [cache.set x y], [get cache x] must return [y] or raise [Not_found]
- [cache.set x y] is only called if [get cache x] fails, never if [x] is already bound
- [cache.size()] must be positive and correspond to the number of items in [cache.iter]
- [cache.iter f] calls [f x y] with every [x] such that [cache.get x = y]
- after [cache.clear()], [cache.get x] fails for every [x]
*)
type ('a,'b) t = {
set : 'a -> 'b -> unit;
@ -163,9 +163,9 @@ module Replacing = struct
let get c x =
let i = c.hash x mod Array.length c.arr in
match c.arr.(i) with
| Pair (x', y) when c.eq x x' -> y
| Pair _
| Empty -> raise Not_found
| Pair (x', y) when c.eq x x' -> y
| Pair _
| Empty -> raise Not_found
let set c x y =
let i = c.hash x mod Array.length c.arr in
@ -225,27 +225,27 @@ module LRU(X:HASH) = struct
(* take first from queue *)
let take_ c =
match c.first with
| Some n when n.next == n ->
| Some n when n.next == n ->
(* last element *)
c.first <- None;
n
| Some n ->
| Some n ->
c.first <- Some n.next;
n.prev.next <- n.next;
n.next.prev <- n.prev;
n
| None ->
| None ->
failwith "LRU: empty queue"
(* push at back of queue *)
let push_ c n =
match c.first with
| None ->
| None ->
n.next <- n;
n.prev <- n;
c.first <- Some n
| Some n1 when n1==n -> ()
| Some n1 ->
| Some n1 when n1==n -> ()
| Some n1 ->
n.prev <- n1.prev;
n.next <- n1;
n1.prev.next <- n;
@ -291,8 +291,8 @@ module LRU(X:HASH) = struct
let len = H.length c.table in
assert (len <= c.size);
if len = c.size
then replace_ c x y
else insert_ c x y
then replace_ c x y
else insert_ c x y
let size c () = H.length c.table
@ -302,10 +302,10 @@ end
let lru (type a) ?(eq=default_eq_) ?(hash=default_hash_) size =
let module L = LRU(struct
type t = a
let equal = eq
let hash = hash
end) in
type t = a
let equal = eq
let hash = hash
end) in
let c = L.make size in
{ get=(fun x -> L.get c x);
set=(fun x y -> L.set c x y);
@ -364,10 +364,10 @@ end
let unbounded (type a) ?(eq=default_eq_) ?(hash=default_hash_) size =
let module C = UNBOUNDED(struct
type t = a
let equal = eq
let hash = hash
end) in
type t = a
let equal = eq
let hash = hash
end) in
let c = C.make size in
{ get=(fun x -> C.get c x);
set=(fun x y -> C.set c x y);

50
src/data/CCCache.mli
View file

@ -25,28 +25,28 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(** {1 Caches}
Particularly useful for memoization. See {!with_cache} and {!with_cache_rec}
for more details.
@since 0.6 *)
Particularly useful for memoization. See {!with_cache} and {!with_cache_rec}
for more details.
@since 0.6 *)
type 'a equal = 'a -> 'a -> bool
type 'a hash = 'a -> int
(** {2 Value interface}
Typical use case: one wants to memoize a function [f : 'a -> 'b]. Code sample:
{[
let f x =
print_endline "call f";
x + 1;;
Typical use case: one wants to memoize a function [f : 'a -> 'b]. Code sample:
{[
let f x =
print_endline "call f";
x + 1;;
let f' = with_cache (lru 256) f;;
f' 0;; (* prints *)
f' 1;; (* prints *)
f' 0;; (* doesn't print, returns cached value *)
]}
let f' = with_cache (lru 256) f;;
f' 0;; (* prints *)
f' 1;; (* prints *)
f' 0;; (* doesn't print, returns cached value *)
]}
@since 0.6 *)
@since 0.6 *)
type ('a, 'b) t
@ -65,15 +65,15 @@ val with_cache_rec : ('a,'b) t -> (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b
It is similar to {!with_cache} but with a function that takes as
first argument its own recursive version.
Example (memoized Fibonacci function):
{[
let fib = with_cache_rec (lru 256)
(fun fib' n -> match n with
| 1 | 2 -> 1
| _ -> fib' (n-1) + fib' (n-2)
);;
{[
let fib = with_cache_rec (lru 256)
(fun fib' n -> match n with
| 1 | 2 -> 1
| _ -> fib' (n-1) + fib' (n-2)
);;
fib 70;;
]}
fib 70;;
]}
*)
val size : (_,_) t -> int
@ -93,7 +93,7 @@ val linear : ?eq:'a equal -> int -> ('a, 'b) t
@param eq optional equality predicate for keys *)
val replacing : ?eq:'a equal -> ?hash:'a hash ->
int -> ('a,'b) t
int -> ('a,'b) t
(** Replacing cache of the given size. Equality and hash functions can be
parametrized. It's a hash table that handles collisions by replacing
the old value with the new (so a cache entry is evicted when another
@ -101,11 +101,11 @@ val replacing : ?eq:'a equal -> ?hash:'a hash ->
Never grows wider than the given size. *)
val lru : ?eq:'a equal -> ?hash:'a hash ->
int -> ('a,'b) t
int -> ('a,'b) t
(** LRU cache of the given size ("Least Recently Used": keys that have not been
used recently are deleted first). Never grows wider than the given size. *)
val unbounded : ?eq:'a equal -> ?hash:'a hash ->
int -> ('a,'b) t
int -> ('a,'b) t
(** Unbounded cache, backed by a Hash table. Will grow forever
unless {!clear} is called manually. *)

58
src/data/CCDeque.ml
View file

@ -8,7 +8,7 @@ type 'a cell =
| One of 'a
| Two of 'a * 'a
| Three of 'a * 'a * 'a
(** A cell holding a small number of elements *)
(** A cell holding a small number of elements *)
type 'a node = {
mutable cell : 'a cell;
@ -82,26 +82,26 @@ let is_empty d =
let push_front d x =
incr_size_ d;
match d.cur.cell with
| Zero -> d.cur.cell <- One x
| One y -> d.cur.cell <- Two (x, y)
| Two (y, z) -> d.cur.cell <- Three (x,y,z)
| Three _ ->
let node = { cell = One x; prev = d.cur.prev; next=d.cur; } in
d.cur.prev.next <- node;
d.cur.prev <- node;
d.cur <- node (* always point to first node *)
| Zero -> d.cur.cell <- One x
| One y -> d.cur.cell <- Two (x, y)
| Two (y, z) -> d.cur.cell <- Three (x,y,z)
| Three _ ->
let node = { cell = One x; prev = d.cur.prev; next=d.cur; } in
d.cur.prev.next <- node;
d.cur.prev <- node;
d.cur <- node (* always point to first node *)
let push_back d x =
incr_size_ d;
let n = d.cur.prev in (* last node *)
match n.cell with
| Zero -> n.cell <- One x
| One y -> n.cell <- Two (y, x)
| Two (y,z) -> n.cell <- Three (y, z, x)
| Three _ ->
let elt = { cell = One x; next=d.cur; prev=n; } in
n.next <- elt;
d.cur.prev <- elt
| Zero -> n.cell <- One x
| One y -> n.cell <- Two (y, x)
| Two (y,z) -> n.cell <- Three (y, z, x)
| Three _ ->
let elt = { cell = One x; next=d.cur; prev=n; } in
n.next <- elt;
d.cur.prev <- elt
let peek_front d = match d.cur.cell with
| Zero -> raise Empty
@ -112,7 +112,7 @@ let peek_front d = match d.cur.cell with
(*$T
of_list [1;2;3] |> peek_front = 1
try (ignore (of_list [] |> peek_front); false) with Empty -> true
*)
*)
(*$R
let d = of_seq Sequence.(1 -- 10) in
@ -180,7 +180,7 @@ let take_back d =
(*$T
let q = of_list [1;2;3] in take_back q = 3 && to_list q = [1;2]
*)
*)
let take_front_node_ n = match n.cell with
| Zero -> assert false
@ -190,7 +190,7 @@ let take_front_node_ n = match n.cell with
(*$T
let q = of_list [1;2;3] in take_front q = 1 && to_list q = [2;3]
*)
*)
let take_front d =
if is_empty d then raise Empty
@ -213,10 +213,10 @@ let take_front d =
let iter f d =
let rec iter f ~first n =
begin match n.cell with
| Zero -> ()
| One x -> f x
| Two (x,y) -> f x; f y
| Three (x,y,z) -> f x; f y; f z
| Zero -> ()
| One x -> f x
| Two (x,y) -> f x; f y
| Three (x,y,z) -> f x; f y; f z
end;
if n.next != first then iter f ~first n.next
in
@ -302,7 +302,7 @@ let to_seq d k = iter k d
(*$Q
Q.(list int) (fun l -> \
Sequence.of_list l |> of_seq |> to_seq |> Sequence.to_list = l)
*)
*)
let of_list l =
let q = create() in
@ -391,15 +391,15 @@ let compare ?(cmp=Pervasives.compare) a b =
| None, Some _ -> -1
| Some _, None -> 1
| Some x, Some y ->
let c = cmp x y in
if c=0 then aux cmp a b else c
let c = cmp x y in
if c=0 then aux cmp a b else c
in aux cmp (to_gen a) (to_gen b)
(*$Q
Q.(pair (list int) (list int)) (fun (l1,l2) -> \
CCOrd.equiv (compare (of_list l1) (of_list l2)) \
(CCList.compare Pervasives.compare l1 l2))
*)
*)
type 'a printer = Format.formatter -> 'a -> unit
@ -408,8 +408,8 @@ let print pp_x out d =
Format.fprintf out "@[<hov2>deque {";
iter
(fun x ->
if !first then first:= false else Format.fprintf out ";@ ";
pp_x out x
if !first then first:= false else Format.fprintf out ";@ ";
pp_x out x
) d;
Format.fprintf out "}@]"

66
src/data/CCFlatHashtbl.ml
View file

@ -26,9 +26,9 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(** {1 Open-Addressing Hash-table}
We use Robin-Hood hashing as described in
http://codecapsule.com/2013/11/17/robin-hood-hashing-backward-shift-deletion/
with backward shift. *)
We use Robin-Hood hashing as described in
http://codecapsule.com/2013/11/17/robin-hood-hashing-backward-shift-deletion/
with backward shift. *)
type 'a sequence = ('a -> unit) -> unit
@ -122,15 +122,15 @@ module Make(X : HASHABLE) = struct
(* insert k->v in [tbl], currently at index [i] and distance [dib] *)
let rec _linear_probe tbl k v h_k i dib =
match tbl.arr.(i) with
| Empty ->
| Empty ->
(* add binding *)
tbl.size <- 1 + tbl.size;
tbl.arr.(i) <- Key (k, v, h_k)
| Key (k', _, h_k') when X.equal k k' ->
| Key (k', _, h_k') when X.equal k k' ->
(* replace *)
assert (h_k = h_k');
tbl.arr.(i) <- Key (k, v, h_k)
| Key (k', v', h_k') ->
| Key (k', v', h_k') ->
let dib' = _dib tbl h_k' ~i in
if dib > dib'
then (
@ -143,7 +143,7 @@ module Make(X : HASHABLE) = struct
)
(* resize table: put a bigger array in it, then insert values
from the old array *)
from the old array *)
let _resize tbl =
let size' = min Sys.max_array_length (2 * Array.length tbl.arr) in
let arr' = Array.make size' Empty in
@ -168,9 +168,9 @@ module Make(X : HASHABLE) = struct
or a bucket that doesn't need shifting is met *)
let rec _backward_shift tbl ~prev:prev_i i =
match tbl.arr.(i) with
| Empty ->
| Empty ->
tbl.arr.(prev_i) <- Empty;
| Key (_, _, h_k) as bucket ->
| Key (_, _, h_k) as bucket ->
let d = _dib tbl h_k ~i in
assert (d >= 0);
if d > 0 then (
@ -185,17 +185,17 @@ module Make(X : HASHABLE) = struct
if any, and perform backward shift from there *)
let rec _linear_probe_remove tbl k h_k i dib =
match tbl.arr.(i) with
| Empty -> ()
| Key (k', _, _) when X.equal k k' ->
| Empty -> ()
| Key (k', _, _) when X.equal k k' ->
tbl.size <- tbl.size - 1;
(* shift all elements that follow and have a DIB > 0;
it will also erase the last shifted bucket, and erase [i] in
any case *)
_backward_shift tbl ~prev:i (_succ tbl i)
| Key (_, _, h_k') ->
if dib > _dib tbl h_k' ~i
then () (* [k] not present, would be here otherwise *)
else _linear_probe_remove tbl k h_k (_succ tbl i) (dib+1)
| Key (_, _, h_k') ->
if dib > _dib tbl h_k' ~i
then () (* [k] not present, would be here otherwise *)
else _linear_probe_remove tbl k h_k (_succ tbl i) (dib+1)
let remove tbl k =
let h_k = X.hash k in
@ -203,9 +203,9 @@ module Make(X : HASHABLE) = struct
let rec get_exn_rec tbl k h_k i dib =
match tbl.arr.(i) with
| Empty -> raise Not_found
| Key (k', v', _) when X.equal k k' -> v'
| Key (_, _, h_k') ->
| Empty -> raise Not_found
| Key (k', v', _) when X.equal k k' -> v'
| Key (_, _, h_k') ->
if dib > _dib tbl h_k' ~i
then raise Not_found (* [k] would be here otherwise *)
else get_exn_rec tbl k h_k (_succ tbl i) (dib+1)
@ -215,22 +215,22 @@ module Make(X : HASHABLE) = struct
let i0 = _initial_idx tbl h_k in
(* unroll a few steps *)
match tbl.arr.(i0) with
| Empty -> raise Not_found
| Key (k', v, _) ->
if X.equal k k' then v
else
let i1 = _succ tbl i0 in
match tbl.arr.(i1) with
| Empty -> raise Not_found
| Key (k', v, _) ->
if X.equal k k' then v
else
let i2 = _succ tbl i1 in
match tbl.arr.(i2) with
| Empty -> raise Not_found
| Key (k', v, _) ->
if X.equal k k' then v
else
let i1 = _succ tbl i0 in
match tbl.arr.(i1) with
| Empty -> raise Not_found
| Key (k', v, _) ->
if X.equal k k' then v
else get_exn_rec tbl k h_k (_succ tbl i2) 3
else
let i2 = _succ tbl i1 in
match tbl.arr.(i2) with
| Empty -> raise Not_found
| Key (k', v, _) ->
if X.equal k k' then v
else get_exn_rec tbl k h_k (_succ tbl i2) 3
let get k tbl =
try Some (get_exn k tbl)
@ -254,8 +254,8 @@ module Make(X : HASHABLE) = struct
let to_list tbl =
Array.fold_left
(fun acc bucket -> match bucket with
| Empty -> acc
| Key (k,v,_) -> (k,v)::acc)
| Empty -> acc
| Key (k,v,_) -> (k,v)::acc)
[] tbl.arr
let of_seq seq =

6
src/data/CCFlatHashtbl.mli
View file

@ -26,10 +26,10 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(** {1 Open-Addressing Hash-table}
This module was previously named [CCHashtbl], but the name is now used for
an extension of the standard library's hashtables.
This module was previously named [CCHashtbl], but the name is now used for
an extension of the standard library's hashtables.
@since 0.4 *)
@since 0.4 *)
type 'a sequence = ('a -> unit) -> unit

200
src/data/CCGraph.ml
View file

@ -58,10 +58,10 @@ type 'a set = ('a, unit) table
let mk_table (type k) ?(eq=(=)) ?(hash=Hashtbl.hash) size =
let module H = Hashtbl.Make(struct
type t = k
let equal = eq
let hash = hash
end) in
type t = k
let equal = eq
let hash = hash
end) in
let tbl = H.create size in
{ mem=(fun k -> H.mem tbl k)
; find=(fun k -> H.find tbl k)
@ -70,9 +70,9 @@ let mk_table (type k) ?(eq=(=)) ?(hash=Hashtbl.hash) size =
let mk_map (type k) ?(cmp=Pervasives.compare) () =
let module M = Map.Make(struct
type t = k
let compare = cmp
end) in
type t = k
let compare = cmp
end) in
let tbl = ref M.empty in
{ mem=(fun k -> M.mem k !tbl)
; find=(fun k -> M.find k !tbl)
@ -112,10 +112,10 @@ module Heap = struct
| N _ -> false
let rec union ~leq t1 t2 = match t1, t2 with
| E, _ -> t2
| _, E -> t1
| N (x1, l1, r1), N (x2, l2, r2) ->
if leq x1 x2
| E, _ -> t2
| _, E -> t1
| N (x1, l1, r1), N (x2, l2, r2) ->
if leq x1 x2
then N (x1, union ~leq t2 r1, l1)
else N (x2, union ~leq t1 r2, l2)
@ -132,9 +132,9 @@ let mk_heap ~leq =
{ push=(fun x -> t := Heap.insert ~leq !t x)
; is_empty=(fun () -> Heap.is_empty !t)
; pop=(fun () ->
let x, h = Heap.pop ~leq !t in
t := h;
x
let x, h = Heap.pop ~leq !t in
t := h;
x
)
}
@ -252,30 +252,30 @@ module Traverse = struct
bag.push (`Enter (v, []));
while not (bag.is_empty ()) do
match bag.pop () with
| `Enter (x, path) ->
if not (tags.get_tag x) then (
let num = !n in
incr n;
tags.set_tag x;
k (`Enter (x, num, path));
bag.push (`Exit x);
Seq.iter
(fun (e,v') -> bag.push (`Edge (v,e,v',(v,e,v') :: path)))
(graph x);
)
| `Exit x -> k (`Exit x)
| `Edge (v,e,v', path) ->
let edge_kind =
if tags.get_tag v'
then if list_mem_ ~eq ~graph v' path
then `Back
else `Cross
else (
bag.push (`Enter (v', path));
`Forward
| `Enter (x, path) ->
if not (tags.get_tag x) then (
let num = !n in
incr n;
tags.set_tag x;
k (`Enter (x, num, path));
bag.push (`Exit x);
Seq.iter
(fun (e,v') -> bag.push (`Edge (v,e,v',(v,e,v') :: path)))
(graph x);
)
in
k (`Edge (v,e,v', edge_kind))
| `Exit x -> k (`Exit x)
| `Edge (v,e,v', path) ->
let edge_kind =
if tags.get_tag v'
then if list_mem_ ~eq ~graph v' path
then `Back
else `Cross
else (
bag.push (`Enter (v', path));
`Forward
)
in
k (`Edge (v,e,v', edge_kind))
done
) seq
@ -306,12 +306,12 @@ let topo_sort_tag ?(eq=(=)) ?(rev=false) ~tags ~graph seq =
let l =
Traverse.Event.dfs_tag ~eq ~tags ~graph seq
|> Seq.filter_map
(function
| `Exit v -> Some v
| `Edge (_, _, _, `Back) -> raise Has_cycle
| `Enter _
| `Edge _ -> None
)
(function
| `Exit v -> Some v
| `Edge (_, _, _, `Back) -> raise Has_cycle
| `Enter _
| `Edge _ -> None
)
|> Seq.fold (fun acc x -> x::acc) []
in
if rev then List.rev l else l
@ -372,7 +372,7 @@ let spanning_tree_tag ~tags ~graph v =
(e, mk_node v') :: acc
)
) [] (graph v)
)
)
in
Lazy_tree.make_ v children
in
@ -428,37 +428,37 @@ module SCC = struct
Stack.push (`Enter v) to_explore;
while not (Stack.is_empty to_explore) do
match Stack.pop to_explore with
| `Enter v ->
if not (tbl.mem v) then (
(* remember unique ID for [v] *)
let id = !n in
incr n;
let cell = mk_cell v id in
cell.on_stack <- true;
tbl.add v cell;
Stack.push cell stack;
Stack.push (`Exit (v, cell)) to_explore;
(* explore children *)
| `Enter v ->
if not (tbl.mem v) then (
(* remember unique ID for [v] *)
let id = !n in
incr n;
let cell = mk_cell v id in
cell.on_stack <- true;
tbl.add v cell;
Stack.push cell stack;
Stack.push (`Exit (v, cell)) to_explore;
(* explore children *)
Seq.iter
(fun (_,v') -> Stack.push (`Enter v') to_explore)
(graph v)
)
| `Exit (v, cell) ->
(* update [min_id] *)
assert cell.on_stack;
Seq.iter
(fun (_,v') -> Stack.push (`Enter v') to_explore)
(graph v)
)
| `Exit (v, cell) ->
(* update [min_id] *)
assert cell.on_stack;
Seq.iter
(fun (_,dest) ->
(* must not fail, [dest] already explored *)
let dest_cell = tbl.find dest in
(* same SCC? yes if [dest] points to [cell.v] *)
if dest_cell.on_stack
(fun (_,dest) ->
(* must not fail, [dest] already explored *)
let dest_cell = tbl.find dest in
(* same SCC? yes if [dest] points to [cell.v] *)
if dest_cell.on_stack
then cell.min_id <- min cell.min_id dest_cell.min_id
) (graph v);
(* pop from stack if SCC found *)
if cell.id = cell.min_id then (
let scc = pop_down_to ~id:cell.id [] stack in
k scc
)
) (graph v);
(* pop from stack if SCC found *)
if cell.id = cell.min_id then (
let scc = pop_down_to ~id:cell.id [] stack in
k scc
)
done
) seq;
assert (Stack.is_empty stack);
@ -502,20 +502,20 @@ let scc ?(tbl=mk_table 128) ~graph seq = SCC.explore ~tbl ~graph seq
module Dot = struct
type attribute = [
| `Color of string
| `Shape of string
| `Weight of int
| `Style of string
| `Label of string
| `Other of string * string
| `Color of string
| `Shape of string
| `Weight of int
| `Style of string
| `Label of string
| `Other of string * string
] (** Dot attribute *)
let pp_list pp_x out l =
Format.pp_print_string out "[";
List.iteri
(fun i x ->
if i > 0 then Format.fprintf out ",@;";
pp_x out x)
if i > 0 then Format.fprintf out ",@;";
pp_x out x)
l;
Format.pp_print_string out "]"
@ -609,10 +609,10 @@ type ('v, 'e) mut_graph = {
let mk_mut_tbl (type k) ?(eq=(=)) ?(hash=Hashtbl.hash) size =
let module Tbl = Hashtbl.Make(struct
type t = k
let hash = hash
let equal = eq
end) in
type t = k
let hash = hash
let equal = eq
end) in
let tbl = Tbl.create size in
{
graph=(fun v yield ->
@ -677,10 +677,10 @@ module Map(O : Map.OrderedType) : MAP with type vertex = O.t = struct
let as_graph m =
(fun v yield ->
try
let sub = M.find v m in
M.iter (fun v' e -> yield (e, v')) sub
with Not_found -> ()
try
let sub = M.find v m in
M.iter (fun v' e -> yield (e, v')) sub
with Not_found -> ()
)
let empty = M.empty
@ -753,19 +753,19 @@ let of_fun f =
let of_hashtbl tbl =
(fun v yield ->
try List.iter (fun b -> yield ((), b)) (Hashtbl.find tbl v)
with Not_found -> ()
try List.iter (fun b -> yield ((), b)) (Hashtbl.find tbl v)
with Not_found -> ()
)
let divisors_graph =
(fun i ->
(* divisors of [i] that are [>= j] *)
let rec divisors j i yield =
if j < i
then (
if (i mod j = 0) then yield ((),j);
divisors (j+1) i yield
)
in
divisors 1 i
(* divisors of [i] that are [>= j] *)
let rec divisors j i yield =
if j < i
then (
if (i mod j = 0) then yield ((),j);
divisors (j+1) i yield
)
in
divisors 1 i
)

166
src/data/CCGraph.mli
View file

@ -105,46 +105,46 @@ module Traverse : sig
type ('v, 'e) path = ('v * 'e * 'v) list
val generic: ?tbl:'v set ->
bag:'v bag ->
graph:('v, 'e) t ->
'v sequence ->
'v sequence_once
bag:'v bag ->
graph:('v, 'e) t ->
'v sequence ->
'v sequence_once
(** Traversal of the given graph, starting from a sequence
of vertices, using the given bag to choose the next vertex to
explore. Each vertex is visited at most once. *)
val generic_tag: tags:'v tag_set ->
bag:'v bag ->
graph:('v, 'e) t ->
'v sequence ->
'v sequence_once
bag:'v bag ->
graph:('v, 'e) t ->
'v sequence ->
'v sequence_once
(** One-shot traversal of the graph using a tag set and the given bag *)
val dfs: ?tbl:'v set ->
graph:('v, 'e) t ->
'v sequence ->
'v sequence_once
graph:('v, 'e) t ->
'v sequence ->
'v sequence_once
val dfs_tag: tags:'v tag_set ->
graph:('v, 'e) t ->
'v sequence ->
'v sequence_once
graph:('v, 'e) t ->
'v sequence ->
'v sequence_once
val bfs: ?tbl:'v set ->
graph:('v, 'e) t ->
'v sequence ->
'v sequence_once
graph:('v, 'e) t ->
'v sequence ->
'v sequence_once
val bfs_tag: tags:'v tag_set ->
graph:('v, 'e) t ->
'v sequence ->
'v sequence_once
graph:('v, 'e) t ->
'v sequence ->
'v sequence_once
val dijkstra : ?tbl:'v set ->
?dist:('e -> int) ->
graph:('v, 'e) t ->
'v sequence ->
('v * int * ('v,'e) path) sequence_once
?dist:('e -> int) ->
graph:('v, 'e) t ->
'v sequence ->
('v * int * ('v,'e) path) sequence_once
(** Dijkstra algorithm, traverses a graph in increasing distance order.
Yields each vertex paired with its distance to the set of initial vertices
(the smallest distance needed to reach the node from the initial vertices)
@ -152,10 +152,10 @@ module Traverse : sig
must be strictly positive. Default is 1 for every edge *)
val dijkstra_tag : ?dist:('e -> int) ->
tags:'v tag_set ->
graph:('v, 'e) t ->
'v sequence ->
('v * int * ('v,'e) path) sequence_once
tags:'v tag_set ->
graph:('v, 'e) t ->
'v sequence ->
('v * int * ('v,'e) path) sequence_once
(** {2 More detailed interface} *)
module Event : sig
@ -175,20 +175,20 @@ module Traverse : sig
val get_edge_kind : ('v, 'e) t -> ('v * 'e * 'v * edge_kind) option
val dfs: ?tbl:'v set ->
?eq:('v -> 'v -> bool) ->
graph:('v, 'e) graph ->
'v sequence ->
('v,'e) t sequence_once
?eq:('v -> 'v -> bool) ->
graph:('v, 'e) graph ->
'v sequence ->
('v,'e) t sequence_once
(** Full version of DFS.
@param eq equality predicate on vertices *)
val dfs_tag: ?eq:('v -> 'v -> bool) ->
tags:'v tag_set ->
graph:('v, 'e) graph ->
'v sequence ->
('v,'e) t sequence_once
(** Full version of DFS using integer tags
@param eq equality predicate on vertices *)
tags:'v tag_set ->
graph:('v, 'e) graph ->
'v sequence ->
('v,'e) t sequence_once
(** Full version of DFS using integer tags
@param eq equality predicate on vertices *)
end
end
@ -208,11 +208,11 @@ val is_dag :
exception Has_cycle
val topo_sort : ?eq:('v -> 'v -> bool) ->
?rev:bool ->
?tbl:'v set ->
graph:('v, 'e) t ->
'v sequence ->
'v list
?rev:bool ->
?tbl:'v set ->
graph:('v, 'e) t ->
'v sequence ->
'v list
(** [topo_sort ~graph seq] returns a list of vertices [l] where each
element of [l] is reachable from [seq].
The list is sorted in a way such that if [v -> v'] in the graph, then
@ -225,11 +225,11 @@ val topo_sort : ?eq:('v -> 'v -> bool) ->
@raise Has_cycle if the graph is not a DAG *)
val topo_sort_tag : ?eq:('v -> 'v -> bool) ->
?rev:bool ->
tags:'v tag_set ->
graph:('v, 'e) t ->
'v sequence ->
'v list
?rev:bool ->
tags:'v tag_set ->
graph:('v, 'e) t ->
'v sequence ->
'v list
(** Same as {!topo_sort} but uses an explicit tag set *)
(** {2 Lazy Spanning Tree} *)
@ -246,16 +246,16 @@ module Lazy_tree : sig
end
val spanning_tree : ?tbl:'v set ->
graph:('v, 'e) t ->
'v ->
('v, 'e) Lazy_tree.t
graph:('v, 'e) t ->
'v ->
('v, 'e) Lazy_tree.t
(** [spanning_tree ~graph v] computes a lazy spanning tree that has [v]
as a root. The table [tbl] is used for the memoization part *)
val spanning_tree_tag : tags:'v tag_set ->
graph:('v, 'e) t ->
'v ->
('v, 'e) Lazy_tree.t
graph:('v, 'e) t ->
'v ->
('v, 'e) Lazy_tree.t
(** {2 Strongly Connected Components} *)
@ -263,9 +263,9 @@ type 'v scc_state
(** Hidden state for {!scc} *)
val scc : ?tbl:('v, 'v scc_state) table ->
graph:('v, 'e) t ->
'v sequence ->
'v list sequence_once
graph:('v, 'e) t ->
'v sequence ->
'v list sequence_once
(** Strongly connected components reachable from the given vertices.
Each component is a list of vertices that are all mutually reachable
in the graph.
@ -274,7 +274,7 @@ val scc : ?tbl:('v, 'v scc_state) table ->
Uses {{: https://en.wikipedia.org/wiki/Tarjan's_strongly_connected_components_algorithm} Tarjan's algorithm}
@param tbl table used to map nodes to some hidden state
@raise Sequence_once if the result is iterated on more than once.
*)
*)
(** {2 Pretty printing in the DOT (graphviz) format}
@ -293,40 +293,40 @@ val scc : ?tbl:('v, 'v scc_state) table ->
module Dot : sig
type attribute = [
| `Color of string
| `Shape of string
| `Weight of int
| `Style of string
| `Label of string
| `Other of string * string
| `Color of string
| `Shape of string
| `Weight of int
| `Style of string
| `Label of string
| `Other of string * string
] (** Dot attribute *)
type vertex_state
(** Hidden state associated to a vertex *)
val pp : ?tbl:('v,vertex_state) table ->
?eq:('v -> 'v -> bool) ->
?attrs_v:('v -> attribute list) ->
?attrs_e:('e -> attribute list) ->
?name:string ->
graph:('v,'e) t ->
Format.formatter ->
'v ->
unit
?eq:('v -> 'v -> bool) ->
?attrs_v:('v -> attribute list) ->
?attrs_e:('e -> attribute list) ->
?name:string ->
graph:('v,'e) t ->
Format.formatter ->
'v ->
unit
(** Print the graph, starting from given vertex, on the formatter
@param attrs_v attributes for vertices
@param attrs_e attributes for edges
@param name name of the graph *)
val pp_seq : ?tbl:('v,vertex_state) table ->
?eq:('v -> 'v -> bool) ->
?attrs_v:('v -> attribute list) ->
?attrs_e:('e -> attribute list) ->
?name:string ->
graph:('v,'e) t ->
Format.formatter ->
'v sequence ->
unit
?eq:('v -> 'v -> bool) ->
?attrs_v:('v -> attribute list) ->
?attrs_e:('e -> attribute list) ->
?name:string ->
graph:('v,'e) t ->
Format.formatter ->
'v sequence ->
unit
val with_out : string -> (Format.formatter -> 'a) -> 'a
(** Shortcut to open a file and write to it *)
@ -341,9 +341,9 @@ type ('v, 'e) mut_graph = {
}
val mk_mut_tbl : ?eq:('v -> 'v -> bool) ->
?hash:('v -> int) ->
int ->
('v, 'a) mut_graph
?hash:('v -> int) ->
int ->
('v, 'a) mut_graph
(** Make a new mutable graph from a Hashtbl. Edges are labelled with type ['a] *)
(** {2 Immutable Graph}

6
src/data/CCHashSet.ml
View file

@ -158,7 +158,7 @@ module Make(E : ELEMENT) : S with type elt = E.t = struct
let inter_mut ~into a =
iter
(fun x ->
if not (mem a x) then remove into x
if not (mem a x) then remove into x
) into
let union a b =
@ -229,8 +229,8 @@ module Make(E : ELEMENT) : S with type elt = E.t = struct
if !first
then first := false
else (
Format.pp_print_string out sep;
Format.pp_print_cut out ();
Format.pp_print_string out sep;
Format.pp_print_cut out ();
);
pp_x out x
) s;

156
src/data/CCHashTrie.ml
View file

@ -179,7 +179,7 @@ let popcount b =
(*$Q
Q.int (fun i -> let i = i land (1 lsl 32) in popcount i <= 32)
*)
*)
(* sparse array, using a bitfield and POPCOUNT *)
module A_SPARSE = struct
@ -216,9 +216,9 @@ module A_SPARSE = struct
let arr = Array.make (n+1) x in
arr.(real_idx) <- x;
if real_idx>0
then Array.blit a.arr 0 arr 0 real_idx;
then Array.blit a.arr 0 arr 0 real_idx;
if real_idx<n
then Array.blit a.arr real_idx arr (real_idx+1) (n-real_idx);
then Array.blit a.arr real_idx arr (real_idx+1) (n-real_idx);
{a with bits; arr}
) else (
(* replace element at [real_idx] *)
@ -244,9 +244,9 @@ module A_SPARSE = struct
let n = Array.length a.arr in
let arr = Array.make (n+1) x in
if real_idx>0
then Array.blit a.arr 0 arr 0 real_idx;
then Array.blit a.arr 0 arr 0 real_idx;
if real_idx<n
then Array.blit a.arr real_idx arr (real_idx+1) (n-real_idx);
then Array.blit a.arr real_idx arr (real_idx+1) (n-real_idx);
{a with bits; arr}
) else (
let x = f a.arr.(real_idx) in
@ -267,9 +267,9 @@ module A_SPARSE = struct
let n = Array.length a.arr in
let arr = if n=1 then [||] else Array.make (n-1) a.arr.(0) in
if real_idx > 0
then Array.blit a.arr 0 arr 0 real_idx;
then Array.blit a.arr 0 arr 0 real_idx;
if real_idx+1 < n
then Array.blit a.arr (real_idx+1) arr real_idx (n-real_idx-1);
then Array.blit a.arr (real_idx+1) arr real_idx (n-real_idx-1);
{a with bits; arr}
)
@ -281,7 +281,7 @@ end
(** {2 Functors} *)
module Make(Key : KEY)
: S with type key = Key.t
: S with type key = Key.t
= struct
module A = A_SPARSE
@ -351,22 +351,22 @@ module Make(Key : KEY)
| Nil -> raise Not_found
| One (k', v') -> if Key.equal k k' then v' else raise Not_found
| Two (k1, v1, k2, v2) ->
if Key.equal k k1 then v1
else if Key.equal k k2 then v2
else raise Not_found
if Key.equal k k1 then v1
else if Key.equal k k2 then v2
else raise Not_found
| Cons (k', v', tail) ->
if Key.equal k k' then v' else get_exn_list_ k tail
if Key.equal k k' then v' else get_exn_list_ k tail
let rec get_exn_ k ~h m = match m with
| E -> raise Not_found
| S (_, k', v') -> if Key.equal k k' then v' else raise Not_found
| L (_, l) -> get_exn_list_ k l
| N (leaf, a) ->
if Hash.is_0 h then get_exn_list_ k leaf
else
let i = Hash.rem h in
let h' = Hash.quotient h in
get_exn_ k ~h:h' (A.get ~default:E a i)
if Hash.is_0 h then get_exn_list_ k leaf
else
let i = Hash.rem h in
let h' = Hash.quotient h in
get_exn_ k ~h:h' (A.get ~default:E a i)
let get_exn k m = get_exn_ k ~h:(hash_ k) m
@ -390,15 +390,15 @@ module Make(Key : KEY)
let rec add_list_ k v l = match l with
| Nil -> One (k,v)
| One (k1, v1) ->
if Key.equal k k1 then One (k, v) else Two (k,v,k1,v1)
if Key.equal k k1 then One (k, v) else Two (k,v,k1,v1)
| Two (k1, v1, k2, v2) ->
if Key.equal k k1 then Two (k, v, k2, v2)
else if Key.equal k k2 then Two (k, v, k1, v1)
else Cons (k, v, l)
if Key.equal k k1 then Two (k, v, k2, v2)
else if Key.equal k k2 then Two (k, v, k1, v1)
else Cons (k, v, l)
| Cons (k', v', tail) ->
if Key.equal k k'
then Cons (k, v, tail) (* replace *)
else Cons (k', v', add_list_ k v tail)
if Key.equal k k'
then Cons (k, v, tail) (* replace *)
else Cons (k', v', add_list_ k v tail)
let node_ leaf a = N (leaf, a)
@ -407,23 +407,23 @@ module Make(Key : KEY)
let rec add_ ~id k v ~h m = match m with
| E -> S (h, k, v)
| S (h', k', v') ->
if h=h'
then if Key.equal k k'
then S (h, k, v) (* replace *)
else L (h, Cons (k, v, Cons (k', v', Nil)))
else
make_array_ ~id ~leaf:(Cons (k', v', Nil)) ~h_leaf:h' k v ~h
if h=h'
then if Key.equal k k'
then S (h, k, v) (* replace *)
else L (h, Cons (k, v, Cons (k', v', Nil)))
else
make_array_ ~id ~leaf:(Cons (k', v', Nil)) ~h_leaf:h' k v ~h
| L (h', l) ->
if h=h'
then L (h, add_list_ k v l)
else (* split into N *)
make_array_ ~id ~leaf:l ~h_leaf:h' k v ~h
if h=h'
then L (h, add_list_ k v l)
else (* split into N *)
make_array_ ~id ~leaf:l ~h_leaf:h' k v ~h
| N (leaf, a) ->
if Hash.is_0 h
then node_ (add_list_ k v leaf) a
else
let mut = A.owns ~id a in (* can we modify [a] in place? *)
node_ leaf (add_to_array_ ~id ~mut k v ~h a)
if Hash.is_0 h
then node_ (add_list_ k v leaf) a
else
let mut = A.owns ~id a in (* can we modify [a] in place? *)
node_ leaf (add_to_array_ ~id ~mut k v ~h a)
(* make an array containing a leaf, and insert (k,v) in it *)
and make_array_ ~id ~leaf ~h_leaf:h' k v ~h =
@ -493,40 +493,40 @@ module Make(Key : KEY)
let rec remove_list_ k l = match l with
| Nil -> Nil
| One (k', _) ->
if Key.equal k k' then Nil else l
if Key.equal k k' then Nil else l
| Two (k1, v1, k2, v2) ->
if Key.equal k k1 then One (k2, v2)
else if Key.equal k k2 then One (k1, v1)
else l
if Key.equal k k1 then One (k2, v2)
else if Key.equal k k2 then One (k1, v1)
else l
| Cons (k', v', tail) ->
if Key.equal k k'
then tail
else Cons (k', v', remove_list_ k tail)
if Key.equal k k'
then tail
else Cons (k', v', remove_list_ k tail)
let rec remove_rec_ ~id k ~h m = match m with
| E -> E
| S (_, k', _) ->
if Key.equal k k' then E else m
if Key.equal k k' then E else m
| L (h, l) ->
let l = remove_list_ k l in
if is_empty_list_ l then E else L (h, l)
let l = remove_list_ k l in
if is_empty_list_ l then E else L (h, l)
| N (leaf, a) ->
let leaf, a =
if Hash.is_0 h
then remove_list_ k leaf, a
else
let i = Hash.rem h in
let h' = Hash.quotient h in
let new_t = remove_rec_ ~id k ~h:h' (A.get ~default:E a i) in
if is_empty new_t
then leaf, A.remove a i (* remove sub-tree *)
else
let mut = A.owns ~id a in
leaf, A.set ~mut a i new_t
in
if is_empty_list_ leaf && is_empty_arr_ a
then E
else N (leaf, a)
let leaf, a =
if Hash.is_0 h
then remove_list_ k leaf, a
else
let i = Hash.rem h in
let h' = Hash.quotient h in
let new_t = remove_rec_ ~id k ~h:h' (A.get ~default:E a i) in
if is_empty new_t
then leaf, A.remove a i (* remove sub-tree *)
else
let mut = A.owns ~id a in
leaf, A.set ~mut a i new_t
in
if is_empty_list_ leaf && is_empty_arr_ a
then E
else N (leaf, a)
let remove k m = remove_rec_ ~id:Transient.empty k ~h:(hash_ k) m
@ -553,10 +553,10 @@ module Make(Key : KEY)
let h = hash_ k in
let opt_v = try Some (get_exn_ k ~h m) with Not_found -> None in
match opt_v, f opt_v with
| None, None -> m
| Some _, Some v
| None, Some v -> add_ ~id k v ~h m
| Some _, None -> remove_rec_ ~id k ~h m
| None, None -> m
| Some _, Some v
| None, Some v -> add_ ~id k v ~h m
| Some _, None -> remove_rec_ ~id k ~h m
let update k ~f m = update_ ~id:Transient.empty k f m
@ -664,17 +664,17 @@ module Make(Key : KEY)
| L (_, Nil) -> next()
| L (_, One (k,v)) -> Some (k,v)
| L (h, Two (k1,v1,k2,v2)) ->
Stack.push (L (h, One (k2,v2))) st;
Some (k1,v1)
Stack.push (L (h, One (k2,v2))) st;
Some (k1,v1)
| L (h, Cons(k,v,tl)) ->
Stack.push (L (h, tl)) st; (* tail *)
Some (k,v)
Stack.push (L (h, tl)) st; (* tail *)
Some (k,v)
| N (l, a) ->
A.iter
(fun sub -> Stack.push sub st)
a;
Stack.push (L (Hash.zero, l)) st; (* leaf *)
next()
A.iter
(fun sub -> Stack.push sub st)
a;
Stack.push (L (Hash.zero, l)) st; (* leaf *)
next()
in
next

16
src/data/CCHashTrie.mli
View file

@ -2,17 +2,17 @@
(** {1 Hash Tries}
Trie indexed by the hash of the keys, where the branching factor is fixed.
The goal is to have a quite efficient functional structure with fast
update and access {b if} the hash function is good.
The trie is not binary, to improve cache locality and decrease depth.
Trie indexed by the hash of the keys, where the branching factor is fixed.
The goal is to have a quite efficient functional structure with fast
update and access {b if} the hash function is good.
The trie is not binary, to improve cache locality and decrease depth.
Preliminary benchmarks (see the "tbl" section of benchmarks) tend to show
that this type is quite efficient for small data sets.
Preliminary benchmarks (see the "tbl" section of benchmarks) tend to show
that this type is quite efficient for small data sets.
{b status: unstable}
{b status: unstable}
@since 0.13
@since 0.13
*)
type 'a sequence = ('a -> unit) -> unit

8
src/data/CCHet.ml
View file

@ -74,8 +74,8 @@ type exn_pair =
let pair_of_e_pair (E_pair (k,e)) =
let module K = (val k) in
match e with
| K.Store v -> Pair (k,v)
| _ -> assert false
| K.Store v -> Pair (k,v)
| _ -> assert false
module Tbl = struct
module M = Hashtbl.Make(struct
@ -148,8 +148,8 @@ module Map = struct
let module K = (val k) in
let E_pair (_, e) = M.find K.id t in
match e with
| K.Store v -> v
| _ -> assert false
| K.Store v -> v
| _ -> assert false
let find k t =
try Some (find_exn k t)

6
src/data/CCImmutArray.ml
View file

@ -46,9 +46,9 @@ let foldi f acc a =
let n = ref 0 in
Array.fold_left
(fun acc x ->
let acc = f acc !n x in
incr n;
acc)
let acc = f acc !n x in
incr n;
acc)
acc a
exception ExitNow

94
src/data/CCIntMap.ml
View file

@ -26,7 +26,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(** {1 Map specialized for Int keys} *)
(* "Fast Mergeable Integer Maps", Okasaki & Gill.
We use big-endian trees. *)
We use big-endian trees. *)
(** Masks with exactly one bit active *)
module Bit : sig
@ -83,7 +83,7 @@ let is_prefix_ ~prefix y ~bit = prefix = Bit.mask y ~mask:bit
(*$inject
let _list_uniq = CCList.sort_uniq ~cmp:(fun a b-> Pervasives.compare (fst a)(fst b))
*)
*)
(*$Q
Q.int (fun i -> \
@ -99,7 +99,7 @@ let is_prefix_ ~prefix y ~bit = prefix = Bit.mask y ~mask:bit
(Bit.highest 2 :> int) = 2
(Bit.highest 17 :> int) = 16
(Bit.highest 300 :> int) = 256
*)
*)
(* helper:
@ -120,18 +120,18 @@ let check_invariants t =
let rec check_keys path t = match t with
| E -> true
| L (k, _) ->
List.for_all
(fun (prefix, switch, side) ->
is_prefix_ ~prefix k ~bit:switch
&&
match side with
| `Left -> Bit.is_0 k ~bit:switch
| `Right -> Bit.is_1 k ~bit:switch
) path
List.for_all
(fun (prefix, switch, side) ->
is_prefix_ ~prefix k ~bit:switch
&&
match side with
| `Left -> Bit.is_0 k ~bit:switch
| `Right -> Bit.is_1 k ~bit:switch
) path
| N (prefix, switch, l, r) ->
check_keys ((prefix, switch, `Left) :: path) l
&&
check_keys ((prefix, switch, `Right) :: path) r
check_keys ((prefix, switch, `Left) :: path) l
&&
check_keys ((prefix, switch, `Right) :: path) r
in
check_keys [] t
@ -151,7 +151,7 @@ let rec find_exn k t = match t with
else find_exn k r
else raise Not_found
(* XXX could test with lt_unsigned_? *)
(* XXX could test with lt_unsigned_? *)
(*
if k <= prefix (* search tree *)
@ -185,7 +185,7 @@ let mk_node_ prefix switch l r = match l, r with
| _ -> N (prefix, switch, l, r)
(* join trees t1 and t2 with prefix p1 and p2 respectively
(p1 and p2 do not overlap) *)
(p1 and p2 do not overlap) *)
let join_ t1 p1 t2 p2 =
let switch = branching_bit_ p1 p2 in
let prefix = Bit.mask p1 ~mask:switch in
@ -246,7 +246,7 @@ let update k f t =
| Some v' -> add k v' t
end
with Not_found ->
match f None with
match f None with
| None -> t
| Some v -> add k v t
@ -263,7 +263,7 @@ let rec equal ~eq 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) ->
pa=pb && sa=sb && equal ~eq la lb && equal ~eq ra rb
pa=pb && sa=sb && equal ~eq la lb && equal ~eq ra rb
| E, _
| N _, _
| L _, _ -> false
@ -291,13 +291,13 @@ let rec mapi f t = match t with
| E -> E
| L (k, v) -> L (k, f k v)
| N (p, s, l, r) ->
N (p, s, mapi f l, mapi f r)
N (p, s, mapi f l, mapi f r)
let rec map f t = match t with
| E -> E
| L (k, v) -> L (k, f v)
| N (p, s, l, r) ->
N (p, s, map f l, map f r)
N (p, s, map f l, map f r)
let rec choose_exn = function
| E -> raise Not_found
@ -318,13 +318,13 @@ let rec union f t1 t2 = match t1, t2 with
if p1 = p2 && m1 = m2
then mk_node_ p1 m1 (union f l1 l2) (union f r1 r2)
else if Bit.gt m1 m2 && is_prefix_ ~prefix:p1 p2 ~bit:m1
then if Bit.is_0 p2 ~bit:m1
then N (p1, m1, union f l1 t2, r1)
else N (p1, m1, l1, union f r1 t2)
then if Bit.is_0 p2 ~bit:m1
then N (p1, m1, union f l1 t2, r1)
else N (p1, m1, l1, union f r1 t2)
else if Bit.lt m1 m2 && is_prefix_ ~prefix:p2 p1 ~bit:m2
then if Bit.is_0 p1 ~bit:m2
then N (p2, m2, union f t1 l2, r2)
else N (p2, m2, l2, union f t1 r2)
then if Bit.is_0 p1 ~bit:m2
then N (p2, m2, union f t1 l2, r2)
else N (p2, m2, l2, union f t1 r2)
else join_ t1 p1 t2 p2
(*$Q & ~small:(fun (a,b) -> List.length a + List.length b)
@ -366,21 +366,21 @@ let rec inter f a b = match a, b with
| L (k, v), o
| o, L (k, v) ->
begin try
let v' = find_exn k o in
L (k, f k v v')
with Not_found -> E
let v' = find_exn k o in
L (k, f k v v')
with Not_found -> E
end
| N (p1, m1, l1, r1), N (p2, m2, l2, r2) ->
if p1 = p2 && m1 = m2
then mk_node_ p1 m1 (inter f l1 l2) (inter f r1 r2)
else if Bit.gt m1 m2 && is_prefix_ ~prefix:p1 p2 ~bit:m1
then if Bit.is_0 p2 ~bit:m1
then inter f l1 b
else inter f r1 b
then if Bit.is_0 p2 ~bit:m1
then inter f l1 b
else inter f r1 b
else if Bit.lt m1 m2 && is_prefix_ ~prefix:p2 p1 ~bit:m2
then if Bit.is_0 p1 ~bit:m2
then inter f l2 a
else inter f r2 a
then if Bit.is_0 p1 ~bit:m2
then inter f l2 a
else inter f r2 a
else E
(*$R
@ -427,7 +427,7 @@ let to_list t = fold (fun k v l -> (k,v) :: l) t []
(*$Q
Q.(list (pair int int)) (fun l -> \
of_list l |> cardinal = List.length l)
*)
*)
let add_seq t seq =
let t = ref t in
@ -458,8 +458,8 @@ let to_gen m =
| E -> next() (* backtrack *)
| L (k,v) -> Some (k,v)
| N (_, _, l, r) ->
Stack.push r st;
explore l
Stack.push r st;
explore l
in
next
@ -480,11 +480,11 @@ let compare ~cmp a b =
| Some _, None -> 1
| None, Some _ -> -1
| Some (ka, va), Some (kb, vb) ->
if ka=kb
then
let c = cmp va vb in
if c=0 then cmp_gen cmp a b else c
else Pervasives.compare ka kb
if ka=kb
then
let c = cmp va vb in
if c=0 then cmp_gen cmp a b else c
else Pervasives.compare ka kb
in
cmp_gen cmp (to_gen a) (to_gen b)
@ -553,9 +553,9 @@ let print pp_x out m =
let first = ref true in
iter
(fun k v ->
if !first then first := false else Format.pp_print_string out ", ";
Format.fprintf out "%d -> " k;
pp_x out v;
Format.pp_print_cut out ()
if !first then first := false else Format.pp_print_string out ", ";
Format.fprintf out "%d -> " k;
pp_x out v;
Format.pp_print_cut out ()
) m;
Format.fprintf out "}@]"

4
src/data/CCIntMap.mli
View file

@ -25,8 +25,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(** {1 Map specialized for Int keys}
{b status: stable}
@since 0.10 *)
{b status: stable}
@since 0.10 *)
type 'a t

6
src/data/CCMixmap.ml
View file

@ -146,9 +146,9 @@ module Make(X : ORD) : S with type key = X.t = struct
let bindings_of ~inj map yield =
M.iter
(fun k value ->
match inj.get value with
| None -> ()
| Some v -> yield (k, v)
match inj.get value with
| None -> ()
| Some v -> yield (k, v)
) map
type value =

12
src/data/CCMixmap.mli
View file

@ -18,12 +18,12 @@
|> M.add ~inj:inj_str 2 "2"
|> M.add ~inj:inj_list_int 3 [3;3;3]
assert (M.get ~inj:inj_int 1 m = Some 1)
assert (M.get ~inj:inj_str 1 m = None)
assert (M.get ~inj:inj_str 2 m = Some "2")
assert (M.get ~inj:inj_int 2 m = None)
assert (M.get ~inj:inj_list_int 3 m = Some [3;3;3])
assert (M.get ~inj:inj_str 3 m = None)
assert (M.get ~inj:inj_int 1 m = Some 1)
assert (M.get ~inj:inj_str 1 m = None)
assert (M.get ~inj:inj_str 2 m = Some "2")
assert (M.get ~inj:inj_int 2 m = None)
assert (M.get ~inj:inj_list_int 3 m = Some [3;3;3])
assert (M.get ~inj:inj_str 3 m = None)
]}
@since 0.9

6
src/data/CCMixset.ml
View file

@ -4,9 +4,9 @@
(** {1 Set of Heterogeneous Values} *)
module IMap = Map.Make(struct
type t = int
let compare : int -> int -> int = compare
end)
type t = int
let compare : int -> int -> int = compare
end)
(*$R
let k1 : int key = newkey () in

6
src/data/CCMixtbl.ml
View file

@ -138,9 +138,9 @@ let keys_seq tbl yield =
let bindings_of ~inj tbl yield =
Hashtbl.iter
(fun k value ->
match inj.get value with
| None -> ()
| Some v -> yield (k, v)
match inj.get value with
| None -> ()
| Some v -> yield (k, v)
) tbl
type value =

36
src/data/CCMixtbl.mli
View file

@ -3,34 +3,34 @@
(** {1 Hash Table with Heterogeneous Keys}
From https://github.com/mjambon/mixtbl (thanks to him).
Example:
From https://github.com/mjambon/mixtbl (thanks to him).
Example:
{[
let inj_int = CCMixtbl.create_inj () ;;
{[
let inj_int = CCMixtbl.create_inj () ;;
let tbl = CCMixtbl.create 10 ;;
let tbl = CCMixtbl.create 10 ;;
OUnit.assert_equal None (CCMixtbl.get ~inj:inj_int tbl "a");;
OUnit.assert_equal None (CCMixtbl.get ~inj:inj_int tbl "a");;
CCMixtbl.set inj_int tbl "a" 1;;
CCMixtbl.set inj_int tbl "a" 1;;
OUnit.assert_equal (Some 1) (CCMixtbl.get ~inj:inj_int tbl "a");;
OUnit.assert_equal (Some 1) (CCMixtbl.get ~inj:inj_int tbl "a");;
let inj_string = CCMixtbl.create_inj () ;;
let inj_string = CCMixtbl.create_inj () ;;
CCMixtbl.set inj_string tbl "b" "Hello";
CCMixtbl.set inj_string tbl "b" "Hello";
OUnit.assert_equal (Some "Hello") (CCMixtbl.get inj_string tbl "b");;
OUnit.assert_equal None (CCMixtbl.get inj_string tbl "a");;
OUnit.assert_equal (Some 1) (CCMixtbl.get inj_int tbl "a");;
CCMixtbl.set inj_string tbl "a" "Bye";;
OUnit.assert_equal (Some "Hello") (CCMixtbl.get inj_string tbl "b");;
OUnit.assert_equal None (CCMixtbl.get inj_string tbl "a");;
OUnit.assert_equal (Some 1) (CCMixtbl.get inj_int tbl "a");;
CCMixtbl.set inj_string tbl "a" "Bye";;
OUnit.assert_equal None (CCMixtbl.get inj_int tbl "a");;
OUnit.assert_equal (Some "Bye") (CCMixtbl.get inj_string tbl "a");;
]}
OUnit.assert_equal None (CCMixtbl.get inj_int tbl "a");;
OUnit.assert_equal (Some "Bye") (CCMixtbl.get inj_string tbl "a");;
]}
@since 0.6 *)
@since 0.6 *)
type 'a t
(** A hash table containing values of different types.

94
src/data/CCMultiMap.ml
View file

@ -33,59 +33,59 @@ module type S = sig
type t
val empty : t
(** Empty multimap *)
(** Empty multimap *)
val is_empty : t -> bool
(** Empty multimap? *)
(** Empty multimap? *)
val add : t -> key -> value -> t
(** Add a key/value binding *)
(** Add a key/value binding *)
val remove : t -> key -> value -> t
(** Remove the binding *)
(** Remove the binding *)
val remove_all : t -> key -> t
(** Remove the key from the map *)
(** Remove the key from the map *)
val mem : t -> key -> bool
(** Is there a binding for this key? *)
(** Is there a binding for this key? *)
val find : t -> key -> value list
(** List of values for this key *)
(** List of values for this key *)
val find_iter : t -> key -> (value -> unit) -> unit
(** Iterate on bindings for this key *)
(** Iterate on bindings for this key *)
val count : t -> key -> int
(** Number of bindings for this key *)
(** Number of bindings for this key *)
val iter : t -> (key -> value -> unit) -> unit
(** Iterate on all key/value *)
(** Iterate on all key/value *)
val fold : t -> 'a -> ('a -> key -> value -> 'a) -> 'a
(** Fold on all key/value *)
(** Fold on all key/value *)
val size : t -> int
(** Number of keys *)
(** Number of keys *)
val union : t -> t -> t
(** Union of multimaps *)
(** Union of multimaps *)
val inter : t -> t -> t
(** Intersection of multimaps *)
(** Intersection of multimaps *)
val diff : t -> t -> t
(** Difference of maps, ie bindings of the first that are not
in the second *)
(** Difference of maps, ie bindings of the first that are not
in the second *)
val equal : t -> t -> bool
(** Same multimap *)
(** Same multimap *)
val compare : t -> t -> int
(** Total order on multimaps *)
(** Total order on multimaps *)
val submap : t -> t -> bool
(** [submap m1 m2] is true iff all bindings of [m1] are also in [m2] *)
(** [submap m1 m2] is true iff all bindings of [m1] are also in [m2] *)
val to_seq : t -> (key * value) sequence
@ -94,7 +94,7 @@ module type S = sig
val keys : t -> key sequence
val values : t -> value sequence
(** Some values may occur several times *)
(** Some values may occur several times *)
end
module type OrderedType = sig
@ -110,7 +110,7 @@ module Make(K : OrderedType)(V : OrderedType) = struct
module S = Set.Make(V)
type t = S.t M.t
(** Map of sets *)
(** Map of sets *)
let empty = M.empty
@ -125,8 +125,8 @@ module Make(K : OrderedType)(V : OrderedType) = struct
let set = M.find k m in
let set' = S.remove v set in
if S.is_empty set'
then M.remove k m
else M.add k set' m
then M.remove k m
else M.add k set' m
with Not_found ->
m
@ -167,34 +167,34 @@ module Make(K : OrderedType)(V : OrderedType) = struct
let union m1 m2 =
M.merge
(fun _k v1 v2 -> match v1, v2 with
| None, None -> None
| Some set1, Some set2 -> Some (S.union set1 set2)
| Some set, None
| None, Some set -> Some set)
| None, None -> None
| Some set1, Some set2 -> Some (S.union set1 set2)
| Some set, None
| None, Some set -> Some set)
m1 m2
let inter m1 m2 =
M.merge
(fun _k v1 v2 -> match v1, v2 with
| None, _
| _, None -> None
| Some set1, Some set2 ->
let set = S.inter set1 set2 in
if S.is_empty set
then None
else Some set)
| None, _
| _, None -> None
| Some set1, Some set2 ->
let set = S.inter set1 set2 in
if S.is_empty set
then None
else Some set)
m1 m2
let diff m1 m2 =
M.merge
(fun _k v1 v2 -> match v1, v2 with
| None, _ -> None
| Some set, None -> Some set
| Some set1, Some set2 ->
let set' = S.diff set1 set2 in
if S.is_empty set'
then None
else Some set')
| None, _ -> None
| Some set, None -> Some set
| Some set1, Some set2 ->
let set' = S.diff set1 set2 in
if S.is_empty set'
then None
else Some set')
m1 m2
let equal m1 m2 =
@ -206,11 +206,11 @@ module Make(K : OrderedType)(V : OrderedType) = struct
let submap m1 m2 =
M.for_all
(fun k set1 ->
try
let set2 = M.find k m2 in
S.subset set1 set2
with Not_found ->
false)
try
let set2 = M.find k m2 in
S.subset set1 set2
with Not_found ->
false)
m1
let to_seq m k = iter m (fun x y -> k (x,y))
@ -291,7 +291,7 @@ let _fold_seq f acc seq =
let _head_seq seq =
let r = ref None in
begin try seq (fun x -> r := Some x; raise Exit)
with Exit -> ();
with Exit -> ();
end;
!r

46
src/data/CCMultiMap.mli
View file

@ -33,59 +33,59 @@ module type S = sig
type t
val empty : t
(** Empty multimap *)
(** Empty multimap *)
val is_empty : t -> bool
(** Empty multimap? *)
(** Empty multimap? *)
val add : t -> key -> value -> t
(** Add a key/value binding *)
(** Add a key/value binding *)
val remove : t -> key -> value -> t
(** Remove the binding *)
(** Remove the binding *)
val remove_all : t -> key -> t
(** Remove the key from the map *)
(** Remove the key from the map *)
val mem : t -> key -> bool
(** Is there a binding for this key? *)
(** Is there a binding for this key? *)
val find : t -> key -> value list
(** List of values for this key *)
(** List of values for this key *)
val find_iter : t -> key -> (value -> unit) -> unit
(** Iterate on bindings for this key *)
(** Iterate on bindings for this key *)
val count : t -> key -> int
(** Number of bindings for this key *)
(** Number of bindings for this key *)
val iter : t -> (key -> value -> unit) -> unit
(** Iterate on all key/value *)
(** Iterate on all key/value *)
val fold : t -> 'a -> ('a -> key -> value -> 'a) -> 'a
(** Fold on all key/value *)
(** Fold on all key/value *)
val size : t -> int
(** Number of keys *)
(** Number of keys *)
val union : t -> t -> t
(** Union of multimaps *)
(** Union of multimaps *)
val inter : t -> t -> t
(** Intersection of multimaps *)
(** Intersection of multimaps *)
val diff : t -> t -> t
(** Difference of maps, ie bindings of the first that are not
in the second *)
(** Difference of maps, ie bindings of the first that are not
in the second *)
val equal : t -> t -> bool
(** Same multimap *)
(** Same multimap *)
val compare : t -> t -> int
(** Total order on multimaps *)
(** Total order on multimaps *)
val submap : t -> t -> bool
(** [submap m1 m2] is true iff all bindings of [m1] are also in [m2] *)
(** [submap m1 m2] is true iff all bindings of [m1] are also in [m2] *)
val to_seq : t -> (key * value) sequence
@ -94,7 +94,7 @@ module type S = sig
val keys : t -> key sequence
val values : t -> value sequence
(** Some values may occur several times *)
(** Some values may occur several times *)
end
module type OrderedType = sig
@ -105,10 +105,10 @@ end
module Make(K : OrderedType)(V : OrderedType) : S with type key = K.t and type value = V.t
(** {2 Two-Way Multimap}
Represents n-to-n mappings between two types. Each element from the "left"
is mapped to several right values, and conversely.
Represents n-to-n mappings between two types. Each element from the "left"
is mapped to several right values, and conversely.
@since 0.3.3 *)
@since 0.3.3 *)
module type BIDIR = sig
type t

68
src/data/CCMultiSet.ml
View file

@ -123,28 +123,28 @@ module Make(O : Set.OrderedType) = struct
let add_mult ms x n =
if n < 0 then invalid_arg "CCMultiSet.add_mult";
if n=0
then ms
else M.add x (count ms x + n) ms
then ms
else M.add x (count ms x + n) ms
let remove_mult ms x n =
if n < 0 then invalid_arg "CCMultiSet.remove_mult";
let cur_n = count ms x in
let new_n = cur_n - n in
if new_n <= 0
then M.remove x ms
else M.add x new_n ms
then M.remove x ms
else M.add x new_n ms
let remove ms x = remove_mult ms x 1
let update ms x f =
let n = count ms x in
match f n with
| 0 ->
| 0 ->
if n=0 then ms else M.remove x ms
| n' ->
| n' ->
if n' < 0
then invalid_arg "CCMultiSet.update"
else M.add x n' ms
then invalid_arg "CCMultiSet.update"
else M.add x n' ms
let min ms =
fst (M.min_binding ms)
@ -155,39 +155,39 @@ module Make(O : Set.OrderedType) = struct
let union m1 m2 =
M.merge
(fun _x n1 n2 -> match n1, n2 with
| None, None -> assert false
| Some n, None
| None, Some n -> Some n
| Some n1, Some n2 -> Some (n1+n2))
| None, None -> assert false
| Some n, None
| None, Some n -> Some n
| Some n1, Some n2 -> Some (n1+n2))
m1 m2
let meet m1 m2 =
M.merge
(fun _ n1 n2 -> match n1, n2 with
| None, None -> assert false
| Some n, None | None, Some n -> Some n
| Some n1, Some n2 -> Some (Pervasives.max n1 n2))
m1 m2
M.merge
(fun _ n1 n2 -> match n1, n2 with
| None, None -> assert false
| Some n, None | None, Some n -> Some n
| Some n1, Some n2 -> Some (Pervasives.max n1 n2))
m1 m2
let intersection m1 m2 =
M.merge
(fun _x n1 n2 -> match n1, n2 with
| None, None -> assert false
| Some _, None
| None, Some _ -> None
| Some n1, Some n2 -> Some (Pervasives.min n1 n2))
| None, None -> assert false
| Some _, None
| None, Some _ -> None
| Some n1, Some n2 -> Some (Pervasives.min n1 n2))
m1 m2
let diff m1 m2 =
M.merge
(fun _x n1 n2 -> match n1, n2 with
| None, None -> assert false
| Some n1, None -> Some n1
| None, Some _n2 -> None
| Some n1, Some n2 ->
if n1 > n2
then Some (n1 - n2)
else None)
| None, None -> assert false
| Some n1, None -> Some n1
| None, Some _n2 -> None
| Some n1, Some n2 ->
if n1 > n2
then Some (n1 - n2)
else None)
m1 m2
let contains m1 m2 =
@ -211,8 +211,8 @@ module Make(O : Set.OrderedType) = struct
let of_list l =
let rec build acc l = match l with
| [] -> acc
| x::l' -> build (add acc x) l'
| [] -> acc
| x::l' -> build (add acc x) l'
in
build empty l
@ -220,9 +220,9 @@ module Make(O : Set.OrderedType) = struct
(* [n_cons n x l] is the result of applying [fun l -> x :: l] [n] times
to [l] *)
let rec n_cons n x l = match n with
| 0 -> l
| 1 -> x::l
| _ -> n_cons (n-1) x (x::l)
| 0 -> l
| 1 -> x::l
| _ -> n_cons (n-1) x (x::l)
in
fold m [] (fun acc n x -> n_cons n x acc)

18
src/data/CCPersistentArray.ml
View file

@ -38,12 +38,12 @@ let rec _reroot t k = match !t with
| Array a -> k a
| Diff (i, v, t') ->
_reroot t' (fun a ->
let v' = a.(i) in
a.(i) <- v;
t := Array a;
t' := Diff(i, v', t);
k a
)
let v' = a.(i) in
a.(i) <- v;
t := Array a;
t' := Diff(i, v', t);
k a
)
let reroot t = match !t with
| Array a -> a
@ -159,7 +159,7 @@ let to_gen a =
(*$Q
Q.(list int) (fun l -> \
of_list l |> to_gen |> of_gen |> to_list = l)
*)
*)
type 'a printer = Format.formatter -> 'a -> unit
@ -167,8 +167,8 @@ let print pp_item out v =
Format.fprintf out "[|";
iteri
(fun i x ->
if i > 0 then Format.fprintf out ";@ ";
pp_item out x
if i > 0 then Format.fprintf out ";@ ";
pp_item out x
) v;
Format.fprintf out "|]"

8
src/data/CCPersistentArray.mli
View file

@ -26,11 +26,11 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(** {1 Persistent Arrays}
From the paper by Jean-Christophe Filliâtre,
"A persistent Union-Find data structure", see
{{: https://www.lri.fr/~filliatr/ftp/publis/puf-wml07.ps} the ps version}
From the paper by Jean-Christophe Filliâtre,
"A persistent Union-Find data structure", see
{{: https://www.lri.fr/~filliatr/ftp/publis/puf-wml07.ps} the ps version}
@since 0.10 *)
@since 0.10 *)
type 'a t
(** The type of persistent arrays *)

158
src/data/CCPersistentHashtbl.ml
View file

@ -136,7 +136,7 @@ end
map_same_type _list_uniq
(list_of_size Gen.(0 -- 40) (pair small_int small_int))
)
*)
*)
(** {2 Implementation} *)
@ -175,12 +175,12 @@ module Make(H : HashedType) : S with type key = H.t = struct
| Arr a -> k a
| Set (i, v, t') ->
reroot_rec_ t' (fun a ->
let v' = a.(i) in
a.(i) <- v;
t.arr <- Arr a;
t'.arr <- Set (i, v', t);
k a
)
let v' = a.(i) in
a.(i) <- v;
t.arr <- Arr a;
t'.arr <- Set (i, v', t);
k a
)
(* obtain the array *)
let reroot_ t = match t.arr with
@ -199,26 +199,26 @@ module Make(H : HashedType) : S with type key = H.t = struct
let rec find_rec_ k l = match l with
| Nil -> raise Not_found
| Cons (k', v', l') ->
if H.equal k k' then v' else find_rec_ k l'
if H.equal k k' then v' else find_rec_ k l'
let find t k =
let a = reroot_ t in
(* unroll like crazy *)
match a.(find_idx_ ~h:(H.hash k) a) with
| Nil -> raise Not_found
| Cons (k1, v1, l1) ->
| Nil -> raise Not_found
| Cons (k1, v1, l1) ->
if H.equal k k1 then v1
else match l1 with
| Nil -> raise Not_found
| Cons (k2,v2,l2) ->
| Nil -> raise Not_found
| Cons (k2,v2,l2) ->
if H.equal k k2 then v2
else match l2 with
| Nil -> raise Not_found
| Cons (k3,v3,l3) ->
| Nil -> raise Not_found
| Cons (k3,v3,l3) ->
if H.equal k k3 then v3
else match l3 with
| Nil -> raise Not_found
| Cons (k4,v4,l4) ->
| Nil -> raise Not_found
| Cons (k4,v4,l4) ->
if H.equal k k4 then v4 else find_rec_ k l4
(*$R
@ -291,10 +291,10 @@ module Make(H : HashedType) : S with type key = H.t = struct
(* preserve order of elements by iterating on each bucket in rev order *)
Array.iter
(buck_rev_iter_
~f:(fun k v ->
let i = find_idx_ ~h:(H.hash k) a' in
a'.(i) <- Cons (k,v,a'.(i))
)
~f:(fun k v ->
let i = find_idx_ ~h:(H.hash k) a' in
a'.(i) <- Cons (k,v,a'.(i))
)
)
a;
let i = find_idx_ ~h a' in
@ -306,18 +306,18 @@ module Make(H : HashedType) : S with type key = H.t = struct
let rec replace_rec_ k v l = match l with
| Nil -> Cons (k,v,Nil), true
| Cons (k',v',l') ->
if H.equal k k'
then Cons (k,v,l'), false
else
let l', is_new = replace_rec_ k v l' in
Cons (k',v',l'), is_new
if H.equal k k'
then Cons (k,v,l'), false
else
let l', is_new = replace_rec_ k v l' in
Cons (k',v',l'), is_new
let replace t k v =
let a = reroot_ t in
let h = H.hash k in
let i = find_idx_ ~h a in
match a.(i) with
| Nil ->
| Nil ->
if t.length > (Array.length a) lsl 1
then (
(* resize *)
@ -330,7 +330,7 @@ module Make(H : HashedType) : S with type key = H.t = struct
t.arr <- Set (i,Nil,t');
t'
)
| Cons _ as l ->
| Cons _ as l ->
let l', is_new = replace_rec_ k v l in
if is_new && t.length > (Array.length a) lsl 1
then (
@ -392,21 +392,21 @@ module Make(H : HashedType) : S with type key = H.t = struct
let rec remove_rec_ k l = match l with
| Nil -> None
| Cons (k', v', l') ->
if H.equal k k'
then Some l'
else match remove_rec_ k l' with
| None -> None
| Some l' -> Some (Cons (k', v', l'))
if H.equal k k'
then Some l'
else match remove_rec_ k l' with
| None -> None
| Some l' -> Some (Cons (k', v', l'))
let remove t k =
let a = reroot_ t in
let i = find_idx_ ~h:(H.hash k) a in
match a.(i) with
| Nil -> t
| Cons _ as l ->
| Nil -> t
| Cons _ as l ->
match remove_rec_ k l with
| None -> t
| Some l' ->
| None -> t
| Some l' ->
a.(i) <- l';
let t' = {length=t.length-1; arr=Arr a} in
t.arr <- Set (i,l,t');
@ -440,14 +440,14 @@ module Make(H : HashedType) : S with type key = H.t = struct
let h = H.of_list l in
let h = List.fold_left (fun h (k,_) -> H.remove h k) h l in
H.is_empty h)
*)
*)
let update t k f =
let v = get k t in
match v, f v with
| None, None -> t (* no change *)
| Some _, None -> remove t k
| _, Some v' -> replace t k v'
| None, None -> t (* no change *)
| Some _, None -> remove t k
| _, Some v' -> replace t k v'
let copy t =
let a = Array.copy (reroot_ t) in
@ -464,8 +464,8 @@ module Make(H : HashedType) : S with type key = H.t = struct
let rec buck_fold_ f acc l = match l with
| Nil -> acc
| Cons (k,v,l') ->
let acc = f acc k v in
buck_fold_ f acc l'
let acc = f acc k v in
buck_fold_ f acc l'
let fold f acc t =
let a = reroot_ t in
@ -475,8 +475,8 @@ module Make(H : HashedType) : S with type key = H.t = struct
let rec buck_map_ f l = match l with
| Nil -> Nil
| Cons (k,v,l') ->
let v' = f k v in
Cons (k,v', buck_map_ f l')
let v' = f k v in
Cons (k,v', buck_map_ f l')
in
let a = reroot_ t in
let a' = Array.map (buck_map_ f) a in
@ -485,8 +485,8 @@ module Make(H : HashedType) : S with type key = H.t = struct
let rec buck_filter_ ~f l = match l with
| Nil -> Nil
| Cons (k,v,l') ->
let l' = buck_filter_ ~f l' in
if f k v then Cons (k,v,l') else l'
let l' = buck_filter_ ~f l' in
if f k v then Cons (k,v,l') else l'
let buck_length_ b = buck_fold_ (fun n _ _ -> n+1) 0 b
@ -494,32 +494,32 @@ module Make(H : HashedType) : S with type key = H.t = struct
let a = reroot_ t in
let length = ref 0 in
let a' = Array.map
(fun b ->
let b' = buck_filter_ ~f:p b in
length := !length + (buck_length_ b');
b'
) a
(fun b ->
let b' = buck_filter_ ~f:p b in
length := !length + (buck_length_ b');
b'
) a
in
{length= !length; arr=Arr a'}
let rec buck_filter_map_ ~f l = match l with
| Nil -> Nil
| Cons (k,v,l') ->
let l' = buck_filter_map_ ~f l' in
match f k v with
let l' = buck_filter_map_ ~f l' in
match f k v with
| None -> l'
| Some v' ->
Cons (k,v',l')
Cons (k,v',l')
let filter_map f t =
let a = reroot_ t in
let length = ref 0 in
let a' = Array.map
(fun b ->
let b' = buck_filter_map_ ~f b in
length := !length + (buck_length_ b');
b'
) a
(fun b ->
let b' = buck_filter_map_ ~f b in
length := !length + (buck_length_ b');
b'
) a
in
{length= !length; arr=Arr a'}
@ -540,22 +540,22 @@ module Make(H : HashedType) : S with type key = H.t = struct
let merge ~f t1 t2 =
let tbl = create (max (length t1) (length t2)) in
let tbl = fold
(fun tbl k v1 ->
let comb =
try `Both (v1, find t2 k)
with Not_found -> `Left v1
in
match f k comb with
| None -> tbl
| Some v' -> replace tbl k v')
tbl t1
(fun tbl k v1 ->
let comb =
try `Both (v1, find t2 k)
with Not_found -> `Left v1
in
match f k comb with
| None -> tbl
| Some v' -> replace tbl k v')
tbl t1
in
fold
(fun tbl k v2 ->
if mem t1 k then tbl
else match f k (`Right v2) with
| None -> tbl
| Some v' -> replace tbl k v'
if mem t1 k then tbl
else match f k (`Right v2) with
| None -> tbl
| Some v' -> replace tbl k v'
) tbl t2
(*$R
@ -629,17 +629,17 @@ module Make(H : HashedType) : S with type key = H.t = struct
&&
for_all
(fun k v -> match get k t2 with
| None -> false
| Some v' -> eq v v'
| None -> false
| Some v' -> eq v v'
) t1
let pp ?(sep=",") ?(arrow="->") pp_k pp_v fmt t =
let first = ref true in
iter t
(fun k v ->
if !first then first:=false
else (Format.pp_print_string fmt sep; Format.pp_print_cut fmt ());
Format.fprintf fmt "%a %s %a" pp_k k arrow pp_v v
if !first then first:=false
else (Format.pp_print_string fmt sep; Format.pp_print_cut fmt ());
Format.fprintf fmt "%a %s %a" pp_k k arrow pp_v v
);
()
@ -650,8 +650,8 @@ module Make(H : HashedType) : S with type key = H.t = struct
let bucket_histogram = Array.make (max_bucket_length+1) 0 in
Array.iter
(fun b ->
let l = buck_length_ b in
bucket_histogram.(l) <- bucket_histogram.(l) + 1
let l = buck_length_ b in
bucket_histogram.(l) <- bucket_histogram.(l) + 1
) a;
{Hashtbl.
num_bindings=t.length;

10
src/data/CCPersistentHashtbl.mli
View file

@ -3,12 +3,12 @@
(** {1 Persistent hash-table on top of OCaml's hashtables}
Almost as efficient as the regular Hashtbl type, but with a persistent
interface (rewinding changes to get back in the past history). This is
mostly useful for backtracking-like uses, or forward uses (never using
old values).
Almost as efficient as the regular Hashtbl type, but with a persistent
interface (rewinding changes to get back in the past history). This is
mostly useful for backtracking-like uses, or forward uses (never using
old values).
This module is not thread-safe. *)
This module is not thread-safe. *)
type 'a sequence = ('a -> unit) -> unit
type 'a printer = Format.formatter -> 'a -> unit

128
src/data/CCRAL.ml
View file

@ -35,8 +35,8 @@ and tree_lookup_ size t i = match t, i with
| Node (_, t1, t2), _ ->
let size' = size / 2 in
if i <= size'
then tree_lookup_ size' t1 (i-1)
else tree_lookup_ size' t2 (i-1-size')
then tree_lookup_ size' t1 (i-1)
else tree_lookup_ size' t2 (i-1-size')
let get l i = try Some (get_exn l i) with Invalid_argument _ -> None
@ -44,15 +44,15 @@ let rec set l i v = match l with
| Nil -> invalid_arg "RAL.set"
| Cons (size,t, l') when i < size -> Cons (size, tree_update_ size t i v, l')
| Cons (size,t, l') -> Cons (size, t, set l' (i - size) v)
and tree_update_ size t i v =match t, i with
and tree_update_ size t i v =match t, i with
| Leaf _, 0 -> Leaf v
| Leaf _, _ -> invalid_arg "RAL.set"
| Node (_, t1, t2), 0 -> Node (v, t1, t2)
| Node (x, t1, t2), _ ->
let size' = size / 2 in
if i <= size'
then Node (x, tree_update_ size' t1 (i-1) v, t2)
else Node (x, t1, tree_update_ size' t2 (i-1-size') v)
then Node (x, tree_update_ size' t1 (i-1) v, t2)
else Node (x, t1, tree_update_ size' t2 (i-1-size') v)
(*$Q & ~small:(CCFun.compose snd List.length)
Q.(pair (pair small_int int) (list int)) (fun ((i,v),l) -> \
@ -71,7 +71,7 @@ let rec set l i v = match l with
let cons x l = match l with
| Cons (size1, t1, Cons (size2, t2, l')) when size1=size2 ->
Cons (1 + size1 + size2, Node (x, t1, t2), l')
Cons (1 + size1 + size2, Node (x, t1, t2), l')
| _ -> Cons (1, Leaf x, l)
let cons' l x = cons x l
@ -116,8 +116,8 @@ let front_exn l = match l with
let rec _remove prefix l i =
let x, l' = front_exn l in
if i=0
then List.fold_left (fun l x -> cons x l) l prefix
else _remove (x::prefix) l' (i-1)
then List.fold_left (fun l x -> cons x l) l prefix
else _remove (x::prefix) l' (i-1)
let remove l i = _remove [] l i
@ -136,9 +136,9 @@ let mapi ~f l =
and aux_t f ~size i t = match t with
| Leaf x -> Leaf (f i x)
| Node (x, l, r) ->
let x = f i x in
let l = aux_t f ~size:(size/2) (i+1) l in
Node (x, l, aux_t f ~size:(size/2) (i+1+size/2) r)
let x = f i x in
let l = aux_t f ~size:(size/2) (i+1) l in
Node (x, l, aux_t f ~size:(size/2) (i+1+size/2) r)
in
aux f 0 l
@ -171,15 +171,15 @@ let iteri ~f l =
let rec aux f i l = match l with
| Nil -> ()
| Cons (size, t, l') ->
aux_t ~size f i t;
aux f (i+size) l'
aux_t ~size f i t;
aux f (i+size) l'
and aux_t f ~size i t = match t with
| Leaf x -> f i x
| Node (x, l, r) ->
f i x;
let size' = size/2 in
aux_t ~size:size' f (i+1) l;
aux_t ~size:size' f (i+1+size') r
f i x;
let size' = size/2 in
aux_t ~size:size' f (i+1) l;
aux_t ~size:size' f (i+1+size') r
in
aux f 0 l
@ -288,17 +288,17 @@ let rec stack_to_list = function
let rec take n l = match l with
| Nil -> Nil
| Cons (size, t, tl) ->
if size <= n
then append_tree_ t (take (n-size) tl)
else take_tree_ ~size n t
if size <= n
then append_tree_ t (take (n-size) tl)
else take_tree_ ~size n t
and take_tree_ ~size n t = match t with
| _ when n=0 -> Nil
| Leaf x -> cons x Nil
| Node (x, l, r) ->
let size' = size/2 in
if size' <= n-1
then cons x (append_tree_ l (take_tree_ ~size:size' (n-size'-1) r))
else cons x (take_tree_ ~size:size' (n-1) l)
let size' = size/2 in
if size' <= n-1
then cons x (append_tree_ l (take_tree_ ~size:size' (n-size'-1) r))
else cons x (take_tree_ ~size:size' (n-1) l)
(*$T
take 3 (of_list CCList.(1--10)) |> to_list = [1;2;3]
@ -313,9 +313,9 @@ let take_while ~f l =
| St_list (Nil, st') -> aux p st'
| St_list (Cons (_, t, tl), st') -> aux p (St_tree (t, St_list (tl, st')))
| St_tree (Leaf x, st') ->
if p x then cons x (aux p st') else Nil
if p x then cons x (aux p st') else Nil
| St_tree (Node (x,l,r), st') ->
if p x then cons x (aux p (St_tree (l, St_tree (r, st')))) else Nil
if p x then cons x (aux p (St_tree (l, St_tree (r, st')))) else Nil
in aux f (St_list (l, St_nil))
(*$Q
@ -328,31 +328,31 @@ let rec drop n l = match l with
| _ when n=0 -> l
| Nil -> Nil
| Cons (size, t, tl) ->
if n >= size then drop (n-size) tl
else drop_tree_ ~size n t tl
if n >= size then drop (n-size) tl
else drop_tree_ ~size n t tl
and drop_tree_ ~size n t tail = match t with
| _ when n=0 -> tail
| Leaf _ -> tail
| Node (_,l,r) ->
if n=1 then append_tree_ l (append_tree_ r tail)
else
let size' = size/2 in
if n-1 < size'
then drop_tree_ ~size:size' (n-1) l (append_tree_ r tail)
else drop_tree_ ~size:size' (n-1-size') r tail
if n=1 then append_tree_ l (append_tree_ r tail)
else
let size' = size/2 in
if n-1 < size'
then drop_tree_ ~size:size' (n-1) l (append_tree_ r tail)
else drop_tree_ ~size:size' (n-1-size') r tail
let drop_while ~f l =
let rec aux p st = match st with
| St_nil -> Nil
| St_list (Nil, st') -> aux p st'
| St_list (Cons (_, t, tail), st') ->
aux p (St_tree (t, St_list (tail, st')))
aux p (St_tree (t, St_list (tail, st')))
| St_tree (Leaf x, st') ->
if p x then aux p st' else cons x (stack_to_list st')
if p x then aux p st' else cons x (stack_to_list st')
| St_tree (Node (x,l,r) as tree, st') ->
if p x
then aux p (St_tree (l, St_tree (r, st')))
else append_tree_ tree (stack_to_list st')
if p x
then aux p (St_tree (l, St_tree (r, st')))
else append_tree_ tree (stack_to_list st')
in aux f (St_list (l, St_nil))
(*$T
@ -372,17 +372,17 @@ let take_drop n l = take n l, drop n l
let equal ?(eq=(=)) l1 l2 =
let rec aux ~eq l1 l2 = match l1, l2 with
| Nil, Nil -> true
| Cons (size1, t1, l1'), Cons (size2, t2, l2') ->
| Nil, Nil -> true
| Cons (size1, t1, l1'), Cons (size2, t2, l2') ->
size1 = size2 && aux_t ~eq t1 t2 && aux ~eq l1' l2'
| Nil, Cons _
| Cons _, Nil -> false
| Nil, Cons _
| Cons _, Nil -> false
and aux_t ~eq t1 t2 = match t1, t2 with
| Leaf x, Leaf y -> eq x y
| Node (x1, l1, r1), Node (x2, l2, r2) ->
| Leaf x, Leaf y -> eq x y
| Node (x1, l1, r1), Node (x2, l2, r2) ->
eq x1 x2 && aux_t ~eq l1 l2 && aux_t ~eq r1 r2
| Leaf _, Node _
| Node _, Leaf _ -> false
| Leaf _, Node _
| Node _, Leaf _ -> false
in
aux ~eq l1 l2
@ -409,7 +409,7 @@ let range i j =
let rec aux i j acc =
if i=j then cons i acc
else if i<j
then aux i (j-1) (cons j acc)
then aux i (j-1) (cons j acc)
else
aux i (j+1) (cons j acc)
in
@ -456,7 +456,7 @@ let to_list l = fold_rev ~f:(fun acc x -> x :: acc) ~x:[] l
(*$Q
Q.(list int) (fun l -> to_list (of_list l) = l)
*)
*)
let add_array l a = Array.fold_right cons a l
@ -466,10 +466,10 @@ let to_array l = match l with
| Nil -> [||]
| Cons (_, Leaf x, _)
| Cons (_, Node (x, _,_), _) ->
let len = length l in
let arr = Array.make len x in
iteri ~f:(fun i x -> Array.set arr i x) l;
arr
let len = length l in
let arr = Array.make len x in
iteri ~f:(fun i x -> Array.set arr i x) l;
arr
(*$Q
Q.(array int) (fun a -> \
@ -516,17 +516,17 @@ let to_gen l =
let rec next () =
if Stack.is_empty st
then match !l with
| Nil -> None
| Cons (_, t, tl) ->
| Nil -> None
| Cons (_, t, tl) ->
l := tl;
Stack.push t st;
next()
else match Stack.pop st with
| Leaf x -> Some x
| Node (x, l, r) ->
Stack.push r st;
Stack.push l st;
Some x
Stack.push r st;
Stack.push l st;
Some x
in
next
@ -539,15 +539,15 @@ let to_gen l =
let rec of_list_map ~f l = match l with
| [] -> empty
| x::l' ->
let y = f x in
cons y (of_list_map ~f l')
let y = f x in
cons y (of_list_map ~f l')
let compare ?(cmp=Pervasives.compare) l1 l2 =
let rec cmp_gen ~cmp g1 g2 = match g1(), g2() with
| None, None -> 0
| Some _, None -> 1
| None, Some _ -> -1
| Some x, Some y ->
| None, None -> 0
| Some _, None -> 1
| None, Some _ -> -1
| Some x, Some y ->
let c = cmp x y in
if c<> 0 then c else cmp_gen ~cmp g1 g2
in

8
src/data/CCRingBuffer.ml
View file

@ -344,7 +344,7 @@ module MakeFromArray(A:Array.S) = struct
let cap = capacity b - length b in
(* resize if needed, with a constant to amortize *)
if cap < len
then resize b (max (b.size+1) (A.length b.buf + len + 24)) (A.get from_buf 0);
then resize b (max (b.size+1) (A.length b.buf + len + 24)) (A.get from_buf 0);
let good = capacity b - length b >= len in
assert good;
if b.stop >= b.start
@ -352,10 +352,10 @@ module MakeFromArray(A:Array.S) = struct
let len_end = A.length b.buf - b.stop in
if len_end >= len
then (A.blit from_buf o b.buf b.stop len;
b.stop <- b.stop + len)
b.stop <- b.stop + len)
else (A.blit from_buf o b.buf b.stop len_end;
A.blit from_buf (o+len_end) b.buf 0 (len-len_end);
b.stop <- len-len_end)
A.blit from_buf (o+len_end) b.buf 0 (len-len_end);
b.stop <- len-len_end)
else begin (* [xxxxx stop ____________ start xxxxxx] *)
let len_middle = b.start - b.stop in
assert (len_middle >= len);

178
src/data/CCWBTree.ml
View file

@ -2,10 +2,10 @@
(** {1 Weight-Balanced Tree}
Most of this comes from "implementing sets efficiently in a functional language",
Stephen Adams.
Most of this comes from "implementing sets efficiently in a functional language",
Stephen Adams.
The coefficients 5/2, 3/2 for balancing come from "balancing weight-balanced trees"
The coefficients 5/2, 3/2 for balancing come from "balancing weight-balanced trees"
*)
(*$inject
@ -175,7 +175,7 @@ module MakeFull(K : KEY) : S with type key = K.t = struct
let rec get_exn k m = match m with
| E -> raise Not_found
| N (k', v, l, r, _) ->
match K.compare k k' with
match K.compare k k' with
| 0 -> v
| n when n<0 -> get_exn k l
| _ -> get_exn k r
@ -215,10 +215,10 @@ module MakeFull(K : KEY) : S with type key = K.t = struct
let rec balanced = function
| E -> true
| N (_, _, l, r, _) ->
is_balanced l r &&
is_balanced r l &&
balanced l &&
balanced r
is_balanced l r &&
is_balanced r l &&
balanced l &&
balanced r
(* smart constructor *)
let mk_node_ k v l r =
@ -227,19 +227,19 @@ module MakeFull(K : KEY) : S with type key = K.t = struct
let single_l k1 v1 t1 t2 = match t2 with
| E -> assert false
| N (k2, v2, t2, t3, _) ->
mk_node_ k2 v2 (mk_node_ k1 v1 t1 t2) t3
mk_node_ k2 v2 (mk_node_ k1 v1 t1 t2) t3
let double_l k1 v1 t1 t2 = match t2 with
| N (k2, v2, N (k3, v3, t2, t3, _), t4, _) ->
mk_node_ k3 v3 (mk_node_ k1 v1 t1 t2) (mk_node_ k2 v2 t3 t4)
mk_node_ k3 v3 (mk_node_ k1 v1 t1 t2) (mk_node_ k2 v2 t3 t4)
| _ -> assert false
let rotate_l k v l r = match r with
| E -> assert false
| N (_, _, rl, rr, _) ->
if is_single rl rr
then single_l k v l r
else double_l k v l r
if is_single rl rr
then single_l k v l r
else double_l k v l r
(* balance towards left *)
let balance_l k v l r =
@ -249,19 +249,19 @@ module MakeFull(K : KEY) : S with type key = K.t = struct
let single_r k1 v1 t1 t2 = match t1 with
| E -> assert false
| N (k2, v2, t11, t12, _) ->
mk_node_ k2 v2 t11 (mk_node_ k1 v1 t12 t2)
mk_node_ k2 v2 t11 (mk_node_ k1 v1 t12 t2)
let double_r k1 v1 t1 t2 = match t1 with
| N (k2, v2, t11, N (k3, v3, t121, t122, _), _) ->
mk_node_ k3 v3 (mk_node_ k2 v2 t11 t121) (mk_node_ k1 v1 t122 t2)
mk_node_ k3 v3 (mk_node_ k2 v2 t11 t121) (mk_node_ k1 v1 t122 t2)
| _ -> assert false
let rotate_r k v l r = match l with
| E -> assert false
| N (_, _, ll, lr, _) ->
if is_single lr ll
then single_r k v l r
else double_r k v l r
if is_single lr ll
then single_r k v l r
else double_r k v l r
(* balance toward right *)
let balance_r k v l r =
@ -271,7 +271,7 @@ module MakeFull(K : KEY) : S with type key = K.t = struct
let rec add k v m = match m with
| E -> singleton k v
| N (k', v', l, r, _) ->
match K.compare k k' with
match K.compare k k' with
| 0 -> mk_node_ k v l r
| n when n<0 -> balance_r k' v' (add k v l) r
| _ -> balance_l k' v' l (add k v r)
@ -293,38 +293,38 @@ module MakeFull(K : KEY) : S with type key = K.t = struct
| E -> raise Not_found
| N (k, v, E, r, _) -> k, v, r
| N (k, v, l, r, _) ->
let k', v', l' = extract_min l in
k', v', balance_l k v l' r
let k', v', l' = extract_min l in
k', v', balance_l k v l' r
(* extract max binding of the tree *)
let rec extract_max m = match m with
| E -> raise Not_found
| N (k, v, l, E, _) -> k, v, l
| N (k, v, l, r, _) ->
let k', v', r' = extract_max r in
k', v', balance_r k v l r'
let k', v', r' = extract_max r in
k', v', balance_r k v l r'
let rec remove k m = match m with
| E -> E
| N (k', v', l, r, _) ->
match K.compare k k' with
match K.compare k k' with
| 0 ->
begin match l, r with
begin match l, r with
| E, E -> E
| E, o
| o, E -> o
| _, _ ->
if weight l > weight r
then
(* remove max element of [l] and put it at the root,
then rebalance towards the left if needed *)
let k', v', l' = extract_max l in
balance_l k' v' l' r
else
(* remove min element of [r] and rebalance *)
let k', v', r' = extract_min r in
balance_r k' v' l r'
end
if weight l > weight r
then
(* remove max element of [l] and put it at the root,
then rebalance towards the left if needed *)
let k', v', l' = extract_max l in
balance_l k' v' l' r
else
(* remove min element of [r] and rebalance *)
let k', v', r' = extract_min r in
balance_r k' v' l r'
end
| n when n<0 -> balance_l k' v' (remove k l) r
| _ -> balance_r k' v' l (remove k r)
@ -341,20 +341,20 @@ module MakeFull(K : KEY) : S with type key = K.t = struct
let update k f m =
let maybe_v = get k m in
match maybe_v, f maybe_v with
| None, None -> m
| Some _, None -> remove k m
| _, Some v -> add k v m
| None, None -> m
| Some _, None -> remove k m
| _, Some v -> add k v m
let rec nth_exn i m = match m with
| E -> raise Not_found
| N (k, v, l, r, w) ->
let c = i - weight l in
match c with
let c = i - weight l in
match c with
| 0 -> k, v
| n when n<0 -> nth_exn i l (* search left *)
| _ ->
(* means c< K.weight k *)
if i<w-weight r then k,v else nth_exn (i+weight r-w) r
(* means c< K.weight k *)
if i<w-weight r then k,v else nth_exn (i+weight r-w) r
let nth i m =
try Some (nth_exn i m)
@ -368,26 +368,26 @@ module MakeFull(K : KEY) : S with type key = K.t = struct
let rec fold ~f ~x:acc m = match m with
| E -> acc
| N (k, v, l, r, _) ->
let acc = fold ~f ~x:acc l in
let acc = f acc k v in
fold ~f ~x:acc r
let acc = fold ~f ~x:acc l in
let acc = f acc k v in
fold ~f ~x:acc r
let rec mapi ~f = function
| E -> E
| N (k, v, l, r, w) ->
N (k, f k v, mapi ~f l, mapi ~f r, w)
N (k, f k v, mapi ~f l, mapi ~f r, w)
let rec map ~f = function
| E -> E
| N (k, v, l, r, w) ->
N (k, f v, map ~f l, map ~f r, w)
N (k, f v, map ~f l, map ~f r, w)
let rec iter ~f m = match m with
| E -> ()
| N (k, v, l, r, _) ->
iter ~f l;
f k v;
iter ~f r
iter ~f l;
f k v;
iter ~f r
let choose_exn = function
| E -> raise Not_found
@ -422,10 +422,10 @@ module MakeFull(K : KEY) : S with type key = K.t = struct
| N (kl, vl, ll, lr, _), N (kr, vr, rl, rr, _) ->
let left = is_balanced l r in
if left && is_balanced r l
then mk_node_ k v l r
then mk_node_ k v l r
else if not left
then node_shallow_ kr vr (node_ k v l rl) rr
else node_shallow_ kl vl ll (node_ k v lr r)
then node_shallow_ kr vr (node_ k v l rl) rr
else node_shallow_ kl vl ll (node_ k v lr r)
(* join two trees, assuming all keys of [l] are smaller than keys of [r] *)
let join_ l r = match l, r with
@ -433,13 +433,13 @@ module MakeFull(K : KEY) : S with type key = K.t = struct
| E, o
| o, E -> o
| N _, N _ ->
if weight l <= weight r
then
let k, v, r' = extract_min r in
node_ k v l r'
else
let k, v, l' = extract_max l in
node_ k v l' r
if weight l <= weight r
then
let k, v, r' = extract_min r in
node_ k v l r'
else
let k, v, l' = extract_max l in
node_ k v l' r
(* if [o_v = Some v], behave like [mk_node k v l r]
else behave like [join_ l r] *)
@ -450,14 +450,14 @@ module MakeFull(K : KEY) : S with type key = K.t = struct
let rec split k m = match m with
| E -> E, None, E
| N (k', v', l, r, _) ->
match K.compare k k' with
match K.compare k k' with
| 0 -> l, Some v', r
| n when n<0 ->
let ll, o, lr = split k l in
ll, o, node_ k' v' lr r
let ll, o, lr = split k l in
ll, o, node_ k' v' lr r
| _ ->
let rl, o, rr = split k r in
node_ k' v' l rl, o, rr
let rl, o, rr = split k r in
node_ k' v' l rl, o, rr
(*$QR & ~count:20
Q.(list_of_size Gen.(1 -- 100) (pair small_int small_int)) ( fun lst ->
@ -476,25 +476,25 @@ module MakeFull(K : KEY) : S with type key = K.t = struct
let rec merge ~f a b = match a, b with
| E, E -> E
| E, N (k, v, l, r, _) ->
let v' = f k None (Some v) in
mk_node_or_join_ k v' (merge ~f E l) (merge ~f E r)
let v' = f k None (Some v) in
mk_node_or_join_ k v' (merge ~f E l) (merge ~f E r)
| N (k, v, l, r, _), E ->
let v' = f k (Some v) None in
mk_node_or_join_ k v' (merge ~f l E) (merge ~f r E)
let v' = f k (Some v) None in
mk_node_or_join_ k v' (merge ~f l E) (merge ~f r E)
| N (k1, v1, l1, r1, w1), N (k2, v2, l2, r2, w2) ->
if K.compare k1 k2 = 0
then (* easy case *)
mk_node_or_join_ k1 (f k1 (Some v1) (Some v2))
(merge ~f l1 l2) (merge ~f r1 r2)
else if w1 <= w2
then (* split left tree *)
let l1', v1', r1' = split k2 a in
mk_node_or_join_ k2 (f k2 v1' (Some v2))
(merge ~f l1' l2) (merge ~f r1' r2)
else (* split right tree *)
let l2', v2', r2' = split k1 b in
mk_node_or_join_ k1 (f k1 (Some v1) v2')
(merge ~f l1 l2') (merge ~f r1 r2')
if K.compare k1 k2 = 0
then (* easy case *)
mk_node_or_join_ k1 (f k1 (Some v1) (Some v2))
(merge ~f l1 l2) (merge ~f r1 r2)
else if w1 <= w2
then (* split left tree *)
let l1', v1', r1' = split k2 a in
mk_node_or_join_ k2 (f k2 v1' (Some v2))
(merge ~f l1' l2) (merge ~f r1' r2)
else (* split right tree *)
let l2', v2', r2' = split k1 b in
mk_node_or_join_ k1 (f k1 (Some v1) v2')
(merge ~f l1 l2') (merge ~f r1 r2')
(*$R
let m1 = M.of_list [1, 1; 2, 2; 4, 4] in
@ -549,9 +549,9 @@ module MakeFull(K : KEY) : S with type key = K.t = struct
else match Stack.pop st with
| E -> next ()
| N (k, v, l, r, _) ->
Stack.push r st;
Stack.push l st;
Some (k,v)
Stack.push r st;
Stack.push l st;
Some (k,v)
in next
let print pp_k pp_v fmt m =
@ -570,6 +570,6 @@ module MakeFull(K : KEY) : S with type key = K.t = struct
end
module Make(X : ORD) = MakeFull(struct
include X
let weight _ = 1
end)
include X
let weight _ = 1
end)

8
src/data/CCWBTree.mli
View file

@ -2,9 +2,9 @@
(** {1 Weight-Balanced Tree}
{b status: experimental}
{b status: experimental}
@since 0.13 *)
@since 0.13 *)
type 'a sequence = ('a -> unit) -> unit
type 'a gen = unit -> 'a option
@ -65,12 +65,12 @@ module type S = sig
val mapi : f:(key -> 'a -> 'b) -> 'a t -> 'b t
(** Map values, giving both key and value. Will use {!WORD.of_list} to rebuild keys.
@since 0.17
*)
*)
val map : f:('a -> 'b) -> 'a t -> 'b t
(** Map values, giving only the value.
@since 0.17
*)
*)
val iter : f:(key -> 'a -> unit) -> 'a t -> unit

8
src/data/CCZipper.ml
View file

@ -40,15 +40,15 @@ let right_exn = function
let modify f z = match z with
| l, [] ->
begin match f None with
begin match f None with
| None -> z
| Some x -> l, [x]
end
end
| l, x::r ->
begin match f (Some x) with
begin match f (Some x) with
| None -> l,r
| Some _ -> l, x::r
end
end
let is_focused = function
| _, [] -> true

114
src/iter/CCKTree.ml
View file

@ -24,9 +24,9 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Lazy Tree Structure}
This structure can be used to represent trees and directed
graphs (as infinite trees) in a lazy fashion. Like {!CCKList}, it
is a structural type. *)
This structure can be used to represent trees and directed
graphs (as infinite trees) in a lazy fashion. Like {!CCKList}, it
is a structural type. *)
type 'a sequence = ('a -> unit) -> unit
type 'a gen = unit -> 'a option
@ -51,8 +51,8 @@ let node2 x t1 t2 () = `Node(x,[t1;t2])
let rec fold f acc t = match t() with
| `Nil -> acc
| `Node (x,l) ->
let acc = f acc x in
List.fold_left (fold f) acc l
let acc = f acc x in
List.fold_left (fold f) acc l
let rec iter f t = match t() with
| `Nil -> ()
@ -67,13 +67,13 @@ let height t =
and aux_l acc l k = match l with
| [] -> k acc
| t'::l' ->
aux t' (fun n -> aux_l (max acc n) l' k)
aux t' (fun n -> aux_l (max acc n) l' k)
in aux t (fun x->x)
let rec map f t () = match t() with
| `Nil -> `Nil
| `Node(x,l) ->
`Node (f x, List.map (map f) l)
`Node (f x, List.map (map f) l)
let (>|=) t f = map f t
@ -81,7 +81,7 @@ let rec cut_depth n t () = match t() with
| `Nil -> `Nil
| `Node _ when n=0 -> `Nil
| `Node(x,l) ->
`Node(x, List.map (cut_depth (n-1)) l)
`Node(x, List.map (cut_depth (n-1)) l)
(** {2 Graph Traversals} *)
@ -93,9 +93,9 @@ end
let set_of_cmp (type elt) ?(cmp=Pervasives.compare) () =
let module S = Set.Make(struct
type t = elt
let compare = cmp
end) in
type t = elt
let compare = cmp
end) in
object
val s = S.empty
method add x = {< s = S.add x s >}
@ -109,19 +109,19 @@ let dfs ?(pset=set_of_cmp ()) t =
let rec dfs pset stack () = match stack with
| [] -> `Nil
| `Explore t :: stack' ->
begin match t() with
begin match t() with
| `Nil -> dfs pset stack' ()
| `Node (x, _) when pset#mem x ->
dfs pset stack' () (* loop *)
dfs pset stack' () (* loop *)
| `Node (x, l) ->
let pset' = pset#add x in
let stack' =
List.rev_append (List.rev_map (fun x -> `Explore x) l) (`Exit x :: stack')
in
_cons (`Enter x) (dfs pset' stack')
end
let pset' = pset#add x in
let stack' =
List.rev_append (List.rev_map (fun x -> `Explore x) l) (`Exit x :: stack')
in
_cons (`Enter x) (dfs pset' stack')
end
| `Exit x :: stack' ->
_cons (`Exit x) (dfs pset stack')
_cons (`Exit x) (dfs pset stack')
in
dfs pset [`Explore t]
@ -147,10 +147,10 @@ module FQ = struct
let pop_exn q =
match q.hd with
| [] -> assert (q.tl = []); raise Empty
| x::hd' ->
let q' = _make hd' q.tl in
x, q'
| [] -> assert (q.tl = []); raise Empty
| x::hd' ->
let q' = _make hd' q.tl in
x, q'
end
let bfs ?(pset=set_of_cmp ()) t =
@ -159,10 +159,10 @@ let bfs ?(pset=set_of_cmp ()) t =
else
let t, q' = FQ.pop_exn q in
match t() with
| `Nil -> bfs pset q' ()
| `Node(x,_) when pset#mem x ->
| `Nil -> bfs pset q' ()
| `Node(x,_) when pset#mem x ->
bfs pset q' () (* loop *)
| `Node(x,l) ->
| `Node(x,l) ->
let q' = List.fold_left FQ.push q' l in
let pset' = pset#add x in
_cons x (bfs pset' q')
@ -177,7 +177,7 @@ let find ?pset f t =
let rec _find_kl f l = match l() with
| `Nil -> None
| `Cons (x, l') ->
match f x with
match f x with
| None -> _find_kl f l'
| Some _ as res -> res
in
@ -192,16 +192,16 @@ let pp pp_x fmt t =
| `Node (x, children) ->
let children = filter children in
match children with
| [] -> pp_x fmt x
| _::_ ->
Format.fprintf fmt "@[<v2>(@[<hov0>%a@]%a)@]"
pp_x x pp_children children
| [] -> pp_x fmt x
| _::_ ->
Format.fprintf fmt "@[<v2>(@[<hov0>%a@]%a)@]"
pp_x x pp_children children
and filter l =
let l = List.fold_left
(fun acc c -> match c() with
| `Nil -> acc
| `Node _ as sub -> sub :: acc
) [] l
(fun acc c -> match c() with
| `Nil -> acc
| `Node _ as sub -> sub :: acc
) [] l
in
List.rev l
and pp_children fmt children =
@ -219,13 +219,13 @@ let pp pp_x fmt t =
module Dot = struct
type attribute = [
| `Color of string
| `Shape of string
| `Weight of int
| `Style of string
| `Label of string
| `Id of string
| `Other of string * string
| `Color of string
| `Shape of string
| `Weight of int
| `Style of string
| `Label of string
| `Id of string
| `Other of string * string
] (** Dot attributes for nodes *)
type graph = (string * attribute list t list)
@ -268,9 +268,9 @@ module Dot = struct
| [] -> ()
| [x] -> _pp_attr fmt x
| x::l' ->
_pp_attr fmt x;
Format.pp_print_char fmt ',';
_pp_attrs fmt l'
_pp_attr fmt x;
Format.pp_print_char fmt ',';
_pp_attrs fmt l'
let pp out (name,l) =
(* nodes already printed *)
@ -299,17 +299,17 @@ module Dot = struct
and pp_node q ?parent t = match t() with
| `Nil -> q
| `Node (x,l) ->
let name, attrs = get_name x in
begin match parent with
| None -> ()
| Some n -> Format.fprintf out " %s -> %s;@," n name
end;
if not (Hashtbl.mem tbl name) then (
Hashtbl.add tbl name ();
Format.fprintf out "@[%s [%a];@]@," name _pp_attrs attrs;
List.fold_left
(fun q y -> FQ.push q (Some name, y)) q l
) else q
let name, attrs = get_name x in
begin match parent with
| None -> ()
| Some n -> Format.fprintf out " %s -> %s;@," n name
end;
if not (Hashtbl.mem tbl name) then (
Hashtbl.add tbl name ();
Format.fprintf out "@[%s [%a];@]@," name _pp_attrs attrs;
List.fold_left
(fun q y -> FQ.push q (Some name, y)) q l
) else q
in
let q =
List.fold_left

48
src/iter/CCKTree.mli
View file

@ -24,9 +24,9 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Lazy Tree Structure}
This structure can be used to represent trees and directed
graphs (as infinite trees) in a lazy fashion. Like {!CCKList}, it
is a structural type. *)
This structure can be used to represent trees and directed
graphs (as infinite trees) in a lazy fashion. Like {!CCKList}, it
is a structural type. *)
type 'a sequence = ('a -> unit) -> unit
type 'a gen = unit -> 'a option
@ -99,23 +99,23 @@ val find : ?pset:'a pset -> ('a -> 'b option) -> 'a t -> 'b option
(** {2 Pretty-printing}
Example (tree of calls for naive Fibonacci function):
{[
let mk_fib n =
let rec fib' l r i =
if i=n then r else fib' r (l+r) (i+1)
in fib' 1 1 1;;
Example (tree of calls for naive Fibonacci function):
{[
let mk_fib n =
let rec fib' l r i =
if i=n then r else fib' r (l+r) (i+1)
in fib' 1 1 1;;
let rec fib n = match n with
| 0 | 1 -> CCKTree.singleton (`Cst n)
| _ -> CCKTree.node2 (`Plus (mk_fib n)) (fib (n-1)) (fib (n-2));;
let rec fib n = match n with
| 0 | 1 -> CCKTree.singleton (`Cst n)
| _ -> CCKTree.node2 (`Plus (mk_fib n)) (fib (n-1)) (fib (n-2));;
let pp_node fmt = function
| `Cst n -> Format.fprintf fmt "%d" n
| `Plus n -> Format.fprintf fmt "%d" n;;
let pp_node fmt = function
| `Cst n -> Format.fprintf fmt "%d" n
| `Plus n -> Format.fprintf fmt "%d" n;;
Format.printf "%a@." (CCKTree.print pp_node) (fib 8);;
]}
Format.printf "%a@." (CCKTree.print pp_node) (fib 8);;
]}
*)
val pp : 'a printer -> 'a t printer
@ -127,13 +127,13 @@ val pp : 'a printer -> 'a t printer
module Dot : sig
type attribute = [
| `Color of string
| `Shape of string
| `Weight of int
| `Style of string
| `Label of string
| `Id of string (** Unique ID in the graph. Allows sharing. *)
| `Other of string * string
| `Color of string
| `Shape of string
| `Weight of int
| `Style of string
| `Label of string
| `Id of string (** Unique ID in the graph. Allows sharing. *)
| `Other of string * string
] (** Dot attributes for nodes *)
type graph = (string * attribute list t list)

12
src/iter/CCLazy_list.ml
View file

@ -36,8 +36,8 @@ let length l =
let rec map ~f l =
lazy (
match l with
| lazy Nil -> Nil
| lazy (Cons (x,tl)) -> Cons (f x, map ~f tl)
| lazy Nil -> Nil
| lazy (Cons (x,tl)) -> Cons (f x, map ~f tl)
)
let filter ~f l =
@ -76,10 +76,10 @@ let rec append a b =
let rec flat_map ~f l =
lazy (
match l with
| lazy Nil -> Nil
| lazy (Cons (x,tl)) ->
let res = append (f x) (flat_map ~f tl) in
Lazy.force res
| lazy Nil -> Nil
| lazy (Cons (x,tl)) ->
let res = append (f x) (flat_map ~f tl) in
Lazy.force res
)
module Infix = struct

52
src/sexp/CCSexp.ml
View file

@ -10,7 +10,7 @@ type 'a gen = unit -> 'a option
type t = [
| `Atom of string
| `List of t list
]
]
type sexp = t
let equal a b = a = b
@ -53,9 +53,9 @@ let _must_escape s =
for i = 0 to String.length s - 1 do
let c = String.unsafe_get s i in
match c with
| ' ' | ')' | '(' | '"' | ';' | '\\' | '\n' | '\t' | '\r' -> raise Exit
| _ when Char.code c > 127 -> raise Exit (* non-ascii *)
| _ -> ()
| ' ' | ')' | '(' | '"' | ';' | '\\' | '\n' | '\t' | '\r' -> raise Exit
| _ when Char.code c > 127 -> raise Exit (* non-ascii *)
| _ -> ()
done;
false
with Exit -> true
@ -66,11 +66,11 @@ let rec to_buf b t = match t with
| `List [] -> Buffer.add_string b "()"
| `List [x] -> Printf.bprintf b "(%a)" to_buf x
| `List l ->
Buffer.add_char b '(';
List.iteri
(fun i t' -> (if i > 0 then Buffer.add_char b ' '; to_buf b t'))
l;
Buffer.add_char b ')'
Buffer.add_char b '(';
List.iteri
(fun i t' -> (if i > 0 then Buffer.add_char b ' '; to_buf b t'))
l;
Buffer.add_char b ')'
let to_string t =
let b = Buffer.create 128 in
@ -83,11 +83,11 @@ let rec pp fmt t = match t with
| `List [] -> Format.pp_print_string fmt "()"
| `List [x] -> Format.fprintf fmt "@[<hov2>(%a)@]" pp x
| `List l ->
Format.fprintf fmt "@[<hov1>(";
List.iteri
(fun i t' -> (if i > 0 then Format.fprintf fmt "@ "; pp fmt t'))
l;
Format.fprintf fmt ")@]"
Format.fprintf fmt "@[<hov1>(";
List.iteri
(fun i t' -> (if i > 0 then Format.fprintf fmt "@ "; pp fmt t'))
l;
Format.fprintf fmt ")@]"
let rec pp_noindent fmt t = match t with
| `Atom s when _must_escape s -> Format.fprintf fmt "\"%s\"" (String.escaped s)
@ -95,11 +95,11 @@ let rec pp_noindent fmt t = match t with
| `List [] -> Format.pp_print_string fmt "()"
| `List [x] -> Format.fprintf fmt "(%a)" pp_noindent x
| `List l ->
Format.pp_print_char fmt '(';
List.iteri
(fun i t' -> (if i > 0 then Format.pp_print_char fmt ' '; pp_noindent fmt t'))
l;
Format.pp_print_char fmt ')'
Format.pp_print_char fmt '(';
List.iteri
(fun i t' -> (if i > 0 then Format.pp_print_char fmt ' '; pp_noindent fmt t'))
l;
Format.pp_print_char fmt ')'
let to_chan oc t =
let fmt = Format.formatter_of_out_channel oc in
@ -109,7 +109,7 @@ let to_chan oc t =
let to_file_seq filename seq =
_with_out filename
(fun oc ->
seq (fun t -> to_chan oc t; output_char oc '\n')
seq (fun t -> to_chan oc t; output_char oc '\n')
)
let to_file filename t = to_file_seq filename (fun k -> k t)
@ -198,9 +198,9 @@ let parse_string s : t or_error =
let buf = Lexing.from_string s in
let d = Decoder.of_lexbuf buf in
match Decoder.next d with
| End -> Result.Error "unexpected end of file"
| Yield x -> Result.Ok x
| Fail s -> Result.Error s
| End -> Result.Error "unexpected end of file"
| Yield x -> Result.Ok x
| Fail s -> Result.Error s
(*$T
CCResult.to_opt (parse_string "(abc d/e/f \"hello \\\" () world\" )") <> None
@ -249,9 +249,9 @@ let parse_chan ic : sexp or_error =
let buf = Lexing.from_channel ic in
let d = Decoder.of_lexbuf buf in
match Decoder.next d with
| End -> Result.Error "unexpected end of file"
| Yield x -> Result.Ok x
| Fail e -> Result.Error e
| End -> Result.Error "unexpected end of file"
| Yield x -> Result.Ok x
| Fail e -> Result.Error e
let parse_chan_list ic =
let buf = Lexing.from_channel ic in

2
src/sexp/CCSexp.mli
View file

@ -12,7 +12,7 @@ type 'a gen = unit -> 'a option
type t = [
| `Atom of string
| `List of t list
]
]
type sexp = t
val equal : t -> t -> bool

36
src/unix/CCUnix.ml
View file

@ -83,29 +83,29 @@ let call_full_inner ?(bufsize=2048) ?(stdin=`Str "") ?(env=Unix.environment()) ~
kbprintf' buf cmd
(fun buf ->
let cmd = Buffer.contents buf in
let oc, ic, errc = Unix.open_process_full cmd env in
(* send stdin *)
begin match stdin with
| `Str s -> output_string ic s
| `Gen g -> iter_gen (output_string ic) g
end;
close_out ic;
(* read out and err *)
let out = read_all ~size:bufsize oc in
let err = read_all ~size:bufsize errc in
let status = Unix.close_process_full (oc, ic, errc) in
f (out,err,status)
let oc, ic, errc = Unix.open_process_full cmd env in
(* send stdin *)
begin match stdin with
| `Str s -> output_string ic s
| `Gen g -> iter_gen (output_string ic) g
end;
close_out ic;
(* read out and err *)
let out = read_all ~size:bufsize oc in
let err = read_all ~size:bufsize errc in
let status = Unix.close_process_full (oc, ic, errc) in
f (out,err,status)
)
let call_full ?bufsize ?stdin ?env cmd =
call_full_inner ?bufsize ?stdin ?env cmd
~f:(fun (out,err,status) ->
object
method stdout = out
method stderr = err
method status = status
method errcode = int_of_process_status status
end)
object
method stdout = out
method stderr = err
method status = status
method errcode = int_of_process_status status
end)
let call ?bufsize ?stdin ?env cmd =
call_full_inner ?bufsize ?stdin ?env cmd

18
src/unix/CCUnix.mli
View file

@ -3,10 +3,10 @@
(** {1 High-level Functions on top of Unix}
Some useful functions built on top of Unix.
Some useful functions built on top of Unix.
{b status: unstable}
@since 0.10 *)
{b status: unstable}
@since 0.10 *)
type 'a or_error = ('a, string) Result.result
type 'a gen = unit -> 'a option
@ -84,14 +84,14 @@ type async_call_result =
close_all:unit; (* close all 3 channels *) (** @since 0.11 *)
wait:Unix.process_status; (* block until the process ends *)
wait_errcode:int; (* block until the process ends, then extract errcode *)
(** @since 0.11 *)
(** @since 0.11 *)
>
(** A subprocess for interactive usage (read/write channels line by line)
@since 0.11 *)
val async_call : ?env:string array ->
('a, Buffer.t, unit, async_call_result) format4 ->
'a
('a, Buffer.t, unit, async_call_result) format4 ->
'a
(** Spawns a subprocess, like {!call}, but the subprocess's channels are
line generators and line sinks (for stdin).
if [p] is [async_call "cmd"], then [p#wait] waits for the subprocess
@ -100,7 +100,7 @@ val async_call : ?env:string array ->
(** {2 Accessors}
@since 0.11 *)
@since 0.11 *)
val stdout : < stdout : 'a; .. > -> 'a
val stderr : < stderr : 'a; .. > -> 'a
@ -110,7 +110,7 @@ val errcode : < errcode : 'a; .. > -> 'a
(** {2 Simple IO} *)
val with_in : ?mode:int -> ?flags:Unix.open_flag list ->
string -> f:(in_channel -> 'a) -> 'a
string -> f:(in_channel -> 'a) -> 'a
(** Open an input file with the given optional flag list, calls the function
on the input channel. When the function raises or returns, the
channel is closed.
@ -118,7 +118,7 @@ val with_in : ?mode:int -> ?flags:Unix.open_flag list ->
@since 0.16 *)
val with_out : ?mode:int -> ?flags:Unix.open_flag list ->
string -> f:(out_channel -> 'a) -> 'a
string -> f:(out_channel -> 'a) -> 'a
(** Same as {!with_in} but for an output channel
@param flags opening flags (default [[Unix.O_CREAT; Unix.O_TRUNC]])
[Unix.O_WRONLY] is used in any cases.