Source file sized.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2022 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module EmptyMap (H: Hashtbl.HashedType)
: Sigs.MAP with type key = H.t
= struct
   type key = H.t
   type 'a t = unit
   let create _ = ()
   let replace () _ _ = ()
   let fold _ () acc = acc
   let fold_oldest_first _ () acc = acc
   let find_opt () _ = None
   let remove () _ = ()
   let length () = 0
   let capacity () = 0
   let clear () = ()
   module H = H
end

module SingletonMap (H: Hashtbl.HashedType)
: Sigs.MAP with type key = H.t
= struct
   type key = H.t
   type 'a t = (key * 'a) option ref
   let create _ = ref None
   let replace r k v = r := Some (k, v)
   let fold f r acc = match !r with | None -> acc | Some (k, v) -> f k v acc
   let fold_oldest_first f r acc = match !r with | None -> acc | Some (k, v) -> f k v acc
   let find_opt r k =
      match !r with
      | None -> None
      | Some (kk, v) -> if H.equal k kk then Some v else None
   let remove r k =
      match !r with
      | None -> ()
      | Some (kk, _) -> if H.equal k kk then r := None
   let length r = match !r with None -> 0 | Some _ -> 1
   let capacity _ = 1
   let clear r = r := None
   module H = H
end

module EmptySet (H: Hashtbl.HashedType)
: Sigs.SET with type elt = H.t
= struct
   type elt = H.t
   type t = unit
   let create _ = ()
   let add () _ = ()
   let fold _ () acc = acc
   let fold_oldest_first _ () acc = acc
   let mem () _ = false
   let remove () _ = ()
   let length () = 0
   let capacity () = 0
   let clear () = ()
end

module SingletonSet (H: Hashtbl.HashedType)
: Sigs.SET with type elt = H.t
= struct
   type elt = H.t
   type t = elt option ref
   let create _ = ref None
   let add r elt = r := Some elt
   let fold f r acc = match !r with | None -> acc | Some e -> f e acc
   let fold_oldest_first f r acc = match !r with | None -> acc | Some e -> f e acc
   let mem r elt = match !r with | None -> false | Some e -> H.equal e elt
   let remove r elt =
      match !r with
      | None -> ()
      | Some e -> if H.equal e elt then r := None
   let length r = match !r with None -> 0 | Some _ -> 1
   let capacity _ = 1
   let clear r = r := None
end