lazy_storage_kind.ml
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2020 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 type TEMP_ID = sig
type t
val equal : t -> t -> bool
val init : t
val next : t -> t
end
module type ID = sig
type t
val compare : t -> t -> int
val encoding : t Data_encoding.t
val rpc_arg : t RPC_arg.arg
val init : t
(** In the protocol, to be used in parse_data only *)
val parse_z : Z.t -> t
(** In the protocol, to be used in unparse_data only *)
val unparse_to_z : t -> Z.t
val next : t -> t
val is_temp : t -> bool
val of_legacy_USE_ONLY_IN_Legacy_big_map_diff : Z.t -> t
val to_legacy_USE_ONLY_IN_Legacy_big_map_diff : t -> Z.t
include Path_encoding.S with type t := t
end
module type Title = sig
val title : string
end
module type TitleWithId = sig
val title : string
module Id : ID
module Temp_id : TEMP_ID with type t = private Id.t
module IdSet : Set.S with type elt = Id.t
end
module MakeId (Title : Title) : TitleWithId = struct
let title = Title.title
let title_words = String.map (function '_' -> ' ' | c -> c) title
let rpc_arg_error = Format.sprintf "Cannot parse %s id" title_words
let description = Format.sprintf "A %s identifier" title_words
let name = title ^ "_id"
let encoding_title = String.capitalize_ascii title_words ^ " identifier"
module Id = struct
type t = Z.t
let compare = Z.compare
let encoding =
Data_encoding.def name ~title:encoding_title ~description Data_encoding.z
let rpc_arg =
let construct = Z.to_string in
let destruct hash =
Result.catch_f (fun () -> Z.of_string hash) (fun _ -> rpc_arg_error)
in
RPC_arg.make ~descr:description ~name ~construct ~destruct ()
let init = Z.zero
let parse_z (z : Z.t) : t = z
let unparse_to_z (z : t) : Z.t = z
let next = Z.succ
let of_legacy_USE_ONLY_IN_Legacy_big_map_diff (z : Z.t) : t = z
let to_legacy_USE_ONLY_IN_Legacy_big_map_diff (z : t) : Z.t = z
let is_temp z = Compare.Z.(z < Z.zero)
let path_length = 1
let to_path z l = Z.to_string z :: l
let of_path = function
| [] | _ :: _ :: _ -> None
| [z] -> Some (Z.of_string z)
end
module Temp_id = struct
type t = Id.t
let equal = Z.equal
let init = Z.of_int ~-1
let next z = Z.sub z Z.one
end
module IdSet = Set.Make (Id)
end
module Big_map = struct
include MakeId (struct
let title = "big_map"
end)
type alloc = {key_type : Script_repr.expr; value_type : Script_repr.expr}
type update = {
key : Script_repr.expr;
(** The key is ignored by [apply_update] but is shown in the receipt,
as specified in [print_big_map_diff]. *)
key_hash : Script_expr_hash.t;
value : Script_repr.expr option;
}
type updates = update list
let alloc_encoding =
let open Data_encoding in
conv
(fun {key_type; value_type} -> (key_type, value_type))
(fun (key_type, value_type) -> {key_type; value_type})
(obj2
(req "key_type" Script_repr.expr_encoding)
(req "value_type" Script_repr.expr_encoding))
let update_encoding =
let open Data_encoding in
conv
(fun {key_hash; key; value} -> (key_hash, key, value))
(fun (key_hash, key, value) -> {key_hash; key; value})
(obj3
(req "key_hash" Script_expr_hash.encoding)
(req "key" Script_repr.expr_encoding)
(opt "value" Script_repr.expr_encoding))
let updates_encoding = Data_encoding.list update_encoding
end
module Sapling_state = struct
include MakeId (struct
let title = "sapling_state"
end)
type alloc = {memo_size : Sapling_repr.Memo_size.t}
type updates = Sapling_repr.diff
let alloc_encoding =
let open Data_encoding in
conv
(fun {memo_size} -> memo_size)
(fun memo_size -> {memo_size})
(obj1 (req "memo_size" Sapling_repr.Memo_size.encoding))
let updates_encoding = Sapling_repr.diff_encoding
end
(*
When adding cases to this type, grep for [new lazy storage kind] in the code
for locations to update.
It must be:
- the value [all] right below,
- modules [Temp_ids], [IdSet] below,
- the rest should be guided by type errors.
*)
type ('id, 'alloc, 'updates) t =
| Big_map : (Big_map.Id.t, Big_map.alloc, Big_map.updates) t
| Sapling_state
: (Sapling_state.Id.t, Sapling_state.alloc, Sapling_state.updates) t
type ex = Ex_Kind : (_, _, _) t -> ex
(* /!\ Don't forget to add new lazy storage kinds here. /!\ *)
let all = [(0, Ex_Kind Big_map); (1, Ex_Kind Sapling_state)]
type (_, _) cmp = Eq : ('a, 'a) cmp | Neq
let equal :
type i1 a1 u1 i2 a2 u2.
(i1, a1, u1) t -> (i2, a2, u2) t -> (i1 * a1 * u1, i2 * a2 * u2) cmp =
fun k1 k2 ->
match (k1, k2) with
| Big_map, Big_map -> Eq
| Sapling_state, Sapling_state -> Eq
| Big_map, _ -> Neq
| _, Big_map -> Neq
type ('i, 'a, 'u) kind = ('i, 'a, 'u) t
module Temp_ids = struct
type t = {
big_map : Big_map.Temp_id.t;
sapling_state : Sapling_state.Temp_id.t;
}
let init =
{big_map = Big_map.Temp_id.init; sapling_state = Sapling_state.Temp_id.init}
let fresh : type i a u. (i, a, u) kind -> t -> t * i =
fun kind temp_ids ->
match kind with
| Big_map ->
let big_map = Big_map.Temp_id.next temp_ids.big_map in
({temp_ids with big_map}, (temp_ids.big_map :> Big_map.Id.t))
| Sapling_state ->
let sapling_state = Sapling_state.Temp_id.next temp_ids.sapling_state in
( {temp_ids with sapling_state},
(temp_ids.sapling_state :> Sapling_state.Id.t) )
[@@coq_axiom_with_reason "gadt"]
let fold_s :
type i a u.
(i, a, u) kind -> ('acc -> i -> 'acc Lwt.t) -> t -> 'acc -> 'acc Lwt.t =
fun kind f temp_ids acc ->
let helper (type j) (module Temp_id : TEMP_ID with type t = j) ~last f =
let rec aux acc id =
if Temp_id.equal id last then Lwt.return acc
else f acc id >>= fun acc -> aux acc (Temp_id.next id)
in
aux acc Temp_id.init
in
match kind with
| Big_map ->
helper
(module Big_map.Temp_id)
~last:temp_ids.big_map
(fun acc temp_id -> f acc (temp_id :> i))
| Sapling_state ->
helper
(module Sapling_state.Temp_id)
~last:temp_ids.sapling_state
(fun acc temp_id -> f acc (temp_id :> i))
[@@coq_axiom_with_reason "gadt"]
end
module IdSet = struct
type t = {big_map : Big_map.IdSet.t; sapling_state : Sapling_state.IdSet.t}
type 'acc fold_f = {f : 'i 'a 'u. ('i, 'a, 'u) kind -> 'i -> 'acc -> 'acc}
let empty =
{big_map = Big_map.IdSet.empty; sapling_state = Sapling_state.IdSet.empty}
let mem (type i a u) (kind : (i, a, u) kind) (id : i) set =
match (kind, set) with
| Big_map, {big_map; _} -> Big_map.IdSet.mem id big_map
| Sapling_state, {sapling_state; _} ->
Sapling_state.IdSet.mem id sapling_state
[@@coq_axiom_with_reason "gadt"]
let add (type i a u) (kind : (i, a, u) kind) (id : i) set =
match (kind, set) with
| Big_map, {big_map; _} ->
let big_map = Big_map.IdSet.add id big_map in
{set with big_map}
| Sapling_state, {sapling_state; _} ->
let sapling_state = Sapling_state.IdSet.add id sapling_state in
{set with sapling_state}
[@@coq_axiom_with_reason "gadt"]
let diff set1 set2 =
let big_map = Big_map.IdSet.diff set1.big_map set2.big_map in
let sapling_state =
Sapling_state.IdSet.diff set1.sapling_state set2.sapling_state
in
{big_map; sapling_state}
[@@coq_axiom_with_reason "gadt"]
let fold (type i a u) (kind : (i, a, u) kind) (f : i -> 'acc -> 'acc) set
(acc : 'acc) =
match (kind, set) with
| Big_map, {big_map; _} -> Big_map.IdSet.fold f big_map acc
| Sapling_state, {sapling_state; _} ->
Sapling_state.IdSet.fold f sapling_state acc
[@@coq_axiom_with_reason "gadt"]
let fold_all f set acc =
List.fold_left
(fun acc (_, Ex_Kind kind) -> fold kind (f.f kind) set acc)
acc
all
[@@coq_axiom_with_reason "gadt"]
end