import Mixtbl from its repository, into misc/

_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

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)

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 *)

tests/run_tests.ml

@@ -21,6 +21,7 @@ let suite =
       Test_heap.suite;
       Test_graph.suite;
       Test_univ.suite;
+      Test_mixtbl.suite;
     ]
 
 let props =

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;
+    ]
+