(* Type-indexed Heterogeneous Collections *)
(* These are collections that hold elements of various types, with typed,
*safe* and above-the-board retrieval
The type representation of an element value is a part of the key
associated with this value in the collection.
This file implements two type-indexed collections:
-- (as a warm-up) an analogue of associative lists
-- an analogue of standard library's hash tables
*)
(*
#load "trep.cmo";;
*)
open Trep
(* A type-indexed analogue of associative lists
An element is identified by its type representation plus some key
(the key type may be unit, in which case the effective key is trep only)
*)
type 'key binding = B : 'key * 'a trep * 'a -> 'key binding
type 'key halist = 'key binding list
let lookup_hetkey : type a key. key -> a trep -> key halist -> a option =
fun key trep coll ->
let rec loop : key halist -> a option = function
| [] -> None
| B (key',trep',v) :: t -> match (key=key',teq trep' trep) with
| (true,Some Refl) -> Some v
| _ -> loop t
in loop coll
(* A sample collection. An element is identified by its type plus
an integer key
*)
let coll1 = [B (1,Int,10); B (2,Int,20); B (1,Bool,true)]
let _ = lookup_hetkey 1 Int coll1
let _ = lookup_hetkey 1 Bool coll1
(* A type-indexed hash table
The code below is essentially Stdlib.Hashtable, stripped to bare
essentials and slightly modified
The biggest modification is the resize function, which no longer
allocates long ndata_tail array (whose size is the same as the
main hash array). Our resize is hence conserves quite a bit of
heap space (and still maintains the constant stack space).
We elide the seeded version of hashtables for simplicity.
*)
module type TypedHashedType =
sig
type t (* key type *)
val equal: t -> t -> bool (* key equality *)
val hash: t -> 'a trep -> int (* Hash the key and trep *)
end
(* The stripped-down signature of our heterogeneous hash tables *)
module type S =
sig
type key
type t
val create: int -> t
val clear : t -> unit
val add: t -> key -> 'a trep -> 'a -> unit
val find_opt: t -> key -> 'a trep -> 'a option
val length: t -> int
end
let rec power_2_above x n =
if x >= n then x
else if x * 2 > Sys.max_array_length then x
else power_2_above (x * 2) n
module Make(H: TypedHashedType): (S with type key = H.t) =
struct
type key = H.t
type hashtbl =
(* The same representation as Stdlib.Hashtable *)
{ mutable size: int; (* number of entries *)
mutable bkts: bucketlist array; (* the buckets *)
mutable initial_size: int; (* initial array size *)
}
and 'b bucket = { mutable key: key;
trep: 'b trep;
mutable data: 'b;
mutable next: bucketlist }
and bucketlist =
| Empty : bucketlist
| Cons : 'b bucket -> bucketlist
type t = hashtbl
let length h = h.size
let create initial_size =
let s = power_2_above 16 initial_size in
{ initial_size = s; size = 0; bkts = Array.make s Empty }
let clear h =
h.size <- 0;
Array.fill h.bkts 0 (Array.length h.bkts) Empty
let key_index h key trep =
(H.hash key trep) land (Array.length h.bkts - 1)
(* This is a tricky function: a bucket list may contain cells with the
same key and trep. Therefore, the order in the bucket list is
important and should be maintained. When we copy buckets
from the old bkts array to the new one, we have to copy a bucket list
from its end. The function insert_bucket below does consing, hence
implicit reversing, so the order eventually comes out right.
We take care to make all recursive functions tail-recursive,
so to do all processing in constant stack space.
*)
let resize h =
let obkts = h.bkts in
let osize = Array.length obkts in
let nsize = osize * 2 in
if nsize < Sys.max_array_length then begin
let nbkts = Array.make nsize Empty in
h.bkts <- nbkts; (* so that indexfun sees the new bucket count *)
let insert_bucket b =
let nidx = key_index h b.key b.trep in
b.next <- nbkts.(nidx);
nbkts.(nidx) <- Cons b
in
let rec insert_buckets : bucketlist -> unit = function
| Empty -> ()
| Cons ({next=Empty} as b) -> insert_bucket b (* singleton *)
| Cons ({next=Cons bn} as b) ->
b.next <- Empty;
wind_list b bn
and wind_list : type b c. b bucket -> c bucket -> unit =
fun bprev -> function
| {next=Empty} as b -> insert_bucket b; unwind_list bprev
| {next=Cons bn} as b -> b.next<-Cons bprev; wind_list b bn
and unwind_list : type b. b bucket -> unit = function
| {next=Empty} as b -> insert_bucket b
| {next=Cons bn} as b -> insert_bucket b; unwind_list bn
in
for i = 0 to osize - 1 do
insert_buckets obkts.(i)
done
end
let add h key trep data =
let i = key_index h key trep in
let bucket = Cons {key; trep; data; next=h.bkts.(i)} in
h.bkts.(i) <- bucket;
h.size <- h.size + 1;
if h.size > Array.length h.bkts lsl 1 then resize h
let rec find_rec_opt : type a. key -> a trep -> bucketlist -> a option =
fun key trep -> function
| Empty ->
None
| Cons{key=key'; trep=trep'; data; next} ->
match (H.equal key key', teq trep trep') with
| (true,Some Refl) -> Some data
| _ -> find_rec_opt key trep next
let find_opt : type a. hashtbl -> key -> a trep -> a option =
fun h key trep ->
match h.bkts.(key_index h key trep) with
| Empty -> None
| Cons{key=key'; trep=trep'; data; next} ->
match (H.equal key key', teq trep trep') with
| (true,Some Refl) -> Some data
| _ -> find_rec_opt key trep next
end
(* Tests *)
module HTbl = Make(struct type t=int let equal = (=)
let hash key trep = Hashtbl.hash (key,trep) end)
let h1 = HTbl.create 16;;
let _ = HTbl.(add h1 1 Int 10; add h1 2 Int 20; add h1 1 Bool true)
let _ = HTbl.find_opt h1 1 Int
let _ = HTbl.find_opt h1 3 Int
let _ = HTbl.find_opt h1 1 Bool
;;