diff --git a/.merlin b/.merlin index 8d5ebfe5..728816da 100644 --- a/.merlin +++ b/.merlin @@ -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 diff --git a/.ocamlinit b/.ocamlinit index be85d342..4bc62be7 100644 --- a/.ocamlinit +++ b/.ocamlinit @@ -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";; diff --git a/README.md b/README.md index a0ace7c7..6ea9202d 100644 --- a/README.md +++ b/README.md @@ -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` diff --git a/_oasis b/_oasis index 70521a04..5ae2f428 100644 --- a/_oasis +++ b/_oasis @@ -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 diff --git a/_tags b/_tags index 7addd0eb..352637f0 100644 --- a/_tags +++ b/_tags @@ -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 +: use_containers # Library containers_misc "misc/containers_misc.cmxs": use_containers_misc "misc/cache.cmx": for-pack(Containers_misc) @@ -79,29 +82,32 @@ : package(CamlGI) : 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 -: package(bench) -: 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 +: package(bench) +: 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 -: package(benchmark) +"benchs/bench_batch.native": package(benchmark) +"benchs/bench_batch.native": use_containers +: package(benchmark) # Executable bench_hash -"tests/bench_hash.native": package(unix) -"tests/bench_hash.native": use_containers -"tests/bench_hash.native": use_containers_misc -: package(unix) -: use_containers_misc +"benchs/bench_hash.native": package(unix) +"benchs/bench_hash.native": use_containers +"benchs/bench_hash.native": use_containers_misc +: package(unix) +: use_containers +: 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 +: use_containers_string # Executable test_lwt : package(lwt) : 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 : package(oUnit) : package(qcheck) +: package(unix) : use_containers +: 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 : package(unix) : use_containers : use_containers_misc # OASIS_STOP : thread : thread +: -traverse <{string,core}/**/*.ml>: warn_K, warn_Y, warn_X diff --git a/tests/bench_batch.ml b/benchs/bench_batch.ml similarity index 100% rename from tests/bench_batch.ml rename to benchs/bench_batch.ml diff --git a/tests/bench_conv.ml b/benchs/bench_conv.ml similarity index 100% rename from tests/bench_conv.ml rename to benchs/bench_conv.ml diff --git a/tests/bench_hash.ml b/benchs/bench_hash.ml similarity index 100% rename from tests/bench_hash.ml rename to benchs/bench_hash.ml diff --git a/tests/benchs.ml b/benchs/benchs.ml similarity index 98% rename from tests/benchs.ml rename to benchs/benchs.ml index a6553124..3a871049 100644 --- a/tests/benchs.ml +++ b/benchs/benchs.ml @@ -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 diff --git a/containers.odocl b/containers.odocl index c56c3c53..a5906cef 100644 --- a/containers.odocl +++ b/containers.odocl @@ -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 diff --git a/core/CCError.ml b/core/CCError.ml index eb8990f6..abe716f7 100644 --- a/core/CCError.ml +++ b/core/CCError.ml @@ -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 diff --git a/core/CCError.mli b/core/CCError.mli index 3fefdcb3..ee2368dd 100644 --- a/core/CCError.mli +++ b/core/CCError.mli @@ -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 diff --git a/core/CCFlatHashtbl.ml b/core/CCFlatHashtbl.ml new file mode 100644 index 00000000..5de3a2a2 --- /dev/null +++ b/core/CCFlatHashtbl.ml @@ -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 + diff --git a/core/CCFlatHashtbl.mli b/core/CCFlatHashtbl.mli new file mode 100644 index 00000000..746e31b6 --- /dev/null +++ b/core/CCFlatHashtbl.mli @@ -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 diff --git a/core/CCHashtbl.ml b/core/CCHashtbl.ml index 5de3a2a2..1a00239a 100644 --- a/core/CCHashtbl.ml +++ b/core/CCHashtbl.ml @@ -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 diff --git a/core/CCHashtbl.mli b/core/CCHashtbl.mli index bd4085f9..f160a609 100644 --- a/core/CCHashtbl.mli +++ b/core/CCHashtbl.mli @@ -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 diff --git a/core/CCPair.ml b/core/CCPair.ml index fa15d4c9..21e1b06c 100644 --- a/core/CCPair.ml +++ b/core/CCPair.ml @@ -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 diff --git a/core/CCPair.mli b/core/CCPair.mli index 1e6ddaf3..e2ccd3ba 100644 --- a/core/CCPair.mli +++ b/core/CCPair.mli @@ -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 diff --git a/core/CCRandom.ml b/core/CCRandom.ml index 86b1e6db..286fbbb5 100644 --- a/core/CCRandom.ml +++ b/core/CCRandom.ml @@ -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 = diff --git a/core/CCRandom.mli b/core/CCRandom.mli index fcf00d42..77f28ab1 100644 --- a/core/CCRandom.mli +++ b/core/CCRandom.mli @@ -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 diff --git a/core/CCString.ml b/core/CCString.ml index 96023ea0..6d926f43 100644 --- a/core/CCString.ml +++ b/core/CCString.ml @@ -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 diff --git a/core/CCString.mli b/core/CCString.mli index f003b908..78059fff 100644 --- a/core/CCString.mli +++ b/core/CCString.mli @@ -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 *) diff --git a/core/CCVector.ml b/core/CCVector.ml index e9675f23..c7f4b9f2 100644 --- a/core/CCVector.ml +++ b/core/CCVector.ml @@ -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; () diff --git a/core/META b/core/META index f814985d..e74efcb5 100644 --- a/core/META +++ b/core/META @@ -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." diff --git a/core/containers.mldylib b/core/containers.mldylib index 32db4c97..97c2b9fc 100644 --- a/core/containers.mldylib +++ b/core/containers.mldylib @@ -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 diff --git a/core/containers.mllib b/core/containers.mllib index 32db4c97..97c2b9fc 100644 --- a/core/containers.mllib +++ b/core/containers.mllib @@ -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 diff --git a/examples/id_sexp.ml b/examples/id_sexp.ml new file mode 100644 index 00000000..75f87a6e --- /dev/null +++ b/examples/id_sexp.ml @@ -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 diff --git a/misc/automaton.ml b/misc/automaton.ml index 53748039..c761fb0a 100644 --- a/misc/automaton.ml +++ b/misc/automaton.ml @@ -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); diff --git a/misc/cache.ml b/misc/cache.ml index 4f9a94f5..bbf59d3c 100644 --- a/misc/cache.ml +++ b/misc/cache.ml @@ -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 diff --git a/misc/fHashtbl.ml b/misc/fHashtbl.ml index 50e4c8a7..fe1b3ea2 100644 --- a/misc/fHashtbl.ml +++ b/misc/fHashtbl.ml @@ -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 diff --git a/misc/puf.ml b/misc/puf.ml index 7a00564a..d41e637f 100644 --- a/misc/puf.ml +++ b/misc/puf.ml @@ -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 = diff --git a/misc/sexp.ml b/misc/sexp.ml index adff2c5c..cd81626b 100644 --- a/misc/sexp.ml +++ b/misc/sexp.ml @@ -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 "@[(%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 diff --git a/misc/sexp.mli b/misc/sexp.mli index e2921285..c1f05b9d 100644 --- a/misc/sexp.mli +++ b/misc/sexp.mli @@ -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 diff --git a/misc/tTree.ml b/misc/tTree.ml index 538432c0..034f91d9 100644 --- a/misc/tTree.ml +++ b/misc/tTree.ml @@ -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 diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 99b05281..3d30e08e 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -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;; diff --git a/pervasives/CCPervasives.ml b/pervasives/CCPervasives.ml new file mode 100644 index 00000000..0454038d --- /dev/null +++ b/pervasives/CCPervasives.ml @@ -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 diff --git a/pervasives/containers_pervasives.mldylib b/pervasives/containers_pervasives.mldylib new file mode 100644 index 00000000..9dc3b5e4 --- /dev/null +++ b/pervasives/containers_pervasives.mldylib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: ea286cccf88f4c81c7b4627216807d4e) +CCPervasives +# OASIS_STOP diff --git a/pervasives/containers_pervasives.mllib b/pervasives/containers_pervasives.mllib new file mode 100644 index 00000000..9dc3b5e4 --- /dev/null +++ b/pervasives/containers_pervasives.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: ea286cccf88f4c81c7b4627216807d4e) +CCPervasives +# OASIS_STOP diff --git a/setup.ml b/setup.ml index a10ba986..d1659093 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 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 ();; diff --git a/tests/test_PiCalculus.ml b/tests/test_PiCalculus.ml index 6d20c9b7..1a2a1243 100644 --- a/tests/test_PiCalculus.ml +++ b/tests/test_PiCalculus.ml @@ -1,6 +1,7 @@ open OUnit +open Containers_misc open PiCalculus module Pi = PiCalculus diff --git a/tests/test_bencode.ml b/tests/test_bencode.ml index 0a5ec637..3bfb5c6f 100644 --- a/tests/test_bencode.ml +++ b/tests/test_bencode.ml @@ -1,5 +1,6 @@ open OUnit +open Containers_misc module B = Bencode diff --git a/tests/test_bij.ml b/tests/test_bij.ml index 90fb42ca..869bd9b1 100644 --- a/tests/test_bij.ml +++ b/tests/test_bij.ml @@ -1,5 +1,6 @@ open OUnit +open Containers_misc module Sequence = CCSequence diff --git a/tests/test_fHashtbl.ml b/tests/test_fHashtbl.ml index b45aec07..1c81e37e 100644 --- a/tests/test_fHashtbl.ml +++ b/tests/test_fHashtbl.ml @@ -1,5 +1,6 @@ open OUnit +open Containers_misc module Sequence = CCSequence diff --git a/tests/test_flatHashtbl.ml b/tests/test_flatHashtbl.ml index c88342f8..60437386 100644 --- a/tests/test_flatHashtbl.ml +++ b/tests/test_flatHashtbl.ml @@ -1,5 +1,6 @@ open OUnit +open Containers_misc module Sequence = CCSequence diff --git a/tests/test_graph.ml b/tests/test_graph.ml index 2899b232..a18913a7 100644 --- a/tests/test_graph.ml +++ b/tests/test_graph.ml @@ -3,6 +3,7 @@ open OUnit open Helpers +open Containers_misc module Sequence = CCSequence module G = PersistentGraph diff --git a/tests/test_heap.ml b/tests/test_heap.ml index daa120ba..c4162e23 100644 --- a/tests/test_heap.ml +++ b/tests/test_heap.ml @@ -2,6 +2,7 @@ open OUnit open Helpers +open Containers_misc module Sequence = CCSequence let test_empty () = diff --git a/tests/test_levenshtein.ml b/tests/test_levenshtein.ml index 72263d7a..4cb1876f 100644 --- a/tests/test_levenshtein.ml +++ b/tests/test_levenshtein.ml @@ -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 diff --git a/tests/test_pHashtbl.ml b/tests/test_pHashtbl.ml index 2103eb69..ce663ecd 100644 --- a/tests/test_pHashtbl.ml +++ b/tests/test_pHashtbl.ml @@ -1,5 +1,6 @@ open OUnit +open Containers_misc module Sequence = CCSequence diff --git a/tests/test_splayMap.ml b/tests/test_splayMap.ml index 2bd33c91..aa22a5a1 100644 --- a/tests/test_splayMap.ml +++ b/tests/test_splayMap.ml @@ -1,5 +1,6 @@ open OUnit +open Containers_misc module Sequence = CCSequence diff --git a/tests/test_univ.ml b/tests/test_univ.ml index 37a7f4a1..51fe80fa 100644 --- a/tests/test_univ.ml +++ b/tests/test_univ.ml @@ -1,5 +1,6 @@ open OUnit +open Containers_misc (** Test Univ embedding *)