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 EmptyTransferMap
  (H: Hashtbl.HashedType)
: Sigs.TRANSFER with type key = H.t
= struct
   type key = H.t
   type 'resource t = (key -> 'resource -> unit)
   let create destroy _ = destroy
   let put destroy k r =
     (* [put] transfers ownership, the cache is responsible for cleaning up, no
        space in the cache, destroy now *)
     destroy k r
   let take _ _ = None
   let take_all _ = []
   let take_some _ _ = []
   let borrow _ _ _ = None
   let fold _ _ acc = acc
   let fold_oldest_first _ _ acc = acc
   let remove _ _ = ()
   let filter _ _ = ()
   let clear _ = ()
   let length _ = 0
   let capacity _ = 0
   module H = H
end

module SingletonTransferMap
  (H: Hashtbl.HashedType)
: Sigs.TRANSFER with type key = H.t
= struct
   type key = H.t
   type 'resource t = {
     mutable content: (key * 'resource) option;
     destroy: (key -> 'resource -> unit);
   }
   let create destroy _ = { content = None; destroy }
   let put r k v =
     begin match r.content with
     | None -> ()
     | Some (k, v) ->
         (* NOTE: The user *shouldn't* put resources that it doesn't have
            ownership of. Thus they *shouldn't* put the the resource that's
            already in the cache. Thus this [v] *shouldn't* be the same as the
            function's parameter. *)
         r.destroy k v
     end;
     r.content <- Some (k, v)
   let take r k =
      match r.content with
      | None -> None
      | Some (kk, vv) ->
          if H.equal k kk then (r.content <- None; Some vv) else None
   let take_all r =
     match r.content with
     | None -> []
     | Some kv -> r.content <- None; [kv]
   let take_some r f =
     match r.content with
     | None -> []
     | Some ((k, v) as kv) ->
         if f k v then (r.content <- None; [kv]) else []
   let borrow r k f =
      match r.content with
      | None -> None
      | Some (kk, vv) ->
          if H.equal k kk then Some (f vv) else None
   let fold f r acc = match r.content with | None -> acc | Some (k, v) -> f k v acc
   let fold_oldest_first f r acc = match r.content with | None -> acc | Some (k, v) -> f k v acc
   let remove r k =
      match r.content with
      | None -> ()
      | Some (kk, rr) ->
          if H.equal k kk then (r.destroy kk rr; r.content <- None)
   let filter r f =
      match r.content with
      | None -> ()
      | Some (k, v) ->
          if not (f k v) then (r.destroy k v; r.content <- None)
   let clear r =
     match r.content with
     | None -> ()
     | Some (k, v) -> r.destroy k v; r.content <- None
   let length r = match r.content with None -> 0 | Some _ -> 1
   let capacity _ = 1
   module H = H
end

module EmptyBorrowMap
  (H: Hashtbl.HashedType)
: Sigs.BORROW with type key = H.t
= struct
   type key = H.t
   type 'resource t = (key -> 'resource -> unit)
   let create destroy _ = destroy
   let borrow_or_make destroy k make f =
     let resource = make k in
     let result = f resource in
     destroy k resource;
     result
   let borrow _ _ _ = None
   let fold _ _ acc = acc
   let fold_oldest_first _ _ acc = acc
   let remove _ _ = ()
   let filter _ _ = ()
   let clear _ = ()
   let length _ = 0
   let capacity _ = 0
   module H = H
end

module SingletonBorrowMap
  (H: Hashtbl.HashedType)
: Sigs.BORROW with type key = H.t
= struct
   type key = H.t
   type 'resource t = {
     mutable content: (key * 'resource) option;
     destroy: (key -> 'resource -> unit);
   }
   let create destroy _ = { content = None; destroy; }
   let borrow_or_make r k make f =
     begin match r.content with
     | None ->
         let resource = make k in
         let result = f resource in
         r.content <- Some (k, resource);
         result
     | Some (kk, v) ->
         if H.equal k kk then
           f v
          else begin
           r.destroy k v;
           let resource = make k in
           r.content <- Some (k, resource);
           let result = f resource in
           result
          end
     end
   let borrow r k f =
      match r.content with
      | None -> None
      | Some (kk, vv) ->
          if H.equal k kk then Some (f vv) else None
   let fold f r acc = match r.content with | None -> acc | Some (k, v) -> f k v acc
   let fold_oldest_first f r acc = match r.content with | None -> acc | Some (k, v) -> f k v acc
   let remove r k =
      match r.content with
      | None -> ()
      | Some (kk, rr) ->
          if H.equal k kk then (r.destroy kk rr; r.content <- None)
   let filter r f =
      match r.content with
      | None -> ()
      | Some (k, v) ->
          if not (f k v) then (r.destroy k v; r.content <- None)
   let clear r =
     match r.content with
     | None -> ()
     | Some (k, v) -> r.destroy k v; r.content <- None
   let length r = match r.content with None -> 0 | Some _ -> 1
   let capacity _ = 1
   module H = H
end