Source file ticket_token_map.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
open Alpha_context
(** A carbonated map where the keys are [Ticket_hash.t] values. *)
module Ticket_token_map =
Carbonated_map.Make
(struct
type context = Alpha_context.context
let consume = Gas.consume
end)
(struct
type t = Ticket_hash.t
let compare = Ticket_hash.compare
let compare_cost _ = Ticket_costs.Constants.cost_compare_ticket_hash
end)
(** Conceptually a map from [Ticket_token.ex_token] to values. Since
ticket-tokens are expensive to compare we use [Ticket_hash.t] keys instead,
and store the ticket-token along with the value. *)
type 'a t = (Ticket_token.ex_token * 'a) Ticket_token_map.t
let empty = Ticket_token_map.empty
let key_of_ticket_token ctxt (Ticket_token.Ex_token {ticketer; _} as token) =
Ticket_balance_key.of_ex_token
ctxt
~owner:(Destination.Contract ticketer)
token
let update ctxt key f m =
key_of_ticket_token ctxt key >>=? fun (key_hash, ctxt) ->
let f ctxt val_opt =
(match val_opt with
| Some (_tkn, value) -> f ctxt (Some value)
| None -> f ctxt None)
>|? fun (val_opt, ctxt) -> (Option.map (fun v -> (key, v)) val_opt, ctxt)
in
Ticket_token_map.update ctxt key_hash f m |> Lwt.return
let fold ctxt f =
Ticket_token_map.fold_e ctxt (fun ctxt acc _key_hash (tkn, value) ->
f ctxt acc tkn value)
let find ctxt ticket_token map =
key_of_ticket_token ctxt ticket_token >>=? fun (key_hash, ctxt) ->
Ticket_token_map.find ctxt key_hash map >>?= fun (val_opt, ctxt) ->
return (Option.map snd val_opt, ctxt)
let lift_merge_overlap merge_overlap ctxt (tkn1, v1) (_tkn2, v2) =
merge_overlap ctxt v1 v2 >|? fun (v, ctxt) -> ((tkn1, v), ctxt)
let of_list ctxt ~merge_overlap token_values =
List.fold_left_es
(fun (map, ctxt) (token, value) ->
key_of_ticket_token ctxt token >>=? fun (key_hash, ctxt) ->
Lwt.return
(Ticket_token_map.update
ctxt
key_hash
(fun ctxt old_val ->
match old_val with
| None -> ok (Some (token, value), ctxt)
| Some old ->
lift_merge_overlap merge_overlap ctxt old (token, value)
>|? fun (x, ctxt) -> (Some x, ctxt))
map))
(Ticket_token_map.empty, ctxt)
token_values
let map ctxt f =
Ticket_token_map.map_e ctxt (fun ctxt _key (tkn, value) ->
f ctxt tkn value >|? fun (new_value, ctxt) -> ((tkn, new_value), ctxt))
let to_list ctxt map =
Ticket_token_map.to_list ctxt map >>? fun (list, ctxt) ->
Gas.consume
ctxt
(Carbonated_map_costs.fold_cost ~size:(Ticket_token_map.size map))
>|? fun ctxt -> (List.map snd list, ctxt)
let merge ctxt ~merge_overlap =
Ticket_token_map.merge ctxt ~merge_overlap:(lift_merge_overlap merge_overlap)
let to_ticket_receipt ctxt ~owner ticket_token_map =
let open Lwt_result_syntax in
Ticket_token_map.fold_es
ctxt
(fun ctxt acc _ticket_hash (ex_ticket, amount) ->
if Z.(equal amount zero) then return (acc, ctxt)
else
let (Ticket_token.Ex_token {ticketer; contents_type; contents}) =
ex_ticket
in
let loc = Micheline.dummy_location in
let* contents, ctxt =
Script_ir_unparser.unparse_comparable_data
ctxt
Script_ir_unparser.Optimized_legacy
contents_type
contents
in
let*? ty_unstripped, ctxt =
Script_ir_unparser.unparse_ty ~loc ctxt contents_type
in
let*? ctxt =
Gas.consume ctxt (Script.strip_annotations_cost ty_unstripped)
in
let ty = Script.strip_annotations ty_unstripped in
let*? ctxt = Gas.consume ctxt (Script.strip_locations_cost ty) in
let contents_type = Micheline.strip_locations ty in
let ticket_token = Ticket_receipt.{ticketer; contents_type; contents} in
let update =
Ticket_receipt.{ticket_token; updates = [{account = owner; amount}]}
in
return (update :: acc, ctxt))
[]
ticket_token_map