From cad578840eb6bb1e315ccadb99da362cbc7a7c2a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 19 Nov 2014 17:16:57 +0100 Subject: [PATCH] import Mixtbl from its repository, into misc/ --- _oasis | 2 +- misc/mixtbl.ml | 91 ++++++++++++++++++++++++++++++++++ misc/mixtbl.mli | 113 +++++++++++++++++++++++++++++++++++++++++++ tests/run_tests.ml | 1 + tests/test_mixtbl.ml | 94 +++++++++++++++++++++++++++++++++++ 5 files changed, 300 insertions(+), 1 deletion(-) create mode 100644 misc/mixtbl.ml create mode 100644 misc/mixtbl.mli create mode 100644 tests/test_mixtbl.ml diff --git a/_oasis b/_oasis index be3dba05..36303bfe 100644 --- a/_oasis +++ b/_oasis @@ -81,7 +81,7 @@ Library "containers_misc" PHashtbl, SkipList, SplayTree, SplayMap, Univ, Bij, PiCalculus, RAL, UnionFind, SmallSet, AbsSet, CSM, TTree, PrintBox, HGraph, Automaton, Conv, Bidir, Iteratee, - BTree, Ty, Cause, AVL, ParseReact + BTree, Ty, Cause, AVL, ParseReact, Mixtbl BuildDepends: unix,containers FindlibName: misc FindlibParent: containers diff --git a/misc/mixtbl.ml b/misc/mixtbl.ml new file mode 100644 index 00000000..95d3413b --- /dev/null +++ b/misc/mixtbl.ml @@ -0,0 +1,91 @@ + +(* +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 Hash Table with Heterogeneous Keys} *) + +type 'a t = ('a, (unit -> unit)) Hashtbl.t + +type ('a, 'b) injection = { + getter : 'a t -> 'a -> 'b option; + setter : 'a t -> 'a -> 'b -> unit; +} + +let create n = Hashtbl.create n + +let access () = + let r = ref None in + let getter tbl k = + r := None; (* reset state in case last operation was not a get *) + try + (Hashtbl.find tbl k) (); + let result = !r in + r := None; (* clean up here in order to avoid memory leak *) + result + with Not_found -> None + in + let setter tbl k v = + let v_opt = Some v in + Hashtbl.replace tbl k (fun () -> r := v_opt) + in + { getter; setter; } + +let get ~inj tbl x = inj.getter tbl x + +let set ~inj tbl x y = inj.setter tbl x y + +let length tbl = Hashtbl.length tbl + +let clear tbl = Hashtbl.clear tbl + +let remove tbl x = Hashtbl.remove tbl x + +let copy tbl = Hashtbl.copy tbl + +let mem ~inj tbl x = + match inj.getter tbl x with + | None -> false + | Some _ -> true + +let find ~inj tbl x = + match inj.getter tbl x with + | None -> raise Not_found + | Some y -> y + +let iter_keys tbl f = + Hashtbl.iter (fun x _ -> f x) tbl + +let fold_keys tbl acc f = + Hashtbl.fold (fun x _ acc -> f acc x) tbl acc + +let keys tbl = + Hashtbl.fold (fun x _ acc -> x :: acc) tbl [] + +let bindings ~inj tbl = + fold_keys tbl [] + (fun acc k -> + match inj.getter tbl k with + | None -> acc + | Some v -> (k, v) :: acc) diff --git a/misc/mixtbl.mli b/misc/mixtbl.mli new file mode 100644 index 00000000..4681c1b9 --- /dev/null +++ b/misc/mixtbl.mli @@ -0,0 +1,113 @@ +(* +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 Hash Table with Heterogeneous Keys} + +From https://github.com/mjambon/mixtbl , thanks to him. +Example: + +{[ +let inj_int = Mixtbl.access () ;; + +let tbl = Mixtbl.create 10 ;; + +OUnit.assert_equal None (Mixtbl.get ~inj:inj_int tbl "a");; + +Mixtbl.set inj_int tbl "a" 1;; + +OUnit.assert_equal (Some 1) (Mixtbl.get ~inj:inj_int tbl "a");; + +let inj_string = Mixtbl.access () ;; + +Mixtbl.set inj_string tbl "b" "Hello"; + +OUnit.assert_equal (Some "Hello") (Mixtbl.get inj_string tbl "b");; +OUnit.assert_equal None (Mixtbl.get inj_string tbl "a");; +OUnit.assert_equal (Some 1) (Mixtbl.get inj_int tbl "a");; +Mixtbl.set inj_string tbl "a" "Bye";; + +OUnit.assert_equal None (Mixtbl.get inj_int tbl "a");; +OUnit.assert_equal (Some "Bye") (Mixtbl.get inj_string tbl "a");; +]} + +@since NEXT_RELEASE *) + +type 'a t +(** A hash table containing values of different types. + The type parameter ['a] represents the type of the keys. *) + +type ('a, 'b) injection +(** An accessor for values of type 'b in the table. Values put + in the table using an injection can only be retrieved using this + very same injection. *) + +val create : int -> 'a t +(** [create n] creates a hash table of initial size [n]. *) + +val access : unit -> ('a, 'b) injection +(** Return a value that works for a given type of values. This function is + normally called once for each type of value. Several injections may be + created for the same type, but a value set with a given setter can only be + retrieved with the matching getter. The same injection can be reused + across multiple tables (although not in a thread-safe way). *) + +val get : inj:('a, 'b) injection -> 'a t -> 'a -> 'b option +(** Get the value corresponding to this key, if it exists and + belongs to the same injection *) + +val set : inj:('a, 'b) injection -> 'a t -> 'a -> 'b -> unit +(** Bind the key to the value, using [inj] *) + +val length : 'a t -> int +(** Number of bindings *) + +val clear : 'a t -> unit +(** Clear content of the hashtable *) + +val remove : 'a t -> 'a -> unit +(** Remove the binding for this key *) + +val copy : 'a t -> 'a t +(** Copy of the table *) + +val mem : inj:('a, _) injection -> 'a t -> 'a -> bool +(** Is the given key in the table, with the right type? *) + +val find : inj:('a, 'b) injection -> 'a t -> 'a -> 'b +(** Find the value for the given key, which must be of the right type. + raises Not_found if either the key is not found, or if its value + doesn't belong to the right type *) + +val iter_keys : 'a t -> ('a -> unit) -> unit +(** Iterate on the keys of this table *) + +val fold_keys : 'a t -> 'b -> ('b -> 'a -> 'b) -> 'b +(** Fold over the keys *) + +val keys : 'a t -> 'a list +(** List of the keys *) + +val bindings : inj:('a, 'b) injection -> 'a t -> ('a * 'b) list +(** All the bindings that come from the corresponding injection *) diff --git a/tests/run_tests.ml b/tests/run_tests.ml index 631379e5..cf4787ac 100644 --- a/tests/run_tests.ml +++ b/tests/run_tests.ml @@ -21,6 +21,7 @@ let suite = Test_heap.suite; Test_graph.suite; Test_univ.suite; + Test_mixtbl.suite; ] let props = diff --git a/tests/test_mixtbl.ml b/tests/test_mixtbl.ml new file mode 100644 index 00000000..6e517417 --- /dev/null +++ b/tests/test_mixtbl.ml @@ -0,0 +1,94 @@ + +open OUnit +open Containers_misc + +let example () = + let inj_int = Mixtbl.access () in + let tbl = Mixtbl.create 10 in + OUnit.assert_equal None (Mixtbl.get ~inj:inj_int tbl "a"); + Mixtbl.set inj_int tbl "a" 1; + OUnit.assert_equal (Some 1) (Mixtbl.get ~inj:inj_int tbl "a"); + let inj_string = Mixtbl.access () in + Mixtbl.set inj_string tbl "b" "Hello"; + OUnit.assert_equal (Some "Hello") (Mixtbl.get inj_string tbl "b"); + OUnit.assert_equal None (Mixtbl.get inj_string tbl "a"); + OUnit.assert_equal (Some 1) (Mixtbl.get inj_int tbl "a"); + Mixtbl.set inj_string tbl "a" "Bye"; + OUnit.assert_equal None (Mixtbl.get inj_int tbl "a"); + OUnit.assert_equal (Some "Bye") (Mixtbl.get inj_string tbl "a"); + () + +let test_length () = + let inj_int = Mixtbl.access () in + let tbl = Mixtbl.create 5 in + Mixtbl.set ~inj:inj_int tbl "foo" 1; + Mixtbl.set ~inj:inj_int tbl "bar" 2; + OUnit.assert_equal 2 (Mixtbl.length tbl); + OUnit.assert_equal 2 (Mixtbl.find ~inj:inj_int tbl "bar"); + Mixtbl.set ~inj:inj_int tbl "foo" 42; + OUnit.assert_equal 2 (Mixtbl.length tbl); + Mixtbl.remove tbl "bar"; + OUnit.assert_equal 1 (Mixtbl.length tbl); + () + +let test_clear () = + let inj_int = Mixtbl.access () in + let inj_str = Mixtbl.access () in + let tbl = Mixtbl.create 5 in + Mixtbl.set ~inj:inj_int tbl "foo" 1; + Mixtbl.set ~inj:inj_int tbl "bar" 2; + Mixtbl.set ~inj:inj_str tbl "baaz" "hello"; + OUnit.assert_equal 3 (Mixtbl.length tbl); + Mixtbl.clear tbl; + OUnit.assert_equal 0 (Mixtbl.length tbl); + () + +let test_mem () = + let inj_int = Mixtbl.access () in + let inj_str = Mixtbl.access () in + let tbl = Mixtbl.create 5 in + Mixtbl.set ~inj:inj_int tbl "foo" 1; + Mixtbl.set ~inj:inj_int tbl "bar" 2; + Mixtbl.set ~inj:inj_str tbl "baaz" "hello"; + OUnit.assert_bool "mem foo int" (Mixtbl.mem ~inj:inj_int tbl "foo"); + OUnit.assert_bool "mem bar int" (Mixtbl.mem ~inj:inj_int tbl "bar"); + OUnit.assert_bool "not mem baaz int" (not (Mixtbl.mem ~inj:inj_int tbl "baaz")); + OUnit.assert_bool "not mem foo str" (not (Mixtbl.mem ~inj:inj_str tbl "foo")); + OUnit.assert_bool "not mem bar str" (not (Mixtbl.mem ~inj:inj_str tbl "bar")); + OUnit.assert_bool "mem baaz str" (Mixtbl.mem ~inj:inj_str tbl "baaz"); + () + +let test_keys () = + let inj_int = Mixtbl.access () in + let inj_str = Mixtbl.access () in + let tbl = Mixtbl.create 5 in + Mixtbl.set ~inj:inj_int tbl "foo" 1; + Mixtbl.set ~inj:inj_int tbl "bar" 2; + Mixtbl.set ~inj:inj_str tbl "baaz" "hello"; + let l = Mixtbl.keys tbl in + OUnit.assert_equal ["baaz"; "bar"; "foo"] (List.sort compare l); + () + +let test_bindings () = + let inj_int = Mixtbl.access () in + let inj_str = Mixtbl.access () in + let tbl = Mixtbl.create 5 in + Mixtbl.set ~inj:inj_int tbl "foo" 1; + Mixtbl.set ~inj:inj_int tbl "bar" 2; + Mixtbl.set ~inj:inj_str tbl "baaz" "hello"; + Mixtbl.set ~inj:inj_str tbl "str" "rts"; + let l_int = Mixtbl.bindings tbl ~inj:inj_int in + OUnit.assert_equal ["bar", 2; "foo", 1] (List.sort compare l_int); + let l_str = Mixtbl.bindings tbl ~inj:inj_str in + OUnit.assert_equal ["baaz", "hello"; "str", "rts"] (List.sort compare l_str); + () + +let suite = + "mixtbl" >::: + [ "example" >:: example; + "length" >:: test_length; + "clear" >:: test_clear; + "mem" >:: test_mem; + "bindings" >:: test_bindings; + ] +