Source file lazy_storage_kind.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
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
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
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