Revision d8f4b9d21f954c3fa150d8ad8f715375e15ef532 authored by KOBAYASHI Kazuhiro on 20 April 2023, 08:01:02 UTC, committed by Marge Bot on 13 June 2023, 11:56:25 UTC
1 parent 98fbc20
lazy_map.ml
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2022 Trili Tech <contact@trili.tech> *)
(* *)
(* 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 type KeyS = sig
include Map.OrderedType
val to_string : t -> string
end
module type S = sig
type key
type 'a producer = key -> 'a Lwt.t
module Map : Map.S with type key = key
type 'a t
val origin : 'a t -> Tezos_tree_encoding.wrapped_tree option
val string_of_key : key -> string
val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
val to_string : ('a -> string) -> 'a t -> string
val create :
?values:'a Map.t ->
?produce_value:'a producer ->
?origin:Tezos_tree_encoding.wrapped_tree ->
unit ->
'a t
val get : key -> 'a t -> 'a Lwt.t
val set : key -> 'a -> 'a t -> 'a t
val remove : key -> 'a t -> 'a t
val dup : 'a t -> 'a t
val loaded_bindings : 'a t -> (key * 'a option) list
end
exception UnexpectedAccess
module Make (Key : KeyS) : S with type key = Key.t = struct
module Map = Map.Make (Key)
type key = Key.t
type 'a producer = key -> 'a Lwt.t
type 'a t = {
origin : Tezos_tree_encoding.wrapped_tree option;
produce_value : 'a producer;
mutable values : 'a option Map.t;
}
let origin {origin; _} = origin
let string_of_key = Key.to_string
let pp pp_value =
let pp_values fmt values =
Map.bindings values
|> Format.fprintf
fmt
"@[<hv>%a@]"
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ")
(fun ppf (k, v) ->
Format.fprintf
ppf
"%s => %a"
(Key.to_string k)
(Format.pp_print_option pp_value)
v))
in
fun fmt map ->
Format.fprintf
fmt
"@[<hv 2>{ values = @[<hv 2>[ %a ]@] }@]"
pp_values
map.values
let to_string show_value map =
let pp_value fmt value = Format.pp_print_string fmt (show_value value) in
Format.asprintf "%a" (pp pp_value) map
let def_produce_value _ = raise UnexpectedAccess
let create ?(values = Map.empty) ?(produce_value = def_produce_value) ?origin
() =
let values = Map.map Option.some values in
{produce_value; values; origin}
let get key map =
let open Lwt.Syntax in
match Map.find_opt key map.values with
| None ->
(* Need to create the missing key-value association. *)
let+ value = map.produce_value key in
map.values <- Map.add key (Some value) map.values ;
value
| Some None -> (* The key was removed *) raise UnexpectedAccess
| Some (Some value) -> Lwt.return value
let set key value map =
{map with values = Map.add key (Some value) map.values}
let remove key map = {map with values = Map.add key None map.values}
let dup {origin; produce_value; values} = {origin; produce_value; values}
let loaded_bindings m = Map.bindings m.values
end
module LwtIntMap = Make (Int)
module LwtInt32Map = Make (Int32)
module LwtInt64Map = Make (Int64)
module Mutable = struct
module type S = sig
type key
module Map : S with type key = key
type 'a t
val of_immutable : 'a Map.t -> 'a t
val create :
?values:'a Map.Map.t ->
?produce_value:'a Map.producer ->
?origin:Tezos_tree_encoding.wrapped_tree ->
unit ->
'a t
val get : key -> 'a t -> 'a Lwt.t
val set : key -> 'a -> 'a t -> unit
val remove : key -> 'a t -> unit
val snapshot : 'a t -> 'a Map.t
end
module Make (Key : KeyS) : S with type key = Key.t = struct
module Map = Make (Key)
type key = Map.key
type 'a t = 'a Map.t ref
let of_immutable = ref
let create ?values ?produce_value ?origin unit =
of_immutable (Map.create ?values ?produce_value ?origin unit)
let get key map_ref = Map.get key !map_ref
let set key value map_ref = map_ref := Map.set key value !map_ref
let remove key map_ref = map_ref := Map.remove key !map_ref
let snapshot map_ref = !map_ref
end
module LwtIntMap = Make (Int)
module LwtInt32Map = Make (Int32)
module LwtInt64Map = Make (Int64)
end
Computing file changes ...