Source file functors.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.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Main functor that is exported to the outside *)
module Map
  (Collection: Ringo.COLLECTION)
  (Tabler: Sigs.TABLER)
  (H: Hashtbl.HashedType)
: Sigs.MAP with type key = H.t
= struct

  module H = H

  module Table = Tabler(H)

  type key = H.t

  type 'a t = {
     table: (key * 'a) Collection.node Table.t;
     collection: (key * 'a) Collection.t;
  }

  let create n = {table = Table.create n; collection = Collection.create n}

  let replace {collection; table} k v =
    begin match Table.find_opt table k with
       | Some node ->
           (* NOTE: in some collections, [remove] is a noop leading to sloppy counting *)
           Collection.remove collection node;
       | None -> ()
    end ;
    match Collection.add_and_return_erased collection (k, v) with
    | node, Some (kerased, _verased) ->
        Table.remove table kerased;
        Table.replace table k node
    | node, None ->
        Table.replace table k node

  let find_opt {table; collection} k =
    match Table.find_opt table k with
    | None -> None
    | Some node ->
        Collection.promote collection node;
        let (_, v) = Collection.data node in
        Some v

  let fold f {collection; _} init =
    let f acc kv =
      let (k, v) = Collection.data kv in
      f k v acc in
    Collection.fold collection ~init ~f

  let fold_oldest_first f {collection; _} init =
    let f acc kv =
      let (k, v) = Collection.data kv in
      f k v acc in
    Collection.fold_oldest_first collection ~init ~f

  let remove {table; collection} k =
    match Table.find_opt table k with
    | None -> ()
    | Some node ->
       (* NOTE: in some collections, [remove] is a noop leading to sloppy counting *)
       Collection.remove collection node;
       Table.remove table k

  let length {table; _} = Table.length table

  let capacity {collection; _} = Collection.capacity collection

  let clear {table; collection} =
    Table.clear table;
    Collection.clear collection

end


module Set
  (Collection: Ringo.COLLECTION)
  (Tabler: Sigs.TABLER)
  (H: Hashtbl.HashedType)
: Sigs.SET with type elt = H.t
= struct

  module Table = Tabler(H)

  type elt = H.t

  type t = {
     table: elt Collection.node Table.t;
     collection: elt Collection.t
  }

  let create n = {table = Table.create n; collection = Collection.create n}

  let add {collection; table} v =
    match Table.find_opt table v with
    | Some node ->
        Collection.promote_write collection node
    | None ->
        match Collection.add_and_return_erased collection v with
        | node, Some erased ->
            Table.remove table erased;
            Table.replace table v node
        | node, None ->
            Table.replace table v node

  let mem {table; collection} v =
    match Table.find_opt table v with
    | None -> false
    | Some node ->
        Collection.promote_read collection node;
        true

  let fold f {collection; _} init =
    let f acc v = f (Collection.data v) acc in
    Collection.fold collection ~init ~f

  let fold_oldest_first f {collection; _} init =
    let f acc v = f (Collection.data v) acc in
    Collection.fold_oldest_first collection ~init ~f

  let remove {table; collection} v =
    match Table.find_opt table v with
    | None -> ()
    | Some node ->
        Collection.remove collection node;
        Table.remove table v

  let length {table; _} = Table.length table

  let capacity {collection; _} = Collection.capacity collection

  let clear {table; collection} =
    Table.clear table;
    Collection.clear collection

end