Source file batHashtbl.ml

(*
 * BatHashtbl, extra functions over hashtables.
 * Copyright (C) 1996 Xavier Leroy
 *               2003 Nicolas Cannasse
 *               2005 Damien Doligez
 *               2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version,
 * with the special exception on linking described in file LICENSE.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)


(** {6 Import the contents of {!Hashtbl}}

    Note: We can't directly [include Hashtbl] as this would cause a
    collision on [Make]*)
type ('a, 'b) t = ('a, 'b) Hashtbl.t
let create s  = Hashtbl.create s
let clear    = Hashtbl.clear
let add      = Hashtbl.add
let copy     = Hashtbl.copy
let find     = Hashtbl.find
let find_all = Hashtbl.find_all
let mem      = Hashtbl.mem
let remove   = Hashtbl.remove
let replace  = Hashtbl.replace
let iter     = Hashtbl.iter
let fold     = Hashtbl.fold
let hash     = Hashtbl.hash

type statistics = Hashtbl.statistics
let stats    = Hashtbl.stats

type ('a, 'b) h_bucketlist =
  | Empty
  | Cons of 'a * 'b * ('a, 'b) h_bucketlist

type ('a, 'b) h_t = {
  mutable size: int;
  mutable data: ('a, 'b) h_bucketlist array;
##V>=4##  mutable seed: int;
##V>=4##  initial_size: int;
}

external h_conv : ('a, 'b) t -> ('a, 'b) h_t = "%identity"
external h_make : ('a, 'b) h_t -> ('a, 'b) t = "%identity"

##V>=4## let key_index h key =
##V>=4##   if Obj.size (Obj.repr h) >= 3
##V>=4##   then Hashtbl.seeded_hash (h_conv h).seed key
##V>=4##        land (Array.length (h_conv h).data - 1)
##V>=4##   else (Hashtbl.hash key land max_int) mod (Array.length (h_conv h).data)

##V<4## let key_index h key = (Hashtbl.hash key land max_int)
##V<4##                       mod (Array.length (h_conv h).data)

(* NOT EXPOSED
   let resize hashfun tbl =
   let odata = tbl.data in
   let osize = Array.length odata in
   let nsize = min (2 * osize + 1) Sys.max_array_length in
   if nsize <> osize then (
    let ndata = Array.create nsize Empty in
    let rec insert_bucket = function
    Empty -> ()
      | Cons(key, data, rest) ->
         insert_bucket rest; (* preserve original order of elements *)
         let nidx = (hashfun key) mod nsize in
         ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in
    for i = 0 to osize - 1 do
      insert_bucket odata.(i)
    done;
    tbl.data <- ndata;
   )
*)

let enum h =
  let rec make ipos ibuck idata icount =
    let pos = ref ipos in
    let buck = ref ibuck in
    let hdata = ref idata in
    let hcount = ref icount in
    let force() =
      (* this is a hack in order to keep an O(1) enum constructor **)
      if !hcount = -1 then (
        hcount := (h_conv h).size;
        hdata := Array.copy (h_conv h).data;
      );
    in
    let rec next() =
      force();
      match !buck with
      | Empty ->
        if !hcount = 0 then raise BatEnum.No_more_elements;
        incr pos;
        buck := Array.unsafe_get !hdata !pos;
        next()
      | Cons (k,i,next_buck) ->
        buck := next_buck;
        decr hcount;
        (k,i)
    in
    let count() =
      if !hcount = -1 then (h_conv h).size else !hcount
    in
    let clone() =
      force();
      make !pos !buck !hdata !hcount
    in
    BatEnum.make ~next ~count ~clone
  in
  make (-1) Empty (Obj.magic()) (-1)

let to_list ht =
  fold (fun k v acc ->
      (k, v) :: acc
    ) ht []
(*$T to_list
  let ht = create 1 in \
  add ht 1 '2'; \
  to_list ht = [(1, '2')]
*)

let of_list l =
  let res = create 11 in
  List.iter (fun (k, v) ->
      add res k v
    ) l;
  res
(*$T of_list
  let l = [(1,2);(2,3);(3,4)] in \
  List.sort compare (to_list (of_list l)) = l
*)

let bindings ht = to_list ht
(*$T bindings
  let ht = create 1 in \
  add ht 1 '2'; \
  bindings ht = [(1, '2')]
*)


let keys h = BatEnum.map (fun (k,_) -> k) (enum h)
let values h = BatEnum.map (fun (_,v) -> v) (enum h)

let map f h =
  let rec loop = function
    | Empty -> Empty
    | Cons (k,v,next) -> Cons (k,f k v,loop next)
  in
  let hc = h_conv h in
  h_make { hc with data = Array.map loop hc.data; }

(*$T map
  (* non regression test for bug #354 *) \
  let h = create 20 and k = (0,5) in add h k 3 ; \
  let h2 = map (fun _ v -> v) h in mem h2 k
*)

let map_inplace f h =
  let rec loop = function
    | Empty -> Empty
    | Cons (k, v, next) -> Cons (k, f k v, loop next)
  in
  BatArray.modify loop (h_conv h).data

(* Helper functions to test hashtables which values are integers: *)
(*$inject
  let (|>) x f = f x
  let printer = IO.to_string (List.print Int.print)
  let to_sorted_list h = values h |> List.of_enum |> List.sort Int.compare
*)
(*$= map_inplace & ~printer
  (let h = Enum.combine (1 -- 5) (1 -- 5) |> of_enum in \
   map_inplace (fun _ x -> x+1) h ; \
   to_sorted_list h) [2;3;4;5;6]
*)

let remove_all h key =
  let hc = h_conv h in
  let rec loop = function
    | Empty -> Empty
    | Cons(k,v,next) ->
      if k = key then (
        hc.size <- pred hc.size;
        loop next
      ) else
        Cons(k,v,loop next)
  in
  let pos = key_index h key in
  Array.unsafe_set hc.data pos (loop (Array.unsafe_get hc.data pos))

let find_default h key defval =
  let rec loop = function
    | Empty -> defval
    | Cons (k,v,next) ->
      if k = key then v else loop next
  in
  let pos = key_index h key in
  loop (Array.unsafe_get (h_conv h).data pos)

let find_option h key =
  let rec loop = function
    | Empty -> None
    | Cons (k,v,next) ->
      if k = key then Some v else loop next
  in
  let pos = key_index h key in
  loop (Array.unsafe_get (h_conv h).data pos)

exception Verified

let exists p ht =
  try
    iter (fun k v ->
        if p k v then raise Verified
      ) ht;
    false
  with Verified -> true

(*$T exists
    exists (fun k v -> k = v) (of_list [(1,2);(2,3);(3,3)])
    not (exists (fun k v -> k = v) (of_list []))
*)

let of_enum e =
  let h = create (if BatEnum.fast_count e then BatEnum.count e else 0) in
  BatEnum.iter (fun (k,v) -> add h k v) e;
  h

let length h = (h_conv h).size

let is_empty h = length h = 0

exception Hashtbl_key_not_found
let modify_opt key f h =
  let hc = h_conv h in

  let rec loop = function
    (* Inserting an element might require a resize of the hash table.
       We rely on Hashtbl.add function to grow the hashtbl if needed
       instead of duplicating logic from the OCaml standard library. *)
    | Empty ->
      raise Hashtbl_key_not_found
    | Cons(k,v,next) ->
      if k = key then
        match f (Some v) with
          | Some v -> Cons(key,v,next)
          | None ->
            hc.size <- pred hc.size;
            next
      else
        Cons(k,v,loop next)
  in
  try
    let pos = key_index h key in
    Array.unsafe_set hc.data pos (loop (Array.unsafe_get hc.data pos))
  with
  | Hashtbl_key_not_found ->
    begin match f None with
      | None -> ()
      | Some v ->
        (* Add the element to make sure the hashtbl is grown correctly if
           needed. *)
        add h key v
    end

(*$T modify_opt
  let h = create 3 in \
  modify_opt "foo" (function None -> Some 0 | _ -> assert false) h; \
  length h = 1 && find_option h "foo" = Some 0
  let h = create 3 in \
  add h "foo" 1; \
  modify_opt "foo" (function Some 1 -> None | _ -> assert false) h; \
  length h = 0 && find_option h "foo" = None
*)

let modify key f h =
  let hc = h_conv h in
  let rec loop = function
    | Empty -> raise Not_found
    | Cons(k,v,next) ->
      if k = key then (
        Cons(key,f v,next)
      ) else
        Cons(k,v,loop next)
  in
  let pos = key_index h key in
  Array.unsafe_set hc.data pos (loop (Array.unsafe_get hc.data pos))

(*$T modify
  let h = create 3 in \
  add h "foo" 1; add h "bar" 2; \
  modify "foo" succ h; \
  values h |> List.of_enum = [ 2; 2 ]
  let h = create 3 in \
  try modify "baz" succ h; false \
  with Not_found -> true
*)

let modify_def v0 key f h =
  let f' = function
    | None -> Some (f v0)
    | Some v -> Some (f v)
  in
  modify_opt key f' h

(*$T modify_def
  let h = create 3 in \
  modify_def 0 "foo" succ h; \
  length h = 1 && find_option h "foo" = Some 1
*)

let print ?(first="{\n") ?(last="\n}") ?(sep=",\n") ?(kvsep=": ") print_k print_v out t =
  BatEnum.print ~first ~last ~sep (fun out (k,v) -> BatPrintf.fprintf out "%a%s%a" print_k k kvsep print_v v) out (enum t)

let filteri (f:'key -> 'a -> bool) (t:('key, 'a) t) =
  let result = create 16 in
  iter (fun k a -> if f k a then add result k a) t;
  result

let filteri_inplace f h =
  let hc = h_conv h in
  let rec loop = function
    | Empty -> Empty
    | Cons (k, v, next) ->
      if f k v then Cons (k, v, loop next)
      else (
        hc.size <- pred hc.size ;
        loop next
      ) in
  BatArray.modify loop hc.data

(*$= filteri_inplace & ~printer
  (let h = Enum.combine (1 -- 5) (1 -- 5) |> of_enum in \
   filteri_inplace (fun _ x -> x>3) h ; \
   to_sorted_list h) [4; 5]
*)


let filter f t = filteri (fun _k a -> f a) t

let filter_inplace f h = filteri_inplace (fun _k a -> f a) h

(*$= filter_inplace & ~printer:(IO.to_string (List.print Int.print))
  (let h = Enum.combine (1 -- 5) (1 -- 5) |> of_enum in \
   filter_inplace (fun x -> x>3) h ; \
   to_sorted_list h) [4; 5]
*)


let filter_map f t =
  let result = create 16 in
  iter (fun k a -> match f k a with
    | None   -> ()
    | Some v -> add result k v) t;
  result

let filter_map_inplace f h =
  let hc = h_conv h in
  let rec loop = function
    | Empty -> Empty
    | Cons (k, v, next) ->
      (match f k v with
       | None ->
         hc.size <- pred hc.size ;
         loop next
       | Some v' -> Cons (k, v', loop next)) in
  BatArray.modify loop hc.data

(*$= filter_map_inplace & ~printer
  (let h = Enum.combine (1 -- 5) (1 -- 5) |> of_enum in \
   filter_map_inplace (fun _ x -> if x>3 then Some (x+1) else None) h ; \
   to_sorted_list h) [5; 6]
*)


let merge f h1 h2 =
  let res = create (max (length h1) (length h2)) in
  let may_add_res k v1 v2 =
    BatOption.may (add res k) (f k v1 v2) in
  iter (fun k v1 ->
    may_add_res k (Some v1) (find_option h2 k)
  ) h1 ;
  iter (fun k v2 ->
      if not (mem h1 k) then
        may_add_res k None (Some v2)
  ) h2 ;
  res

(*$inject
  let union = merge (fun _ l r -> if l = None then r else l)
  let inter = merge (fun _ l r -> if l = None then l else r)
  let equal h1 h2 = to_sorted_list h1 = to_sorted_list h2
  let empty = create 0
  let h_1_5 = Enum.combine (1 -- 5) (1 -- 5) |> of_enum
  let h_1_3 = Enum.combine (1 -- 3) (1 -- 3) |> of_enum
  let h_3_5 = Enum.combine (3 -- 5) (3 -- 5) |> of_enum
  let of_uniq_list l = List.unique l |> List.map (fun i -> i, i) |> of_list
*)
(*$= merge & ~printer
  [] \
    (merge (fun k _ _ -> Some k) empty empty |> to_sorted_list)
  [1; 2; 3; 4; 5] \
    (merge (fun _ l _ -> l) h_1_5 empty |> to_sorted_list)
  [] \
    (merge (fun _ _ r -> r) h_1_5 empty |> to_sorted_list)
  [] \
    (merge (fun _ l _ -> l) empty h_1_5 |> to_sorted_list)
  [1; 2; 3; 4; 5] \
    (merge (fun _ _ r -> r) empty h_1_5 |> to_sorted_list)
  [1; 2; 3] \
    (let h = Enum.combine (3 -- 6) (13 -- 15) |> of_enum in \
     merge (fun _ l _ -> l) h_1_3 h |> to_sorted_list)
  [13; 14; 15] \
    (let h = Enum.combine (3 -- 5) (13 -- 15) |> of_enum in \
     merge (fun _ _ r -> r) h_1_3 h |> to_sorted_list)
  [] \
    (merge (fun _ _ _ -> None) h_1_3 h_3_5 |> to_sorted_list)
*)
(*$= union & ~printer
  [1; 2; 3; 4; 5] \
    (union h_1_3 h_3_5 |> to_sorted_list)
*)
(*$= inter & ~printer
  [3] \
    (inter h_1_3 h_3_5 |> to_sorted_list)
*)
(*$Q equal
  (Q.list Q.small_int) (fun l -> \
    let h = of_uniq_list l in \
    equal (inter h h) h)
  (Q.list Q.small_int) (fun l -> \
    let h = of_uniq_list l in \
    equal (union h h) h)
  (Q.list Q.small_int) (fun l -> \
    let h = of_uniq_list l in \
    equal (union h empty) h)
  (Q.list Q.small_int) (fun l -> \
    let h = of_uniq_list l in \
    equal (inter h empty) empty)
  (Q.pair (Q.list Q.small_int) (Q.list Q.small_int)) (fun (l1, l2) -> \
    let h1 = of_uniq_list l1 and h2 = of_uniq_list l2 in \
    equal (inter h1 h2) (inter h2 h1))
  (Q.pair (Q.list Q.small_int) (Q.list Q.small_int)) (fun (l1, l2) -> \
    let h1 = of_uniq_list l1 and h2 = of_uniq_list l2 in \
    equal (union h1 h2) (union h2 h1))
*)

let merge_all f h1 h2 =
  let res = create (max (length h1) (length h2)) in
  let may_add_res k v1 v2 =
    List.iter (add res k) (List.rev (f k v1 v2)) in
  iter (fun k _ ->
    let l1 = find_all h1 k
    and l2 = find_all h2 k in
    may_add_res k l1 l2
  ) h1 ;
  iter (fun k _ ->
    match find_all h1 k with
    | [] ->
        let l2 = find_all h2 k in
        may_add_res k [] l2
    | _ -> () (* done above *)
  ) h2 ;
  res

(*$= merge_all & ~printer
  [] \
    (let h1 = create 0 and h2 = create 0 in \
     merge_all (fun k _ _ -> [k]) h1 h2 |> to_sorted_list)
  [1; 2; 3; 4; 5] \
    (let h = create 0 in \
     merge_all (fun _ l _ -> l) h_1_5 h |> to_sorted_list)
  [] \
    (let h = create 0 in \
     merge_all (fun _ _ r -> r) h_1_5 h |> to_sorted_list)
  [] \
    (let h = create 0 in \
     merge_all (fun _ l _ -> l) h h_1_5 |> to_sorted_list)
  [1; 2; 3; 4; 5] \
    (let h = create 0 in \
     merge_all (fun _ _ r -> r) h h_1_5 |> to_sorted_list)
  [1; 2; 3] \
    (let h = Enum.combine (3 -- 6) (13 -- 15) |> of_enum in \
     merge_all (fun _ l _ -> l) h_1_3 h |> to_sorted_list)
  [13; 14; 15] \
    (let h = Enum.combine (3 -- 5) (13 -- 15) |> of_enum in \
     merge_all (fun _ _ r -> r) h_1_3 h |> to_sorted_list)
  [] \
    (merge_all (fun _ _ _ -> []) h_1_3 h_3_5 |> to_sorted_list)
  [2; 1] \
    (let h1 = of_list [1, 1] in \
     let h2 = copy h1 in \
     Hashtbl.add h2 1 2 ;\
     let h = merge_all (fun _ _ r -> r) h1 h2 in \
     find_all h 1)
*)
exception Falsified

(* test if predicate holds for all key-value pairs *)
let for_all p ht =
  try
    iter (fun k v ->
        if not (p k v) then
          raise Falsified
      ) ht;
    true
  with Falsified -> false

(*$T for_all
    for_all (fun k v -> k = v) (of_list [(1,1);(2,2);(3,3)])
    not (for_all (fun k v -> k = v) (of_list [(1,1);(2,2);(3,4)]))
    for_all (fun k v -> k = v) empty
*)

module Exceptionless =
struct
  let find = find_option
  let modify k f = BatPervasives.wrap (modify k f)
end

module Infix =
struct
  let (-->) h k = find h k
  let (<--) h (k,v) = add h k v
end

module Labels =
struct
  let label f = fun key data -> f ~key ~data
  let add e ~key ~data = add e key data
  let replace e ~key ~data = replace e key data
  let iter ~f e = iter (label f) e
  let for_all ~f e = for_all (label f) e
  let map ~f e = map (label f) e
  let map_inplace ~f e = map_inplace (label f) e
  let filter ~f e = filter f e
  let filter_inplace ~f e = filter_inplace f e
  let filteri ~f e = filteri (label f) e
  let filteri_inplace ~f e = filteri_inplace (label f) e
  let filter_map ~f e = filter_map (label f) e
  let filter_map_inplace ~f e = filter_map_inplace (label f) e
  let fold ~f e ~init = fold (label f) e init
  let exists ~f e = exists (label f) e
  let modify ~key ~f = modify key f
  let modify_def ~default ~key ~f = modify_def default key f
  let modify_opt ~key ~f = modify_opt key f
  let merge ~f ~left ~right = merge f left right
  let merge_all ~f ~left ~right = merge_all f left right
end

module type HashedType = Hashtbl.HashedType

module type S =
sig
  type key
  type 'a t
  val create : int -> 'a t
  val length : 'a t -> int
  val is_empty : 'a t -> bool
  val clear : 'a t -> unit
  val copy : 'a t -> 'a t
  val add : 'a t -> key -> 'a -> unit
  val remove : 'a t -> key -> unit
  val remove_all : 'a t -> key -> unit
  val find : 'a t -> key -> 'a
  val find_all : 'a t -> key -> 'a list
  val find_default : 'a t -> key ->  'a -> 'a
  val find_option : 'a t -> key -> 'a option
  val replace : 'a t -> key -> 'a -> unit
  val mem : 'a t -> key -> bool
  val iter : (key -> 'a -> unit) -> 'a t -> unit
  val for_all : (key -> 'a -> bool) -> 'a t -> bool
  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
  val exists : (key -> 'a -> bool) -> 'a t -> bool
  val map : (key -> 'b -> 'c) -> 'b t -> 'c t
  val map_inplace : (key -> 'a -> 'a) -> 'a t -> unit
  val filter : ('a -> bool) -> 'a t -> 'a t
  val filter_inplace : ('a -> bool) -> 'a t -> unit
  val filteri : (key -> 'a -> bool) -> 'a t -> 'a t
  val filteri_inplace : (key -> 'a -> bool) -> 'a t -> unit
  val filter_map : (key -> 'a -> 'b option) -> 'a t -> 'b t
  val filter_map_inplace : (key -> 'a -> 'a option) -> 'a t -> unit
  val modify : key -> ('a -> 'a) -> 'a t -> unit
  val modify_def : 'a -> key -> ('a -> 'a) -> 'a t -> unit
  val modify_opt : key -> ('a option -> 'a option) -> 'a t -> unit
  val merge : (key -> 'a option -> 'b option -> 'c option) ->
             'a t -> 'b t -> 'c t
  val merge_all : (key -> 'a list -> 'b list -> 'c list) ->
    'a t -> 'b t -> 'c t
  val stats : 'a t -> statistics
  val keys : 'a t -> key BatEnum.t
  val values : 'a t -> 'a BatEnum.t
  val enum : 'a t -> (key * 'a) BatEnum.t
  val to_list: 'a t -> (key * 'a) list
  val of_enum : (key * 'a) BatEnum.t -> 'a t
  val of_list : (key * 'a) list -> 'a t
  val print :  ?first:string -> ?last:string -> ?sep:string ->
    ('a BatInnerIO.output -> key -> unit) ->
    ('a BatInnerIO.output -> 'b -> unit) ->
    'a BatInnerIO.output -> 'b t -> unit

  (** Operations on {!Hashtbl} without exceptions.*)
  module Exceptionless :
  sig
    val find : 'a t -> key -> 'a option
    val modify : key -> ('a -> 'a) -> 'a t -> (unit, exn) BatPervasives.result
  end

  (** Infix operators over a {!BatHashtbl} *)
  module Infix :
  sig
    val (-->) : 'a t -> key -> 'a
    (** [tbl-->x] returns the current binding of [x] in [tbl],
          or raises [Not_found] if no such binding exists.
          Equivalent to [Hashtbl.find tbl x]*)

    val (<--) : 'a t -> key * 'a -> unit
      (** [tbl<--(x, y)] adds a binding of [x] to [y] in table [tbl].
              Previous bindings for [x] are not removed, but simply
              hidden. That is, after performing {!Hashtbl.remove}[ tbl x],
              the previous binding for [x], if any, is restored.
              (Same behavior as with association lists.)
              Equivalent to [Hashtbl.add tbl x y]*)
  end

  (** Operations on {!Hashtbl} with labels.

      This module overrides a number of functions of {!Hashtbl} by
      functions in which some arguments require labels. These labels are
      there to improve readability and safety and to let you change the
      order of arguments to functions. In every case, the behavior of the
      function is identical to that of the corresponding function of {!Hashtbl}.
  *)
  module Labels :
  sig
    val add : 'a t -> key:key -> data:'a -> unit
    val replace : 'a t -> key:key -> data:'a -> unit
    val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit
    val for_all : f:(key:key -> data:'a -> bool) -> 'a t -> bool
    val map : f:(key:key -> data:'a -> 'b) -> 'a t -> 'b t
    val map_inplace : f:(key:key -> data:'a -> 'a) -> 'a t -> unit
    val filter : f:('a -> bool) -> 'a t -> 'a t
    val filter_inplace : f:('a -> bool) -> 'a t -> unit
    val filteri : f:(key:key -> data:'a -> bool) -> 'a t -> 'a t
    val filteri_inplace : f:(key:key -> data:'a -> bool) -> 'a t -> unit
    val filter_map : f:(key:key -> data:'a -> 'b option) -> 'a t -> 'b t
    val filter_map_inplace : f:(key:key -> data:'a -> 'a option) -> 'a t -> unit
    val fold : f:(key:key -> data:'a -> 'b -> 'b) -> 'a t -> init:'b -> 'b
    val exists : f:(key:key -> data:'a -> bool) -> 'a t -> bool
    val modify : key:key -> f:('a -> 'a) -> 'a t -> unit
    val modify_def : default:'a -> key:key -> f:('a -> 'a) -> 'a t -> unit
    val modify_opt : key:key -> f:('a option -> 'a option) -> 'a t -> unit
    val merge : f:(key -> 'a option -> 'b option -> 'c option) ->
               left:'a t -> right:'b t -> 'c t
    val merge_all : f:(key -> 'a list -> 'b list -> 'c list) ->
                    left:'a t -> right:'b t -> 'c t
  end

end


module Make(H: HashedType): (S with type key = H.t) =
struct
  include Hashtbl.Make(H)
  external to_hash : 'a t -> (key, 'a) Hashtbl.t = "%identity"
  external of_hash : (key, 'a) Hashtbl.t -> 'a t = "%identity"
  (* Warning: these two externals are unsafe, as they forget about the user-provided
     HashtedType implementation. They are used to avoid code duplication for functions
     that do *not* use the hashing function, but only traverse the bucket structure. *)

  (*      type key = H.t
          type 'a hashtbl = (key, 'a) t
          type 'a t = 'a hashtbl
          let create = create
          let clear = clear
          let copy = copy

          let safehash key = (H.hash key) land max_int

          let add h key info =
        let h = h_conv h in
        let i = (safehash key) mod (Array.length h.data) in
        let bucket = Cons(key, info, h.data.(i)) in
          h.data.(i) <- bucket;
          h.size <- succ h.size;
          if h.size > Array.length h.data lsl 1 then resize safehash h

          let remove h key =
        let h = h_conv h in
        let rec remove_bucket = function
          Empty ->
            Empty
          | Cons(k, i, next) ->
            if H.equal k key
            then begin h.size <- pred h.size; next end
            else Cons(k, i, remove_bucket next) in
        let i = (safehash key) mod (Array.length h.data) in
          h.data.(i) <- remove_bucket h.data.(i)

          let rec find_rec key = function
          Empty ->
          raise Not_found
        | Cons(k, d, rest) ->
          if H.equal key k then d else find_rec key rest

          let find h key =
        let h = h_conv h in
        match h.data.((safehash key) mod (Array.length h.data)) with
          Empty -> raise Not_found
          | Cons(k1, d1, rest1) ->
            if H.equal key k1 then d1 else
            match rest1 with
                Empty -> raise Not_found
              | Cons(k2, d2, rest2) ->
                  if H.equal key k2 then d2 else
                match rest2 with
                    Empty -> raise Not_found
                  | Cons(k3, d3, rest3) ->
                      if H.equal key k3 then d3 else find_rec key rest3

          let find_all h key =
        let rec find_in_bucket = function
          Empty ->
            []
          | Cons(k, d, rest) ->
            if H.equal k key
            then d :: find_in_bucket rest
            else find_in_bucket rest in
          find_in_bucket h.data.((safehash key) mod (Array.length h.data))

          let replace h key info =
        let rec replace_bucket = function
          Empty ->
            raise Not_found
          | Cons(k, i, next) ->
            if H.equal k key
            then Cons(k, info, next)
            else Cons(k, i, replace_bucket next) in
        let i = (safehash key) mod (Array.length h.data) in
        let l = h.data.(i) in
          try
          h.data.(i) <- replace_bucket l
          with Not_found ->
          h.data.(i) <- Cons(key, info, l);
          h.size <- succ h.size;
          if h.size > Array.length h.data lsl 1 then resize safehash h

          let mem h key =
        let rec mem_in_bucket = function
          | Empty ->
            false
          | Cons(k, d, rest) ->
            H.equal k key || mem_in_bucket rest in
          mem_in_bucket h.data.((safehash key) mod (Array.length h.data))*)

  let key_index h key =
    (H.hash key) land (Array.length (h_conv (to_hash h)).data - 1)

  let iter = iter
  let for_all p ht = for_all p (to_hash ht)
  let fold = fold
  let length = length
  let stats = stats

  (* the functions here do not hash values, they only traverse the buckets *)
  let enum h = enum (to_hash h)
  let to_list h = to_list (to_hash h)
  let values  h = values (to_hash h)
  let keys h = keys (to_hash h)
  let map (f:key -> 'a -> 'b) h =
    of_hash (map f (to_hash h))
  let exists (f:key -> 'a -> bool) h = exists f (to_hash h)
  (* We can use polymorphic filteri since we do not use the key at all for inline ops *)
  let map_inplace (f:key -> 'a -> 'b) h = map_inplace f (to_hash h)
  let filteri_inplace f h = filteri_inplace f (to_hash h)
  let filter_inplace f h = filter_inplace f (to_hash h)
##V<4.3##  let filter_map_inplace f h = filter_map_inplace f (to_hash h)

  (* these functions do need to hash values, so we cannot use {to,of}_hash *)
  let of_enum e =
    let tbl = create 11 in
    BatEnum.iter (fun (k, v) -> add tbl k v) e;
    tbl

  let of_list li =
    let tbl = create 11 in
    List.iter (fun (k, v) -> add tbl k v) li;
    tbl


  let find_option h key =
    let hc = h_conv (to_hash h) in
    let rec loop = function
      | Empty -> None
      | Cons (k,v,next) ->
        if H.equal k key then Some v else loop next
    in
    let pos = key_index h key in
    loop (Array.unsafe_get hc.data pos)

  let find_default h key defval =
    let hc = h_conv (to_hash h) in
    let rec loop = function
      | Empty -> defval
      | Cons (k,v,next) ->
        if H.equal k key then v else loop next
    in
    let pos = key_index h key in
    loop (Array.unsafe_get hc.data pos)

  let remove_all h key =
    let hc = h_conv (to_hash h) in
    let rec loop = function
      | Empty -> Empty
      | Cons(k,v,next) ->
        if H.equal k key then begin
          hc.size <- pred hc.size;
          loop next
        end else
          Cons(k,v,loop next)
    in
    let pos = key_index h key in
    Array.unsafe_set hc.data pos (loop (Array.unsafe_get hc.data pos))

  let is_empty h = length h = 0

  let print ?first ?last ?sep print_k print_v out t =
    print ?first ?last ?sep print_k print_v out (to_hash t)

  let filteri f t =
    let result = create 16 in
    iter (fun k a -> if f k a then add result k a) t;
    result

  let filter f t = filteri (fun _k a -> f a) t

  let filter_map f t =
    let result = create 16 in
    iter (fun k a -> match f k a with
      | None   -> ()
      | Some v -> add result k v) t;
    result

  let modify_opt key f h =
    let hc = h_conv (to_hash h) in

    let rec loop = function
      (* Inserting an element might require a resize of the hash table.
         We rely on Hashtbl.add function to grow the hashtbl if needed
         instead of duplicating logic from the OCaml standard library. *)
      | Empty ->
        raise Hashtbl_key_not_found
      | Cons(k,v,next) ->
        if H.equal k key then
          match f (Some v) with
            | Some v -> Cons(key,v,next)
            | None ->
              hc.size <- pred hc.size;
              next
        else
          Cons(k,v,loop next)
    in
    try
      let pos = key_index h key in
      Array.unsafe_set hc.data pos (loop (Array.unsafe_get hc.data pos))
    with
    | Hashtbl_key_not_found ->
      begin match f None with
        | None -> ()
        | Some v ->
          (* Add the element to make sure the hashtbl is grown correctly if
             needed. *)
          add h key v
      end

  let modify key f h =
    let hc = h_conv (to_hash h) in
    let rec loop = function
      | Empty -> raise Not_found
      | Cons(k,v,next) ->
        if H.equal k key then (
          Cons(key,f v,next)
        ) else
          Cons(k,v,loop next)
    in
    let pos = key_index h key in
    Array.unsafe_set hc.data pos (loop (Array.unsafe_get hc.data pos))

  let modify_def v0 key f h =
    let f' = function
      | None -> Some (f v0)
      | Some v -> Some (f v)
    in
    modify_opt key f' h

  let merge f a b =
    let res = create (max (length a) (length b)) in
    let may_add_res k v1 v2 =
      BatOption.may (add res k) (f k v1 v2) in
    iter (fun k v1 ->
        may_add_res k (Some v1) (find_option b k)
      ) a ;
    iter (fun k v2 ->
        if not (mem a k) then
          may_add_res k None (Some v2)
    ) b ;
    res

  let merge_all f a b =
    let res = create (max (length a) (length b)) in
    let may_add_res k v1 v2 =
      List.iter (add res k) (List.rev (f k v1 v2)) in
    iter (fun k _ ->
      let l1 = find_all a k
      and l2 = find_all b k in
      may_add_res k l1 l2
    ) a ;
    iter (fun k _ ->
      match find_all a k with
      | [] ->
          let l2 = find_all b k in
          may_add_res k [] l2
      | _ -> () (* done above *)
    ) b ;
    res


  module Labels =
  struct
    let label f = fun key data -> f ~key ~data
    let add e ~key ~data = add e key data
    let replace e ~key ~data = replace e key data
    let iter ~f e = iter (label f) e
    let for_all ~f e = for_all (label f) e
    let map ~f e = map (label f) e
    let map_inplace ~f e = map_inplace (label f) e
    let filter ~f e = filter f e
    let filter_inplace ~f e = filter_inplace f e
    let filteri ~f e = filteri (label f) e
    let filteri_inplace ~f e = filteri_inplace (label f) e
    let filter_map ~f e = filter_map (label f) e
    let filter_map_inplace ~f e = filter_map_inplace (label f) e
    let fold ~f e ~init = fold (label f) e init
    let exists ~f e = exists (label f) e
    let modify ~key ~f = modify key f
    let modify_def ~default ~key ~f = modify_def default key f
    let modify_opt ~key ~f = modify_opt key f
    let merge ~f ~left ~right = merge f left right
    let merge_all ~f ~left ~right = merge_all f left right
  end

  module Exceptionless =
  struct
    let find = find_option
    let modify k f = BatPervasives.wrap (modify k f)
  end

  module Infix =
  struct
    let (-->) h k = find h k
    let (<--) h (k,v) = add h k v
  end
end

module Cap =
struct
  type ('a, 'b, 'c) t = ('a, 'b) Hashtbl.t constraint 'c = [< `Read | `Write ]

  let create = create
  external of_table  : ('a, 'b) Hashtbl.t -> ('a, 'b, _ ) t = "%identity"
  external to_table  : ('a, 'b, [`Read | `Write]) t -> ('a, 'b) Hashtbl.t = "%identity"
  external read_only :  ('a, 'b, [>`Read])  t -> ('a, 'b, [`Read])  t = "%identity"
  external write_only : ('a, 'b, [>`Write]) t -> ('a, 'b, [`Write]) t = "%identity"

  let length      = length
  let is_empty    = is_empty
  let add         = add
  let remove      = remove
  let remove_all  = remove_all
  let replace     = replace
  let copy        = copy
  let clear       = clear
  let find        = find
  let find_all    = find_all
  let find_default= find_default
  let find_option = find_option
  let exists      = exists
  let mem         = mem
  let iter        = iter
  let for_all     = for_all
  let fold        = fold
  let map         = map
  let map_inplace = map_inplace
  let filter      = filter
  let filter_inplace = filter_inplace
  let filteri     = filteri
  let filteri_inplace = filteri_inplace
  let filter_map  = filter_map
  let filter_map_inplace = filter_map_inplace
  let modify      = modify
  let modify_def  = modify_def
  let modify_opt  = modify_opt
  let stats       = stats
  let keys        = keys
  let values      = values
  let enum        = enum
  let to_list     = to_list
  let of_enum     = of_enum
  let of_list     = of_list
  let print       = print
  let filter      = filter
  let filteri     = filteri
  let filter_map  = filter_map
  let merge       = merge
  let merge_all   = merge_all
  module Labels =
  struct
    let label f = fun key data -> f ~key ~data
    let add e ~key ~data = add e key data
    let replace e ~key ~data = replace e key data
    let iter ~f e = iter (label f) e
    let for_all ~f e = for_all (label f) e
    let map ~f e = map (label f) e
    let map_inplace ~f e = map_inplace (label f) e
    let filter ~f e = filter f e
    let filter_inplace ~f e = filter_inplace f e
    let filteri ~f e = filteri (label f) e
    let filteri_inplace ~f e = filteri_inplace (label f) e
    let filter_map ~f e = filter_map (label f) e
    let filter_map_inplace ~f e = filter_map_inplace (label f) e
    let fold ~f e ~init = fold (label f) e init
    let exists ~f e = exists (label f) e
    let modify ~key ~f = modify key f
    let modify_def ~default ~key ~f = modify_def default key f
    let modify_opt ~key ~f = modify_opt key f
    let merge ~f ~left ~right = merge f left right
    let merge_all ~f ~left ~right = merge_all f left right
  end

  module Exceptionless =
  struct
    let find = find_option
    let modify k f = BatPervasives.wrap (modify k f)
  end
end