Source file `script_ir_unparser.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
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
(*****************************************************************************)
(*                                                                           *)
(* 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.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Micheline
open Script_typed_ir
open Michelson_v1_primitives
module Unparse_costs = Michelson_v1_gas.Cost_of.Unparsing

type unparsing_mode = Optimized | Readable | Optimized_legacy

(* This part contains the unparsing that does not depend on parsing
   (everything that cannot contain a lambda). The rest is located at
   the end of the file. *)

let unparse_memo_size ~loc memo_size =
  let z = Sapling.Memo_size.unparse_to_z memo_size in
  Int (loc, z)

let rec unparse_ty_and_entrypoints_uncarbonated :
    type a ac loc.
    loc:loc -> (a, ac) ty -> a entrypoints_node -> loc Script.michelson_node =
 fun ~loc ty {nested = nested_entrypoints; at_node} ->
  let name, args =
    match ty with
    | Unit_t -> (T_unit, [])
    | Int_t -> (T_int, [])
    | Nat_t -> (T_nat, [])
    | Signature_t -> (T_signature, [])
    | String_t -> (T_string, [])
    | Bytes_t -> (T_bytes, [])
    | Mutez_t -> (T_mutez, [])
    | Bool_t -> (T_bool, [])
    | Key_hash_t -> (T_key_hash, [])
    | Key_t -> (T_key, [])
    | Timestamp_t -> (T_timestamp, [])
    | Address_t -> (T_address, [])
    | Tx_rollup_l2_address_t -> (T_tx_rollup_l2_address, [])
    | Operation_t -> (T_operation, [])
    | Chain_id_t -> (T_chain_id, [])
    | Never_t -> (T_never, [])
    | Bls12_381_g1_t -> (T_bls12_381_g1, [])
    | Bls12_381_g2_t -> (T_bls12_381_g2, [])
    | Bls12_381_fr_t -> (T_bls12_381_fr, [])
    | Contract_t (ut, _meta) ->
        let t =
          unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints
        in
        (T_contract, [t])
    | Pair_t (utl, utr, _meta, _) -> (
        let tl =
          unparse_ty_and_entrypoints_uncarbonated ~loc utl no_entrypoints
        in
        let tr =
          unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints
        in
        (* Fold [pair a1 (pair ... (pair an-1 an))] into [pair a1 ... an] *)
        (* Note that the folding does not happen if the pair on the right has an
           annotation because this annotation would be lost *)
        match tr with
        | Prim (_, T_pair, ts, []) -> (T_pair, tl :: ts)
        | _ -> (T_pair, [tl; tr]))
    | Or_t (utl, utr, _meta, _) ->
        let entrypoints_l, entrypoints_r =
          match nested_entrypoints with
          | Entrypoints_None -> (no_entrypoints, no_entrypoints)
          | Entrypoints_Or {left; right} -> (left, right)
        in
        let tl =
          unparse_ty_and_entrypoints_uncarbonated ~loc utl entrypoints_l
        in
        let tr =
          unparse_ty_and_entrypoints_uncarbonated ~loc utr entrypoints_r
        in
        (T_or, [tl; tr])
    | Lambda_t (uta, utr, _meta) ->
        let ta =
          unparse_ty_and_entrypoints_uncarbonated ~loc uta no_entrypoints
        in
        let tr =
          unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints
        in
        (T_lambda, [ta; tr])
    | Option_t (ut, _meta, _) ->
        let ut =
          unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints
        in
        (T_option, [ut])
    | List_t (ut, _meta) ->
        let t =
          unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints
        in
        (T_list, [t])
    | Ticket_t (ut, _meta) ->
        let t = unparse_comparable_ty_uncarbonated ~loc ut in
        (T_ticket, [t])
    | Set_t (ut, _meta) ->
        let t = unparse_comparable_ty_uncarbonated ~loc ut in
        (T_set, [t])
    | Map_t (uta, utr, _meta) ->
        let ta = unparse_comparable_ty_uncarbonated ~loc uta in
        let tr =
          unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints
        in
        (T_map, [ta; tr])
    | Big_map_t (uta, utr, _meta) ->
        let ta = unparse_comparable_ty_uncarbonated ~loc uta in
        let tr =
          unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints
        in
        (T_big_map, [ta; tr])
    | Sapling_transaction_t memo_size ->
        (T_sapling_transaction, [unparse_memo_size ~loc memo_size])
    | Sapling_transaction_deprecated_t memo_size ->
        (T_sapling_transaction_deprecated, [unparse_memo_size ~loc memo_size])
    | Sapling_state_t memo_size ->
        (T_sapling_state, [unparse_memo_size ~loc memo_size])
    | Chest_key_t -> (T_chest_key, [])
    | Chest_t -> (T_chest, [])
  in
  let annot =
    match at_node with
    | None -> []
    | Some {name; original_type_expr = _} ->
        [Entrypoint.unparse_as_field_annot name]
  in
  Prim (loc, name, args, annot)

and unparse_comparable_ty_uncarbonated :
    type a loc. loc:loc -> a comparable_ty -> loc Script.michelson_node =
 fun ~loc ty -> unparse_ty_and_entrypoints_uncarbonated ~loc ty no_entrypoints

let unparse_ty_uncarbonated ~loc ty =
  unparse_ty_and_entrypoints_uncarbonated ~loc ty no_entrypoints

let unparse_ty ~loc ctxt ty =
  Gas.consume ctxt (Unparse_costs.unparse_type ty) >|? fun ctxt ->
  (unparse_ty_uncarbonated ~loc ty, ctxt)

let unparse_parameter_ty ~loc ctxt ty ~entrypoints =
  Gas.consume ctxt (Unparse_costs.unparse_type ty) >|? fun ctxt ->
  (unparse_ty_and_entrypoints_uncarbonated ~loc ty entrypoints.root, ctxt)

let serialize_ty_for_error ty =
  (*
    Types are bounded by [Constants.michelson_maximum_type_size], so
    [unparse_ty_uncarbonated] and [strip_locations] are bounded in time.

    It is hence OK to use them in errors that are not caught in the validation
    (only once in apply).
  *)
  unparse_ty_uncarbonated ~loc:() ty |> Micheline.strip_locations

let rec unparse_stack_uncarbonated :
    type a s. (a, s) stack_ty -> Script.expr list = function
  | Bot_t -> []
  | Item_t (ty, rest) ->
      let uty = unparse_ty_uncarbonated ~loc:() ty in
      let urest = unparse_stack_uncarbonated rest in
      strip_locations uty :: urest

let serialize_stack_for_error ctxt stack_ty =
  match Gas.level ctxt with
  | Unaccounted -> unparse_stack_uncarbonated stack_ty
  | Limited _ -> []

let unparse_unit ~loc ctxt () = ok (Prim (loc, D_Unit, [], []), ctxt)

let unparse_int ~loc ctxt v = ok (Int (loc, Script_int.to_zint v), ctxt)

let unparse_nat ~loc ctxt v = ok (Int (loc, Script_int.to_zint v), ctxt)

let unparse_string ~loc ctxt s =
  ok (String (loc, Script_string.to_string s), ctxt)

let unparse_bytes ~loc ctxt s = ok (Bytes (loc, s), ctxt)

let unparse_bool ~loc ctxt b =
  ok (Prim (loc, (if b then D_True else D_False), [], []), ctxt)

let unparse_timestamp ~loc ctxt mode t =
  match mode with
  | Optimized | Optimized_legacy ->
      ok (Int (loc, Script_timestamp.to_zint t), ctxt)
  | Readable -> (
      Gas.consume ctxt Unparse_costs.timestamp_readable >>? fun ctxt ->
      match Script_timestamp.to_notation t with
      | None -> ok (Int (loc, Script_timestamp.to_zint t), ctxt)
      | Some s -> ok (String (loc, s), ctxt))

let unparse_address ~loc ctxt mode {destination; entrypoint} =
  match mode with
  | Optimized | Optimized_legacy ->
      Gas.consume ctxt Unparse_costs.contract_optimized >|? fun ctxt ->
      let bytes =
        Data_encoding.Binary.to_bytes_exn
          Data_encoding.(tup2 Destination.encoding Entrypoint.value_encoding)
          (destination, entrypoint)
      in
      (Bytes (loc, bytes), ctxt)
  | Readable ->
      Gas.consume ctxt Unparse_costs.contract_readable >|? fun ctxt ->
      let notation =
        Destination.to_b58check destination
        ^ Entrypoint.to_address_suffix entrypoint
      in
      (String (loc, notation), ctxt)

let unparse_tx_rollup_l2_address ~loc ctxt mode
    (tx_address : tx_rollup_l2_address) =
  let tx_address = Indexable.to_value tx_address in
  match mode with
  | Optimized | Optimized_legacy ->
      Gas.consume ctxt Unparse_costs.contract_optimized >|? fun ctxt ->
      let bytes =
        Data_encoding.Binary.to_bytes_exn
          Tx_rollup_l2_address.encoding
          tx_address
      in
      (Bytes (loc, bytes), ctxt)
  | Readable ->
      Gas.consume ctxt Unparse_costs.contract_readable >|? fun ctxt ->
      let b58check = Tx_rollup_l2_address.to_b58check tx_address in
      (String (loc, b58check), ctxt)

let unparse_contract ~loc ctxt mode typed_contract =
  let destination = Typed_contract.destination typed_contract in
  let entrypoint = Typed_contract.entrypoint typed_contract in
  let address = {destination; entrypoint} in
  unparse_address ~loc ctxt mode address

let unparse_signature ~loc ctxt mode s =
  let s = Script_signature.get s in
  match mode with
  | Optimized | Optimized_legacy ->
      Gas.consume ctxt Unparse_costs.signature_optimized >|? fun ctxt ->
      let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in
      (Bytes (loc, bytes), ctxt)
  | Readable ->
      Gas.consume ctxt Unparse_costs.signature_readable >|? fun ctxt ->
      (String (loc, Signature.to_b58check s), ctxt)

let unparse_mutez ~loc ctxt v = ok (Int (loc, Z.of_int64 (Tez.to_mutez v)), ctxt)

let unparse_key ~loc ctxt mode k =
  match mode with
  | Optimized | Optimized_legacy ->
      Gas.consume ctxt Unparse_costs.public_key_optimized >|? fun ctxt ->
      let bytes =
        Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k
      in
      (Bytes (loc, bytes), ctxt)
  | Readable ->
      Gas.consume ctxt Unparse_costs.public_key_readable >|? fun ctxt ->
      (String (loc, Signature.Public_key.to_b58check k), ctxt)

let unparse_key_hash ~loc ctxt mode k =
  match mode with
  | Optimized | Optimized_legacy ->
      Gas.consume ctxt Unparse_costs.key_hash_optimized >|? fun ctxt ->
      let bytes =
        Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k
      in
      (Bytes (loc, bytes), ctxt)
  | Readable ->
      Gas.consume ctxt Unparse_costs.key_hash_readable >|? fun ctxt ->
      (String (loc, Signature.Public_key_hash.to_b58check k), ctxt)

(* Operations are only unparsed during the production of execution traces of
   the interpreter. *)
let unparse_operation ~loc ctxt {piop; lazy_storage_diff = _} =
  let iop = Apply_internal_results.packed_internal_operation piop in
  let bytes =
    Data_encoding.Binary.to_bytes_exn
      Apply_internal_results.internal_operation_encoding
      iop
  in
  Gas.consume ctxt (Unparse_costs.operation bytes) >|? fun ctxt ->
  (Bytes (loc, bytes), ctxt)

let unparse_chain_id ~loc ctxt mode chain_id =
  match mode with
  | Optimized | Optimized_legacy ->
      Gas.consume ctxt Unparse_costs.chain_id_optimized >|? fun ctxt ->
      let bytes =
        Data_encoding.Binary.to_bytes_exn Script_chain_id.encoding chain_id
      in
      (Bytes (loc, bytes), ctxt)
  | Readable ->
      Gas.consume ctxt Unparse_costs.chain_id_readable >|? fun ctxt ->
      (String (loc, Script_chain_id.to_b58check chain_id), ctxt)

let unparse_bls12_381_g1 ~loc ctxt x =
  Gas.consume ctxt Unparse_costs.bls12_381_g1 >|? fun ctxt ->
  let bytes = Script_bls.G1.to_bytes x in
  (Bytes (loc, bytes), ctxt)

let unparse_bls12_381_g2 ~loc ctxt x =
  Gas.consume ctxt Unparse_costs.bls12_381_g2 >|? fun ctxt ->
  let bytes = Script_bls.G2.to_bytes x in
  (Bytes (loc, bytes), ctxt)

let unparse_bls12_381_fr ~loc ctxt x =
  Gas.consume ctxt Unparse_costs.bls12_381_fr >|? fun ctxt ->
  let bytes = Script_bls.Fr.to_bytes x in
  (Bytes (loc, bytes), ctxt)

let unparse_with_data_encoding ~loc ctxt s unparse_cost encoding =
  Lwt.return
    ( Gas.consume ctxt unparse_cost >|? fun ctxt ->
      let bytes = Data_encoding.Binary.to_bytes_exn encoding s in
      (Bytes (loc, bytes), ctxt) )

(* -- Unparsing data of complex types -- *)

type ('ty, 'depth) comb_witness =
  | Comb_Pair : ('t, 'd) comb_witness -> (_ * 't, unit -> 'd) comb_witness
  | Comb_Any : (_, _) comb_witness

let unparse_pair (type r) ~loc unparse_l unparse_r ctxt mode
    (r_comb_witness : (r, unit -> unit -> _) comb_witness) (l, (r : r)) =
  unparse_l ctxt l >>=? fun (l, ctxt) ->
  unparse_r ctxt r >|=? fun (r, ctxt) ->
  (* Fold combs.
     For combs, three notations are supported:
     - a) [Pair x1 (Pair x2 ... (Pair xn-1 xn) ...)],
     - b) [Pair x1 x2 ... xn-1 xn], and
     - c) [{x1; x2; ...; xn-1; xn}].
     In readable mode, we always use b),
     in optimized mode we use the shortest to serialize:
     - for n=2, [Pair x1 x2],
     - for n=3, [Pair x1 (Pair x2 x3)],
     - for n>=4, [{x1; x2; ...; xn}].
  *)
  let res =
    match (mode, r_comb_witness, r) with
    | Optimized, Comb_Pair _, Micheline.Seq (_, r) ->
        (* Optimized case n > 4 *)
        Micheline.Seq (loc, l :: r)
    | ( Optimized,
        Comb_Pair (Comb_Pair _),
        Prim (_, D_Pair, [x2; Prim (_, D_Pair, [x3; x4], [])], []) ) ->
        (* Optimized case n = 4 *)
        Micheline.Seq (loc, [l; x2; x3; x4])
    | Readable, Comb_Pair _, Prim (_, D_Pair, xs, []) ->
        (* Readable case n > 2 *)
        Prim (loc, D_Pair, l :: xs, [])
    | _ ->
        (* The remaining cases are:
            - Optimized n = 2,
            - Optimized n = 3, and
            - Readable n = 2,
            - Optimized_legacy, any n *)
        Prim (loc, D_Pair, [l; r], [])
  in
  (res, ctxt)

let unparse_or ~loc unparse_l unparse_r ctxt = function
  | L l ->
      unparse_l ctxt l >|=? fun (l, ctxt) -> (Prim (loc, D_Left, [l], []), ctxt)
  | R r ->
      unparse_r ctxt r >|=? fun (r, ctxt) -> (Prim (loc, D_Right, [r], []), ctxt)

let unparse_option ~loc unparse_v ctxt = function
  | Some v ->
      unparse_v ctxt v >|=? fun (v, ctxt) -> (Prim (loc, D_Some, [v], []), ctxt)
  | None -> return (Prim (loc, D_None, [], []), ctxt)

(* -- Unparsing data of comparable types -- *)

let comb_witness2 :
    type t tc. (t, tc) ty -> (t, unit -> unit -> unit) comb_witness = function
  | Pair_t (_, Pair_t _, _, _) -> Comb_Pair (Comb_Pair Comb_Any)
  | Pair_t _ -> Comb_Pair Comb_Any
  | _ -> Comb_Any

let rec unparse_comparable_data_rec :
    type a loc.
    loc:loc ->
    context ->
    unparsing_mode ->
    a comparable_ty ->
    a ->
    (loc Script.michelson_node * context) tzresult Lwt.t =
 fun ~loc ctxt mode ty a ->
  (* No need for stack_depth here. Unlike [unparse_data],
     [unparse_comparable_data] doesn't call [unparse_code].
     The stack depth is bounded by the type depth, currently bounded
     by 1000 (michelson_maximum_type_size). *)
  Gas.consume ctxt Unparse_costs.unparse_data_cycle
  (* We could have a smaller cost but let's keep it consistent with
     [unparse_data] for now. *)
  >>?=
  fun ctxt ->
  match (ty, a) with
  | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v
  | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v
  | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v
  | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s
  | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s
  | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b
  | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t
  | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address
  | Tx_rollup_l2_address_t, address ->
      Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address
  | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s
  | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v
  | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k
  | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k
  | Chain_id_t, chain_id ->
      Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id
  | Pair_t (tl, tr, _, YesYes), pair ->
      let r_witness = comb_witness2 tr in
      let unparse_l ctxt v = unparse_comparable_data_rec ~loc ctxt mode tl v in
      let unparse_r ctxt v = unparse_comparable_data_rec ~loc ctxt mode tr v in
      unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair
  | Or_t (tl, tr, _, YesYes), v ->
      let unparse_l ctxt v = unparse_comparable_data_rec ~loc ctxt mode tl v in
      let unparse_r ctxt v = unparse_comparable_data_rec ~loc ctxt mode tr v in
      unparse_or ~loc unparse_l unparse_r ctxt v
  | Option_t (t, _, Yes), v ->
      let unparse_v ctxt v = unparse_comparable_data_rec ~loc ctxt mode t v in
      unparse_option ~loc unparse_v ctxt v
  | Never_t, _ -> .

let account_for_future_serialization_cost unparsed_data ctxt =
  Gas.consume ctxt (Script.strip_locations_cost unparsed_data) >>? fun ctxt ->
  let unparsed_data = Micheline.strip_locations unparsed_data in
  Gas.consume ctxt (Script.micheline_serialization_cost unparsed_data)
  >|? fun ctxt -> (unparsed_data, ctxt)

type unparse_code_rec =
  t ->
  stack_depth:int ->
  unparsing_mode ->
  Script.node ->
  ((canonical_location, prim) node * t, error trace) result Lwt.t

module type MICHELSON_PARSER = sig
  val opened_ticket_type :
    Script.location ->
    'a comparable_ty ->
    (address, ('a, Script_int.n Script_int.num) pair) pair comparable_ty
    tzresult

  val parse_packable_ty :
    context ->
    stack_depth:int ->
    legacy:bool ->
    Script.node ->
    (ex_ty * context) tzresult

  val parse_data :
    unparse_code_rec:unparse_code_rec ->
    elab_conf:Script_ir_translator_config.elab_config ->
    stack_depth:int ->
    context ->
    allow_forged:bool ->
    ('a, 'ac) ty ->
    Script.node ->
    ('a * t) tzresult Lwt.t
end

module Data_unparser (P : MICHELSON_PARSER) = struct
  open Script_tc_errors

  (* -- Unparsing data of any type -- *)
  let rec unparse_data_rec :
      type a ac.
      context ->
      stack_depth:int ->
      unparsing_mode ->
      (a, ac) ty ->
      a ->
      (Script.node * context) tzresult Lwt.t =
   fun ctxt ~stack_depth mode ty a ->
    Gas.consume ctxt Unparse_costs.unparse_data_cycle >>?= fun ctxt ->
    let non_terminal_recursion ctxt mode ty a =
      if Compare.Int.(stack_depth > 10_000) then
        tzfail Script_tc_errors.Unparsing_too_many_recursive_calls
      else unparse_data_rec ctxt ~stack_depth:(stack_depth + 1) mode ty a
    in
    let loc = Micheline.dummy_location in
    match (ty, a) with
    | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v
    | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v
    | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v
    | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s
    | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s
    | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b
    | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t
    | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address
    | Tx_rollup_l2_address_t, address ->
        Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address
    | Contract_t _, contract ->
        Lwt.return @@ unparse_contract ~loc ctxt mode contract
    | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s
    | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v
    | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k
    | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k
    | Operation_t, operation ->
        Lwt.return @@ unparse_operation ~loc ctxt operation
    | Chain_id_t, chain_id ->
        Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id
    | Bls12_381_g1_t, x -> Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x
    | Bls12_381_g2_t, x -> Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x
    | Bls12_381_fr_t, x -> Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x
    | Pair_t (tl, tr, _, _), pair ->
        let r_witness = comb_witness2 tr in
        let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in
        let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in
        unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair
    | Or_t (tl, tr, _, _), v ->
        let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in
        let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in
        unparse_or ~loc unparse_l unparse_r ctxt v
    | Option_t (t, _, _), v ->
        let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in
        unparse_option ~loc unparse_v ctxt v
    | List_t (t, _), items ->
        List.fold_left_es
          (fun (l, ctxt) element ->
            non_terminal_recursion ctxt mode t element
            >|=? fun (unparsed, ctxt) -> (unparsed :: l, ctxt))
          ([], ctxt)
          items.elements
        >|=? fun (items, ctxt) -> (Micheline.Seq (loc, List.rev items), ctxt)
    | Ticket_t (t, _), {ticketer; contents; amount} ->
        (* ideally we would like to allow a little overhead here because it is only used for unparsing *)
        P.opened_ticket_type loc t >>?= fun t ->
        let destination : Destination.t = Contract ticketer in
        let addr = {destination; entrypoint = Entrypoint.default} in
        (unparse_data_rec [@tailcall])
          ctxt
          ~stack_depth
          mode
          t
          (addr, (contents, (amount :> Script_int.n Script_int.num)))
    | Set_t (t, _), set ->
        List.fold_left_es
          (fun (l, ctxt) item ->
            unparse_comparable_data_rec ~loc ctxt mode t item
            >|=? fun (item, ctxt) -> (item :: l, ctxt))
          ([], ctxt)
          (Script_set.fold (fun e acc -> e :: acc) set [])
        >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)
    | Map_t (kt, vt, _), map ->
        let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in
        unparse_items_rec ctxt ~stack_depth:(stack_depth + 1) mode kt vt items
        >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)
    | Big_map_t (_kt, _vt, _), Big_map {id = Some id; diff = {size; _}; _}
      when Compare.Int.( = ) size 0 ->
        return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt)
    | Big_map_t (kt, vt, _), Big_map {id = Some id; diff = {map; _}; _} ->
        let items =
          Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map []
        in
        let items =
          (* Sort the items in Michelson comparison order and not in key
             hash order. This code path is only exercised for tracing,
             so we don't bother carbonating this sort operation
             precisely. Also, the sort uses a reverse compare because
             [unparse_items] will reverse the result. *)
          List.sort
            (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a)
            items
        in
        (* this can't fail if the original type is well-formed
           because [option vt] is always strictly smaller than [big_map kt vt] *)
        option_t loc vt >>?= fun vt ->
        unparse_items_rec ctxt ~stack_depth:(stack_depth + 1) mode kt vt items
        >|=? fun (items, ctxt) ->
        ( Micheline.Prim
            ( loc,
              D_Pair,
              [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)],
              [] ),
          ctxt )
    | Big_map_t (kt, vt, _), Big_map {id = None; diff = {map; _}; _} ->
        let items =
          Big_map_overlay.fold
            (fun _ (k, v) acc ->
              match v with None -> acc | Some v -> (k, v) :: acc)
            map
            []
        in
        let items =
          (* See note above. *)
          List.sort
            (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a)
            items
        in
        unparse_items_rec ctxt ~stack_depth:(stack_depth + 1) mode kt vt items
        >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)
    | Lambda_t _, Lam (_, original_code) ->
        unparse_code_rec ctxt ~stack_depth:(stack_depth + 1) mode original_code
    | Lambda_t _, LamRec (_, original_code) ->
        unparse_code_rec ctxt ~stack_depth:(stack_depth + 1) mode original_code
        >|=? fun (body, ctxt) ->
        (Micheline.Prim (loc, D_Lambda_rec, [body], []), ctxt)
    | Never_t, _ -> .
    | Sapling_transaction_t _, s ->
        Lwt.return
          ( Gas.consume ctxt (Unparse_costs.sapling_transaction s)
          >|? fun ctxt ->
            let bytes =
              Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s
            in
            (Bytes (loc, bytes), ctxt) )
    | Sapling_transaction_deprecated_t _, s ->
        Lwt.return
          ( Gas.consume ctxt (Unparse_costs.sapling_transaction_deprecated s)
          >|? fun ctxt ->
            let bytes =
              Data_encoding.Binary.to_bytes_exn
                Sapling.Legacy.transaction_encoding
                s
            in
            (Bytes (loc, bytes), ctxt) )
    | Sapling_state_t _, {id; diff; _} ->
        Lwt.return
          ( Gas.consume ctxt (Unparse_costs.sapling_diff diff) >|? fun ctxt ->
            ( (match diff with
              | {commitments_and_ciphertexts = []; nullifiers = []} -> (
                  match id with
                  | None -> Micheline.Seq (loc, [])
                  | Some id ->
                      let id = Sapling.Id.unparse_to_z id in
                      Micheline.Int (loc, id))
              | diff -> (
                  let diff_bytes =
                    Data_encoding.Binary.to_bytes_exn Sapling.diff_encoding diff
                  in
                  let unparsed_diff = Bytes (loc, diff_bytes) in
                  match id with
                  | None -> unparsed_diff
                  | Some id ->
                      let id = Sapling.Id.unparse_to_z id in
                      Micheline.Prim
                        (loc, D_Pair, [Int (loc, id); unparsed_diff], []))),
              ctxt ) )
    | Chest_key_t, s ->
        unparse_with_data_encoding
          ~loc
          ctxt
          s
          Unparse_costs.chest_key
          Script_timelock.chest_key_encoding
    | Chest_t, s ->
        unparse_with_data_encoding
          ~loc
          ctxt
          s
          (Unparse_costs.chest
             ~plaintext_size:(Script_timelock.get_plaintext_size s))
          Script_timelock.chest_encoding

  and unparse_items_rec :
      type k v vc.
      context ->
      stack_depth:int ->
      unparsing_mode ->
      k comparable_ty ->
      (v, vc) ty ->
      (k * v) list ->
      (Script.node list * context) tzresult Lwt.t =
   fun ctxt ~stack_depth mode kt vt items ->
    List.fold_left_es
      (fun (l, ctxt) (k, v) ->
        let loc = Micheline.dummy_location in
        unparse_comparable_data_rec ~loc ctxt mode kt k >>=? fun (key, ctxt) ->
        unparse_data_rec ctxt ~stack_depth:(stack_depth + 1) mode vt v
        >|=? fun (value, ctxt) ->
        (Prim (loc, D_Elt, [key; value], []) :: l, ctxt))
      ([], ctxt)
      items

  and unparse_code_rec ctxt ~stack_depth mode code =
    let elab_conf = Script_ir_translator_config.make ~legacy:true () in
    Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt ->
    let non_terminal_recursion ctxt mode code =
      if Compare.Int.(stack_depth > 10_000) then
        tzfail Unparsing_too_many_recursive_calls
      else unparse_code_rec ctxt ~stack_depth:(stack_depth + 1) mode code
    in
    match code with
    | Prim (loc, I_PUSH, [ty; data], annot) ->
        P.parse_packable_ty
          ctxt
          ~stack_depth:(stack_depth + 1)
          ~legacy:elab_conf.legacy
          ty
        >>?= fun (Ex_ty t, ctxt) ->
        let allow_forged =
          false
          (* Forgeable in PUSH data are already forbidden at parsing,
             the only case for which this matters is storing a lambda resulting
             from APPLYing a non-forgeable but this cannot happen either as long
             as all packable values are also forgeable. *)
        in
        P.parse_data
          ~unparse_code_rec
          ~elab_conf
          ctxt
          ~stack_depth:(stack_depth + 1)
          ~allow_forged
          t
          data
        >>=? fun (data, ctxt) ->
        unparse_data_rec ctxt ~stack_depth:(stack_depth + 1) mode t data
        >>=? fun (data, ctxt) ->
        return (Prim (loc, I_PUSH, [ty; data], annot), ctxt)
    | Seq (loc, items) ->
        List.fold_left_es
          (fun (l, ctxt) item ->
            non_terminal_recursion ctxt mode item >|=? fun (item, ctxt) ->
            (item :: l, ctxt))
          ([], ctxt)
          items
        >>=? fun (items, ctxt) ->
        return (Micheline.Seq (loc, List.rev items), ctxt)
    | Prim (loc, prim, items, annot) ->
        List.fold_left_es
          (fun (l, ctxt) item ->
            non_terminal_recursion ctxt mode item >|=? fun (item, ctxt) ->
            (item :: l, ctxt))
          ([], ctxt)
          items
        >>=? fun (items, ctxt) ->
        return (Prim (loc, prim, List.rev items, annot), ctxt)
    | (Int _ | String _ | Bytes _) as atom -> return (atom, ctxt)

  let unparse_data ctxt ~stack_depth mode ty v =
    unparse_data_rec ctxt ~stack_depth mode ty v
    >>=? fun (unparsed_data, ctxt) ->
    Lwt.return (account_for_future_serialization_cost unparsed_data ctxt)

  let unparse_code ctxt ~stack_depth mode v =
    unparse_code_rec ctxt ~stack_depth mode v >>=? fun (unparsed_data, ctxt) ->
    Lwt.return (account_for_future_serialization_cost unparsed_data ctxt)

  let unparse_items ctxt ~stack_depth mode ty vty vs =
    unparse_items_rec ctxt ~stack_depth mode ty vty vs
    >>=? fun (unparsed_datas, ctxt) ->
    List.fold_left_e
      (fun (acc, ctxt) unparsed_data ->
        account_for_future_serialization_cost unparsed_data ctxt
        >|? fun (unparsed_data, ctxt) -> (unparsed_data :: acc, ctxt))
      ([], ctxt)
      unparsed_datas
    >>?= fun (unparsed_datas, ctxt) -> return (List.rev unparsed_datas, ctxt)

  module Internal_for_benchmarking = struct
    let unparse_data = unparse_data_rec

    let unparse_code = unparse_code_rec
  end
end

let unparse_comparable_data ctxt mode ty v =
  unparse_comparable_data_rec ctxt ~loc:() mode ty v
  >>=? fun (unparsed_data, ctxt) ->
  Lwt.return (account_for_future_serialization_cost unparsed_data ctxt)
package tezos-protocol-017-PtNairob

Source file script_ir_unparser.ml

Source file `script_ir_unparser.ml`
