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

merge from master

Browse source
This commit is contained in:
Simon Cruanes 2014-09-28 15:23:56 +02:00
commit 2fb05ad8b5
50 changed files with 1826 additions and 601 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.merlin
View file

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

3
.ocamlinit
View file

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

7
README.md
View file

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

35
_oasis
View file

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

51
_tags
View file

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

0
tests/bench_batch.ml → benchs/bench_batch.ml
View file

0
tests/bench_conv.ml → benchs/bench_conv.ml
View file

0
tests/bench_hash.ml → benchs/bench_hash.ml
View file

6
tests/benchs.ml → benchs/benchs.ml
View file

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

3
containers.odocl
View file

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

8
core/CCError.ml
View file

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

9
core/CCError.mli
View file

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

272
core/CCFlatHashtbl.ml Normal file
View file

@ -0,0 +1,272 @@
(*
copyright (c) 2013-2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Open-Addressing Hash-table}
We use Robin-Hood hashing as described in
http://codecapsule.com/2013/11/17/robin-hood-hashing-backward-shift-deletion/
with backward shift. *)
type 'a sequence = ('a -> unit) -> unit
module type S = sig
type key
type 'a t
val create : int -> 'a t
(** Create a new table of the given initial capacity *)
val mem : 'a t -> key -> bool
(** [mem tbl k] returns [true] iff [k] is mapped to some value
in [tbl] *)
val find : 'a t -> key -> 'a option
val find_exn : 'a t -> key -> 'a
val get : key -> 'a t -> 'a option
(** [get k tbl] recovers the value for [k] in [tbl], or
returns [None] if [k] doesn't belong *)
val get_exn : key -> 'a t -> 'a
val add : 'a t -> key -> 'a -> unit
(** [add tbl k v] adds [k -> v] to [tbl], possibly replacing the old
value associated with [k]. *)
val remove : 'a t -> key -> unit
(** Remove binding *)
val size : _ t -> int
(** Number of bindings *)
val of_list : (key * 'a) list -> 'a t
val to_list : 'a t -> (key * 'a) list
val of_seq : (key * 'a) sequence -> 'a t
val to_seq : 'a t -> (key * 'a) sequence
val keys : _ t -> key sequence
val values : 'a t -> 'a sequence
end
module type HASHABLE = sig
type t
val equal : t -> t -> bool
val hash : t -> int
end
module Make(X : HASHABLE) = struct
type key = X.t
type 'a bucket =
| Empty
| Key of key * 'a * int (* store the hash too *)
type 'a t = {
mutable arr : 'a bucket array;
mutable size : int;
}
let size tbl = tbl.size
let _reached_max_load tbl =
let n = Array.length tbl.arr in
(n - tbl.size) < n/10 (* full at 9/10 *)
let create i =
let i = min Sys.max_array_length (max i 8) in
{ arr=Array.make i Empty; size=0; }
(* initial index for a value with hash [h] *)
let _initial_idx tbl h =
h mod Array.length tbl.arr
let _succ tbl i =
let i' = i+1 in
if i' = Array.length tbl.arr then 0 else i'
let _pred tbl i =
if i = 0 then Array.length tbl.arr - 1 else i-1
(* distance to initial bucket, at index [i] with hash [h] *)
let _dib tbl h i =
let i0 = _initial_idx tbl h in
if i>=i0
then i-i0
else i+ (Array.length tbl.arr - i0 - 1)
(* insert k->v in [tbl], currently at index [i] *)
let rec _linear_probe tbl k v h_k i =
match tbl.arr.(i) with
| Empty ->
(* add binding *)
tbl.size <- 1 + tbl.size;
tbl.arr.(i) <- Key (k, v, h_k)
| Key (k', _, h_k') when X.equal k k' ->
(* replace *)
assert (h_k = h_k');
tbl.arr.(i) <- Key (k, v, h_k)
| Key (k', v', h_k') ->
if _dib tbl h_k i < _dib tbl h_k' i
then (
(* replace *)
tbl.arr.(i) <- Key (k, v, h_k);
_linear_probe tbl k' v' h_k' (_succ tbl i)
) else
(* go further *)
_linear_probe tbl k v h_k (_succ tbl i)
(* resize table: put a bigger array in it, then insert values
from the old array *)
let _resize tbl =
let size' = min Sys.max_array_length (2 * Array.length tbl.arr) in
let arr' = Array.make size' Empty in
let old_arr = tbl.arr in
(* replace with new table *)
tbl.size <- 0;
tbl.arr <- arr';
Array.iter
(function
| Empty -> ()
| Key (k, v, h_k) -> _linear_probe tbl k v h_k (_initial_idx tbl h_k)
) old_arr
let add tbl k v =
if _reached_max_load tbl
then _resize tbl;
(* insert value *)
let h_k = X.hash k in
_linear_probe tbl k v h_k (_initial_idx tbl h_k)
(* shift back elements that have a DIB > 0 until an empty bucket is
met, or some element doesn't need shifting *)
let rec _backward_shift tbl i =
match tbl.arr.(i) with
| Empty -> ()
| Key (_, _, h_k) when _dib tbl h_k i = 0 ->
() (* stop *)
| Key (k, v, h_k) as bucket ->
assert (_dib tbl h_k i > 0);
(* shift backward *)
tbl.arr.(_pred tbl i) <- bucket;
tbl.arr.(i) <- Empty;
_backward_shift tbl (_succ tbl i)
(* linear probing for removal of [k] *)
let rec _linear_probe_remove tbl k h_k i =
match tbl.arr.(i) with
| Empty -> ()
| Key (k', _, _) when X.equal k k' ->
tbl.arr.(i) <- Empty;
tbl.size <- tbl.size - 1;
_backward_shift tbl (_succ tbl i)
| Key (_, _, h_k') ->
if _dib tbl h_k' i < _dib tbl h_k i
then () (* [k] not present, would be here otherwise *)
else _linear_probe_remove tbl k h_k (_succ tbl i)
let remove tbl k =
let h_k = X.hash k in
_linear_probe_remove tbl k h_k (_initial_idx tbl h_k)
let rec _get_exn tbl k h_k i dib =
match tbl.arr.(i) with
| Empty -> raise Not_found
| Key (k', v', _) when X.equal k k' -> v'
| Key (_, _, h_k') ->
if _dib tbl h_k' i < dib
then raise Not_found (* [k] would be here otherwise *)
else _get_exn tbl k h_k (_succ tbl i) (dib+1)
let get_exn k tbl =
let h_k = X.hash k in
let i0 = _initial_idx tbl h_k in
match tbl.arr.(i0) with
| Empty -> raise Not_found
| Key (k', v, _) ->
if X.equal k k' then v
else let i1 = _succ tbl i0 in
match tbl.arr.(i1) with
| Empty -> raise Not_found
| Key (k', v, _) ->
if X.equal k k' then v
else
let i2 = _succ tbl i1 in
match tbl.arr.(i2) with
| Empty -> raise Not_found
| Key (k', v, _) ->
if X.equal k k' then v
else _get_exn tbl k h_k (_succ tbl i2) 3
let get k tbl =
try Some (get_exn k tbl)
with Not_found -> None
let find_exn tbl k = get_exn k tbl
let find tbl k =
try Some (get_exn k tbl)
with Not_found -> None
let mem tbl k =
try ignore (get_exn k tbl); true
with Not_found -> false
let of_list l =
let tbl = create 16 in
List.iter (fun (k,v) -> add tbl k v) l;
tbl
let to_list tbl =
Array.fold_left
(fun acc bucket -> match bucket with
| Empty -> acc
| Key (k,v,_) -> (k,v)::acc
) [] tbl.arr
let of_seq seq =
let tbl = create 16 in
seq (fun (k,v) -> add tbl k v);
tbl
let to_seq tbl yield =
Array.iter
(function Empty -> () | Key (k, v, _) -> yield (k,v))
tbl.arr
let keys tbl yield =
Array.iter
(function Empty -> () | Key (k, _, _) -> yield k)
tbl.arr
let values tbl yield =
Array.iter
(function Empty -> () | Key (_, v, _) -> yield v)
tbl.arr
end

84
core/CCFlatHashtbl.mli Normal file
View file

@ -0,0 +1,84 @@
(*
copyright (c) 2013-2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Open-Addressing Hash-table}
This module was previously named [CCHashtbl], but the name is now used for
an extension of the standard library's hashtables.
@since NEXT_RELEASE *)
type 'a sequence = ('a -> unit) -> unit
module type S = sig
type key
type 'a t
val create : int -> 'a t
(** Create a new table of the given initial capacity *)
val mem : 'a t -> key -> bool
(** [mem tbl k] returns [true] iff [k] is mapped to some value
in [tbl] *)
val find : 'a t -> key -> 'a option
val find_exn : 'a t -> key -> 'a
val get : key -> 'a t -> 'a option
(** [get k tbl] recovers the value for [k] in [tbl], or
returns [None] if [k] doesn't belong *)
val get_exn : key -> 'a t -> 'a
val add : 'a t -> key -> 'a -> unit
(** [add tbl k v] adds [k -> v] to [tbl], possibly replacing the old
value associated with [k]. *)
val remove : 'a t -> key -> unit
(** Remove binding *)
val size : _ t -> int
(** Number of bindings *)
val of_list : (key * 'a) list -> 'a t
val to_list : 'a t -> (key * 'a) list
val of_seq : (key * 'a) sequence -> 'a t
val to_seq : 'a t -> (key * 'a) sequence
val keys : _ t -> key sequence
val values : 'a t -> 'a sequence
end
module type HASHABLE = sig
type t
val equal : t -> t -> bool
val hash : t -> int
end
module Make(X : HASHABLE) : S with type key = X.t

398
core/CCHashtbl.ml
View file

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

145
core/CCHashtbl.mli
View file

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

4
core/CCPair.ml
View file

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

3
core/CCPair.mli
View file

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

4
core/CCRandom.ml
View file

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

21
core/CCRandom.mli
View file

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

2
core/CCString.ml
View file

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

54
core/CCString.mli
View file

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

2
core/CCVector.ml
View file

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

13
core/META
View file

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

3
core/containers.mldylib
View file

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

3
core/containers.mllib
View file

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

13
examples/id_sexp.ml Normal file
View file

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

4
misc/automaton.ml
View file

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

8
misc/cache.ml
View file

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

2
misc/fHashtbl.ml
View file

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

2
misc/puf.ml
View file

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

813
misc/sexp.ml
View file

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

282
misc/sexp.mli
View file

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

2
misc/tTree.ml
View file

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

9
myocamlbuild.ml
View file

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

49
pervasives/CCPervasives.ml Normal file
View file

@ -0,0 +1,49 @@
(*
copyright (c) 2013-2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Drop-In replacement to Stdlib}
This module is meant to be opened if one doesn't want to use both, say,
[List] and [CCList]. Instead, [List] is now an alias to
{[struct
include List
include CCList
end
]}
@since NEXT_RELEASE
*)
module Array = struct include Array include CCArray end
module Bool = CCBool
module Error = CCError
module Fun = CCFun
module Int = CCInt
module List = struct include List include CCList end
module Opt = CCOpt
module Pair = CCPair
module String = struct include String include CCString end
module Vector = CCVector

4
pervasives/containers_pervasives.mldylib Normal file
View file

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

4
pervasives/containers_pervasives.mllib Normal file
View file

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

91
setup.ml
View file

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

1
tests/test_PiCalculus.ml
View file

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

1
tests/test_bencode.ml
View file

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

1
tests/test_bij.ml
View file

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

1
tests/test_fHashtbl.ml
View file

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

1
tests/test_flatHashtbl.ml
View file

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

1
tests/test_graph.ml
View file

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

1
tests/test_heap.ml
View file

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

2
tests/test_levenshtein.ml
View file

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

1
tests/test_pHashtbl.ml
View file

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

1
tests/test_splayMap.ml
View file

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

1
tests/test_univ.ml
View file

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