CCache.{size,iter}

core/CCCache.ml

@@ -23,7 +23,7 @@ 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 Memoization caches} *)
+(** {1 Caches} *)
 
 type 'a equal = 'a -> 'a -> bool
 type 'a hash = 'a -> int
@@ -36,6 +36,8 @@ let default_hash_ = Hashtbl.hash
 type ('a,'b) t = {
   set : 'a -> 'b -> unit;
   get : 'a -> 'b;  (* or raise Not_found *)
+  size : unit -> int;
+  iter : ('a -> 'b -> unit) -> unit;
   clear : unit -> unit;
 }
 
@@ -53,10 +55,16 @@ let with_cache_rec c f =
   let rec f' x = with_cache c (f f') x in
   f'
 
+let size c = c.size ()
+
+let iter c f = c.iter f
+
 let dummy = {
   set=(fun _ _ -> ());
   get=(fun _ -> raise Not_found);
   clear=(fun _ -> ());
+  size=(fun _ -> 0);
+  iter=(fun _ -> ());
 }
 
 module Linear = struct
@@ -91,6 +99,14 @@ module Linear = struct
   let set c x y =
     c.arr.(c.i) <- Pair (x,y);
     c.i <- (c.i + 1) mod Array.length c.arr
+
+  let iter c f =
+    Array.iter (function Pair (x,y) -> f x y | Empty -> ()) c.arr
+
+  let size c () =
+    let r = ref 0 in
+    iter c (fun _ _ -> incr r);
+    !r
 end
 
 let linear ?(eq=default_eq_) size =
@@ -99,6 +115,8 @@ let linear ?(eq=default_eq_) size =
   { get=(fun x -> Linear.get arr x);
     set=(fun x y -> Linear.set arr x y);
     clear=(fun () -> Linear.clear arr);
+    size=Linear.size arr;
+    iter=Linear.iter arr;
   }
 
 module Replacing = struct
@@ -110,13 +128,15 @@ module Replacing = struct
     eq : 'a equal;
     hash : 'a hash;
     arr : ('a,'b) bucket array;
+    mutable c_size : int;
   }
 
   let make eq hash size =
     assert (size>0);
-    {arr=Array.make size Empty; eq; hash }
+    {arr=Array.make size Empty; eq; hash; c_size=0 }
 
   let clear c =
+    c.c_size <- 0;
     Array.fill c.arr 0 (Array.length c.arr) Empty
 
   let get c x =
@@ -128,7 +148,13 @@ module Replacing = struct
 
   let set c x y =
     let i = c.hash x mod Array.length c.arr in
+    if c.arr.(i) = Empty then c.c_size <- c.c_size + 1;
     c.arr.(i) <- Pair (x,y)
+
+  let iter c f =
+    Array.iter (function Empty -> () | Pair (x,y) -> f x y) c.arr
+
+  let size c () = c.c_size
 end
 
 let replacing ?(eq=default_eq_) ?(hash=default_hash_) size =
@@ -136,6 +162,8 @@ let replacing ?(eq=default_eq_) ?(hash=default_hash_) size =
   { get=(fun x -> Replacing.get c x);
     set=(fun x y -> Replacing.set c x y);
     clear=(fun () -> Replacing.clear c);
+    size=Replacing.size c;
+    iter=Replacing.iter c;
   }
 
 module type HASH = sig
@@ -173,10 +201,6 @@ module LRU(X:HASH) = struct
     c.first <- None;
     ()
 
-  let get_opt = function
-    | None -> assert false
-    | Some x -> x
-
   (* take first from queue *)
   let take_ c =
     match c.first with
@@ -248,6 +272,11 @@ module LRU(X:HASH) = struct
     if len = c.size
       then replace_ c x y
       else insert_ c x y
+
+  let size c () = H.length c.table
+
+  let iter c f =
+    H.iter (fun x node -> f x node.value) c.table
 end
 
 let lru (type a) ?(eq=default_eq_) ?(hash=default_hash_) size =
@@ -260,15 +289,13 @@ let lru (type a) ?(eq=default_eq_) ?(hash=default_hash_) size =
   { get=(fun x -> L.get c x);
     set=(fun x y -> L.set c x y);
     clear=(fun () -> L.clear c);
+    size=L.size c;
+    iter=L.iter c;
   }
 
 module UNBOUNDED(X:HASH) = struct
-  type key = X.t
-
   module H = Hashtbl.Make(X)
 
-  type 'a t = 'a H.t
-
   let make size =
     assert (size > 0);
     H.create size
@@ -278,6 +305,10 @@ module UNBOUNDED(X:HASH) = struct
   let get c x = H.find c x
 
   let set c x y = H.replace c x y
+  
+  let size c () = H.length c
+
+  let iter c f = H.iter f c
 end
 
 let unbounded (type a) ?(eq=default_eq_) ?(hash=default_hash_) size =
@@ -290,4 +321,6 @@ let unbounded (type a) ?(eq=default_eq_) ?(hash=default_hash_) size =
   { get=(fun x -> C.get c x);
     set=(fun x y -> C.set c x y);
     clear=(fun () -> C.clear c);
+    iter=C.iter c;
+    size=C.size c;
   }

core/CCCache.mli

@@ -23,7 +23,11 @@ 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 Memoization caches} *)
+(** {1 Caches}
+
+Particularly useful for memoization. See {!with_cache} and {!with_cache_rec}
+for more details.
+@since NEXT_RELEASE *)
 
 type 'a equal = 'a -> 'a -> bool
 type 'a hash = 'a -> int
@@ -72,6 +76,13 @@ fib 70;;
 ]}
 *)
 
+val size : (_,_) t -> int
+(** Size of the cache (number of entries). At most linear in the number
+    of entries. *)
+
+val iter : ('a,'b) t -> ('a -> 'b -> unit) -> unit
+(** Iterate on cached values. Should yield [size cache] pairs. *)
+
 val dummy : ('a,'b) t
 (** dummy cache, never stores any value *)
 
@@ -92,42 +103,9 @@ val replacing : ?eq:'a equal -> ?hash:'a hash ->
 val lru : ?eq:'a equal -> ?hash:'a hash ->
           int -> ('a,'b) t
 (** LRU cache of the given size ("Least Recently Used": keys that have not been
-    used recently are deleted first). Never grows wider. *)
+    used recently are deleted first). Never grows wider than the given size. *)
 
 val unbounded : ?eq:'a equal -> ?hash:'a hash ->
                 int -> ('a,'b) t
 (** Unbounded cache, backed by a Hash table. Will grow forever
     unless {!clear} is called manually. *)
-
-(** {2 Binary Caches}
-TODO
-
-module C2 : sig
-  type ('a, 'b, 'c) t
-
-  val clear : (_,_,_) t -> unit
-
-  val with_cache : ('a, 'b, 'c) t -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c
-
-  val with_cache_rec : ('a,'b,'c) t ->
-                       (('a -> 'b -> 'c) -> 'a -> 'b -> 'c) ->
-                       'a -> 'b -> 'c
-
-  val dummy : ('a,'b,'c) t
-
-  val linear : ?eq1:('a -> 'a -> bool) -> ?eq2:('b -> 'b -> bool) ->
-               int -> ('a, 'b, 'c) t
-
-  val replacing : ?eq1:('a -> 'a -> bool) -> ?hash1:('a -> int) ->
-                  ?eq2:('b -> 'b -> bool) -> ?hash2:('b -> int) ->
-                  int -> ('a,'b,'c) t
-
-  val lru : ?eq1:('a -> 'a -> bool) -> ?hash1:('a -> int) ->
-            ?eq2:('b -> 'b -> bool) -> ?hash2:('b -> int) ->
-            int -> ('a,'b,'c) t
-
-  val unbounded : ?eq1:('a -> 'a -> bool) -> ?hash1:('a -> int) ->
-                  ?eq2:('b -> 'b -> bool) -> ?hash2:('b -> int) ->
-                  int -> ('a,'b,'c) t
-end
-*)