diff --git a/src/lib_context/sigs/context.ml b/src/lib_context/sigs/context.ml index 3f7d59564fb016607f15e7a83d727a0c23d68f8a..65e66e7256a83e1f0d57245778b3f5d7679d6513 100644 --- a/src/lib_context/sigs/context.ml +++ b/src/lib_context/sigs/context.ml @@ -27,6 +27,10 @@ (** The tree depth of a fold. See the [fold] function for more information. *) type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int] +(** The order in which we fold over elements. See the [View.fold] function for + more information. *) +type order = [`Sorted | `Undefined] + module type VIEW = sig (** The type for context views. *) type t diff --git a/src/lib_crypto/blake2B.ml b/src/lib_crypto/blake2B.ml index 6ae5f3ee0669399306682a770afa5c97259691b7..278a022033a312ff7bc653f9d74fd3a5516d509c 100644 --- a/src/lib_crypto/blake2B.ml +++ b/src/lib_crypto/blake2B.ml @@ -314,20 +314,13 @@ end let rec log2 x = if x <= 1 then 0 else 1 + log2 ((x + 1) / 2) -module Make_merkle_tree (R : sig - val register_encoding : - prefix:string -> - length:int -> - to_raw:('a -> string) -> - of_raw:(string -> 'a option) -> - wrap:('a -> Base58.data) -> - 'a Base58.encoding -end) -(K : PrefixedName) (Contents : sig +module type To_bytes = sig type t val to_bytes : t -> Bytes.t -end) = +end + +module Make_merkle_tree (R : Register) (K : PrefixedName) (Contents : To_bytes) = struct include Make (R) (K) diff --git a/src/lib_crypto/blake2B.mli b/src/lib_crypto/blake2B.mli index 044734007acd633d5e74e63c38f9e07be9b26dc9..021a5201e74def063341a08c3c7157758be73e56 100644 --- a/src/lib_crypto/blake2B.mli +++ b/src/lib_crypto/blake2B.mli @@ -68,20 +68,14 @@ module Make (Register : Register) (Name : PrefixedName) : S.HASH (**/**) -module Make_merkle_tree (R : sig - val register_encoding : - prefix:string -> - length:int -> - to_raw:('a -> string) -> - of_raw:(string -> 'a option) -> - wrap:('a -> Base58.data) -> - 'a Base58.encoding -end) -(K : PrefixedName) (Contents : sig +module type To_bytes = sig type t val to_bytes : t -> Bytes.t -end) : S.MERKLE_TREE with type elt = Contents.t +end + +module Make_merkle_tree (R : Register) (K : PrefixedName) (Contents : To_bytes) : + S.MERKLE_TREE with type elt = Contents.t module Generic_Merkle_tree (H : sig type t diff --git a/src/lib_protocol_environment/environment_V6.ml b/src/lib_protocol_environment/environment_V6.ml index 687c637789cfacf056d6ece596c85ea508fb5089..cb3af05c1d3095aa8c3514df3f10767b680345c8 100644 --- a/src/lib_protocol_environment/environment_V6.ml +++ b/src/lib_protocol_environment/environment_V6.ml @@ -1101,6 +1101,12 @@ struct end module Wasm_2_0_0 = struct + module type S = sig + type tree + + val step : tree -> tree Lwt.t + end + module Make (Tree : Context.TREE with type key = string list and type value = bytes) = struct diff --git a/src/lib_protocol_environment/environment_context_intf.ml b/src/lib_protocol_environment/environment_context_intf.ml index 49df9910abf1e89cd0f177ecbbdfc1a88037b978..6f2e3325d3addf23c5d6d5a4d38cd14da738433e 100644 --- a/src/lib_protocol_environment/environment_context_intf.ml +++ b/src/lib_protocol_environment/environment_context_intf.ml @@ -208,6 +208,8 @@ module V3 = V2 module V4 = struct type depth = V3.depth + type order = [`Sorted | `Undefined] + module type VIEW = sig include V3.VIEW diff --git a/src/lib_protocol_environment/sigs/v4/context.mli b/src/lib_protocol_environment/sigs/v4/context.mli index 6114a50ed3948ac432a33e8f2eaf2efdd0191a2f..6447c03f7e1b0f88d7777c13bab09849a900d9db 100644 --- a/src/lib_protocol_environment/sigs/v4/context.mli +++ b/src/lib_protocol_environment/sigs/v4/context.mli @@ -31,6 +31,10 @@ (** The tree depth of a fold. See the [fold] function for more information. *) type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int] +(** The order in which we fold over elements. See the [fold] function for more + information. *) +type order = [`Sorted | `Undefined] + module type VIEW = sig (** The type for context views. *) type t @@ -113,7 +117,7 @@ module type VIEW = sig ?depth:depth -> t -> key -> - order:[`Sorted | `Undefined] -> + order:order -> init:'a -> f:(key -> tree -> 'a -> 'a Lwt.t) -> 'a Lwt.t diff --git a/src/lib_protocol_environment/sigs/v5/bounded.mli b/src/lib_protocol_environment/sigs/v5/bounded.mli index 46539808d0884e20c02aa453b83a4f157c4de1e4..f2a037d48a7b1153eb272aca2c7c40b0f36d5bb3 100644 --- a/src/lib_protocol_environment/sigs/v5/bounded.mli +++ b/src/lib_protocol_environment/sigs/v5/bounded.mli @@ -66,5 +66,5 @@ module Int32 : sig allow future compatiblity with larger bounds, at the price of addding 1-3 redundant bytes to each message. *) - module Make (_ : BOUNDS) : S + module Make (B : BOUNDS) : S end diff --git a/src/lib_protocol_environment/sigs/v5/compare.mli b/src/lib_protocol_environment/sigs/v5/compare.mli index 0437dd1e23de5ed838b312bd66370f404b6a750c..38f5f19e98bd3409a1c5b005f7add61f1131cd19 100644 --- a/src/lib_protocol_environment/sigs/v5/compare.mli +++ b/src/lib_protocol_environment/sigs/v5/compare.mli @@ -120,6 +120,7 @@ module Int : sig external equal : int -> int -> bool = "%equal" end +[@@coq_plain_module] module Int32 : S with type t = int32 diff --git a/src/lib_protocol_environment/sigs/v5/context.mli b/src/lib_protocol_environment/sigs/v5/context.mli index 4d7ccd466b7314dcac0880d9feef30113e92ca52..068eedd5add5fa9fbb03acdd8c4396803c7d2b1a 100644 --- a/src/lib_protocol_environment/sigs/v5/context.mli +++ b/src/lib_protocol_environment/sigs/v5/context.mli @@ -139,6 +139,7 @@ end module Kind : sig type t = [`Value | `Tree] end +[@@coq_plain_module] module type TREE = sig (** [Tree] provides immutable, in-memory partial mirror of the diff --git a/src/lib_protocol_environment/sigs/v5/data_encoding.mli b/src/lib_protocol_environment/sigs/v5/data_encoding.mli index e7cd699b0623a4a79128370d4357592a1f90e417..b3c52a30caf2cf2d0d23c1e3ac4c6452b66babe2 100644 --- a/src/lib_protocol_environment/sigs/v5/data_encoding.mli +++ b/src/lib_protocol_environment/sigs/v5/data_encoding.mli @@ -466,6 +466,8 @@ type 't case type case_tag = Tag of int | Json_only +type match_result + (** A sum descriptor can be optimized by providing a specific [matching_function] which efficiently determines in which case some value of type ['a] falls. @@ -481,8 +483,6 @@ type case_tag = Tag of int | Json_only inhabited. *) type 'a matching_function = 'a -> match_result -and match_result - (** [matched t e u] represents the fact that a value is tagged with [t] and carries the payload [u] which can be encoded with [e]. diff --git a/src/lib_protocol_environment/sigs/v5/map.mli b/src/lib_protocol_environment/sigs/v5/map.mli index 559bf1cf78546df8e4b7d05d0f94154599560754..8e1d02424fa2af8228b3556142461e037d0b854f 100644 --- a/src/lib_protocol_environment/sigs/v5/map.mli +++ b/src/lib_protocol_environment/sigs/v5/map.mli @@ -154,9 +154,9 @@ module type S = sig val of_seq : (key * 'a) Seq.t -> 'a t val iter_ep : - (key -> 'a -> (unit, 'error Error_monad.trace) result Lwt.t) -> + (key -> 'a -> (unit, 'error list) result Lwt.t) -> 'a t -> - (unit, 'error Error_monad.trace) result Lwt.t + (unit, 'error list) result Lwt.t end diff --git a/src/lib_protocol_environment/sigs/v6/bounded.mli b/src/lib_protocol_environment/sigs/v6/bounded.mli index 46539808d0884e20c02aa453b83a4f157c4de1e4..835cf46553f6bf2ac8314d6effc496de2ba5493e 100644 --- a/src/lib_protocol_environment/sigs/v6/bounded.mli +++ b/src/lib_protocol_environment/sigs/v6/bounded.mli @@ -66,5 +66,6 @@ module Int32 : sig allow future compatiblity with larger bounds, at the price of addding 1-3 redundant bytes to each message. *) - module Make (_ : BOUNDS) : S + module Make (B : BOUNDS) : S end +[@@coq_plain_module] diff --git a/src/lib_protocol_environment/sigs/v6/compare.mli b/src/lib_protocol_environment/sigs/v6/compare.mli index 0437dd1e23de5ed838b312bd66370f404b6a750c..38f5f19e98bd3409a1c5b005f7add61f1131cd19 100644 --- a/src/lib_protocol_environment/sigs/v6/compare.mli +++ b/src/lib_protocol_environment/sigs/v6/compare.mli @@ -120,6 +120,7 @@ module Int : sig external equal : int -> int -> bool = "%equal" end +[@@coq_plain_module] module Int32 : S with type t = int32 diff --git a/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli b/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli index ca448ec3bcd8ab1d8041c08d30734b7e7b549339..3a0c43c35cf840bc72e84ebbf24287eb4233ceb0 100644 --- a/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli +++ b/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli @@ -23,7 +23,12 @@ (* *) (*****************************************************************************) -module Make - (Tree : Context.TREE with type key = string list and type value = bytes) : sig - val step : Tree.tree -> Tree.tree Lwt.t +module type S = sig + type tree + + val step : tree -> tree Lwt.t end + +module Make + (Tree : Context.TREE with type key = string list and type value = bytes) : + S with type tree := Tree.tree diff --git a/src/proto_013_PtJakart/lib_protocol/legacy_script_patches_for_J.ml b/src/proto_013_PtJakart/lib_protocol/legacy_script_patches_for_J.ml index e7355d3ebfc9ba62688e5d8dab59f7afef222eb4..d5b8622266025d83879cbb86d3aa886a6c6c1731 100644 --- a/src/proto_013_PtJakart/lib_protocol/legacy_script_patches_for_J.ml +++ b/src/proto_013_PtJakart/lib_protocol/legacy_script_patches_for_J.ml @@ -162,7 +162,9 @@ let expru1ukk6ZqdA32rFYFG7j1eGjfsatbdUZWz8Mi1kXWZYRZm4FZVe = ]; patched_code = bin_expr_exn - "0200002f0405000764076407640865046e000000083a7370656e646572076504620000000a3a616c6c6f77616e63650462000000113a63757272656e74416c6c6f77616e63650000000825617070726f766508650765046e000000063a6f776e657204620000000d3a6d696e4c71744d696e74656407650462000000133a6d6178546f6b656e734465706f7369746564046b000000093a646561646c696e650000000d256164644c6971756964697479076408650765046e000000063a6f776e65720765046e000000033a746f04620000000a3a6c71744275726e65640765046a000000103a6d696e58747a57697468647261776e07650462000000133a6d696e546f6b656e7357697468647261776e046b000000093a646561646c696e65000000102572656d6f76654c697175696469747907640865046e000000033a746f07650462000000103a6d696e546f6b656e73426f75676874046b000000093a646561646c696e650000000b2578747a546f546f6b656e08650765046e000000063a6f776e6572046e000000033a746f076504620000000b3a746f6b656e73536f6c640765046a0000000d3a6d696e58747a426f75676874046b000000093a646561646c696e650000000b25746f6b656e546f58747a0764076408650765046e000000153a6f7574707574446578746572436f6e747261637407650462000000103a6d696e546f6b656e73426f75676874046e000000063a6f776e65720765046e000000033a746f076504620000000b3a746f6b656e73536f6c64046b000000093a646561646c696e650000000d25746f6b656e546f546f6b656e0764045d0000001025757064617465546f6b656e506f6f6c04620000001825757064617465546f6b656e506f6f6c496e7465726e616c076408650563035d0359000000092573657442616b65720764046e0000000b257365744d616e61676572046c000000082564656661756c74050107650861046e000000063a6f776e657207650462000000083a62616c616e63650760046e000000083a7370656e64657204620000000a3a616c6c6f77616e636500000009256163636f756e7473076507650459000000183a73656c6649735570646174696e67546f6b656e506f6f6c076504590000000c3a667265657a6542616b65720462000000093a6c7174546f74616c07650765046e000000083a6d616e61676572046e0000000d3a746f6b656e41646472657373076504620000000a3a746f6b656e506f6f6c046a000000083a78747a506f6f6c05020200002b61055707650764076407640765036e07650362036207650765036e036207650362036b076407650765036e0765036e03620765036a07650362036b07640765036e07650362036b07650765036e036e076503620765036a036b0764076407650765036e07650362036e0765036e07650362036b0764035d0362076407650563035d03590764036e036c07650761036e076503620760036e036207650765035907650359036207650765036e036e07650362036a03210316051f02000000020317072e0200001e3d072e0200000b73072e02000001c1051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031603480329072f020000000e0723036e03620743036200000342020000000003210317071f0002020000000203210570000203160329072f02000000060743036200000200000000071f000202000000020321057000020317031703190325072c020000000002000000630743036801000000585468652063757272656e7420616c6c6f77616e636520706172616d65746572206d75737420657175616c207468652073656e64657227732063757272656e7420616c6c6f77616e636520666f7220746865206f776e65722e0327032103170570000203210316051f02000000060317031603460350051f020000000d0321051f020000000203160317034c0320034c0342051f020000000403210316034603480350051f020000000d0321051f020000000203170316034c03200342053d036d034202000009a6051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003807430368010000002d6d6178546f6b656e734465706f7369746564206d7573742062652067726561746572207468616e207a65726f2e032703210316031707430362000003190337072c020000000002000000320743036801000000276d696e4c71744d696e746564206d7573742062652067726561746572207468616e207a65726f2e03270743036a000003130319032a072c0200000000020000002c074303680100000021416d6f756e74206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c031703160317031703300325072c020000032f03130743036a0080897a03190332072c0200000000020000004f07430368010000004454686520696e697469616c206c697175696469747920616d6f756e74206d7573742062652067726561746572207468616e206f7220657175616c20746f20312058545a2e0327034c0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f0200000071051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342034c071f0002020000000203210570000203160316051f0200000004032103160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00030200000002032105700003031603160350051f020000000d0321051f020000000203170316034c032003420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000004e6051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321071f000402000000020321057000040317031703170316033a071f00020200000002032105700002034c0322072f020000001507430368010000000a64697642795a65726f2e0327020000002703210316051f02000000020317034c03300325072c020000000002000000080743036200010312032107430362000003190337072c02000000000200000023074303680100000018746f6b656e734465706f7369746564206973207a65726f2e0327034c071f000402000000020321057000040317031603170317033a051f0200000002034c0322072f0200000002032702000000020316071f0002020000000203210570000203160317051f0200000002032103190332072c020000000002000000430743036801000000386c71744d696e746564206d7573742062652067726561746572207468616e206f7220657175616c20746f206d696e4c71744d696e7465642e0327051f0200000066051f02000000020321034c03170316051f0200000002032103190328072c0200000000020000003e074303680100000033746f6b656e734465706f73697465642069732067726561746572207468616e206d6178546f6b656e734465706f73697465642e0327071f00030200000002032105700003071f0003020000000203210570000303160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000003210316071f000202000000020321057000020312051f020000000d0321051f020000000203170316034c032003420346071f0003020000000203210570000303160316051f020000000f051f020000000805700003032103160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317057000020312051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f000202000000020321057000020312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000b051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000012be072e020000090b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703160743036a000003190337072c0200000000020000003507430368010000002a6d696e58747a57697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103170317031607430362000003190337072c0200000000020000003807430368010000002d6d696e546f6b656e7357697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103160317031707430362000003190337072c0200000000020000002f0743036801000000246c71744275726e6564206d7573742062652067726561746572207468616e207a65726f2e0327032103160316051f020000000d051f02000000020321034c03160329072f02000000220743036801000000176f776e657220686173206e6f206c69717569646974792e03270200000000034c0321031603170317071f00020200000002032105700002031603190328072c0200000000020000003507430368010000002a6c71744275726e65642069732067726561746572207468616e206f776e657227732062616c616e63652e0327032103160316034803190325072c0200000004034c03160200000132034c0321031703480329072f020000002a07430368010000001f73656e64657220686173206e6f20617070726f76616c2062616c616e63652e03270200000000051f0200000017034c0321031603170317051f02000000060743035b0000034b0321051f020000004b03190328072c0200000000020000003b07430368010000003073656e64657220617070726f76616c2062616c616e6365206973206c657373207468616e204c5154206275726e65642e03270311034605700002032103170570000203480350051f020000000d0321051f020000000203160317034c0320034c034203210316051f0200000043034605710001032103160316034c051f020000002e051f020000000b051f0200000004032103160350051f020000000d0321051f020000000203170316034c03200342051f02000000020321034c031603170317071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a051f0200000017071f0002020000000203210570000203170316031703170322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321071f000302000000020321057000030317031603190332072c0200000000020000003507430368010000002a78747a57697468647261776e206973206c657373207468616e206d696e58747a57697468647261776e2e0327071f00020200000002032105700002031603170317051f0200000023071f0003020000000203210570000303210317031603170317034c0317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321071f0004020000000203210570000403170317031603190332072c0200000000020000003b074303680100000030746f6b656e7357697468647261776e206973206c657373207468616e206d696e546f6b656e7357697468647261776e2e0327071f0003020000000203210570000303160317031705700003034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327057000040321071f0005020000000203210570000503160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00050200000002032105700005031603160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317071f00040200000002032105700004031603170317034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00030200000002032105700003034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000302000000020321057000030316031703160555036c072f020000000403170327020000000005700003034f034d051f020000005f051f020000000d051f02000000060316031703160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a000005700003057000040342034903540342034d053d036d034c031b034c031b034202000009a7072e020000049c051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a000003130319032a072c0200000000020000002c074303680100000021416d6f756e74206d7573742062652067726561746572207468616e207a65726f2e032703210317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f0327051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160743036200a80f033a0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f020000000b0743036200a50f033a03120743036200a50f033a071f000302000000020321057000030317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321051f0200000052051f020000000603210317031603190328072c0200000000020000003507430368010000002a746f6b656e73426f75676874206973206c657373207468616e206d696e546f6b656e73426f756768742e03270321071f000302000000020321057000030317031703170316034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000d051f02000000060316034903540321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030570000505700005051f020000000203420342034d051f0200000004053d036d031b034202000004ff051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f032703210317031607430362000003190337072c0200000000020000001d074303680100000012746f6b656e73536f6c64206973207a65726f032703210317031703160743036a000003190337072c020000000002000000320743036801000000276d696e58747a426f75676874206d7573742062652067726561746572207468616e207a65726f2e03270321031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321051f020000004e051f0200000008032103170317031603190328072c0200000000020000002f07430368010000002478747a426f75676874206973206c657373207468616e206d696e58747a426f756768742e0327051f0200000092034c03210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321051f02000000ae051f020000000a03210317031703170317034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f00020200000002032105700002031603170555036c072f02000000020327020000000005700001034f034d051f020000006a051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d05700002031b034c031b03420200000c59072e0200000867072e0200000517051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e0327032103170317031607430362000003190337072c0200000000020000001d074303680100000012746f6b656e73536f6c64206973207a65726f0327032103160317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f032703210317031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c0317031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a051f02000000020321034c031703170316071f0003020000000203210570000303170317031703160312051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00020200000002032105700002034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000202000000020321057000020316031606550765036e07650362036b0000000b2578747a546f546f6b656e072f020000000403170327020000000005700002071f00030200000002032105700003032103170316051f02000000190321031603170316051f0200000008032103170317031703420342034c0320034d034c051f0200000017034c0321031703170316051f02000000060316031703170321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b051f0200000002034c034c031b03420200000344072e02000001720743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327031e0354034803190325072c02000000000200000020074303680100000015756e73616665557064617465546f6b656e506f6f6c03270321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031707430359030a051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170316031706550765036e055a03620000000b2567657442616c616e6365072f02000000040317032702000000000743036a000004490000001825757064617465546f6b656e506f6f6c496e7465726e616c034903540342034d051f0200000004053d036d031b034202000001c60743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031703160316072c0200000000020000003207430368010000002744657874657220646964206e6f7420696e6974696174652074686973206f7065726174696f6e2e0327051f02000000020321034c0317031703160317034803190325072c0200000000020000004e0743036801000000435468652073656e646572206973206e6f742074686520746f6b656e20636f6e7472616374206173736f6369617465642077697468207468697320636f6e74726163742e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317074303590303051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000003e6072e02000001bd051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f02000000020321034c0317031603170316033f072c0200000000020000003d07430368010000003243616e6e6f74206368616e6765207468652062616b6572207768696c6520667265657a6542616b657220697320747275652e032703210316051f02000000020317034e051f0200000073051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d031b0342020000021d072e0200000147051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000000ca03200321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d0342"; + ("0200002f0405000764076407640865046e000000083a7370656e646572076504620000000a3a616c6c6f77616e63650462000000113a63757272656e74416c6c6f77616e63650000000825617070726f766508650765046e000000063a6f776e657204620000000d3a6d696e4c71744d696e74656407650462000000133a6d6178546f6b656e734465706f7369746564046b000000093a646561646c696e650000000d256164644c6971756964697479076408650765046e000000063a6f776e65720765046e000000033a746f04620000000a3a6c71744275726e65640765046a000000103a6d696e58747a57697468647261776e07650462000000133a6d696e546f6b656e7357697468647261776e046b000000093a646561646c696e65000000102572656d6f76654c697175696469747907640865046e000000033a746f07650462000000103a6d696e546f6b656e73426f75676874046b000000093a646561646c696e650000000b2578747a546f546f6b656e08650765046e000000063a6f776e6572046e000000033a746f076504620000000b3a746f6b656e73536f6c640765046a0000000d3a6d696e58747a426f75676874046b000000093a646561646c696e650000000b25746f6b656e546f58747a0764076408650765046e000000153a6f7574707574446578746572436f6e747261637407650462000000103a6d696e546f6b656e73426f75676874046e000000063a6f776e65720765046e000000033a746f076504620000000b3a746f6b656e73536f6c64046b000000093a646561646c696e650000000d25746f6b656e546f546f6b656e0764045d0000001025757064617465546f6b656e506f6f6c04620000001825757064617465546f6b656e506f6f6c496e7465726e616c076408650563035d0359000000092573657442616b65720764046e0000000b257365744d616e61676572046c000000082564656661756c74050107650861046e000000063a6f776e657207650462000000083a62616c616e63650760046e000000083a7370656e64657204620000000a3a616c6c6f77616e636500000009256163636f756e7473076507650459000000183a73656c6649735570646174696e67546f6b656e506f6f6c076504590000000c3a667265657a6542616b65720462000000093a6c7174546f74616c07650765046e000000083a6d616e61676572046e0000000d3a746f6b656e41646472657373076504620000000a3a746f6b656e506f6f6c046a000000083a78747a506f6f6c05020200002b61055707650764076407640765036e07650362036207650765036e036207650362036b076407650765036e0765036e03620765036a07650362036b07640765036e07650362036b07650765036e036e076503620765036a036b0764076407650765036e07650362036e0765036e07650362036b0764035d0362076407650563035d03590764036e036c07650761036e076503620760036e036207650765035907650359036207650765036e036e07650362036a03210316051f02000000020317072e0200001e3d072e0200000b73072e02000001c1051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031603480329072f020000000e0723036e03620743036200000342020000000003210317071f0002020000000203210570000203160329072f02000000060743036200000200000000071f000202000000020321057000020317031703190325072c020000000002000000630743036801000000585468652063757272656e7420616c6c6f77616e636520706172616d65746572206d75737420657175616c207468652073656e64657227732063757272656e7420616c6c6f77616e636520666f7220746865206f776e65722e0327032103170570000203210316051f02000000060317031603460350051f020000000d0321051f020000000203160317034c0320034c0342051f020000000403210316034603480350051f020000000d0321051f020000000203170316034c03200342053d036d034202000009a6051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003807430368010000002d6d6178546f6b656e734465706f7369746564206d7573742062652067726561746572207468616e207a65726f2e032703210316031707430362000003190337072c020000000002000000320743036801000000276d696e4c71744d696e746564206d7573742062652067726561746572207468616e207a65726f2e03270743036a000003130319032a072c0200000000020000002c074303680100000021416d6f756e74206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c031703160317031703300325072c020000032f03130743036a0080897a03190332072c0200000000020000004f07430368010000004454686520696e697469616c206c697175696469747920616d6f756e74206d7573742062652067726561746572207468616e206f7220657175616c20746f20312058545a2e0327034c0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f0200000071051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342034c071f0002020000000203210570000203160316051f0200000004032103160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00030200000002032105700003031603160350051f020000000d0321051f020000000203170316034c032003420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000004e6051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321071f000402000000020321057000040317031703170316033a071f00020200000002032105700002034c0322072f020000001507430368010000000a64697642795a65726f2e0327020000002703210316051f02000000020317034c03300325072c020000000002000000080743036200010312032107430362000003190337072c02000000000200000023074303680100000018746f6b656e734465706f7369746564206973207a65726f2e0327034c071f000402000000020321057000040317031603170317033a051f0200000002034c0322072f0200000002032702000000020316071f0002020000000203210570000203160317051f0200000002032103190332072c020000000002000000430743036801000000386c71744d696e746564206d7573742062652067726561746572207468616e206f7220657175616c20746f206d696e4c71744d696e7465642e0327051f0200000066051f02000000020321034c03170316051f0200000002032103190328072c0200000000020000003e074303680100000033746f6b656e734465706f73697465642069732067726561746572207468616e206d6178546f6b656e734465706f73697465642e0327071f00030200000002032105700003071f0003020000000203210570000303160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000003210316071f000202000000020321057000020312051f020000000d0321051f020000000203170316034c032003420346071f0003020000000203210570000303160316051f020000000f051f020000000805700003032103160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317057000020312051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f000202000000020321057000020312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000b051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000012be072e020000090b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703160743036a000003190337072c0200000000020000003507430368010000002a6d696e58747a57697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103170317031607430362000003190337072c0200000000020000003807430368010000002d6d696e546f6b656e7357697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103160317031707430362000003190337072c0200000000020000002f0743036801000000246c71744275726e6564206d7573742062652067726561746572207468616e207a65726f2e0327032103160316051f020000000d051f02000000020321034c03160329072f02000000220743036801000000176f776e657220686173206e6f206c69717569646974792e03270200000000034c0321031603170317071f00020200000002032105700002031603190328072c0200000000020000003507430368010000002a6c71744275726e65642069732067726561746572207468616e206f776e657227732062616c616e63652e0327032103160316034803190325072c0200000004034c03160200000132034c0321031703480329072f020000002a07430368010000001f73656e64657220686173206e6f20617070726f76616c2062616c616e63652e03270200000000051f0200000017034c0321031603170317051f02000000060743035b0000034b0321051f020000004b03190328072c0200000000020000003b07430368010000003073656e64657220617070726f76616c2062616c616e6365206973206c657373207468616e204c5154206275726e65642e03270311034605700002032103170570000203480350051f020000000d0321051f020000000203160317034c0320034c034203210316051f0200000043034605710001032103160316034c051f020000002e051f020000000b051f0200000004032103160350051f020000000d0321051f020000000203170316034c03200342051f02000000020321034c031603170317071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a051f0200000017071f0002020000000203210570000203170316031703170322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321071f000302000000020321057000030317031603190332072c0200000000020000003507430368010000002a78747a57697468647261776e206973206c657373207468616e206d696e58747a57697468647261776e2e0327071f00020200000002032105700002031603170317051f0200000023071f0003020000000203210570000303210317031603170317034c0317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321071f0004020000000203210570000403170317031603190332072c0200000000020000003b074303680100000030746f6b656e7357697468647261776e206973206c657373207468616e206d696e546f6b656e7357697468647261776e2e0327071f0003020000000203210570000303160317031705700003034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327057000040321071f0005020000000203210570000503160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00050200000002032105700005031603160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317071f00040200000002032105700004031603170317034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002034c034b03210743035b000003190332072c02000000020311020000000" + ^ "b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00030200000002032105700003034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000302000000020321057000030316031703160555036c072f020000000403170327020000000005700003034f034d051f020000005f051f020000000d051f02000000060316031703160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a000005700003057000040342034903540342034d053d036d034c031b034c031b034202000009a7072e020000049c051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a000003130319032a072c0200000000020000002c074303680100000021416d6f756e74206d7573742062652067726561746572207468616e207a65726f2e032703210317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f0327051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160743036200a80f033a0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f020000000b0743036200a50f033a03120743036200a50f033a071f000302000000020321057000030317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321051f0200000052051f020000000603210317031603190328072c0200000000020000003507430368010000002a746f6b656e73426f75676874206973206c657373207468616e206d696e546f6b656e73426f756768742e03270321071f000302000000020321057000030317031703170316034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000d051f02000000060316034903540321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030570000505700005051f020000000203420342034d051f0200000004053d036d031b034202000004ff051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f032703210317031607430362000003190337072c0200000000020000001d074303680100000012746f6b656e73536f6c64206973207a65726f032703210317031703160743036a000003190337072c020000000002000000320743036801000000276d696e58747a426f75676874206d7573742062652067726561746572207468616e207a65726f2e03270321031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321051f020000004e051f0200000008032103170317031603190328072c0200000000020000002f07430368010000002478747a426f75676874206973206c657373207468616e206d696e58747a426f756768742e0327051f0200000092034c03210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321051f02000000ae051f020000000a03210317031703170317034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f00020200000002032105700002031603170555036c072f02000000020327020000000005700001034f034d051f020000006a051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d05700002031b034c031b03420200000c59072e0200000867072e0200000517051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e0327032103170317031607430362000003190337072c0200000000020000001d074303680100000012746f6b656e73536f6c64206973207a65726f0327032103160317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f032703210317031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c0317031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a051f02000000020321034c031703170316071f0003020000000203210570000303170317031703160312051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00020200000002032105700002034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000202000000020321057000020316031606550765036e07650362036b0000000b2578747a546f546f6b656e072f020000000403170327020000000005700002071f00030200000002032105700003032103170316051f02000000190321031603170316051f0200000008032103170317031703420342034c0320034d034c051f0200000017034c0321031703170316051f02000000060316031703170321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b051f0200000002034c034c031b03420200000344072e02000001720743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327031e0354034803190325072c02000000000200000020074303680100000015756e73616665557064617465546f6b656e506f6f6c03270321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031707430359030a051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170316031706550765036e055a03620000000b2567657442616c616e6365072f02000000040317032702000000000743036a000004490000001825757064617465546f6b656e506f6f6c496e7465726e616c034903540342034d051f0200000004053d036d031b034202000001c60743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031703160316072c0200000000020000003207430368010000002744657874657220646964206e6f7420696e6974696174652074686973206f7065726174696f6e2e0327051f02000000020321034c0317031703160317034803190325072c0200000000020000004e0743036801000000435468652073656e646572206973206e6f742074686520746f6b656e20636f6e7472616374206173736f6369617465642077697468207468697320636f6e74726163742e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317074303590303051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000003e6072e02000001bd051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f02000000020321034c0317031603170316033f072c0200000000020000003d07430368010000003243616e6e6f74206368616e6765207468652062616b6572207768696c6520667265657a6542616b657220697320747275652e032703210316051f02000000020317034e051f0200000073051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d031b0342020000021d072e0200000147051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000000ca03200321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d0342" + ); } let exprubv5oQmAUP8BwktmDgMWqTizYDJVhzHhJESGZhJ2GkHESZ1VWg = @@ -173,7 +175,9 @@ let exprubv5oQmAUP8BwktmDgMWqTizYDJVhzHhJESGZhJ2GkHESZ1VWg = addresses = ["KT1CT7S2b9hXNRxRrEcany9sak1qe4aaFAZJ"]; patched_code = bin_expr_exn - "0200002c6905000764076407640865046e000000083a7370656e646572076504620000000a3a616c6c6f77616e63650462000000113a63757272656e74416c6c6f77616e63650000000825617070726f766508650765046e000000063a6f776e657204620000000d3a6d696e4c71744d696e74656407650462000000133a6d6178546f6b656e734465706f7369746564046b000000093a646561646c696e650000000d256164644c6971756964697479076408650765046e000000063a6f776e65720765046e000000033a746f04620000000a3a6c71744275726e65640765046a000000103a6d696e58747a57697468647261776e07650462000000133a6d696e546f6b656e7357697468647261776e046b000000093a646561646c696e65000000102572656d6f76654c697175696469747907640865046e000000033a746f07650462000000103a6d696e546f6b656e73426f75676874046b000000093a646561646c696e650000000b2578747a546f546f6b656e08650765046e000000063a6f776e6572046e000000033a746f076504620000000b3a746f6b656e73536f6c640765046a0000000d3a6d696e58747a426f75676874046b000000093a646561646c696e650000000b25746f6b656e546f58747a0764076408650765046e000000153a6f7574707574446578746572436f6e747261637407650462000000103a6d696e546f6b656e73426f75676874046e000000063a6f776e65720765046e000000033a746f076504620000000b3a746f6b656e73536f6c64046b000000093a646561646c696e650000000d25746f6b656e546f546f6b656e0764045d0000001025757064617465546f6b656e506f6f6c04620000001825757064617465546f6b656e506f6f6c496e7465726e616c076408650563035d0359000000092573657442616b65720764046e0000000b257365744d616e61676572046c000000082564656661756c74050107650861046e000000063a6f776e657207650462000000083a62616c616e63650760046e000000083a7370656e64657204620000000a3a616c6c6f77616e636500000009256163636f756e7473076507650459000000183a73656c6649735570646174696e67546f6b656e506f6f6c076504590000000c3a667265657a6542616b65720462000000093a6c7174546f74616c07650765046e000000083a6d616e61676572046e0000000d3a746f6b656e41646472657373076504620000000a3a746f6b656e506f6f6c046a000000083a78747a506f6f6c050202000028c6055707650764076407640765036e07650362036207650765036e036207650362036b076407650765036e0765036e03620765036a07650362036b07640765036e07650362036b07650765036e036e076503620765036a036b0764076407650765036e07650362036e0765036e07650362036b0764035d0362076407650563035d03590764036e036c07650761036e076503620760036e036207650765035907650359036207650765036e036e07650362036a03210316051f02000000020317072e0200001c86072e0200000b8d072e02000001c1051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031603480329072f020000000e0723036e03620743036200000342020000000003210317071f0002020000000203210570000203160329072f02000000060743036200000200000000071f000202000000020321057000020317031703190325072c020000000002000000630743036801000000585468652063757272656e7420616c6c6f77616e636520706172616d65746572206d75737420657175616c207468652073656e64657227732063757272656e7420616c6c6f77616e636520666f7220746865206f776e65722e0327032103170570000203210316051f02000000060317031603460350051f020000000d0321051f020000000203160317034c0320034c0342051f020000000403210316034603480350051f020000000d0321051f020000000203170316034c03200342053d036d034202000009c0051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003807430368010000002d6d6178546f6b656e734465706f7369746564206d7573742062652067726561746572207468616e207a65726f2e032703210316031707430362000003190337072c020000000002000000320743036801000000276d696e4c71744d696e746564206d7573742062652067726561746572207468616e207a65726f2e032703130743036a000003190337072c0200000000020000004607430368010000003b54686520616d6f756e74206f662058545a2073656e7420746f20446578746572206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c031703160317031703300325072c020000032f03130743036a0080897a03190332072c0200000000020000004f07430368010000004454686520696e697469616c206c697175696469747920616d6f756e74206d7573742062652067726561746572207468616e206f7220657175616c20746f20312058545a2e0327034c0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f0200000071051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342034c071f0002020000000203210570000203160316051f0200000004032103160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00030200000002032105700003031603160350051f020000000d0321051f020000000203170316034c032003420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000004e6051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321071f000402000000020321057000040317031703170316033a071f00020200000002032105700002034c0322072f020000001507430368010000000a64697642795a65726f2e0327020000002703210316051f02000000020317034c03300325072c020000000002000000080743036200010312032107430362000003190337072c02000000000200000023074303680100000018746f6b656e734465706f7369746564206973207a65726f2e0327034c071f000402000000020321057000040317031603170317033a051f0200000002034c0322072f0200000002032702000000020316071f0002020000000203210570000203160317051f0200000002032103190332072c020000000002000000430743036801000000386c71744d696e746564206d7573742062652067726561746572207468616e206f7220657175616c20746f206d696e4c71744d696e7465642e0327051f0200000066051f02000000020321034c03170316051f0200000002032103190328072c0200000000020000003e074303680100000033746f6b656e734465706f73697465642069732067726561746572207468616e206d6178546f6b656e734465706f73697465642e0327071f00030200000002032105700003071f0003020000000203210570000303160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000003210316071f000202000000020321057000020312051f020000000d0321051f020000000203170316034c032003420346071f0003020000000203210570000303160316051f020000000f051f020000000805700003032103160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317057000020312051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f000202000000020321057000020312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000b051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000010ed072e020000090b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270321031703160743036a000003190337072c0200000000020000003507430368010000002a6d696e58747a57697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103170317031607430362000003190337072c0200000000020000003807430368010000002d6d696e546f6b656e7357697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103160317031707430362000003190337072c0200000000020000002f0743036801000000246c71744275726e6564206d7573742062652067726561746572207468616e207a65726f2e0327032103160316051f020000000d051f02000000020321034c03160329072f02000000220743036801000000176f776e657220686173206e6f206c69717569646974792e03270200000000034c0321031603170317071f00020200000002032105700002031603190328072c0200000000020000003507430368010000002a6c71744275726e65642069732067726561746572207468616e206f776e657227732062616c616e63652e0327032103160316034803190325072c0200000004034c03160200000132034c0321031703480329072f020000002a07430368010000001f73656e64657220686173206e6f20617070726f76616c2062616c616e63652e03270200000000051f0200000017034c0321031603170317051f02000000060743035b0000034b0321051f020000004b03190328072c0200000000020000003b07430368010000003073656e64657220617070726f76616c2062616c616e6365206973206c657373207468616e204c5154206275726e65642e03270311034605700002032103170570000203480350051f020000000d0321051f020000000203160317034c0320034c034203210316051f0200000043034605710001032103160316034c051f020000002e051f020000000b051f0200000004032103160350051f020000000d0321051f020000000203170316034c03200342051f02000000020321034c031603170317071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a051f0200000017071f0002020000000203210570000203170316031703170322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321071f000302000000020321057000030317031603190332072c0200000000020000003507430368010000002a78747a57697468647261776e206973206c657373207468616e206d696e58747a57697468647261776e2e0327071f00020200000002032105700002031603170317051f0200000023071f0003020000000203210570000303210317031603170317034c0317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321071f0004020000000203210570000403170317031603190332072c0200000000020000003b074303680100000030746f6b656e7357697468647261776e206973206c657373207468616e206d696e546f6b656e7357697468647261776e2e0327071f0003020000000203210570000303160317031705700003034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327057000040321071f0005020000000203210570000503160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00050200000002032105700005031603160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317071f00040200000002032105700004031603170317034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00030200000002032105700003034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000302000000020321057000030316031703160555036c072f020000000403170327020000000005700003034f034d051f020000005f051f020000000d051f02000000060316031703160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a000005700003057000040342034903540342034d053d036d034c031b034c031b034202000007d6072e02000003af051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160743036200a80f033a0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f020000000b0743036200a50f033a03120743036200a50f033a071f000302000000020321057000030317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321051f0200000052051f020000000603210317031603190328072c0200000000020000003507430368010000002a746f6b656e73426f75676874206973206c657373207468616e206d696e546f6b656e73426f756768742e03270321071f000302000000020321057000030317031703170316034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000d051f02000000060316034903540321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030570000505700005051f020000000203420342034d051f0200000004053d036d031b0342020000041b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e032703210317031703160743036a000003190337072c020000000002000000320743036801000000276d696e58747a426f75676874206d7573742062652067726561746572207468616e207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270321031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321051f020000004e051f0200000008032103170317031603190328072c0200000000020000002f07430368010000002478747a426f75676874206973206c657373207468616e206d696e58747a426f756768742e0327051f0200000092034c03210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321051f02000000ae051f020000000a03210317031703170317034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f00020200000002032105700002031603170555036c072f02000000020327020000000005700001034f034d051f020000006a051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b034c031b03420200000b75072e0200000783072e0200000433051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e0327032103160317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e032703210317031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c0317031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a051f02000000020321034c031703170316071f0003020000000203210570000303170317031703160312051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00020200000002032105700002034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000202000000020321057000020316031606550765036e07650362036b0000000b2578747a546f546f6b656e072f020000000403170327020000000005700002071f00030200000002032105700003032103170316051f02000000190321031603170316051f0200000008032103170317031703420342034c0320034d034c051f0200000017034c0321031703170316051f02000000060316031703170321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b051f0200000002034c034c031b03420200000344072e02000001720743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327031e0354034803190325072c02000000000200000020074303680100000015756e73616665557064617465546f6b656e506f6f6c03270321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031707430359030a051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170316031706550765036e055a03620000000b2567657442616c616e6365072f02000000040317032702000000000743036a000004490000001825757064617465546f6b656e506f6f6c496e7465726e616c034903540342034d051f0200000004053d036d031b034202000001c60743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031703160316072c0200000000020000003207430368010000002744657874657220646964206e6f7420696e6974696174652074686973206f7065726174696f6e2e0327051f02000000020321034c0317031703160317034803190325072c0200000000020000004e0743036801000000435468652073656e646572206973206e6f742074686520746f6b656e20636f6e7472616374206173736f6369617465642077697468207468697320636f6e74726163742e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317074303590303051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000003e6072e02000001bd051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f02000000020321034c0317031603170316033f072c0200000000020000003d07430368010000003243616e6e6f74206368616e6765207468652062616b6572207768696c6520667265657a6542616b657220697320747275652e032703210316051f02000000020317034e051f0200000073051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d031b0342020000021d072e0200000147051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000000ca03200321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d0342"; + ("0200002c6905000764076407640865046e000000083a7370656e646572076504620000000a3a616c6c6f77616e63650462000000113a63757272656e74416c6c6f77616e63650000000825617070726f766508650765046e000000063a6f776e657204620000000d3a6d696e4c71744d696e74656407650462000000133a6d6178546f6b656e734465706f7369746564046b000000093a646561646c696e650000000d256164644c6971756964697479076408650765046e000000063a6f776e65720765046e000000033a746f04620000000a3a6c71744275726e65640765046a000000103a6d696e58747a57697468647261776e07650462000000133a6d696e546f6b656e7357697468647261776e046b000000093a646561646c696e65000000102572656d6f76654c697175696469747907640865046e000000033a746f07650462000000103a6d696e546f6b656e73426f75676874046b000000093a646561646c696e650000000b2578747a546f546f6b656e08650765046e000000063a6f776e6572046e000000033a746f076504620000000b3a746f6b656e73536f6c640765046a0000000d3a6d696e58747a426f75676874046b000000093a646561646c696e650000000b25746f6b656e546f58747a0764076408650765046e000000153a6f7574707574446578746572436f6e747261637407650462000000103a6d696e546f6b656e73426f75676874046e000000063a6f776e65720765046e000000033a746f076504620000000b3a746f6b656e73536f6c64046b000000093a646561646c696e650000000d25746f6b656e546f546f6b656e0764045d0000001025757064617465546f6b656e506f6f6c04620000001825757064617465546f6b656e506f6f6c496e7465726e616c076408650563035d0359000000092573657442616b65720764046e0000000b257365744d616e61676572046c000000082564656661756c74050107650861046e000000063a6f776e657207650462000000083a62616c616e63650760046e000000083a7370656e64657204620000000a3a616c6c6f77616e636500000009256163636f756e7473076507650459000000183a73656c6649735570646174696e67546f6b656e506f6f6c076504590000000c3a667265657a6542616b65720462000000093a6c7174546f74616c07650765046e000000083a6d616e61676572046e0000000d3a746f6b656e41646472657373076504620000000a3a746f6b656e506f6f6c046a000000083a78747a506f6f6c050202000028c6055707650764076407640765036e07650362036207650765036e036207650362036b076407650765036e0765036e03620765036a07650362036b07640765036e07650362036b07650765036e036e076503620765036a036b0764076407650765036e07650362036e0765036e07650362036b0764035d0362076407650563035d03590764036e036c07650761036e076503620760036e036207650765035907650359036207650765036e036e07650362036a03210316051f02000000020317072e0200001c86072e0200000b8d072e02000001c1051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031603480329072f020000000e0723036e03620743036200000342020000000003210317071f0002020000000203210570000203160329072f02000000060743036200000200000000071f000202000000020321057000020317031703190325072c020000000002000000630743036801000000585468652063757272656e7420616c6c6f77616e636520706172616d65746572206d75737420657175616c207468652073656e64657227732063757272656e7420616c6c6f77616e636520666f7220746865206f776e65722e0327032103170570000203210316051f02000000060317031603460350051f020000000d0321051f020000000203160317034c0320034c0342051f020000000403210316034603480350051f020000000d0321051f020000000203170316034c03200342053d036d034202000009c0051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003807430368010000002d6d6178546f6b656e734465706f7369746564206d7573742062652067726561746572207468616e207a65726f2e032703210316031707430362000003190337072c020000000002000000320743036801000000276d696e4c71744d696e746564206d7573742062652067726561746572207468616e207a65726f2e032703130743036a000003190337072c0200000000020000004607430368010000003b54686520616d6f756e74206f662058545a2073656e7420746f20446578746572206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c031703160317031703300325072c020000032f03130743036a0080897a03190332072c0200000000020000004f07430368010000004454686520696e697469616c206c697175696469747920616d6f756e74206d7573742062652067726561746572207468616e206f7220657175616c20746f20312058545a2e0327034c0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f0200000071051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342034c071f0002020000000203210570000203160316051f0200000004032103160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00030200000002032105700003031603160350051f020000000d0321051f020000000203170316034c032003420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000004e6051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321071f000402000000020321057000040317031703170316033a071f00020200000002032105700002034c0322072f020000001507430368010000000a64697642795a65726f2e0327020000002703210316051f02000000020317034c03300325072c020000000002000000080743036200010312032107430362000003190337072c02000000000200000023074303680100000018746f6b656e734465706f7369746564206973207a65726f2e0327034c071f000402000000020321057000040317031603170317033a051f0200000002034c0322072f0200000002032702000000020316071f0002020000000203210570000203160317051f0200000002032103190332072c020000000002000000430743036801000000386c71744d696e746564206d7573742062652067726561746572207468616e206f7220657175616c20746f206d696e4c71744d696e7465642e0327051f0200000066051f02000000020321034c03170316051f0200000002032103190328072c0200000000020000003e074303680100000033746f6b656e734465706f73697465642069732067726561746572207468616e206d6178546f6b656e734465706f73697465642e0327071f00030200000002032105700003071f0003020000000203210570000303160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000003210316071f000202000000020321057000020312051f020000000d0321051f020000000203170316034c032003420346071f0003020000000203210570000303160316051f020000000f051f020000000805700003032103160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317057000020312051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f000202000000020321057000020312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000b051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000010ed072e020000090b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270321031703160743036a000003190337072c0200000000020000003507430368010000002a6d696e58747a57697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103170317031607430362000003190337072c0200000000020000003807430368010000002d6d696e546f6b656e7357697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103160317031707430362000003190337072c0200000000020000002f0743036801000000246c71744275726e6564206d7573742062652067726561746572207468616e207a65726f2e0327032103160316051f020000000d051f02000000020321034c03160329072f02000000220743036801000000176f776e657220686173206e6f206c69717569646974792e03270200000000034c0321031603170317071f00020200000002032105700002031603190328072c0200000000020000003507430368010000002a6c71744275726e65642069732067726561746572207468616e206f776e657227732062616c616e63652e0327032103160316034803190325072c0200000004034c03160200000132034c0321031703480329072f020000002a07430368010000001f73656e64657220686173206e6f20617070726f76616c2062616c616e63652e03270200000000051f0200000017034c0321031603170317051f02000000060743035b0000034b0321051f020000004b03190328072c0200000000020000003b07430368010000003073656e64657220617070726f76616c2062616c616e6365206973206c657373207468616e204c5154206275726e65642e03270311034605700002032103170570000203480350051f020000000d0321051f020000000203160317034c0320034c034203210316051f0200000043034605710001032103160316034c051f020000002e051f020000000b051f0200000004032103160350051f020000000d0321051f020000000203170316034c03200342051f02000000020321034c031603170317071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a051f0200000017071f0002020000000203210570000203170316031703170322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321071f000302000000020321057000030317031603190332072c0200000000020000003507430368010000002a78747a57697468647261776e206973206c657373207468616e206d696e58747a57697468647261776e2e0327071f00020200000002032105700002031603170317051f0200000023071f0003020000000203210570000303210317031603170317034c0317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321071f0004020000000203210570000403170317031603190332072c0200000000020000003b074303680100000030746f6b656e7357697468647261776e206973206c657373207468616e206d696e546f6b656e7357697468647261776e2e0327071f0003020000000203210570000303160317031705700003034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327057000040321071f0005020000000" + ^ "203210570000503160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00050200000002032105700005031603160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317071f00040200000002032105700004031603170317034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00030200000002032105700003034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000302000000020321057000030316031703160555036c072f020000000403170327020000000005700003034f034d051f020000005f051f020000000d051f02000000060316031703160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a000005700003057000040342034903540342034d053d036d034c031b034c031b034202000007d6072e02000003af051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160743036200a80f033a0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f020000000b0743036200a50f033a03120743036200a50f033a071f000302000000020321057000030317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321051f0200000052051f020000000603210317031603190328072c0200000000020000003507430368010000002a746f6b656e73426f75676874206973206c657373207468616e206d696e546f6b656e73426f756768742e03270321071f000302000000020321057000030317031703170316034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000d051f02000000060316034903540321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030570000505700005051f020000000203420342034d051f0200000004053d036d031b0342020000041b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e032703210317031703160743036a000003190337072c020000000002000000320743036801000000276d696e58747a426f75676874206d7573742062652067726561746572207468616e207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270321031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321051f020000004e051f0200000008032103170317031603190328072c0200000000020000002f07430368010000002478747a426f75676874206973206c657373207468616e206d696e58747a426f756768742e0327051f0200000092034c03210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321051f02000000ae051f020000000a03210317031703170317034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f00020200000002032105700002031603170555036c072f02000000020327020000000005700001034f034d051f020000006a051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b034c031b03420200000b75072e0200000783072e0200000433051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e0327032103160317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e032703210317031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c0317031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a051f02000000020321034c031703170316071f0003020000000203210570000303170317031703160312051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00020200000002032105700002034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000202000000020321057000020316031606550765036e07650362036b0000000b2578747a546f546f6b656e072f020000000403170327020000000005700002071f00030200000002032105700003032103170316051f02000000190321031603170316051f0200000008032103170317031703420342034c0320034d034c051f0200000017034c0321031703170316051f02000000060316031703170321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b051f0200000002034c034c031b03420200000344072e02000001720743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327031e0354034803190325072c02000000000200000020074303680100000015756e73616665557064617465546f6b656e506f6f6c03270321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031707430359030a051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170316031706550765036e055a03620000000b2567657442616c616e6365072f02000000040317032702000000000743036a000004490000001825757064617465546f6b656e506f6f6c496e7465726e616c034903540342034d051f0200000004053d036d031b034202000001c60743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031703160316072c0200000000020000003207430368010000002744657874657220646964206e6f7420696e6974696174652074686973206f7065726174696f6e2e0327051f02000000020321034c0317031703160317034803190325072c0200000000020000004e0743036801000000435468652073656e646572206973206e6f742074686520746f6b656e20636f6e7472616374206173736f6369617465642077697468207468697320636f6e74726163742e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317074303590303051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000003e6072e02000001bd051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f02000000020321034c0317031603170316033f072c0200000000020000003d07430368010000003243616e6e6f74206368616e6765207468652062616b6572207768696c6520667265657a6542616b657220697320747275652e032703210316051f02000000020317034e051f0200000073051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d031b0342020000021d072e0200000147051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000000ca03200321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d0342" + ); } let patches = diff --git a/src/proto_013_PtJakart/lib_protocol/script_int_repr.ml b/src/proto_013_PtJakart/lib_protocol/script_int_repr.ml index fba40417adb4dc1581531ccb99e591f0f7ad5011..9b74fcf18e1d6b08d4553e51e8f641360ec0f187 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_int_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/script_int_repr.ml @@ -35,7 +35,7 @@ type z = Integer_tag having to deconstruct to and reconstruct from `Z.t`. *) type 't repr = Z.t -type 't num = Num_tag of 't repr [@@ocaml.unboxed] +type 't num = Num_tag of 't repr [@@ocaml.unboxed] [@@coq_force_gadt] let compare (Num_tag x) (Num_tag y) = Z.compare x y diff --git a/src/proto_013_PtJakart/lib_protocol/script_int_repr.mli b/src/proto_013_PtJakart/lib_protocol/script_int_repr.mli index 1dbb5425330dc06fd588367ba34a07daa5005458..7abe7e93c56977e9b1be711f1e5c6ec9736e17ef 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_int_repr.mli +++ b/src/proto_013_PtJakart/lib_protocol/script_int_repr.mli @@ -34,7 +34,7 @@ type 't repr [@@coq_phantom] (** [num] is made algebraic in order to distinguish it from the other type parameters of [Script_typed_ir.ty]. *) -type 't num = Num_tag of 't repr [@@ocaml.unboxed] +type 't num = Num_tag of 't repr [@@ocaml.unboxed] [@@coq_force_gadt] (** Flag for natural numbers. *) type n = Natural_tag diff --git a/src/proto_013_PtJakart/lib_protocol/script_string_repr.ml b/src/proto_013_PtJakart/lib_protocol/script_string_repr.ml index b3108eb31ef238ac9328e322e14ef52818dd5aea..ea0c6bca872cc047a75833d213b6d79c80d42c51 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_string_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/script_string_repr.ml @@ -57,7 +57,7 @@ let () = let empty = String_tag "" let of_string v = - let rec check_printable_ascii i = + let[@coq_struct "i_value"] rec check_printable_ascii i = if Compare.Int.(i < 0) then ok (String_tag v) else match v.[i] with diff --git a/src/proto_alpha/bin_sc_rollup_node/store.ml b/src/proto_alpha/bin_sc_rollup_node/store.ml index e49a8b3d31e57615da1d07e679813e6e1662bb0d..3f0818be5e94e5ac8b8c1cc540f3b969527e0f41 100644 --- a/src/proto_alpha/bin_sc_rollup_node/store.ml +++ b/src/proto_alpha/bin_sc_rollup_node/store.ml @@ -162,6 +162,8 @@ module IStoreTree = struct type key = path type value = bytes + + let __infer_t _ = () end module IStoreProof = diff --git a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml index 4f36381313075b1a4ffa8331938dccb2d3cecc10..c4a652dc42e5b967f51ddddfa59bffea6f782efc 100644 --- a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml @@ -114,7 +114,7 @@ let get_block_offset level = Events.(emit invalid_level_conversion) (Environment.wrap_tztrace errs) >>= fun () -> Lwt.return (`Head 0) -let get_payload_hash (type kind) (op_kind : kind consensus_operation_type) +let get_payload_hash (type kind) (op_kind : kind Consensus_operation_type.t) (op : kind Operation.t) = match (op_kind, op.protocol_data.contents) with | Preendorsement, Single (Preendorsement consensus_content) @@ -123,7 +123,7 @@ let get_payload_hash (type kind) (op_kind : kind consensus_operation_type) | _ -> . let double_consensus_op_evidence (type kind) : - kind consensus_operation_type -> + kind Consensus_operation_type.t -> #Protocol_client_context.full -> 'a -> branch:Block_hash.t -> @@ -135,7 +135,7 @@ let double_consensus_op_evidence (type kind) : | Preendorsement -> Plugin.RPC.Forge.double_preendorsement_evidence let process_consensus_op (type kind) cctxt - (op_kind : kind consensus_operation_type) (new_op : kind Operation.t) + (op_kind : kind Consensus_operation_type.t) (new_op : kind Operation.t) chain_id level round slot ops_table = let map = Option.value ~default:Slot_Map.empty diff --git a/src/proto_alpha/lib_injector/injector_functor.ml b/src/proto_alpha/lib_injector/injector_functor.ml index 3e844aa3e73d9b1584862740e62c6c6201daead9..cab01309c5cc52d7a214e5cf44e0f31315754041 100644 --- a/src/proto_alpha/lib_injector/injector_functor.ml +++ b/src/proto_alpha/lib_injector/injector_functor.ml @@ -390,7 +390,7 @@ module Make (Rollup : PARAMETERS) = struct let* packed_op, result = simulate_operations ~must_succeed state operations in - let results = Apply_results.to_list result in + let results = Apply_results.packed_contents_result_list_to_list result in let failure = ref false in let* rev_non_failing_operations = List.fold_left2_s diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 03c8f89a1e060228cb8c52c898d4498805b033cf..04dbe97d2303727b1a85b5359db835b0307dc447 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -50,7 +50,7 @@ module Registration = struct let register0_fullctxt ~chunked s f = patched_services := RPC_directory.register ~chunked !patched_services s (fun ctxt q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let register0 ~chunked s f = @@ -60,7 +60,8 @@ module Registration = struct patched_services := RPC_directory.register ~chunked !patched_services s (fun ctxt q i -> let mode = - if q#successor_level then `Successor_level else `Head_level + if q#successor_level then Services_registration.Successor_level + else Head_level in Services_registration.rpc_init ctxt mode >>=? fun ctxt -> f ctxt q i) @@ -75,7 +76,7 @@ module Registration = struct let opt_register0_fullctxt ~chunked s f = patched_services := RPC_directory.opt_register ~chunked !patched_services s (fun ctxt q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let opt_register0 ~chunked s f = @@ -88,7 +89,7 @@ module Registration = struct !patched_services s (fun (ctxt, arg) q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i) let opt_register1_fullctxt ~chunked s f = @@ -98,7 +99,7 @@ module Registration = struct !patched_services s (fun (ctxt, arg) q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i) let register1 ~chunked s f = @@ -114,7 +115,7 @@ module Registration = struct !patched_services s (fun ((ctxt, arg1), arg2) q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) let register2 ~chunked s f = @@ -915,8 +916,8 @@ module Scripts = struct Token.transfer ~origin:Simulation ctxt - `Minted - (`Contract dummy_contract) + (Source_infinite Minted) + (Sink_container (Contract dummy_contract)) balance >>=? fun (ctxt, _) -> return (ctxt, dummy_contract_hash) in diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index f1e852c2f6ee467715a1ba344823b7a02742db10..e1ae28d7d4b609326816780c58afabe8f4dd0ec9 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -80,7 +80,7 @@ module Sc_rollup = struct include Sc_rollups module Outbox = struct - include Sc_rollup_storage.Outbox + include Sc_rollup_storage.Outbox_aux module Message = Sc_rollup_outbox_message_repr end @@ -185,7 +185,6 @@ end module Round = struct include Round_repr - module Durations = Durations type round_durations = Durations.t diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index e246db86a4fd878c70ea338282fe0b20878d3c5d..d25cde6d52a7cb722dfd3111882d0a7bb2f07b75 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -101,9 +101,9 @@ module Slot : sig end module Tez : sig - type repr + type repr = Tez_repr.repr - type t = Tez_tag of repr [@@ocaml.unboxed] + type t = Tez_repr.t = Tez_tag of repr [@@ocaml.unboxed] include BASIC_DATA with type t := t @@ -1287,7 +1287,7 @@ module Big_map : sig Id.t -> (context * Script.expr list) tzresult Lwt.t - type update = { + type update = Lazy_storage_kind.Big_map.update = { key : Script_repr.expr; key_hash : Script_expr_hash.t; value : Script_repr.expr option; @@ -1295,7 +1295,10 @@ module Big_map : sig type updates = update list - type alloc = {key_type : Script_repr.expr; value_type : Script_repr.expr} + type alloc = Lazy_storage_kind.Big_map.alloc = { + key_type : Script_repr.expr; + value_type : Script_repr.expr; + } end module Sapling : sig @@ -1322,7 +1325,7 @@ module Sapling : sig val diff_encoding : diff Data_encoding.t module Memo_size : sig - type t + type t = Sapling_repr.Memo_size.t val encoding : t Data_encoding.t @@ -1375,7 +1378,7 @@ module Sapling : sig string -> (context * (Int64.t * state) option) tzresult Lwt.t - type alloc = {memo_size : Memo_size.t} + type alloc = Lazy_storage_kind.Sapling_state.alloc = {memo_size : Memo_size.t} type updates = diff @@ -1472,7 +1475,7 @@ end (** This module re-exports functions from {!Ticket_hash_repr}. See documentation of the functions there. *) module Ticket_hash : sig - type t + type t = Ticket_hash_repr.t val encoding : t Data_encoding.t @@ -1515,7 +1518,7 @@ module Ticket_hash : sig end module Contract : sig - type t = + type t = Contract_repr.t = | Implicit of Signature.Public_key_hash.t | Originated of Contract_hash.t @@ -1655,7 +1658,7 @@ end (** This module re-exports definitions from {!Tx_rollup_repr} and {!Tx_rollup_storage}. *) module Tx_rollup : sig - include BASIC_DATA + include BASIC_DATA with type t = Tx_rollup_repr.t val rpc_arg : t RPC_arg.arg @@ -1692,9 +1695,10 @@ module Tx_rollup_withdraw : sig val encoding : t Data_encoding.t end +[@@coq_plain_module] module Tx_rollup_withdraw_list_hash : sig - include S.HASH + include S.HASH with type t = Tx_rollup_withdraw_list_hash_repr.t val hash_uncarbonated : Tx_rollup_withdraw.t list -> t @@ -1831,7 +1835,7 @@ end (** This module re-exports definitions from {!Tx_rollup_message_repr}. *) module Tx_rollup_message : sig - type deposit = { + type deposit = Tx_rollup_message_repr.deposit = { sender : public_key_hash; destination : Tx_rollup_l2_address.Indexable.value; ticket_hash : Ticket_hash.t; @@ -1978,11 +1982,14 @@ module Tx_rollup_commitment : sig val compact : t -> Compact.t end + type hash_or_result = + | Hash of Tx_rollup_message_result_hash_repr.t + | Result of Tx_rollup_message_result_repr.t + val check_message_result : context -> Compact.t -> - [ `Hash of Tx_rollup_message_result_hash.t - | `Result of Tx_rollup_message_result.t ] -> + hash_or_result -> path:Merkle.path -> index:int -> context tzresult @@ -2091,6 +2098,12 @@ module Tx_rollup_hash : sig end module Tx_rollup_errors : sig + type error_or_commitment = Inbox | Commitment + + type valid_path_or_hash = + | Valid_path of Tx_rollup_commitment.Merkle.h * int + | Hash of Tx_rollup_message_result_hash.t + type error += | Tx_rollup_already_exists of Tx_rollup.t | Tx_rollup_does_not_exist of Tx_rollup.t @@ -2128,7 +2141,7 @@ module Tx_rollup_errors : sig length : int; } | Wrong_path_depth of { - kind : [`Inbox | `Commitment]; + kind : error_or_commitment; provided : int; limit : int; } @@ -2147,9 +2160,7 @@ module Tx_rollup_errors : sig } | Wrong_rejection_hash of { provided : Tx_rollup_message_result_hash.t; - expected : - [ `Valid_path of Tx_rollup_commitment.Merkle.h * int - | `Hash of Tx_rollup_message_result_hash.t ]; + expected : valid_path_or_hash; } | Wrong_deposit_parameters | Proof_failed_to_reject @@ -2161,7 +2172,7 @@ module Tx_rollup_errors : sig | No_withdrawals_to_dispatch val check_path_depth : - [`Inbox | `Commitment] -> int -> count_limit:int -> unit tzresult + error_or_commitment -> int -> count_limit:int -> unit tzresult end (** This is a forward declaration to avoid circular dependencies. @@ -2169,13 +2180,13 @@ end TODO : find a better way to resolve the circular dependency https://gitlab.com/tezos/tezos/-/issues/3147 *) module Sc_rollup_repr : sig - module Address : S.HASH + module Address : S.HASH with type t = Sc_rollup_repr.t type t = Address.t end module Bond_id : sig - type t = + type t = Bond_id_repr.t = | Tx_rollup_bond_id of Tx_rollup.t | Sc_rollup_bond_id of Sc_rollup_repr.t @@ -2324,7 +2335,10 @@ module Delegate : sig endorsing_power:int -> context tzresult Lwt.t - type deposits = {initial_amount : Tez.t; current_amount : Tez.t} + type deposits = Storage.deposits = { + initial_amount : Tez.t; + current_amount : Tez.t; + } val frozen_deposits : context -> public_key_hash -> deposits tzresult Lwt.t @@ -2500,7 +2514,7 @@ module Sc_rollup : sig module Map : Map.S with type key = t end - module Address = Sc_rollup_repr.Address + module Address = Sc_rollup_repr.Address [@@coq_plain_module] type t = Sc_rollup_repr.t @@ -2641,6 +2655,7 @@ module Sc_rollup : sig val all_names : string list end + [@@coq_plain_module] module ArithPVM : sig module type P = sig @@ -2738,7 +2753,7 @@ module Sc_rollup : sig module Number_of_ticks : Bounded.Int32.S module Commitment : sig - module Hash : S.HASH + module Hash : S.HASH [@@coq_plain_module] type t = { compressed_state : State_hash.t; @@ -2876,6 +2891,8 @@ module Sc_rollup : sig val is_empty : tree -> bool val hash : tree -> Context_hash.t + + val __infer_t : t -> unit end module MakeHashingScheme (Tree : TREE) : @@ -2906,7 +2923,7 @@ module Sc_rollup : sig module type PVM_with_proof = sig include PVM.S - val proof : proof + val proof_val : proof end type wrapped_proof = @@ -3348,12 +3365,13 @@ module Kind : sig | Sc_rollup_recover_bond_manager_kind : sc_rollup_recover_bond manager end -type 'a consensus_operation_type = - | Endorsement : Kind.endorsement consensus_operation_type - | Preendorsement : Kind.preendorsement consensus_operation_type +module Consensus_operation_type : sig + type 'a t = + | Endorsement : Kind.endorsement t + | Preendorsement : Kind.preendorsement t -val pp_operation_kind : - Format.formatter -> 'kind consensus_operation_type -> unit + val pp : Format.formatter -> 'kind t -> unit +end type consensus_content = { slot : Slot.t; @@ -3603,10 +3621,14 @@ module Operation : sig type nonrec packed_protocol_data = packed_protocol_data - type consensus_watermark = - | Endorsement of Chain_id.t - | Preendorsement of Chain_id.t - | Dal_slot_availability of Chain_id.t + module Consensus_watermark : sig + type consensus_watermark = + | Endorsement of Chain_id.t + | Preendorsement of Chain_id.t + | Dal_slot_availability of Chain_id.t + end + + open Consensus_watermark val to_watermark : consensus_watermark -> Signature.watermark @@ -4012,35 +4034,39 @@ end (** See 'token.mli' for more explanation. *) module Token : sig type container = - [ `Contract of Contract.t - | `Collected_commitments of Blinded_public_key_hash.t - | `Delegate_balance of Signature.Public_key_hash.t - | `Frozen_deposits of Signature.Public_key_hash.t - | `Block_fees - | `Frozen_bonds of Contract.t * Bond_id.t ] + | Contract of Contract_repr.t + | Collected_commitments of Blinded_public_key_hash.t + | Delegate_balance of Signature.Public_key_hash.t + | Frozen_deposits of Signature.Public_key_hash.t + | Block_fees + | Frozen_bonds of Contract_repr.t * Bond_id_repr.t + + type infinite_source = + | Invoice + | Bootstrap + | Initial_commitments + | Revelation_rewards + | Double_signing_evidence_rewards + | Endorsing_rewards + | Baking_rewards + | Baking_bonuses + | Minted + | Liquidity_baking_subsidies + | Tx_rollup_rejection_rewards type source = - [ `Invoice - | `Bootstrap - | `Initial_commitments - | `Revelation_rewards - | `Double_signing_evidence_rewards - | `Endorsing_rewards - | `Baking_rewards - | `Baking_bonuses - | `Minted - | `Liquidity_baking_subsidies - | `Tx_rollup_rejection_rewards - | container ] - - type sink = - [ `Storage_fees - | `Double_signing_punishments - | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool - | `Burned - | `Tx_rollup_rejection_punishments - | `Sc_rollup_refutation_punishments - | container ] + | Source_infinite of infinite_source + | Source_container of container + + type infinite_sink = + | Storage_fees + | Double_signing_punishments + | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool + | Tx_rollup_rejection_punishments + | Sc_rollup_refutation_punishments + | Burned + + type sink = Sink_infinite of infinite_sink | Sink_container of container val allocated : context -> container -> (context * bool) tzresult Lwt.t @@ -4049,15 +4075,15 @@ module Token : sig val transfer_n : ?origin:Receipt.update_origin -> context -> - ([< source] * Tez.t) list -> - [< sink] -> + (source * Tez.t) list -> + sink -> (context * Receipt.balance_updates) tzresult Lwt.t val transfer : ?origin:Receipt.update_origin -> context -> - [< source] -> - [< sink] -> + source -> + sink -> Tez.t -> (context * Receipt.balance_updates) tzresult Lwt.t end diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index bd65117ab13d5d829d225beaf367428ad353e71c..9f05a4c9b2c173b5607642ccca32e3da025bdec5 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -830,7 +830,11 @@ let apply_transaction_to_implicit ~ctxt ~source ~amount ~pkh ~parameter (* If the implicit contract is not yet allocated at this point then the next transfer of tokens will allocate it. *) Contract.allocated ctxt contract >>= fun already_allocated -> - Token.transfer ctxt (`Contract source) (`Contract contract) amount + Token.transfer + ctxt + (Source_container (Contract source)) + (Sink_container (Contract contract)) + amount >>=? fun (ctxt, balance_updates) -> let is_unit = match parameter with @@ -874,7 +878,11 @@ let apply_transaction_to_smart_contract ~ctxt ~source ~contract_hash ~amount does not exist, [Script_cache.find] will signal that by returning [None] and we'll fail. *) - Token.transfer ctxt (`Contract source) (`Contract contract) amount + Token.transfer + ctxt + (Source_container (Contract source)) + (Sink_container (Contract contract)) + amount >>=? fun (ctxt, balance_updates) -> Script_cache.find ctxt contract_hash >>=? fun (ctxt, cache_key, script) -> match script with @@ -1029,7 +1037,11 @@ let apply_transaction_to_tx_rollup ~ctxt ~parameters_ty ~parameters ~payer in Tx_rollup_state.get ctxt dst_rollup >>=? fun (ctxt, state) -> Tx_rollup_state.burn_cost ~limit:None state message_size >>?= fun cost -> - Token.transfer ctxt (`Contract (Contract.Implicit payer)) `Burned cost + Token.transfer + ctxt + (Source_container (Contract (Contract.Implicit payer))) + (Sink_infinite Burned) + cost >>=? fun (ctxt, balance_updates) -> Tx_rollup_inbox.append_message ctxt dst_rollup state deposit >>=? fun (ctxt, state, paid_storage_size_diff) -> @@ -1084,7 +1096,11 @@ let apply_origination ~ctxt ~storage_type ~storage ~unparsed_code | None -> return ctxt | Some delegate -> Delegate.init ctxt contract delegate) >>=? fun ctxt -> - Token.transfer ctxt (`Contract source) (`Contract contract) credit + Token.transfer + ctxt + (Source_container (Contract source)) + (Sink_container (Contract contract)) + credit >>=? fun (ctxt, balance_updates) -> Fees.record_paid_storage_space ctxt contract >|=? fun (ctxt, size, paid_storage_size_diff) -> @@ -1219,7 +1235,7 @@ let apply_internal_manager_operation_content : >|=? fun (ctxt, consumed_gas, ops) -> (ctxt, IDelegation_result {consumed_gas}, ops) -let apply_external_manager_operation_content : +let[@coq_axiom_with_reason "unresolved implicit type"] apply_external_manager_operation_content : type kind. context -> Script_ir_translator.unparsing_mode -> @@ -1364,7 +1380,7 @@ let apply_external_manager_operation_content : Tx_rollup_commitment.check_message_result ctxt commitment.commitment - (`Result {context_hash; withdraw_list_hash}) + (Result {context_hash; withdraw_list_hash}) ~path:message_result_path ~index:message_index >>?= fun ctxt -> @@ -1572,7 +1588,11 @@ let apply_external_manager_operation_content : >>=? fun (ctxt, state, paid_storage_size_diff) -> Tx_rollup_state.burn_cost ~limit:burn_limit state message_size >>?= fun cost -> - Token.transfer ctxt (`Contract source_contract) `Burned cost + Token.transfer + ctxt + (Source_container (Contract source_contract)) + (Sink_infinite Burned) + cost >>=? fun (ctxt, balance_updates) -> Tx_rollup_state.update ctxt tx_rollup state >>=? fun ctxt -> let result = @@ -1592,8 +1612,8 @@ let apply_external_manager_operation_content : let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in Token.transfer ctxt - (`Contract source_contract) - (`Frozen_bonds (source_contract, bond_id)) + (Source_container (Contract source_contract)) + (Sink_container (Frozen_bonds (source_contract, bond_id))) (Constants.tx_rollup_commitment_bond ctxt) else return (ctxt, []) ) >>=? fun (ctxt, balance_updates) -> @@ -1606,12 +1626,12 @@ let apply_external_manager_operation_content : >>=? fun (ctxt, slashed) -> if slashed then let bid = Bond_id.Tx_rollup_bond_id tx_rollup in - Token.balance ctxt (`Frozen_bonds (committer, bid)) + Token.balance ctxt (Frozen_bonds (committer, bid)) >>=? fun (ctxt, burn) -> Token.transfer ctxt - (`Frozen_bonds (committer, bid)) - `Tx_rollup_rejection_punishments + (Source_container (Frozen_bonds (committer, bid))) + (Sink_infinite Tx_rollup_rejection_punishments) burn else return (ctxt, []) | None -> return (ctxt, [])) @@ -1628,12 +1648,12 @@ let apply_external_manager_operation_content : | Tx_rollup_return_bond {tx_rollup} -> Tx_rollup_commitment.remove_bond ctxt tx_rollup source >>=? fun ctxt -> let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in - Token.balance ctxt (`Frozen_bonds (source_contract, bond_id)) + Token.balance ctxt (Frozen_bonds (source_contract, bond_id)) >>=? fun (ctxt, bond) -> Token.transfer ctxt - (`Frozen_bonds (source_contract, bond_id)) - (`Contract source_contract) + (Source_container (Frozen_bonds (source_contract, bond_id))) + (Sink_container (Contract source_contract)) bond >>=? fun (ctxt, balance_updates) -> let result = @@ -1749,19 +1769,19 @@ let apply_external_manager_operation_content : (if slashed then let committer = Contract.Implicit commitment.committer in let bid = Bond_id.Tx_rollup_bond_id tx_rollup in - Token.balance ctxt (`Frozen_bonds (committer, bid)) + Token.balance ctxt (Frozen_bonds (committer, bid)) >>=? fun (ctxt, burn) -> Tez.(burn /? 2L) >>?= fun reward -> Token.transfer ctxt - (`Frozen_bonds (committer, bid)) - `Tx_rollup_rejection_punishments + (Source_container (Frozen_bonds (committer, bid))) + (Sink_infinite Tx_rollup_rejection_punishments) burn >>=? fun (ctxt, burn_update) -> Token.transfer ctxt - `Tx_rollup_rejection_rewards - (`Contract source_contract) + (Source_infinite Tx_rollup_rejection_rewards) + (Sink_container (Contract source_contract)) reward >>=? fun (ctxt, reward_update) -> return (ctxt, burn_update @ reward_update) @@ -2002,7 +2022,7 @@ let precheck_manager_contents (type kind) ctxt (op : kind Kind.manager contents) Constants.tx_rollup ctxt in Tx_rollup_errors.check_path_depth - `Commitment + Commitment (Tx_rollup_commitment.Merkle.path_depth message_result_path) ~count_limit:max_messages_per_inbox >>?= fun () -> @@ -2029,17 +2049,17 @@ let precheck_manager_contents (type kind) ctxt (op : kind Kind.manager contents) Constants.tx_rollup ctxt in Tx_rollup_errors.check_path_depth - `Inbox + Inbox (Tx_rollup_inbox.Merkle.path_depth message_path) ~count_limit:max_messages_per_inbox >>?= fun () -> Tx_rollup_errors.check_path_depth - `Commitment + Commitment (Tx_rollup_commitment.Merkle.path_depth message_result_path) ~count_limit:max_messages_per_inbox >>?= fun () -> Tx_rollup_errors.check_path_depth - `Commitment + Commitment (Tx_rollup_commitment.Merkle.path_depth previous_message_result_path) ~count_limit:max_messages_per_inbox >>?= fun () -> return ctxt @@ -2059,7 +2079,11 @@ let precheck_manager_contents (type kind) ctxt (op : kind Kind.manager contents) return ctxt) >>=? fun ctxt -> Contract.increment_counter ctxt source >>=? fun ctxt -> - Token.transfer ctxt (`Contract source_contract) `Block_fees fee + Token.transfer + ctxt + (Source_container (Contract source_contract)) + (Sink_container Block_fees) + fee let burn_transaction_storage_fees ctxt trr ~storage_limit ~payer = match trr with @@ -2139,7 +2163,7 @@ let burn_manager_storage_fees : payer:public_key_hash -> (context * Z.t * kind successful_manager_operation_result) tzresult Lwt.t = fun ctxt smopr ~storage_limit ~payer -> - let payer = `Contract (Contract.Implicit payer) in + let payer = Token.Source_container (Contract (Contract.Implicit payer)) in match smopr with | Transaction_result transaction_result -> burn_transaction_storage_fees @@ -2249,7 +2273,7 @@ let burn_internal_storage_fees : (context * Z.t * kind successful_internal_manager_operation_result) tzresult Lwt.t = fun ctxt smopr ~storage_limit ~payer -> - let payer = `Contract (Contract.Implicit payer) in + let payer = Token.Source_container (Contract (Contract.Implicit payer)) in match smopr with | ITransaction_result transaction_result -> burn_transaction_storage_fees @@ -2316,7 +2340,7 @@ let apply_manager_contents (type kind) ctxt mode chain_id List.fold_left_es (fun (ctxt, storage_limit, res) imopr -> let (Internal_manager_operation_result (op, mopr)) = imopr in - match mopr with + match[@coq_match_gadt] mopr with | Applied smopr -> burn_internal_storage_fees ctxt @@ -2448,7 +2472,7 @@ let find_manager_public_key ctxt (op : _ Kind.manager contents_list) = let rec check_batch_tail_sanity : type kind. public_key_hash -> kind Kind.manager contents_list -> unit tzresult = - fun expected_source -> function + fun expected_source -> function[@coq_match_with_default] | Single (Manager_operation {operation = Reveal _key; _}) -> error Incorrect_reveal_position | Cons (Manager_operation {operation = Reveal _key; _}, _res) -> @@ -2468,7 +2492,7 @@ let find_manager_public_key ctxt (op : _ Kind.manager contents_list) = kind Kind.manager contents_list -> (public_key_hash * public_key option) tzresult = fun op -> - match op with + match[@coq_match_with_default] op with | Single (Manager_operation {source; operation = Reveal key; _}) -> ok (source, Some key) | Single (Manager_operation {source; _}) -> ok (source, None) @@ -2488,7 +2512,7 @@ let check_manager_signature ctxt chain_id (op : _ Kind.manager contents_list) find_manager_public_key ctxt op >>=? fun public_key -> Lwt.return (Operation.check_signature public_key chain_id raw_operation) -let rec apply_manager_contents_list_rec : +let[@coq_axiom_with_reason "gadts"] rec apply_manager_contents_list_rec : type kind. context -> Script_ir_translator.unparsing_mode -> @@ -2556,7 +2580,7 @@ let mark_backtracked results = Internal_manager_operation_result (kind, mark_internal_manager_operation_result result) in - match results with + match[@coq_match_with_default] results with | Manager_operation_result op -> Manager_operation_result { @@ -2608,7 +2632,7 @@ let get_predecessor_level = function predecessor_level let record_operation (type kind) ctxt (operation : kind operation) : context = - match operation.protocol_data.contents with + match[@coq_match_with_default] operation.protocol_data.contents with | Single (Preendorsement _) -> ctxt | Single (Endorsement _) -> ctxt | Single (Dal_slot_availability _) -> ctxt @@ -2633,7 +2657,7 @@ type 'consensus_op_kind expected_consensus_content = { let compute_expected_consensus_content (type consensus_op_kind) ~(current_level : Level.t) ~(proposal_level : Level.t) (ctxt : context) (application_mode : apply_mode) - (operation_kind : consensus_op_kind consensus_operation_type) + (operation_kind : consensus_op_kind Consensus_operation_type.t) (operation_round : Round.t) (operation_level : Raw_level.t) : (context * consensus_op_kind expected_consensus_content) tzresult Lwt.t = match operation_kind with @@ -2738,7 +2762,7 @@ let check_operation_branch ~expected ~provided = (Block_hash.equal expected provided) (Wrong_consensus_operation_branch (expected, provided)) -let check_round (type kind) (operation_kind : kind consensus_operation_type) +let check_round (type kind) (operation_kind : kind Consensus_operation_type.t) (apply_mode : apply_mode) ~(expected : Round.t) ~(provided : Round.t) : unit tzresult = match apply_mode with @@ -2764,7 +2788,7 @@ let check_round (type kind) (operation_kind : kind consensus_operation_type) let check_consensus_content (type kind) (apply_mode : apply_mode) (content : consensus_content) (operation_branch : Block_hash.t) - (operation_kind : kind consensus_operation_type) + (operation_kind : kind Consensus_operation_type.t) (expected_content : kind expected_consensus_content) : unit tzresult = let expected_level = expected_content.level.level in let provided_level = content.level in @@ -2791,8 +2815,8 @@ let check_consensus_content (type kind) (apply_mode : apply_mode) to the grandfather: the block hash used in the payload_hash. Otherwise we could produce a preendorsement pointing to the direct proposal. This preendorsement wouldn't be able to propagate for a subsequent proposal using it as a locked_round evidence. *) -let validate_consensus_contents (type kind) ctxt chain_id - (operation_kind : kind consensus_operation_type) +let[@coq_axiom_with_reason "bug in coq-of-ocaml"] validate_consensus_contents + (type kind) ctxt chain_id (operation_kind : kind Consensus_operation_type.t) (operation : kind operation) (apply_mode : apply_mode) (content : consensus_content) : (context * public_key_hash * int) tzresult Lwt.t = @@ -2859,13 +2883,15 @@ let check_denunciation_age ctxt kind given_level = (Outdated_denunciation {kind; level = given_level; last_cycle = last_slashable_cycle}) +type mistake = Double_baking | Double_endorsing + let punish_delegate ctxt delegate level mistake mk_result ~payload_producer = let already_slashed, punish = match mistake with - | `Double_baking -> + | Double_baking -> ( Delegate.already_slashed_for_double_baking, Delegate.punish_double_baking ) - | `Double_endorsing -> + | Double_endorsing -> ( Delegate.already_slashed_for_double_endorsing, Delegate.punish_double_endorsing ) in @@ -2876,8 +2902,8 @@ let punish_delegate ctxt delegate level mistake mk_result ~payload_producer = | Ok reward -> Token.transfer ctxt - `Double_signing_evidence_rewards - (`Contract (Contract.Implicit payload_producer)) + (Source_infinite Double_signing_evidence_rewards) + (Sink_container (Contract (Contract.Implicit payload_producer))) reward | Error _ -> (* reward is Tez.zero *) return (ctxt, [])) >|=? fun (ctxt, reward_balance_updates) -> @@ -2893,13 +2919,15 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt ~chain_id Lwt.t = let mk_result (balance_updates : Receipt.balance_updates) : kind Kind.double_consensus_operation_evidence contents_result = - match op1.protocol_data.contents with + match[@coq_match_with_default] op1.protocol_data.contents with | Single (Preendorsement _) -> Double_preendorsement_evidence_result balance_updates | Single (Endorsement _) -> Double_endorsement_evidence_result balance_updates in - match (op1.protocol_data.contents, op2.protocol_data.contents) with + match[@coq_match_with_default] + (op1.protocol_data.contents, op2.protocol_data.contents) + with | Single (Preendorsement e1), Single (Preendorsement e2) | Single (Endorsement e1), Single (Endorsement e2) -> let kind = if preendorsement then Preendorsement else Endorsement in @@ -2935,7 +2963,7 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt ~chain_id ctxt delegate level - `Double_endorsing + Double_endorsing mk_result ~payload_producer @@ -2978,7 +3006,7 @@ let punish_double_baking ctxt chain_id bh1 bh2 ~payload_producer = ctxt delegate level - `Double_baking + Double_baking ~payload_producer (fun balance_updates -> Double_baking_evidence_result balance_updates) @@ -2999,7 +3027,7 @@ let is_parent_endorsement ctxt ~proposal_level ~grand_parent_round let validate_grand_parent_endorsement ctxt chain_id (op : Kind.endorsement operation) = - match op.protocol_data.contents with + match[@coq_match_with_default] op.protocol_data.contents with | Single (Endorsement e) -> let level = Level.from_raw ctxt e.level in Stake_distribution.slot_owner ctxt level e.slot @@ -3107,7 +3135,11 @@ let apply_contents_list (type kind) ctxt chain_id (apply_mode : apply_mode) mode Nonce.reveal ctxt level nonce >>=? fun ctxt -> let tip = Constants.seed_nonce_revelation_tip ctxt in let contract = Contract.Implicit payload_producer in - Token.transfer ctxt `Revelation_rewards (`Contract contract) tip + Token.transfer + ctxt + (Source_infinite Revelation_rewards) + (Sink_container (Contract contract)) + tip >|=? fun (ctxt, balance_updates) -> (ctxt, Single_result (Seed_nonce_revelation_result balance_updates)) | Single (Double_preendorsement_evidence {op1; op2}) -> @@ -3132,12 +3164,16 @@ let apply_contents_list (type kind) ctxt chain_id (apply_mode : apply_mode) mode let blinded_pkh = Blinded_public_key_hash.of_ed25519_pkh activation_code pkh in - let src = `Collected_commitments blinded_pkh in + let src = Token.Collected_commitments blinded_pkh in Token.allocated ctxt src >>=? fun (ctxt, src_exists) -> fail_unless src_exists (Invalid_activation {pkh}) >>=? fun () -> let contract = Contract.Implicit (Signature.Ed25519 pkh) in Token.balance ctxt src >>=? fun (ctxt, amount) -> - Token.transfer ctxt src (`Contract contract) amount + Token.transfer + ctxt + (Source_container src) + (Sink_container (Contract contract)) + amount >>=? fun (ctxt, bupds) -> return (ctxt, Single_result (Activate_account_result bupds)) | Single (Proposals {source; period; proposals}) -> @@ -3270,8 +3306,8 @@ let apply_liquidity_baking_subsidy ctxt ~toggle_vote = Token.transfer ~origin:Subsidy ctxt - `Liquidity_baking_subsidies - (`Contract liquidity_baking_cpmm_contract) + (Source_infinite Liquidity_baking_subsidies) + (Sink_container (Contract liquidity_baking_cpmm_contract)) liquidity_baking_subsidy >>=? fun (ctxt, balance_updates) -> Script_cache.find ctxt liquidity_baking_cpmm_contract_hash diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index c1fe3cf605746a8b406a79b73da0692295e222c2..6b53268090634417fa9028b5efae2d75e9678abf 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -380,7 +380,7 @@ module Manager_result = struct ~title:"Applied" (merge_objs (obj1 (req "status" (constant "applied"))) encoding) (fun o -> - match o with + match[@coq_match_gadt] o with | Skipped _ | Failed _ | Backtracked _ -> None | Applied o -> ( match select (Successful_manager_result o) with @@ -410,7 +410,7 @@ module Manager_result = struct (opt "errors" trace_encoding)) encoding) (fun o -> - match o with + match[@coq_match_gadt] o with | Skipped _ | Failed _ | Applied _ -> None | Backtracked (o, errs) -> ( match select (Successful_manager_result o) with @@ -421,7 +421,7 @@ module Manager_result = struct in MCase {op_case; encoding; kind; select; proj; inj; t} - let[@coq_axiom_with_reason "gadt"] reveal_case = + let reveal_case = make ~op_case:Operation.Encoding.Manager_operations.reveal_case ~encoding: @@ -431,10 +431,11 @@ module Manager_result = struct | Successful_manager_result (Reveal_result _ as op) -> Some op | _ -> None) ~kind:Kind.Reveal_manager_kind - ~proj:(function Reveal_result {consumed_gas} -> consumed_gas) + ~proj:(function[@coq_match_with_default] + | Reveal_result {consumed_gas} -> consumed_gas) ~inj:(fun consumed_gas -> Reveal_result {consumed_gas}) - let[@coq_axiom_with_reason "gadt"] transaction_contract_variant_cases = + let transaction_contract_variant_cases = union [ case @@ -525,7 +526,7 @@ module Manager_result = struct }); ] - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = make ~op_case:Operation.Encoding.Manager_operations.transaction_case ~encoding:transaction_contract_variant_cases @@ -533,10 +534,10 @@ module Manager_result = struct | Successful_manager_result (Transaction_result _ as op) -> Some op | _ -> None) ~kind:Kind.Transaction_manager_kind - ~proj:(function Transaction_result x -> x) + ~proj:(function[@coq_match_with_default] Transaction_result x -> x) ~inj:(fun x -> Transaction_result x) - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = make ~op_case:Operation.Encoding.Manager_operations.origination_case ~encoding: @@ -550,7 +551,7 @@ module Manager_result = struct ~select:(function | Successful_manager_result (Origination_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Origination_result { lazy_storage_diff; @@ -589,7 +590,7 @@ module Manager_result = struct paid_storage_size_diff; }) - let[@coq_axiom_with_reason "gadt"] register_global_constant_case = + let register_global_constant_case = make ~op_case: Operation.Encoding.Manager_operations.register_global_constant_case @@ -603,7 +604,7 @@ module Manager_result = struct | Successful_manager_result (Register_global_constant_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Register_global_constant_result {balance_updates; consumed_gas; size_of_constant; global_address} -> (balance_updates, consumed_gas, size_of_constant, global_address)) @@ -638,11 +639,11 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Set_deposits_limit_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Set_deposits_limit_result {consumed_gas} -> consumed_gas) ~inj:(fun consumed_gas -> Set_deposits_limit_result {consumed_gas}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_origination_case = + let tx_rollup_origination_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_origination_case ~encoding: @@ -656,7 +657,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_origination_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_origination_result {balance_updates; consumed_gas; originated_tx_rollup} -> (balance_updates, consumed_gas, originated_tx_rollup)) @@ -664,7 +665,7 @@ module Manager_result = struct Tx_rollup_origination_result {balance_updates; consumed_gas; originated_tx_rollup}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_submit_batch_case = + let tx_rollup_submit_batch_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_submit_batch_case ~encoding: @@ -678,7 +679,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_submit_batch_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_submit_batch_result {balance_updates; consumed_gas; paid_storage_size_diff} -> (balance_updates, consumed_gas, paid_storage_size_diff)) @@ -686,7 +687,7 @@ module Manager_result = struct Tx_rollup_submit_batch_result {balance_updates; consumed_gas; paid_storage_size_diff}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case = + let tx_rollup_commit_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_commit_case ~encoding: @@ -698,13 +699,13 @@ module Manager_result = struct | Successful_manager_result (Tx_rollup_commit_result _ as op) -> Some op | _ -> None) ~kind:Kind.Tx_rollup_commit_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_commit_result {balance_updates; consumed_gas} -> (balance_updates, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas) -> Tx_rollup_commit_result {balance_updates; consumed_gas}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_return_bond_case = + let tx_rollup_return_bond_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_return_bond_case ~encoding: @@ -717,13 +718,13 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_return_bond_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_return_bond_result {balance_updates; consumed_gas} -> (balance_updates, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas) -> Tx_rollup_return_bond_result {balance_updates; consumed_gas}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_finalize_commitment_case = + let tx_rollup_finalize_commitment_case = make ~op_case: Operation.Encoding.Manager_operations.tx_rollup_finalize_commitment_case @@ -739,7 +740,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_finalize_commitment_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_finalize_commitment_result {balance_updates; consumed_gas; level} -> (balance_updates, consumed_gas, level)) @@ -747,7 +748,7 @@ module Manager_result = struct Tx_rollup_finalize_commitment_result {balance_updates; consumed_gas; level}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_remove_commitment_case = + let tx_rollup_remove_commitment_case = make ~op_case: Operation.Encoding.Manager_operations.tx_rollup_remove_commitment_case @@ -763,7 +764,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_remove_commitment_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_remove_commitment_result {balance_updates; consumed_gas; level} -> (balance_updates, consumed_gas, level)) @@ -771,7 +772,7 @@ module Manager_result = struct Tx_rollup_remove_commitment_result {balance_updates; consumed_gas; level}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_rejection_case = + let tx_rollup_rejection_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_rejection_case ~encoding: @@ -784,13 +785,13 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_rejection_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_rejection_result {balance_updates; consumed_gas} -> (balance_updates, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas) -> Tx_rollup_rejection_result {balance_updates; consumed_gas}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_dispatch_tickets_case = + let tx_rollup_dispatch_tickets_case = make ~op_case: Operation.Encoding.Manager_operations.tx_rollup_dispatch_tickets_case @@ -806,7 +807,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_dispatch_tickets_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_dispatch_tickets_result {balance_updates; consumed_gas; paid_storage_size_diff} -> (balance_updates, consumed_gas, paid_storage_size_diff)) @@ -814,7 +815,7 @@ module Manager_result = struct Tx_rollup_dispatch_tickets_result {balance_updates; consumed_gas; paid_storage_size_diff}) - let[@coq_axiom_with_reason "gadt"] transfer_ticket_case = + let transfer_ticket_case = make ~op_case:Operation.Encoding.Manager_operations.transfer_ticket_case ~encoding: @@ -827,7 +828,7 @@ module Manager_result = struct | Successful_manager_result (Transfer_ticket_result _ as op) -> Some op | _ -> None) ~kind:Kind.Transfer_ticket_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Transfer_ticket_result {balance_updates; consumed_gas; paid_storage_size_diff} -> (balance_updates, consumed_gas, paid_storage_size_diff)) @@ -835,7 +836,7 @@ module Manager_result = struct Transfer_ticket_result {balance_updates; consumed_gas; paid_storage_size_diff}) - let[@coq_axiom_with_reason "gadt"] dal_publish_slot_header_case = + let dal_publish_slot_header_case = make ~op_case: Operation.Encoding.Manager_operations.dal_publish_slot_header_case @@ -845,12 +846,12 @@ module Manager_result = struct | Successful_manager_result (Dal_publish_slot_header_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Dal_publish_slot_header_result {consumed_gas} -> consumed_gas) ~kind:Kind.Dal_publish_slot_header_manager_kind ~inj:(fun consumed_gas -> Dal_publish_slot_header_result {consumed_gas}) - let[@coq_axiom_with_reason "gadt"] sc_rollup_originate_case = + let sc_rollup_originate_case = make ~op_case:Operation.Encoding.Manager_operations.sc_rollup_originate_case ~encoding: @@ -863,7 +864,7 @@ module Manager_result = struct | Successful_manager_result (Sc_rollup_originate_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_originate_result {balance_updates; address; consumed_gas; size} -> (balance_updates, address, consumed_gas, size)) @@ -883,7 +884,7 @@ module Manager_result = struct | Successful_manager_result (Sc_rollup_add_messages_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_add_messages_result {consumed_gas; inbox_after} -> (consumed_gas, inbox_after)) ~kind:Kind.Sc_rollup_add_messages_manager_kind @@ -898,7 +899,8 @@ module Manager_result = struct ~select:(function | Successful_manager_result (Sc_rollup_cement_result _ as op) -> Some op | _ -> None) - ~proj:(function Sc_rollup_cement_result {consumed_gas} -> consumed_gas) + ~proj:(function[@coq_match_with_default] + | Sc_rollup_cement_result {consumed_gas} -> consumed_gas) ~kind:Kind.Sc_rollup_cement_manager_kind ~inj:(fun consumed_gas -> Sc_rollup_cement_result {consumed_gas}) @@ -915,7 +917,7 @@ module Manager_result = struct | Successful_manager_result (Sc_rollup_publish_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_publish_result {consumed_gas; staked_hash; published_at_level; balance_updates} -> (consumed_gas, staked_hash, published_at_level, balance_updates)) @@ -937,7 +939,7 @@ module Manager_result = struct ~select:(function | Successful_manager_result (Sc_rollup_refute_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_refute_result {consumed_gas; status; balance_updates} -> (consumed_gas, status, balance_updates)) ~kind:Kind.Sc_rollup_refute_manager_kind @@ -956,7 +958,7 @@ module Manager_result = struct | Successful_manager_result (Sc_rollup_timeout_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_timeout_result {consumed_gas; status; balance_updates} -> (consumed_gas, status, balance_updates)) ~kind:Kind.Sc_rollup_timeout_manager_kind @@ -980,7 +982,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Sc_rollup_execute_outbox_message_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_execute_outbox_message_result {balance_updates; consumed_gas; paid_storage_size_diff} -> (balance_updates, consumed_gas, paid_storage_size_diff)) @@ -988,7 +990,7 @@ module Manager_result = struct Sc_rollup_execute_outbox_message_result {balance_updates; consumed_gas; paid_storage_size_diff}) - let[@coq_axiom_with_reason "gadt"] sc_rollup_recover_bond_case = + let sc_rollup_recover_bond_case = make ~op_case:Operation.Encoding.Manager_operations.sc_rollup_recover_bond_case ~encoding: @@ -1001,7 +1003,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Sc_rollup_recover_bond_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_recover_bond_result {balance_updates; consumed_gas} -> (balance_updates, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas) -> @@ -1030,7 +1032,7 @@ module Internal_result = struct -> 'kind case [@@coq_force_gadt] - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = MCase { (* This value should be changed with care: maybe receipts are read by @@ -1055,7 +1057,7 @@ module Internal_result = struct select = (function Manager (Transaction _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Transaction {amount; destination; parameters; entrypoint} -> let parameters = if @@ -1075,7 +1077,7 @@ module Internal_result = struct Transaction {amount; destination; parameters; entrypoint}); } - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = MCase { (* This value should be changed with care: maybe receipts are read by @@ -1096,14 +1098,14 @@ module Internal_result = struct select = (function Manager (Origination _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Origination {credit; delegate; script} -> (credit, delegate, script)); inj = (fun (credit, delegate, script) -> Origination {credit; delegate; script}); } - let[@coq_axiom_with_reason "gadt"] delegation_case = + let delegation_case = MCase { (* This value should be changed with care: maybe receipts are read by @@ -1119,7 +1121,7 @@ module Internal_result = struct | _ -> None); select = (function Manager (Delegation _ as op) -> Some op | _ -> None); - proj = (function Delegation key -> key); + proj = (function[@coq_match_with_default] Delegation key -> key); inj = (fun key -> Delegation key); } @@ -1132,13 +1134,16 @@ module Internal_result = struct (fun ((), x) -> inj x) let encoding = - let make (MCase {tag; name; encoding; iselect = _; select; proj; inj}) = - case - (Tag tag) - name - encoding - (fun o -> match select o with None -> None | Some o -> Some (proj o)) - (fun x -> Manager (inj x)) + let make m_case = + match[@coq_grab_existentials] m_case with + | MCase {tag; name; encoding; iselect = _; select; proj; inj} -> + case + (Tag tag) + name + encoding + (fun o -> + match select o with None -> None | Some o -> Some (proj o)) + (fun x -> Manager (inj x)) in union ~tag_size:`Uint8 @@ -1183,7 +1188,7 @@ module Internal_manager_result = struct ~title:"Applied" (merge_objs (obj1 (req "status" (constant "applied"))) encoding) (fun o -> - match o with + match[@coq_match_gadt] o with | Skipped _ | Failed _ | Backtracked _ -> None | Applied o -> ( match select (Successful_internal_manager_result o) with @@ -1213,7 +1218,7 @@ module Internal_manager_result = struct (opt "errors" trace_encoding)) encoding) (fun o -> - match o with + match[@coq_match_gadt] o with | Skipped _ | Failed _ | Applied _ -> None | Backtracked (o, errs) -> ( match select (Successful_internal_manager_result o) with @@ -1224,7 +1229,7 @@ module Internal_manager_result = struct in MCase {op_case; encoding; kind; select; proj; inj; t} - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = make ~op_case:Internal_result.transaction_case ~encoding:Manager_result.transaction_contract_variant_cases @@ -1233,10 +1238,10 @@ module Internal_manager_result = struct Some op | _ -> None) ~kind:Kind.Transaction_manager_kind - ~proj:(function ITransaction_result x -> x) + ~proj:(function[@coq_match_with_default] ITransaction_result x -> x) ~inj:(fun x -> ITransaction_result x) - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = make ~op_case:Internal_result.origination_case ~encoding: @@ -1251,7 +1256,7 @@ module Internal_manager_result = struct | Successful_internal_manager_result (IOrigination_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | IOrigination_result { lazy_storage_diff; @@ -1310,26 +1315,27 @@ let internal_manager_operation_result_encoding : packed_internal_manager_operation_result Data_encoding.t = let make (type kind) (Internal_manager_result.MCase res_case : - kind Internal_manager_result.case) - (Internal_result.MCase ires_case : kind Internal_result.case) = - let (Internal_result.MCase op_case) = res_case.op_case in - case - (Tag op_case.tag) - ~title:op_case.name - (merge_objs - (obj3 - (req "kind" (constant op_case.name)) - (req "source" Contract.encoding) - (req "nonce" uint16)) - (merge_objs ires_case.encoding (obj1 (req "result" res_case.t)))) - (fun op -> - match ires_case.iselect op with - | Some (op, res) -> - Some (((), op.source, op.nonce), (ires_case.proj op.operation, res)) - | None -> None) - (fun (((), source, nonce), (op, res)) -> - let op = {source; operation = ires_case.inj op; nonce} in - Internal_manager_operation_result (op, res)) + kind Internal_manager_result.case) = function[@coq_match_gadt] + | (Internal_result.MCase ires_case : kind Internal_result.case) -> + let (Internal_result.MCase op_case) = res_case.op_case in + case + (Tag op_case.tag) + ~title:op_case.name + (merge_objs + (obj3 + (req "kind" (constant op_case.name)) + (req "source" Contract.encoding) + (req "nonce" uint16)) + (merge_objs ires_case.encoding (obj1 (req "result" res_case.t)))) + (fun op -> + match ires_case.iselect op with + | Some (op, res) -> + Some + (((), op.source, op.nonce), (ires_case.proj op.operation, res)) + | None -> None) + (fun (((), source, nonce), (op, res)) -> + let op = {source; operation = ires_case.inj op; nonce} in + Internal_manager_operation_result (op, res)) in def "apply_results.alpha.operation_result" @@ union @@ -1347,20 +1353,23 @@ let internal_manager_operation_result_encoding : let successful_manager_operation_result_encoding : packed_successful_manager_operation_result Data_encoding.t = - let make (type kind) - (Manager_result.MCase res_case : kind Manager_result.case) = - let (Operation.Encoding.Manager_operations.MCase op_case) = - res_case.op_case - in - case - (Tag op_case.tag) - ~title:op_case.name - (merge_objs (obj1 (req "kind" (constant op_case.name))) res_case.encoding) - (fun res -> - match res_case.select res with - | Some res -> Some ((), res_case.proj res) - | None -> None) - (fun ((), res) -> Successful_manager_result (res_case.inj res)) + let make (type kind) (mcase : kind Manager_result.case) = + match[@coq_grab_existentials] mcase with + | Manager_result.MCase res_case -> + let (Operation.Encoding.Manager_operations.MCase op_case) = + res_case.op_case + in + case + (Tag op_case.tag) + ~title:op_case.name + (merge_objs + (obj1 (req "kind" (constant op_case.name))) + res_case.encoding) + (fun res -> + match res_case.select res with + | Some res -> Some ((), res_case.proj res) + | None -> None) + (fun ((), res) -> Successful_manager_result (res_case.inj res)) in def "operation.alpha.successful_manager_operation_result" @@ union @@ -1534,7 +1543,7 @@ module Encoding = struct (fun x -> match proj x with None -> None | Some x -> Some ((), x)) (fun ((), x) -> inj x) - let[@coq_axiom_with_reason "gadt"] preendorsement_case = + let preendorsement_case = Case { op_case = Operation.Encoding.preendorsement_case; @@ -1552,7 +1561,7 @@ module Encoding = struct | Contents_and_result ((Preendorsement _ as op), res) -> Some (op, res) | _ -> None); proj = - (function + (function[@coq_match_with_default] | Preendorsement_result {balance_updates; delegate; preendorsement_power} -> (balance_updates, delegate, preendorsement_power)); @@ -1562,7 +1571,7 @@ module Encoding = struct {balance_updates; delegate; preendorsement_power}); } - let[@coq_axiom_with_reason "gadt"] endorsement_case = + let endorsement_case = Case { op_case = Operation.Encoding.endorsement_case; @@ -1579,7 +1588,7 @@ module Encoding = struct | Contents_and_result ((Endorsement _ as op), res) -> Some (op, res) | _ -> None); proj = - (function + (function[@coq_match_with_default] | Endorsement_result {balance_updates; delegate; endorsement_power} -> (balance_updates, delegate, endorsement_power)); inj = @@ -1587,7 +1596,7 @@ module Encoding = struct Endorsement_result {balance_updates; delegate; endorsement_power}); } - let[@coq_axiom_with_reason "gadt"] dal_slot_availability_case = + let dal_slot_availability_case = Case { op_case = Operation.Encoding.dal_slot_availability_case; @@ -1601,11 +1610,13 @@ module Encoding = struct | Contents_and_result ((Dal_slot_availability _ as op), res) -> Some (op, res) | _ -> None); - proj = (function Dal_slot_availability_result {delegate} -> delegate); + proj = + (function[@coq_match_with_default] + | Dal_slot_availability_result {delegate} -> delegate); inj = (fun delegate -> Dal_slot_availability_result {delegate}); } - let[@coq_axiom_with_reason "gadt"] seed_nonce_revelation_case = + let seed_nonce_revelation_case = Case { op_case = Operation.Encoding.seed_nonce_revelation_case; @@ -1620,11 +1631,13 @@ module Encoding = struct | Contents_and_result ((Seed_nonce_revelation _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Seed_nonce_revelation_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Seed_nonce_revelation_result bus) -> + bus); inj = (fun bus -> Seed_nonce_revelation_result bus); } - let[@coq_axiom_with_reason "gadt"] double_endorsement_evidence_case = + let double_endorsement_evidence_case = Case { op_case = Operation.Encoding.double_endorsement_evidence_case; @@ -1640,11 +1653,14 @@ module Encoding = struct | Contents_and_result ((Double_endorsement_evidence _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Double_endorsement_evidence_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Double_endorsement_evidence_result + bus) -> + bus); inj = (fun bus -> Double_endorsement_evidence_result bus); } - let[@coq_axiom_with_reason "gadt"] double_preendorsement_evidence_case = + let double_preendorsement_evidence_case = Case { op_case = Operation.Encoding.double_preendorsement_evidence_case; @@ -1661,11 +1677,14 @@ module Encoding = struct -> Some (op, res) | _ -> None); - proj = (fun (Double_preendorsement_evidence_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Double_preendorsement_evidence_result + bus) -> + bus); inj = (fun bus -> Double_preendorsement_evidence_result bus); } - let[@coq_axiom_with_reason "gadt"] double_baking_evidence_case = + let double_baking_evidence_case = Case { op_case = Operation.Encoding.double_baking_evidence_case; @@ -1680,11 +1699,13 @@ module Encoding = struct | Contents_and_result ((Double_baking_evidence _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Double_baking_evidence_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Double_baking_evidence_result bus) -> + bus); inj = (fun bus -> Double_baking_evidence_result bus); } - let[@coq_axiom_with_reason "gadt"] activate_account_case = + let activate_account_case = Case { op_case = Operation.Encoding.activate_account_case; @@ -1699,11 +1720,12 @@ module Encoding = struct | Contents_and_result ((Activate_account _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Activate_account_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Activate_account_result bus) -> bus); inj = (fun bus -> Activate_account_result bus); } - let[@coq_axiom_with_reason "gadt"] proposals_case = + let proposals_case = Case { op_case = Operation.Encoding.proposals_case; @@ -1715,11 +1737,11 @@ module Encoding = struct (function | Contents_and_result ((Proposals _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun Proposals_result -> ()); + proj = (fun [@coq_match_with_default] Proposals_result -> ()); inj = (fun () -> Proposals_result); } - let[@coq_axiom_with_reason "gadt"] ballot_case = + let ballot_case = Case { op_case = Operation.Encoding.ballot_case; @@ -1731,11 +1753,11 @@ module Encoding = struct (function | Contents_and_result ((Ballot _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun Ballot_result -> ()); + proj = (fun [@coq_match_with_default] Ballot_result -> ()); inj = (fun () -> Ballot_result); } - let[@coq_axiom_with_reason "gadt"] make_manager_case (type kind) + let make_manager_case (type kind) (Operation.Encoding.Case op_case : kind Kind.manager Operation.Encoding.case) (Manager_result.MCase res_case : kind Manager_result.case) mselect = @@ -1751,7 +1773,7 @@ module Encoding = struct (list internal_manager_operation_result_encoding) []); select = - (function + (function[@coq_match_gadt] | Contents_result (Manager_operation_result ({operation_result = Applied res; _} as op)) -> ( @@ -1800,12 +1822,12 @@ module Encoding = struct | Contents_result Proposals_result -> None); mselect; proj = - (fun (Manager_operation_result - { - balance_updates = bus; - operation_result = r; - internal_operation_results = rs; - }) -> + (fun [@coq_match_with_default] (Manager_operation_result + { + balance_updates = bus; + operation_result = r; + internal_operation_results = rs; + }) -> (bus, r, rs)); inj = (fun (bus, r, rs) -> @@ -1817,7 +1839,7 @@ module Encoding = struct }); } - let[@coq_axiom_with_reason "gadt"] reveal_case = + let reveal_case = make_manager_case Operation.Encoding.reveal_case Manager_result.reveal_case @@ -1827,7 +1849,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = make_manager_case Operation.Encoding.transaction_case Manager_result.transaction_case @@ -1837,7 +1859,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = make_manager_case Operation.Encoding.origination_case Manager_result.origination_case @@ -1847,7 +1869,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] delegation_case = + let delegation_case = make_manager_case Operation.Encoding.delegation_case Manager_result.delegation_case @@ -1857,7 +1879,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] register_global_constant_case = + let register_global_constant_case = make_manager_case Operation.Encoding.register_global_constant_case Manager_result.register_global_constant_case @@ -1869,7 +1891,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] set_deposits_limit_case = + let set_deposits_limit_case = make_manager_case Operation.Encoding.set_deposits_limit_case Manager_result.set_deposits_limit_case @@ -1880,7 +1902,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_origination_case = + let tx_rollup_origination_case = make_manager_case Operation.Encoding.tx_rollup_origination_case Manager_result.tx_rollup_origination_case @@ -1891,7 +1913,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_submit_batch_case = + let tx_rollup_submit_batch_case = make_manager_case Operation.Encoding.tx_rollup_submit_batch_case Manager_result.tx_rollup_submit_batch_case @@ -1902,7 +1924,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case = + let tx_rollup_commit_case = make_manager_case Operation.Encoding.tx_rollup_commit_case Manager_result.tx_rollup_commit_case @@ -1913,7 +1935,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_return_bond_case = + let tx_rollup_return_bond_case = make_manager_case Operation.Encoding.tx_rollup_return_bond_case Manager_result.tx_rollup_return_bond_case @@ -1924,7 +1946,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_finalize_commitment_case = + let tx_rollup_finalize_commitment_case = make_manager_case Operation.Encoding.tx_rollup_finalize_commitment_case Manager_result.tx_rollup_finalize_commitment_case @@ -1936,7 +1958,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_remove_commitment_case = + let tx_rollup_remove_commitment_case = make_manager_case Operation.Encoding.tx_rollup_remove_commitment_case Manager_result.tx_rollup_remove_commitment_case @@ -1948,7 +1970,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_rejection_case = + let tx_rollup_rejection_case = make_manager_case Operation.Encoding.tx_rollup_rejection_case Manager_result.tx_rollup_rejection_case @@ -1959,7 +1981,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_dispatch_tickets_case = + let tx_rollup_dispatch_tickets_case = make_manager_case Operation.Encoding.tx_rollup_dispatch_tickets_case Manager_result.tx_rollup_dispatch_tickets_case @@ -1971,7 +1993,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] transfer_ticket_case = + let transfer_ticket_case = make_manager_case Operation.Encoding.transfer_ticket_case Manager_result.transfer_ticket_case @@ -1982,7 +2004,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] dal_publish_slot_header_case = + let dal_publish_slot_header_case = make_manager_case Operation.Encoding.dal_publish_slot_header_case Manager_result.dal_publish_slot_header_case @@ -1994,7 +2016,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_originate_case = + let sc_rollup_originate_case = make_manager_case Operation.Encoding.sc_rollup_originate_case Manager_result.sc_rollup_originate_case @@ -2005,7 +2027,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_add_messages_case = + let sc_rollup_add_messages_case = make_manager_case Operation.Encoding.sc_rollup_add_messages_case Manager_result.sc_rollup_add_messages_case @@ -2016,7 +2038,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_cement_case = + let sc_rollup_cement_case = make_manager_case Operation.Encoding.sc_rollup_cement_case Manager_result.sc_rollup_cement_case @@ -2027,7 +2049,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_publish_case = + let sc_rollup_publish_case = make_manager_case Operation.Encoding.sc_rollup_publish_case Manager_result.sc_rollup_publish_case @@ -2038,7 +2060,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_refute_case = + let sc_rollup_refute_case = make_manager_case Operation.Encoding.sc_rollup_refute_case Manager_result.sc_rollup_refute_case @@ -2049,7 +2071,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_timeout_case = + let sc_rollup_timeout_case = make_manager_case Operation.Encoding.sc_rollup_timeout_case Manager_result.sc_rollup_timeout_case @@ -2060,7 +2082,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_execute_outbox_message_case = + let sc_rollup_execute_outbox_message_case = make_manager_case Operation.Encoding.sc_rollup_execute_outbox_message_case Manager_result.sc_rollup_execute_outbox_message_case @@ -2072,7 +2094,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_recover_bond_case = + let sc_rollup_recover_bond_case = make_manager_case Operation.Encoding.sc_rollup_recover_bond_case Manager_result.sc_rollup_recover_bond_case @@ -2086,8 +2108,9 @@ end let contents_result_encoding = let open Encoding in - let make - (Case + let make case_description = + match[@coq_grab_existentials] case_description with + | Case { op_case = Operation.Encoding.Case {tag; name; _}; encoding; @@ -2095,10 +2118,12 @@ let contents_result_encoding = select; proj; inj; - }) = - let proj x = match select x with None -> None | Some x -> Some (proj x) in - let inj x = Contents_result (inj x) in - tagged_case (Tag tag) name encoding proj inj + } -> + let proj x = + match select x with None -> None | Some x -> Some (proj x) + in + let inj x = Contents_result (inj x) in + tagged_case (Tag tag) name encoding proj inj in def "operation.alpha.contents_result" @@ union @@ -2141,8 +2166,9 @@ let contents_result_encoding = let contents_and_result_encoding = let open Encoding in - let make - (Case + let make case_description = + match[@coq_grab_existentials] case_description with + | Case { op_case = Operation.Encoding.Case {tag; name; encoding; proj; inj; _}; mselect; @@ -2150,15 +2176,17 @@ let contents_and_result_encoding = proj = meta_proj; inj = meta_inj; _; - }) = - let proj c = - match mselect c with - | Some (op, res) -> Some (proj op, meta_proj res) - | _ -> None - in - let inj (op, res) = Contents_and_result (inj op, meta_inj res) in - let encoding = merge_objs encoding (obj1 (req "metadata" meta_encoding)) in - tagged_case (Tag tag) name encoding proj inj + } -> + let proj c = + match mselect c with + | Some (op, res) -> Some (proj op, meta_proj res) + | _ -> None + in + let inj (op, res) = Contents_and_result (inj op, meta_inj res) in + let encoding = + merge_objs encoding (obj1 (req "metadata" meta_encoding)) + in + tagged_case (Tag tag) name encoding proj inj in def "operation.alpha.operation_contents_and_result" @@ union @@ -2209,27 +2237,34 @@ type packed_contents_result_list = 'kind contents_result_list -> packed_contents_result_list +let rec contents_result_list_to_list : type kind. kind contents_result_list -> _ + = function + | Single_result o -> [Contents_result o] + | Cons_result (o, os) -> Contents_result o :: contents_result_list_to_list os + +let packed_contents_result_list_to_list = function + | Contents_result_list l -> contents_result_list_to_list l + +let rec packed_contents_result_list_of_list = function + | [] -> Error "cannot decode empty operation result" + | [Contents_result o] -> Ok (Contents_result_list (Single_result o)) + | Contents_result o :: os -> ( + packed_contents_result_list_of_list os + >>? fun (Contents_result_list os) -> + match (o, os) with + | Manager_operation_result _, Single_result (Manager_operation_result _) + -> + Ok (Contents_result_list (Cons_result (o, os))) + | Manager_operation_result _, Cons_result _ -> + Ok (Contents_result_list (Cons_result (o, os))) + | _ -> Error "cannot decode ill-formed operation result") + let contents_result_list_encoding = - let rec to_list = function - | Contents_result_list (Single_result o) -> [Contents_result o] - | Contents_result_list (Cons_result (o, os)) -> - Contents_result o :: to_list (Contents_result_list os) - in - let rec of_list = function - | [] -> Error "cannot decode empty operation result" - | [Contents_result o] -> Ok (Contents_result_list (Single_result o)) - | Contents_result o :: os -> ( - of_list os >>? fun (Contents_result_list os) -> - match (o, os) with - | Manager_operation_result _, Single_result (Manager_operation_result _) - -> - Ok (Contents_result_list (Cons_result (o, os))) - | Manager_operation_result _, Cons_result _ -> - Ok (Contents_result_list (Cons_result (o, os))) - | _ -> Error "cannot decode ill-formed operation result") - in def "operation.alpha.contents_list_result" - @@ conv_with_guard to_list of_list (list contents_result_encoding) + @@ conv_with_guard + packed_contents_result_list_to_list + packed_contents_result_list_of_list + (list contents_result_encoding) type 'kind contents_and_result_list = | Single_and_result : @@ -2246,27 +2281,34 @@ type packed_contents_and_result_list = 'kind contents_and_result_list -> packed_contents_and_result_list +let rec contents_and_result_list_to_list : + type kind. kind contents_and_result_list -> _ = function + | Single_and_result (op, res) -> [Contents_and_result (op, res)] + | Cons_and_result (op, res, rest) -> + Contents_and_result (op, res) :: contents_and_result_list_to_list rest + +let packed_contents_and_result_list_to_list = function + | Contents_and_result_list l -> contents_and_result_list_to_list l + +let rec packed_contents_and_result_list_of_list = function + | [] -> Error "cannot decode empty combined operation result" + | [Contents_and_result (op, res)] -> + Ok (Contents_and_result_list (Single_and_result (op, res))) + | Contents_and_result (op, res) :: rest -> ( + packed_contents_and_result_list_of_list rest + >>? fun (Contents_and_result_list rest) -> + match (op, rest) with + | Manager_operation _, Single_and_result (Manager_operation _, _) -> + Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) + | Manager_operation _, Cons_and_result (_, _, _) -> + Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) + | _ -> Error "cannot decode ill-formed combined operation result") + let contents_and_result_list_encoding = - let rec to_list = function - | Contents_and_result_list (Single_and_result (op, res)) -> - [Contents_and_result (op, res)] - | Contents_and_result_list (Cons_and_result (op, res, rest)) -> - Contents_and_result (op, res) :: to_list (Contents_and_result_list rest) - in - let rec of_list = function - | [] -> Error "cannot decode empty combined operation result" - | [Contents_and_result (op, res)] -> - Ok (Contents_and_result_list (Single_and_result (op, res))) - | Contents_and_result (op, res) :: rest -> ( - of_list rest >>? fun (Contents_and_result_list rest) -> - match (op, rest) with - | Manager_operation _, Single_and_result (Manager_operation _, _) -> - Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) - | Manager_operation _, Cons_and_result (_, _, _) -> - Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) - | _ -> Error "cannot decode ill-formed combined operation result") - in - conv_with_guard to_list of_list (Variable.list contents_and_result_encoding) + conv_with_guard + packed_contents_and_result_list_to_list + packed_contents_and_result_list_of_list + (Variable.list contents_and_result_encoding) type 'kind operation_metadata = {contents : 'kind contents_result_list} @@ -2296,11 +2338,11 @@ let operation_metadata_encoding = (fun () -> No_operation_metadata); ] -let kind_equal : +let[@coq_axiom_with_reason "gadt"] kind_equal : type kind kind2. kind contents -> kind2 contents_result -> (kind, kind2) eq option = fun op res -> - match (op, res) with + match[@coq_match_gadt] (op, res) with | Endorsement _, Endorsement_result _ -> Some Eq | Endorsement _, _ -> None | Preendorsement _, Preendorsement_result _ -> Some Eq @@ -2327,13 +2369,12 @@ let kind_equal : (* the Failing_noop operation always fails and can't have result *) None | ( Manager_operation {operation = Reveal _; _}, - Manager_operation_result {operation_result = Applied (Reveal_result _); _} - ) -> - Some Eq + Manager_operation_result {operation_result = Applied applied; _} ) -> ( + match applied with Reveal_result _ -> Some Eq | _ -> None) | ( Manager_operation {operation = Reveal _; _}, - Manager_operation_result - {operation_result = Backtracked (Reveal_result _, _); _} ) -> - Some Eq + Manager_operation_result {operation_result = Backtracked (applied, _); _} + ) -> ( + match applied with Reveal_result _ -> Some Eq | _ -> None) | ( Manager_operation {operation = Reveal _; _}, Manager_operation_result { @@ -2970,13 +3011,13 @@ let rec kind_equal_list : | Some Eq -> Some Eq)) | _ -> None -let[@coq_axiom_with_reason "gadt"] rec pack_contents_list : +let rec pack_contents_list : type kind. kind contents_list -> kind contents_result_list -> kind contents_and_result_list = fun contents res -> - match (contents, res) with + match[@coq_match_with_default] (contents, res) with | Single op, Single_result res -> Single_and_result (op, res) | Cons (op, ops), Cons_result (res, ress) -> Cons_and_result (op, res, pack_contents_list ops ress) @@ -3010,11 +3051,6 @@ let rec unpack_contents_list : let ops, ress = unpack_contents_list rest in (Cons (op, ops), Cons_result (res, ress)) -let rec to_list = function - | Contents_result_list (Single_result o) -> [Contents_result o] - | Contents_result_list (Cons_result (o, os)) -> - Contents_result o :: to_list (Contents_result_list os) - let operation_data_and_metadata_encoding = def "operation.alpha.operation_with_metadata" @@ union diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index 009fbdbbc34073f9fc620b6a72707cb64122cf69..e59d318e5930c6082a0e9770d9a866bbe573c6db 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -401,7 +401,8 @@ val unpack_contents_list : 'kind contents_and_result_list -> 'kind contents_list * 'kind contents_result_list -val to_list : packed_contents_result_list -> packed_contents_result list +val packed_contents_result_list_to_list : + packed_contents_result_list -> packed_contents_result list type ('a, 'b) eq = Eq : ('a, 'a) eq diff --git a/src/proto_alpha/lib_protocol/baking.ml b/src/proto_alpha/lib_protocol/baking.ml index 00bc864d91028aaa0517cd4f0246cf39b2c7a37f..8c5175342eb866cc20d1aa6306844bfb00ff2bc6 100644 --- a/src/proto_alpha/lib_protocol/baking.ml +++ b/src/proto_alpha/lib_protocol/baking.ml @@ -70,7 +70,7 @@ let bonus_baking_reward ctxt ~endorsing_power = Tez.(baking_reward_bonus_per_slot *? Int64.of_int extra_endorsing_power) let baking_rights c level = - let rec f c round = + let[@coq_struct "round"] rec f c round = Stake_distribution.baking_rights_owner c level ~round >>=? fun (c, _slot, (delegate, _)) -> return (LCons (delegate, fun () -> f c (Round.succ round))) diff --git a/src/proto_alpha/lib_protocol/blinded_public_key_hash.ml b/src/proto_alpha/lib_protocol/blinded_public_key_hash.ml index 7b0a3272cc6ee63368f38901f3fcaea1102308de..38a8f65138c2d5b99785bbb699d25a51ad9b7b1b 100644 --- a/src/proto_alpha/lib_protocol/blinded_public_key_hash.ml +++ b/src/proto_alpha/lib_protocol/blinded_public_key_hash.ml @@ -26,15 +26,17 @@ module H = Blake2B.Make (Base58) - (struct - let name = "Blinded public key hash" + (( + struct + let name = "Blinded public key hash" - let title = "A blinded public key hash" + let title = "A blinded public key hash" - let b58check_prefix = "\001\002\049\223" + let b58check_prefix = "\001\002\049\223" - let size = Some Ed25519.Public_key_hash.size - end) + let size = Some Ed25519.Public_key_hash.size + end : + Blake2B.PrefixedName)) module Index : Storage_description.INDEX with type t = H.t = struct include H diff --git a/src/proto_alpha/lib_protocol/bond_id_repr.ml b/src/proto_alpha/lib_protocol/bond_id_repr.ml index 665d0e64d5bfd84534b339dbe8d8fac0936a5346..ad9ce24f1477a6fe277c34be39924a2cb4ff121f 100644 --- a/src/proto_alpha/lib_protocol/bond_id_repr.ml +++ b/src/proto_alpha/lib_protocol/bond_id_repr.ml @@ -74,7 +74,7 @@ let rpc_arg = let starts_with ~prefix s = let open String in let len_s = length s and len_pre = length prefix in - let rec aux i = + let[@coq_struct "i_value"] rec aux i = if Compare.Int.(i = len_pre) then true else if Compare.Char.(get s i <> get prefix i) then false else aux (i + 1) diff --git a/src/proto_alpha/lib_protocol/bootstrap_storage.ml b/src/proto_alpha/lib_protocol/bootstrap_storage.ml index ce7a64777383033371ced4c3243360916cb36d11..cf23520d9cd237ccc43e65ec41ce6e34ea3c3e99 100644 --- a/src/proto_alpha/lib_protocol/bootstrap_storage.ml +++ b/src/proto_alpha/lib_protocol/bootstrap_storage.ml @@ -30,8 +30,8 @@ let init_account (ctxt, balance_updates) Token.transfer ~origin:Protocol_migration ctxt - `Bootstrap - (`Contract contract) + (Source_infinite Bootstrap) + (Sink_container (Contract contract)) amount >>=? fun (ctxt, new_balance_updates) -> (match public_key with @@ -65,7 +65,12 @@ let init_contract ~typecheck (ctxt, balance_updates) | Some delegate -> Delegate_storage.init ctxt contract delegate) >>=? fun ctxt -> let origin = Receipt_repr.Protocol_migration in - Token.transfer ~origin ctxt `Bootstrap (`Contract contract) amount + Token.transfer + ~origin + ctxt + (Source_infinite Bootstrap) + (Sink_container (Contract contract)) + amount >|=? fun (ctxt, new_balance_updates) -> (ctxt, new_balance_updates @ balance_updates) diff --git a/src/proto_alpha/lib_protocol/cache_repr.ml b/src/proto_alpha/lib_protocol/cache_repr.ml index 1fb43b8739c3e10b4ebea58225405215fef7eaf3..2359480d4dc04f473df78ce161b6ce2e379e4d2d 100644 --- a/src/proto_alpha/lib_protocol/cache_repr.ml +++ b/src/proto_alpha/lib_protocol/cache_repr.ml @@ -264,15 +264,17 @@ let register_exn (type cvalue) >>?= fun ctxt -> Admin.find ctxt (mk ~id) >>= function | None -> return None - | Some (K v) -> return (Some v) - | _ -> - (* This execution path is impossible because all the keys of - C's namespace (which is unique to C) are constructed with - [K]. This [assert false] could have been pushed into the - environment in exchange for extra complexity. The - argument that justifies this [assert false] seems - simple enough to keep the current design though. *) - assert false + | Some value -> ( + match value with + | K v -> return (Some v) + | _ -> + (* This execution path is impossible because all the keys of + C's namespace (which is unique to C) are constructed with + [K]. This [assert false] could have been pushed into the + environment in exchange for extra complexity. The + argument that justifies this [assert false] seems + simple enough to keep the current design though. *) + assert false) let list_identifiers ctxt = Admin.list_keys ctxt ~cache_index:C.cache_index |> function diff --git a/src/proto_alpha/lib_protocol/carbonated_map.ml b/src/proto_alpha/lib_protocol/carbonated_map.ml index dcd812c9836c96f0dcaadaeafa8f0bbba966db3e..28e8a3da72ba94868461fbc850c0b0cf97627bba 100644 --- a/src/proto_alpha/lib_protocol/carbonated_map.ml +++ b/src/proto_alpha/lib_protocol/carbonated_map.ml @@ -91,7 +91,16 @@ module type COMPARABLE = sig val compare_cost : t -> Saturation_repr.may_saturate Saturation_repr.t end -module Make_builder (C : COMPARABLE) = struct +module type S_builder = sig + type 'a t + + type key + + module Make (G : GAS) : + S with type key = key and type context = G.context and type 'a t := 'a t +end + +module Make_builder (C : COMPARABLE) : S_builder with type key := C.t = struct module M = Map.Make (C) type 'a t = {map : 'a M.t; size : int} diff --git a/src/proto_alpha/lib_protocol/carbonated_map.mli b/src/proto_alpha/lib_protocol/carbonated_map.mli index 60de5b15667c745e4808cb02b700519700675bce..e175569b172f8139ef36c4f8204e931feff5285b 100644 --- a/src/proto_alpha/lib_protocol/carbonated_map.mli +++ b/src/proto_alpha/lib_protocol/carbonated_map.mli @@ -136,18 +136,22 @@ module type COMPARABLE = sig val compare_cost : t -> Saturation_repr.may_saturate Saturation_repr.t end +module type S_builder = sig + type 'a t + + type key + + module Make (G : GAS) : + S with type key = key and type context = G.context and type 'a t := 'a t +end + (** A functor for exposing the type of a carbonated map before the carbonated make is created. This is useful in scenarios where the map that will need to be carbonated is defined before the gas consuming functions for the carbonation are available. See for example [Raw_context]. *) -module Make_builder (C : COMPARABLE) : sig - type 'a t - - module Make (G : GAS) : - S with type key = C.t and type context = G.context and type 'a t := 'a t -end +module Make_builder (C : COMPARABLE) : S_builder with type key := C.t (** A functor for building gas metered maps. When building a gas metered map via [Make(G)(C)], [C] is a [COMPARABLE] required to construct a the map while diff --git a/src/proto_alpha/lib_protocol/cycle_repr.ml b/src/proto_alpha/lib_protocol/cycle_repr.ml index b1a4b8bc6e0b911d00c46c9581384404781d7a5d..21dc8929c35530633a7cf4cf21c41c8e6d0f1457 100644 --- a/src/proto_alpha/lib_protocol/cycle_repr.ml +++ b/src/proto_alpha/lib_protocol/cycle_repr.ml @@ -34,8 +34,9 @@ let rpc_arg = RPC_arg.like RPC_arg.uint31 ~descr:"A cycle integer" "block_cycle" let pp ppf cycle = Format.fprintf ppf "%ld" cycle -include (Compare.Int32 : Compare.S with type t := t) +module M : Compare.S with type t := t = Compare.Int32 +include M module Map = Map.Make (Compare.Int32) let root = 0l diff --git a/src/proto_alpha/lib_protocol/dal_slot_repr.ml b/src/proto_alpha/lib_protocol/dal_slot_repr.ml index 44539286a8a9796d44fb876633fe85638c199926..7af4fd9b7bf7a2bd1595043c76ea227fca853cdd 100644 --- a/src/proto_alpha/lib_protocol/dal_slot_repr.ml +++ b/src/proto_alpha/lib_protocol/dal_slot_repr.ml @@ -85,26 +85,26 @@ module Slot_market = struct length (fun _ -> None) in - match l with Error msg -> invalid_arg msg | Ok l -> l + match l with Error msg -> invalid_arg msg | Ok l' -> l' let current_fees candidates index = match List.nth candidates index with | None | Some None -> None | Some (Some ((_ : slot), tez)) -> Some tez - let update candidates slot fees = + let update candidates slot' fees = let has_changed = ref false in let may_replace_candidate current_candidate = match current_candidate with | Some ((_slot : slot), current_fees) when Tez_repr.(current_fees >= fees) -> current_candidate - | _ -> Some (slot, fees) + | _ -> Some (slot', fees) in let candidates = List.mapi (fun i candidate -> - if Compare.Int.(i = slot.index) then may_replace_candidate candidate + if Compare.Int.(i = slot'.index) then may_replace_candidate candidate else candidate) candidates in diff --git a/src/proto_alpha/lib_protocol/delegate_storage.ml b/src/proto_alpha/lib_protocol/delegate_storage.ml index d2f0fa7c765693732737e996abd195f996c6f61c..73ae8537e4ed185ca11d1676a33de88b41c0e18e 100644 --- a/src/proto_alpha/lib_protocol/delegate_storage.ml +++ b/src/proto_alpha/lib_protocol/delegate_storage.ml @@ -362,8 +362,8 @@ let distribute_endorsing_rewards ctxt last_cycle unrevealed_nonces = (* Sufficient participation: we pay the rewards *) Token.transfer ctxt - `Endorsing_rewards - (`Contract delegate_contract) + (Source_infinite Endorsing_rewards) + (Sink_container (Contract delegate_contract)) rewards >|=? fun (ctxt, payed_rewards_receipts) -> (ctxt, payed_rewards_receipts @ balance_updates) @@ -371,9 +371,10 @@ let distribute_endorsing_rewards ctxt last_cycle unrevealed_nonces = (* Insufficient participation or unrevealed nonce: no rewards *) Token.transfer ctxt - `Endorsing_rewards - (`Lost_endorsing_rewards - (delegate, not sufficient_participation, not has_revealed_nonces)) + (Source_infinite Endorsing_rewards) + (Sink_infinite + (Lost_endorsing_rewards + (delegate, not sufficient_participation, not has_revealed_nonces))) rewards >|=? fun (ctxt, payed_rewards_receipts) -> (ctxt, payed_rewards_receipts @ balance_updates)) @@ -477,8 +478,8 @@ let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle Token.transfer ~origin ctxt - (`Frozen_deposits delegate) - (`Delegate_balance delegate) + (Source_container (Frozen_deposits delegate)) + (Sink_container (Delegate_balance delegate)) to_reimburse >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates) else if Tez_repr.(current_amount < maximum_stake_to_be_deposited) then @@ -498,8 +499,8 @@ let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle Token.transfer ~origin ctxt - (`Delegate_balance delegate) - (`Frozen_deposits delegate) + (Source_container (Delegate_balance delegate)) + (Sink_container (Frozen_deposits delegate)) to_freeze >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates) else return (ctxt, balance_updates)) @@ -525,8 +526,8 @@ let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle Token.transfer ~origin ctxt - (`Frozen_deposits delegate) - (`Delegate_balance delegate) + (Source_container (Frozen_deposits delegate)) + (Sink_container (Delegate_balance delegate)) frozen_deposits.current_amount >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates) else return (ctxt, balance_updates)) @@ -747,7 +748,7 @@ module Random = struct the sequence and try again). *) Int64.sub Int64.max_int (Int64.rem Int64.max_int bound) in - let rec loop (bytes, n) = + let[@coq_struct "function_parameter"] rec loop (bytes, n) = let consumed_bytes = 8 in let state_size = Bytes.length bytes in if Compare.Int.(n > state_size - consumed_bytes) then @@ -830,8 +831,8 @@ let punish_double_endorsing ctxt delegate (level : Level_repr.t) = in Token.transfer ctxt - (`Frozen_deposits delegate) - `Double_signing_punishments + (Source_container (Frozen_deposits delegate)) + (Sink_infinite Double_signing_punishments) amount_to_burn >>=? fun (ctxt, balance_updates) -> Stake_storage.remove_stake ctxt delegate amount_to_burn >>=? fun ctxt -> @@ -861,8 +862,8 @@ let punish_double_baking ctxt delegate (level : Level_repr.t) = in Token.transfer ctxt - (`Frozen_deposits delegate) - `Double_signing_punishments + (Source_container (Frozen_deposits delegate)) + (Sink_infinite Double_signing_punishments) amount_to_burn >>=? fun (ctxt, balance_updates) -> Stake_storage.remove_stake ctxt delegate amount_to_burn >>=? fun ctxt -> @@ -941,15 +942,22 @@ let record_baking_activity_and_pay_rewards_and_fees ctxt ~payload_producer >>=? fun ctxt -> let pay_payload_producer ctxt delegate = let contract = Contract_repr.Implicit delegate in - Token.balance ctxt `Block_fees >>=? fun (ctxt, block_fees) -> + Token.balance ctxt Block_fees >>=? fun (ctxt, block_fees) -> Token.transfer_n ctxt - [(`Block_fees, block_fees); (`Baking_rewards, baking_reward)] - (`Contract contract) + [ + (Source_container Block_fees, block_fees); + (Source_infinite Baking_rewards, baking_reward); + ] + (Sink_container (Contract contract)) in let pay_block_producer ctxt delegate bonus = let contract = Contract_repr.Implicit delegate in - Token.transfer ctxt `Baking_bonuses (`Contract contract) bonus + Token.transfer + ctxt + (Source_infinite Baking_bonuses) + (Sink_container (Contract contract)) + bonus in pay_payload_producer ctxt payload_producer >>=? fun (ctxt, balance_updates_payload_producer) -> diff --git a/src/proto_alpha/lib_protocol/dependent_bool.ml b/src/proto_alpha/lib_protocol/dependent_bool.ml index 26d5bd7a9b5e43a16518b87ebc688465b9fc4180..e82e863c8822ddd58413e392bc1efd005f868942 100644 --- a/src/proto_alpha/lib_protocol/dependent_bool.ml +++ b/src/proto_alpha/lib_protocol/dependent_bool.ml @@ -36,7 +36,7 @@ type ('a, 'b, 'r) dand = | YesYes : (yes, yes, yes) dand type ('a, 'b) ex_dand = Ex_dand : ('a, 'b, _) dand -> ('a, 'b) ex_dand -[@@unboxed] +[@@unboxed] [@@coq_force_gadt] let dand : type a b. a dbool -> b dbool -> (a, b) ex_dand = fun a b -> @@ -57,7 +57,7 @@ type (_, _) eq = Eq : ('a, 'a) eq let merge_dand : type a b c1 c2. (a, b, c1) dand -> (a, b, c2) dand -> (c1, c2) eq = fun w1 w2 -> - match (w1, w2) with + match[@coq_match_with_default] (w1, w2) with | NoNo, NoNo -> Eq | NoYes, NoYes -> Eq | YesNo, YesNo -> Eq diff --git a/src/proto_alpha/lib_protocol/dependent_bool.mli b/src/proto_alpha/lib_protocol/dependent_bool.mli index 54416d9fd9c3ed36b714b280fedb1cf6bc399293..a5265a36a14f06cfaf1334edec28c3c49a4f7794 100644 --- a/src/proto_alpha/lib_protocol/dependent_bool.mli +++ b/src/proto_alpha/lib_protocol/dependent_bool.mli @@ -46,7 +46,7 @@ type ('a, 'b, 'r) dand = | YesYes : (yes, yes, yes) dand type ('a, 'b) ex_dand = Ex_dand : ('a, 'b, _) dand -> ('a, 'b) ex_dand -[@@unboxed] +[@@unboxed] [@@coq_force_gadt] (** Logical conjunction of dependent booleans. *) val dand : 'a dbool -> 'b dbool -> ('a, 'b) ex_dand diff --git a/src/proto_alpha/lib_protocol/fees_storage.ml b/src/proto_alpha/lib_protocol/fees_storage.ml index 9a378f8eef8b5d1e2e4fc35b76e9cbc60201c676..ef02e16d2167a2d94dbb5ffbcd5ddf1c054f78d3 100644 --- a/src/proto_alpha/lib_protocol/fees_storage.ml +++ b/src/proto_alpha/lib_protocol/fees_storage.ml @@ -78,7 +78,7 @@ let record_paid_storage_space ctxt contract = let source_must_exist c src = match src with - | `Contract src -> Contract_storage.must_exist c src + | Token.Source_container (Contract src) -> Contract_storage.must_exist c src | _ -> return_unit let burn_storage_fees ?(origin = Receipt_repr.Block_application) c @@ -97,7 +97,7 @@ let burn_storage_fees ?(origin = Receipt_repr.Block_application) c trace Cannot_pay_storage_fee ( source_must_exist c payer >>=? fun () -> - Token.transfer ~origin c payer `Storage_fees to_burn + Token.transfer ~origin c payer (Sink_infinite Storage_fees) to_burn >>=? fun (ctxt, balance_updates) -> return (ctxt, remaining, balance_updates) ) diff --git a/src/proto_alpha/lib_protocol/fitness_repr.ml b/src/proto_alpha/lib_protocol/fitness_repr.ml index 8abc162cf54276cb72e2f801a894b922ec4a3422..dcaf851549becb8e0d08a4354834222a7a832ea4 100644 --- a/src/proto_alpha/lib_protocol/fitness_repr.ml +++ b/src/proto_alpha/lib_protocol/fitness_repr.ml @@ -167,10 +167,10 @@ let locked_round_to_bytes = function | Some locked_round -> int32_to_bytes (Round_repr.to_int32 locked_round) let locked_round_of_bytes b = - match Bytes.length b with - | 0 -> ok None - | 4 -> Round_repr.of_int32 (TzEndian.get_int32 b 0) >>? fun r -> ok (Some r) - | _ -> error Invalid_fitness + if Compare.Int.(Bytes.length b = 0) then ok None + else if Compare.Int.(Bytes.length b = 4) then + Round_repr.of_int32 (TzEndian.get_int32 b 0) >>? fun r -> ok (Some r) + else error Invalid_fitness let predecessor_round_of_bytes neg_predecessor_round = int32_of_bytes neg_predecessor_round >>? fun neg_predecessor_round -> diff --git a/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml b/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml index 62831ed1d33b1910b988b612184208391fdf523a..d592d2cada5dc710c5aade098a2af7b0cf0ce023 100644 --- a/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml +++ b/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml @@ -105,7 +105,7 @@ let tx_rollup_l2_address x = let timestamp (tstamp : Script_timestamp.t) : t = Z.numbits (Script_timestamp.to_zint tstamp) / 8 -let rec size_of_comparable_value : +let[@coq_axiom_with_reason "gadts"] rec size_of_comparable_value : type a. a Script_typed_ir.comparable_ty -> a -> t = fun (type a) (wit : a Script_typed_ir.comparable_ty) (v : a) -> match wit with diff --git a/src/proto_alpha/lib_protocol/gas_input_size.ml b/src/proto_alpha/lib_protocol/gas_input_size.ml index 1a35ae6ea9e13d920d3ee52cc4c7952a289a7243..561ac86c9a1a9b9ef75ba28e2934a431cc7bb2dc 100644 --- a/src/proto_alpha/lib_protocol/gas_input_size.ml +++ b/src/proto_alpha/lib_protocol/gas_input_size.ml @@ -52,7 +52,7 @@ let node leaves = let r = List.fold_left ( ++ ) micheline_zero leaves in {r with traversal = r.traversal + 1} -let rec of_micheline (x : ('a, 'b) Micheline.node) = +let[@coq_struct "x_value"] rec of_micheline (x : ('a, 'b) Micheline.node) = match x with | Micheline.Int (_loc, z) -> let int_bytes = integer (Script_int.of_zint z) in diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml index 3597f4bfa47f62d3619f22c944300c827337813d..ba4d9045c060197d30b2455aebeb3824bd925264 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.ml +++ b/src/proto_alpha/lib_protocol/gas_monad.ml @@ -46,7 +46,7 @@ let ( >>?? ) m f = match m with None -> None | Some x -> f x let bind m f gas = m gas >>?? fun (res, gas) -> - match res with Ok y -> f y gas | Error _ as err -> of_result err gas + match res with Ok y -> f y gas | Error err -> of_result (Error err) gas [@@ocaml.inline always] let map f m gas = m gas >>?? fun (x, gas) -> of_result (x >|? f) gas @@ -79,7 +79,7 @@ let run ctxt m = ok (res, ctxt) | None -> error Gas.Operation_quota_exceeded) -let record_trace_eval : +let[@coq_axiom_with_reason "type being matched is not informative enough."] record_trace_eval : type error_trace error_context. error_details:(error_context, error_trace) Script_tc_errors.error_details -> (error_context -> error) -> diff --git a/src/proto_alpha/lib_protocol/global_constants_storage.ml b/src/proto_alpha/lib_protocol/global_constants_storage.ml index f00b2f3330c512b46578e8d1d399acd0d66d7ee7..ee0aa4f00b96c66e791885b2c4503ddd4e818754 100644 --- a/src/proto_alpha/lib_protocol/global_constants_storage.ml +++ b/src/proto_alpha/lib_protocol/global_constants_storage.ml @@ -225,7 +225,7 @@ let expand context expr = with [Expression_too_deep] if greater than [max_allowed_global_constant_depth].*) let check_depth node = - let rec advance node depth k = + let[@coq_struct "node_value"] rec advance node depth k = if Compare.Int.(depth > Constants_repr.max_allowed_global_constant_depth) then error Expression_too_deep else diff --git a/src/proto_alpha/lib_protocol/indexable.ml b/src/proto_alpha/lib_protocol/indexable.ml index 0dce5fd663ed18e12aebb8e224dc25fc3b32cbae..670450c0d98d9ef61fa01f717fc8853aaabd5c88 100644 --- a/src/proto_alpha/lib_protocol/indexable.ml +++ b/src/proto_alpha/lib_protocol/indexable.ml @@ -93,9 +93,9 @@ let forget : type state a. (state, a) t -> (unknown, a) t = function | Hidden_value x | Value x -> Hidden_value x | Hidden_index x | Index x -> Hidden_index x -let to_int32 = function Index x -> x +let to_int32 = function[@coq_match_with_default] Index x -> x -let to_value = function Value x -> x +let to_value = function[@coq_match_with_default] Value x -> x let is_value_e : error:'trace -> ('state, 'a) t -> ('a, 'trace) result = fun ~error v -> @@ -104,7 +104,8 @@ let is_value_e : error:'trace -> ('state, 'a) t -> ('a, 'trace) result = let compact val_encoding = Data_encoding.Compact.( conv - (function Hidden_index x -> Either.Left x | Hidden_value x -> Right x) + (function[@coq_match_with_default] + | Hidden_index x -> Either.Left x | Hidden_value x -> Right x) (function Left x -> Hidden_index x | Right x -> Hidden_value x) @@ or_int32 ~int32_title:"index" ~alt_title:"value" val_encoding) @@ -148,10 +149,13 @@ let compare : | (Hidden_value _ | Value _), (Hidden_index _ | Index _) -> 1 let compare_values c : 'a value -> 'a value -> int = - fun (Value x) (Value y) -> c x y + fun x y -> + match[@coq_match_with_default] (x, y) with Value x, Value y -> c x y let compare_indexes : 'a index -> 'a index -> int = - fun (Index x) (Index y) -> Compare.Int32.compare x y + fun x y -> + match[@coq_match_with_default] (x, y) with + | Index x, Index y -> Compare.Int32.compare x y module type VALUE = sig type t @@ -163,7 +167,41 @@ module type VALUE = sig val pp : Format.formatter -> t -> unit end -module Make (V : VALUE) = struct +module type INDEXABLE = sig + type v_t + + type nonrec 'state t = ('state, v_t) t + + type nonrec index = v_t index + + type nonrec value = v_t value + + type nonrec either = v_t either + + val value : v_t -> value + + val index : int32 -> index tzresult + + val index_exn : int32 -> index + + val compact : either Data_encoding.Compact.t + + val encoding : either Data_encoding.t + + val index_encoding : index Data_encoding.t + + val value_encoding : value Data_encoding.t + + val compare : 'state t -> 'state' t -> int + + val compare_values : value -> value -> int + + val compare_indexes : index -> index -> int + + val pp : Format.formatter -> 'state t -> unit +end + +module Make (V : VALUE) : INDEXABLE with type v_t := V.t = struct type nonrec 'state t = ('state, V.t) t type nonrec index = V.t index @@ -172,28 +210,35 @@ module Make (V : VALUE) = struct type nonrec either = V.t either - let value = value + let value : V.t -> value = value - let index = index + let index : int32 -> index tzresult = index - let index_exn = index_exn + let index_exn : int32 -> index = index_exn - let compact = compact V.encoding + let compact : either Data_encoding.Compact.t = compact V.encoding - let encoding = encoding V.encoding + let encoding : either Data_encoding.t = encoding V.encoding let index_encoding : index Data_encoding.t = Data_encoding.( - conv (fun (Index x) -> x) (fun x -> Index x) Data_encoding.int32) + conv + (fun [@coq_match_with_default] (Index x) -> x) + (fun x -> Index x) + Data_encoding.int32) let value_encoding : value Data_encoding.t = - Data_encoding.(conv (fun (Value x) -> x) (fun x -> Value x) V.encoding) + Data_encoding.( + conv + (fun [@coq_match_with_default] (Value x) -> x) + (fun x -> Value x) + V.encoding) let pp : Format.formatter -> 'state t -> unit = fun fmt x -> pp V.pp fmt x - let compare_values = compare_values V.compare + let compare_values : value -> value -> int = compare_values V.compare - let compare_indexes = compare_indexes + let compare_indexes : index -> index -> int = compare_indexes let compare : 'state t -> 'state' t -> int = fun x y -> compare V.compare x y end diff --git a/src/proto_alpha/lib_protocol/indexable.mli b/src/proto_alpha/lib_protocol/indexable.mli index cc921e802f1f6578af411223f45a41f9757d597f..e71d8926bc4a50d96b27d09101d9ed1297e8cf70 100644 --- a/src/proto_alpha/lib_protocol/indexable.mli +++ b/src/proto_alpha/lib_protocol/indexable.mli @@ -162,16 +162,18 @@ module type VALUE = sig val pp : Format.formatter -> t -> unit end -module Make (V : VALUE) : sig - type nonrec 'state t = ('state, V.t) t +module type INDEXABLE = sig + type v_t - type nonrec index = V.t index + type nonrec 'state t = ('state, v_t) t - type nonrec value = V.t value + type nonrec index = v_t index - type nonrec either = V.t either + type nonrec value = v_t value - val value : V.t -> value + type nonrec either = v_t either + + val value : v_t -> value val index : int32 -> index tzresult @@ -194,4 +196,6 @@ module Make (V : VALUE) : sig val pp : Format.formatter -> 'state t -> unit end +module Make (V : VALUE) : INDEXABLE with type v_t := V.t + type error += Index_cannot_be_negative of int32 diff --git a/src/proto_alpha/lib_protocol/init_storage.ml b/src/proto_alpha/lib_protocol/init_storage.ml index 258702c6e1f02a990bd7d7de728d54bae8edf4d5..670fb7957f4787d3dd9d37e8cdae47400cdafc2f 100644 --- a/src/proto_alpha/lib_protocol/init_storage.ml +++ b/src/proto_alpha/lib_protocol/init_storage.ml @@ -78,8 +78,8 @@ let prepare_first_block _chain_id ctxt ~typecheck ~level ~timestamp = Commitment_repr.{blinded_public_key_hash; amount} = Token.transfer ctxt - `Initial_commitments - (`Collected_commitments blinded_public_key_hash) + (Source_infinite Initial_commitments) + (Sink_container (Collected_commitments blinded_public_key_hash)) amount >>=? fun (ctxt, new_balance_updates) -> return (ctxt, new_balance_updates @ balance_updates) diff --git a/src/proto_alpha/lib_protocol/level_repr.ml b/src/proto_alpha/lib_protocol/level_repr.ml index 0b5926f387f5739ae86379290e958bc48abc9c9f..cc16715354fcbf943ff54f4816f0edf59cc84a93 100644 --- a/src/proto_alpha/lib_protocol/level_repr.ml +++ b/src/proto_alpha/lib_protocol/level_repr.ml @@ -130,7 +130,8 @@ let create_cycle_eras cycle_eras = match cycle_eras with | [] -> error Invalid_cycle_eras | newest_era :: older_eras -> - let rec aux {first_level; first_cycle; _} older_eras = + let rec aux era older_eras = + let {first_level; first_cycle; _} = era in match older_eras with | ({ first_level = first_level_of_previous_era; diff --git a/src/proto_alpha/lib_protocol/level_storage.ml b/src/proto_alpha/lib_protocol/level_storage.ml index 526e64e9638870941134b059a08fc0f847f9f058..53f5a464025510f3a37650630d2188b235ff3d9e 100644 --- a/src/proto_alpha/lib_protocol/level_storage.ml +++ b/src/proto_alpha/lib_protocol/level_storage.ml @@ -73,7 +73,7 @@ let last_level_in_cycle ctxt c = let levels_in_cycle ctxt cycle = let first = first_level_in_cycle ctxt cycle in - let[@coq_struct "n"] rec loop (n : Level_repr.t) acc = + let[@coq_struct "n_value"] rec loop (n : Level_repr.t) acc = if Cycle_repr.(n.cycle = first.cycle) then loop (succ ctxt n) (n :: acc) else acc in @@ -89,7 +89,7 @@ let levels_in_current_cycle ctxt ?(offset = 0l) () = let levels_with_commitments_in_cycle ctxt c = let first = first_level_in_cycle ctxt c in - let[@coq_struct "n"] rec loop (n : Level_repr.t) acc = + let[@coq_struct "n_value"] rec loop (n : Level_repr.t) acc = if Cycle_repr.(n.cycle = first.cycle) then if n.expected_commitment then loop (succ ctxt n) (n :: acc) else loop (succ ctxt n) acc diff --git a/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml b/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml index 4f4d13dfa38ebc7b1bbda76bac8c88d888a15afc..643c0d37608ad2e233490331260feeb47fa12fc4 100644 --- a/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml +++ b/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml @@ -124,20 +124,20 @@ let originate ctxt address_hash ~balance script = ~origin:Protocol_migration ctxt ~storage_limit:(Z.of_int64 Int64.max_int) - ~payer:`Liquidity_baking_subsidies + ~payer:(Source_infinite Liquidity_baking_subsidies) >>=? fun (ctxt, _, origination_updates) -> Fees_storage.burn_storage_fees ~origin:Protocol_migration ctxt ~storage_limit:(Z.of_int64 Int64.max_int) - ~payer:`Liquidity_baking_subsidies + ~payer:(Source_infinite Liquidity_baking_subsidies) size >>=? fun (ctxt, _, storage_updates) -> Token.transfer ~origin:Protocol_migration ctxt - `Liquidity_baking_subsidies - (`Contract address) + (Source_infinite Liquidity_baking_subsidies) + (Sink_container (Contract address)) balance >>=? fun (ctxt, transfer_updates) -> let balance_updates = diff --git a/src/proto_alpha/lib_protocol/merkle_list.ml b/src/proto_alpha/lib_protocol/merkle_list.ml index 9f9aaa0c6da9d1629fa08e2d0137a5bd84fc93cf..93e671434f84eb9fc6c8aa06f48041166fa46ee7 100644 --- a/src/proto_alpha/lib_protocol/merkle_list.ml +++ b/src/proto_alpha/lib_protocol/merkle_list.ml @@ -88,12 +88,14 @@ module type T = sig end end -module Make (El : sig +module type S_El = sig type t val to_bytes : t -> bytes -end) -(H : S.HASH) : T with type elt = El.t and type h = H.t = struct +end + +module Make (El : S_El) (H : S.HASH) : T with type elt = El.t and type h = H.t = +struct type h = H.t type elt = El.t @@ -145,7 +147,7 @@ end) let empty = H.zero - let root = function Empty -> empty | Leaf h -> h | Node (h, _, _) -> h + let root_aux = function Empty -> empty | Leaf h -> h | Node (h, _, _) -> h let nil = {tree = Empty; depth = 0; next_pos = 0} @@ -155,7 +157,7 @@ end) let hash2 h1 h2 = H.(hash_bytes [to_bytes h1; to_bytes h2]) - let node_of t1 t2 = Node (hash2 (root t1) (root t2), t1, t2) + let node_of t1 t2 = Node (hash2 (root_aux t1) (root_aux t2), t1, t2) (* to_bin computes the [depth]-long binary representation of [pos] (left-padding with 0s if required). This corresponds to the tree traversal @@ -164,25 +166,25 @@ end) Pre-condition: pos >= 0 /| pos < 2^depth Post-condition: len(to_bin pos depth) = depth *) let to_bin ~pos ~depth = - let rec aux acc pos depth = + let[@coq_struct "depth"] rec aux acc pos depth = let pos', dir = (pos / 2, pos mod 2) in match depth with | 0 -> acc | d -> aux (Compare.Int.(dir = 1) :: acc) pos' (d - 1) in - aux [] pos depth + aux List.nil pos depth (* Constructs a tree of a given depth in which every right subtree is empty * and the only leaf contains the hash of el. *) let make_spine_with el = - let rec aux left = function + let[@coq_struct "function_parameter"] rec aux left = function | 0 -> left | d -> (aux [@tailcall]) (node_of left Empty) (d - 1) in aux (leaf_of el) let snoc t (el : elt) = - let rec traverse tree depth key = + let[@coq_struct "depth"] rec traverse tree depth key = match (tree, key) with | Node (_, t_left, Empty), true :: _key -> (* The base case where the left subtree is full and we start @@ -209,13 +211,13 @@ end) let tree', depth' = match (t.tree, t.depth, t.next_pos) with | Empty, 0, 0 -> (node_of (leaf_of el) Empty, 1) - | tree, depth, pos when Int32.(equal (shift_left 1l depth) (of_int pos)) - -> - let t_right = make_spine_with el depth in - (node_of tree t_right, depth + 1) | tree, depth, pos -> - let key = to_bin ~pos ~depth in - (traverse tree depth key, depth) + if Int32.(equal (shift_left 1l depth) (of_int pos)) then + let t_right = make_spine_with el depth in + (node_of tree t_right, depth + 1) + else + let key = to_bin ~pos ~depth in + (traverse tree depth key, depth) in {tree = tree'; depth = depth'; next_pos = t.next_pos + 1} @@ -248,18 +250,18 @@ end) let tree', depth' = match (t.tree, t.depth, t.next_pos) with | Empty, 0, 0 -> (node_of (leaf_of el) Empty, 1) - | tree, depth, pos when Int32.(equal (shift_left 1l depth) (of_int pos)) - -> - let t_right = make_spine_with el depth in - (node_of tree t_right, depth + 1) | tree, depth, pos -> - let key = to_bin ~pos ~depth in - (traverse Top tree depth key, depth) + if Int32.(equal (shift_left 1l depth) (of_int pos)) then + let t_right = make_spine_with el depth in + (node_of tree t_right, depth + 1) + else + let key = to_bin ~pos ~depth in + (traverse Top tree depth key, depth) in {tree = tree'; depth = depth'; next_pos = t.next_pos + 1} let rec tree_to_list = function - | Empty -> [] + | Empty -> List.nil | Leaf h -> [h] | Node (_, t_left, t_right) -> tree_to_list t_left @ tree_to_list t_right @@ -280,10 +282,11 @@ end) match (tree, key) with | Leaf _, [] -> ok acc | Node (_, l, r), b :: key -> - if b then aux (root l :: acc) r key else aux (root r :: acc) l key + if b then aux (root_aux l :: acc) r key + else aux (root_aux r :: acc) l key | _ -> error Merkle_list_invalid_position in - aux [] tree key + aux List.nil tree key let check_path path pos el expected_root = let depth = List.length path in @@ -305,17 +308,17 @@ end) let path_depth path = List.length path let compute l = - let rec aux l = + let[@coq_struct "l_value"] rec aux l = let rec pairs acc = function | [] -> List.rev acc | [x] -> List.rev (hash2 x empty :: acc) | x :: y :: xs -> pairs (hash2 x y :: acc) xs in - match pairs [] l with [] -> empty | [h] -> h | pl -> aux pl + match pairs List.nil l with [] -> empty | [h] -> h | pl -> aux pl in aux (List.map hash_elt l) - let root t = root t.tree + let root t = root_aux t.tree module Internal_for_tests = struct let path_to_list x = x diff --git a/src/proto_alpha/lib_protocol/merkle_list.mli b/src/proto_alpha/lib_protocol/merkle_list.mli index 2352d451b773834e1be3246c4e5f41f3a3a9c9ae..8a40dbe749eee0387a94ad1cc802204ac39f9f5e 100644 --- a/src/proto_alpha/lib_protocol/merkle_list.mli +++ b/src/proto_alpha/lib_protocol/merkle_list.mli @@ -107,9 +107,10 @@ module type T = sig end end -module Make (El : sig +module type S_El = sig type t val to_bytes : t -> bytes -end) -(H : S.HASH) : T with type elt = El.t and type h = H.t +end + +module Make (El : S_El) (H : S.HASH) : T with type elt = El.t and type h = H.t diff --git a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml index 39f89d88f157c7f33da62fbd0127fcce6a0465cb..8a6c0bf8d3ade84d42772e54410dc5faef978035 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml @@ -1380,31 +1380,37 @@ module Cost_of = struct | Compare : 'a Script_typed_ir.comparable_ty * 'a * 'a * cont -> cont | Return : cont - let compare : type a. a Script_typed_ir.comparable_ty -> a -> a -> cost = - fun ty x y -> - let rec compare : + module Compare = struct + let[@coq_struct "ty_value"] rec compare : type a. a Script_typed_ir.comparable_ty -> a -> a -> cost -> cont -> cost = fun ty x y acc k -> - match ty with - | Unit_t -> (apply [@tailcall]) Gas.(acc +@ compare_unit) k - | Never_t -> ( match x with _ -> .) - | Bool_t -> (apply [@tailcall]) Gas.(acc +@ compare_bool) k - | String_t -> (apply [@tailcall]) Gas.(acc +@ compare_string x y) k - | Signature_t -> (apply [@tailcall]) Gas.(acc +@ compare_signature) k - | Bytes_t -> (apply [@tailcall]) Gas.(acc +@ compare_bytes x y) k - | Mutez_t -> (apply [@tailcall]) Gas.(acc +@ compare_mutez) k - | Int_t -> (apply [@tailcall]) Gas.(acc +@ compare_int x y) k - | Nat_t -> (apply [@tailcall]) Gas.(acc +@ compare_nat x y) k - | Key_hash_t -> (apply [@tailcall]) Gas.(acc +@ compare_key_hash) k - | Key_t -> (apply [@tailcall]) Gas.(acc +@ compare_key) k - | Timestamp_t -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, x, y) with + | Unit_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_unit) k + | Never_t, _, _ -> . + | Bool_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_bool) k + | String_t, (x : Script_string.t), (y : Script_string.t) -> + (apply [@tailcall]) Gas.(acc +@ compare_string x y) k + | Signature_t, _, _ -> + (apply [@tailcall]) Gas.(acc +@ compare_signature) k + | Bytes_t, (x : bytes), (y : bytes) -> + (apply [@tailcall]) Gas.(acc +@ compare_bytes x y) k + | Mutez_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_mutez) k + | Int_t, (x : _ Script_int.num), (y : _ Script_int.num) -> + (apply [@tailcall]) Gas.(acc +@ compare_int x y) k + | Nat_t, (x : _ Script_int.num), (y : _ Script_int.num) -> + (apply [@tailcall]) Gas.(acc +@ compare_nat x y) k + | Key_hash_t, _, _ -> + (apply [@tailcall]) Gas.(acc +@ compare_key_hash) k + | Key_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_key) k + | Timestamp_t, (x : Script_timestamp.t), (y : Script_timestamp.t) -> (apply [@tailcall]) Gas.(acc +@ compare_timestamp x y) k - | Address_t -> (apply [@tailcall]) Gas.(acc +@ compare_address) k - | Tx_rollup_l2_address_t -> + | Address_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_address) k + | Tx_rollup_l2_address_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_tx_rollup_l2_address) k - | Chain_id_t -> (apply [@tailcall]) Gas.(acc +@ compare_chain_id) k - | Pair_t (tl, tr, _, YesYes) -> + | Chain_id_t, _, _ -> + (apply [@tailcall]) Gas.(acc +@ compare_chain_id) k + | Pair_t (tl, tr, _, YesYes), (x : _ * _), (y : _ * _) -> (* Reasonable over-approximation of the cost of lexicographic comparison. *) let xl, xr = x in let yl, yr = y in @@ -1414,7 +1420,9 @@ module Cost_of = struct yl Gas.(acc +@ compare_pair_tag) (Compare (tr, xr, yr, k)) - | Union_t (tl, tr, _, YesYes) -> ( + | ( Union_t (tl, tr, _, YesYes), + (x : _ Script_typed_ir.union), + (y : _ Script_typed_ir.union) ) -> ( match (x, y) with | L x, L y -> (compare [@tailcall]) tl x y Gas.(acc +@ compare_union_tag) k @@ -1422,7 +1430,7 @@ module Cost_of = struct | R _, L _ -> (apply [@tailcall]) Gas.(acc +@ compare_union_tag) k | R x, R y -> (compare [@tailcall]) tr x y Gas.(acc +@ compare_union_tag) k) - | Option_t (t, _, Yes) -> ( + | Option_t (t, _, Yes), (x : _ option), (y : _ option) -> ( match (x, y) with | None, None -> (apply [@tailcall]) Gas.(acc +@ compare_option_tag) k @@ -1432,13 +1440,15 @@ module Cost_of = struct (apply [@tailcall]) Gas.(acc +@ compare_option_tag) k | Some x, Some y -> (compare [@tailcall]) t x y Gas.(acc +@ compare_option_tag) k) - and apply cost k = + + and[@coq_mutual_as_notation] apply cost k = match k with | Compare (ty, x, y, k) -> (compare [@tailcall]) ty x y cost k | Return -> cost - in - compare ty x y Gas.free Return - [@@coq_axiom_with_reason "non top-level mutually recursive function"] + end + + let compare : type a. a Script_typed_ir.comparable_ty -> a -> a -> cost = + fun ty x y -> Compare.compare ty x y Gas.free Return let set_mem (type a) (elt : a) (set : a Script_typed_ir.set) = let open S_syntax in diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml index 97464d4f6aee189eb4c926f11445fd62a48348c1..a276ff3b819b2c3708d7be8e6f8d3b73cd095d0d 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml @@ -551,8 +551,10 @@ let prim_of_string = function else error (Invalid_case n) let prims_of_strings expr = - let rec convert = function - | (Int _ | String _ | Bytes _) as expr -> ok expr + let[@coq_struct "function_parameter"] rec convert = function + | Int (l, z) -> ok (Int (l, z)) + | String (l, s) -> ok (String (l, s)) + | Bytes (l, b) -> ok (Bytes (l, b)) | Prim (loc, prim, args, annot) -> Error_monad.record_trace (Invalid_primitive_name (expr, loc)) @@ -562,12 +564,12 @@ let prims_of_strings expr = | Seq (loc, args) -> List.map_e convert args >|? fun args -> Seq (loc, args) in convert (root expr) >|? fun expr -> strip_locations expr - [@@coq_axiom_with_reason - "implicit type conversion for expr in the constant cases"] let strings_of_prims expr = - let rec convert = function - | (Int _ | String _ | Bytes _) as expr -> expr + let[@coq_struct "function_parameter"] rec convert = function + | Int (l, z) -> Int (l, z) + | String (l, s) -> String (l, s) + | Bytes (l, b) -> Bytes (l, b) | Prim (loc, prim, args, annot) -> let prim = string_of_prim prim in let args = List.map convert args in @@ -577,8 +579,6 @@ let strings_of_prims expr = Seq (loc, args) in strip_locations (convert (root expr)) - [@@coq_axiom_with_reason - "implicit type conversion for expr in the constant cases"] let prim_encoding = let open Data_encoding in diff --git a/src/proto_alpha/lib_protocol/misc.ml b/src/proto_alpha/lib_protocol/misc.ml index bd350a5ef85b2a35d204d68f06094db9686e565d..2fe3e7075f447d71f269c590e4718e3b0c656698 100644 --- a/src/proto_alpha/lib_protocol/misc.ml +++ b/src/proto_alpha/lib_protocol/misc.ml @@ -31,15 +31,15 @@ type 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t -let[@coq_struct "i"] rec ( --> ) i j = +let[@coq_struct "i_value"] rec ( --> ) i j = (* [i; i+1; ...; j] *) if Compare.Int.(i > j) then [] else i :: (succ i --> j) -let[@coq_struct "j"] rec ( <-- ) i j = +let[@coq_struct "j_value"] rec ( <-- ) i j = (* [j; j-1; ...; i] *) if Compare.Int.(i > j) then [] else j :: (i <-- pred j) -let[@coq_struct "i"] rec ( ---> ) i j = +let[@coq_struct "i_value"] rec ( ---> ) i j = (* [i; i+1; ...; j] *) if Compare.Int32.(i > j) then [] else i :: (Int32.succ i ---> j) diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 4e737928a4def8d3d44538d550c37672c5d86171..2e610b9201d398d72359f08a8f818db4dbe242fb 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -45,6 +45,7 @@ module Kind = struct type 'a double_consensus_operation_evidence = | Double_consensus_operation_evidence + [@@coq_force_gadt] type double_endorsement_evidence = endorsement_consensus_kind double_consensus_operation_evidence @@ -142,15 +143,16 @@ module Kind = struct | Sc_rollup_recover_bond_manager_kind : sc_rollup_recover_bond manager end -type 'a consensus_operation_type = - | Endorsement : Kind.endorsement consensus_operation_type - | Preendorsement : Kind.preendorsement consensus_operation_type +module Consensus_operation_type = struct + type 'a t = + | Endorsement : Kind.endorsement t + | Preendorsement : Kind.preendorsement t -let pp_operation_kind (type kind) ppf - (operation_kind : kind consensus_operation_type) = - match operation_kind with - | Endorsement -> Format.fprintf ppf "Endorsement" - | Preendorsement -> Format.fprintf ppf "Preendorsement" + let pp (type kind) ppf (operation_kind : kind t) = + match operation_kind with + | Endorsement -> Format.fprintf ppf "Endorsement" + | Preendorsement -> Format.fprintf ppf "Preendorsement" +end type consensus_content = { slot : Slot_repr.t; @@ -191,10 +193,14 @@ let pp_consensus_content ppf content = Block_payload_hash.pp_short content.block_payload_hash -type consensus_watermark = - | Endorsement of Chain_id.t - | Preendorsement of Chain_id.t - | Dal_slot_availability of Chain_id.t +module Consensus_watermark = struct + type consensus_watermark = + | Endorsement of Chain_id.t + | Preendorsement of Chain_id.t + | Dal_slot_availability of Chain_id.t +end + +open Consensus_watermark let bytes_of_consensus_watermark = function | Preendorsement chain_id -> @@ -236,6 +242,8 @@ type origination = { credit : Tez_repr.tez; } +type counter = Z.t + type 'kind operation = { shell : Operation.shell_header; protocol_data : 'kind protocol_data; @@ -433,8 +441,6 @@ and _ manager_operation = } -> Kind.sc_rollup_recover_bond manager_operation -and counter = Z.t - let manager_kind : type kind. kind manager_operation -> kind Kind.manager = function | Reveal _ -> Kind.Reveal_manager_kind @@ -583,14 +589,14 @@ module Encoding = struct -> 'kind case [@@coq_force_gadt] - let[@coq_axiom_with_reason "gadt"] reveal_case = + let reveal_case = MCase { tag = 0; name = "reveal"; encoding = obj1 (req "public_key" Signature.Public_key.encoding); select = (function Manager (Reveal _ as op) -> Some op | _ -> None); - proj = (function Reveal pkh -> pkh); + proj = (function[@coq_match_with_default] Reveal pkh -> pkh); inj = (fun pkh -> Reveal pkh); } @@ -611,7 +617,7 @@ module Encoding = struct select = (function Manager (Transaction _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Transaction {amount; destination; parameters; entrypoint} -> let parameters = if @@ -644,7 +650,7 @@ module Encoding = struct select = (function Manager (Origination _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Origination {credit; delegate; script} -> (credit, delegate, script)); inj = @@ -660,11 +666,11 @@ module Encoding = struct encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding); select = (function Manager (Delegation _ as op) -> Some op | _ -> None); - proj = (function Delegation key -> key); + proj = (function[@coq_match_with_default] Delegation key -> key); inj = (fun key -> Delegation key); } - let[@coq_axiom_with_reason "gadt"] register_global_constant_case = + let register_global_constant_case = MCase { tag = 4; @@ -673,11 +679,13 @@ module Encoding = struct select = (function | Manager (Register_global_constant _ as op) -> Some op | _ -> None); - proj = (function Register_global_constant {value} -> value); + proj = + (function[@coq_match_with_default] + | Register_global_constant {value} -> value); inj = (fun value -> Register_global_constant {value}); } - let[@coq_axiom_with_reason "gadt"] set_deposits_limit_case = + let set_deposits_limit_case = MCase { tag = 5; @@ -686,11 +694,12 @@ module Encoding = struct select = (function | Manager (Set_deposits_limit _ as op) -> Some op | _ -> None); - proj = (function Set_deposits_limit key -> key); + proj = + (function[@coq_match_with_default] Set_deposits_limit key -> key); inj = (fun key -> Set_deposits_limit key); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_origination_case = + let tx_rollup_origination_case = MCase { tag = tx_rollup_operation_origination_tag; @@ -699,7 +708,8 @@ module Encoding = struct select = (function | Manager (Tx_rollup_origination as op) -> Some op | _ -> None); - proj = (function Tx_rollup_origination -> ()); + proj = + (function[@coq_match_with_default] Tx_rollup_origination -> ()); inj = (fun () -> Tx_rollup_origination); } @@ -709,7 +719,7 @@ module Encoding = struct encoding which is in hexadecimal for JSON. *) conv Bytes.of_string Bytes.to_string bytes - let[@coq_axiom_with_reason "gadt"] tx_rollup_submit_batch_case = + let tx_rollup_submit_batch_case = MCase { tag = tx_rollup_operation_submit_batch_tag; @@ -723,7 +733,7 @@ module Encoding = struct (function | Manager (Tx_rollup_submit_batch _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Tx_rollup_submit_batch {tx_rollup; content; burn_limit} -> (tx_rollup, content, burn_limit)); inj = @@ -731,7 +741,7 @@ module Encoding = struct Tx_rollup_submit_batch {tx_rollup; content; burn_limit}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case = + let tx_rollup_commit_case = MCase { tag = tx_rollup_operation_commit_tag; @@ -744,14 +754,14 @@ module Encoding = struct (function | Manager (Tx_rollup_commit _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Tx_rollup_commit {tx_rollup; commitment} -> (tx_rollup, commitment)); inj = (fun (tx_rollup, commitment) -> Tx_rollup_commit {tx_rollup; commitment}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_return_bond_case = + let tx_rollup_return_bond_case = MCase { tag = tx_rollup_operation_return_bond_tag; @@ -760,11 +770,13 @@ module Encoding = struct select = (function | Manager (Tx_rollup_return_bond _ as op) -> Some op | _ -> None); - proj = (function Tx_rollup_return_bond {tx_rollup} -> tx_rollup); + proj = + (function[@coq_match_with_default] + | Tx_rollup_return_bond {tx_rollup} -> tx_rollup); inj = (fun tx_rollup -> Tx_rollup_return_bond {tx_rollup}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_finalize_commitment_case = + let tx_rollup_finalize_commitment_case = MCase { tag = tx_rollup_operation_finalize_commitment_tag; @@ -775,11 +787,12 @@ module Encoding = struct | Manager (Tx_rollup_finalize_commitment _ as op) -> Some op | _ -> None); proj = - (function Tx_rollup_finalize_commitment {tx_rollup} -> tx_rollup); + (function[@coq_match_with_default] + | Tx_rollup_finalize_commitment {tx_rollup} -> tx_rollup); inj = (fun tx_rollup -> Tx_rollup_finalize_commitment {tx_rollup}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_remove_commitment_case = + let tx_rollup_remove_commitment_case = MCase { tag = tx_rollup_operation_remove_commitment_tag; @@ -790,11 +803,12 @@ module Encoding = struct | Manager (Tx_rollup_remove_commitment _ as op) -> Some op | _ -> None); proj = - (function Tx_rollup_remove_commitment {tx_rollup} -> tx_rollup); + (function[@coq_match_with_default] + | Tx_rollup_remove_commitment {tx_rollup} -> tx_rollup); inj = (fun tx_rollup -> Tx_rollup_remove_commitment {tx_rollup}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_rejection_case = + let tx_rollup_rejection_case = MCase { tag = tx_rollup_operation_rejection_tag; @@ -823,7 +837,7 @@ module Encoding = struct (function | Manager (Tx_rollup_rejection _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Tx_rollup_rejection { tx_rollup; @@ -873,7 +887,7 @@ module Encoding = struct }); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_dispatch_tickets_case = + let tx_rollup_dispatch_tickets_case = MCase { tag = tx_rollup_operation_dispatch_tickets_tag; @@ -895,7 +909,7 @@ module Encoding = struct | Manager (Tx_rollup_dispatch_tickets _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Tx_rollup_dispatch_tickets { tx_rollup; @@ -929,7 +943,7 @@ module Encoding = struct }); } - let[@coq_axiom_with_reason "gadt"] transfer_ticket_case = + let transfer_ticket_case = MCase { tag = transfer_ticket_tag; @@ -946,7 +960,7 @@ module Encoding = struct (function | Manager (Transfer_ticket _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Transfer_ticket {contents; ty; ticketer; amount; destination; entrypoint} -> (contents, ty, ticketer, amount, destination, entrypoint)); @@ -956,7 +970,7 @@ module Encoding = struct {contents; ty; ticketer; amount; destination; entrypoint}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_originate_case = + let sc_rollup_originate_case = MCase { tag = sc_rollup_operation_origination_tag; @@ -970,7 +984,7 @@ module Encoding = struct (function | Manager (Sc_rollup_originate _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_originate {kind; boot_sector; parameters_ty} -> (kind, boot_sector, parameters_ty)); inj = @@ -991,7 +1005,7 @@ module Encoding = struct inj = (fun slot -> Dal_publish_slot_header {slot}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_add_messages_case = + let sc_rollup_add_messages_case = MCase { tag = sc_rollup_operation_add_message_tag; @@ -1004,14 +1018,14 @@ module Encoding = struct (function | Manager (Sc_rollup_add_messages _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_add_messages {rollup; messages} -> (rollup, messages)); inj = (fun (rollup, messages) -> Sc_rollup_add_messages {rollup; messages}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_cement_case = + let sc_rollup_cement_case = MCase { tag = sc_rollup_operation_cement_tag; @@ -1024,13 +1038,13 @@ module Encoding = struct (function | Manager (Sc_rollup_cement _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_cement {rollup; commitment} -> (rollup, commitment)); inj = (fun (rollup, commitment) -> Sc_rollup_cement {rollup; commitment}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_publish_case = + let sc_rollup_publish_case = MCase { tag = sc_rollup_operation_publish_tag; @@ -1043,7 +1057,7 @@ module Encoding = struct (function | Manager (Sc_rollup_publish _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_publish {rollup; commitment} -> (rollup, commitment)); inj = (fun (rollup, commitment) -> Sc_rollup_publish {rollup; commitment}); @@ -1178,15 +1192,21 @@ module Encoding = struct encoding = consensus_content_encoding; select = (function Contents (Preendorsement _ as op) -> Some op | _ -> None); - proj = (fun (Preendorsement preendorsement) -> preendorsement); + proj = + (fun [@coq_match_with_default] (Preendorsement preendorsement) -> + preendorsement); inj = (fun preendorsement -> Preendorsement preendorsement); } let preendorsement_encoding = - let make (Case {tag; name; encoding; select = _; proj; inj}) = + let make = + fun [@coq_grab_existentials] (Case + {tag; name; encoding; select = _; proj; inj}) + -> case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x) in - let to_list : Kind.preendorsement contents_list -> _ = function + let to_list : Kind.preendorsement contents_list -> _ = + function[@coq_match_with_default] | Single o -> o in let of_list : Kind.preendorsement contents -> _ = function @@ -1208,19 +1228,17 @@ module Encoding = struct @@ union [make preendorsement_case])) (varopt "signature" Signature.encoding))) - let endorsement_encoding = - obj4 - (req "slot" Slot_repr.encoding) - (req "level" Raw_level_repr.encoding) - (req "round" Round_repr.encoding) - (req "block_payload_hash" Block_payload_hash.encoding) - let endorsement_case = Case { tag = 21; name = "endorsement"; - encoding = endorsement_encoding; + encoding = + obj4 + (req "slot" Slot_repr.encoding) + (req "level" Raw_level_repr.encoding) + (req "round" Round_repr.encoding) + (req "block_payload_hash" Block_payload_hash.encoding); select = (function Contents (Endorsement _ as op) -> Some op | _ -> None); proj = @@ -1234,11 +1252,16 @@ module Encoding = struct Endorsement {slot; level; round; block_payload_hash}); } - let[@coq_axiom_with_reason "gadt"] endorsement_encoding = - let make (Case {tag; name; encoding; select = _; proj; inj}) = + let endorsement_encoding = + let make = + fun [@coq_grab_existentials] (Case + {tag; name; encoding; select = _; proj; inj}) + -> case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x) in - let to_list : Kind.endorsement contents_list -> _ = fun (Single o) -> o in + let to_list : Kind.endorsement contents_list -> _ = + fun [@coq_match_with_default] (Single o) -> o + in let of_list : Kind.endorsement contents -> _ = fun o -> Single o in def "inlined.endorsement" @@ conv @@ -1291,11 +1314,13 @@ module Encoding = struct select = (function | Contents (Seed_nonce_revelation _ as op) -> Some op | _ -> None); - proj = (fun (Seed_nonce_revelation {level; nonce}) -> (level, nonce)); + proj = + (fun [@coq_match_with_default] (Seed_nonce_revelation {level; nonce}) -> + (level, nonce)); inj = (fun (level, nonce) -> Seed_nonce_revelation {level; nonce}); } - let[@coq_axiom_with_reason "gadt"] double_preendorsement_evidence_case : + let double_preendorsement_evidence_case : Kind.double_preendorsement_evidence case = Case { @@ -1309,12 +1334,14 @@ module Encoding = struct (function | Contents (Double_preendorsement_evidence _ as op) -> Some op | _ -> None); - proj = (fun (Double_preendorsement_evidence {op1; op2}) -> (op1, op2)); + proj = + (fun [@coq_match_with_default] (Double_preendorsement_evidence + {op1; op2}) -> + (op1, op2)); inj = (fun (op1, op2) -> Double_preendorsement_evidence {op1; op2}); } - let[@coq_axiom_with_reason "gadt"] double_endorsement_evidence_case : - Kind.double_endorsement_evidence case = + let double_endorsement_evidence_case : Kind.double_endorsement_evidence case = Case { tag = 2; @@ -1327,11 +1354,14 @@ module Encoding = struct (function | Contents (Double_endorsement_evidence _ as op) -> Some op | _ -> None); - proj = (fun (Double_endorsement_evidence {op1; op2}) -> (op1, op2)); + proj = + (fun [@coq_match_with_default] (Double_endorsement_evidence + {op1; op2}) -> + (op1, op2)); inj = (fun (op1, op2) -> Double_endorsement_evidence {op1; op2}); } - let[@coq_axiom_with_reason "gadt"] double_baking_evidence_case = + let double_baking_evidence_case = Case { tag = 3; @@ -1343,11 +1373,13 @@ module Encoding = struct select = (function | Contents (Double_baking_evidence _ as op) -> Some op | _ -> None); - proj = (fun (Double_baking_evidence {bh1; bh2}) -> (bh1, bh2)); + proj = + (fun [@coq_match_with_default] (Double_baking_evidence {bh1; bh2}) -> + (bh1, bh2)); inj = (fun (bh1, bh2) -> Double_baking_evidence {bh1; bh2}); } - let[@coq_axiom_with_reason "gadt"] activate_account_case = + let activate_account_case = Case { tag = 4; @@ -1360,13 +1392,14 @@ module Encoding = struct (function | Contents (Activate_account _ as op) -> Some op | _ -> None); proj = - (fun (Activate_account {id; activation_code}) -> + (fun [@coq_match_with_default] (Activate_account + {id; activation_code}) -> (id, activation_code)); inj = (fun (id, activation_code) -> Activate_account {id; activation_code}); } - let[@coq_axiom_with_reason "gadt"] proposals_case = + let proposals_case = Case { tag = 5; @@ -1379,14 +1412,14 @@ module Encoding = struct select = (function Contents (Proposals _ as op) -> Some op | _ -> None); proj = - (fun (Proposals {source; period; proposals}) -> + (fun [@coq_match_with_default] (Proposals {source; period; proposals}) -> (source, period, proposals)); inj = (fun (source, period, proposals) -> Proposals {source; period; proposals}); } - let[@coq_axiom_with_reason "gadt"] ballot_case = + let ballot_case = Case { tag = 6; @@ -1399,7 +1432,7 @@ module Encoding = struct (req "ballot" Vote_repr.ballot_encoding); select = (function Contents (Ballot _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Ballot {source; period; proposal; ballot} -> (source, period, proposal, ballot)); inj = @@ -1438,8 +1471,9 @@ module Encoding = struct Manager_operation {source; fee; counter; gas_limit; storage_limit; operation} - let[@coq_axiom_with_reason "gadt"] make_manager_case tag (type kind) - (Manager_operations.MCase mcase : kind Manager_operations.case) = + let make_manager_case tag (type kind) = + fun [@coq_grab_existentials] (Manager_operations.MCase mcase : + kind Manager_operations.case) -> Case { tag; @@ -1453,7 +1487,7 @@ module Encoding = struct | Some operation -> Some (Manager_operation {op with operation})) | _ -> None); proj = - (function + (function[@coq_match_with_default] | Manager_operation {operation; _} as op -> (extract op, mcase.proj operation)); inj = (fun (op, contents) -> rebuild op (mcase.inj contents)); @@ -1566,13 +1600,16 @@ module Encoding = struct Manager_operations.sc_rollup_recover_bond_case let contents_encoding = - let make (Case {tag; name; encoding; select; proj; inj}) = - case - (Tag tag) - name - encoding - (fun o -> match select o with None -> None | Some o -> Some (proj o)) - (fun x -> Contents (inj x)) + let make case_description = + match[@coq_grab_existentials] case_description with + | Case {tag; name; encoding; select; proj; inj} -> + case + (Tag tag) + name + encoding + (fun o -> + match select o with None -> None | Some o -> Some (proj o)) + (fun x -> Contents (inj x)) in def "operation.alpha.contents" @@ union @@ -1667,7 +1704,7 @@ let raw ({shell; protocol_data} : _ operation) = let acceptable_passes (op : packed_operation) = let (Operation_data protocol_data) = op.protocol_data in - match protocol_data.contents with + match[@coq_match_with_default] protocol_data.contents with | Single (Failing_noop _) -> [] | Single (Preendorsement _) -> [0] | Single (Endorsement _) -> [0] @@ -1739,7 +1776,7 @@ let check_signature (type kind) key chain_id match protocol_data.signature with | None -> error Missing_signature | Some signature -> ( - match protocol_data.contents with + match[@coq_match_with_default] protocol_data.contents with | Single (Preendorsement _) as contents -> check ~watermark:(to_watermark (Preendorsement chain_id)) diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index 0277f6fad073064a31bda4a7c777f8102c317088..dea534d881f7c688febae47cb22b34d176355fa4 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -171,12 +171,13 @@ module Kind : sig | Sc_rollup_recover_bond_manager_kind : sc_rollup_recover_bond manager end -type 'a consensus_operation_type = - | Endorsement : Kind.endorsement consensus_operation_type - | Preendorsement : Kind.preendorsement consensus_operation_type +module Consensus_operation_type : sig + type 'a t = + | Endorsement : Kind.endorsement t + | Preendorsement : Kind.preendorsement t -val pp_operation_kind : - Format.formatter -> 'kind consensus_operation_type -> unit + val pp : Format.formatter -> 'kind t -> unit +end type consensus_content = { slot : Slot_repr.t; @@ -193,10 +194,14 @@ val consensus_content_encoding : consensus_content Data_encoding.t val pp_consensus_content : Format.formatter -> consensus_content -> unit -type consensus_watermark = - | Endorsement of Chain_id.t - | Preendorsement of Chain_id.t - | Dal_slot_availability of Chain_id.t +module Consensus_watermark : sig + type consensus_watermark = + | Endorsement of Chain_id.t + | Preendorsement of Chain_id.t + | Dal_slot_availability of Chain_id.t +end + +open Consensus_watermark val to_watermark : consensus_watermark -> Signature.watermark @@ -212,124 +217,16 @@ type origination = { credit : Tez_repr.tez; } -(** An [operation] contains the operation header information in [shell] - and all data related to the operation itself in [protocol_data]. *) -type 'kind operation = { - shell : Operation.shell_header; - protocol_data : 'kind protocol_data; -} - -(** A [protocol_data] wraps together a signature for the operation and - the contents of the operation itself. *) -and 'kind protocol_data = { - contents : 'kind contents_list; - signature : Signature.t option; -} - -(** A [contents_list] is a list of contents, the GADT guarantees two - invariants: - - the list is not empty, and - - if the list has several elements then it only contains manager - operations. *) -and _ contents_list = - | Single : 'kind contents -> 'kind contents_list - | Cons : - 'kind Kind.manager contents * 'rest Kind.manager contents_list - -> ('kind * 'rest) Kind.manager contents_list - -(** A value of type [contents] an operation related to whether - consensus, governance or contract management. *) -and _ contents = - (* Preendorsement: About consensus, preendorsement of a block held by a - validator (specific to Tenderbake). *) - | Preendorsement : consensus_content -> Kind.preendorsement contents - (* Endorsement: About consensus, endorsement of a block held by a - validator. *) - | Endorsement : consensus_content -> Kind.endorsement contents - (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3115 - - Temporary operation to avoid modifying endorsement encoding. *) - | Dal_slot_availability : - Signature.Public_key_hash.t * Dal_endorsement_repr.t - -> Kind.dal_slot_availability contents - (* Seed_nonce_revelation: Nonces are created by bakers and are - combined to create pseudo-random seeds. Bakers are urged to reveal their - nonces after a given number of cycles to keep their block rewards - from being forfeited. *) - | Seed_nonce_revelation : { - level : Raw_level_repr.t; - nonce : Seed_repr.nonce; - } - -> Kind.seed_nonce_revelation contents - (* Double_preendorsement_evidence: Double-preendorsement is a - kind of malicious attack where a byzantine attempts to fork - the chain by preendorsing blocks with different - contents (at the same level and same round) - twice. This behavior may be reported and the byzantine will have - its security deposit forfeited. *) - | Double_preendorsement_evidence : { - op1 : Kind.preendorsement operation; - op2 : Kind.preendorsement operation; - } - -> Kind.double_preendorsement_evidence contents - (* Double_endorsement_evidence: Similar to double-preendorsement but - for endorsements. *) - | Double_endorsement_evidence : { - op1 : Kind.endorsement operation; - op2 : Kind.endorsement operation; - } - -> Kind.double_endorsement_evidence contents - (* Double_baking_evidence: Similarly to double-endorsement but the - byzantine attempts to fork by signing two different blocks at the - same level. *) - | Double_baking_evidence : { - bh1 : Block_header_repr.t; - bh2 : Block_header_repr.t; - } - -> Kind.double_baking_evidence contents - (* Activate_account: Account activation allows to register a public - key hash on the blockchain. *) - | Activate_account : { - id : Ed25519.Public_key_hash.t; - activation_code : Blinded_public_key_hash.activation_code; - } - -> Kind.activate_account contents - (* Proposals: A candidate protocol can be proposed for voting. *) - | Proposals : { - source : Signature.Public_key_hash.t; - period : int32; - proposals : Protocol_hash.t list; - } - -> Kind.proposals contents - (* Ballot: The validators of the chain will then vote on proposals. *) - | Ballot : { - source : Signature.Public_key_hash.t; - period : int32; - proposal : Protocol_hash.t; - ballot : Vote_repr.ballot; - } - -> Kind.ballot contents - (* Failing_noop: An operation never considered by the state machine - and which will always fail at [apply]. This allows end-users to - sign arbitrary messages which have no computational semantics. *) - | Failing_noop : string -> Kind.failing_noop contents - (* Manager_operation: Operations, emitted and signed by - a (revealed) implicit account, that describe management and - interactions between contracts (whether implicit or - smart). *) - | Manager_operation : { - source : Signature.Public_key_hash.t; - fee : Tez_repr.tez; - counter : counter; - operation : 'kind manager_operation; - gas_limit : Gas_limit_repr.Arith.integral; - storage_limit : Z.t; - } - -> 'kind Kind.manager contents +(** Counters are used as anti-replay protection mechanism in + manager operations: each manager account stores a counter and + each manager operation declares a value for the counter. When + a manager operation is applied, the value of the counter of + its manager is checked and incremented. *) +type counter = Z.t (** A [manager_operation] describes management and interactions between contracts (whether implicit or smart). *) -and _ manager_operation = +type _ manager_operation = (* [Reveal] for the revelation of a public key, a one-time prerequisite to any signed operation, in order to be able to check the sender’s signature. *) @@ -507,12 +404,120 @@ and _ manager_operation = } -> Kind.sc_rollup_recover_bond manager_operation -(** Counters are used as anti-replay protection mechanism in - manager operations: each manager account stores a counter and - each manager operation declares a value for the counter. When - a manager operation is applied, the value of the counter of - its manager is checked and incremented. *) -and counter = Z.t +(** An [operation] contains the operation header information in [shell] + and all data related to the operation itself in [protocol_data]. *) +type 'kind operation = { + shell : Operation.shell_header; + protocol_data : 'kind protocol_data; +} + +(** A [protocol_data] wraps together a signature for the operation and + the contents of the operation itself. *) +and 'kind protocol_data = { + contents : 'kind contents_list; + signature : Signature.t option; +} + +(** A [contents_list] is a list of contents, the GADT guarantees two + invariants: + - the list is not empty, and + - if the list has several elements then it only contains manager + operations. *) +and _ contents_list = + | Single : 'kind contents -> 'kind contents_list + | Cons : + 'kind Kind.manager contents * 'rest Kind.manager contents_list + -> ('kind * 'rest) Kind.manager contents_list + +(** A value of type [contents] an operation related to whether + consensus, governance or contract management. *) +and _ contents = + (* Preendorsement: About consensus, preendorsement of a block held by a + validator (specific to Tenderbake). *) + | Preendorsement : consensus_content -> Kind.preendorsement contents + (* Endorsement: About consensus, endorsement of a block held by a + validator. *) + | Endorsement : consensus_content -> Kind.endorsement contents + (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3115 + + Temporary operation to avoid modifying endorsement encoding. *) + | Dal_slot_availability : + Signature.Public_key_hash.t * Dal_endorsement_repr.t + -> Kind.dal_slot_availability contents + (* Seed_nonce_revelation: Nonces are created by bakers and are + combined to create pseudo-random seeds. Bakers are urged to reveal their + nonces after a given number of cycles to keep their block rewards + from being forfeited. *) + | Seed_nonce_revelation : { + level : Raw_level_repr.t; + nonce : Seed_repr.nonce; + } + -> Kind.seed_nonce_revelation contents + (* Double_preendorsement_evidence: Double-preendorsement is a + kind of malicious attack where a byzantine attempts to fork + the chain by preendorsing blocks with different + contents (at the same level and same round) + twice. This behavior may be reported and the byzantine will have + its security deposit forfeited. *) + | Double_preendorsement_evidence : { + op1 : Kind.preendorsement operation; + op2 : Kind.preendorsement operation; + } + -> Kind.double_preendorsement_evidence contents + (* Double_endorsement_evidence: Similar to double-preendorsement but + for endorsements. *) + | Double_endorsement_evidence : { + op1 : Kind.endorsement operation; + op2 : Kind.endorsement operation; + } + -> Kind.double_endorsement_evidence contents + (* Double_baking_evidence: Similarly to double-endorsement but the + byzantine attempts to fork by signing two different blocks at the + same level. *) + | Double_baking_evidence : { + bh1 : Block_header_repr.t; + bh2 : Block_header_repr.t; + } + -> Kind.double_baking_evidence contents + (* Activate_account: Account activation allows to register a public + key hash on the blockchain. *) + | Activate_account : { + id : Ed25519.Public_key_hash.t; + activation_code : Blinded_public_key_hash.activation_code; + } + -> Kind.activate_account contents + (* Proposals: A candidate protocol can be proposed for voting. *) + | Proposals : { + source : Signature.Public_key_hash.t; + period : int32; + proposals : Protocol_hash.t list; + } + -> Kind.proposals contents + (* Ballot: The validators of the chain will then vote on proposals. *) + | Ballot : { + source : Signature.Public_key_hash.t; + period : int32; + proposal : Protocol_hash.t; + ballot : Vote_repr.ballot; + } + -> Kind.ballot contents + (* Failing_noop: An operation never considered by the state machine + and which will always fail at [apply]. This allows end-users to + sign arbitrary messages which have no computational semantics. *) + | Failing_noop : string -> Kind.failing_noop contents + (* Manager_operation: Operations, emitted and signed by + a (revealed) implicit account, that describe management and + interactions between contracts (whether implicit or + smart). *) + | Manager_operation : { + source : Signature.Public_key_hash.t; + fee : Tez_repr.tez; + counter : counter; + operation : 'kind manager_operation; + gas_limit : Gas_limit_repr.Arith.integral; + storage_limit : Z.t; + } + -> 'kind Kind.manager contents type packed_manager_operation = | Manager : 'kind manager_operation -> packed_manager_operation diff --git a/src/proto_alpha/lib_protocol/period_repr.ml b/src/proto_alpha/lib_protocol/period_repr.ml index 1f2de5752be8f7b2b1b8a571fff948620bbfec7b..23a0aa1da5086f44e479b3dd8bbd02670020a8b9 100644 --- a/src/proto_alpha/lib_protocol/period_repr.ml +++ b/src/proto_alpha/lib_protocol/period_repr.ml @@ -101,7 +101,9 @@ module Internal : INTERNAL = struct let pp ppf v = Format.fprintf ppf "%Ld" v - include (Compare.Int64 : Compare.S with type t := t) + module M : Compare.S with type t := t = Compare.Int64 + + include M let zero = 0L diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index f14d37096401f7938221f23a4d9fcd6eca786fbd..8d18cdb66f499cff585ae250a1b7257ddcdee7d1 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -1118,7 +1118,7 @@ let fold ?depth ctxt k ~order ~init ~f = let config ctxt = Context.config (context ctxt) -module Proof = Context.Proof +(* module Proof = Context.Proof *) let length ctxt key = Context.length (context ctxt) key @@ -1467,6 +1467,76 @@ module Sc_rollup_in_memory_inbox = struct {ctxt with back} end +(** Explicit module to present this file as a record in Coq and reduce the size + of the generated Coq code. *) +module M : T with type t = root = struct + type t = root + + type error += Block_quota_exceeded = Block_quota_exceeded + + type error += Operation_quota_exceeded = Operation_quota_exceeded + + let mem = mem + + let mem_tree = mem_tree + + let get = get + + let get_tree = get_tree + + let find = find + + let find_tree = find_tree + + let list = list + + let init = init + + let init_tree = init_tree + + let update = update + + let update_tree = update_tree + + let add = add + + let add_tree = add_tree + + let remove = remove + + let remove_existing = remove_existing + + let remove_existing_tree = remove_existing_tree + + let add_or_remove = add_or_remove + + let add_or_remove_tree = add_or_remove_tree + + let fold = fold + + let config = config + + module Tree = Tree + + let verify_tree_proof = verify_tree_proof + + let verify_stream_proof = verify_stream_proof + + let equal_config = equal_config + + let project : t -> root = project + + let absolute_key : t -> key -> key = absolute_key + + let consume_gas = consume_gas + + let check_enough_gas = check_enough_gas + + let description : t Storage_description.t = description + + let length = length +end + module Dal = struct let record_available_shards ctxt slots shards = let dal_endorsement_slot_accountability = diff --git a/src/proto_alpha/lib_protocol/raw_context.mli b/src/proto_alpha/lib_protocol/raw_context.mli index 906b187e6930ab1deaec7a56586861f0b2bf9bf2..ab01f1ff50bd8e8acf34bfa7ebd084fd1a1b1350 100644 --- a/src/proto_alpha/lib_protocol/raw_context.mli +++ b/src/proto_alpha/lib_protocol/raw_context.mli @@ -408,3 +408,5 @@ module Dal : sig [endorser] for the current level. *) val shards : t -> endorser:Signature.Public_key_hash.t -> int list end + +module M : T with type t = root diff --git a/src/proto_alpha/lib_protocol/raw_context_intf.ml b/src/proto_alpha/lib_protocol/raw_context_intf.ml index 39c8b058d78aa7a682d24b1d8e9095c4cb5a2645..259f9659a06df05ae9e0ae47303e74296fe5d928 100644 --- a/src/proto_alpha/lib_protocol/raw_context_intf.ml +++ b/src/proto_alpha/lib_protocol/raw_context_intf.ml @@ -28,9 +28,6 @@ as-is for direct context accesses, and used in {!Storage_functors} to provide restricted views to the context. *) -(** The tree depth of a fold. See the [fold] function for more information. *) -type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int] - (** The type for context configuration. If two trees or stores have the same configuration, they will generate the same context hash. *) type config = Context.config @@ -173,7 +170,7 @@ module type VIEW = sig lexicographic order of their keys. For large nodes, it is memory-consuming, use [`Undefined] for a more memory efficient [fold]. *) val fold : - ?depth:depth -> + ?depth:Context.depth -> t -> key -> order:[`Sorted | `Undefined] -> @@ -201,10 +198,6 @@ module type VIEW = sig val length : t -> key -> int Lwt.t end -module Kind = struct - type t = [`Value | `Tree] -end - module type TREE = sig (** [Tree] provides immutable, in-memory partial mirror of the context, with lazy reads and delayed writes. The trees are Merkle @@ -233,7 +226,7 @@ module type TREE = sig (** [kind t] is [t]'s kind. It's either a tree node or a leaf value. *) - val kind : tree -> Kind.t + val kind : tree -> Context.Kind.t (** [to_value t] is an Lwt promise that resolves to [Some v] if [t] is a leaf tree and [None] otherwise. It is equivalent to [find t @@ -254,203 +247,6 @@ module type TREE = sig val clear : ?depth:int -> tree -> unit end -module type PROOF = sig - (** Proofs are compact representations of trees which can be shared - between peers. - - This is expected to be used as follows: - - - A first peer runs a function [f] over a tree [t]. While performing - this computation, it records: the hash of [t] (called [before] - below), the hash of [f t] (called [after] below) and a subset of [t] - which is needed to replay [f] without any access to the first peer's - storage. Once done, all these informations are packed into a proof of - type [t] that is sent to the second peer. - - - The second peer generates an initial tree [t'] from [p] and computes - [f t']. Once done, it compares [t']'s hash and [f t']'s hash to [before] - and [after]. If they match, they know that the result state [f t'] is a - valid context state, without having to have access to the full storage - of the first peer. *) - - (** The type for file and directory names. *) - type step = string - - (** The type for values. *) - type value = bytes - - (** The type of indices for inodes' children. *) - type index = int - - (** The type for hashes. *) - type hash = Context_hash.t - - (** The type for (internal) inode proofs. - - These proofs encode large directories into a tree-like structure. This - reflects irmin-pack's way of representing nodes and computing - hashes (tree-like representations for nodes scales better than flat - representations). - - [length] is the total number of entries in the children of the inode. - It's the size of the "flattened" version of that inode. [length] can be - used to prove the correctness of operations such [Tree.length] and - [Tree.list ~offset ~length] in an efficient way. - - In proofs with [version.is_binary = false], an inode at depth 0 has a - [length] of at least [257]. Below that threshold a [Node] tag is used in - [tree]. That threshold is [3] when [version.is_binary = true]. - - [proofs] contains the children proofs. It is a sparse list of ['a] values. - These values are associated to their index in the list, and the list is - kept sorted in increasing order of indices. ['a] can be a concrete proof - or a hash of that proof. - - In proofs with [version.is_binary = true], inodes have at most 2 proofs - (indexed 0 or 1). - - In proofs with [version.is_binary = false], inodes have at most 32 proofs - (indexed from 0 to 31). *) - type 'a inode = {length : int; proofs : (index * 'a) list} - - (** The type for inode extenders. - - An extender is a compact representation of a sequence of [inode] which - contain only one child. As for inodes, The ['a] parameter can be a - concrete proof or a hash of that proof. - - If an inode proof contains singleton children [i_0, ..., i_n] such as: - [{length=l; proofs = [ (i_0, {proofs = ... { proofs = [ (i_n, p) ] }})]}], - then it is compressed into the inode extender - [{length=l; segment = [i_0;..;i_n]; proof=p}] sharing the same lenght [l] - and final proof [p]. *) - type 'a inode_extender = {length : int; segment : index list; proof : 'a} - - (** The type for compressed and partial Merkle tree proofs. - - Tree proofs do not provide any guarantee with the ordering of - computations. For instance, if two effects commute, they won't be - distinguishable by this kind of proofs. - - [Value v] proves that a value [v] exists in the store. - - [Blinded_value h] proves a value with hash [h] exists in the store. - - [Node ls] proves that a a "flat" node containing the list of files [ls] - exists in the store. - - In proofs with [version.is_binary = true], the length of [ls] is at most - 2. - - In proofs with [version.is_binary = false], the length of [ls] is at most - 256. - - [Blinded_node h] proves that a node with hash [h] exists in the store. - - [Inode i] proves that an inode [i] exists in the store. - - [Extender e] proves that an inode extender [e] exist in the store. *) - type tree = - | Value of value - | Blinded_value of hash - | Node of (step * tree) list - | Blinded_node of hash - | Inode of inode_tree inode - | Extender of inode_tree inode_extender - - (** The type for inode trees. It is a subset of [tree], limited to nodes. - - [Blinded_inode h] proves that an inode with hash [h] exists in the store. - - [Inode_values ls] is simliar to trees' [Node]. - - [Inode_tree i] is similar to tree's [Inode]. - - [Inode_extender e] is similar to trees' [Extender]. *) - and inode_tree = - | Blinded_inode of hash - | Inode_values of (step * tree) list - | Inode_tree of inode_tree inode - | Inode_extender of inode_tree inode_extender - - (** The type for kinded hashes. *) - type kinded_hash = [`Value of hash | `Node of hash] - - module Stream : sig - (** Stream proofs represent an explicit traversal of a Merle tree proof. - Every element (a node, a value, or a shallow pointer) met is first - "compressed" by shallowing its children and then recorded in the proof. - - As stream proofs directly encode the recursive construction of the - Merkle root hash is slightly simpler to implement: verifier simply - need to hash the compressed elements lazily, without any memory or - choice. - - Moreover, the minimality of stream proofs is trivial to check. - Once the computation has consumed the compressed elements required, - it is sufficient to check that no more compressed elements remain - in the proof. - - However, as the compressed elements contain all the hashes of their - shallow children, the size of stream proofs is larger - (at least double in size in practice) than tree proofs, which only - contains the hash for intermediate shallow pointers. *) - - (** The type for elements of stream proofs. - - [Value v] is a proof that the next element read in the store is the - value [v]. - - [Node n] is a proof that the next element read in the store is the - node [n]. - - [Inode i] is a proof that the next element read in the store is the - inode [i]. - - [Inode_extender e] is a proof that the next element read in the store - is the node extender [e]. *) - type elt = - | Value of value - | Node of (step * kinded_hash) list - | Inode of hash inode - | Inode_extender of hash inode_extender - - (** The type for stream proofs. - - The sequance [e_1 ... e_n] proves that the [e_1], ..., [e_n] are - read in the store in sequence. *) - type t = elt Seq.t - end - - type stream = Stream.t - - (** The type for proofs of kind ['a]. - - A proof [p] proves that the state advanced from [before p] to - [after p]. [state p]'s hash is [before p], and [state p] contains - the minimal information for the computation to reach [after p]. - - [version p] is the proof version, it packs several informations. - - [is_stream] discriminates between the stream proofs and the tree proofs. - - [is_binary] discriminates between proofs emitted from - [Tezos_context(_memory).Context_binary] and - [Tezos_context(_memory).Context]. - - It will also help discriminate between the data encoding techniques used. - - The version is meant to be decoded and encoded using the - {!Tezos_context_helpers.Context.decode_proof_version} and - {!Tezos_context_helpers.Context.encode_proof_version}. *) - type 'a t = { - version : int; - before : kinded_hash; - after : kinded_hash; - state : 'a; - } -end - module type T = sig (** The type for root contexts. *) type root @@ -464,8 +260,6 @@ module type T = sig and type value := value and type tree := tree - module Proof : PROOF - (** [verify p f] runs [f] in checking mode. [f] is a function that takes a tree as input and returns a new version of the tree and a result. [p] is a proof, that is a minimal representation of the tree that contains what [f] @@ -517,7 +311,7 @@ module type T = sig Guarantee that the given computation performs exactly the same state operations as the generating computation, *in some order*. *) - type tree_proof := Proof.tree Proof.t + type tree_proof := Context.Proof.tree Context.Proof.t (** [verify_tree_proof] is the verifier of tree proofs. *) val verify_tree_proof : (tree_proof, 'a) verifier @@ -526,7 +320,7 @@ module type T = sig Guarantee that the given computation performs exactly the same state operations as the generating computation, in the exact same order. *) - type stream_proof := Proof.stream Proof.t + type stream_proof := Context.Proof.stream Context.Proof.t (** [verify_stream] is the verifier of stream proofs. *) val verify_stream_proof : (stream_proof, 'a) verifier diff --git a/src/proto_alpha/lib_protocol/raw_level_repr.ml b/src/proto_alpha/lib_protocol/raw_level_repr.ml index 82aa2ef9b5d76047f7c135a6fb21d1370197a924..78b27029aec2252371149e4de946253b78940357 100644 --- a/src/proto_alpha/lib_protocol/raw_level_repr.ml +++ b/src/proto_alpha/lib_protocol/raw_level_repr.ml @@ -27,7 +27,9 @@ type t = int32 type raw_level = t -include (Compare.Int32 : Compare.S with type t := t) +module M : Compare.S with type t := t = Compare.Int32 + +include M let pp ppf level = Format.fprintf ppf "%ld" level diff --git a/src/proto_alpha/lib_protocol/round_repr.ml b/src/proto_alpha/lib_protocol/round_repr.ml index 4f8c5c7b20eec2f0e55ad77ac757c9848a27e19b..086e8e8acc46896967075f8bda90eba06ddff70d 100644 --- a/src/proto_alpha/lib_protocol/round_repr.ml +++ b/src/proto_alpha/lib_protocol/round_repr.ml @@ -29,7 +29,9 @@ type t = round module Map = Map.Make (Int32) -include (Compare.Int32 : Compare.S with type t := t) +module M : Compare.S with type t := t = Compare.Int32 + +include M let zero = 0l @@ -107,7 +109,7 @@ let encoding = (fun i -> i) (fun i -> match of_int32 i with - | Ok _ as res -> res + | Ok round -> Ok round | Error _ -> Error "Round_repr.encoding: negative round") Data_encoding.int32 diff --git a/src/proto_alpha/lib_protocol/sampler.ml b/src/proto_alpha/lib_protocol/sampler.ml index 043e05945f86e279182030da08d26ca0b3746049..1aab07130e6e3c774ee7fac961c478dddfea7c28 100644 --- a/src/proto_alpha/lib_protocol/sampler.ml +++ b/src/proto_alpha/lib_protocol/sampler.ml @@ -74,7 +74,7 @@ module Make (Mass : SMass) : S with type mass = Mass.t = struct alias : int FallbackArray.t; } - let rec init_loop total p alias small large = + let[@coq_struct "small"] rec init_loop total p alias small large = match (small, large) with | [], _ -> List.iter (fun (_, i) -> FallbackArray.set p i total) large | _, [] -> diff --git a/src/proto_alpha/lib_protocol/sapling_repr.ml b/src/proto_alpha/lib_protocol/sapling_repr.ml index 5b9a1586d73fe7e46e7bc4c9d07615ebdc325fee..52551d4682ff31625bebc2d3b1e3c968c97ca6bb 100644 --- a/src/proto_alpha/lib_protocol/sapling_repr.ml +++ b/src/proto_alpha/lib_protocol/sapling_repr.ml @@ -25,6 +25,8 @@ type transaction = Sapling.UTXO.transaction +type legacy_transaction = Sapling.UTXO.Legacy.transaction + let transaction_encoding = Sapling.UTXO.transaction_encoding (* The two data structures in the state are all ordered by position, a diff diff --git a/src/proto_alpha/lib_protocol/sapling_storage.ml b/src/proto_alpha/lib_protocol/sapling_storage.ml index 3f151b75784725fc27024965b1aad5d2ae943e85..88a33e62396959d745dcaa39245c73cdccf4a20d 100644 --- a/src/proto_alpha/lib_protocol/sapling_storage.ml +++ b/src/proto_alpha/lib_protocol/sapling_storage.ml @@ -240,7 +240,7 @@ module Ciphertexts = struct let add ctx id c pos = Storage.Sapling.Ciphertexts.init (ctx, id) pos c let get_from ctx id offset = - let rec aux (ctx, acc) pos = + let[@coq_struct "function_parameter"] rec aux (ctx, acc) pos = Storage.Sapling.Ciphertexts.find (ctx, id) pos >>=? fun (ctx, c) -> match c with | None -> return (ctx, List.rev acc) @@ -319,7 +319,7 @@ module Roots = struct let mem ctx id root = Storage.Sapling.Roots_pos.get (ctx, id) >>=? fun start_pos -> - let rec aux pos = + let[@coq_struct "pos"] rec aux pos = Storage.Sapling.Roots.get (ctx, id) pos >>=? fun hash -> if Compare.Int.(Sapling.Hash.compare hash root = 0) then return true else diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index 2fceb16ac63bf231729a1098e23194dd6bd236f5..26d03fbd0ba2727f5539142c62d1369dc34d9218 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -286,7 +286,7 @@ module Make (Context : P) : open Monad - module MakeVar (P : sig + module type P_MakeVar = sig type t val name : string @@ -296,8 +296,21 @@ module Make (Context : P) : val pp : Format.formatter -> t -> unit val encoding : t Data_encoding.t - end) = - struct + end + + module type S_MakeVar = sig + type t + + val create : unit Monad.t + + val get : t Monad.t + + val set : t -> unit Monad.t + + val pp : (Format.formatter -> unit -> unit) Monad.t + end + + module MakeVar (P : P_MakeVar) : S_MakeVar with type t := P.t = struct let key = [P.name] let create = set_value key P.encoding P.initial @@ -319,7 +332,7 @@ module Make (Context : P) : return @@ fun fmt () -> Format.fprintf fmt "@[%s : %a@]" P.name P.pp v end - module MakeDict (P : sig + module type P_MakeDict = sig type t val name : string @@ -327,8 +340,21 @@ module Make (Context : P) : val pp : Format.formatter -> t -> unit val encoding : t Data_encoding.t - end) = - struct + end + + module type MakeDict_sig = sig + type t + + val get : string -> t option Monad.t + + val set : string -> t -> unit Monad.t + + val mapped_to : string -> t -> state -> bool Lwt.t + + val pp : (Format.formatter -> unit -> unit) Monad.t + end + + module MakeDict (P : P_MakeDict) : MakeDict_sig with type t := P.t = struct let key k = [P.name; k] let get k = find_value (key k) P.encoding @@ -338,8 +364,8 @@ module Make (Context : P) : let mapped_to k v state = let open Lwt_syntax in let* state', _ = Monad.(run (set k v) state) in - let* t = Tree.find_tree state (key k) - and* t' = Tree.find_tree state' (key k) in + let* t = Tree.find_tree state (key k) in + let* t' = Tree.find_tree state' (key k) in Lwt.return (Option.equal Tree.equal t t') let pp = @@ -351,13 +377,31 @@ module Make (Context : P) : return @@ fun fmt () -> Format.pp_print_list pp_elem fmt l end - module MakeDeque (P : sig + module type P_MakeDeque = sig type t val name : string val encoding : t Data_encoding.t - end) = + end + + module type MakeDeque_sig = sig + type t + + val top : t option Monad.t + + val push : t -> unit Monad.t + + val pop : t option Monad.t + + val inject : t -> unit Monad.t + + val to_list : t list Monad.t + + val clear : unit Monad.t + end + + module MakeDeque (P : P_MakeDeque) : MakeDeque_sig with type t := P.t = struct (* @@ -427,7 +471,7 @@ module Make (Context : P) : let open Monad.Syntax in let* head_idx = get_head in let* end_idx = get_end in - let rec aux l idx = + let[@coq_struct "idx"] rec aux l idx = if Z.(lt idx head_idx) then return l else let* v = find_value (idx_key idx) P.encoding in @@ -441,9 +485,15 @@ module Make (Context : P) : end module CurrentTick = MakeVar (struct - include Sc_rollup_tick_repr + type t = Sc_rollup_tick_repr.t let name = "tick" + + let initial = Sc_rollup_tick_repr.initial + + let pp = Sc_rollup_tick_repr.pp + + let encoding = Sc_rollup_tick_repr.encoding end) module Vars = MakeDict (struct diff --git a/src/proto_alpha/lib_protocol/sc_rollup_errors.ml b/src/proto_alpha/lib_protocol/sc_rollup_errors.ml index b716a3a793d0e0ee56c7e56279ac615f872994dd..5d17a2d627c703bfebe943266db79d4f3e4c15b0 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_errors.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_errors.ml @@ -63,7 +63,7 @@ type error += min_expected_balance : Tez_repr.t; } -let () = +let[@coq_axiom_with_reason "Polymorphic variant."] () = register_error_kind `Temporary ~id:"Sc_rollup_max_number_of_available_messages_reached" diff --git a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml index 7077617212618c55660f17e75fbcacc3053740d8..3ea3369d89f43ca05713a2ccbb24415305d33b7e 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml @@ -333,7 +333,7 @@ let game_error reason = let find_choice game tick = let open Lwt_result_syntax in - let rec traverse states = + let[@coq_struct "states"] rec traverse states = match states with | (state, state_tick) :: (next_state, next_tick) :: others -> if Sc_rollup_tick_repr.(tick = state_tick) then @@ -404,7 +404,7 @@ let check_dissection start start_tick stop stop_tick dissection = stop_tick)) | _ -> game_error "Dissection should contain at least 2 elements" in - let rec traverse states = + let[@coq_struct "states"] rec traverse states = match states with | (None, _) :: (Some _, _) :: _ -> game_error "Cannot return to a Some state after being at a None state" @@ -496,5 +496,7 @@ let play game refutation = in match result with | Ok x -> Lwt.return x - | Error (Game_error e) -> Lwt.return @@ game_over e - | Error _ -> Lwt.return @@ game_over "undefined" + | Error e -> ( + match e with + | Game_error e -> Lwt.return @@ game_over e + | _ -> Lwt.return @@ game_over "undefined") diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml index 6ac78a7131aee8effe1c8845fb2ece63927d5190..5908d7a3e9a0c43cf7457081003805cce7bf1ccd 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml @@ -426,11 +426,13 @@ module type TREE = sig val is_empty : tree -> bool val hash : tree -> Context_hash.t + + val __infer_t : t -> unit end -module MakeHashingScheme (Tree : TREE) : - MerkelizedOperations with type tree = Tree.tree = struct - module Tree = Tree +module MakeHashingScheme (P : TREE) : + MerkelizedOperations with type tree = P.tree = struct + module Tree = P type tree = Tree.tree @@ -604,7 +606,7 @@ module MakeHashingScheme (Tree : TREE) : in (history, inbox) in - let rec aux (history, inbox) = + let[@coq_struct "function_parameter"] rec aux (history, inbox) = if Raw_level_repr.(inbox.level = target_level) then (history, inbox) else aux (archive_level history inbox) in @@ -631,7 +633,8 @@ module MakeHashingScheme (Tree : TREE) : let current_messages_hash () = hash_messages messages in return (messages, history, {inbox with current_messages_hash}) - let add_external_messages history inbox level payloads messages = + let[@coq_axiom_with_reason "Non-exhaustive pattern match."] add_external_messages + history inbox level payloads messages = let open Lwt_tzresult_syntax in let*? payloads = List.map_e @@ -644,7 +647,8 @@ module MakeHashingScheme (Tree : TREE) : in return (messages, history, inbox) - let add_messages_no_history inbox level payloads messages = + let[@coq_axiom_with_reason "Non-exhaustive pattern match."] add_messages_no_history + inbox level payloads messages = let open Lwt_tzresult_syntax in let* messages, No_history, inbox = add_messages_aux No_history inbox level payloads messages @@ -677,7 +681,8 @@ module MakeHashingScheme (Tree : TREE) : in aux [] ptr_path - let produce_inclusion_proof history inbox1 inbox2 = + let[@coq_axiom_with_reason "Non-exhaustive pattern match."] produce_inclusion_proof + history inbox1 inbox2 = let cell_ptr = hash_old_levels_messages inbox2.old_levels_messages in let target_index = Skip_list.index inbox1.old_levels_messages in let (With_history history) = @@ -708,7 +713,15 @@ end include ( MakeHashingScheme (struct - include Context.Tree + let find = Context.Tree.find + + let find_tree = Context.Tree.find_tree + + let add = Context.Tree.add + + let is_empty = Context.Tree.is_empty + + let hash = Context.Tree.hash type t = Context.t @@ -717,6 +730,8 @@ include ( type value = bytes type key = string list + + let __infer_t (_ : t) = () end) : MerkelizedOperations with type tree = Context.tree) @@ -798,7 +813,7 @@ module Proof = struct let* r = get_message_payload tree n in return (tree, r) - let check_hash hash kinded_hash = + let[@coq_axiom_with_reason "Type error."] check_hash hash kinded_hash = match kinded_hash with | `Node h -> Hash.(equal (of_context_hash h) hash) | `Value h -> Hash.(equal (of_context_hash h) hash) @@ -814,7 +829,8 @@ module Proof = struct let*! result = promise in match result with Ok r -> return r | Error _ -> proof_error reason - let rec valid {inbox_level = l; message_counter = n} inbox proof = + let[@coq_axiom_with_reason "Type error."] rec valid + {inbox_level = l; message_counter = n} inbox proof = assert (Z.(geq n zero)) ; let open Lwt_result_syntax in match split_proof proof with diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli index 9b322fbdf989f8b5ef88a9460206fd399af9258d..5c7be4ec56b891323ed0b12591fff35f54ef2b1c 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli @@ -284,6 +284,8 @@ module type TREE = sig val is_empty : tree -> bool val hash : tree -> Context_hash.t + + val __infer_t : t -> unit end (** diff --git a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml index 98856c39a1eb4e6f2f6326a5bef8d286a74ca40e..10e047f642653444d740259e395c8abc0ef8dd51 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml @@ -72,43 +72,46 @@ let transactions_batch_of_internal ctxt transactions = {Sc_rollup.Outbox.Message.unparsed_parameters; destination; entrypoint} = (* Lookup the contract-hash. *) (* Load the type and entrypoints of the script. *) - let* ( Script_ir_translator.Ex_script (Script {arg_type; entrypoints; _}), - ctxt ) = + let* res, ctxt = let* ctxt, _cache_key, cached = Script_cache.find ctxt destination in match cached with | Some (_script, ex_script) -> return (ex_script, ctxt) | None -> fail Sc_rollup_invalid_destination in - (* Find the entrypoint type for the given entrypoint. *) - let*? res, ctxt = - Gas_monad.run - ctxt - (Script_ir_translator.find_entrypoint - ~error_details:(Informative ()) - arg_type - entrypoints - entrypoint) - in - let*? (Ex_ty_cstr {ty = parameters_ty; _}) = res in - (* Parse the parameters according to the entrypoint type. *) - let* parameters, ctxt = - Script_ir_translator.parse_data - ctxt - ~legacy:false - ~allow_forged:true - parameters_ty - (Micheline.root unparsed_parameters) - in - return - ( Transaction - { - destination; - entrypoint; - parameters_ty; - parameters; - unparsed_parameters; - }, - ctxt ) + match[@coq_match_gadt] res with + | Script_ir_translator.Ex_script (Script {arg_type; entrypoints; _}) -> ( + (* Find the entrypoint type for the given entrypoint. *) + let*? res, ctxt = + Gas_monad.run + ctxt + ((Script_ir_translator.find_entrypoint [@coq_type_annotation]) + ~error_details:(Informative ()) + arg_type + entrypoints + entrypoint) + in + let*? res = res in + match[@coq_match_gadt] res with + | Script_ir_translator.Ex_ty_cstr {ty = parameters_ty; _} -> + (* Parse the parameters according to the entrypoint type. *) + let* parameters, ctxt = + (Script_ir_translator.parse_data [@coq_type_annotation]) + ctxt + ~legacy:false + ~allow_forged:true + parameters_ty + (Micheline.root unparsed_parameters) + in + return + ( Transaction + { + destination; + entrypoint; + parameters_ty; + parameters; + unparsed_parameters; + }, + ctxt )) in let+ ctxt, transactions = List.fold_left_map_es diff --git a/src/proto_alpha/lib_protocol/sc_rollup_operations.ml b/src/proto_alpha/lib_protocol/sc_rollup_operations.ml index 74d469570a150cf39a87f0c5120ea9995f405498..aecbeb23221c3dc3314bf447e70d1fa00c8e739e 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_operations.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_operations.ml @@ -106,7 +106,7 @@ let rec validate_ty : | Chest_key_t -> error Sc_rollup_invalid_parameters_type | Lambda_t (_, _, _) -> error Sc_rollup_invalid_parameters_type -and validate_two_tys : +and[@coq_mutual_as_notation] validate_two_tys : type a ac b bc ret. (a, ac) Script_typed_ir.ty -> (b, bc) Script_typed_ir.ty -> diff --git a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml index 84333262f7aecba559d54fa31d9d8bde80781e0b..e7e3050258557e6db40621ccf8770c56dddb36fa 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml @@ -42,11 +42,11 @@ let pp ppf _ = Format.fprintf ppf "Refutation game proof" let start proof = let (module P) = Sc_rollups.wrapped_proof_module proof.pvm_step in - P.proof_start_state P.proof + P.proof_start_state P.proof_val let stop proof = let (module P) = Sc_rollups.wrapped_proof_module proof.pvm_step in - P.proof_stop_state P.proof + P.proof_stop_state P.proof_val (* This takes an [input] and checks if it is at or above the given level. It returns [None] if this is the case. @@ -69,12 +69,13 @@ let check p reason = let open Lwt_result_syntax in if p then return () else proof_error reason -let valid snapshot commit_level ~pvm_name proof = +let[@coq_axiom_with_reason "Type errors."] valid snapshot commit_level ~pvm_name + proof = let (module P) = Sc_rollups.wrapped_proof_module proof.pvm_step in let open Lwt_result_syntax in let* _ = check (String.equal P.name pvm_name) "Incorrect PVM kind" in - let input_requested = P.proof_input_requested P.proof in - let input_given = P.proof_input_given P.proof in + let input_requested = P.proof_input_requested P.proof_val in + let input_given = P.proof_input_given P.proof_val in let* input = match (input_requested, proof.inbox) with | Sc_rollup_PVM_sem.No_input_required, None -> return None @@ -105,7 +106,7 @@ let valid snapshot commit_level ~pvm_name proof = input_given) "Input given is not what inbox proof expects" in - Lwt.map Result.ok (P.verify_proof P.proof) + Lwt.map Result.ok (P.verify_proof P.proof_val) module type PVM_with_context_and_state = sig include Sc_rollups.PVM.S @@ -117,7 +118,8 @@ end type error += Proof_cannot_be_wrapped -let produce pvm_and_state inbox commit_level = +let[@coq_axiom_with_reason "Type errors."] produce pvm_and_state inbox + commit_level = let open Lwt_result_syntax in let (module P : PVM_with_context_and_state) = pvm_and_state in let*! request = P.is_input_state P.state in @@ -140,7 +142,7 @@ let produce pvm_and_state inbox commit_level = let module P_with_proof = struct include P - let proof = pvm_step_proof + let proof_val = pvm_step_proof end in match Sc_rollups.wrap_proof (module P_with_proof) with | Some pvm_step -> return {pvm_step; inbox} diff --git a/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml index 66e00aa3cca1cc8639b3544cb1822f66d3a93bce..626131f03dea8a7eedd9a65dae62bdfff79991d5 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml @@ -49,7 +49,7 @@ let timeout_level ctxt = arrives at the exact [inbox_level]. The result is the commit hash at the given inbox level. *) let goto_inbox_level ctxt rollup inbox_level commit = let open Lwt_tzresult_syntax in - let rec go ctxt commit = + let[@coq_struct "commit"] rec go ctxt commit = let* info, ctxt = Commitment_storage.get_commitment_unsafe ctxt rollup commit in @@ -104,7 +104,7 @@ let get_conflict_point ctxt rollup staker1 staker2 = (* The inbox level of a commitment increases by a fixed amount over the preceding commitment. We use this fact in the following to efficiently traverse both commitment histories towards the conflict points. *) - let rec traverse_in_parallel ctxt commit1 commit2 = + let[@coq_struct "commit1"] rec traverse_in_parallel ctxt commit1 commit2 = (* We know that commit1 <> commit2 at the first call and during recursive calls as well. *) let* commit1_info, ctxt = diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml index db14462b787e1d22ea374a4aec61fe053798508f..4157c21db439b07e6355273b0ed2de42dcee71ba 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml @@ -138,9 +138,11 @@ let () = (fun loc -> Invalid_sc_rollup_address loc) let of_b58check s = + let error () = Error (Format.sprintf "Invalid_sc_rollup_address %s" s) in match Base58.decode s with - | Some (Address.Data hash) -> ok hash - | _ -> Error (Format.sprintf "Invalid_sc_rollup_address %s" s) + | Some data -> ( + match data with Address.Data hash -> ok hash | _ -> error ()) + | _ -> error () let pp = Address.pp diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli index e24094de265155f1f20a2d90df1198e0d0c4d2a1..a9b1339d297384b1f25de91bf394ae19e1a4c2dc 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli @@ -61,7 +61,7 @@ module Internal_for_tests : sig val originated_sc_rollup : Origination_nonce.t -> Address.t end -module State_hash : S.HASH +module State_hash : S.HASH [@@coq_plain_module] (** Number of messages consumed by a single commitment. This represents a claim about the shape of the Inbox, which can be disputed as part of a commitment diff --git a/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml index 46ef8abf8d454e04b9f2dce30cb726c74db80f7e..bbf1fc8ec69521f0afa525bbefddc276d974b72b 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml @@ -58,7 +58,7 @@ let deposit_stake ctxt rollup staker = let open Lwt_tzresult_syntax in let* lcc, ctxt = Commitment_storage.last_cemented_commitment ctxt rollup in let staker_contract, stake = get_contract_and_stake ctxt staker in - let* ctxt, staker_balance = Token.balance ctxt (`Contract staker_contract) in + let* ctxt, staker_balance = Token.balance ctxt (Contract staker_contract) in let* () = fail_when Tez_repr.(staker_balance < stake) @@ -74,8 +74,8 @@ let deposit_stake ctxt rollup staker = let* ctxt, balance_updates = Token.transfer ctxt - (`Contract staker_contract) - (`Frozen_bonds (staker_contract, bond_id)) + (Source_container (Contract staker_contract)) + (Sink_container (Frozen_bonds (staker_contract, bond_id))) stake in let* ctxt, _size = Store.Stakers.init (ctxt, rollup) staker lcc in @@ -99,8 +99,8 @@ let withdraw_stake ctxt rollup staker = let* ctxt, balance_updates = Token.transfer ctxt - (`Frozen_bonds (staker_contract, bond_id)) - (`Contract staker_contract) + (Source_container (Frozen_bonds (staker_contract, bond_id))) + (Sink_container (Contract staker_contract)) stake in let* ctxt, _size_freed = @@ -248,7 +248,7 @@ let refine_stake ctxt rollup staker commitment = let new_hash = Commitment.hash commitment in (* TODO: https://gitlab.com/tezos/tezos/-/issues/2559 Add a test checking that L2 nodes can catch up after going offline. *) - let rec go node ctxt = + let[@coq_struct "node_value"] rec go node ctxt = (* WARNING: Do NOT reorder this sequence of ifs. we must check for staked_on before LCC, since refining from the LCC to another commit is a valid operation. *) @@ -390,15 +390,15 @@ let remove_staker ctxt rollup staker = let* ctxt, balance_updates = Token.transfer ctxt - (`Frozen_bonds (staker_contract, bond_id)) - `Sc_rollup_refutation_punishments + (Source_container (Frozen_bonds (staker_contract, bond_id))) + (Sink_infinite Sc_rollup_refutation_punishments) stake in let* ctxt, _size_diff = Store.Stakers.remove_existing (ctxt, rollup) staker in let* ctxt = modify_staker_count ctxt rollup Int32.pred in - let rec go node ctxt = + let[@coq_struct "node_value"] rec go node ctxt = if Commitment_hash.(node = lcc) then return ctxt else let* pred, ctxt = diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml index 06a0fea1999db959ade3155cc350eaf600f761e8..1bf6ddb426c7925ceaddee169366d9b437bd7dc7 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml @@ -26,8 +26,7 @@ open Sc_rollup_errors module Store = Storage.Sc_rollup -module Commitment = Sc_rollup_commitment_repr -module Commitment_hash = Commitment.Hash +module Commitment_hash = Sc_rollup_commitment_repr.Hash let originate ctxt ~kind ~boot_sector ~parameters_ty = Raw_context.increment_origination_nonce ctxt >>?= fun (ctxt, nonce) -> @@ -80,7 +79,7 @@ let parameters_type ctxt rollup = let+ ctxt, res = Store.Parameters_type.find ctxt rollup in (res, ctxt) -module Outbox = struct +module Outbox_aux = struct let level_index ctxt level = let max_active_levels = Constants_storage.sc_rollup_max_active_outbox_levels ctxt diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.mli b/src/proto_alpha/lib_protocol/sc_rollup_storage.mli index 2dca63488e63c728ae5df90a2101089b1a498790..dd602c88abeb4af2901513b71189cd17c738928b 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_storage.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.mli @@ -62,7 +62,7 @@ val parameters_type : (Script_repr.lazy_expr option * Raw_context.t) tzresult Lwt.t (** A module for managing state concerning a rollup's outbox. *) -module Outbox : sig +module Outbox_aux : sig (** [record_applied_message ctxt rollup level ~message_index] marks the message in the outbox of rollup [rollup] at level [level] and position [message_index] as processed. Returns the size diff resulting from diff --git a/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml index 22156b964fedbc8dc43fb4ac1185cf1cf2148ca8..75e2b1372f7772b2c9cdb5befc3108097a741fa6 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml @@ -24,13 +24,13 @@ (* *) (*****************************************************************************) -include Z +type t = Z.t -let initial = zero +let initial = Z.zero -let next = succ +let next = Z.succ -let pp = pp_print +let pp = Z.pp_print let encoding = Data_encoding.n @@ -43,16 +43,24 @@ let to_int x = if Z.fits_int x then Some (Z.to_int x) else None let of_number_of_ticks x = Z.of_int (Int32.to_int (Sc_rollup_repr.Number_of_ticks.to_int32 x)) -let ( <= ) = leq +let ( <= ) = Z.leq -let ( < ) = lt +let ( < ) = Z.lt -let ( >= ) = geq +let ( >= ) = Z.geq -let ( > ) = gt +let ( > ) = Z.gt -let ( = ) = equal +let ( = ) = Z.equal let ( <> ) x y = not (x = y) +let compare = Z.compare + +let equal = Z.equal + +let min = Z.min + +let max = Z.max + module Map = Map.Make (Z) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml index 8243b7403fc735cf4c55e8c4e02d0b9cf7131b13..91eee6b23cec35ba7203a0088797cffb992ee09e 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml @@ -103,15 +103,16 @@ module V2_0_0 = struct type nonrec proof = Context.proof proof - let proof_input_given p = p.given + let proof_input_given (p : proof) = p.given - let proof_input_requested p = p.requested + let proof_input_requested (p : proof) = p.requested - let proof_encoding = proof_encoding Context.proof_encoding + let proof_encoding : proof Data_encoding.t = + proof_encoding Context.proof_encoding - let proof_start_state p = Context.proof_before p.tree_proof + let proof_start_state (p : proof) = Context.proof_before p.tree_proof - let proof_stop_state p = + let proof_stop_state (p : proof) = match (p.given, p.requested) with | None, PS.No_input_required -> Some (Context.proof_after p.tree_proof) | None, _ -> None @@ -207,7 +208,7 @@ module V2_0_0 = struct open Monad - module MakeVar (P : sig + module type P_MakeVar = sig type t val name : string @@ -215,8 +216,18 @@ module V2_0_0 = struct val initial : t val encoding : t Data_encoding.t - end) = - struct + end + + module type MakeVar_sig = sig + type t + (*val key : string list*) + + val get : t Monad.t + + val set : t -> unit Monad.t + end + + module MakeVar (P : P_MakeVar) : MakeVar_sig with type t := P.t = struct let key = [P.name] let get = @@ -228,9 +239,15 @@ module V2_0_0 = struct end module CurrentTick = MakeVar (struct - include Sc_rollup_tick_repr + type t = Sc_rollup_tick_repr.t let name = "tick" + + let initial = Sc_rollup_tick_repr.initial + + let encoding = Sc_rollup_tick_repr.encoding + + let _pp = Sc_rollup_tick_repr.pp end) module Boot_sector = MakeVar (struct @@ -411,7 +428,7 @@ module V2_0_0 = struct in return (state, request) - let verify_proof proof = + let verify_proof (proof : proof) = let open Lwt_syntax in let* result = Context.verify_proof proof.tree_proof (step_transition proof.given) @@ -423,7 +440,7 @@ module V2_0_0 = struct type error += WASM_proof_production_failed - let produce_proof context input_given state = + let produce_proof context input_given state : (proof, error) result Lwt.t = let open Lwt_result_syntax in let*! result = Context.produce_proof context state (step_transition input_given) @@ -489,15 +506,18 @@ module V2_0_0 = struct (* Can't produce proof without full context*) Lwt.return None - let kinded_hash_to_state_hash = function + let[@coq_axiom_with_reason "Type error."] kinded_hash_to_state_hash = + function | `Value hash | `Node hash -> State_hash.hash_bytes [Context_hash.to_bytes hash] - let proof_before proof = + let[@coq_axiom_with_reason "Type error."] proof_before proof = kinded_hash_to_state_hash proof.Context.Proof.before - let proof_after proof = kinded_hash_to_state_hash proof.Context.Proof.after + let[@coq_axiom_with_reason "Type error."] proof_after proof = + kinded_hash_to_state_hash proof.Context.Proof.after - let proof_encoding = Context.Proof_encoding.V1.Tree32.tree_proof_encoding + let[@coq_axiom_with_reason "Type error."] proof_encoding = + Context.Proof_encoding.V1.Tree32.tree_proof_encoding end) end diff --git a/src/proto_alpha/lib_protocol/sc_rollups.ml b/src/proto_alpha/lib_protocol/sc_rollups.ml index f8dc13c41824c8167dfe47b44186ca2d110e484c..d142b61ac28f77915de1f5255192e0658871c00a 100644 --- a/src/proto_alpha/lib_protocol/sc_rollups.ml +++ b/src/proto_alpha/lib_protocol/sc_rollups.ml @@ -84,11 +84,11 @@ module Kind = struct | "wasm_2_0_0" -> Some Wasm_2_0_0 | _ -> None - let example_arith_pvm = - (module Sc_rollup_arith.ProtocolImplementation : PVM.S) + let example_arith_pvm : (module PVM.S) = + (module (Sc_rollup_arith.ProtocolImplementation : PVM.S)) - let wasm_2_0_0_pvm = - (module Sc_rollup_wasm.V2_0_0.ProtocolImplementation : PVM.S) + let wasm_2_0_0_pvm : (module PVM.S) = + (module (Sc_rollup_wasm.V2_0_0.ProtocolImplementation : PVM.S)) let pvm_of = function | Example_arith -> example_arith_pvm @@ -122,7 +122,7 @@ end module type PVM_with_proof = sig include PVM.S - val proof : proof + val proof_val : proof end type wrapped_proof = @@ -148,7 +148,7 @@ let wrapped_proof_module p = include P end : PVM_with_proof) -let wrapped_proof_encoding = +let[@coq_axiom_with_reason "Module Issues."] wrapped_proof_encoding = let open Data_encoding in let encoding = union @@ -165,13 +165,13 @@ let wrapped_proof_encoding = Sc_rollup_arith.ProtocolImplementation.proof) = pvm in - Some P.proof + Some P.proof_val | _ -> None) (fun proof -> let module P = struct include Sc_rollup_arith.ProtocolImplementation - let proof = proof + let proof_val = proof end in Arith_pvm_with_proof (module P)); case @@ -185,20 +185,20 @@ let wrapped_proof_encoding = Sc_rollup_wasm.V2_0_0.ProtocolImplementation.proof) = pvm in - Some P.proof + Some P.proof_val | _ -> None) (fun proof -> let module P = struct include Sc_rollup_wasm.V2_0_0.ProtocolImplementation - let proof = proof + let proof_val = proof end in Wasm_2_0_0_pvm_with_proof (module P)); ] in check_size Constants_repr.sc_max_wrapped_proof_binary_size encoding -let wrap_proof pvm_with_proof = +let[@coq_axiom_with_reason "Module Issues."] wrap_proof pvm_with_proof = let (module P : PVM_with_proof) = pvm_with_proof in match Kind.of_name P.name with | None -> Some (Unencodable pvm_with_proof) @@ -208,11 +208,11 @@ let wrap_proof pvm_with_proof = let module P_arith = struct include Sc_rollup_arith.ProtocolImplementation - let proof = arith_proof + let proof_val = arith_proof end in Arith_pvm_with_proof (module P_arith)) (Option.bind - (Data_encoding.Binary.to_bytes_opt P.proof_encoding P.proof) + (Data_encoding.Binary.to_bytes_opt P.proof_encoding P.proof_val) (fun bytes -> Data_encoding.Binary.of_bytes_opt Sc_rollup_arith.ProtocolImplementation.proof_encoding @@ -223,11 +223,11 @@ let wrap_proof pvm_with_proof = let module P_wasm2_0_0 = struct include Sc_rollup_wasm.V2_0_0.ProtocolImplementation - let proof = wasm_proof + let proof_val = wasm_proof end in Wasm_2_0_0_pvm_with_proof (module P_wasm2_0_0)) (Option.bind - (Data_encoding.Binary.to_bytes_opt P.proof_encoding P.proof) + (Data_encoding.Binary.to_bytes_opt P.proof_encoding P.proof_val) (fun bytes -> Data_encoding.Binary.of_bytes_opt Sc_rollup_wasm.V2_0_0.ProtocolImplementation.proof_encoding diff --git a/src/proto_alpha/lib_protocol/sc_rollups.mli b/src/proto_alpha/lib_protocol/sc_rollups.mli index 81ec833da0ab9a2c24de9c31fdae6993452e374c..3684ff07ab392c63078774673aecf64273f6cce7 100644 --- a/src/proto_alpha/lib_protocol/sc_rollups.mli +++ b/src/proto_alpha/lib_protocol/sc_rollups.mli @@ -87,7 +87,7 @@ end module type PVM_with_proof = sig include PVM.S - val proof : proof + val proof_val : proof end (** A wrapper for first-class modules [(module PVM_with_proof)]. We need diff --git a/src/proto_alpha/lib_protocol/script_big_map.ml b/src/proto_alpha/lib_protocol/script_big_map.ml index 44369f61a1fd532eb8b055c820335bdd3e5fa4e3..7ed08fb4359b3c7906965d956e30baaef200f69d 100644 --- a/src/proto_alpha/lib_protocol/script_big_map.ml +++ b/src/proto_alpha/lib_protocol/script_big_map.ml @@ -29,11 +29,11 @@ open Script_typed_ir open Script_ir_translator -let empty key_type value_type = +let empty key_type value_type : ('a, 'b) big_map = Big_map { id = None; - diff = {map = Big_map_overlay.empty; size = 0}; + diff = {map = Big_map_overlay.empty; size = 0} [@coq_type_annotation]; key_type; value_type; } @@ -48,37 +48,41 @@ let mem ctxt key (Big_map {id; diff; key_type; _}) = | Some (_, None), _ -> return (false, ctxt) | Some (_, Some _), _ -> return (true, ctxt) -let get_by_hash ctxt key (Big_map {id; diff; value_type; _}) = - match (Big_map_overlay.find key diff.map, id) with - | Some (_, x), _ -> return (x, ctxt) - | None, None -> return (None, ctxt) - | None, Some id -> ( - Alpha_context.Big_map.get_opt ctxt id key >>=? function - | ctxt, None -> return (None, ctxt) - | ctxt, Some value -> - parse_data - ctxt - ~legacy:true - ~allow_forged:true - value_type - (Micheline.root value) - >|=? fun (x, ctxt) -> (Some x, ctxt)) +let get_by_hash ctxt key big_map = + match[@coq_match_gadt] big_map with + | Big_map {id; diff; value_type; _} -> ( + match (Big_map_overlay.find key diff.map, id) with + | Some (_, x), _ -> return (x, ctxt) + | None, None -> return (None, ctxt) + | None, Some id -> ( + Alpha_context.Big_map.get_opt ctxt id key >>=? function + | ctxt, None -> return (None, ctxt) + | ctxt, Some value -> + parse_data + ctxt + ~legacy:true + ~allow_forged:true + value_type + (Micheline.root value) + >|=? fun (x, ctxt) -> (Some x, ctxt))) let get ctxt key (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> - get_by_hash ctxt key_hash map + (get_by_hash [@coq_implicit "B" "A"]) ctxt key_hash map -let update_by_hash key_hash key value (Big_map map) = - let contains = Big_map_overlay.mem key_hash map.diff.map in - Big_map - { - map with - diff = +let update_by_hash key_hash key value big_map = + match[@coq_match_gadt] big_map with + | Big_map map -> + let contains = Big_map_overlay.mem key_hash map.diff.map in + Big_map { - map = Big_map_overlay.add key_hash (key, value) map.diff.map; - size = (if contains then map.diff.size else map.diff.size + 1); - }; - } + map with + diff = + { + map = Big_map_overlay.add key_hash (key, value) map.diff.map; + size = (if contains then map.diff.size else map.diff.size + 1); + }; + } let update ctxt key value (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> @@ -88,5 +92,5 @@ let update ctxt key value (Big_map {key_type; _} as map) = let get_and_update ctxt key value (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> let new_map = update_by_hash key_hash key value map in - get_by_hash ctxt key_hash map >>=? fun (old_value, ctxt) -> - return ((old_value, new_map), ctxt) + (get_by_hash [@coq_implicit "B" "A"]) ctxt key_hash map + >>=? fun (old_value, ctxt) -> return ((old_value, new_map), ctxt) diff --git a/src/proto_alpha/lib_protocol/script_comparable.ml b/src/proto_alpha/lib_protocol/script_comparable.ml index d570ef9bda7669507e559eabf611f893e5fe3509..391495985f44ad10fedac1761f553de9875b173b 100644 --- a/src/proto_alpha/lib_protocol/script_comparable.ml +++ b/src/proto_alpha/lib_protocol/script_comparable.ml @@ -42,46 +42,63 @@ type compare_comparable_cont = -> compare_comparable_cont | Compare_comparable_return : compare_comparable_cont -let compare_comparable : type a. a comparable_ty -> a -> a -> int = - let rec compare_comparable : +module Compare_comparable = struct + let[@coq_struct "kind_value"] rec compare_comparable : type a. a comparable_ty -> compare_comparable_cont -> a -> a -> int = fun kind k x y -> - match (kind, x, y) with - | Unit_t, (), () -> (apply [@tailcall]) 0 k + match[@coq_match_gadt] [@coq_match_with_default] (kind, x, y) with + | Unit_t, _, _ -> (apply [@tailcall]) 0 k | Never_t, _, _ -> . - | Signature_t, x, y -> (apply [@tailcall]) (Script_signature.compare x y) k - | String_t, x, y -> (apply [@tailcall]) (Script_string.compare x y) k - | Bool_t, x, y -> (apply [@tailcall]) (Compare.Bool.compare x y) k - | Mutez_t, x, y -> (apply [@tailcall]) (Tez.compare x y) k - | Key_hash_t, x, y -> + | Signature_t, (x : signature), (y : signature) -> + (apply [@tailcall]) (Script_signature.compare x y) k + | String_t, (x : Script_string.t), (y : Script_string.t) -> + (apply [@tailcall]) (Script_string.compare x y) k + | Bool_t, (x : bool), (y : bool) -> + (apply [@tailcall]) (Compare.Bool.compare x y) k + | Mutez_t, (x : Tez.t), (y : Tez.t) -> + (apply [@tailcall]) (Tez.compare x y) k + | Key_hash_t, (x : public_key_hash), (y : public_key_hash) -> (apply [@tailcall]) (Signature.Public_key_hash.compare x y) k - | Key_t, x, y -> (apply [@tailcall]) (Signature.Public_key.compare x y) k - | Int_t, x, y -> (apply [@tailcall]) (Script_int.compare x y) k - | Nat_t, x, y -> (apply [@tailcall]) (Script_int.compare x y) k - | Timestamp_t, x, y -> (apply [@tailcall]) (Script_timestamp.compare x y) k - | Address_t, x, y -> (apply [@tailcall]) (compare_address x y) k - | Tx_rollup_l2_address_t, x, y -> + | Key_t, (x : public_key), (y : public_key) -> + (apply [@tailcall]) (Signature.Public_key.compare x y) k + | Int_t, (x : _ Script_int.num), (y : _ Script_int.num) -> + (apply [@tailcall]) (Script_int.compare x y) k + | Nat_t, (x : _ Script_int.num), (y : _ Script_int.num) -> + (apply [@tailcall]) (Script_int.compare x y) k + | Timestamp_t, (x : Script_timestamp.t), (y : Script_timestamp.t) -> + (apply [@tailcall]) (Script_timestamp.compare x y) k + | Address_t, (x : address), (y : address) -> + (apply [@tailcall]) (compare_address x y) k + | ( Tx_rollup_l2_address_t, + (x : tx_rollup_l2_address), + (y : tx_rollup_l2_address) ) -> (apply [@tailcall]) (compare_tx_rollup_l2_address x y) k - | Bytes_t, x, y -> (apply [@tailcall]) (Compare.Bytes.compare x y) k - | Chain_id_t, x, y -> (apply [@tailcall]) (Script_chain_id.compare x y) k - | Pair_t (tl, tr, _, YesYes), (lx, rx), (ly, ry) -> + | Bytes_t, (x : bytes), (y : bytes) -> + (apply [@tailcall]) (Compare.Bytes.compare x y) k + | Chain_id_t, (x : Script_chain_id.t), (y : Script_chain_id.t) -> + (apply [@tailcall]) (Script_chain_id.compare x y) k + | Pair_t (tl, tr, _, YesYes), (x : _ * _), (y : _ * _) -> + let lx, rx = x in + let ly, ry = y in (compare_comparable [@tailcall]) tl (Compare_comparable (tr, rx, ry, k)) lx ly - | Union_t (tl, _, _, YesYes), L x, L y -> - (compare_comparable [@tailcall]) tl k x y - | Union_t _, L _, R _ -> -1 - | Union_t _, R _, L _ -> 1 - | Union_t (_, tr, _, YesYes), R x, R y -> - (compare_comparable [@tailcall]) tr k x y - | Option_t _, None, None -> (apply [@tailcall]) 0 k - | Option_t _, None, Some _ -> -1 - | Option_t _, Some _, None -> 1 - | Option_t (t, _, Yes), Some x, Some y -> - (compare_comparable [@tailcall]) t k x y - and apply ret k = + | Union_t (tl, tr, _, YesYes), (x : (_, _) union), (y : (_, _) union) -> ( + match (x, y) with + | L x, L y -> (compare_comparable [@tailcall]) tl k x y + | L _, R _ -> -1 + | R _, L _ -> 1 + | R x, R y -> (compare_comparable [@tailcall]) tr k x y) + | Option_t (t, _, _), (x : _ option), (y : _ option) -> ( + match (x, y) with + | None, None -> (apply [@tailcall]) 0 k + | None, Some _ -> -1 + | Some _, None -> 1 + | Some x, Some y -> (compare_comparable [@tailcall]) t k x y) + + and[@coq_mutual_as_notation] apply ret k = match (ret, k) with | 0, Compare_comparable (ty, x, y, k) -> (compare_comparable [@tailcall]) ty k x y @@ -89,6 +106,7 @@ let compare_comparable : type a. a comparable_ty -> a -> a -> int = | ret, _ -> (* ret <> 0, we perform an early exit *) if Compare.Int.(ret > 0) then 1 else -1 - in - fun t -> compare_comparable t Compare_comparable_return - [@@coq_axiom_with_reason "non top-level mutually recursive function"] +end + +let compare_comparable : type a. a comparable_ty -> a -> a -> int = + fun t -> Compare_comparable.compare_comparable t Compare_comparable_return diff --git a/src/proto_alpha/lib_protocol/script_int.ml b/src/proto_alpha/lib_protocol/script_int.ml index a2ef0ebc257e989ec8d7963719526918ed084fa5..5d06c29b734ed9fce23807e4e39affe07f251daf 100644 --- a/src/proto_alpha/lib_protocol/script_int.ml +++ b/src/proto_alpha/lib_protocol/script_int.ml @@ -35,7 +35,7 @@ type z = Integer_tag having to deconstruct to and reconstruct from `Z.t`. *) type 't repr = Z.t -type 't num = Num_tag of 't repr [@@ocaml.unboxed] +type 't num = Num_tag of 't repr [@@ocaml.unboxed] [@@coq_force_gadt] let compare (Num_tag x) (Num_tag y) = Z.compare x y diff --git a/src/proto_alpha/lib_protocol/script_int.mli b/src/proto_alpha/lib_protocol/script_int.mli index 1dbb5425330dc06fd588367ba34a07daa5005458..7abe7e93c56977e9b1be711f1e5c6ec9736e17ef 100644 --- a/src/proto_alpha/lib_protocol/script_int.mli +++ b/src/proto_alpha/lib_protocol/script_int.mli @@ -34,7 +34,7 @@ type 't repr [@@coq_phantom] (** [num] is made algebraic in order to distinguish it from the other type parameters of [Script_typed_ir.ty]. *) -type 't num = Num_tag of 't repr [@@ocaml.unboxed] +type 't num = Num_tag of 't repr [@@ocaml.unboxed] [@@coq_force_gadt] (** Flag for natural numbers. *) type n = Natural_tag diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 49d2809b34e950f75158c93397fda2f23be4719e..a7896682576dfac0ffb26f19da1faed5016a6f44 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -234,6 +234,17 @@ let () = *) +let ifailwith : ifailwith_type = + { + ifailwith = + (fun logger (ctxt, _) gas kloc tv accu -> + let ctxt = update_context gas ctxt in + trace Cannot_serialize_failure (unparse_data ctxt Optimized tv accu) + >>=? fun (v, _ctxt) -> + let v = Micheline.strip_locations v in + get_log logger >>=? fun log -> fail (Reject (kloc, v, log))); + } + (* Evaluation of continuations @@ -247,19 +258,20 @@ let () = evaluation rules depending on the continuation at stake. *) -let rec kmap_exit : +let[@coq_mutual_as_notation] rec kmap_exit : type a b c d e f g h m n o. (a, b, c, d, e, f, g, h, m, n, o) kmap_exit_type = fun mk g gas body xs ys yk ks accu stack -> let ys = Script_map.update yk (Some accu) ys in let ks = mk (KMap_enter_body (body, xs, ys, ks)) in let accu, stack = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and kmap_enter : type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = +and[@coq_mutual_as_notation] kmap_enter : + type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = fun mk g gas body xs ys ks accu stack -> - match xs with + match[@coq_type_annotation] xs with | [] -> (next [@ocaml.tailcall]) g gas ks ys (accu, stack) | (xk, xv) :: xs -> let ks = mk (KMap_exit_body (body, xs, ys, xk, ks)) in @@ -268,16 +280,18 @@ and kmap_enter : type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = (step [@ocaml.tailcall]) g gas body ks res stack [@@inline] -and klist_exit : type a b c d i j. (a, b, c, d, i, j) klist_exit_type = +and[@coq_mutual_as_notation] klist_exit : + type a b c d i j. (a, b, c, d, i, j) klist_exit_type = fun mk g gas body xs ys len ks accu stack -> let ks = mk (KList_enter_body (body, xs, accu :: ys, len, ks)) in let accu, stack = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and klist_enter : type a b c d e j. (a, b, c, d, e, j) klist_enter_type = +and[@coq_mutual_as_notation] klist_enter : + type a b c d e j. (a, b, c, d, e, j) klist_enter_type = fun mk g gas body xs ys len ks' accu stack -> - match xs with + match[@coq_type_annotation] xs with | [] -> let ys = {elements = List.rev ys; length = len} in (next [@ocaml.tailcall]) g gas ks' ys (accu, stack) @@ -286,31 +300,34 @@ and klist_enter : type a b c d e j. (a, b, c, d, e, j) klist_enter_type = (step [@ocaml.tailcall]) g gas body ks x (accu, stack) [@@inline] -and kloop_in_left : type a b c d e f g. (a, b, c, d, e, f, g) kloop_in_left_type - = +and[@coq_mutual_as_notation] kloop_in_left : + type a b c d e f g. (a, b, c, d, e, f, g) kloop_in_left_type = fun g gas ks0 ki ks' accu stack -> - match accu with + match[@coq_type_annotation] accu with | L v -> (step [@ocaml.tailcall]) g gas ki ks0 v stack | R v -> (next [@ocaml.tailcall]) g gas ks' v stack [@@inline] -and kloop_in : type a b c r f s. (a, b, c, r, f, s) kloop_in_type = +and[@coq_mutual_as_notation] kloop_in : + type a b c r f s. (a, b, c, r, f, s) kloop_in_type = fun g gas ks0 ki ks' accu stack -> let accu', stack' = stack in - if accu then (step [@ocaml.tailcall]) g gas ki ks0 accu' stack' + if [@coq_type_annotation] accu then + (step [@ocaml.tailcall]) g gas ki ks0 accu' stack' else (next [@ocaml.tailcall]) g gas ks' accu' stack' [@@inline] -and kiter : type a b s r f. (a, b, s, r, f) kiter_type = +and[@coq_mutual_as_notation] kiter : type a b s r f. (a, b, s, r, f) kiter_type + = fun mk g gas body xs ks accu stack -> - match xs with + match[@coq_type_annotation] xs with | [] -> (next [@ocaml.tailcall]) g gas ks accu stack | x :: xs -> let ks = mk (KIter (body, xs, ks)) in (step [@ocaml.tailcall]) g gas body ks x (accu, stack) [@@inline] -and next : +and[@coq_struct "gas"] next : type a s r f. outdated_context * step_constants -> local_gas_counter -> @@ -318,33 +335,37 @@ and next : a -> s -> (r * f * outdated_context * local_gas_counter) tzresult Lwt.t = - fun ((ctxt, _) as g) gas ks0 accu stack -> + fun g gas ks0 accu stack -> + let ctxt, _ = g in match consume_control gas ks0 with | None -> fail Gas.Operation_quota_exceeded | Some gas -> ( - match ks0 with - | KLog (ks, logger) -> + match[@coq_match_gadt] (ks0, accu, stack) with + | KLog (ks, logger), _, _ -> (klog [@ocaml.tailcall]) logger g gas ks0 ks accu stack - | KNil -> Lwt.return (Ok (accu, stack, ctxt, gas)) - | KCons (k, ks) -> (step [@ocaml.tailcall]) g gas k ks accu stack - | KLoop_in (ki, ks') -> + | KNil, (accu : r), (stack : f) -> + Lwt.return (Ok (accu, stack, ctxt, gas)) + | KCons (k, ks), _, _ -> (step [@ocaml.tailcall]) g gas k ks accu stack + | KLoop_in (ki, ks'), (accu : bool), (stack : _ * _) -> (kloop_in [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KReturn (stack', ks) -> (next [@ocaml.tailcall]) g gas ks accu stack' - | KMap_head (f, ks) -> (next [@ocaml.tailcall]) g gas ks (f accu) stack - | KLoop_in_left (ki, ks') -> + | KReturn (stack', ks), _, _ -> + (next [@ocaml.tailcall]) g gas ks accu stack' + | KMap_head (f, ks), _, _ -> + (next [@ocaml.tailcall]) g gas ks (f accu) stack + | KLoop_in_left (ki, ks'), (accu : _ union), _ -> (kloop_in_left [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KUndip (x, ks) -> (next [@ocaml.tailcall]) g gas ks x (accu, stack) - | KIter (body, xs, ks) -> + | KUndip (x, ks), _, _ -> (next [@ocaml.tailcall]) g gas ks x (accu, stack) + | KIter (body, xs, ks), _, _ -> (kiter [@ocaml.tailcall]) id g gas body xs ks accu stack - | KList_enter_body (body, xs, ys, len, ks) -> + | KList_enter_body (body, xs, ys, len, ks), _, _ -> (klist_enter [@ocaml.tailcall]) id g gas body xs ys len ks accu stack - | KList_exit_body (body, xs, ys, len, ks) -> + | KList_exit_body (body, xs, ys, len, ks), _, (stack : _ * _) -> (klist_exit [@ocaml.tailcall]) id g gas body xs ys len ks accu stack - | KMap_enter_body (body, xs, ys, ks) -> + | KMap_enter_body (body, xs, ys, ks), _, _ -> (kmap_enter [@ocaml.tailcall]) id g gas body xs ys ks accu stack - | KMap_exit_body (body, xs, ys, yk, ks) -> + | KMap_exit_body (body, xs, ys, yk, ks), _, (stack : _ * _) -> (kmap_exit [@ocaml.tailcall]) id g gas body xs ys yk ks accu stack - | KView_exit (orig_step_constants, ks) -> + | KView_exit (orig_step_constants, ks), _, _ -> let g = (fst g, orig_step_constants) in (next [@ocaml.tailcall]) g gas ks accu stack) @@ -361,102 +382,102 @@ and next : instructions. *) -and ilist_map : type a b c d e f g h. (a, b, c, d, e, f, g, h) ilist_map_type = +and[@coq_mutual_as_notation] ilist_map : + type a b c d e f g h. (a, b, c, d, e, f, g, h) ilist_map_type = fun log_if_needed g gas body k ks accu stack -> let xs = accu.elements in - let ys = [] in + let ys = (([] [@coq_type_annotation]) : f list) in let len = accu.length in let ks = log_if_needed (KList_enter_body (body, xs, ys, len, KCons (k, ks))) in let accu, stack = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and ilist_iter : type a b c d e f g. (a, b, c, d, e, f, g) ilist_iter_type = +and[@coq_mutual_as_notation] ilist_iter : + type a b c d e f g. (a, b, c, d, e, f, g) ilist_iter_type = fun log_if_needed g gas body k ks accu stack -> let xs = accu.elements in let ks = log_if_needed (KIter (body, xs, KCons (k, ks))) in let accu, stack = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and iset_iter : type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type = +and[@coq_mutual_as_notation] iset_iter : + type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type = fun log_if_needed g gas body k ks accu stack -> let set = accu in let l = List.rev (Script_set.fold (fun e acc -> e :: acc) set []) in let ks = log_if_needed (KIter (body, l, KCons (k, ks))) in let accu, stack = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and imap_map : type a b c d e f g h i. (a, b, c, d, e, f, g, h, i) imap_map_type - = +and[@coq_mutual_as_notation] imap_map : + type a b c d e f g h i. (a, b, c, d, e, f, g, h, i) imap_map_type = fun log_if_needed g gas body k ks accu stack -> let map = accu in let xs = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in - let ys = Script_map.empty_from map in + let ys = (Script_map.empty_from [@coq_type_annotation]) map in let ks = log_if_needed (KMap_enter_body (body, xs, ys, KCons (k, ks))) in let accu, stack = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and imap_iter : type a b c d e f g h. (a, b, c, d, e, f, g, h) imap_iter_type = +and[@coq_mutual_as_notation] imap_iter : + type a b c d e f g h. (a, b, c, d, e, f, g, h) imap_iter_type = fun log_if_needed g gas body k ks accu stack -> let map = accu in let l = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in let ks = log_if_needed (KIter (body, l, KCons (k, ks))) in let accu, stack = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and imul_teznat : type a b c d e f. (a, b, c, d, e, f) imul_teznat_type = +and[@coq_mutual_as_notation] imul_teznat : + type a b c d e f. (a, b, c, d, e, f) imul_teznat_type = fun logger g gas kinfo k ks accu stack -> let x = accu in let y, stack = stack in - match Script_int.to_int64 y with + match[@coq_type_annotation] Script_int.to_int64 y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some y -> Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack -and imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = +and[@coq_mutual_as_notation] imul_nattez : + type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = fun logger g gas kinfo k ks accu stack -> let y = accu in let x, stack = stack in - match Script_int.to_int64 y with + match[@coq_type_annotation] Script_int.to_int64 y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some y -> Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack -and ilsl_nat : type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type = +and[@coq_mutual_as_notation] ilsl_nat : + type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type = fun logger g gas kinfo k ks accu stack -> - let x = accu and y, stack = stack in - match Script_int.shift_left_n x y with + let x = accu in + let y, stack = stack in + match[@coq_type_annotation] Script_int.shift_left_n x y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some x -> (step [@ocaml.tailcall]) g gas k ks x stack -and ilsr_nat : type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type = +and[@coq_mutual_as_notation] ilsr_nat : + type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type = fun logger g gas kinfo k ks accu stack -> - let x = accu and y, stack = stack in - match Script_int.shift_right_n x y with + let x = accu in + let y, stack = stack in + match[@coq_type_annotation] Script_int.shift_right_n x y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some r -> (step [@ocaml.tailcall]) g gas k ks r stack -and ifailwith : ifailwith_type = - { - ifailwith = - (fun logger (ctxt, _) gas kloc tv accu -> - let v = accu in - let ctxt = update_context gas ctxt in - trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v) - >>=? fun (v, _ctxt) -> - let v = Micheline.strip_locations v in - get_log logger >>=? fun log -> fail (Reject (kloc, v, log))); - } - -and iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = +and[@coq_mutual_as_notation] iexec : + type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = fun logger g gas k ks accu stack -> - let arg = accu and code, stack = stack in + let arg = accu in + let code, stack = stack in let (Lam (code, _)) = code in let code = match logger with @@ -464,32 +485,49 @@ and iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = | Some logger -> log_kinstr logger code.kinstr in let ks = KReturn (stack, KCons (k, ks)) in - (step [@ocaml.tailcall]) g gas code ks arg (EmptyCell, EmptyCell) - -and step : type a s b t r f. (a, s, b, t, r, f) step_type = - fun ((ctxt, sc) as g) gas i ks accu stack -> + ((step [@ocaml.tailcall]) + g + gas + code + ks + arg + (EmptyCell, EmptyCell) [@coq_type_annotation]) + +and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = + fun g gas i ks accu stack -> + let ctxt, sc = g in match consume_instr gas i accu stack with | None -> fail Gas.Operation_quota_exceeded | Some gas -> ( - match i with - | ILog (_, event, logger, k) -> + match[@coq_match_gadt] [@coq_match_with_default] (i, accu, stack) with + | ILog (_, event, logger, k), _, _ -> (log [@ocaml.tailcall]) (logger, event) g gas k ks accu stack - | IHalt _ -> (next [@ocaml.tailcall]) g gas ks accu stack + | IHalt _, _, _ -> (next [@ocaml.tailcall]) g gas ks accu stack (* stack ops *) - | IDrop (_, k) -> + | IDrop (_, k), _, (stack : _ * _) -> let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDup (_, k) -> (step [@ocaml.tailcall]) g gas k ks accu (accu, stack) - | ISwap (_, k) -> + | IDup (_, k), _, _ -> + (step [@ocaml.tailcall]) g gas k ks accu (accu, stack) + | ISwap (_, k), _, (stack : _ * _) -> let top, stack = stack in (step [@ocaml.tailcall]) g gas k ks top (accu, stack) - | IConst (_, v, k) -> (step [@ocaml.tailcall]) g gas k ks v (accu, stack) + | IConst (_, v, k), _, _ -> + (step [@ocaml.tailcall]) g gas k ks v (accu, stack) (* options *) - | ICons_some (_, k) -> + | ICons_some (_, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks (Some accu) stack - | ICons_none (_, k) -> - (step [@ocaml.tailcall]) g gas k ks None (accu, stack) - | IIf_none {branch_if_none; branch_if_some; k; _} -> ( + | ICons_none (_, k), _, _ -> + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + (accu, stack) + | ( IIf_none {branch_if_none; branch_if_some; k; _}, + (accu : _ option), + (stack : _ * _) ) -> ( match accu with | None -> let accu, stack = stack in @@ -508,29 +546,53 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (KCons (k, ks)) v stack) - | IOpt_map {body; k; kinfo = _} -> ( + | IOpt_map {body; k; kinfo = _}, (accu : _ option), _ -> ( match accu with - | None -> (step [@ocaml.tailcall]) g gas k ks None stack + | None -> + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + stack | Some v -> - let ks' = KMap_head (Option.some, KCons (k, ks)) in + let ks' = + KMap_head ((Option.some [@coq_type_annotation]), KCons (k, ks)) + in (step [@ocaml.tailcall]) g gas body ks' v stack) (* pairs *) - | ICons_pair (_, k) -> + | ICons_pair (_, k), _, (stack : _ * _) -> let b, stack = stack in (step [@ocaml.tailcall]) g gas k ks (accu, b) stack - | IUnpair (_, k) -> + | IUnpair (_, k), (accu : _ * _), _ -> let a, b = accu in (step [@ocaml.tailcall]) g gas k ks a (b, stack) - | ICar (_, k) -> + | ICar (_, k), (accu : _ * _), _ -> let a, _ = accu in (step [@ocaml.tailcall]) g gas k ks a stack - | ICdr (_, k) -> + | ICdr (_, k), (accu : _ * _), _ -> let _, b = accu in (step [@ocaml.tailcall]) g gas k ks b stack (* unions *) - | ICons_left (_, k) -> (step [@ocaml.tailcall]) g gas k ks (L accu) stack - | ICons_right (_, k) -> (step [@ocaml.tailcall]) g gas k ks (R accu) stack - | IIf_left {branch_if_left; branch_if_right; k; _} -> ( + | ICons_left (_, k), _, _ -> + (step [@ocaml.tailcall]) + g + gas + k + ks + (L accu [@coq_type_annotation]) + stack + | ICons_right (_, k), _, _ -> + (step [@ocaml.tailcall]) + g + gas + k + ks + (R accu [@coq_type_annotation]) + stack + | IIf_left {branch_if_left; branch_if_right; k; _}, (accu : _ union), _ + -> ( match accu with | L v -> (step [@ocaml.tailcall]) @@ -549,15 +611,23 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = v stack) (* lists *) - | ICons_list (_, k) -> + | ICons_list (_, k), _, (stack : _ * _) -> let tl, stack = stack in let accu = Script_list.cons accu tl in (step [@ocaml.tailcall]) g gas k ks accu stack - | INil (_, k) -> + | INil (_, k), _, _ -> let stack = (accu, stack) in let accu = Script_list.empty in - (step [@ocaml.tailcall]) g gas k ks accu stack - | IIf_cons {branch_if_cons; branch_if_nil; k; _} -> ( + (step [@ocaml.tailcall]) + g + gas + k + ks + (accu [@coq_implicit "E" "__INil_'b"]) + stack + | ( IIf_cons {branch_if_cons; branch_if_nil; k; _}, + (accu : _ boxed_list), + (stack : _ * _) ) -> ( match accu.elements with | [] -> let accu, stack = stack in @@ -577,88 +647,117 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (KCons (k, ks)) hd (tl, stack)) - | IList_map (_, body, k) -> - (ilist_map [@ocaml.tailcall]) id g gas body k ks accu stack - | IList_size (_, k) -> + | IList_map (_, body, k), (accu : _ boxed_list), (stack : _ * _) -> + (ilist_map [@ocaml.tailcall] [@coq_implicit "f" "__IList_map_'b"]) + id + g + gas + body + k + ks + accu + stack + | IList_size (_, k), (accu : _ boxed_list), _ -> let list = accu in let len = Script_int.(abs (of_int list.length)) in (step [@ocaml.tailcall]) g gas k ks len stack - | IList_iter (_, body, k) -> + | IList_iter (_, body, k), (accu : _ boxed_list), (stack : _ * _) -> (ilist_iter [@ocaml.tailcall]) id g gas body k ks accu stack (* sets *) - | IEmpty_set (_, ty, k) -> - let res = Script_set.empty ty in + | IEmpty_set (_, ty, k), _, _ -> + let res = (Script_set.empty [@coq_type_annotation]) ty in let stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks res stack - | ISet_iter (_, body, k) -> + | ISet_iter (_, body, k), (accu : _ set), (stack : _ * _) -> (iset_iter [@ocaml.tailcall]) id g gas body k ks accu stack - | ISet_mem (_, k) -> + | ISet_mem (_, k), _, (stack : _ * _) -> let set, stack = stack in let res = Script_set.mem accu set in (step [@ocaml.tailcall]) g gas k ks res stack - | ISet_update (_, k) -> + | ISet_update (_, k), _, (stack : _ * (_ * _)) -> let presence, (set, stack) = stack in let res = Script_set.update accu presence set in (step [@ocaml.tailcall]) g gas k ks res stack - | ISet_size (_, k) -> + | ISet_size (_, k), (accu : _ set), _ -> let res = Script_set.size accu in (step [@ocaml.tailcall]) g gas k ks res stack (* maps *) - | IEmpty_map (_, ty, k) -> - let res = Script_map.empty ty and stack = (accu, stack) in + | IEmpty_map (_, ty, k), _, _ -> + let res = (Script_map.empty [@coq_type_annotation]) ty in + let stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_map (_, body, k) -> - (imap_map [@ocaml.tailcall]) id g gas body k ks accu stack - | IMap_iter (_, body, k) -> + | IMap_map (_, body, k), (accu : _ map), (stack : _ * _) -> + (imap_map [@ocaml.tailcall] [@coq_implicit "g" "__IMap_map_'c"]) + id + g + gas + body + k + ks + accu + stack + | IMap_iter (_, body, k), (accu : _ map), (stack : _ * _) -> (imap_iter [@ocaml.tailcall]) id g gas body k ks accu stack - | IMap_mem (_, k) -> + | IMap_mem (_, k), _, (stack : _ * _) -> let map, stack = stack in let res = Script_map.mem accu map in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_get (_, k) -> + | IMap_get (_, k), _, (stack : _ * _) -> let map, stack = stack in let res = Script_map.get accu map in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_update (_, k) -> + | IMap_update (_, k), _, (stack : _ * (_ * _)) -> let v, (map, stack) = stack in let key = accu in let res = Script_map.update key v map in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_get_and_update (_, k) -> + | IMap_get_and_update (_, k), _, (stack : _ * (_ * _)) -> let key = accu in let v, (map, rest) = stack in let map' = Script_map.update key v map in let v' = Script_map.get key map in (step [@ocaml.tailcall]) g gas k ks v' (map', rest) - | IMap_size (_, k) -> + | IMap_size (_, k), (accu : _ map), _ -> let res = Script_map.size accu in (step [@ocaml.tailcall]) g gas k ks res stack (* Big map operations *) - | IEmpty_big_map (_, tk, tv, k) -> - let ebm = Script_big_map.empty tk tv in + | IEmpty_big_map (_, tk, tv, k), _, _ -> + let ebm = + (Script_big_map.empty + [@coq_implicit "a" "__IEmpty_big_map_'b"] + [@coq_implicit "b" "__IEmpty_big_map_'c"]) + tk + tv + in (step [@ocaml.tailcall]) g gas k ks ebm (accu, stack) - | IBig_map_mem (_, k) -> + | IBig_map_mem (_, k), _, (stack : _ * _) -> let map, stack = stack in let key = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_big_map.mem ctxt key map ) >>=? fun (res, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | IBig_map_get (_, k) -> + | IBig_map_get (_, k), _, (stack : _ * _) -> let map, stack = stack in let key = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_big_map.get ctxt key map ) >>=? fun (res, ctxt, gas) -> - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | IBig_map_update (_, k) -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (res [@coq_type_annotation]) + stack + | IBig_map_update (_, k), _, (stack : _ * (_ * _)) -> let key = accu in let maybe_value, (map, stack) = stack in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_big_map.update ctxt key maybe_value map ) >>=? fun (big_map, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks big_map stack - | IBig_map_get_and_update (_, k) -> + | IBig_map_get_and_update (_, k), _, (stack : _ * (_ * _)) -> let key = accu in let v, (map, stack) = stack in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> @@ -666,33 +765,39 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = >>=? fun ((v', map'), ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks v' (map', stack) (* timestamp operations *) - | IAdd_seconds_to_timestamp (_, k) -> + | ( IAdd_seconds_to_timestamp (_, k), + (accu : _ Script_int.num), + (stack : _ * _) ) -> let n = accu in let t, stack = stack in let result = Script_timestamp.add_delta t n in (step [@ocaml.tailcall]) g gas k ks result stack - | IAdd_timestamp_to_seconds (_, k) -> + | ( IAdd_timestamp_to_seconds (_, k), + (accu : Script_timestamp.t), + (stack : _ * _) ) -> let t = accu in let n, stack = stack in let result = Script_timestamp.add_delta t n in (step [@ocaml.tailcall]) g gas k ks result stack - | ISub_timestamp_seconds (_, k) -> + | ( ISub_timestamp_seconds (_, k), + (accu : Script_timestamp.t), + (stack : _ * _) ) -> let t = accu in let s, stack = stack in let result = Script_timestamp.sub_delta t s in (step [@ocaml.tailcall]) g gas k ks result stack - | IDiff_timestamps (_, k) -> + | IDiff_timestamps (_, k), (accu : Script_timestamp.t), (stack : _ * _) -> let t1 = accu in let t2, stack = stack in let result = Script_timestamp.diff t1 t2 in (step [@ocaml.tailcall]) g gas k ks result stack (* string operations *) - | IConcat_string_pair (_, k) -> + | IConcat_string_pair (_, k), (accu : Script_string.t), (stack : _ * _) -> let x = accu in let y, stack = stack in let s = Script_string.concat_pair x y in (step [@ocaml.tailcall]) g gas k ks s stack - | IConcat_string (_, k) -> + | IConcat_string (_, k), (accu : _ boxed_list), _ -> let ss = accu in (* The cost for this fold_left has been paid upfront *) let total_length = @@ -704,8 +809,11 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = consume gas (Interp_costs.concat_string total_length) >>?= fun gas -> let s = Script_string.concat ss.elements in (step [@ocaml.tailcall]) g gas k ks s stack - | ISlice_string (_, k) -> - let offset = accu and length, (s, stack) = stack in + | ( ISlice_string (_, k), + (accu : _ Script_int.num), + (stack : _ * (Script_string.t * _)) ) -> + let offset = accu in + let length, (s, stack) = stack in let s_length = Z.of_int (Script_string.length s) in let offset = Script_int.to_zint offset in let length = Script_int.to_zint length in @@ -713,18 +821,25 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = then let s = Script_string.sub s (Z.to_int offset) (Z.to_int length) in (step [@ocaml.tailcall]) g gas k ks (Some s) stack - else (step [@ocaml.tailcall]) g gas k ks None stack - | IString_size (_, k) -> + else + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + stack + | IString_size (_, k), (accu : Script_string.t), _ -> let s = accu in let result = Script_int.(abs (of_int (Script_string.length s))) in (step [@ocaml.tailcall]) g gas k ks result stack (* bytes operations *) - | IConcat_bytes_pair (_, k) -> + | IConcat_bytes_pair (_, k), (accu : bytes), (stack : _ * _) -> let x = accu in let y, stack = stack in let s = Bytes.cat x y in (step [@ocaml.tailcall]) g gas k ks s stack - | IConcat_bytes (_, k) -> + | IConcat_bytes (_, k), (accu : _ boxed_list), _ -> let ss = accu in (* The cost for this fold_left has been paid upfront *) let total_length = @@ -736,8 +851,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = consume gas (Interp_costs.concat_string total_length) >>?= fun gas -> let s = Bytes.concat Bytes.empty ss.elements in (step [@ocaml.tailcall]) g gas k ks s stack - | ISlice_bytes (_, k) -> - let offset = accu and length, (s, stack) = stack in + | ISlice_bytes (_, k), (accu : _ Script_int.num), (stack : _ * (_ * _)) -> + let offset = accu in + let length, (s, stack) = stack in let s_length = Z.of_int (Bytes.length s) in let offset = Script_int.to_zint offset in let length = Script_int.to_zint length in @@ -745,85 +861,102 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = then let s = Bytes.sub s (Z.to_int offset) (Z.to_int length) in (step [@ocaml.tailcall]) g gas k ks (Some s) stack - else (step [@ocaml.tailcall]) g gas k ks None stack - | IBytes_size (_, k) -> + else + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + stack + | IBytes_size (_, k), (accu : bytes), _ -> let s = accu in let result = Script_int.(abs (of_int (Bytes.length s))) in (step [@ocaml.tailcall]) g gas k ks result stack (* currency operations *) - | IAdd_tez (_, k) -> + | IAdd_tez (_, k), (accu : Tez.t), (stack : _ * _) -> let x = accu in let y, stack = stack in Tez.(x +? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack - | ISub_tez (_, k) -> + | ISub_tez (_, k), (accu : Tez.t), (stack : _ * _) -> let x = accu in let y, stack = stack in let res = Tez.sub_opt x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ISub_tez_legacy (_, k) -> + | ISub_tez_legacy (_, k), (accu : Tez.t), (stack : _ * _) -> let x = accu in let y, stack = stack in Tez.(x -? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_teznat (kinfo, k) -> imul_teznat None g gas kinfo k ks accu stack - | IMul_nattez (kinfo, k) -> imul_nattez None g gas kinfo k ks accu stack + | IMul_teznat (kinfo, k), (accu : Tez.t), (stack : _ Script_int.num * _) + -> + imul_teznat None g gas kinfo k ks accu stack + | IMul_nattez (kinfo, k), (accu : _ Script_int.num), (stack : Tez.t * _) + -> + imul_nattez None g gas kinfo k ks accu stack (* boolean operations *) - | IOr (_, k) -> + | IOr (_, k), (accu : bool), (stack : _ * _) -> let x = accu in let y, stack = stack in (step [@ocaml.tailcall]) g gas k ks (x || y) stack - | IAnd (_, k) -> + | IAnd (_, k), (accu : bool), (stack : _ * _) -> let x = accu in let y, stack = stack in (step [@ocaml.tailcall]) g gas k ks (x && y) stack - | IXor (_, k) -> + | IXor (_, k), (accu : bool), (stack : _ * _) -> let x = accu in let y, stack = stack in let res = Compare.Bool.(x <> y) in (step [@ocaml.tailcall]) g gas k ks res stack - | INot (_, k) -> + | INot (_, k), (accu : bool), _ -> let x = accu in (step [@ocaml.tailcall]) g gas k ks (not x) stack (* integer operations *) - | IIs_nat (_, k) -> + | IIs_nat (_, k), (accu : _ Script_int.num), _ -> let x = accu in let res = Script_int.is_nat x in (step [@ocaml.tailcall]) g gas k ks res stack - | IAbs_int (_, k) -> + | IAbs_int (_, k), (accu : _ Script_int.num), _ -> let x = accu in let res = Script_int.abs x in (step [@ocaml.tailcall]) g gas k ks res stack - | IInt_nat (_, k) -> + | IInt_nat (_, k), (accu : _ Script_int.num), _ -> let x = accu in let res = Script_int.int x in (step [@ocaml.tailcall]) g gas k ks res stack - | INeg (_, k) -> + | INeg (_, k), (accu : _ Script_int.num), _ -> let x = accu in let res = Script_int.neg x in (step [@ocaml.tailcall]) g gas k ks res stack - | IAdd_int (_, k) -> - let x = accu and y, stack = stack in + | IAdd_int (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.add x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IAdd_nat (_, k) -> - let x = accu and y, stack = stack in + | IAdd_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.add_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ISub_int (_, k) -> - let x = accu and y, stack = stack in + | ISub_int (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.sub x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_int (_, k) -> - let x = accu and y, stack = stack in + | IMul_int (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_nat (_, k) -> - let x = accu and y, stack = stack in + | IMul_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.mul_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IEdiv_teznat (_, k) -> - let x = accu and y, stack = stack in + | IEdiv_teznat (_, k), (accu : Tez.t), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let x = Script_int.of_int64 (Tez.to_mutez x) in let result = match Script_int.ediv x y with @@ -839,8 +972,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | _ -> assert false) in (step [@ocaml.tailcall]) g gas k ks result stack - | IEdiv_tez (_, k) -> - let x = accu and y, stack = stack in + | IEdiv_tez (_, k), (accu : Tez.t), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in let result = @@ -855,38 +989,54 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | Some r -> Some (q, r))) in (step [@ocaml.tailcall]) g gas k ks result stack - | IEdiv_int (_, k) -> - let x = accu and y, stack = stack in + | ( IEdiv_int (_, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> + let x = accu in + let y, stack = stack in let res = Script_int.ediv x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IEdiv_nat (_, k) -> - let x = accu and y, stack = stack in + | IEdiv_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.ediv_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ILsl_nat (kinfo, k) -> ilsl_nat None g gas kinfo k ks accu stack - | ILsr_nat (kinfo, k) -> ilsr_nat None g gas kinfo k ks accu stack - | IOr_nat (_, k) -> - let x = accu and y, stack = stack in + | ( ILsl_nat (kinfo, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> + ilsl_nat None g gas kinfo k ks accu stack + | ( ILsr_nat (kinfo, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> + ilsr_nat None g gas kinfo k ks accu stack + | IOr_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.logor x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IAnd_nat (_, k) -> - let x = accu and y, stack = stack in + | IAnd_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.logand x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IAnd_int_nat (_, k) -> - let x = accu and y, stack = stack in + | IAnd_int_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.logand x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IXor_nat (_, k) -> - let x = accu and y, stack = stack in + | IXor_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.logxor x y in (step [@ocaml.tailcall]) g gas k ks res stack - | INot_int (_, k) -> + | INot_int (_, k), (accu : _ Script_int.num), _ -> let x = accu in let res = Script_int.lognot x in (step [@ocaml.tailcall]) g gas k ks res stack (* control *) - | IIf {branch_if_true; branch_if_false; k; _} -> + | ( IIf {branch_if_true; branch_if_false; k; _}, + (accu : bool), + (stack : _ * _) ) -> let res, stack = stack in if accu then (step [@ocaml.tailcall]) @@ -904,30 +1054,31 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (KCons (k, ks)) res stack - | ILoop (_, body, k) -> + | ILoop (_, body, k), _, _ -> let ks = KLoop_in (body, KCons (k, ks)) in (next [@ocaml.tailcall]) g gas ks accu stack - | ILoop_left (_, bl, br) -> + | ILoop_left (_, bl, br), _, _ -> let ks = KLoop_in_left (bl, KCons (br, ks)) in (next [@ocaml.tailcall]) g gas ks accu stack - | IDip (_, b, k) -> + | IDip (_, b, k), _, (stack : _ * _) -> let ign = accu in let ks = KUndip (ign, KCons (k, ks)) in let accu, stack = stack in (step [@ocaml.tailcall]) g gas b ks accu stack - | IExec (_, k) -> iexec None g gas k ks accu stack - | IApply (_, capture_ty, k) -> + | IExec (_, k), _, (stack : _ lambda * _) -> + iexec None g gas k ks accu stack + | IApply (_, capture_ty, k), _, (stack : _ lambda * _) -> let capture = accu in let lam, stack = stack in apply ctxt gas capture_ty capture lam >>=? fun (lam', ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks lam' stack - | ILambda (_, lam, k) -> + | ILambda (_, lam, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks lam (accu, stack) - | IFailwith (_, kloc, tv) -> + | IFailwith (_, kloc, tv), _, _ -> let {ifailwith} = ifailwith in ifailwith None g gas kloc tv accu (* comparison *) - | ICompare (_, ty, k) -> + | ICompare (_, ty, k), _, (stack : _ * _) -> let a = accu in let b, stack = stack in let r = @@ -935,53 +1086,53 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in (step [@ocaml.tailcall]) g gas k ks r stack (* comparators *) - | IEq (_, k) -> + | IEq (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a = 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | INeq (_, k) -> + | INeq (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a <> 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | ILt (_, k) -> + | ILt (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a < 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | ILe (_, k) -> + | ILe (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a <= 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | IGt (_, k) -> + | IGt (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a > 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | IGe (_, k) -> + | IGe (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a >= 0) in (step [@ocaml.tailcall]) g gas k ks a stack (* packing *) - | IPack (_, ty, k) -> + | IPack (_, ty, k), _, _ -> let value = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_ir_translator.pack_data ctxt ty value ) >>=? fun (bytes, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks bytes stack - | IUnpack (_, ty, k) -> + | IUnpack (_, ty, k), (accu : bytes), _ -> let bytes = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> - unpack ctxt ~ty ~bytes ) + (unpack [@coq_type_annotation]) ctxt ~ty ~bytes ) >>=? fun (opt, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks opt stack - | IAddress (_, k) -> + | IAddress (_, k), (accu : _ Script_typed_ir.typed_contract), _ -> let (Typed_contract {address; _}) = accu in (step [@ocaml.tailcall]) g gas k ks address stack - | IContract (kinfo, t, entrypoint, k) -> ( + | IContract (kinfo, t, entrypoint, k), (accu : address), _ -> ( let addr = accu in let entrypoint_opt = if Entrypoint.is_default addr.entrypoint then Some entrypoint @@ -1001,8 +1152,15 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let gas, ctxt = local_gas_counter_and_outdated_context ctxt in let accu = maybe_contract in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) - | ITransfer_tokens (kinfo, k) -> + | None -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack) + | ITransfer_tokens (kinfo, k), _, (stack : _ * (_ typed_contract * _)) -> let p = accu in let amount, (Typed_contract {arg_ty; address}, stack) = stack in let {destination; entrypoint} = address in @@ -1017,7 +1175,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = entrypoint >>=? fun (accu, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack - | IImplicit_account (_, k) -> + | IImplicit_account (_, k), (accu : public_key_hash), _ -> let key = accu in let arg_ty = unit_t in let address = @@ -1028,14 +1186,22 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in let res = Typed_contract {arg_ty; address} in (step [@ocaml.tailcall]) g gas k ks res stack - | IView (_, View_signature {name; input_ty; output_ty}, k) -> ( + | ( IView (_, View_signature {name; input_ty; output_ty}, k), + _, + (stack : address * _) ) -> ( let input = accu in let addr, stack = stack in let c = addr.destination in let ctxt = update_context gas ctxt in let return_none ctxt = let gas, ctxt = local_gas_counter_and_outdated_context ctxt in - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack in match c with | Contract (Implicit _) | Tx_rollup _ | Sc_rollup _ -> @@ -1050,8 +1216,15 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = ~allow_forged_in_storage:true ctxt script - >>=? fun ( Ex_script (Script {storage; storage_type; views; _}), - ctxt ) -> + >>=? fun [@coq_match_gadt] ( Ex_script + (Script + { + storage; + storage_type; + views; + _; + }), + ctxt ) -> Gas.consume ctxt (Interp_costs.view_get name views) >>?= fun ctxt -> match Script_map.get name views with @@ -1093,7 +1266,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (return_none [@ocaml.tailcall]) ctxt | Ok (Eq, Eq) -> ( let kkinfo = kinfo_of_kinstr k in - match kkinfo.kstack_ty with + match[@coq_match_with_default] kkinfo.kstack_ty with | Item_t (_, s) -> let kstack_ty = Item_t (output_ty, s) in let kkinfo = {kkinfo with kstack_ty} in @@ -1123,7 +1296,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (KView_exit (sc, KReturn (stack, ks))) (input, storage) (EmptyCell, EmptyCell)))))) - | ICreate_contract {storage_type; code; k; kinfo = _} -> + | ( ICreate_contract {storage_type; code; k; kinfo = _}, + (accu : public_key_hash option), + (stack : _ * (_ * _)) ) -> (* Removed the instruction's arguments manager, spendable and delegatable *) let delegate = accu in let credit, (init, stack) = stack in @@ -1132,7 +1307,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let destination = Destination.Contract (Originated contract) in let stack = ({destination; entrypoint = Entrypoint.default}, stack) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | ISet_delegate (_, k) -> + | ISet_delegate (_, k), (accu : public_key_hash option), _ -> let delegate = accu in let operation = Delegation delegate in let ctxt = update_context gas ctxt in @@ -1141,18 +1316,25 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = Internal_operation {source = Contract.Originated sc.self; operation; nonce} in - let res = {piop; lazy_storage_diff = None} in + let res = + { + piop; + lazy_storage_diff = + (None [@coq_type_annotation] : Lazy_storage.diffs option); + } + in let gas, ctxt = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | IBalance (_, k) -> + | IBalance (_, k), _, _ -> let ctxt = update_context gas ctxt in let gas, ctxt = local_gas_counter_and_outdated_context ctxt in let g = (ctxt, sc) in (step [@ocaml.tailcall]) g gas k ks sc.balance (accu, stack) - | ILevel (_, k) -> + | ILevel (_, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks sc.level (accu, stack) - | INow (_, k) -> (step [@ocaml.tailcall]) g gas k ks sc.now (accu, stack) - | IMin_block_time (_, k) -> + | INow (_, k), _, _ -> + (step [@ocaml.tailcall]) g gas k ks sc.now (accu, stack) + | IMin_block_time (_, k), _, _ -> let ctxt = update_context gas ctxt in let min_block_time = Alpha_context.Constants.minimal_block_delay ctxt @@ -1162,47 +1344,49 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in let new_stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks min_block_time new_stack - | ICheck_signature (_, k) -> - let key = accu and signature, (message, stack) = stack in + | ICheck_signature (_, k), (accu : public_key), (stack : _ * (_ * _)) -> + let key = accu in + let signature, (message, stack) = stack in let res = Script_signature.check key signature message in (step [@ocaml.tailcall]) g gas k ks res stack - | IHash_key (_, k) -> + | IHash_key (_, k), (accu : public_key), _ -> let key = accu in let res = Signature.Public_key.hash key in (step [@ocaml.tailcall]) g gas k ks res stack - | IBlake2b (_, k) -> + | IBlake2b (_, k), (accu : bytes), _ -> let bytes = accu in let hash = Raw_hashes.blake2b bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha256 (_, k) -> + | ISha256 (_, k), (accu : bytes), _ -> let bytes = accu in let hash = Raw_hashes.sha256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha512 (_, k) -> + | ISha512 (_, k), (accu : bytes), _ -> let bytes = accu in let hash = Raw_hashes.sha512 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISource (_, k) -> + | ISource (_, k), _, _ -> let destination : Destination.t = Contract sc.payer in let res = {destination; entrypoint = Entrypoint.default} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISender (_, k) -> + | ISender (_, k), _, _ -> let destination : Destination.t = Contract sc.source in let res = {destination; entrypoint = Entrypoint.default} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISelf (_, ty, entrypoint, k) -> + | ISelf (_, ty, entrypoint, k), _, _ -> let destination : Destination.t = Contract (Originated sc.self) in let address = {destination; entrypoint} in let res = Typed_contract {arg_ty = ty; address} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISelf_address (_, k) -> + | ISelf_address (_, k), _, _ -> let destination : Destination.t = Contract (Originated sc.self) in let res = {destination; entrypoint = Entrypoint.default} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | IAmount (_, k) -> - let accu = sc.amount and stack = (accu, stack) in + | IAmount (_, k), _, _ -> + let stack = (accu, stack) in + let accu = sc.amount in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDig (_, _n, n', k) -> + | IDig (_, _n, n', k), _, _ -> let (accu, stack), x = interp_stack_prefix_preserving_operation (fun v stack -> (stack, v)) @@ -1210,9 +1394,10 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = accu stack in - let accu = x and stack = (accu, stack) in + let stack = ((accu, stack) [@coq_type_annotation]) in + let accu = x in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDug (_, _n, n', k) -> + | IDug (_, _n, n', k), _, (stack : _ * _) -> let v = accu in let accu, stack = stack in let (accu, stack), () = @@ -1222,34 +1407,44 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = accu stack in - (step [@ocaml.tailcall]) g gas k ks accu stack - | IDipn (_, _n, n', b, k) -> - let accu, stack, restore_prefix = kundip n' accu stack k in + (step [@ocaml.tailcall]) + g + gas + k + ks + (accu [@coq_type_annotation]) + (stack [@coq_type_annotation]) + | IDipn (_, _n, n', b, k), _, _ -> + let accu, stack, restore_prefix = + (kundip [@coq_type_annotation]) n' accu stack k + in let ks = KCons (restore_prefix, ks) in (step [@ocaml.tailcall]) g gas b ks accu stack - | IDropn (_, _n, n', k) -> + | IDropn (_, _n, n', k), _, _ -> let stack = - let rec aux : + let[@coq_struct "w_value"] rec aux : type a s b t. (b, t, b, t, a, s, a, s) stack_prefix_preservation_witness -> a -> s -> b * t = fun w accu stack -> - match w with - | KRest -> (accu, stack) - | KPrefix (_, w) -> + match[@coq_match_gadt] (w, accu, stack) with + | KRest, (accu : b), (stack : t) -> (accu, stack) + | KPrefix (_, w), _, (stack : _ * _) -> let accu, stack = stack in aux w accu stack in - aux n' accu stack + (aux [@coq_type_annotation]) n' accu stack in let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | ISapling_empty_state (_, memo_size, k) -> + | ISapling_empty_state (_, memo_size, k), _, _ -> let state = Sapling.empty_state ~memo_size () in (step [@ocaml.tailcall]) g gas k ks state (accu, stack) - | ISapling_verify_update (_, k) -> ( + | ( ISapling_verify_update (_, k), + (accu : Sapling.transaction), + (stack : _ * _) ) -> ( let transaction = accu in let state, stack = stack in let address = Contract_hash.to_b58check sc.self in @@ -1268,8 +1463,17 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (Script_int.of_int64 balance, state) ) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) - | ISapling_verify_update_deprecated (_, k) -> ( + | None -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack) + | ( ISapling_verify_update_deprecated (_, k), + (accu : Sapling_repr.legacy_transaction), + (stack : _ * _) ) -> ( let transaction = accu in let state, stack = stack in let address = Contract_hash.to_b58check sc.self in @@ -1284,170 +1488,223 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | Some (balance, state) -> let state = Some (Script_int.of_int64 balance, state) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) - | IChainId (_, k) -> - let accu = Script_chain_id.make sc.chain_id - and stack = (accu, stack) in + | None -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack) + | IChainId (_, k), _, _ -> + let stack = (accu, stack) in + let accu = Script_chain_id.make sc.chain_id in (step [@ocaml.tailcall]) g gas k ks accu stack - | INever _ -> ( match accu with _ -> .) - | IVoting_power (_, k) -> + | INever _, _, _ -> . + | IVoting_power (_, k), (accu : public_key_hash), _ -> let key_hash = accu in let ctxt = update_context gas ctxt in Vote.get_voting_power ctxt key_hash >>=? fun (ctxt, power) -> let power = Script_int.(abs (of_int64 power)) in let gas, ctxt = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks power stack - | ITotal_voting_power (_, k) -> + | ITotal_voting_power (_, k), _, _ -> let ctxt = update_context gas ctxt in Vote.get_total_voting_power ctxt >>=? fun (ctxt, power) -> let power = Script_int.(abs (of_int64 power)) in let gas, ctxt = local_gas_counter_and_outdated_context ctxt in let g = (ctxt, sc) in (step [@ocaml.tailcall]) g gas k ks power (accu, stack) - | IKeccak (_, k) -> + | IKeccak (_, k), (accu : bytes), _ -> let bytes = accu in let hash = Raw_hashes.keccak256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha3 (_, k) -> + | ISha3 (_, k), (accu : bytes), _ -> let bytes = accu in let hash = Raw_hashes.sha3_256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | IAdd_bls12_381_g1 (_, k) -> - let x = accu and y, stack = stack in + | ( IAdd_bls12_381_g1 (_, k), + (accu : Script_bls.G1.t), + (stack : Script_bls.G1.t * _) ) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.G1.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IAdd_bls12_381_g2 (_, k) -> - let x = accu and y, stack = stack in + | ( IAdd_bls12_381_g2 (_, k), + (accu : Script_bls.G2.t), + (stack : Script_bls.G2.t * _) ) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.G2.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IAdd_bls12_381_fr (_, k) -> - let x = accu and y, stack = stack in + | ( IAdd_bls12_381_fr (_, k), + (accu : Script_bls.Fr.t), + (stack : Script_bls.Fr.t * _) ) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.Fr.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_g1 (_, k) -> - let x = accu and y, stack = stack in + | ( IMul_bls12_381_g1 (_, k), + (accu : Script_bls.G1.t), + (stack : Script_bls.Fr.t * _) ) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.G1.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_g2 (_, k) -> - let x = accu and y, stack = stack in + | ( IMul_bls12_381_g2 (_, k), + (accu : Script_bls.G2.t), + (stack : Script_bls.Fr.t * _) ) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.G2.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_fr (_, k) -> - let x = accu and y, stack = stack in + | ( IMul_bls12_381_fr (_, k), + (accu : Script_bls.Fr.t), + (stack : Script_bls.Fr.t * _) ) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_fr_z (_, k) -> - let x = accu and y, stack = stack in + | ( IMul_bls12_381_fr_z (_, k), + (accu : _ Script_int.num), + (stack : Script_bls.Fr.t * _) ) -> + let x = accu in + let y, stack = stack in let x = Script_bls.Fr.of_z (Script_int.to_zint x) in let res = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_bls12_381_z_fr (_, k) -> - let y = accu and x, stack = stack in + | ( IMul_bls12_381_z_fr (_, k), + (accu : Script_bls.Fr.t), + (stack : _ Script_int.num * _) ) -> + let y = accu in + let x, stack = stack in let x = Script_bls.Fr.of_z (Script_int.to_zint x) in let res = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IInt_bls12_381_fr (_, k) -> + | IInt_bls12_381_fr (_, k), (accu : Script_bls.Fr.t), _ -> let x = accu in let res = Script_int.of_zint (Script_bls.Fr.to_z x) in (step [@ocaml.tailcall]) g gas k ks res stack - | INeg_bls12_381_g1 (_, k) -> + | INeg_bls12_381_g1 (_, k), (accu : Script_bls.G1.t), _ -> let x = accu in let accu = Script_bls.G1.negate x in (step [@ocaml.tailcall]) g gas k ks accu stack - | INeg_bls12_381_g2 (_, k) -> + | INeg_bls12_381_g2 (_, k), (accu : Script_bls.G2.t), _ -> let x = accu in let accu = Script_bls.G2.negate x in (step [@ocaml.tailcall]) g gas k ks accu stack - | INeg_bls12_381_fr (_, k) -> + | INeg_bls12_381_fr (_, k), (accu : Script_bls.Fr.t), _ -> let x = accu in let accu = Script_bls.Fr.negate x in (step [@ocaml.tailcall]) g gas k ks accu stack - | IPairing_check_bls12_381 (_, k) -> + | IPairing_check_bls12_381 (_, k), (accu : _ boxed_list), _ -> let pairs = accu in let check = Script_bls.pairing_check pairs.elements in (step [@ocaml.tailcall]) g gas k ks check stack - | IComb (_, _, witness, k) -> - let rec aux : + | IComb (_, _, witness, k), _, _ -> + let[@coq_struct "witness"] rec aux : type before after. (before, after) comb_gadt_witness -> before -> after = fun witness stack -> - match (witness, stack) with - | Comb_one, stack -> stack - | Comb_succ witness', (a, tl) -> - let b, tl' = aux witness' tl in - ((a, b), tl') + match[@coq_match_gadt] (witness, stack) with + | Comb_one, (stack : after) -> stack + | Comb_succ witness', (stack : _ * _) -> + let a, tl = stack in + let b, tl' = (aux [@coq_type_annotation]) witness' tl in + ((((a, b), tl') [@coq_cast]) : after) in - let stack = aux witness (accu, stack) in + let stack = (aux [@coq_type_annotation]) witness (accu, stack) in let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | IUncomb (_, _, witness, k) -> - let rec aux : + | IUncomb (_, _, witness, k), _, _ -> + let[@coq_struct "witness"] rec aux : type before after. (before, after) uncomb_gadt_witness -> before -> after = fun witness stack -> - match (witness, stack) with - | Uncomb_one, stack -> stack - | Uncomb_succ witness', ((a, b), tl) -> (a, aux witness' (b, tl)) + match[@coq_match_gadt] (witness, stack) with + | Uncomb_one, (stack : after) -> stack + | Uncomb_succ witness', (stack : (_ * _) * _) -> + let (a, b), tl = stack in + (((a, (aux [@coq_type_annotation]) witness' (b, tl)) + [@coq_cast]) + : after) in - let stack = aux witness (accu, stack) in + let stack = (aux [@coq_type_annotation]) witness (accu, stack) in let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | IComb_get (_, _, witness, k) -> + | IComb_get (_, _, witness, k), _, _ -> let comb = accu in - let rec aux : + let[@coq_struct "witness"] rec aux : type before after. (before, after) comb_get_gadt_witness -> before -> after = fun witness comb -> - match (witness, comb) with - | Comb_get_zero, v -> v - | Comb_get_one, (a, _) -> a - | Comb_get_plus_two witness', (_, b) -> aux witness' b + match[@coq_match_gadt] (witness, comb) with + | Comb_get_zero, (v : after) -> v + | Comb_get_one, (comb : after * _) -> + let a, _ = comb in + a + | Comb_get_plus_two witness', (comb : _ * _) -> + let _, b = comb in + aux witness' b in - let accu = aux witness comb in + let accu = (aux [@coq_type_annotation]) witness comb in (step [@ocaml.tailcall]) g gas k ks accu stack - | IComb_set (_, _, witness, k) -> - let value = accu and comb, stack = stack in - let rec aux : + | IComb_set (_, _, witness, k), _, (stack : _ * _) -> + let value = accu in + let comb, stack = stack in + let[@coq_struct "witness"] rec aux : type value before after. (value, before, after) comb_set_gadt_witness -> value -> before -> after = fun witness value item -> - match (witness, item) with - | Comb_set_zero, _ -> value - | Comb_set_one, (_hd, tl) -> (value, tl) - | Comb_set_plus_two witness', (hd, tl) -> (hd, aux witness' value tl) + match[@coq_match_gadt] (witness, value, item) with + | Comb_set_zero, (value : after), _ -> value + | Comb_set_one, _, (item : _ * _) -> + let _hd, tl = item in + (((value, tl) [@coq_cast]) : after) + | Comb_set_plus_two witness', _, (item : _ * _) -> + let hd, tl = item in + (((hd, (aux [@coq_type_annotation]) witness' value tl) + [@coq_cast]) + : after) in - let accu = aux witness value comb in + let accu = (aux [@coq_type_annotation]) witness value comb in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDup_n (_, _, witness, k) -> - let rec aux : + | IDup_n (_, _, witness, k), _, _ -> + let[@coq_struct "witness"] rec aux : type before after. (before, after) dup_n_gadt_witness -> before -> after = fun witness stack -> - match (witness, stack) with - | Dup_n_zero, (a, _) -> a - | Dup_n_succ witness', (_, tl) -> aux witness' tl + match[@coq_match_gadt] (witness, stack) with + | Dup_n_zero, (stack : after * _) -> + let a, _ = stack in + a + | Dup_n_succ witness', (stack : _ * _) -> + let _, tl = stack in + aux witness' tl in let stack = (accu, stack) in - let accu = aux witness stack in + let accu = (aux [@coq_type_annotation]) witness stack in (step [@ocaml.tailcall]) g gas k ks accu stack (* Tickets *) - | ITicket (_, k) -> - let contents = accu and amount, stack = stack in + | ITicket (_, k), _, (stack : _ * _) -> + let contents = accu in + let amount, stack = stack in let ticketer = Contract.Originated sc.self in let accu = {ticketer; contents; amount} in (step [@ocaml.tailcall]) g gas k ks accu stack - | IRead_ticket (_, k) -> + | IRead_ticket (_, k), (accu : _ ticket), _ -> let {ticketer; contents; amount} = accu in let stack = (accu, stack) in let destination : Destination.t = Contract ticketer in let addr = {destination; entrypoint = Entrypoint.default} in let accu = (addr, (contents, amount)) in (step [@ocaml.tailcall]) g gas k ks accu stack - | ISplit_ticket (_, k) -> - let ticket = accu and (amount_a, amount_b), stack = stack in + | ISplit_ticket (_, k), (accu : _ ticket), (stack : (_ * _) * _) -> + let ticket = accu in + let (amount_a, amount_b), stack = stack in let result = if Compare.Int.( @@ -1459,7 +1716,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = else None in (step [@ocaml.tailcall]) g gas k ks result stack - | IJoin_tickets (_, contents_ty, k) -> + | IJoin_tickets (_, contents_ty, k), (accu : _ ticket * _ ticket), _ -> let ticket_a, ticket_b = accu in let result = if @@ -1480,7 +1737,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = else None in (step [@ocaml.tailcall]) g gas k ks result stack - | IOpen_chest (_, k) -> + | ( IOpen_chest (_, k), + (accu : Script_timelock.chest_key), + (stack : Script_timelock.chest * (_ Script_int.num * _)) ) -> let open Timelock in let chest_key = accu in let chest, (time_z, stack) = stack in @@ -1522,7 +1781,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = that starts the evaluation. *) -and log : +and[@coq_axiom_with_reason "we ignore the logging operations"] log : type a s b t r f. logger * logging_event -> (a, s, b, t, r, f) step_type = fun (logger, event) ((ctxt, _) as g) gas k ks accu stack -> (match (k, event) with @@ -1531,40 +1790,60 @@ and log : | _, LogExit prev_kinfo -> log_exit logger ctxt gas prev_kinfo k accu stack) ; let k = log_next_kinstr logger k in let with_log k = match k with KLog _ -> k | _ -> KLog (k, logger) in - match k with - | IList_map (_, body, k) -> - (ilist_map [@ocaml.tailcall]) with_log g gas body k ks accu stack - | IList_iter (_, body, k) -> + match[@coq_match_gadt] (k, accu, stack) with + | IList_map (_, body, k), (accu : _ boxed_list), (stack : _ * _) -> + (ilist_map [@ocaml.tailcall] [@coq_implicit "f" "__IList_map_'b2"]) + with_log + g + gas + body + k + ks + accu + stack + | IList_iter (_, body, k), (accu : _ boxed_list), (stack : _ * _) -> (ilist_iter [@ocaml.tailcall]) with_log g gas body k ks accu stack - | ISet_iter (_, body, k) -> + | ISet_iter (_, body, k), (accu : _ set), (stack : _ * _) -> (iset_iter [@ocaml.tailcall]) with_log g gas body k ks accu stack - | IMap_map (_, body, k) -> - (imap_map [@ocaml.tailcall]) with_log g gas body k ks accu stack - | IMap_iter (_, body, k) -> + | IMap_map (_, body, k), (accu : _ map), (stack : _ * _) -> + (imap_map [@ocaml.tailcall] [@coq_implicit "g" "__IMap_map_'c2"]) + with_log + g + gas + body + k + ks + accu + stack + | IMap_iter (_, body, k), (accu : _ map), (stack : _ * _) -> (imap_iter [@ocaml.tailcall]) with_log g gas body k ks accu stack - | ILoop (_, body, k) -> + | ILoop (_, body, k), _, _ -> let ks = with_log (KLoop_in (body, KCons (k, ks))) in (next [@ocaml.tailcall]) g gas ks accu stack - | ILoop_left (_, bl, br) -> + | ILoop_left (_, bl, br), _, _ -> let ks = with_log (KLoop_in_left (bl, KCons (br, ks))) in (next [@ocaml.tailcall]) g gas ks accu stack - | IMul_teznat (kinfo, k) -> + | IMul_teznat (kinfo, k), (accu : Tez.t), (stack : _ Script_int.num * _) -> (imul_teznat [@ocaml.tailcall]) (Some logger) g gas kinfo k ks accu stack - | IMul_nattez (kinfo, k) -> + | IMul_nattez (kinfo, k), (accu : _ Script_int.num), (stack : Tez.t * _) -> (imul_nattez [@ocaml.tailcall]) (Some logger) g gas kinfo k ks accu stack - | ILsl_nat (kinfo, k) -> + | ( ILsl_nat (kinfo, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> (ilsl_nat [@ocaml.tailcall]) (Some logger) g gas kinfo k ks accu stack - | ILsr_nat (kinfo, k) -> + | ( ILsr_nat (kinfo, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> (ilsr_nat [@ocaml.tailcall]) (Some logger) g gas kinfo k ks accu stack - | IFailwith (_, kloc, tv) -> + | IFailwith (_, kloc, tv), _, _ -> let {ifailwith} = ifailwith in (ifailwith [@ocaml.tailcall]) (Some logger) g gas kloc tv accu - | IExec (_, k) -> + | IExec (_, k), _, (stack : _ lambda * _) -> (iexec [@ocaml.tailcall]) (Some logger) g gas k ks accu stack | _ -> (step [@ocaml.tailcall]) g gas k (with_log ks) accu stack [@@inline] -and klog : +and[@coq_axiom_with_reason "we ignore the logging operations"] klog : type a s r f. logger -> outdated_context * step_constants -> @@ -1578,49 +1857,49 @@ and klog : (match ks with KLog _ -> () | _ -> log_control logger ks) ; let enable_log ki = log_kinstr logger ki in let mk k = match k with KLog _ -> k | _ -> KLog (k, logger) in - match ks with - | KCons (ki, ks') -> + match[@coq_match_gadt] (ks, accu, stack) with + | KCons (ki, ks'), _, _ -> let log = enable_log ki in let ks = mk ks' in (step [@ocaml.tailcall]) g gas log ks accu stack - | KNil -> (next [@ocaml.tailcall]) g gas ks accu stack - | KLoop_in (ki, ks') -> + | KNil, _, _ -> (next [@ocaml.tailcall]) g gas ks accu stack + | KLoop_in (ki, ks'), (accu : bool), (stack : _ * _) -> let ks' = mk ks' in let ki = enable_log ki in (kloop_in [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KReturn (stack', ks') -> + | KReturn (stack', ks'), _, _ -> let ks' = mk ks' in let ks = KReturn (stack', ks') in (next [@ocaml.tailcall]) g gas ks accu stack - | KMap_head (f, ks) -> (next [@ocaml.tailcall]) g gas ks (f accu) stack - | KLoop_in_left (ki, ks') -> + | KMap_head (f, ks), _, _ -> (next [@ocaml.tailcall]) g gas ks (f accu) stack + | KLoop_in_left (ki, ks'), (accu : _ union), _ -> let ks' = mk ks' in let ki = enable_log ki in (kloop_in_left [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KUndip (x, ks') -> + | KUndip (x, ks'), _, _ -> let ks' = mk ks' in let ks = KUndip (x, ks') in (next [@ocaml.tailcall]) g gas ks accu stack - | KIter (body, xs, ks') -> + | KIter (body, xs, ks'), _, _ -> let ks' = mk ks' in let body = enable_log body in (kiter [@ocaml.tailcall]) mk g gas body xs ks' accu stack - | KList_enter_body (body, xs, ys, len, ks') -> + | KList_enter_body (body, xs, ys, len, ks'), _, _ -> let ks' = mk ks' in (klist_enter [@ocaml.tailcall]) mk g gas body xs ys len ks' accu stack - | KList_exit_body (body, xs, ys, len, ks') -> + | KList_exit_body (body, xs, ys, len, ks'), _, (stack : _ * _) -> let ks' = mk ks' in (klist_exit [@ocaml.tailcall]) mk g gas body xs ys len ks' accu stack - | KMap_enter_body (body, xs, ys, ks') -> + | KMap_enter_body (body, xs, ys, ks'), _, _ -> let ks' = mk ks' in (kmap_enter [@ocaml.tailcall]) mk g gas body xs ys ks' accu stack - | KMap_exit_body (body, xs, ys, yk, ks') -> + | KMap_exit_body (body, xs, ys, yk, ks'), _, (stack : _ * _) -> let ks' = mk ks' in (kmap_exit [@ocaml.tailcall]) mk g gas body xs ys yk ks' accu stack - | KView_exit (orig_step_constants, ks') -> + | KView_exit (orig_step_constants, ks'), _, _ -> let g = (fst g, orig_step_constants) in (next [@ocaml.tailcall]) g gas ks' accu stack - | KLog (_, _) -> + | KLog (_, _), _, _ -> (* This case should never happen. *) (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] @@ -1690,7 +1969,7 @@ let lift_execution_arg (type a ac) ctxt ~internal (entrypoint_ty : (a, ac) ty) >>?= fun (res, ctxt) -> res >>?= fun Eq -> let parsed_arg : a = parsed_arg in - return (parsed_arg, ctxt)) + return ((parsed_arg [@coq_cast]), ctxt)) >>=? fun (entrypoint_arg, ctxt) -> return (construct entrypoint_arg, ctxt) type execution_result = { @@ -1712,18 +1991,18 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal ~legacy:true ~allow_forged_in_storage:true | Some ex_script -> return (ex_script, ctxt)) - >>=? fun ( Ex_script - (Script - { - code_size; - code; - arg_type; - storage = old_storage; - storage_type; - entrypoints; - views; - }), - ctxt ) -> + >>=? fun [@coq_match_gadt] ( Ex_script + (Script + { + code_size; + code; + arg_type; + storage = old_storage; + storage_type; + entrypoints; + views; + }), + ctxt ) -> Gas_monad.run ctxt (find_entrypoint @@ -1733,9 +2012,13 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal entrypoint) >>?= fun (r, ctxt) -> let self_contract = Contract.Originated step_constants.self in - record_trace (Bad_contract_parameter self_contract) r - >>?= fun (Ex_ty_cstr {ty = entrypoint_ty; construct; original_type_expr = _}) - -> + record_trace (Bad_contract_parameter self_contract) (r [@coq_type_annotation]) + >>?= fun [@coq_match_gadt] (Ex_ty_cstr + { + ty = entrypoint_ty; + construct; + original_type_expr = _; + }) -> trace (Bad_contract_parameter self_contract) (lift_execution_arg ctxt ~internal entrypoint_ty construct arg) @@ -1759,7 +2042,7 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal >>=? fun (storage, lazy_storage_diff, ctxt) -> trace Cannot_serialize_storage - ( unparse_data ctxt mode storage_type storage + ( (unparse_data [@coq_type_annotation]) ctxt mode storage_type storage >>=? fun (unparsed_storage, ctxt) -> Lwt.return ( Gas.consume ctxt (Script.strip_locations_cost unparsed_storage) diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index e4b53ba12eede142e6ca2ae6046fc4216357d453..0bb0033e643886c18944cede3b29d77ab628eee5 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -73,289 +73,267 @@ module Interp_costs = Michelson_v1_gas.Cost_of.Interpreter let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = fun i accu stack -> - match i with - | IList_map _ -> - let list = accu in - Interp_costs.list_map list - | IList_iter _ -> - let list = accu in - Interp_costs.list_iter list - | ISet_iter _ -> - let set = accu in - Interp_costs.set_iter set - | ISet_mem _ -> - let v = accu and set, _ = stack in + match[@coq_match_gadt] [@coq_match_with_default] (i, accu, stack) with + | IList_map _, (list : _ boxed_list), _ -> Interp_costs.list_map list + | IList_iter _, (list : _ boxed_list), _ -> Interp_costs.list_iter list + | ISet_iter _, (set : _ set), _ -> Interp_costs.set_iter set + | ISet_mem _, v, (stack : _ * _) -> + let set, _ = stack in Interp_costs.set_mem v set - | ISet_update _ -> - let v = accu and _, (set, _) = stack in + | ISet_update _, v, (stack : _ * (_ * _)) -> + let _, (set, _) = stack in Interp_costs.set_update v set - | IMap_map _ -> - let map = accu in - Interp_costs.map_map map - | IMap_iter _ -> - let map = accu in - Interp_costs.map_iter map - | IMap_mem _ -> - let v = accu and map, _ = stack in + | IMap_map _, (map : (_, _) map), _ -> Interp_costs.map_map map + | IMap_iter _, (map : (_, _) map), _ -> Interp_costs.map_iter map + | IMap_mem _, v, (stack : (a, _) map * _) -> + let map, _ = stack in Interp_costs.map_mem v map - | IMap_get _ -> - let v = accu and map, _ = stack in + | IMap_get _, v, (stack : (a, _) map * _) -> + let map, _ = stack in Interp_costs.map_get v map - | IMap_update _ -> - let k = accu and _, (map, _) = stack in + | IMap_update _, k, (stack : _ * ((a, _) map * _)) -> + let _, (map, _) = stack in Interp_costs.map_update k map - | IMap_get_and_update _ -> - let k = accu and _, (map, _) = stack in + | IMap_get_and_update _, k, (stack : _ * ((a, _) map * _)) -> + let _, (map, _) = stack in Interp_costs.map_get_and_update k map - | IBig_map_mem _ -> - let Big_map map, _ = stack in - Interp_costs.big_map_mem map.diff - | IBig_map_get _ -> + | IBig_map_get _, _, (stack : (a, _) big_map * _) -> let Big_map map, _ = stack in Interp_costs.big_map_get map.diff - | IBig_map_update _ -> + | IBig_map_mem _, _, (stack : (a, _) big_map * _) -> + let Big_map map, _ = stack in + Interp_costs.big_map_mem map.diff + | IBig_map_update _, _, (stack : _ * ((a, _) big_map * _)) -> let _, (Big_map map, _) = stack in Interp_costs.big_map_update map.diff - | IBig_map_get_and_update _ -> + | IBig_map_get_and_update _, _, (stack : _ * ((a, _) big_map * _)) -> let _, (Big_map map, _) = stack in Interp_costs.big_map_get_and_update map.diff - | IAdd_seconds_to_timestamp _ -> - let n = accu and t, _ = stack in + | ( IAdd_seconds_to_timestamp _, + (n : _ Script_int.num), + (stack : Script_timestamp.t * _) ) -> + let t, _ = stack in Interp_costs.add_seconds_timestamp n t - | IAdd_timestamp_to_seconds _ -> - let t = accu and n, _ = stack in + | ( IAdd_timestamp_to_seconds _, + (t : Script_timestamp.t), + (stack : _ Script_int.num * _) ) -> + let n, _ = stack in Interp_costs.add_timestamp_seconds t n - | ISub_timestamp_seconds _ -> - let t = accu and n, _ = stack in + | ( ISub_timestamp_seconds _, + (t : Script_timestamp.t), + (stack : _ Script_int.num * _) ) -> + let n, _ = stack in Interp_costs.sub_timestamp_seconds t n - | IDiff_timestamps _ -> - let t1 = accu and t2, _ = stack in + | ( IDiff_timestamps _, + (t1 : Script_timestamp.t), + (stack : Script_timestamp.t * _) ) -> + let t2, _ = stack in Interp_costs.diff_timestamps t1 t2 - | IConcat_string_pair _ -> - let x = accu and y, _ = stack in + | IConcat_string_pair _, (x : Script_string.t), (stack : Script_string.t * _) + -> + let y, _ = stack in Interp_costs.concat_string_pair x y - | IConcat_string _ -> - let ss = accu in + | IConcat_string _, (ss : _ boxed_list), _ -> Interp_costs.concat_string_precheck ss - | ISlice_string _ -> - let _offset = accu in + | ISlice_string _, _offset, (stack : _ Script_int.num * (Script_string.t * _)) + -> let _length, (s, _) = stack in Interp_costs.slice_string s - | IConcat_bytes_pair _ -> - let x = accu and y, _ = stack in + | IConcat_bytes_pair _, (x : bytes), (stack : bytes * _) -> + let y, _ = stack in Interp_costs.concat_bytes_pair x y - | IConcat_bytes _ -> - let ss = accu in + | IConcat_bytes _, (ss : _ boxed_list), _ -> Interp_costs.concat_string_precheck ss - | ISlice_bytes _ -> + | ISlice_bytes _, _, (stack : _ * (bytes * _)) -> let _, (s, _) = stack in Interp_costs.slice_bytes s - | IMul_teznat _ -> Interp_costs.mul_teznat - | IMul_nattez _ -> Interp_costs.mul_nattez - | IAbs_int _ -> - let x = accu in - Interp_costs.abs_int x - | INeg _ -> - let x = accu in - Interp_costs.neg x - | IAdd_int _ -> - let x = accu and y, _ = stack in + | IMul_teznat _, _, _ -> Interp_costs.mul_teznat + | IMul_nattez _, _, _ -> Interp_costs.mul_nattez + | IAbs_int _, (x : _ Script_int.num), _ -> Interp_costs.abs_int x + | INeg _, (x : _ Script_int.num), _ -> Interp_costs.neg x + | IAdd_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.add_int x y - | IAdd_nat _ -> - let x = accu and y, _ = stack in + | IAdd_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.add_nat x y - | ISub_int _ -> - let x = accu and y, _ = stack in + | ISub_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.sub_int x y - | IMul_int _ -> - let x = accu and y, _ = stack in + | IMul_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.mul_int x y - | IMul_nat _ -> - let x = accu and y, _ = stack in + | IMul_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.mul_nat x y - | IEdiv_teznat _ -> - let x = accu and y, _ = stack in + | IEdiv_teznat _, x, (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.ediv_teznat x y - | IEdiv_int _ -> - let x = accu and y, _ = stack in + | IEdiv_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.ediv_int x y - | IEdiv_nat _ -> - let x = accu and y, _ = stack in + | IEdiv_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.ediv_nat x y - | ILsl_nat _ -> - let x = accu in - Interp_costs.lsl_nat x - | ILsr_nat _ -> - let x = accu in - Interp_costs.lsr_nat x - | IOr_nat _ -> - let x = accu and y, _ = stack in + | ILsl_nat _, (x : _ Script_int.num), _ -> Interp_costs.lsl_nat x + | ILsr_nat _, (x : _ Script_int.num), _ -> Interp_costs.lsr_nat x + | IOr_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.or_nat x y - | IAnd_nat _ -> - let x = accu and y, _ = stack in + | IAnd_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.and_nat x y - | IAnd_int_nat _ -> - let x = accu and y, _ = stack in + | IAnd_int_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.and_int_nat x y - | IXor_nat _ -> - let x = accu and y, _ = stack in + | IXor_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.xor_nat x y - | INot_int _ -> - let x = accu in - Interp_costs.not_int x - | ICompare (_, ty, _) -> - let a = accu and b, _ = stack in + | INot_int _, (x : _ Script_int.num), _ -> Interp_costs.not_int x + | ICompare (_, ty, _), a, (stack : a * _) -> + let b, _ = stack in Interp_costs.compare ty a b - | ICheck_signature _ -> - let key = accu and _, (message, _) = stack in + | ICheck_signature _, (key : public_key), (stack : _ * (bytes * _)) -> + let _, (message, _) = stack in Interp_costs.check_signature key message - | IHash_key _ -> - let pk = accu in - Interp_costs.hash_key pk - | IBlake2b _ -> - let bytes = accu in - Interp_costs.blake2b bytes - | ISha256 _ -> - let bytes = accu in - Interp_costs.sha256 bytes - | ISha512 _ -> - let bytes = accu in - Interp_costs.sha512 bytes - | IKeccak _ -> - let bytes = accu in - Interp_costs.keccak bytes - | ISha3 _ -> - let bytes = accu in - Interp_costs.sha3 bytes - | IPairing_check_bls12_381 _ -> - let pairs = accu in + | IHash_key _, (pk : public_key), _ -> Interp_costs.hash_key pk + | IBlake2b _, (bytes : bytes), _ -> Interp_costs.blake2b bytes + | ISha256 _, (bytes : bytes), _ -> Interp_costs.sha256 bytes + | ISha512 _, (bytes : bytes), _ -> Interp_costs.sha512 bytes + | IKeccak _, (bytes : bytes), _ -> Interp_costs.keccak bytes + | ISha3 _, (bytes : bytes), _ -> Interp_costs.sha3 bytes + | IPairing_check_bls12_381 _, (pairs : _ boxed_list), _ -> Interp_costs.pairing_check_bls12_381 pairs - | ISapling_verify_update _ -> + | ISapling_verify_update _, (accu : Sapling_repr.transaction), _ -> let tx = accu in let inputs = Gas_input_size.sapling_transaction_inputs tx in let outputs = Gas_input_size.sapling_transaction_outputs tx in let bound_data = Gas_input_size.sapling_transaction_bound_data tx in Interp_costs.sapling_verify_update ~inputs ~outputs ~bound_data - | ISapling_verify_update_deprecated _ -> + | ( ISapling_verify_update_deprecated _, + (accu : Sapling_repr.legacy_transaction), + _ ) -> let tx = accu in let inputs = List.length tx.inputs in let outputs = List.length tx.outputs in Interp_costs.sapling_verify_update_deprecated ~inputs ~outputs - | ISplit_ticket _ -> - let ticket = accu and (amount_a, amount_b), _ = stack in + | ISplit_ticket _, (accu : _ ticket), (stack : (_ * _) * _) -> + let ticket = accu in + let (amount_a, amount_b), _ = stack in Interp_costs.split_ticket ticket.amount amount_a amount_b - | IJoin_tickets (_, ty, _) -> - let ticket_a, ticket_b = accu in + | IJoin_tickets (_, ty, _), (ticket_a_b : _ ticket * _ ticket), _ -> + let ticket_a, ticket_b = ticket_a_b in Interp_costs.join_tickets ty ticket_a ticket_b - | IHalt _ -> Interp_costs.halt - | IDrop _ -> Interp_costs.drop - | IDup _ -> Interp_costs.dup - | ISwap _ -> Interp_costs.swap - | IConst _ -> Interp_costs.const - | ICons_some _ -> Interp_costs.cons_some - | ICons_none _ -> Interp_costs.cons_none - | IIf_none _ -> Interp_costs.if_none - | IOpt_map _ -> Interp_costs.opt_map - | ICons_pair _ -> Interp_costs.cons_pair - | IUnpair _ -> Interp_costs.unpair - | ICar _ -> Interp_costs.car - | ICdr _ -> Interp_costs.cdr - | ICons_left _ -> Interp_costs.cons_left - | ICons_right _ -> Interp_costs.cons_right - | IIf_left _ -> Interp_costs.if_left - | ICons_list _ -> Interp_costs.cons_list - | INil _ -> Interp_costs.nil - | IIf_cons _ -> Interp_costs.if_cons - | IList_size _ -> Interp_costs.list_size - | IEmpty_set _ -> Interp_costs.empty_set - | ISet_size _ -> Interp_costs.set_size - | IEmpty_map _ -> Interp_costs.empty_map - | IMap_size _ -> Interp_costs.map_size - | IEmpty_big_map _ -> Interp_costs.empty_big_map - | IString_size _ -> Interp_costs.string_size - | IBytes_size _ -> Interp_costs.bytes_size - | IAdd_tez _ -> Interp_costs.add_tez - | ISub_tez _ -> Interp_costs.sub_tez - | ISub_tez_legacy _ -> Interp_costs.sub_tez_legacy - | IOr _ -> Interp_costs.bool_or - | IAnd _ -> Interp_costs.bool_and - | IXor _ -> Interp_costs.bool_xor - | INot _ -> Interp_costs.bool_not - | IIs_nat _ -> Interp_costs.is_nat - | IInt_nat _ -> Interp_costs.int_nat - | IInt_bls12_381_fr _ -> Interp_costs.int_bls12_381_fr - | IEdiv_tez _ -> Interp_costs.ediv_tez - | IIf _ -> Interp_costs.if_ - | ILoop _ -> Interp_costs.loop - | ILoop_left _ -> Interp_costs.loop_left - | IDip _ -> Interp_costs.dip - | IExec _ -> Interp_costs.exec - | IApply _ -> Interp_costs.apply - | ILambda _ -> Interp_costs.lambda - | IFailwith _ -> Gas.free - | IEq _ -> Interp_costs.eq - | INeq _ -> Interp_costs.neq - | ILt _ -> Interp_costs.lt - | ILe _ -> Interp_costs.le - | IGt _ -> Interp_costs.gt - | IGe _ -> Interp_costs.ge - | IPack _ -> Gas.free - | IUnpack _ -> + | IHalt _, _, _ -> Interp_costs.halt + | IDrop _, _, _ -> Interp_costs.drop + | IDup _, _, _ -> Interp_costs.dup + | ISwap _, _, _ -> Interp_costs.swap + | IConst _, _, _ -> Interp_costs.const + | ICons_some _, _, _ -> Interp_costs.cons_some + | ICons_none _, _, _ -> Interp_costs.cons_none + | IIf_none _, _, _ -> Interp_costs.if_none + | IOpt_map _, _, _ -> Interp_costs.opt_map + | ICons_pair _, _, _ -> Interp_costs.cons_pair + | IUnpair _, _, _ -> Interp_costs.unpair + | ICar _, _, _ -> Interp_costs.car + | ICdr _, _, _ -> Interp_costs.cdr + | ICons_left _, _, _ -> Interp_costs.cons_left + | ICons_right _, _, _ -> Interp_costs.cons_right + | IIf_left _, _, _ -> Interp_costs.if_left + | ICons_list _, _, _ -> Interp_costs.cons_list + | INil _, _, _ -> Interp_costs.nil + | IIf_cons _, _, _ -> Interp_costs.if_cons + | IList_size _, _, _ -> Interp_costs.list_size + | IEmpty_set _, _, _ -> Interp_costs.empty_set + | ISet_size _, _, _ -> Interp_costs.set_size + | IEmpty_map _, _, _ -> Interp_costs.empty_map + | IMap_size _, _, _ -> Interp_costs.map_size + | IEmpty_big_map _, _, _ -> Interp_costs.empty_big_map + | IString_size _, _, _ -> Interp_costs.string_size + | IBytes_size _, _, _ -> Interp_costs.bytes_size + | IAdd_tez _, _, _ -> Interp_costs.add_tez + | ISub_tez _, _, _ -> Interp_costs.sub_tez + | ISub_tez_legacy _, _, _ -> Interp_costs.sub_tez_legacy + | IOr _, _, _ -> Interp_costs.bool_or + | IAnd _, _, _ -> Interp_costs.bool_and + | IXor _, _, _ -> Interp_costs.bool_xor + | INot _, _, _ -> Interp_costs.bool_not + | IIs_nat _, _, _ -> Interp_costs.is_nat + | IInt_nat _, _, _ -> Interp_costs.int_nat + | IInt_bls12_381_fr _, _, _ -> Interp_costs.int_bls12_381_fr + | IEdiv_tez _, _, _ -> Interp_costs.ediv_tez + | IIf _, _, _ -> Interp_costs.if_ + | ILoop _, _, _ -> Interp_costs.loop + | ILoop_left _, _, _ -> Interp_costs.loop_left + | IDip _, _, _ -> Interp_costs.dip + | IExec _, _, _ -> Interp_costs.exec + | IApply _, _, _ -> Interp_costs.apply + | ILambda _, _, _ -> Interp_costs.lambda + | IFailwith _, _, _ -> Gas.free + | IEq _, _, _ -> Interp_costs.eq + | INeq _, _, _ -> Interp_costs.neq + | ILt _, _, _ -> Interp_costs.lt + | ILe _, _, _ -> Interp_costs.le + | IGt _, _, _ -> Interp_costs.gt + | IGe _, _, _ -> Interp_costs.ge + | IPack _, _, _ -> Gas.free + | IUnpack _, (accu : bytes), _ -> let b = accu in Interp_costs.unpack b - | IAddress _ -> Interp_costs.address - | IContract _ -> Interp_costs.contract - | ITransfer_tokens _ -> Interp_costs.transfer_tokens - | IView _ -> Interp_costs.view - | IImplicit_account _ -> Interp_costs.implicit_account - | ISet_delegate _ -> Interp_costs.set_delegate - | IBalance _ -> Interp_costs.balance - | ILevel _ -> Interp_costs.level - | INow _ -> Interp_costs.now - | IMin_block_time _ -> Interp_costs.min_block_time - | ISapling_empty_state _ -> Interp_costs.sapling_empty_state - | ISource _ -> Interp_costs.source - | ISender _ -> Interp_costs.sender - | ISelf _ -> Interp_costs.self - | ISelf_address _ -> Interp_costs.self_address - | IAmount _ -> Interp_costs.amount - | IDig (_, n, _, _) -> Interp_costs.dign n - | IDug (_, n, _, _) -> Interp_costs.dugn n - | IDipn (_, n, _, _, _) -> Interp_costs.dipn n - | IDropn (_, n, _, _) -> Interp_costs.dropn n - | IChainId _ -> Interp_costs.chain_id - | ICreate_contract _ -> Interp_costs.create_contract - | INever _ -> ( match accu with _ -> .) - | IVoting_power _ -> Interp_costs.voting_power - | ITotal_voting_power _ -> Interp_costs.total_voting_power - | IAdd_bls12_381_g1 _ -> Interp_costs.add_bls12_381_g1 - | IAdd_bls12_381_g2 _ -> Interp_costs.add_bls12_381_g2 - | IAdd_bls12_381_fr _ -> Interp_costs.add_bls12_381_fr - | IMul_bls12_381_g1 _ -> Interp_costs.mul_bls12_381_g1 - | IMul_bls12_381_g2 _ -> Interp_costs.mul_bls12_381_g2 - | IMul_bls12_381_fr _ -> Interp_costs.mul_bls12_381_fr - | INeg_bls12_381_g1 _ -> Interp_costs.neg_bls12_381_g1 - | INeg_bls12_381_g2 _ -> Interp_costs.neg_bls12_381_g2 - | INeg_bls12_381_fr _ -> Interp_costs.neg_bls12_381_fr - | IMul_bls12_381_fr_z _ -> + | IAddress _, _, _ -> Interp_costs.address + | IContract _, _, _ -> Interp_costs.contract + | ITransfer_tokens _, _, _ -> Interp_costs.transfer_tokens + | IView _, _, _ -> Interp_costs.view + | IImplicit_account _, _, _ -> Interp_costs.implicit_account + | ISet_delegate _, _, _ -> Interp_costs.set_delegate + | IBalance _, _, _ -> Interp_costs.balance + | ILevel _, _, _ -> Interp_costs.level + | INow _, _, _ -> Interp_costs.now + | IMin_block_time _, _, _ -> Interp_costs.min_block_time + | ISapling_empty_state _, _, _ -> Interp_costs.sapling_empty_state + | ISource _, _, _ -> Interp_costs.source + | ISender _, _, _ -> Interp_costs.sender + | ISelf _, _, _ -> Interp_costs.self + | ISelf_address _, _, _ -> Interp_costs.self_address + | IAmount _, _, _ -> Interp_costs.amount + | IDig (_, n, _, _), _, _ -> Interp_costs.dign n + | IDug (_, n, _, _), _, _ -> Interp_costs.dugn n + | IDipn (_, n, _, _, _), _, _ -> Interp_costs.dipn n + | IDropn (_, n, _, _), _, _ -> Interp_costs.dropn n + | IChainId _, _, _ -> Interp_costs.chain_id + | ICreate_contract _, _, _ -> Interp_costs.create_contract + | INever _, _, _ -> . + | IVoting_power _, _, _ -> Interp_costs.voting_power + | ITotal_voting_power _, _, _ -> Interp_costs.total_voting_power + | IAdd_bls12_381_g1 _, _, _ -> Interp_costs.add_bls12_381_g1 + | IAdd_bls12_381_g2 _, _, _ -> Interp_costs.add_bls12_381_g2 + | IAdd_bls12_381_fr _, _, _ -> Interp_costs.add_bls12_381_fr + | IMul_bls12_381_g1 _, _, _ -> Interp_costs.mul_bls12_381_g1 + | IMul_bls12_381_g2 _, _, _ -> Interp_costs.mul_bls12_381_g2 + | IMul_bls12_381_fr _, _, _ -> Interp_costs.mul_bls12_381_fr + | INeg_bls12_381_g1 _, _, _ -> Interp_costs.neg_bls12_381_g1 + | INeg_bls12_381_g2 _, _, _ -> Interp_costs.neg_bls12_381_g2 + | INeg_bls12_381_fr _, _, _ -> Interp_costs.neg_bls12_381_fr + | IMul_bls12_381_fr_z _, (accu : _ Script_int.num), _ -> let z = accu in Interp_costs.mul_bls12_381_fr_z z - | IMul_bls12_381_z_fr _ -> + | IMul_bls12_381_z_fr _, _, (stack : _ Script_int.num * _) -> let z, _ = stack in Interp_costs.mul_bls12_381_z_fr z - | IDup_n (_, n, _, _) -> Interp_costs.dupn n - | IComb (_, n, _, _) -> Interp_costs.comb n - | IUncomb (_, n, _, _) -> Interp_costs.uncomb n - | IComb_get (_, n, _, _) -> Interp_costs.comb_get n - | IComb_set (_, n, _, _) -> Interp_costs.comb_set n - | ITicket _ -> Interp_costs.ticket - | IRead_ticket _ -> Interp_costs.read_ticket - | IOpen_chest _ -> - let _chest_key = accu and chest, (time, _) = stack in + | IDup_n (_, n, _, _), _, _ -> Interp_costs.dupn n + | IComb (_, n, _, _), _, _ -> Interp_costs.comb n + | IUncomb (_, n, _, _), _, _ -> Interp_costs.uncomb n + | IComb_get (_, n, _, _), _, _ -> Interp_costs.comb_get n + | IComb_set (_, n, _, _), _, _ -> Interp_costs.comb_set n + | ITicket _, _, _ -> Interp_costs.ticket + | IRead_ticket _, _, _ -> Interp_costs.read_ticket + | ( IOpen_chest _, + _chest_key, + (stack : Script_timelock.chest * (_ Script_int.num * _)) ) -> + let chest, (time, _) = stack in Interp_costs.open_chest ~chest ~time:(Script_int.to_zint time) - | ILog _ -> Gas.free + | ILog _, _, _ -> Gas.free [@@ocaml.inline always] - [@@coq_axiom_with_reason "unreachable expression `.` not handled"] let cost_of_control : type a s r f. (a, s, r, f) continuation -> Gas.cost = fun ks -> @@ -460,7 +438,7 @@ let id x = x [@@inline] (* The following function pops n elements from the stack and push their reintroduction in the continuations stack. *) -let rec kundip : +let[@coq_struct "w_value"] rec kundip : type a s e z c u d w b t. (a, s, e, z, c, u, d, w) stack_prefix_preservation_witness -> c -> @@ -468,53 +446,58 @@ let rec kundip : (d, w, b, t) kinstr -> a * s * (e, z, b, t) kinstr = fun w accu stack k -> - match w with - | KPrefix (kinfo, w) -> + match[@coq_match_gadt] (w, accu, stack) with + | KPrefix (kinfo, w), _, (stack : _ * _) -> let k = IConst (kinfo, accu, k) in let accu, stack = stack in kundip w accu stack k - | KRest -> (accu, stack, k) + | KRest, (accu : a), (stack : s) -> (accu, stack, k) (* [apply ctxt gas ty v lam] specializes [lam] by fixing its first formal argument to [v]. The type of [v] is represented by [ty]. *) let apply ctxt gas capture_ty capture lam = let (Lam (descr, expr)) = lam in - let (Item_t (full_arg_ty, _)) = descr.kbef in - let ctxt = update_context gas ctxt in - unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) -> - let loc = Micheline.dummy_location in - unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) -> - match full_arg_ty with - | Pair_t (capture_ty, arg_ty, _, _) -> - let arg_stack_ty = Item_t (arg_ty, Bot_t) in - let full_descr = - { - kloc = descr.kloc; - kbef = arg_stack_ty; - kaft = descr.kaft; - kinstr = - (let kinfo_const = {iloc = descr.kloc; kstack_ty = arg_stack_ty} in - let kinfo_pair = - { - iloc = descr.kloc; - kstack_ty = Item_t (capture_ty, arg_stack_ty); - } - in - IConst (kinfo_const, capture, ICons_pair (kinfo_pair, descr.kinstr))); - } - in - let full_expr = - Micheline.Seq - ( loc, - [ - Prim (loc, I_PUSH, [ty_expr; const_expr], []); - Prim (loc, I_PAIR, [], []); - expr; - ] ) - in - let lam' = Lam (full_descr, full_expr) in - let gas, ctxt = local_gas_counter_and_outdated_context ctxt in - return (lam', ctxt, gas) + match[@coq_match_with_default] descr.kbef with + | Item_t (full_arg_ty, _) -> ( + let ctxt = update_context gas ctxt in + unparse_data ctxt Optimized capture_ty capture + >>=? fun (const_expr, ctxt) -> + let loc = Micheline.dummy_location in + unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) -> + match[@coq_match_with_default] full_arg_ty with + | Pair_t (capture_ty, arg_ty, _, _) -> + let arg_stack_ty = Item_t (arg_ty, Bot_t) in + let full_descr = + { + kloc = descr.kloc; + kbef = arg_stack_ty; + kaft = descr.kaft; + kinstr = + (let kinfo_const = + {iloc = descr.kloc; kstack_ty = arg_stack_ty} + in + let kinfo_pair = + { + iloc = descr.kloc; + kstack_ty = Item_t (capture_ty, arg_stack_ty); + } + in + IConst + (kinfo_const, capture, ICons_pair (kinfo_pair, descr.kinstr))); + } + in + let full_expr = + Micheline.Seq + ( loc, + [ + Prim (loc, I_PUSH, [ty_expr; const_expr], []); + Prim (loc, I_PAIR, [], []); + expr; + ] ) + in + let lam' = Lam (full_descr, full_expr) in + let gas, ctxt = local_gas_counter_and_outdated_context ctxt in + return (lam', ctxt, gas)) let make_transaction_to_contract ctxt ~destination ~amount ~entrypoint ~location ~parameters_ty ~parameters = @@ -704,7 +687,7 @@ let unpack ctxt ~ty ~bytes = a well-typed operation [f] under some prefix of the A-stack exploiting [w] to justify that the shape of the stack is preserved. *) -let rec interp_stack_prefix_preserving_operation : +let[@coq_struct "n_value"] rec interp_stack_prefix_preserving_operation : type a s b t c u d w result. (a -> s -> (b * t) * result) -> (a, s, b, t, c, u, d, w) stack_prefix_preservation_witness -> @@ -712,11 +695,11 @@ let rec interp_stack_prefix_preserving_operation : u -> (d * w) * result = fun f n accu stk -> - match (n, stk) with - | KPrefix (_, n), rest -> + match[@coq_match_gadt_with_result] (n, accu, stk) with + | KPrefix (_, n), _, (rest : _ * _) -> interp_stack_prefix_preserving_operation f n (fst rest) (snd rest) |> fun ((v, rest'), result) -> ((accu, (v, rest')), result) - | KRest, v -> f accu v + | KRest, (accu : a), (v : s) -> f accu v (* diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index a9d0cdfce7ddb18706add230f6ca7ee37337383c..faeb1dfe05227a0c182a93bc9d7b5f2dc2d6a614 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -42,7 +42,7 @@ let error_unexpected_annot loc annot = (* Check that the predicate p holds on all s.[k] for k >= i *) let string_iter p s i = let len = String.length s in - let rec aux i = + let[@coq_struct "i_value"] rec aux i = if Compare.Int.(i >= len) then Result.return_unit else p s.[i] >>? fun () -> aux (i + 1) in diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 58f525f87417e09e05c1b41d667bebe0b47178fe..6009a0171a596292ea3358befbf3d5d8405fce41 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -168,7 +168,7 @@ 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 : +let[@coq_struct "ty_value"] 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} -> @@ -277,7 +277,7 @@ let rec unparse_ty_and_entrypoints_uncarbonated : in Prim (loc, name, args, annot) -and unparse_comparable_ty_uncarbonated : +and[@coq_struct "ty_value"] 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 @@ -302,7 +302,7 @@ let serialize_ty_for_error ty = *) unparse_ty_uncarbonated ~loc:() ty |> Micheline.strip_locations -let[@coq_axiom_with_reason "gadt"] check_comparable : +let check_comparable : type a ac. Script.location -> (a, ac) ty -> (ac, Dependent_bool.yes) eq tzresult = fun loc ty -> @@ -532,7 +532,7 @@ let comb_witness2 : | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any -let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data : +let[@coq_struct "ty_value"] rec unparse_comparable_data : type a loc. loc:loc -> context -> @@ -550,33 +550,37 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data : [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 -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, a) with + | Unit_t, (v : unit) -> Lwt.return @@ unparse_unit ~loc ctxt v + | Int_t, (v : _ Script_int.num) -> Lwt.return @@ unparse_int ~loc ctxt v + | Nat_t, (v : _ Script_int.num) -> Lwt.return @@ unparse_nat ~loc ctxt v + | String_t, (s : Script_string.t) -> Lwt.return @@ unparse_string ~loc ctxt s + | Bytes_t, (s : bytes) -> Lwt.return @@ unparse_bytes ~loc ctxt s + | Bool_t, (b : bool) -> Lwt.return @@ unparse_bool ~loc ctxt b + | Timestamp_t, (t : Script_timestamp.t) -> + Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | Address_t, (address : address) -> + Lwt.return @@ unparse_address ~loc ctxt mode address + | Tx_rollup_l2_address_t, (address : tx_rollup_l2_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 -> + | Signature_t, (s : Script_signature.t) -> + Lwt.return @@ unparse_signature ~loc ctxt mode s + | Mutez_t, (v : Tez_repr.t) -> Lwt.return @@ unparse_mutez ~loc ctxt v + | Key_t, (k : public_key) -> Lwt.return @@ unparse_key ~loc ctxt mode k + | Key_hash_t, (k : public_key_hash) -> + Lwt.return @@ unparse_key_hash ~loc ctxt mode k + | Chain_id_t, (chain_id : Script_chain_id.t) -> Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | Pair_t (tl, tr, _, YesYes), pair -> + | Pair_t (tl, tr, _, YesYes), (pair : _ * _) -> let r_witness = comb_witness2 tr in let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair - | Union_t (tl, tr, _, YesYes), v -> + | Union_t (tl, tr, _, YesYes), (v : _ union) -> let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in unparse_union ~loc unparse_l unparse_r ctxt v - | Option_t (t, _, Yes), v -> + | Option_t (t, _, Yes), (v : _ option) -> let unparse_v ctxt v = unparse_comparable_data ~loc ctxt mode t v in unparse_option ~loc unparse_v ctxt v | Never_t, _ -> . @@ -607,10 +611,11 @@ let hash_comparable_data ctxt ty data = (* ---- Tickets ------------------------------------------------------------ *) (* - All comparable types are dupable, this function exists only to not forget - checking this property when adding new types. -*) -let check_dupable_comparable_ty : type a. a comparable_ty -> unit = function + All comparable types are dupable, this function exists only to not forget + checking this property when adding new types. + *) +let check_dupable_comparable_ty : type a. a comparable_ty -> unit = + function[@coq_match_with_default] | Unit_t | Never_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t | Bool_t | Key_hash_t | Key_t | Timestamp_t | Chain_id_t | Address_t | Tx_rollup_l2_address_t | Pair_t _ | Union_t _ | Option_t _ -> @@ -656,13 +661,13 @@ let check_dupable_ty ctxt loc ty = aux loc ty_b | Lambda_t (_, _, _) -> (* - Lambda are dupable as long as: - - they don't contain non-dupable values, e.g. in `PUSH` - (mostly non-dupable values should probably be considered forged) - - they are not the result of a partial application on a non-dupable - value. `APPLY` rejects non-packable types (because of `PUSH`). - Hence non-dupable should imply non-packable. - *) + Lambda are dupable as long as: + - they don't contain non-dupable values, e.g. in `PUSH` + (mostly non-dupable values should probably be considered forged) + - they are not the result of a partial application on a non-dupable + value. `APPLY` rejects non-packable types (because of `PUSH`). + Hence non-dupable should imply non-packable. + *) return_unit | Option_t (ty, _, _) -> aux loc ty | List_t (ty, _) -> aux loc ty @@ -704,7 +709,7 @@ let memo_size_eq : if Sapling.Memo_size.equal ms1 ms2 then Result.return_unit else Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> Inconsistent_types_fast | Informative _ -> trace_of_error @@ Inconsistent_memo_sizes (ms1, ms2)) @@ -733,27 +738,18 @@ let rec ty_eq : (ta, tac) ty -> (tb, tbc) ty -> (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t = - fun ty1 ty2 -> - help0 ty1 ty2 - |> Gas_monad.record_trace_eval ~error_details (fun loc -> - default_ty_eq_error loc ty1 ty2) - and help0 : - type ta tac tb tbc. - (ta, tac) ty -> - (tb, tbc) ty -> - (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t = fun ty1 ty2 -> let open Gas_monad.Syntax in let* () = Gas_monad.consume_gas Typecheck_costs.merge_cycle in let not_equal () = Gas_monad.of_result @@ Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> (Inconsistent_types_fast : error_trace) | Informative loc -> trace_of_error @@ default_ty_eq_error loc ty1 ty2) in - match (ty1, ty2) with + (match (ty1, ty2) with | Unit_t, Unit_t -> return (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) | Unit_t, _ -> not_equal () | Int_t, Int_t -> return Eq @@ -865,10 +861,13 @@ let rec ty_eq : | Chest_t, Chest_t -> return Eq | Chest_t, _ -> not_equal () | Chest_key_t, Chest_key_t -> return Eq - | Chest_key_t, _ -> not_equal () + | Chest_key_t, _ -> not_equal ()) + |> Gas_monad.record_trace_eval ~error_details (fun loc -> + default_ty_eq_error loc ty1 ty2) in help ty1 ty2 - [@@coq_axiom_with_reason "non-top-level mutual recursion"] + |> Gas_monad.record_trace_eval ~error_details (fun loc -> + default_ty_eq_error loc ty1 ty2) (* Same as ty_eq but for stacks. A single error monad is used here because there is no need to @@ -901,6 +900,7 @@ type ('a, 's) judgement = descr : 'b 'u. ('b, 'u) stack_ty -> ('a, 's, 'b, 'u) descr; } -> ('a, 's) judgement +[@@coq_force_gadt] (* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*) @@ -953,7 +953,7 @@ let parse_memo_size (n : (location, _) Micheline.node) : type ex_comparable_ty = | Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty -type ex_ty = Ex_ty : ('a, _) ty -> ex_ty +type ex_ty = Ex_ty : ('a, _) ty -> ex_ty [@@coq_force_gadt] type ex_parameter_ty_and_entrypoints_node = | Ex_parameter_ty_and_entrypoints_node : { @@ -963,20 +963,20 @@ type ex_parameter_ty_and_entrypoints_node = -> ex_parameter_ty_and_entrypoints_node (** [parse_ty] can be used to parse regular types as well as parameter types - together with their entrypoints. + together with their entrypoints. - In the first case, use [~ret:Don't_parse_entrypoints], [parse_ty] will - return an [ex_ty]. + In the first case, use [~ret:Don't_parse_entrypoints], [parse_ty] will + return an [ex_ty]. - In the second case, use [~ret:Parse_entrypoints], [parse_ty] will return - an [ex_parameter_ty_and_entrypoints_node]. -*) + In the second case, use [~ret:Parse_entrypoints], [parse_ty] will return + an [ex_parameter_ty_and_entrypoints_node]. + *) type ('ret, 'name) parse_ty_ret = | Don't_parse_entrypoints : (ex_ty, unit) parse_ty_ret | Parse_entrypoints : (ex_parameter_ty_and_entrypoints_node, Entrypoint.t option) parse_ty_ret -let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty : +let[@coq_struct "node_value"] rec parse_ty_aux : type ret name. context -> stack_depth:int -> @@ -1002,13 +1002,13 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty error Typechecking_too_many_recursive_calls else (match ret with - | Don't_parse_entrypoints -> ok (node, (() : name)) + | Don't_parse_entrypoints -> ok (node, None) | Parse_entrypoints -> extract_entrypoint_annot node) >>? fun (node, name) -> let return ctxt ty : ret * context = - match ret with - | Don't_parse_entrypoints -> (Ex_ty ty, ctxt) - | Parse_entrypoints -> + match[@coq_match_gadt_with_result] (ret, name) with + | Don't_parse_entrypoints, _ -> (Ex_ty ty, ctxt) + | Parse_entrypoints, (name : Alpha_context.Entrypoint.t option) -> let at_node = Option.map (fun name -> {name; original_type_expr = node}) name in @@ -1069,7 +1069,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty check_type_annot loc annot >|? fun () -> return ctxt bls12_381_fr_t | Prim (loc, T_contract, [utl], annot) -> if allow_contract then - parse_passable_ty + parse_passable_ty_aux_with_ret ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1081,7 +1081,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty else error (Unexpected_contract loc) | Prim (loc, T_pair, utl :: utr, annot) -> remove_field_annot utl >>? fun utl -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1098,7 +1098,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty (* Unfold [pair t1 ... tn] as [pair t1 (... (pair tn-1 tn))] *) ok (Prim (loc, T_pair, utr, []))) >>? fun utr -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1118,7 +1118,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty remove_field_annot utr >|? fun utr -> (utl, utr) | Parse_entrypoints -> ok (utl, utr)) >>? fun (utl, utr) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1129,7 +1129,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty ~ret utl >>? fun (parsed_l, ctxt) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1141,12 +1141,15 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty utr >>? fun (parsed_r, ctxt) -> check_type_annot loc annot >>? fun () -> - match ret with - | Don't_parse_entrypoints -> + match[@coq_match_gadt_with_result] (ret, parsed_l, parsed_r, name) with + | Don't_parse_entrypoints, _, _, _ -> let (Ex_ty tl) = parsed_l in let (Ex_ty tr) = parsed_r in union_t loc tl tr >|? fun (Ty_ex_c ty) -> ((Ex_ty ty : ret), ctxt) - | Parse_entrypoints -> + | ( Parse_entrypoints, + (parsed_l : ex_parameter_ty_and_entrypoints_node), + (parsed_r : ex_parameter_ty_and_entrypoints_node), + (name : Alpha_context.Entrypoint.t option) ) -> let (Ex_parameter_ty_and_entrypoints_node {arg_type = tl; entrypoints = left}) = parsed_l @@ -1165,9 +1168,9 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty (Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints}, ctxt) ) | Prim (loc, T_lambda, [uta; utr], annot) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy uta + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy uta >>? fun (Ex_ty ta, ctxt) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy utr + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy utr >>? fun (Ex_ty tr, ctxt) -> check_type_annot loc annot >>? fun () -> lambda_t loc ta tr >|? fun ty -> return ctxt ty @@ -1178,7 +1181,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty check_composed_type_annot loc annot >>? fun () -> ok ut else check_type_annot loc annot >>? fun () -> ok ut) >>? fun ut -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1191,7 +1194,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty >>? fun (Ex_ty t, ctxt) -> option_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_list, [ut], annot) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1206,20 +1209,20 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty list_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_ticket, [ut], annot) -> if allow_ticket then - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> check_type_annot loc annot >>? fun () -> ticket_t loc t >|? fun ty -> return ctxt ty else error (Unexpected_ticket loc) | Prim (loc, T_set, [ut], annot) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> check_type_annot loc annot >>? fun () -> set_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_map, [uta; utr], annot) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt uta + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt uta >>? fun (Ex_comparable_ty ta, ctxt) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1243,11 +1246,11 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty return ctxt (sapling_transaction_deprecated_t ~memo_size) else error (Deprecated_instruction T_sapling_transaction_deprecated) (* - /!\ When adding new lazy storage kinds, be careful to use - [when allow_lazy_storage] /!\ - Lazy storage should not be packable to avoid stealing a lazy storage - from another contract with `PUSH t id` or `UNPACK`. - *) + /!\ When adding new lazy storage kinds, be careful to use + [when allow_lazy_storage] /!\ + Lazy storage should not be packable to avoid stealing a lazy storage + from another contract with `PUSH t id` or `UNPACK`. + *) | Prim (loc, T_big_map, args, annot) when allow_lazy_storage -> parse_big_map_ty ctxt @@ -1316,14 +1319,13 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty T_unit; ] -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_comparable_ty - : +and[@coq_struct "stack_depth"] parse_comparable_ty_aux : context -> stack_depth:int -> Script.node -> (ex_comparable_ty * context) tzresult = fun ctxt ~stack_depth node -> - parse_ty + parse_ty_aux ~ret:Don't_parse_entrypoints ctxt ~stack_depth:(stack_depth + 1) @@ -1340,7 +1342,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_compar error (Comparable_type_expected (location node, Micheline.strip_locations node)) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passable_ty : +and[@coq_mutual_as_notation] parse_passable_ty_aux_with_ret : type ret name. context -> stack_depth:int -> @@ -1349,41 +1351,40 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passab Script.node -> (ret * context) tzresult = fun ctxt ~stack_depth ~legacy -> - (parse_ty [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:true - ~allow_operation:false - ~allow_contract:true - ~allow_ticket:true + ((parse_ty_aux [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:true + ~allow_operation:false + ~allow_contract:true + ~allow_ticket:true [@coq_type_annotation]) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_any_ty - : +and[@coq_mutual_as_notation] parse_any_ty_aux : context -> stack_depth:int -> legacy:bool -> Script.node -> (ex_ty * context) tzresult = fun ctxt ~stack_depth ~legacy -> - (parse_ty [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:true - ~allow_operation:true - ~allow_contract:true - ~allow_ticket:true - ~ret:Don't_parse_entrypoints - -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_ty - ctxt ~stack_depth ~legacy big_map_loc args map_annot = + ((parse_ty_aux [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:true + ~allow_operation:true + ~allow_contract:true + ~allow_ticket:true + ~ret:Don't_parse_entrypoints [@coq_type_annotation]) + +and[@coq_struct "args"] parse_big_map_ty ctxt ~stack_depth ~legacy big_map_loc + args map_annot = Gas.consume ctxt Typecheck_costs.parse_type_cycle >>? fun ctxt -> match args with | [key_ty; value_ty] -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt key_ty + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt key_ty >>? fun (Ex_comparable_ty key_ty, ctxt) -> - parse_big_map_value_ty + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1394,21 +1395,21 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma (Ex_ty big_map_ty, ctxt) | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_value_ty - ctxt ~stack_depth ~legacy value_ty = - (parse_ty [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:false - ~allow_operation:false - ~allow_contract:legacy - ~allow_ticket:true - ~ret:Don't_parse_entrypoints - value_ty - -let parse_packable_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) +and[@coq_mutual_as_notation] parse_big_map_value_ty_aux ctxt ~stack_depth + ~legacy value_ty = + ((parse_ty_aux [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:false + ~allow_operation:false + ~allow_contract:legacy + ~allow_ticket:true + ~ret:Don't_parse_entrypoints + value_ty [@coq_type_annotation]) + +let parse_packable_ty_aux ctxt ~stack_depth ~legacy node = + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1422,7 +1423,7 @@ let parse_packable_ty ctxt ~stack_depth ~legacy node = node let parse_view_input_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1434,7 +1435,7 @@ let parse_view_input_ty ctxt ~stack_depth ~legacy node = node let parse_view_output_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1446,7 +1447,7 @@ let parse_view_output_ty ctxt ~stack_depth ~legacy node = node let parse_normal_storage_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1560,6 +1561,7 @@ type ('arg, 'storage) code = code_size : Cache_memory_helpers.sint; } -> ('arg, 'storage) code +[@@coq_force_gadt] type ex_script = Ex_script : ('a, 'c) Script_typed_ir.script -> ex_script @@ -1573,6 +1575,7 @@ type 'storage typed_view = original_code_expr : Script.node; } -> 'storage typed_view +[@@coq_force_gadt] type 'storage typed_view_map = (Script_string.t, 'storage typed_view) map @@ -1617,16 +1620,19 @@ type 'before comb_get_proof_argument = | Comb_get_proof_argument : ('before, 'after) comb_get_gadt_witness * ('after, _) ty -> 'before comb_get_proof_argument +[@@coq_force_gadt] type ('rest, 'before) comb_set_proof_argument = | Comb_set_proof_argument : ('rest, 'before, 'after) comb_set_gadt_witness * ('after, _) ty -> ('rest, 'before) comb_set_proof_argument +[@@coq_force_gadt] type 'before dup_n_proof_argument = | Dup_n_proof_argument : ('before, 'a) dup_n_gadt_witness * ('a, _) ty -> 'before dup_n_proof_argument +[@@coq_force_gadt] let rec make_dug_proof_argument : type a s x xc. @@ -1696,7 +1702,7 @@ let find_entrypoint (type full fullc error_context error_trace) (full : (full, fullc) ty) (entrypoints : full entrypoints) entrypoint : (full ex_ty_cstr, error_trace) Gas_monad.t = let open Gas_monad.Syntax in - let rec find_entrypoint : + let[@coq_struct "ty_value"] rec find_entrypoint : type t tc. (t, tc) ty -> t entrypoints_node -> @@ -1704,26 +1710,35 @@ let find_entrypoint (type full fullc error_context error_trace) (t ex_ty_cstr, unit) Gas_monad.t = fun ty entrypoints entrypoint -> let* () = Gas_monad.consume_gas Typecheck_costs.find_entrypoint_cycle in - match (ty, entrypoints) with + match[@coq_match_gadt] [@coq_match_with_default] (ty, entrypoints) with | _, {at_node = Some {name; original_type_expr}; _} when Entrypoint.(name = entrypoint) -> return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr}) - | Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _} -> ( - Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ function - | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> - return - (Ex_ty_cstr - { - ty; - construct = (fun e -> L (construct e)); - original_type_expr; - }) - | Error () -> - let+ (Ex_ty_cstr {ty; construct; original_type_expr}) = - find_entrypoint tr right entrypoint - in - Ex_ty_cstr - {ty; construct = (fun e -> R (construct e)); original_type_expr}) + | Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _} -> + Gas_monad.bind_recover + (find_entrypoint tl left entrypoint) + (function [@coq_match_gadt] + | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> + return + (Ex_ty_cstr + { + ty; + construct = (fun e -> L (construct e)); + original_type_expr; + }) + | Error () -> ( + let+ x = + (find_entrypoint tr right entrypoint [@coq_type_annotation]) + in + match[@coq_match_gadt] x with + | Ex_ty_cstr {ty; construct; original_type_expr} -> + Ex_ty_cstr + { + ty; + construct = (fun e -> R (construct e)); + original_type_expr; + })) + [@coq_cast] | _, {nested = Entrypoints_None; _} -> Gas_monad.of_result (Error ()) in let {root; original_type_expr} = entrypoints in @@ -1736,7 +1751,7 @@ let find_entrypoint (type full fullc error_context error_trace) else Gas_monad.of_result @@ Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> (Inconsistent_types_fast : error_trace) | Informative _ -> trace_of_error @@ No_such_entrypoint entrypoint) @@ -1745,7 +1760,13 @@ let find_entrypoint_for_type (type full fullc exp expc error_trace) entrypoints entrypoint : (Entrypoint.t * (exp, expc) ty, error_trace) Gas_monad.t = let open Gas_monad.Syntax in - let* res = find_entrypoint ~error_details full entrypoints entrypoint in + let* res = + (find_entrypoint + ~error_details + full + entrypoints + entrypoint [@coq_type_annotation]) + in match res with | Ex_ty_cstr {ty; _} -> ( match entrypoints.root.at_node with @@ -1823,14 +1844,14 @@ type ex_parameter_ty_and_entrypoints = } -> ex_parameter_ty_and_entrypoints -let parse_parameter_ty_and_entrypoints : +let parse_parameter_ty_and_entrypoints_aux : context -> stack_depth:int -> legacy:bool -> Script.node -> (ex_parameter_ty_and_entrypoints * context) tzresult = fun ctxt ~stack_depth ~legacy node -> - parse_passable_ty + parse_passable_ty_aux_with_ret ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1844,7 +1865,8 @@ let parse_parameter_ty_and_entrypoints : let entrypoints = {root = entrypoints; original_type_expr = node} in (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -let parse_passable_ty = parse_passable_ty ~ret:Don't_parse_entrypoints +let parse_passable_ty_aux = + parse_passable_ty_aux_with_ret ~ret:Don't_parse_entrypoints let parse_uint ~nb_bits = assert (Compare.Int.(nb_bits >= 0 && nb_bits <= 30)) ; @@ -2189,7 +2211,7 @@ let parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = (* The limitation of length of string is same as entrypoint *) if Compare.Int.(String.length v > 31) then error (View_name_too_long v) else - let rec check_char i = + let[@coq_struct "i_value"] rec check_char i = if Compare.Int.(i < 0) then ok v else if Script_ir_annot.is_allowed_char v.[i] then check_char (i - 1) else error (Bad_view_name loc) @@ -2205,7 +2227,7 @@ let parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = Script_string.of_string v >|? fun s -> (s, ctxt) ) | expr -> error @@ Invalid_kind (location expr, [String_kind], kind expr) -let parse_toplevel : +let parse_toplevel_aux : context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult = fun ctxt ~legacy toplevel -> record_trace (Ill_typed_contract (toplevel, [])) @@ -2300,19 +2322,19 @@ let parse_toplevel : (* -- parse data of any type -- *) (* - Some values, such as operations, tickets, or big map ids, are used only - internally and are not allowed to be forged by users. - In [parse_data], [allow_forged] should be [false] for: - - PUSH - - UNPACK - - user-provided script parameters - - storage on origination - And [true] for: - - internal calls parameters - - storage after origination -*) + Some values, such as operations, tickets, or big map ids, are used only + internally and are not allowed to be forged by users. + In [parse_data], [allow_forged] should be [false] for: + - PUSH + - UNPACK + - user-provided script parameters + - storage on origination + And [true] for: + - internal calls parameters + - storage after origination + *) -let[@coq_axiom_with_reason "gadt"] rec parse_data : +let[@coq_struct "ctxt"] rec parse_data_aux : type a ac. ?type_logger:type_logger -> stack_depth:int -> @@ -2328,7 +2350,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : if Compare.Int.(stack_depth > 10_000) then fail Typechecking_too_many_recursive_calls else - parse_data + parse_data_aux ?type_logger ~stack_depth:(stack_depth + 1) ctxt @@ -2456,7 +2478,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : |> traced >|=? fun (_, map, ctxt) -> (map, ctxt) in - match (ty, script_data) with + match[@coq_match_gadt_with_result] (ty, script_data) with | Unit_t, expr -> Lwt.return @@ traced_no_lwt @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult) @@ -2484,7 +2506,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : traced ( parse_address ctxt expr >>?= fun (address, ctxt) -> let loc = location expr in - parse_contract_data + parse_contract_data_aux ~stack_depth:(stack_depth + 1) ctxt loc @@ -2524,7 +2546,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : tr script_instr | Lambda_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Options *) | Option_t (t, _, _), expr -> let parse_v ctxt v = @@ -2541,7 +2564,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : items (Script_list.empty, ctxt) | List_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Tickets *) | Ticket_t (t, _ty_name), expr -> if allow_forged then @@ -2549,7 +2573,10 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : non_terminal_recursion ?type_logger ctxt ~legacy ty expr >>=? fun (({destination; entrypoint = _}, (contents, amount)), ctxt) -> match destination with - | Contract ticketer -> return ({ticketer; contents; amount}, ctxt) + | Contract ticketer -> + return + ( {ticketer; contents = contents [@coq_type_annotation]; amount}, + ctxt ) | Tx_rollup _ | Sc_rollup _ -> fail (Unexpected_ticket_owner destination) else traced_fail (Unexpected_forged_value (location expr)) @@ -2586,16 +2613,28 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : vs >|=? fun (_, set, ctxt) -> (set, ctxt) | Set_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Maps *) | Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr) -> - parse_items ?type_logger ctxt expr tk tv vs (fun x -> x) + ((parse_items [@coq_type_annotation]) + ?type_logger + ctxt + expr + tk + tv + vs + (fun x -> x) + : (_ map * _) tzresult Lwt.t) | Map_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) | Big_map_t (tk, tv, _ty_name), expr -> (match expr with | Int (loc, id) -> - return (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) + return + (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) + [@coq_type_annotation] | Seq (_, vs) -> parse_big_map_items ?type_logger ctxt expr tk tv vs (fun x -> Some x) >|=? fun (diff, ctxt) -> (None, diff, ctxt) @@ -2623,12 +2662,12 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | _, None -> traced_fail (Invalid_big_map (loc, id)) | ctxt, Some (btk, btv) -> Lwt.return - ( parse_comparable_ty + ( parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt (Micheline.root btk) >>? fun (Ex_comparable_ty btk, ctxt) -> - parse_big_map_value_ty + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -2653,14 +2692,16 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) | Bls12_381_g1_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Bls12_381_g2_t, Bytes (_, bs) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_g2 >>?= fun ctxt -> match Script_bls.G2.of_bytes_opt bs with | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) | Bls12_381_g2_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Bls12_381_fr_t, Bytes (_, bs) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> match Script_bls.Fr.of_bytes_opt bs with @@ -2670,11 +2711,12 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> return (Script_bls.Fr.of_z v, ctxt) | Bls12_381_fr_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) (* - /!\ When adding new lazy storage kinds, you may want to guard the parsing - of identifiers with [allow_forged]. - *) + /!\ When adding new lazy storage kinds, you may want to guard the parsing + of identifiers with [allow_forged]. + *) (* Sapling *) | Sapling_transaction_t memo_size, Bytes (_, bytes) -> ( match @@ -2692,7 +2734,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) | Sapling_transaction_t _, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Sapling_transaction_deprecated_t memo_size, Bytes (_, bytes) -> ( match Data_encoding.Binary.of_bytes_opt @@ -2711,7 +2754,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) | Sapling_transaction_deprecated_t _, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Sapling_state_t memo_size, Int (loc, id) -> if allow_forged then let id = Sapling.Id.parse_z id in @@ -2725,11 +2769,12 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : >|? fun () -> (state, ctxt) ) else traced_fail (Unexpected_forged_value loc) | Sapling_state_t memo_size, Seq (_, []) -> - return (Sapling.empty_state ~memo_size (), ctxt) + ((return [@coq_type_annotation]) (Sapling.empty_state ~memo_size (), ctxt) + : (Sapling.state * _) tzresult Lwt.t) | Sapling_state_t _, expr -> (* Do not allow to input diffs as they are untrusted and may not be the result of a verify_update. *) - traced_fail + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) (* Time lock*) | Chest_key_t, Bytes (_, bytes) -> ( @@ -2742,7 +2787,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Some chest_key -> return (chest_key, ctxt) | None -> fail_parse_data ()) | Chest_key_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Chest_t, Bytes (_, bytes) -> ( Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes)) >>?= fun ctxt -> @@ -2752,9 +2798,10 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Some chest -> return (chest, ctxt) | None -> fail_parse_data ()) | Chest_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) -and parse_view : +and[@coq_struct "ctxt"] parse_view : type storage storagec. ?type_logger:type_logger -> context -> @@ -2778,7 +2825,7 @@ and parse_view : (parse_view_output_ty ctxt ~stack_depth:0 ~legacy output_ty) >>?= fun (Ex_ty output_ty, ctxt) -> pair_t input_ty_loc input_ty storage_type >>?= fun (Ty_ex_c pair_ty) -> - parse_instr + parse_instr_aux ?type_logger ~stack_depth:0 Tc_context.view @@ -2818,7 +2865,7 @@ and parse_view : ctxt ) | _ -> error (ill_type_view aft loc)) -and parse_views : +and[@coq_mutual_as_notation] parse_views : type storage storagec. ?type_logger:type_logger -> context -> @@ -2835,7 +2882,7 @@ and parse_views : in Script_map.map_es_in_context aux ctxt views -and[@coq_axiom_with_reason "gadt"] parse_returning : +and[@coq_mutual_as_notation] parse_returning : type arg argc ret retc. ?type_logger:type_logger -> stack_depth:int -> @@ -2847,7 +2894,7 @@ and[@coq_axiom_with_reason "gadt"] parse_returning : Script.node -> ((arg, ret) lambda * context) tzresult Lwt.t = fun ?type_logger ~stack_depth tc_context ctxt ~legacy arg ret script_instr -> - parse_instr + parse_instr_aux ?type_logger tc_context ctxt @@ -2878,7 +2925,7 @@ and[@coq_axiom_with_reason "gadt"] parse_returning : : (arg, ret) lambda), ctxt ) -and[@coq_axiom_with_reason "gadt"] parse_instr : +and[@coq_struct "ctxt"] parse_instr_aux : type a s. ?type_logger:type_logger -> stack_depth:int -> @@ -2924,7 +2971,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : if Compare.Int.(stack_depth > 10000) then fail Typechecking_too_many_recursive_calls else - parse_instr + parse_instr_aux ?type_logger tc_context ctxt @@ -3055,9 +3102,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc swap stack_ty | Prim (loc, I_PUSH, [t; d], annot), stack -> check_var_annot loc annot >>?= fun () -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t - >>?= fun (Ex_ty t, ctxt) -> - parse_data + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t + >>?= fun [@coq_match_gadt] (Ex_ty t, ctxt) -> + parse_data_aux ?type_logger ~stack_depth:(stack_depth + 1) ctxt @@ -3066,7 +3113,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : t d >>=? fun (v, ctxt) -> - let const = {apply = (fun kinfo k -> IConst (kinfo, v, k))} in + let const = + {apply = (fun kinfo k -> IConst (kinfo, (v [@coq_type_annotation]), k))} + in typed ctxt loc const (Item_t (t, stack)) | Prim (loc, I_UNIT, [], annot), stack -> check_var_type_annot loc annot >>?= fun () -> @@ -3078,7 +3127,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let cons_some = {apply = (fun kinfo k -> ICons_some (kinfo, k))} in option_t loc t >>?= fun ty -> typed ctxt loc cons_some (Item_t (ty, rest)) | Prim (loc, I_NONE, [t], annot), stack -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let cons_none = {apply = (fun kinfo k -> ICons_none (kinfo, k))} in @@ -3162,8 +3211,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : ok (Comb_proof_argument (Comb_one, Item_t (a_ty, tl_ty))) | n, Item_t (a_ty, tl_ty) -> make_proof_argument (n - 1) tl_ty - >>? fun (Comb_proof_argument (comb_witness, Item_t (b_ty, tl_ty'))) - -> + >>? fun [@coq_match_with_default] (Comb_proof_argument + ( comb_witness, + Item_t (b_ty, tl_ty') )) -> pair_t loc a_ty b_ty >|? fun (Ty_ex_c pair_t) -> Comb_proof_argument (Comb_succ comb_witness, Item_t (pair_t, tl_ty')) | _ -> @@ -3180,7 +3230,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc comb after_ty | Prim (loc, I_UNPAIR, [n], annot), stack_ty -> error_unexpected_annot loc annot >>?= fun () -> - let rec make_proof_argument : + let[@coq_struct "n_value"] rec make_proof_argument : type a s. int -> (a, s) stack_ty -> (a * s) uncomb_proof_argument tzresult = fun n stack_ty -> @@ -3243,7 +3293,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc cdr (Item_t (b, rest)) (* unions *) | Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tr + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tr >>?= fun (Ex_ty tr, ctxt) -> check_constr_annot loc annot >>?= fun () -> let cons_left = {apply = (fun kinfo k -> ICons_left (kinfo, k))} in @@ -3251,7 +3301,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack_ty = Item_t (ty, rest) in typed ctxt loc cons_left stack_ty | Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tl + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tl >>?= fun (Ex_ty tl, ctxt) -> check_constr_annot loc annot >>?= fun () -> let cons_right = {apply = (fun kinfo k -> ICons_right (kinfo, k))} in @@ -3296,7 +3346,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Lwt.return @@ merge_branches ctxt loc btr bfr {branch} (* lists *) | Prim (loc, I_NIL, [t], annot), stack -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let nil = {apply = (fun kinfo k -> INil (kinfo, k))} in @@ -3417,7 +3467,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : ) (* sets *) | Prim (loc, I_EMPTY_SET, [t], annot), rest -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt t >>?= fun (Ex_comparable_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_set (kinfo, t, k))} in @@ -3477,9 +3527,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc instr (Item_t (nat_t, rest)) (* maps *) | Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_map (kinfo, tk, k))} in @@ -3603,9 +3653,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc instr (Item_t (nat_t, rest)) (* big_map *) | Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> - parse_big_map_value_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = @@ -3842,9 +3892,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (tr, rest) in typed_no_lwt ctxt loc instr stack) | Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy arg >>?= fun (Ex_ty arg, ctxt) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ret + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ret >>?= fun (Ex_ty ret, ctxt) -> check_kind [Seq_kind] code >>?= fun () -> check_var_annot loc annot >>?= fun () -> @@ -4288,7 +4338,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : (* annotations *) | Prim (loc, I_CAST, [cast_t], annot), (Item_t (t, _) as stack) -> check_var_annot loc annot >>?= fun () -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t >>?= fun (Ex_ty cast_t, ctxt) -> Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) cast_t t >>?= fun (eq, ctxt) -> @@ -4313,7 +4363,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (bytes_t, rest) in typed ctxt loc instr stack | Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t, rest) -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> option_t loc t >>?= fun res_ty -> @@ -4327,7 +4377,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (address_t, rest) in typed ctxt loc instr stack | Prim (loc, I_CONTRACT, [ty], annot), Item_t (Address_t, rest) -> - parse_passable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + parse_passable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> contract_t loc t >>?= fun contract_ty -> option_t loc contract_ty >>?= fun res_ty -> @@ -4386,11 +4436,11 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : contracts but then we throw away the typed version, except for the storage type which is kept for efficiency in the ticket scanner. *) let canonical_code = Micheline.strip_locations code in - parse_toplevel ctxt ~legacy canonical_code + parse_toplevel_aux ctxt ~legacy canonical_code >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) -> record_trace (Ill_formed_type (Some "parameter", canonical_code, location arg_type)) - (parse_parameter_ty_and_entrypoints + (parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -4419,10 +4469,14 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : arg_type_full ret_type_full code_field) - >>=? fun ( Lam - ( {kbef = Item_t (arg, Bot_t); kaft = Item_t (ret, Bot_t); _}, - _ ), - ctxt ) -> + >>=? fun [@coq_match_with_default] ( Lam + ( { + kbef = Item_t (arg, Bot_t); + kaft = Item_t (ret, Bot_t); + _; + }, + _ ), + ctxt ) -> let views_result = parse_views ctxt ?type_logger ~legacy storage_type views in @@ -4503,7 +4557,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Lwt.return ( parse_entrypoint_annot_lax loc annot >>? fun entrypoint -> let open Tc_context in - match tc_context.callsite with + match[@coq_match_gadt] tc_context.callsite with | _ when is_in_lambda tc_context -> error (Forbidden_instr_in_context (loc, Script_tc_errors.Lambda, prim)) @@ -4516,11 +4570,11 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : (Forbidden_instr_in_context (loc, Script_tc_errors.View, prim)) | Toplevel {param_type; entrypoints; storage_type = _} -> Gas_monad.run ctxt - @@ find_entrypoint - ~error_details:(Informative ()) - param_type - entrypoints - entrypoint + @@ (find_entrypoint + ~error_details:(Informative ()) + param_type + entrypoints + entrypoint [@coq_type_annotation]) >>? fun (r, ctxt) -> r >>? fun (Ex_ty_cstr {ty = param_type; _}) -> contract_t loc param_type >>? fun res_ty -> @@ -4901,27 +4955,6 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : I_XOR; ] -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract_data : - type arg argc. - stack_depth:int -> - context -> - Script.location -> - (arg, argc) ty -> - Destination.t -> - entrypoint:Entrypoint.t -> - (context * arg typed_contract) tzresult Lwt.t = - fun ~stack_depth ctxt loc arg destination ~entrypoint -> - let error_details = Informative loc in - parse_contract - ~stack_depth:(stack_depth + 1) - ctxt - ~error_details - loc - arg - destination - ~entrypoint - >>=? fun (ctxt, res) -> Lwt.return (res >|? fun res -> (ctxt, res)) - (* [parse_contract] is used both to: - parse contract data by [parse_data] ([parse_contract_data]) - to execute the [CONTRACT] instruction ([parse_contract_for_script]). @@ -4933,7 +4966,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra The inner [result] is turned into an [option] by [parse_contract_for_script]. Both [tzresult] are merged by [parse_contract_data]. *) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract : +and[@coq_mutual_as_notation] parse_contract : type arg argc err. stack_depth:int -> context -> @@ -4947,7 +4980,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra let error ctxt f_err : context * (_, err) result = ( ctxt, Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> (Inconsistent_types_fast : err) | Informative loc -> trace_of_error @@ f_err loc) ) in @@ -4984,18 +5017,20 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra code >>? fun (code, ctxt) -> (* can only fail because of gas *) - parse_toplevel ctxt ~legacy:true code + parse_toplevel_aux ctxt ~legacy:true code >>? fun ({arg_type; _}, ctxt) -> - parse_parameter_ty_and_entrypoints + parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy:true arg_type - >>? fun ( Ex_parameter_ty_and_entrypoints - {arg_type = targ; entrypoints}, - ctxt ) -> + >>? fun [@coq_match_gadt] ( Ex_parameter_ty_and_entrypoints + {arg_type = targ; entrypoints}, + ctxt ) -> Gas_monad.run ctxt - @@ find_entrypoint_for_type + @@ (find_entrypoint_for_type + [@coq_implicit + "full" "__Ex_parameter_ty_and_entrypoints_'a1"]) ~error_details ~full:targ ~expected:arg @@ -5034,16 +5069,17 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra ctxt parameters_type >>? fun (parameters_type, ctxt) -> - parse_parameter_ty_and_entrypoints + parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy:true (root parameters_type) - >>? fun ( Ex_parameter_ty_and_entrypoints - {arg_type = full; entrypoints}, - ctxt ) -> + >>? fun [@coq_match_gadt] ( Ex_parameter_ty_and_entrypoints + {arg_type = full; entrypoints}, + ctxt ) -> Gas_monad.run ctxt - @@ find_entrypoint_for_type + @@ (find_entrypoint_for_type + [@coq_implicit "full" "__Ex_parameter_ty_and_entrypoints_'a2"]) ~error_details ~full ~expected:arg @@ -5055,6 +5091,27 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra let address = {destination; entrypoint} in Typed_contract {arg_ty; address} )) +and[@coq_mutual_as_notation] parse_contract_data_aux : + type arg argc. + stack_depth:int -> + context -> + Script.location -> + (arg, argc) ty -> + Destination.t -> + entrypoint:Entrypoint.t -> + (context * arg typed_contract) tzresult Lwt.t = + fun ~stack_depth ctxt loc arg destination ~entrypoint -> + let error_details = Informative loc in + parse_contract + ~stack_depth:(stack_depth + 1) + ctxt + ~error_details + loc + arg + destination + ~entrypoint + >>=? fun (ctxt, res) -> Lwt.return (res >|? fun res -> (ctxt, res)) + (* Same as [parse_contract], but does not fail when the contact is missing or if the expected type doesn't match the actual one. In that case None is returned and some overapproximation of the typechecking gas is consumed. @@ -5112,12 +5169,16 @@ let parse_code : code >>?= fun (code, ctxt) -> Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) -> - parse_toplevel ctxt ~legacy code + parse_toplevel_aux ctxt ~legacy code >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) -> let arg_type_loc = location arg_type in record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) - (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:0 ~legacy arg_type) + (parse_parameter_ty_and_entrypoints_aux + ctxt + ~stack_depth:0 + ~legacy + arg_type) >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -> let storage_type_loc = location storage_type in record_trace @@ -5165,7 +5226,7 @@ let parse_storage : (fun () -> let storage_type = serialize_ty_for_error storage_type in Ill_typed_data (None, storage, storage_type)) - (parse_data + (parse_data_aux ?type_logger ~stack_depth:0 ctxt @@ -5174,7 +5235,7 @@ let parse_storage : storage_type (root storage)) -let[@coq_axiom_with_reason "gadt"] parse_script : +let parse_script : ?type_logger:type_logger -> context -> legacy:bool -> @@ -5183,10 +5244,17 @@ let[@coq_axiom_with_reason "gadt"] parse_script : (ex_script * context) tzresult Lwt.t = fun ?type_logger ctxt ~legacy ~allow_forged_in_storage {code; storage} -> parse_code ~legacy ctxt ?type_logger ~code - >>=? fun ( Ex_code - (Code - {code; arg_type; storage_type; views; entrypoints; code_size}), - ctxt ) -> + >>=? fun [@coq_match_gadt] ( Ex_code + (Code + { + code; + arg_type; + storage_type; + views; + entrypoints; + code_size; + }), + ctxt ) -> parse_storage ?type_logger ctxt @@ -5197,7 +5265,15 @@ let[@coq_axiom_with_reason "gadt"] parse_script : >|=? fun (storage, ctxt) -> ( Ex_script (Script - {code_size; code; arg_type; storage; storage_type; views; entrypoints}), + { + code_size; + code; + arg_type; + storage = storage [@coq_type_annotation]; + storage_type; + views; + entrypoints; + }), ctxt ) type typechecked_code_internal = @@ -5211,7 +5287,7 @@ type typechecked_code_internal = } -> typechecked_code_internal -let typecheck_code : +let typecheck_code_aux : legacy:bool -> show_types:bool -> context -> @@ -5220,13 +5296,17 @@ let typecheck_code : fun ~legacy ~show_types ctxt code -> (* Constants need to be expanded or [parse_toplevel] may fail. *) Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) -> - parse_toplevel ctxt ~legacy code >>?= fun (toplevel, ctxt) -> + parse_toplevel_aux ctxt ~legacy code >>?= fun (toplevel, ctxt) -> let {arg_type; storage_type; code_field; views} = toplevel in let type_map = ref [] in let arg_type_loc = location arg_type in record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) - (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:0 ~legacy arg_type) + (parse_parameter_ty_and_entrypoints_aux + ctxt + ~stack_depth:0 + ~legacy + arg_type) >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -> let storage_type_loc = location storage_type in record_trace @@ -5314,13 +5394,12 @@ let list_entrypoints_uncarbonated (type full fullc) (full : (full, fullc) ty) (Entrypoint.Map.singleton name (Ex_ty full, original_type_expr), true) in fold_tree full entrypoints.root [] reachable ([], init) - [@@coq_axiom_with_reason "unsupported syntax"] (* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*) (* -- Unparsing data of any type -- *) -let[@coq_axiom_with_reason "gadt"] rec unparse_data : +let[@coq_struct "ctxt"] rec unparse_data_aux : type a ac. context -> stack_depth:int -> @@ -5333,46 +5412,53 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : let non_terminal_recursion ctxt mode ty a = if Compare.Int.(stack_depth > 10_000) then fail Unparsing_too_many_recursive_calls - else unparse_data ctxt ~stack_depth:(stack_depth + 1) mode ty a + else unparse_data_aux 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 -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, a) with + | Unit_t, (v : unit) -> Lwt.return @@ unparse_unit ~loc ctxt v + | Int_t, (v : _ Script_int.num) -> Lwt.return @@ unparse_int ~loc ctxt v + | Nat_t, (v : _ Script_int.num) -> Lwt.return @@ unparse_nat ~loc ctxt v + | String_t, (s : Script_string.t) -> Lwt.return @@ unparse_string ~loc ctxt s + | Bytes_t, (s : bytes) -> Lwt.return @@ unparse_bytes ~loc ctxt s + | Bool_t, (b : bool) -> Lwt.return @@ unparse_bool ~loc ctxt b + | Timestamp_t, (t : Script_timestamp.t) -> + Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | Address_t, (address : address) -> + Lwt.return @@ unparse_address ~loc ctxt mode address + | Tx_rollup_l2_address_t, (address : tx_rollup_l2_address) -> Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | Contract_t _, contract -> + | Contract_t _, (contract : _ typed_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 -> + | Signature_t, (s : signature) -> + Lwt.return @@ unparse_signature ~loc ctxt mode s + | Mutez_t, (v : Tez_repr.t) -> Lwt.return @@ unparse_mutez ~loc ctxt v + | Key_t, (k : public_key) -> Lwt.return @@ unparse_key ~loc ctxt mode k + | Key_hash_t, (k : public_key_hash) -> + Lwt.return @@ unparse_key_hash ~loc ctxt mode k + | Operation_t, (operation : operation) -> Lwt.return @@ unparse_operation ~loc ctxt operation - | Chain_id_t, chain_id -> + | Chain_id_t, (chain_id : Script_chain_id.t) -> 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 -> + | Bls12_381_g1_t, (x : Script_bls.G1.t) -> + Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x + | Bls12_381_g2_t, (x : Script_bls.G2.t) -> + Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x + | Bls12_381_fr_t, (x : Script_bls.Fr.t) -> + 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 - | Union_t (tl, tr, _, _), v -> + | Union_t (tl, tr, _, _), (v : _ union) -> 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_union ~loc unparse_l unparse_r ctxt v - | Option_t (t, _, _), v -> + | Option_t (t, _, _), (v : _ option) -> 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_t (t, _), (items : _ boxed_list) -> List.fold_left_es (fun (l, ctxt) element -> non_terminal_recursion ctxt mode t element @@ -5380,18 +5466,19 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : ([], ctxt) items.elements >|=? fun (items, ctxt) -> (Micheline.Seq (loc, List.rev items), ctxt) - | Ticket_t (t, _), {ticketer; contents; amount} -> + | Ticket_t (t, _), (x : _ ticket) -> + let {ticketer; contents; amount} = x in (* ideally we would like to allow a little overhead here because it is only used for unparsing *) opened_ticket_type loc t >>?= fun t -> let destination : Destination.t = Contract ticketer in let addr = {destination; entrypoint = Entrypoint.default} in - (unparse_data [@tailcall]) + (unparse_data_aux [@tailcall]) ctxt ~stack_depth mode t (addr, (contents, amount)) - | Set_t (t, _), set -> + | Set_t (t, _), (set : _ set) -> List.fold_left_es (fun (l, ctxt) item -> unparse_comparable_data ~loc ctxt mode t item >|=? fun (item, ctxt) -> @@ -5399,65 +5486,68 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : ([], ctxt) (Script_set.fold (fun e acc -> e :: acc) set []) >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | Map_t (kt, vt, _), map -> + | Map_t (kt, vt, _), (map : _ map) -> let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in unparse_items 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 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 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 ctxt ~stack_depth:(stack_depth + 1) mode original_code + | Big_map_t (kt, vt, _), (x : _ big_map) -> ( + match[@coq_match_gadt] x with + | 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 {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 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 {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 ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)) + | Lambda_t _, (x : _ lambda) -> + let (Lam (_, original_code)) = x in + unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode original_code | Never_t, _ -> . - | Sapling_transaction_t _, s -> + | Sapling_transaction_t _, (s : Sapling.transaction) -> 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 -> + | Sapling_transaction_deprecated_t _, (s : Sapling_repr.legacy_transaction) -> Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_transaction_deprecated s) >|? fun ctxt -> @@ -5467,7 +5557,8 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : s in (Bytes (loc, bytes), ctxt) ) - | Sapling_state_t _, {id; diff; _} -> + | Sapling_state_t _, (x : Sapling.state) -> + let {Sapling.id; diff; _} = x in Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_diff diff) >|? fun ctxt -> ( (match diff with @@ -5489,14 +5580,14 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : Micheline.Prim (loc, D_Pair, [Int (loc, id); unparsed_diff], []))), ctxt ) ) - | Chest_key_t, s -> + | Chest_key_t, (s : Script_timelock.chest_key) -> unparse_with_data_encoding ~loc ctxt s Unparse_costs.chest_key Script_timelock.chest_key_encoding - | Chest_t, s -> + | Chest_t, (s : Script_timelock.chest) -> unparse_with_data_encoding ~loc ctxt @@ -5505,7 +5596,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : ~plaintext_size:(Script_timelock.get_plaintext_size s)) Script_timelock.chest_encoding -and unparse_items : +and[@coq_mutual_as_notation] unparse_items : type k v vc. context -> stack_depth:int -> @@ -5519,23 +5610,23 @@ and unparse_items : (fun (l, ctxt) (k, v) -> let loc = Micheline.dummy_location in unparse_comparable_data ~loc ctxt mode kt k >>=? fun (key, ctxt) -> - unparse_data ctxt ~stack_depth:(stack_depth + 1) mode vt v + unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode vt v >|=? fun (value, ctxt) -> (Prim (loc, D_Elt, [key; value], []) :: l, ctxt)) ([], ctxt) items -and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = +and[@coq_struct "ctxt"] unparse_code_aux ctxt ~stack_depth mode code = let 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 fail Unparsing_too_many_recursive_calls - else unparse_code ctxt ~stack_depth:(stack_depth + 1) mode code + else unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode code in match code with | Prim (loc, I_PUSH, [ty; data], annot) -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty - >>?= fun (Ex_ty t, ctxt) -> + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + >>?= fun [@coq_match_gadt] (Ex_ty t, ctxt) -> let allow_forged = false (* Forgeable in PUSH data are already forbidden at parsing, @@ -5543,7 +5634,7 @@ and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = from APPLYing a non-forgeable but this cannot happen either as long as all packable values are also forgeable. *) in - parse_data + parse_data_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -5551,7 +5642,12 @@ and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = t data >>=? fun (data, ctxt) -> - unparse_data ctxt ~stack_depth:(stack_depth + 1) mode t data + unparse_data_aux + ctxt + ~stack_depth:(stack_depth + 1) + mode + t + (data [@coq_type_annotation]) >>=? fun (data, ctxt) -> return (Prim (loc, I_PUSH, [ty; data], annot), ctxt) | Seq (loc, items) -> @@ -5581,7 +5677,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage ctxt code >>?= fun (code, ctxt) -> - typecheck_code ~legacy ~show_types:false ctxt code + typecheck_code_aux ~legacy ~show_types:false ctxt code >>=? fun ( Typechecked_code_internal { toplevel = @@ -5598,15 +5694,15 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage type_map = _; }, ctxt ) -> - parse_storage + (parse_storage [@coq_implicit "storage" "a"]) ctxt ~legacy ~allow_forged:allow_forged_in_storage storage_type ~storage >>=? fun (storage, ctxt) -> - unparse_code ctxt ~stack_depth:0 mode code_field >>=? fun (code, ctxt) -> - unparse_data ctxt ~stack_depth:0 mode storage_type storage + unparse_code_aux ctxt ~stack_depth:0 mode code_field >>=? fun (code, ctxt) -> + unparse_data_aux ctxt ~stack_depth:0 mode storage_type storage >>=? fun (storage, ctxt) -> let loc = Micheline.dummy_location in (if normalize_types then @@ -5628,7 +5724,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage >>=? fun (arg_type, storage_type, views, ctxt) -> Script_map.map_es_in_context (fun ctxt _name {input_ty; output_ty; view_code} -> - unparse_code ctxt ~stack_depth:0 mode view_code + unparse_code_aux ctxt ~stack_depth:0 mode view_code >|=? fun (view_code, ctxt) -> ({input_ty; output_ty; view_code}, ctxt)) ctxt views @@ -5666,7 +5762,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage ctxt ) let pack_data_with_mode ctxt ty data ~mode = - unparse_data ~stack_depth:0 ctxt mode ty data >>=? fun (unparsed, ctxt) -> + unparse_data_aux ~stack_depth:0 ctxt mode ty data >>=? fun (unparsed, ctxt) -> Lwt.return @@ pack_node unparsed ctxt let hash_data ctxt ty data = @@ -5683,60 +5779,63 @@ type lazy_storage_ids = Lazy_storage.IdSet.t let no_lazy_storage_id = Lazy_storage.IdSet.empty let diff_of_big_map ctxt mode ~temporary ~ids_to_copy - (Big_map {id; key_type; value_type; diff}) = - (match id with - | Some id -> - if Lazy_storage.IdSet.mem Big_map id ids_to_copy then - Big_map.fresh ~temporary ctxt >|=? fun (ctxt, duplicate) -> - (ctxt, Lazy_storage.Copy {src = id}, duplicate) - else - (* The first occurrence encountered of a big_map reuses the - ID. This way, the payer is only charged for the diff. - For this to work, this diff has to be put at the end of - the global diff, otherwise the duplicates will use the - updated version as a base. This is true because we add - this diff first in the accumulator of - `extract_lazy_storage_updates`, and this accumulator is not - reversed. *) - return (ctxt, Lazy_storage.Existing, id) - | None -> - Big_map.fresh ~temporary ctxt >>=? fun (ctxt, id) -> - Lwt.return - (let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in - Gas.consume ctxt (Script.strip_locations_cost kt) >>? fun ctxt -> - unparse_ty ~loc:() ctxt value_type >>? fun (kv, ctxt) -> - Gas.consume ctxt (Script.strip_locations_cost kv) >|? fun ctxt -> - let key_type = Micheline.strip_locations kt in - let value_type = Micheline.strip_locations kv in - (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id))) - >>=? fun (ctxt, init, id) -> - let pairs = - Big_map_overlay.fold - (fun key_hash (key, value) acc -> (key_hash, key, value) :: acc) - diff.map - [] - in - List.fold_left_es - (fun (acc, ctxt) (key_hash, key, value) -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> - unparse_comparable_data ~loc:() ctxt mode key_type key - >>=? fun (key_node, ctxt) -> - Gas.consume ctxt (Script.strip_locations_cost key_node) >>?= fun ctxt -> - let key = Micheline.strip_locations key_node in - (match value with - | None -> return (None, ctxt) - | Some x -> - unparse_data ~stack_depth:0 ctxt mode value_type x - >>=? fun (node, ctxt) -> + (big_map : ('a, 'b) big_map) = + match[@coq_match_gadt] big_map with + | Big_map {id; key_type; value_type; diff} -> + (match id with + | Some id -> + if Lazy_storage.IdSet.mem Big_map id ids_to_copy then + Big_map.fresh ~temporary ctxt >|=? fun (ctxt, duplicate) -> + (ctxt, Lazy_storage.Copy {src = id}, duplicate) + else + (* The first occurrence encountered of a big_map reuses the + ID. This way, the payer is only charged for the diff. + For this to work, this diff has to be put at the end of + the global diff, otherwise the duplicates will use the + updated version as a base. This is true because we add + this diff first in the accumulator of + `extract_lazy_storage_updates`, and this accumulator is not + reversed. *) + return (ctxt, Lazy_storage.Existing, id) + | None -> + Big_map.fresh ~temporary ctxt >>=? fun (ctxt, id) -> Lwt.return - ( Gas.consume ctxt (Script.strip_locations_cost node) >|? fun ctxt -> - (Some (Micheline.strip_locations node), ctxt) )) - >|=? fun (value, ctxt) -> - let diff_item = Big_map.{key; key_hash; value} in - (diff_item :: acc, ctxt)) - ([], ctxt) - (List.rev pairs) - >|=? fun (updates, ctxt) -> (Lazy_storage.Update {init; updates}, id, ctxt) + (let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in + Gas.consume ctxt (Script.strip_locations_cost kt) >>? fun ctxt -> + unparse_ty ~loc:() ctxt value_type >>? fun (kv, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost kv) >|? fun ctxt -> + let key_type = Micheline.strip_locations kt in + let value_type = Micheline.strip_locations kv in + (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id))) + >>=? fun (ctxt, init, id) -> + let pairs = + Big_map_overlay.fold + (fun key_hash (key, value) acc -> (key_hash, key, value) :: acc) + diff.map + [] + in + List.fold_left_es + (fun (acc, ctxt) (key_hash, key, value) -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> + unparse_comparable_data ~loc:() ctxt mode key_type key + >>=? fun (key_node, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost key_node) + >>?= fun ctxt -> + let key = Micheline.strip_locations key_node in + (match value with + | None -> return (None, ctxt) + | Some x -> + unparse_data_aux ~stack_depth:0 ctxt mode value_type x + >>=? fun (node, ctxt) -> + Lwt.return + ( Gas.consume ctxt (Script.strip_locations_cost node) + >|? fun ctxt -> (Some (Micheline.strip_locations node), ctxt) )) + >|=? fun (value, ctxt) -> + let diff_item = Big_map.{key; key_hash; value} in + (diff_item :: acc, ctxt)) + ([], ctxt) + (List.rev pairs) + >|=? fun (updates, ctxt) -> (Lazy_storage.Update {init; updates}, id, ctxt) let diff_of_sapling_state ctxt ~temporary ~ids_to_copy ({id; diff; memo_size} : Sapling.state) = @@ -5753,21 +5852,21 @@ let diff_of_sapling_state ctxt ~temporary ~ids_to_copy (Lazy_storage.Update {init; updates = diff}, id, ctxt) (** - Witness flag for whether a type can be populated by a value containing a - lazy storage. - [False_f] must be used only when a value of the type cannot contain a lazy - storage. + Witness flag for whether a type can be populated by a value containing a + lazy storage. + [False_f] must be used only when a value of the type cannot contain a lazy + storage. - This flag is built in [has_lazy_storage] and used only in - [extract_lazy_storage_updates] and [collect_lazy_storage]. + This flag is built in [has_lazy_storage] and used only in + [extract_lazy_storage_updates] and [collect_lazy_storage]. - This flag is necessary to avoid these two functions to have a quadratic - complexity in the size of the type. + This flag is necessary to avoid these two functions to have a quadratic + complexity in the size of the type. - Add new lazy storage kinds here. + Add new lazy storage kinds here. - Please keep the usage of this GADT local. -*) + Please keep the usage of this GADT local. + *) type 'ty has_lazy_storage = | Big_map_f : ('a, 'b) big_map has_lazy_storage @@ -5784,11 +5883,11 @@ type 'ty has_lazy_storage = | Map_f : 'v has_lazy_storage -> (_, 'v) map has_lazy_storage (** - This function is called only on storage and parameter types of contracts, - once per typechecked contract. It has a complexity linear in the size of - the types, which happen to be literally written types, so the gas for them - has already been paid. -*) + This function is called only on storage and parameter types of contracts, + once per typechecked contract. It has a complexity linear in the size of + the types, which happen to be literally written types, so the gas for them + has already been paid. + *) let rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage = fun ty -> let aux1 cons t = @@ -5836,16 +5935,15 @@ let rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage = | Map_t (_, t, _) -> aux1 (fun h -> Map_f h) t (** - Transforms a value potentially containing lazy storage in an intermediary - state to a value containing lazy storage only represented by identifiers. + Transforms a value potentially containing lazy storage in an intermediary + state to a value containing lazy storage only represented by identifiers. - Returns the updated value, the updated set of ids to copy, and the lazy - storage diff to show on the receipt and apply on the storage. + Returns the updated value, the updated set of ids to copy, and the lazy + storage diff to show on the receipt and apply on the storage. -*) -let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode - ~temporary ids_to_copy acc ty x = - let rec aux : + *) +let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = + let[@coq_struct "has_lazy_storage_value"] rec aux : type a ac. context -> unparsing_mode -> @@ -5858,9 +5956,11 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode (context * a * Lazy_storage.IdSet.t * Lazy_storage.diffs) tzresult Lwt.t = fun ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> - match (has_lazy_storage, ty, x) with - | False_f, _, _ -> return (ctxt, x, ids_to_copy, acc) - | Big_map_f, Big_map_t (_, _, _), map -> + match[@coq_match_gadt_with_result] [@coq_match_with_default] + (has_lazy_storage, ty, x) + with + | False_f, _, _ -> return (ctxt, x, ids_to_copy, acc) [@coq_type_annotation] + | Big_map_f, Big_map_t (_, _, _), (map : _ big_map) -> diff_of_big_map ctxt mode ~temporary ~ids_to_copy map >|=? fun (diff, id, ctxt) -> let map = @@ -5875,7 +5975,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode let diff = Lazy_storage.make Big_map id diff in let ids_to_copy = Lazy_storage.IdSet.add Big_map id ids_to_copy in (ctxt, map, ids_to_copy, diff :: acc) - | Sapling_state_f, Sapling_state_t _, sapling_state -> + | Sapling_state_f, Sapling_state_t _, (sapling_state : Sapling.state) -> diff_of_sapling_state ctxt ~temporary ~ids_to_copy sapling_state >|=? fun (diff, id, ctxt) -> let sapling_state = @@ -5884,22 +5984,48 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode let diff = Lazy_storage.make Sapling_state id diff in let ids_to_copy = Lazy_storage.IdSet.add Sapling_state id ids_to_copy in (ctxt, sapling_state, ids_to_copy, diff :: acc) - | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr) -> + | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (x : _ * _) -> + let xl, xr = x in aux ctxt mode ~temporary ids_to_copy acc tyl xl ~has_lazy_storage:hl >>=? fun (ctxt, xl, ids_to_copy, acc) -> aux ctxt mode ~temporary ids_to_copy acc tyr xr ~has_lazy_storage:hr >|=? fun (ctxt, xr, ids_to_copy, acc) -> (ctxt, (xl, xr), ids_to_copy, acc) - | Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc) - | Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, R x, ids_to_copy, acc) - | Option_f has_lazy_storage, Option_t (ty, _, _), Some x -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, Some x, ids_to_copy, acc) - | List_f has_lazy_storage, List_t (ty, _), l -> + | ( Union_f (has_lazy_storage_l, has_lazy_storage_r), + Union_t (tyl, tyr, _, _), + (x : _ union) ) -> ( + match x with + | L x -> + aux + ctxt + mode + ~temporary + ids_to_copy + acc + tyl + x + ~has_lazy_storage:has_lazy_storage_l + >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc) + | R x -> + aux + ctxt + mode + ~temporary + ids_to_copy + acc + tyr + x + ~has_lazy_storage:has_lazy_storage_r + >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, R x, ids_to_copy, acc) + ) + | Option_f has_lazy_storage, Option_t (ty, _, _), (x : _ option) -> ( + match x with + | Some x -> + aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage + >|=? fun (ctxt, x, ids_to_copy, acc) -> + (ctxt, Some x, ids_to_copy, acc) + | None -> return (ctxt, None, ids_to_copy, acc)) + | List_f has_lazy_storage, List_t (ty, _), (l : _ boxed_list) -> List.fold_left_es (fun (ctxt, l, ids_to_copy, acc) x -> aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage @@ -5910,7 +6036,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode >|=? fun (ctxt, l, ids_to_copy, acc) -> let reversed = {length = l.length; elements = List.rev l.elements} in (ctxt, reversed, ids_to_copy, acc) - | Map_f has_lazy_storage, Map_t (_, ty, _), map -> + | Map_f has_lazy_storage, Map_t (_, ty, _), (map : _ map) -> let (module M) = Script_map.get_module map in let bindings m = M.OPS.fold (fun k v bs -> (k, v) :: bs) m [] in List.fold_left_es @@ -5921,7 +6047,8 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode (ctxt, M.OPS.empty, ids_to_copy, acc) (bindings M.boxed) >|=? fun (ctxt, m, ids_to_copy, acc) -> - let module M = struct + let module M : + Boxed_map with type key = M.key and type value = M.value = struct module OPS = M.OPS type key = M.key @@ -5931,6 +6058,8 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode let boxed = m let size = M.size + + let boxed_map_tag = () end in ( ctxt, Script_map.make @@ -5939,13 +6068,12 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode and type value = M.value), ids_to_copy, acc ) - | _, Option_t (_, _, _), None -> return (ctxt, None, ids_to_copy, acc) in let has_lazy_storage = has_lazy_storage ty in aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage (** We namespace an error type for [fold_lazy_storage]. The error case is only - available when the ['error] parameter is equal to unit. *) + available when the ['error] parameter is equal to unit. *) module Fold_lazy_storage = struct type ('acc, 'error) result = | Ok : 'acc -> ('acc, 'error) result @@ -5953,9 +6081,9 @@ module Fold_lazy_storage = struct end (** Prematurely abort if [f] generates an error. Use this function without the - [unit] type for [error] if you are in a case where errors are impossible. -*) -let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : + [unit] type for [error] if you are in a case where errors are impossible. + *) +let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage : type a ac error. f:('acc, error) Fold_lazy_storage.result Lazy_storage.IdSet.fold_f -> init:'acc -> @@ -5966,33 +6094,55 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : (('acc, error) Fold_lazy_storage.result * context) tzresult = fun ~f ~init ctxt ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - match (has_lazy_storage, ty, x) with - | Big_map_f, Big_map_t (_, _, _), Big_map {id = Some id; _} -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt) - | Sapling_state_f, Sapling_state_t _, {id = Some id; _} -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - ok (f.f Sapling_state id (Fold_lazy_storage.Ok init), ctxt) + match[@coq_match_gadt] [@coq_match_with_default] + (has_lazy_storage, ty, x) + with + | Big_map_f, Big_map_t (_, _, _), (x : _ big_map) -> ( + match x with + | Big_map {id = Some id; _} -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> + ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt) + | Big_map {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt)) + | Sapling_state_f, Sapling_state_t _, (x : Alpha_context.Sapling.state) -> ( + match x with + | {id = Some id; _} -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> + ok (f.f Sapling_state id (Fold_lazy_storage.Ok init), ctxt) + | {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt)) | False_f, _, _ -> ok (Fold_lazy_storage.Ok init, ctxt) - | Big_map_f, Big_map_t (_, _, _), Big_map {id = None; _} -> - ok (Fold_lazy_storage.Ok init, ctxt) - | Sapling_state_f, Sapling_state_t _, {id = None; _} -> - ok (Fold_lazy_storage.Ok init, ctxt) - | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr) -> ( + | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (x : _ pair) -> ( + let xl, xr = x in fold_lazy_storage ~f ~init ctxt tyl xl ~has_lazy_storage:hl >>? fun (init, ctxt) -> match init with | Fold_lazy_storage.Ok init -> fold_lazy_storage ~f ~init ctxt tyr xr ~has_lazy_storage:hr | Fold_lazy_storage.Error -> ok (init, ctxt)) - | Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x -> - fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x -> - fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | _, Option_t (_, _, _), None -> ok (Fold_lazy_storage.Ok init, ctxt) - | Option_f has_lazy_storage, Option_t (ty, _, _), Some x -> - fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | List_f has_lazy_storage, List_t (ty, _), l -> + | ( Union_f (has_lazy_storage_l, has_lazy_storage_r), + Union_t (tyl, tyr, _, _), + (x : _ union) ) -> ( + match x with + | L x -> + fold_lazy_storage + ~f + ~init + ctxt + tyl + x + ~has_lazy_storage:has_lazy_storage_l + | R x -> + fold_lazy_storage + ~f + ~init + ctxt + tyr + x + ~has_lazy_storage:has_lazy_storage_r) + | Option_f has_lazy_storage, Option_t (ty, _, _), (x : _ option) -> ( + match x with + | Some x -> fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage + | None -> ok (Fold_lazy_storage.Ok init, ctxt)) + | List_f has_lazy_storage, List_t (ty, _), (l : _ boxed_list) -> List.fold_left_e (fun ((init, ctxt) : ('acc, error) Fold_lazy_storage.result * context) x -> match init with @@ -6001,7 +6151,7 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : | Fold_lazy_storage.Error -> ok (init, ctxt)) (Fold_lazy_storage.Ok init, ctxt) l.elements - | Map_f has_lazy_storage, Map_t (_, ty, _), m -> + | Map_f has_lazy_storage, Map_t (_, ty, _), (m : _ map) -> Script_map.fold (fun _ v @@ -6014,23 +6164,26 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : m (ok (Fold_lazy_storage.Ok init, ctxt)) -let[@coq_axiom_with_reason "gadt"] collect_lazy_storage ctxt ty x = +let collect_lazy_storage ctxt ty x = let has_lazy_storage = has_lazy_storage ty in let f kind id (acc : (_, never) Fold_lazy_storage.result) = - let acc = match acc with Fold_lazy_storage.Ok acc -> acc in + let acc = + match[@coq_match_with_default] acc with Fold_lazy_storage.Ok acc -> acc + in Fold_lazy_storage.Ok (Lazy_storage.IdSet.add kind id acc) in fold_lazy_storage ~f:{f} ~init:no_lazy_storage_id ctxt ty x ~has_lazy_storage >>? fun (ids, ctxt) -> - match ids with Fold_lazy_storage.Ok ids -> ok (ids, ctxt) + match[@coq_match_with_default] ids with + | Fold_lazy_storage.Ok ids -> ok (ids, ctxt) -let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode - ~temporary ~to_duplicate ~to_update ty v = +let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v + = (* - Basically [to_duplicate] are ids from the argument and [to_update] are ids - from the storage before execution (i.e. it is safe to reuse them since they - will be owned by the same contract). - *) + Basically [to_duplicate] are ids from the argument and [to_update] are ids + from the storage before execution (i.e. it is safe to reuse them since they + will be owned by the same contract). + *) let to_duplicate = Lazy_storage.IdSet.diff to_duplicate to_update in extract_lazy_storage_updates ctxt mode ~temporary to_duplicate [] ty v >|=? fun (ctxt, v, alive, diffs) -> @@ -6038,10 +6191,15 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode if temporary then diffs else let dead = Lazy_storage.IdSet.diff to_update alive in - Lazy_storage.IdSet.fold_all - {f = (fun kind id acc -> Lazy_storage.make kind id Remove :: acc)} - dead - diffs + let f kind id acc = + (Lazy_storage.make + [@coq_implicit "a" "unit"] [@coq_implicit "u" "unit"]) + kind + id + Remove + :: acc + in + Lazy_storage.IdSet.fold_all {f} dead diffs in match diffs with | [] -> (v, None, ctxt) @@ -6050,7 +6208,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode let list_of_big_map_ids ids = Lazy_storage.IdSet.fold Big_map (fun id acc -> id :: acc) ids [] -let parse_data = parse_data ~stack_depth:0 +let parse_data = parse_data_aux ~stack_depth:0 let parse_comparable_data = parse_data ~legacy:false ~allow_forged:false @@ -6064,7 +6222,7 @@ let parse_instr : (a, s) stack_ty -> ((a, s) judgement * context) tzresult Lwt.t = fun ?type_logger tc_context ctxt ~legacy script_instr stack_ty -> - parse_instr + parse_instr_aux ~stack_depth:0 ?type_logger tc_context @@ -6073,41 +6231,41 @@ let parse_instr : script_instr stack_ty -let unparse_data = unparse_data ~stack_depth:0 +let unparse_data = unparse_data_aux ~stack_depth:0 let unparse_code ctxt mode code = (* Constants need to be expanded or [unparse_code] may fail. *) Global_constants_storage.expand ctxt (strip_locations code) - >>=? fun (ctxt, code) -> unparse_code ~stack_depth:0 ctxt mode (root code) + >>=? fun (ctxt, code) -> unparse_code_aux ~stack_depth:0 ctxt mode (root code) let parse_contract_data context loc arg_ty contract ~entrypoint = - parse_contract_data ~stack_depth:0 context loc arg_ty contract ~entrypoint + parse_contract_data_aux ~stack_depth:0 context loc arg_ty contract ~entrypoint let parse_toplevel ctxt ~legacy toplevel = Global_constants_storage.expand ctxt toplevel >>=? fun (ctxt, toplevel) -> - Lwt.return @@ parse_toplevel ctxt ~legacy toplevel + Lwt.return @@ parse_toplevel_aux ctxt ~legacy toplevel -let parse_comparable_ty = parse_comparable_ty ~stack_depth:0 +let parse_comparable_ty = parse_comparable_ty_aux ~stack_depth:0 -let parse_big_map_value_ty = parse_big_map_value_ty ~stack_depth:0 +let parse_big_map_value_ty = parse_big_map_value_ty_aux ~stack_depth:0 -let parse_packable_ty = parse_packable_ty ~stack_depth:0 +let parse_packable_ty = parse_packable_ty_aux ~stack_depth:0 -let parse_passable_ty = parse_passable_ty ~stack_depth:0 +let parse_passable_ty = parse_passable_ty_aux ~stack_depth:0 -let parse_any_ty = parse_any_ty ~stack_depth:0 +let parse_any_ty = parse_any_ty_aux ~stack_depth:0 -let parse_ty = parse_ty ~stack_depth:0 ~ret:Don't_parse_entrypoints +let parse_ty = parse_ty_aux ~stack_depth:0 ~ret:Don't_parse_entrypoints let parse_parameter_ty_and_entrypoints = - parse_parameter_ty_and_entrypoints ~stack_depth:0 + parse_parameter_ty_and_entrypoints_aux ~stack_depth:0 -let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x = +let get_single_sapling_state ctxt ty x = let has_lazy_storage = has_lazy_storage ty in let f (type i a u) (kind : (i, a, u) Lazy_storage.Kind.t) (id : i) single_id_opt : (Sapling.Id.t option, unit) Fold_lazy_storage.result = - match kind with - | Lazy_storage.Kind.Sapling_state -> ( + match[@coq_match_gadt] (kind, id) with + | Lazy_storage.Kind.Sapling_state, (id : Sapling.Id.t) -> ( match single_id_opt with | Fold_lazy_storage.Ok None -> Fold_lazy_storage.Ok (Some id) | Fold_lazy_storage.Ok (Some _) -> @@ -6123,31 +6281,31 @@ let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x = (* - {!Script_cache} needs a measure of the script size in memory. - Determining this size is not easy in OCaml because of sharing. - - Indeed, many values present in the script share the same memory - area. This is especially true for types and stack types: they are - heavily shared in every typed IR internal representation. As a - consequence, computing the size of the typed IR without taking - sharing into account leads to a size which is sometimes two order - of magnitude bigger than the actual size. - - We could track down this sharing. Unfortunately, sharing is not - part of OCaml semantics: for this reason, a compiler can optimize - memory representation by adding more sharing. If two nodes use - different optimization flags or compilers, such a precise - computation of the memory footprint of scripts would lead to two - distinct sizes. As these sizes occur in the blockchain context, - this situation would lead to a fork. - - For this reason, we introduce a *size model* for the script size. - This model provides an overapproximation of the actual size in - memory. The risk is to be too far from the actual size: the cache - would then be wrongly marked as full. This situation would make the - cache less useful but should present no security risk . + {!Script_cache} needs a measure of the script size in memory. + Determining this size is not easy in OCaml because of sharing. + + Indeed, many values present in the script share the same memory + area. This is especially true for types and stack types: they are + heavily shared in every typed IR internal representation. As a + consequence, computing the size of the typed IR without taking + sharing into account leads to a size which is sometimes two order + of magnitude bigger than the actual size. + + We could track down this sharing. Unfortunately, sharing is not + part of OCaml semantics: for this reason, a compiler can optimize + memory representation by adding more sharing. If two nodes use + different optimization flags or compilers, such a precise + computation of the memory footprint of scripts would lead to two + distinct sizes. As these sizes occur in the blockchain context, + this situation would lead to a fork. + + For this reason, we introduce a *size model* for the script size. + This model provides an overapproximation of the actual size in + memory. The risk is to be too far from the actual size: the cache + would then be wrongly marked as full. This situation would make the + cache less useful but should present no security risk . -*) + *) let script_size (Ex_script (Script @@ -6167,5 +6325,5 @@ let script_size (Saturation_repr.(add code_size storage_size |> to_int), cost) let typecheck_code ~legacy ~show_types ctxt code = - typecheck_code ~legacy ~show_types ctxt code + typecheck_code_aux ~legacy ~show_types ctxt code >|=? fun (Typechecked_code_internal {type_map; _}, ctxt) -> (type_map, ctxt) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index e7a85579e8e5bc49846ce2175d2d5d9b7af1a672..ba42422368368c1d348692fc94d8957fe9df49a1 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -111,6 +111,7 @@ type ('arg, 'storage) code = field as it has a dynamic size. *) } -> ('arg, 'storage) code +[@@coq_force_gadt] type ex_code = Ex_code : ('a, 'c) code -> ex_code @@ -127,6 +128,7 @@ type 'storage typed_view = original_code_expr : Script.node; } -> 'storage typed_view +[@@coq_force_gadt] type 'storage typed_view_map = (Script_string.t, 'storage typed_view) Script_typed_ir.map diff --git a/src/proto_alpha/lib_protocol/script_map.ml b/src/proto_alpha/lib_protocol/script_map.ml index 5e7dcf3b44da353282503c399c567c4db5a93def..70f2c38f91f8daee459b717c452a124b877ace18 100644 --- a/src/proto_alpha/lib_protocol/script_map.ml +++ b/src/proto_alpha/lib_protocol/script_map.ml @@ -44,18 +44,36 @@ let empty_from : type a b c. (a, b) map -> (a, c) map = let boxed = OPS.empty let size = 0 + + let boxed_map_tag = () end) let empty : type a b. a comparable_ty -> (a, b) map = fun ty -> - let module OPS = struct + let module OPS : Boxed_map_OPS with type key = a = struct let key_size = Gas_comparable_input_size.size_of_comparable_value ty - include Map.Make (struct + module Map = Map.Make (struct type t = a let compare = Script_comparable.compare_comparable ty end) + + type 'a t = 'a Map.t + + type key = Map.key + + let empty = Map.empty + + let add = Map.add + + let remove = Map.remove + + let find = Map.find + + let fold = Map.fold + + let fold_es = Map.fold_es end in Map_tag (module struct @@ -68,6 +86,8 @@ let empty : type a b. a comparable_ty -> (a, b) map = let boxed = OPS.empty let size = 0 + + let boxed_map_tag = () end) let get : type key value. key -> (key, value) map -> value option = @@ -94,6 +114,8 @@ let update : type a b. a -> b option -> (a, b) map -> (a, b) map = let boxed = boxed let size = size + + let boxed_map_tag = () end) let mem : type key value. key -> (key, value) map -> bool = @@ -141,5 +163,7 @@ let map_es_in_context : let boxed = map let size = Box.size + + let boxed_map_tag = () end), ctxt ) diff --git a/src/proto_alpha/lib_protocol/script_repr.ml b/src/proto_alpha/lib_protocol/script_repr.ml index 681d6d7c627a54161e667a89f2aa46381efff12d..139f9cc215b03487ff1e79f1aa0cb5c8f18e1efe 100644 --- a/src/proto_alpha/lib_protocol/script_repr.ml +++ b/src/proto_alpha/lib_protocol/script_repr.ml @@ -254,11 +254,13 @@ let force_decode_cost lexpr = ~fun_combine:(fun _ _ -> Gas_limit_repr.free) lexpr +type 'a bytes_or_value = Only_value of 'a | Has_bytes of bytes + let stable_force_decode_cost lexpr = let has_bytes = Data_encoding.apply_lazy - ~fun_value:(fun v -> `Only_value v) - ~fun_bytes:(fun b -> `Has_bytes b) + ~fun_value:(fun v -> Only_value v) + ~fun_bytes:(fun b -> Has_bytes b) ~fun_combine:(fun _v b -> (* When the lazy_expr contains both a deserialized version and a serialized one, we compute the cost from the @@ -267,8 +269,8 @@ let stable_force_decode_cost lexpr = lexpr in match has_bytes with - | `Has_bytes b -> deserialization_cost_estimated_from_bytes (Bytes.length b) - | `Only_value v -> + | Has_bytes b -> deserialization_cost_estimated_from_bytes (Bytes.length b) + | Only_value v -> (* This code path should not be reached in theory because values that are decoded should have been encoded before. Here we use Data_encoding.Binary.length, which yields the same results @@ -312,7 +314,7 @@ let is_unit_parameter = ~fun_bytes:(fun b -> Compare.Bytes.equal b unit_bytes) ~fun_combine:(fun res _ -> res) -let[@coq_struct "node"] rec strip_annotations node = +let[@coq_struct "node_value"] rec strip_annotations node = let open Micheline in match node with | (Int (_, _) | String (_, _) | Bytes (_, _)) as leaf -> leaf @@ -320,7 +322,7 @@ let[@coq_struct "node"] rec strip_annotations node = Prim (loc, name, List.map strip_annotations args, []) | Seq (loc, args) -> Seq (loc, List.map strip_annotations args) -let rec micheline_fold_aux node f acc k = +let rec micheline_fold_aux (node : _ michelson_node) f acc k = match node with | Micheline.Int (_, _) -> k (f acc node) | Micheline.String (_, _) -> k (f acc node) diff --git a/src/proto_alpha/lib_protocol/script_set.ml b/src/proto_alpha/lib_protocol/script_set.ml index c18824cdb973bde4acdf6b6286851932e76a262a..01ad398d0e5e94acbc252aea5f0f0aa29f170ce3 100644 --- a/src/proto_alpha/lib_protocol/script_set.ml +++ b/src/proto_alpha/lib_protocol/script_set.ml @@ -36,11 +36,25 @@ let empty : type a. a comparable_ty -> a set = let module OPS : Boxed_set_OPS with type elt = a = struct let elt_size = Gas_comparable_input_size.size_of_comparable_value ty - include Set.Make (struct + module Set = Set.Make (struct type t = a let compare = Script_comparable.compare_comparable ty end) + + type t = Set.t + + type elt = Set.elt + + let empty = Set.empty + + let add = Set.add + + let mem = Set.mem + + let remove = Set.remove + + let fold = Set.fold end in Set_tag (module struct diff --git a/src/proto_alpha/lib_protocol/script_string.ml b/src/proto_alpha/lib_protocol/script_string.ml index b3108eb31ef238ac9328e322e14ef52818dd5aea..ea0c6bca872cc047a75833d213b6d79c80d42c51 100644 --- a/src/proto_alpha/lib_protocol/script_string.ml +++ b/src/proto_alpha/lib_protocol/script_string.ml @@ -57,7 +57,7 @@ let () = let empty = String_tag "" let of_string v = - let rec check_printable_ascii i = + let[@coq_struct "i_value"] rec check_printable_ascii i = if Compare.Int.(i < 0) then ok (String_tag v) else match v.[i] with diff --git a/src/proto_alpha/lib_protocol/script_tc_errors.ml b/src/proto_alpha/lib_protocol/script_tc_errors.ml index 1f0c39d222b8bda47d16e6cd30e5bca766cbb951..13c4404495e29d522eca152416d4cab5e09129cb 100644 --- a/src/proto_alpha/lib_protocol/script_tc_errors.ml +++ b/src/proto_alpha/lib_protocol/script_tc_errors.ml @@ -210,6 +210,6 @@ the error will be ignored later. For example, when types are compared during the interpretation of the [CONTRACT] instruction any error will lead to returning [None] but the content of the error will be ignored. *) -type (_, _) error_details = +type ('error_context, _) error_details = | Informative : 'error_context -> ('error_context, error trace) error_details - | Fast : (_, inconsistent_types_fast_error) error_details + | Fast : ('error_context, inconsistent_types_fast_error) error_details diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index ace9d41489774034b5cd8dee83e6a87885e22589..c15ecdad5e276d5c441d7e715369eaab53475890 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -241,7 +241,7 @@ module type TYPE_SIZE = sig submodule), the type is abstract but we have access to unsafe constructors that can break the invariant. *) - type 'a t + type 'a t [@@coq_phantom] val check_eq : error_details:('error_context, 'error_trace) Script_tc_errors.error_details -> @@ -296,7 +296,7 @@ module Type_size : TYPE_SIZE = struct if Compare.Int.(x = y) then Result.return_unit else Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> Inconsistent_types_fast | Informative _ -> trace_of_error @@ Script_tc_errors.Inconsistent_type_sizes (x, y)) @@ -399,6 +399,8 @@ module type Boxed_map = sig val boxed : value OPS.t val size : int + + val boxed_map_tag : unit end type ('key, 'value) map = @@ -440,6 +442,7 @@ and 'arg nested_entrypoints = } -> ('l, 'r) union nested_entrypoints | Entrypoints_None : _ nested_entrypoints +[@@coq_force_gadt] let no_entrypoints = {at_node = None; nested = Entrypoints_None} @@ -465,6 +468,7 @@ type ('arg, 'storage) script = field as it has a dynamic size. *) } -> ('arg, 'storage) script +[@@coq_force_gadt] (* ---- Instructions --------------------------------------------------------*) and ('before_top, 'before, 'result_top, 'result) kinstr = @@ -1149,6 +1153,7 @@ and 'arg typed_contract = address : address; } -> 'arg typed_contract +[@@coq_force_gadt] and (_, _, _, _) continuation = | KNil : ('r, 'f, 'r, 'f) continuation @@ -1206,6 +1211,7 @@ and (_, _, _, _) continuation = | KLog : ('a, 's, 'r, 'f) continuation * logger -> ('a, 's, 'r, 'f) continuation +[@@coq_force_gadt] and ('a, 's, 'b, 'f, 'c, 'u) logging_function = ('a, 's, 'b, 'f) kinstr -> @@ -1283,6 +1289,7 @@ and ('ty, 'comparable) ty = | Ticket_t : 'a comparable_ty * 'a ticket ty_metadata -> ('a ticket, no) ty | Chest_key_t : (Script_timelock.chest_key, no) ty | Chest_t : (Script_timelock.chest, no) ty +[@@coq_force_gadt] and 'ty comparable_ty = ('ty, yes) ty @@ -1300,6 +1307,7 @@ and ('key, 'value) big_map = value_type : ('value, _) ty; } -> ('key, 'value) big_map +[@@coq_force_gadt] and ('a, 's, 'r, 'f) kdescr = { kloc : Script.location; @@ -1365,6 +1373,7 @@ and ('input, 'output) view_signature = output_ty : ('output, _) ty; } -> ('input, 'output) view_signature +[@@coq_force_gadt] and 'kind manager_operation = | Transaction_to_contract : { @@ -1849,7 +1858,8 @@ let is_comparable : type v c. (v, c) ty -> c dbool = function | Chest_t -> No | Chest_key_t -> No -type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c [@@ocaml.unboxed] +type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c +[@@ocaml.unboxed] [@@coq_force_gadt] let unit_t = Unit_t @@ -2191,7 +2201,7 @@ let kinstr_traverse i init f = type 'a ty_traverse = {apply : 't 'tc. 'a -> ('t, 'tc) ty -> 'a} -let ty_traverse = +module Ty_traverse = struct let rec aux : type ret t tc accu. accu ty_traverse -> accu -> (t, tc) ty -> (accu -> ret) -> ret = @@ -2222,7 +2232,8 @@ let ty_traverse = (aux [@ocaml.tailcall]) f accu cty (fun accu -> (next [@ocaml.tailcall]) f accu ty1 continue) | Contract_t (ty1, _) -> (next [@ocaml.tailcall]) f accu ty1 continue - and next2 : + + and[@coq_mutual_as_notation] next2 : type a ac b bc ret accu. accu ty_traverse -> accu -> @@ -2234,14 +2245,16 @@ let ty_traverse = (aux [@ocaml.tailcall]) f accu ty1 (fun accu -> (aux [@ocaml.tailcall]) f accu ty2 (fun accu -> (continue [@ocaml.tailcall]) accu)) - and next : + + and[@coq_mutual_as_notation] next : type a ac ret accu. accu ty_traverse -> accu -> (a, ac) ty -> (accu -> ret) -> ret = fun f accu ty1 continue -> (aux [@ocaml.tailcall]) f accu ty1 (fun accu -> (continue [@ocaml.tailcall]) accu) - in - fun ty init f -> aux f init ty (fun accu -> accu) +end + +let ty_traverse ty init f = Ty_traverse.aux f init ty (fun accu -> accu) type 'accu stack_ty_traverse = { apply : 'ty 's. 'accu -> ('ty, 's) stack_ty -> 'accu; @@ -2258,78 +2271,104 @@ let stack_ty_traverse (type a t) (sty : (a, t) stack_ty) init f = type 'a value_traverse = {apply : 't 'tc. 'a -> ('t, 'tc) ty -> 't -> 'a} -let value_traverse (type t tc) (ty : (t, tc) ty) (x : t) init f = - let rec aux : type ret t tc. 'accu -> (t, tc) ty -> t -> ('accu -> ret) -> ret +module Value_traverse = struct + let[@coq_struct "ty_value"] rec aux : + type ret t tc. + 'accu value_traverse -> 'accu -> (t, tc) ty -> t -> ('accu -> ret) -> ret = - fun accu ty x continue -> + fun f accu ty x continue -> let accu = f.apply accu ty x in let next2 ty1 ty2 x1 x2 = - (aux [@ocaml.tailcall]) accu ty1 x1 (fun accu -> - (aux [@ocaml.tailcall]) accu ty2 x2 (fun accu -> + (aux [@ocaml.tailcall]) f accu ty1 x1 (fun accu -> + (aux [@ocaml.tailcall]) f accu ty2 x2 (fun accu -> (continue [@ocaml.tailcall]) accu)) in let next ty1 x1 = - (aux [@ocaml.tailcall]) accu ty1 x1 (fun accu -> + (aux [@ocaml.tailcall]) f accu ty1 x1 (fun accu -> (continue [@ocaml.tailcall]) accu) in let return () = (continue [@ocaml.tailcall]) accu in let rec on_list ty' accu = function | [] -> (continue [@ocaml.tailcall]) accu | x :: xs -> - (aux [@ocaml.tailcall]) accu ty' x (fun accu -> + (aux [@ocaml.tailcall]) f accu ty' x (fun accu -> (on_list [@ocaml.tailcall]) ty' accu xs) in - match ty with - | Unit_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t - | Key_hash_t | Key_t | Timestamp_t | Address_t | Tx_rollup_l2_address_t - | Bool_t | Sapling_transaction_t _ | Sapling_transaction_deprecated_t _ - | Sapling_state_t _ | Operation_t | Chain_id_t | Never_t | Bls12_381_g1_t - | Bls12_381_g2_t | Bls12_381_fr_t | Chest_key_t | Chest_t - | Lambda_t (_, _, _) -> + match[@coq_match_gadt] (ty, x) with + | Unit_t, _ + | Int_t, _ + | Nat_t, _ + | Signature_t, _ + | String_t, _ + | Bytes_t, _ + | Mutez_t, _ + | Key_hash_t, _ + | Key_t, _ + | Timestamp_t, _ + | Address_t, _ + | Tx_rollup_l2_address_t, _ + | Bool_t, _ + | Sapling_transaction_t _, _ + | Sapling_transaction_deprecated_t _, _ + | Sapling_state_t _, _ + | Operation_t, _ + | Chain_id_t, _ + | Never_t, _ + | Bls12_381_g1_t, _ + | Bls12_381_g2_t, _ + | Bls12_381_fr_t, _ + | Chest_key_t, _ + | Chest_t, _ + | Lambda_t (_, _, _), _ -> (return [@ocaml.tailcall]) () - | Pair_t (ty1, ty2, _, _) -> + | Pair_t (ty1, ty2, _, _), (x : _ * _) -> (next2 [@ocaml.tailcall]) ty1 ty2 (fst x) (snd x) - | Union_t (ty1, ty2, _, _) -> ( + | Union_t (ty1, ty2, _, _), (x : _ union) -> ( match x with | L l -> (next [@ocaml.tailcall]) ty1 l | R r -> (next [@ocaml.tailcall]) ty2 r) - | Option_t (ty, _, _) -> ( + | Option_t (ty, _, _), (x : _ option) -> ( match x with | None -> return () | Some v -> (next [@ocaml.tailcall]) ty v) - | Ticket_t (cty, _) -> (aux [@ocaml.tailcall]) accu cty x.contents continue - | List_t (ty', _) -> on_list ty' accu x.elements - | Map_t (kty, ty', _) -> + | Ticket_t (cty, _), (x : _ ticket) -> + (aux [@ocaml.tailcall]) f accu cty x.contents continue + | List_t (ty', _), (x : _ boxed_list) -> on_list ty' accu x.elements + | Map_t (kty, ty', _), (x : _ map) -> let (Map_tag (module M)) = x in let bindings = M.OPS.fold (fun k v bs -> (k, v) :: bs) M.boxed [] in - on_bindings accu kty ty' continue bindings - | Set_t (ty', _) -> + on_bindings f accu kty ty' continue bindings + | Set_t (ty', _), (x : _ set) -> let (Set_tag (module M)) = x in let elements = M.OPS.fold (fun x s -> x :: s) M.boxed [] in on_list ty' accu elements - | Big_map_t (_, _, _) -> + | Big_map_t (_, _, _), _ -> (* For big maps, there is no obvious recursion scheme so we delegate this case to the client. *) (return [@ocaml.tailcall]) () - | Contract_t (_, _) -> (return [@ocaml.tailcall]) () - and on_bindings : + | Contract_t (_, _), _ -> (return [@ocaml.tailcall]) () + + and[@coq_struct "xs"] on_bindings : type ret k v vc. + 'accu value_traverse -> 'accu -> k comparable_ty -> (v, vc) ty -> ('accu -> ret) -> (k * v) list -> ret = - fun accu kty ty' continue xs -> + fun f accu kty ty' continue xs -> match xs with | [] -> (continue [@ocaml.tailcall]) accu | (k, v) :: xs -> - (aux [@ocaml.tailcall]) accu kty k (fun accu -> - (aux [@ocaml.tailcall]) accu ty' v (fun accu -> - (on_bindings [@ocaml.tailcall]) accu kty ty' continue xs)) - in - aux init ty x (fun accu -> accu) - [@@coq_axiom_with_reason "local mutually recursive definition not handled"] + (aux [@ocaml.tailcall]) f accu kty k (fun accu -> + (aux [@ocaml.tailcall]) f accu ty' v (fun accu -> + (on_bindings [@ocaml.tailcall]) f accu kty ty' continue xs)) +end + +let value_traverse (type t tc) (ty : (t, tc) ty) (x : t) init f = + Value_traverse.aux f init ty x (fun accu -> accu) -let stack_top_ty : type a b s. (a, b * s) stack_ty -> a ty_ex_c = function +let stack_top_ty : type a b s. (a, b * s) stack_ty -> a ty_ex_c = + function[@coq_match_with_default] | Item_t (ty, _) -> Ty_ex_c ty diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 5d1bb7692169eb02b2ef7462d21e12d28d842eb6..ece8c036e0059d2793f762c6510f4d7416f4df16 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -174,7 +174,7 @@ type empty_cell = EmptyCell type end_of_stack = empty_cell * empty_cell module Type_size : sig - type 'a t + type 'a t [@@coq_phantom] val check_eq : error_details:('error_context, 'error_trace) Script_tc_errors.error_details -> @@ -254,6 +254,8 @@ module type Boxed_map = sig val boxed : value OPS.t val size : int + + val boxed_map_tag : unit end (** [map] is made algebraic in order to distinguish it from the other type @@ -322,6 +324,7 @@ type ('arg, 'storage) script = code_size : Cache_memory_helpers.sint; } -> ('arg, 'storage) script +[@@coq_force_gadt] (* ---- Instructions --------------------------------------------------------*) @@ -1147,6 +1150,7 @@ and 'arg typed_contract = address : address; } -> 'arg typed_contract +[@@coq_force_gadt] (* @@ -1377,6 +1381,7 @@ and ('ty, 'comparable) ty = | Ticket_t : 'a comparable_ty * 'a ticket ty_metadata -> ('a ticket, no) ty | Chest_key_t : (Script_timelock.chest_key, no) ty | Chest_t : (Script_timelock.chest, no) ty +[@@coq_force_gadt] and 'ty comparable_ty = ('ty, yes) ty @@ -1394,6 +1399,7 @@ and ('key, 'value) big_map = value_type : ('value, _) ty; } -> ('key, 'value) big_map +[@@coq_force_gadt] and ('a, 's, 'r, 'f) kdescr = { kloc : Script.location; @@ -1493,6 +1499,7 @@ and ('input, 'output) view_signature = output_ty : ('output, _) ty; } -> ('input, 'output) view_signature +[@@coq_force_gadt] and 'kind manager_operation = | Transaction_to_contract : { @@ -1562,7 +1569,8 @@ val ty_size : ('a, _) ty -> 'a Type_size.t val is_comparable : ('v, 'c) ty -> 'c dbool -type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c [@@ocaml.unboxed] +type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c +[@@ocaml.unboxed] [@@coq_force_gadt] val unit_t : unit comparable_ty diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index 0ae56ce6e9f39b1bbdb25b0744b0a84cdba7e7a5..04cefa4509c20fbce8ac502eff7e3d4e21f37dac 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -204,7 +204,7 @@ let kinfo_size {iloc = _; kstack_ty = _} = h2w tail-recursive and the only recursive call that is not a tailcall cannot be nested. (See [big_map_size].) For this reason, these functions should not trigger stack overflows. *) -let rec value_size : +let[@coq_struct "ty_value"] rec value_size_aux : type a ac. count_lambda_nodes:bool -> nodes_and_size -> @@ -214,65 +214,79 @@ let rec value_size : fun ~count_lambda_nodes accu ty x -> let apply : type a ac. nodes_and_size -> (a, ac) ty -> a -> nodes_and_size = fun accu ty x -> - match ty with - | Unit_t -> ret_succ accu - | Int_t -> ret_succ_adding accu (script_int_size x) - | Nat_t -> ret_succ_adding accu (script_nat_size x) - | Signature_t -> ret_succ_adding accu signature_size - | String_t -> ret_succ_adding accu (script_string_size x) - | Bytes_t -> ret_succ_adding accu (bytes_size x) - | Mutez_t -> ret_succ_adding accu mutez_size - | Key_hash_t -> ret_succ_adding accu (key_hash_size x) - | Key_t -> ret_succ_adding accu (public_key_size x) - | Timestamp_t -> ret_succ_adding accu (timestamp_size x) - | Address_t -> ret_succ_adding accu (address_size x) - | Tx_rollup_l2_address_t -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, x) with + | Unit_t, _ -> ret_succ accu + | Int_t, (x : _ Script_int.num) -> ret_succ_adding accu (script_int_size x) + | Nat_t, (x : _ Script_int.num) -> ret_succ_adding accu (script_nat_size x) + | Signature_t, _ -> ret_succ_adding accu signature_size + | String_t, (x : Script_string.t) -> + ret_succ_adding accu (script_string_size x) + | Bytes_t, (x : bytes) -> ret_succ_adding accu (bytes_size x) + | Mutez_t, _ -> ret_succ_adding accu mutez_size + | Key_hash_t, (x : public_key_hash) -> + ret_succ_adding accu (key_hash_size x) + | Key_t, (x : public_key) -> ret_succ_adding accu (public_key_size x) + | Timestamp_t, (x : Script_timestamp.t) -> + ret_succ_adding accu (timestamp_size x) + | Address_t, (x : address) -> ret_succ_adding accu (address_size x) + | Tx_rollup_l2_address_t, (x : tx_rollup_l2_address) -> ret_succ_adding accu (tx_rollup_l2_address_size x) - | Bool_t -> ret_succ accu - | Pair_t (_, _, _, _) -> ret_succ_adding accu h2w - | Union_t (_, _, _, _) -> ret_succ_adding accu h1w - | Lambda_t (_, _, _) -> - (lambda_size [@ocaml.tailcall]) ~count_lambda_nodes (ret_succ accu) x - | Option_t (_, _, _) -> ret_succ_adding accu (option_size (fun _ -> !!0) x) - | List_t (_, _) -> ret_succ_adding accu (h2w +! (h2w *? x.length)) - | Set_t (_, _) -> - let module M = (val Script_set.get x) in + | Bool_t, _ -> ret_succ accu + | Pair_t (_, _, _, _), _ -> ret_succ_adding accu h2w + | Union_t (_, _, _, _), _ -> ret_succ_adding accu h1w + | Lambda_t (_, _, _), (x : _ lambda) -> + (lambda_size_aux [@ocaml.tailcall]) + ~count_lambda_nodes + (ret_succ accu) + x + | Option_t (_, _, _), (x : _ option) -> + ret_succ_adding accu (option_size (fun _ -> !!0) x) + | List_t (_, _), (x : _ boxed_list) -> + ret_succ_adding accu (h2w +! (h2w *? x.length)) + | Set_t (_, _), (x : _ set) -> + let set = Script_set.get x in + let module M = (val set) in let boxing_space = !!536 (* By Obj.reachable_words. *) in ret_succ_adding accu (boxing_space +! (h4w *? M.size)) - | Map_t (_, _, _) -> - let module M = (val Script_map.get_module x) in + | Map_t (_, _, _), (x : _ map) -> + let map = Script_map.get_module x in + let module M = (val map) in let boxing_space = !!696 (* By Obj.reachable_words. *) in ret_succ_adding accu (boxing_space +! (h5w *? M.size)) - | Big_map_t (cty, ty', _) -> - (big_map_size [@ocaml.tailcall]) + | Big_map_t (cty, ty', _), (x : _ big_map) -> + (big_map_size_aux [@ocaml.tailcall]) ~count_lambda_nodes (ret_succ accu) cty ty' x - | Contract_t (_, _) -> ret_succ (accu ++ contract_size x) - | Sapling_transaction_t _ -> + | Contract_t (_, _), (x : _ typed_contract) -> + ret_succ (accu ++ contract_size x) + | Sapling_transaction_t _, (x : Sapling.transaction) -> ret_succ_adding accu (Sapling.transaction_in_memory_size x) - | Sapling_transaction_deprecated_t _ -> + | Sapling_transaction_deprecated_t _, (x : Sapling_repr.legacy_transaction) + -> ret_succ_adding accu (Sapling.Legacy.transaction_in_memory_size x) - | Sapling_state_t _ -> ret_succ_adding accu (sapling_state_size x) + | Sapling_state_t _, (x : Sapling.state) -> + ret_succ_adding accu (sapling_state_size x) (* Operations are neither storable nor pushable, so they can appear neither in the storage nor in the script. Hence they cannot appear in the cache and we never need to measure their size. *) - | Operation_t -> assert false - | Chain_id_t -> ret_succ_adding accu chain_id_size - | Never_t -> ( match x with _ -> .) - | Bls12_381_g1_t -> ret_succ_adding accu !!Bls12_381.G1.size_in_memory - | Bls12_381_g2_t -> ret_succ_adding accu !!Bls12_381.G2.size_in_memory - | Bls12_381_fr_t -> ret_succ_adding accu !!Bls12_381.Fr.size_in_memory - | Ticket_t (_, _) -> ret_succ_adding accu (ticket_size x) - | Chest_key_t -> ret_succ_adding accu (chest_key_size x) - | Chest_t -> ret_succ_adding accu (chest_size x) + | Operation_t, _ -> assert false + | Chain_id_t, _ -> ret_succ_adding accu chain_id_size + | Never_t, _ -> . + | Bls12_381_g1_t, _ -> ret_succ_adding accu !!Bls12_381.G1.size_in_memory + | Bls12_381_g2_t, _ -> ret_succ_adding accu !!Bls12_381.G2.size_in_memory + | Bls12_381_fr_t, _ -> ret_succ_adding accu !!Bls12_381.Fr.size_in_memory + | Ticket_t (_, _), (x : _ ticket) -> ret_succ_adding accu (ticket_size x) + | Chest_key_t, (x : Script_timelock.chest_key) -> + ret_succ_adding accu (chest_key_size x) + | Chest_t, (x : Script_timelock.chest) -> + ret_succ_adding accu (chest_size x) in value_traverse ty x accu {apply} - [@@coq_axiom_with_reason "unreachable expressions '.' not handled for now"] -and big_map_size : +and[@coq_mutual_as_notation] big_map_size_aux : type a b bc. count_lambda_nodes:bool -> nodes_and_size -> @@ -292,12 +306,16 @@ and big_map_size : (* The following recursive call cannot introduce a stack overflow because this would require a key of type big_map while big_map is not comparable. *) - let accu = value_size ~count_lambda_nodes accu cty key in + let accu = value_size_aux ~count_lambda_nodes accu cty key in match value with | None -> accu | Some value -> let accu = ret_succ_adding accu h1w in - (value_size [@ocaml.tailcall]) ~count_lambda_nodes accu ty' value) + (value_size_aux [@ocaml.tailcall]) + ~count_lambda_nodes + accu + ty' + value) diff.map accu in @@ -309,7 +327,7 @@ and big_map_size : (ty_size key_type ++ ty_size value_type ++ diff_size) (h4w +! id_size) -and lambda_size : +and[@coq_struct "function_parameter"] lambda_size_aux : type i o. count_lambda_nodes:bool -> nodes_and_size -> (i, o) lambda -> nodes_and_size = @@ -319,9 +337,9 @@ and lambda_size : let accu = ret_adding (accu ++ if count_lambda_nodes then node_size node else zero) h2w in - (kdescr_size [@ocaml.tailcall]) ~count_lambda_nodes:false accu kdescr + (kdescr_size_aux [@ocaml.tailcall]) ~count_lambda_nodes:false accu kdescr -and kdescr_size : +and[@coq_mutual_as_notation] kdescr_size_aux : type a s r f. count_lambda_nodes:bool -> nodes_and_size -> @@ -331,9 +349,9 @@ and kdescr_size : let accu = ret_adding (accu ++ stack_ty_size kbef ++ stack_ty_size kaft) h4w in - (kinstr_size [@ocaml.tailcall]) ~count_lambda_nodes accu kinstr + (kinstr_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu kinstr -and kinstr_size : +and[@coq_struct "t_value"] kinstr_size_aux : type a s r f. count_lambda_nodes:bool -> nodes_and_size -> @@ -351,7 +369,7 @@ and kinstr_size : | IConst (kinfo, x, k) -> let accu = ret_succ_adding accu (base kinfo +! word_size) in let (Ty_ex_c top_ty) = stack_top_ty (kinfo_of_kinstr k).kstack_ty in - (value_size [@ocaml.tailcall]) ~count_lambda_nodes accu top_ty x + (value_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu top_ty x | ICons_pair (kinfo, _) -> ret_succ_adding accu (base kinfo) | ICar (kinfo, _) -> ret_succ_adding accu (base kinfo) | ICdr (kinfo, _) -> ret_succ_adding accu (base kinfo) @@ -442,7 +460,7 @@ and kinstr_size : ret_succ_adding (accu ++ ty_size ty) (base kinfo +! word_size) | ILambda (kinfo, lambda, _) -> let accu = ret_succ_adding accu (base kinfo +! word_size) in - (lambda_size [@ocaml.tailcall]) ~count_lambda_nodes accu lambda + (lambda_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu lambda | IFailwith (kinfo, _, ty) -> ret_succ_adding (accu ++ ty_size ty) (base kinfo +! word_size) | ICompare (kinfo, cty, _) -> @@ -606,7 +624,7 @@ let lambda_size lam = *) let lambda_nodes, lambda_size = - lambda_size ~count_lambda_nodes:true zero lam + lambda_size_aux ~count_lambda_nodes:true zero lam in let lambda_extra_size_nodes, lambda_extra_size = lambda_extra_size lam in let size = (lambda_size *? 157 /? 100) +! (lambda_extra_size *? 18 /? 100) in @@ -615,12 +633,12 @@ let lambda_size lam = let kinstr_size kinstr = let kinstr_extra_size_nodes, kinstr_extra_size = kinstr_extra_size kinstr in let kinstr_nodes, kinstr_size = - kinstr_size ~count_lambda_nodes:true zero kinstr + kinstr_size_aux ~count_lambda_nodes:true zero kinstr in let size = (kinstr_size *? 157 /? 100) +! (kinstr_extra_size *? 18 /? 100) in (Nodes.add kinstr_nodes kinstr_extra_size_nodes, size) -let value_size ty x = value_size ~count_lambda_nodes:true zero ty x +let value_size ty x = value_size_aux ~count_lambda_nodes:true zero ty x module Internal_for_tests = struct let ty_size = ty_size diff --git a/src/proto_alpha/lib_protocol/seed_repr.ml b/src/proto_alpha/lib_protocol/seed_repr.ml index f3873d795502c2362431ce610b01000beb309cd1..9fc16a497e4e48104821e26087d04b6e0f6a2e50 100644 --- a/src/proto_alpha/lib_protocol/seed_repr.ml +++ b/src/proto_alpha/lib_protocol/seed_repr.ml @@ -78,7 +78,7 @@ let take_int32 s bound = let drop_if_over = Int32.sub Int32.max_int (Int32.rem Int32.max_int bound) in - let rec loop s = + let[@coq_struct "s_value"] rec loop s = let bytes, s = take s in let r = TzEndian.get_int32 bytes 0 in (* The absolute value of min_int is min_int. Also, every @@ -101,7 +101,7 @@ let take_int64 s bound = Int64.sub Int64.max_int (Int64.rem Int64.max_int bound) in - let rec loop s = + let[@coq_struct "s_value"] rec loop s = let bytes, s = take s in let r = TzEndian.get_int64 bytes 0 in (* The absolute value of min_int is min_int. Also, every @@ -153,7 +153,7 @@ let initial_nonce_hash_0 = hash initial_nonce_0 let deterministic_seed seed = nonce seed zero_bytes let initial_seeds ?initial_seed n = - let[@coq_struct "i"] rec loop acc elt i = + let[@coq_struct "i_value"] rec loop acc elt i = if Compare.Int.(i = 1) then List.rev (elt :: acc) else loop (elt :: acc) (deterministic_seed elt) (i - 1) in diff --git a/src/proto_alpha/lib_protocol/services_registration.ml b/src/proto_alpha/lib_protocol/services_registration.ml index de94c5dbdf6957cfcd9406cef2a9772469539436..4fa5d81a2d9c3d48c73ef29c1920b339d0788ef8 100644 --- a/src/proto_alpha/lib_protocol/services_registration.ml +++ b/src/proto_alpha/lib_protocol/services_registration.ml @@ -31,12 +31,14 @@ type rpc_context = { context : Alpha_context.t; } +type level = Head_level | Successor_level + let rpc_init ({block_hash; block_header; context} : Updater.rpc_context) mode = let timestamp = block_header.timestamp in let level = match mode with - | `Head_level -> block_header.level - | `Successor_level -> Int32.succ block_header.level + | Head_level -> block_header.level + | Successor_level -> Int32.succ block_header.level in Alpha_context.prepare ~level @@ -51,7 +53,7 @@ let rpc_services = let register0_fullctxt ~chunked s f = rpc_services := RPC_directory.register ~chunked !rpc_services s (fun ctxt q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let register0 ~chunked s f = register0_fullctxt ~chunked s (fun {context; _} -> f context) @@ -63,7 +65,7 @@ let register0_noctxt ~chunked s f = let register1_fullctxt ~chunked s f = rpc_services := RPC_directory.register ~chunked !rpc_services s (fun (ctxt, arg) q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i) let register1 ~chunked s f = register1_fullctxt ~chunked s (fun {context; _} x -> f context x) @@ -75,7 +77,7 @@ let register2_fullctxt ~chunked s f = !rpc_services s (fun ((ctxt, arg1), arg2) q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) let register2 ~chunked s f = register2_fullctxt ~chunked s (fun {context; _} a1 a2 q i -> @@ -84,7 +86,7 @@ let register2 ~chunked s f = let opt_register0_fullctxt ~chunked s f = rpc_services := RPC_directory.opt_register ~chunked !rpc_services s (fun ctxt q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let opt_register0 ~chunked s f = opt_register0_fullctxt ~chunked s (fun {context; _} -> f context) @@ -92,7 +94,7 @@ let opt_register0 ~chunked s f = let opt_register1_fullctxt ~chunked s f = rpc_services := RPC_directory.opt_register ~chunked !rpc_services s (fun (ctxt, arg) q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i) let opt_register1 ~chunked s f = opt_register1_fullctxt ~chunked s (fun {context; _} x -> f context x) @@ -104,7 +106,7 @@ let opt_register2_fullctxt ~chunked s f = !rpc_services s (fun ((ctxt, arg1), arg2) q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) let opt_register2 ~chunked s f = opt_register2_fullctxt ~chunked s (fun {context; _} a1 a2 q i -> @@ -114,7 +116,7 @@ let get_rpc_services () = let p = RPC_directory.map (fun c -> - rpc_init c `Head_level >|= function + rpc_init c Head_level >|= function | Error t -> raise (Failure (Format.asprintf "%a" Error_monad.pp_trace t)) | Ok c -> c.context) diff --git a/src/proto_alpha/lib_protocol/services_registration.mli b/src/proto_alpha/lib_protocol/services_registration.mli index c6bc2ed72c92adc5cc2cb09a26e0b467a831aa1d..da7faca5500a26c5d9c72060d7f8429943f6c2cf 100644 --- a/src/proto_alpha/lib_protocol/services_registration.mli +++ b/src/proto_alpha/lib_protocol/services_registration.mli @@ -44,6 +44,8 @@ type rpc_context = { context : t; } +type level = Head_level | Successor_level + (** [rpc_init rpc_context mode] allows to instantiate an [rpc_context] using the [Alpha_context] representation from a raw context representation (the one the shell knows). @@ -60,9 +62,7 @@ type rpc_context = { paths depend on the level. Using the successor level allows to ensure that the simulation is done on a fresh level. *) val rpc_init : - Updater.rpc_context -> - [`Head_level | `Successor_level] -> - rpc_context Error_monad.tzresult Lwt.t + Updater.rpc_context -> level -> rpc_context Error_monad.tzresult Lwt.t val register0 : chunked:bool -> diff --git a/src/proto_alpha/lib_protocol/skip_list_repr.ml b/src/proto_alpha/lib_protocol/skip_list_repr.ml index 56f0d73cc4f452b0fcf46db9f18f331be2dc1276..37b76c499e0d0419bd14f1db2e1e848b78d9f103 100644 --- a/src/proto_alpha/lib_protocol/skip_list_repr.ml +++ b/src/proto_alpha/lib_protocol/skip_list_repr.ml @@ -38,7 +38,7 @@ module type S = sig 'content Data_encoding.t -> ('content, 'ptr) cell Data_encoding.t - val index : (_, _) cell -> int + val index : ('content, 'ptr) cell -> int val content : ('content, 'ptr) cell -> 'content @@ -69,9 +69,11 @@ module type S = sig bool end -module Make (Parameters : sig +module type S_Parameters = sig val basis : int -end) : S = struct +end + +module Make (Parameters : S_Parameters) : S = struct let () = assert (Compare.Int.(Parameters.basis >= 2)) open Parameters @@ -170,7 +172,7 @@ end) : S = struct let next ~prev_cell ~prev_cell_ptr content = let index = prev_cell.index + 1 in let back_pointers = - let rec aux power accu i = + let[@coq_struct "power"] rec aux power accu i = if Compare.Int.(index < power) then List.rev accu else let back_pointer_i = @@ -194,7 +196,7 @@ end) : S = struct let best_skip cell target_index = let index = cell.index in - let rec aux idx pow best_idx best_skip = + let[@coq_struct "idx"] rec aux idx pow best_idx best_skip = if Compare.Int.(idx >= FallbackArray.length cell.back_pointers) then best_idx else @@ -209,7 +211,7 @@ end) : S = struct aux 0 1 None None let back_path ~deref ~cell_ptr ~target_index = - let rec aux path ptr = + let[@coq_struct "ptr"] rec aux path ptr = let path = ptr :: path in Option.bind (deref ptr) @@ fun cell -> let index = cell.index in @@ -224,7 +226,7 @@ end) : S = struct let mem equal x l = let open FallbackArray in let n = length l in - let rec aux idx = + let[@coq_struct "idx"] rec aux idx = if Compare.Int.(idx >= n) then false else match FallbackArray.get l idx with @@ -239,7 +241,7 @@ end) : S = struct assume_some (deref target_ptr) @@ fun target -> assume_some (deref cell_ptr) @@ fun cell -> let target_index = index target and cell_index = index cell in - let rec valid_path index cell_ptr path = + let[@coq_struct "path"] rec valid_path index cell_ptr path = match (cell_ptr, path) with | final_cell, [] -> equal_ptr target_ptr final_cell && Compare.Int.(index = target_index) diff --git a/src/proto_alpha/lib_protocol/skip_list_repr.mli b/src/proto_alpha/lib_protocol/skip_list_repr.mli index 843003e18a151fd318ad5b23e4ad2bfcbe10ac07..88c52825bd5ef0b2fe8db2273ec1f115c42aba8e 100644 --- a/src/proto_alpha/lib_protocol/skip_list_repr.mli +++ b/src/proto_alpha/lib_protocol/skip_list_repr.mli @@ -112,6 +112,8 @@ module type S = sig bool end -module Make (_ : sig +module type S_Parameters = sig val basis : int -end) : S +end + +module Make (_ : S_Parameters) : S diff --git a/src/proto_alpha/lib_protocol/slot_repr.ml b/src/proto_alpha/lib_protocol/slot_repr.ml index 4cb7219bfedc206efcfaa00496e19e5a66369a29..338df1a6d3e22f50406327e722e7459b295e2c1b 100644 --- a/src/proto_alpha/lib_protocol/slot_repr.ml +++ b/src/proto_alpha/lib_protocol/slot_repr.ml @@ -84,21 +84,21 @@ module Range = struct ok (Interval {lo = min; hi = max}) let fold f init (Interval {lo; hi}) = - let rec loop ~acc ~next = + let[@coq_struct "next"] rec loop ~acc ~next = if Compare.Int.(next > hi) then acc else loop ~acc:(f acc next) ~next:(next + 1) in loop ~acc:(f init lo) ~next:(lo + 1) let fold_es f init (Interval {lo; hi}) = - let rec loop ~acc ~next = + let[@coq_struct "next"] rec loop ~acc ~next = if Compare.Int.(next > hi) then return acc else f acc next >>=? fun acc -> loop ~acc ~next:(next + 1) in f init lo >>=? fun acc -> loop ~acc ~next:(lo + 1) let rev_fold_es f init (Interval {lo; hi}) = - let rec loop ~acc ~next = + let[@coq_struct "next"] rec loop ~acc ~next = if Compare.Int.(next < lo) then return acc else f acc next >>=? fun acc -> loop ~acc ~next:(next - 1) in diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index f5f916ec2278e8c48213a5fd88676dfe9996293e..3e586ee145e89db5c96eb414bdeebf6ecc7edf65 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -93,7 +93,7 @@ module type Simple_single_data_storage = sig end module Block_round : Simple_single_data_storage with type value = Round_repr.t = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["block_round"] end) @@ -101,7 +101,7 @@ module Block_round : Simple_single_data_storage with type value = Round_repr.t = module Tenderbake = struct module First_level_of_protocol = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["first_level_of_protocol"] end) @@ -118,14 +118,14 @@ module Tenderbake = struct end module Endorsement_branch = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["endorsement_branch"] end) (Branch) module Grand_parent_branch = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["grand_parent_branch"] end) @@ -164,7 +164,7 @@ end module Contract = struct module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["contracts"] end) @@ -390,7 +390,7 @@ module Global_constants = struct and type key = Script_expr_hash.t and type value = Script_repr.expr = Make_indexed_carbonated_data_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["global_constant"] end)) @@ -408,7 +408,7 @@ module Big_map = struct type id = Lazy_storage_kind.Big_map.Id.t module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["big_maps"] end) @@ -543,7 +543,7 @@ module Sapling = struct type id = Lazy_storage_kind.Sapling_state.Id.t module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["sapling"] end) @@ -899,7 +899,7 @@ end module Delegates = Make_data_set_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["delegates"] end)) @@ -925,7 +925,7 @@ end module Cycle = struct module Indexed_context = Make_indexed_subcontext - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["cycle"] end)) @@ -1040,7 +1040,7 @@ module Slashed_deposits = Cycle.Slashed_deposits module Stake = struct module Staking_balance = Make_indexed_data_snapshotable_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["staking_balance"] end)) @@ -1050,7 +1050,7 @@ module Stake = struct module Active_delegate_with_one_roll = Make_indexed_data_snapshotable_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["active_delegate_with_one_roll"] end)) @@ -1081,7 +1081,7 @@ module Stake = struct The ratio [blocks_per_cycle / blocks_per_stake_snapshot] above is checked in {!val:Constants_repr.check_constants} to fit in a UInt16. *) module Last_snapshot = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["last_snapshot"] end) @@ -1095,7 +1095,7 @@ module Delegate_sampler_state = Cycle.Delegate_sampler_state module Vote = struct module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["votes"] end) @@ -1254,7 +1254,7 @@ end module Commitments = Make_indexed_data_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["commitments"] end)) @@ -1272,7 +1272,7 @@ module Ramp_up = struct module Rewards = Make_indexed_data_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["ramp_up"; "rewards"] end)) @@ -1308,7 +1308,7 @@ end module Pending_migration = struct module Balance_updates = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["pending_migration_balance_updates"] end) @@ -1319,7 +1319,7 @@ module Pending_migration = struct end) module Operation_results = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["pending_migration_operation_results"] end) @@ -1354,7 +1354,7 @@ end module Liquidity_baking = struct module Toggle_ema = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct (* The old "escape" name is kept here to avoid migrating this. *) let name = ["liquidity_baking_escape_ema"] @@ -1362,7 +1362,7 @@ module Liquidity_baking = struct (Encoding.Int32) module Cpmm_address = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["liquidity_baking_cpmm_address"] end) @@ -1379,7 +1379,7 @@ module Ticket_balance = struct let name = ["ticket_balance"] end - module Raw_context = Make_subcontext (Registered) (Raw_context) (Name) + module Raw_context = Make_subcontext (Registered) (Raw_context.M) (Name) module Paid_storage_space = Make_single_data_storage (Registered) (Raw_context) @@ -1402,14 +1402,19 @@ module Ticket_balance = struct end) module Index = Make_index (Ticket_hash_repr.Index) - module Table = + + module Table : + Non_iterable_indexed_carbonated_data_storage + with type t := Raw_context.t + and type key = Ticket_hash_repr.t + and type value = Z.t = Make_indexed_carbonated_data_storage (Table_context) (Index) (Encoding.Z) end module Tx_rollup = struct module Indexed_context = Make_indexed_subcontext - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["tx_rollup"] end)) @@ -1477,7 +1482,7 @@ end module Sc_rollup = struct module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["sc_rollup"] end) @@ -1490,15 +1495,52 @@ module Sc_rollup = struct end)) (Make_index (Sc_rollup_repr.Index)) - module Make_versioned (Versioned_value : sig - val name : string + module type Make_versioned_sig = sig + include Sc_rollup_data_version_sig.S module Index : Storage_description.INDEX - include Sc_rollup_data_version_sig.S - end) = - struct - include + val name : string + end + + (* + module type Make_versioned_out = sig + type t + + type context + + type key + + val mem : context -> key -> (Indexed_context.t * bool) tzresult Lwt.t + + val remove_existing : context -> key -> (Indexed_context.t * int) tzresult Lwt.t + + val remove : context -> key -> (Indexed_context.t * int * bool) tzresult Lwt.t + + type value + + val get : context -> key -> (Indexed_context.t * value, error trace) result Lwt.t + + val find : context -> + key -> (Indexed_context.t * value option, error trace) result Lwt.t + + val update : context -> key -> value -> (Indexed_context.t * int) tzresult Lwt.t + + val init : context -> key -> value -> (Indexed_context.t * int) tzresult Lwt.t + + val add : context -> key -> value -> (Indexed_context.t * int * bool) tzresult Lwt.t + + val add_or_remove : context -> + key -> value option -> (Indexed_context.t * int * bool) tzresult Lwt.t + end + *) + + module Make_versioned (Versioned_value : Make_versioned_sig) : + Non_iterable_indexed_carbonated_data_storage + with type key = Versioned_value.Index.t + and type value = Versioned_value.t + and type t = Raw_context.t * Sc_rollup_repr.t = struct + module M = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1511,27 +1553,40 @@ module Sc_rollup = struct let encoding = Versioned_value.versioned_encoding end) + type t = M.t + + type context = M.context + + type key = M.key + + let mem = M.mem + + let remove_existing = M.remove_existing + + let remove = M.remove + type value = Versioned_value.t let get ctxt key = let open Lwt_result_syntax in - let* ctxt, versioned = get ctxt key in + let* ctxt, versioned = M.get ctxt key in return (ctxt, Versioned_value.of_versioned versioned) let find ctxt key = let open Lwt_result_syntax in - let* ctxt, versioned = find ctxt key in + let* ctxt, versioned = M.find ctxt key in return (ctxt, Option.map Versioned_value.of_versioned versioned) let update ctxt key value = - update ctxt key (Versioned_value.to_versioned value) + M.update ctxt key (Versioned_value.to_versioned value) - let init ctxt key value = init ctxt key (Versioned_value.to_versioned value) + let init ctxt key value = + M.init ctxt key (Versioned_value.to_versioned value) - let add ctxt key value = add ctxt key (Versioned_value.to_versioned value) + let add ctxt key value = M.add ctxt key (Versioned_value.to_versioned value) let add_or_remove ctxt key value = - add_or_remove ctxt key (Option.map Versioned_value.to_versioned value) + M.add_or_remove ctxt key (Option.map Versioned_value.to_versioned value) end module PVM_kind = @@ -1600,7 +1655,11 @@ module Sc_rollup = struct let encoding = Sc_rollup_commitment_repr.Hash.encoding end) - module Stakers = + module Stakers : + Non_iterable_indexed_carbonated_data_storage + with type key = Signature.Public_key_hash.t + and type value = Sc_rollup_commitment_repr.Hash.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1625,13 +1684,22 @@ module Sc_rollup = struct end) module Commitments = Make_versioned (struct - include Sc_rollup_commitment_repr - module Index = Hash + include ( + Sc_rollup_commitment_repr : + Sc_rollup_data_version_sig.S with type t = Sc_rollup_commitment_repr.t) + + module Index : + Storage_description.INDEX with type t = Sc_rollup_commitment_repr.Hash.t = + Sc_rollup_commitment_repr.Hash let name = "commitments" end) - module Commitment_stake_count = + module Commitment_stake_count : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_commitment_repr.Hash.t + and type value = int32 + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1644,7 +1712,11 @@ module Sc_rollup = struct let encoding = Data_encoding.int32 end) - module Commitment_added = + module Commitment_added : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_commitment_repr.Hash.t + and type value = Raw_level_repr.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1657,7 +1729,11 @@ module Sc_rollup = struct let encoding = Raw_level_repr.encoding end) - module Game = + module Game : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_game_repr.Index.t + and type value = Sc_rollup_game_repr.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1670,7 +1746,11 @@ module Sc_rollup = struct let encoding = Sc_rollup_game_repr.encoding end) - module Game_timeout = + module Game_timeout : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_game_repr.Index.t + and type value = Raw_level_repr.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1683,7 +1763,11 @@ module Sc_rollup = struct let encoding = Raw_level_repr.encoding end) - module Opponent = + module Opponent : + Non_iterable_indexed_carbonated_data_storage + with type key = Signature.Public_key_hash.t + and type value = Sc_rollup_repr.Staker.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1777,7 +1861,11 @@ module Dal = struct This is only for prototyping. Probably something smarter would be to index each header directly. *) - module Slot_headers = + module Slot_headers : + Non_iterable_indexed_data_storage + with type t = Raw_context.t + and type key = Raw_level_repr.t + and type value = Dal_slot_repr.slot list = Level_context.Make_map (struct let name = ["slots"] diff --git a/src/proto_alpha/lib_protocol/storage_description.ml b/src/proto_alpha/lib_protocol/storage_description.ml index 86aed867ac16187268cf940550636bb291a6f689..6e28de43fdeb88c10ed594dbfe5da8362c4eab1a 100644 --- a/src/proto_alpha/lib_protocol/storage_description.ml +++ b/src/proto_alpha/lib_protocol/storage_description.ml @@ -124,26 +124,28 @@ type (_, _, _) args = ('key, 'a, 'inter_key) args * ('inter_key, 'b, 'sub_key) args -> ('key, 'a * 'b, 'sub_key) args -let rec unpack : type a b c. (a, b, c) args -> c -> a * b = function +let[@coq_struct "function_parameter"] rec unpack : + type a b c. (a, b, c) args -> c -> a * b = + function[@coq_match_gadt_with_result] | One _ -> fun x -> x | Pair (l, r) -> - let unpack_l = unpack l in - let unpack_r = unpack r in + let unpack_l = (unpack [@coq_type_annotation]) l in + let unpack_r = (unpack [@coq_type_annotation]) r in fun x -> let c, d = unpack_r x in let b, a = unpack_l c in (b, (a, d)) - [@@coq_axiom_with_reason "gadt"] -let rec pack : type a b c. (a, b, c) args -> a -> b -> c = function +let[@coq_struct "function_parameter"] rec pack : + type a b c. (a, b, c) args -> a -> b -> c = + function[@coq_match_gadt_with_result] | One _ -> fun b a -> (b, a) | Pair (l, r) -> - let pack_l = pack l in - let pack_r = pack r in + let pack_l = (pack [@coq_type_annotation]) l in + let pack_r = (pack [@coq_type_annotation]) r in fun b (a, d) -> let c = pack_l b a in pack_r c d - [@@coq_axiom_with_reason "gadt"] let rec compare : type a b c. (a, b, c) args -> b -> b -> int = function | One {compare; _} -> compare diff --git a/src/proto_alpha/lib_protocol/storage_functors.ml b/src/proto_alpha/lib_protocol/storage_functors.ml index d32d3f00c45626102bd9c53593d79b5911708f3f..c0deb0c3fa4a9972520800c86104769b6319cdb3 100644 --- a/src/proto_alpha/lib_protocol/storage_functors.ml +++ b/src/proto_alpha/lib_protocol/storage_functors.ml @@ -115,7 +115,6 @@ module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) : let config t = C.config t module Tree = C.Tree - module Proof = C.Proof let verify_tree_proof = C.verify_tree_proof @@ -249,7 +248,9 @@ module Make_data_set_storage (C : Raw_context.T) (I : INDEX) : C.fold ~depth:(`Eq I.path_length) s [] ~order ~init ~f:(fun file tree acc -> match C.Tree.kind tree with | `Value -> ( - match I.of_path file with None -> assert false | Some p -> f p acc) + match I.of_path file with + | None -> Lwt.return acc + | Some p -> f p acc) | `Tree -> Lwt.return acc) let elements s = @@ -321,7 +322,7 @@ struct C.Tree.to_value tree >>= function | Some v -> ( match I.of_path file with - | None -> assert false + | None -> Lwt.return acc | Some path -> ( let key () = C.absolute_key s file in match of_bytes ~key v with @@ -497,7 +498,7 @@ module Make_indexed_carbonated_data_storage_INTERNAL else (* Nominal case *) match I.of_path file with - | None -> assert false + | None -> Lwt.return acc | Some key -> get_unprojected s key >|=? fun (s, value) -> (s, value :: rev_values, 0, pred length)) @@ -520,9 +521,9 @@ module Make_indexed_carbonated_data_storage_INTERNAL | last :: rest when Compare.String.(last = data_name) -> ( let file = List.rev rest in match I.of_path file with - | None -> assert false + | None -> Lwt.return acc | Some path -> f path acc) - | _ -> assert false) + | _ -> Lwt.return acc) | `Tree -> Lwt.return acc) let keys_unaccounted s = @@ -642,7 +643,7 @@ module Make_indexed_data_snapshotable_storage C.Tree.to_value tree >>= function | Some v -> ( match I.of_path file with - | None -> assert false + | None -> return acc | Some path -> ( let key () = C.absolute_key s file in match V_encoder.of_bytes ~key v with @@ -674,7 +675,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : match C.Tree.kind tree with | `Tree -> ( match I.of_path path with - | None -> assert false + | None -> Lwt.return acc | Some path -> f path acc) | `Value -> Lwt.return acc) @@ -795,8 +796,6 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : C.Tree.empty t end - module Proof = C.Proof - let verify_tree_proof = C.verify_tree_proof let verify_stream_proof = C.verify_stream_proof diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_combined_operations.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_combined_operations.ml index 71baae6762925c9837172e59b99180efd6b0470d..b639f43bd039a183613e419dba0854b376ff8073 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_combined_operations.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_combined_operations.ml @@ -118,7 +118,8 @@ let test_multiple_origination_and_delegation () = (fun acc -> function | No_operation_metadata -> assert false | Operation_metadata {contents} -> - to_list (Contents_result_list contents) @ acc) + packed_contents_result_list_to_list (Contents_result_list contents) + @ acc) [] tickets |> List.rev @@ -186,7 +187,8 @@ let test_failing_operation_in_the_middle () = (fun acc -> function | No_operation_metadata -> assert false | Operation_metadata {contents} -> - to_list (Contents_result_list contents) @ acc) + packed_contents_result_list_to_list (Contents_result_list contents) + @ acc) [] tickets in @@ -231,7 +233,8 @@ let test_failing_operation_in_the_middle_with_fees () = (fun acc -> function | No_operation_metadata -> assert false | Operation_metadata {contents} -> - to_list (Contents_result_list contents) @ acc) + packed_contents_result_list_to_list (Contents_result_list contents) + @ acc) [] tickets in diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml index dda98827132d5d881630fdceebf7f98ca8402338..f5a18227126235f5cb6a52e539032f239a180e77 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml @@ -2915,7 +2915,7 @@ module Rejection = struct Tx_rollup_message_result_hash.hash_uncarbonated previous_message_result; expected = - `Hash + Hash (Tx_rollup_message_result_hash.of_b58check_exn "txmr344vtdPzvWsfnoSd3mJ3MCFA5ehKLQs1pK9WGcX4FEACg1rVgC"); })) @@ -4554,7 +4554,7 @@ module Withdraw = struct ~expect_apply_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, 0)} -> + {provided = _; expected = Valid_path (_, 0)} -> true | _ -> false) incr @@ -4575,7 +4575,7 @@ module Withdraw = struct ~expect_apply_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, 0)} -> + {provided = _; expected = Valid_path (_, 0)} -> true | _ -> false) incr @@ -4617,7 +4617,7 @@ module Withdraw = struct ~expect_apply_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, 0)} -> + {provided = _; expected = Valid_path (_, 0)} -> true | _ -> false) incr @@ -4638,7 +4638,7 @@ module Withdraw = struct ~expect_apply_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, 0)} -> + {provided = _; expected = Valid_path (_, 0)} -> true | _ -> false) incr @@ -4925,7 +4925,7 @@ module Withdraw = struct ~expect_apply_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, idx)} -> + {provided = _; expected = Valid_path (_, idx)} -> Compare.Int.(idx = valid_message_index) | _ -> false) incr @@ -4946,7 +4946,7 @@ module Withdraw = struct ~expect_apply_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, idx)} -> + {provided = _; expected = Valid_path (_, idx)} -> Compare.Int.(idx = wrong_message_index) | _ -> false) incr @@ -4969,7 +4969,7 @@ module Withdraw = struct ~expect_apply_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, idx)} -> + {provided = _; expected = Valid_path (_, idx)} -> Compare.Int.(idx = wrong_message_index) | _ -> false) incr diff --git a/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml b/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml index 27f5394c700a2b0276a33e8f3782f8558e6e49d8..b2570761b32ec2e196ad0a2643575295a5e03001 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml @@ -76,19 +76,26 @@ let init_test ~user_is_delegate = create_context () >>=? fun (ctxt, _) -> let delegate, delegate_pk, _ = Signature.generate_key () in let delegate_contract = Contract.Implicit delegate in - let delegate_account = `Contract (Contract.Implicit delegate) in + let delegate_account = + Token.Sink_container (Contract (Contract.Implicit delegate)) + in let user_contract = if user_is_delegate then delegate_contract else let user, _, _ = Signature.generate_key () in Contract.Implicit user in - let user_account = `Contract user_contract in + let user_account = Token.Contract user_contract in (* Allocate contracts for user and delegate. *) let user_balance = big_random_amount () in - Token.transfer ctxt `Minted user_account user_balance >>>=? fun (ctxt, _) -> + Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container user_account) + user_balance + >>>=? fun (ctxt, _) -> let delegate_balance = big_random_amount () in - Token.transfer ctxt `Minted delegate_account delegate_balance + Token.transfer ctxt (Source_infinite Minted) delegate_account delegate_balance >>>=? fun (ctxt, _) -> (* Configure delegate, as a delegate by self-delegation, for which revealing its manager key is a prerequisite. *) @@ -118,8 +125,12 @@ let test_delegate_then_freeze_deposit () = let tx_rollup, _ = mk_tx_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = small_random_amount () in - let deposit_account = `Frozen_bonds (user_contract, bond_id) in - Token.transfer ctxt user_account deposit_account deposit_amount + let deposit_account = Token.Frozen_bonds (user_contract, bond_id) in + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance after freeze. *) Delegate.staking_balance ctxt delegate >>>=? fun staking_balance' -> @@ -136,7 +147,11 @@ let test_delegate_then_freeze_deposit () = (staking_balance' -! user_balance) >>=? fun () -> (* Unfreeze the deposit. *) - Token.transfer ctxt deposit_account user_account deposit_amount + Token.transfer + ctxt + (Source_container deposit_account) + (Sink_container user_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance of delegate. *) Delegate.staking_balance ctxt delegate >>>=? fun staking_balance''' -> @@ -166,8 +181,12 @@ let test_freeze_deposit_then_delegate () = let tx_rollup, _ = mk_tx_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = small_random_amount () in - let deposit_account = `Frozen_bonds (user_contract, bond_id) in - Token.transfer ctxt user_account deposit_account deposit_amount + let deposit_account = Token.Frozen_bonds (user_contract, bond_id) in + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Here, user balance has decreased. Now, fetch staking balance before delegation and after freeze. *) @@ -183,7 +202,11 @@ let test_freeze_deposit_then_delegate () = (user_balance +! staking_balance) >>=? fun () -> (* Unfreeze the deposit. *) - Token.transfer ctxt deposit_account user_account deposit_amount + Token.transfer + ctxt + (Source_container deposit_account) + (Sink_container user_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance after unfreeze. *) Delegate.staking_balance ctxt delegate >>>=? fun staking_balance'' -> @@ -220,8 +243,12 @@ let test_allocated_when_frozen_deposits_exists ~user_is_delegate () = let tx_rollup, _ = mk_tx_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = user_balance in - let deposit_account = `Frozen_bonds (user_contract, bond_id) in - Token.transfer ctxt user_account deposit_account deposit_amount + let deposit_account = Token.Frozen_bonds (user_contract, bond_id) in + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Check that user contract is still allocated, despite a null balance. *) Token.balance ctxt user_account >>>=? fun (ctxt, balance) -> @@ -231,7 +258,11 @@ let test_allocated_when_frozen_deposits_exists ~user_is_delegate () = Assert.equal_bool ~loc:__LOC__ (user_allocated && dep_allocated) true >>=? fun () -> (* Punish the user contract. *) - Token.transfer ctxt deposit_account `Burned deposit_amount + Token.transfer + ctxt + (Source_container deposit_account) + (Sink_infinite Burned) + deposit_amount >>>=? fun (ctxt, _) -> (* Check that user and deposit accounts have been unallocated. *) Token.allocated ctxt user_account >>>=? fun (ctxt, user_allocated) -> @@ -259,11 +290,19 @@ let test_total_stake ~user_is_delegate () = let tx_rollup, _ = mk_tx_rollup ~nonce () in let bond_id2 = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = small_random_amount () in - let deposit_account1 = `Frozen_bonds (user_contract, bond_id1) in - Token.transfer ctxt user_account deposit_account1 deposit_amount + let deposit_account1 = Token.Frozen_bonds (user_contract, bond_id1) in + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account1) + deposit_amount >>>=? fun (ctxt, _) -> - let deposit_account2 = `Frozen_bonds (user_contract, bond_id2) in - Token.transfer ctxt user_account deposit_account2 deposit_amount + let deposit_account2 = Token.Frozen_bonds (user_contract, bond_id2) in + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account2) + deposit_amount >>>=? fun (ctxt, _) -> (* Test folding on bond ids. *) Bond_id.Internal_for_tests.fold_on_bond_ids @@ -289,7 +328,11 @@ let test_total_stake ~user_is_delegate () = Assert.equal_tez ~loc:__LOC__ (stake -! balance) (deposit_amount *! 2L) >>=? fun () -> (* Punish for one deposit. *) - Token.transfer ctxt deposit_account2 `Burned deposit_amount + Token.transfer + ctxt + (Source_container deposit_account2) + (Sink_infinite Burned) + deposit_amount >>>=? fun (ctxt, _) -> (* Check that stake of contract is balance + deposit. *) Contract.get_balance_and_frozen_bonds ctxt user_contract >>>=? fun stake -> @@ -297,7 +340,11 @@ let test_total_stake ~user_is_delegate () = Assert.equal_tez ~loc:__LOC__ (stake -! balance) frozen_bonds >>=? fun () -> Assert.equal_tez ~loc:__LOC__ (stake -! balance) deposit_amount >>=? fun () -> (* Punish for the other deposit. *) - Token.transfer ctxt deposit_account1 `Burned deposit_amount + Token.transfer + ctxt + (Source_container deposit_account1) + (Sink_infinite Burned) + deposit_amount >>>=? fun (ctxt, _) -> (* Check that stake of contract is equal to balance. *) Contract.get_balance_and_frozen_bonds ctxt user_contract >>>=? fun stake -> @@ -322,9 +369,13 @@ let test_scenario scenario = >>=? fun (ctxt, user_contract, user_account, delegate1) -> let delegate2, delegate_pk2, _ = Signature.generate_key () in let delegate_contract2 = Contract.Implicit delegate2 in - let delegate_account2 = `Contract delegate_contract2 in + let delegate_account2 = Token.Contract delegate_contract2 in let delegate_balance2 = big_random_amount () in - Token.transfer ctxt `Minted delegate_account2 delegate_balance2 + Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container delegate_account2) + delegate_balance2 >>>=? fun (ctxt, _) -> (* Configure delegate, as a delegate by self-delegation, for which revealing its manager key is a prerequisite. *) @@ -335,8 +386,8 @@ let test_scenario scenario = let bond_id1 = Bond_id.Tx_rollup_bond_id tx_rollup1 in let bond_id2 = Bond_id.Tx_rollup_bond_id tx_rollup2 in let deposit_amount = Tez.of_mutez_exn 1000L in - let deposit_account1 = `Frozen_bonds (user_contract, bond_id1) in - let deposit_account2 = `Frozen_bonds (user_contract, bond_id2) in + let deposit_account1 = Token.Frozen_bonds (user_contract, bond_id1) in + let deposit_account2 = Token.Frozen_bonds (user_contract, bond_id2) in let do_delegate ?(delegate = delegate1) ctxt = (* Fetch staking balance before delegation *) Delegate.staking_balance ctxt delegate >>>=? fun staking_balance -> @@ -358,7 +409,11 @@ let test_scenario scenario = Delegate.staking_balance ctxt delegate1 >>>=? fun staking_balance1 -> Delegate.staking_balance ctxt delegate2 >>>=? fun staking_balance2 -> (* Freeze a tx-rollup deposit. *) - Token.transfer ctxt user_account deposit_account deposit_amount + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance after freeze. *) Delegate.staking_balance ctxt delegate1 >>>=? fun staking_balance1' -> @@ -374,7 +429,11 @@ let test_scenario scenario = Delegate.staking_balance ctxt delegate1 >>>=? fun staking_balance1 -> Delegate.staking_balance ctxt delegate2 >>>=? fun staking_balance2 -> (* Unfreeze the deposit *) - Token.transfer ctxt deposit_account user_account deposit_amount + Token.transfer + ctxt + (Source_container deposit_account) + (Sink_container user_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance after unfreeze. *) Delegate.staking_balance ctxt delegate1 >>>=? fun staking_balance1' -> @@ -395,8 +454,8 @@ let test_scenario scenario = (* Slash the deposit *) Token.transfer ctxt - deposit_account - `Tx_rollup_rejection_punishments + (Source_container deposit_account) + (Sink_infinite Tx_rollup_rejection_punishments) deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance after slash. *) diff --git a/src/proto_alpha/lib_protocol/test/integration/test_token.ml b/src/proto_alpha/lib_protocol/test/integration/test_token.ml index 4a05fb1a885e7d9e132c526f87c3b45bc7ec7193..d09043561e104cf5d3b5e7ce65a3ad3b96e387b1 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_token.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_token.ml @@ -60,11 +60,12 @@ let mk_rollup () = Tx_rollup.Internal_for_tests.originated_tx_rollup nonce let test_simple_balances () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> - let src = `Contract (Contract.Implicit pkh) in + let src = Token.Contract (Contract.Implicit pkh) in let pkh, _pk, _sk = Signature.generate_key () in - let dest = `Contract (Contract.Implicit pkh) in + let dest = Token.Contract (Contract.Implicit pkh) in let amount = Tez.one in - wrap (Token.transfer ctxt src dest amount) >>=? fun (ctxt', _) -> + wrap (Token.transfer ctxt (Source_container src) (Sink_container dest) amount) + >>=? fun (ctxt', _) -> wrap (Token.balance ctxt src) >>=? fun (ctxt, bal_src) -> wrap (Token.balance ctxt' src) >>=? fun (ctxt', bal_src') -> wrap (Token.balance ctxt dest) >>=? fun (_, bal_dest) -> @@ -83,7 +84,12 @@ let test_simple_balance_updates () = let pkh, _pk, _sk = Signature.generate_key () in let dest = Contract.Implicit pkh in let amount = Tez.one in - wrap (Token.transfer ctxt (`Contract src) (`Contract dest) amount) + wrap + (Token.transfer + ctxt + (Source_container (Contract src)) + (Sink_container (Contract dest)) + amount) >>=? fun (_, bal_updates) -> Alcotest.( check @@ -109,11 +115,19 @@ let test_allocated_and_deallocated ctxt dest initial_status status_when_empty = wrap (Token.allocated ctxt dest) >>=? fun (ctxt, allocated) -> Assert.equal_bool ~loc:__LOC__ allocated initial_status >>=? fun () -> let amount = Tez.one in - wrap (Token.transfer ctxt `Minted dest amount) >>=? fun (ctxt', _) -> + wrap + (Token.transfer ctxt (Source_infinite Minted) (Sink_container dest) amount) + >>=? fun (ctxt', _) -> wrap (Token.allocated ctxt' dest) >>=? fun (ctxt', allocated) -> Assert.equal_bool ~loc:__LOC__ allocated true >>=? fun () -> wrap (Token.balance ctxt' dest) >>=? fun (ctxt', bal_dest') -> - wrap (Token.transfer ctxt' dest `Burned bal_dest') >>=? fun (ctxt', _) -> + wrap + (Token.transfer + ctxt' + (Source_container dest) + (Sink_infinite Burned) + bal_dest') + >>=? fun (ctxt', _) -> wrap (Token.allocated ctxt' dest) >>=? fun (_, allocated) -> Assert.equal_bool ~loc:__LOC__ allocated status_when_empty >>=? fun () -> return_unit @@ -127,20 +141,20 @@ let test_allocated_and_still_allocated_when_empty ctxt dest initial_status = let test_allocated () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> - let dest = `Delegate_balance pkh in + let dest = Token.Delegate_balance pkh in test_allocated_and_still_allocated_when_empty ctxt dest true >>=? fun _ -> let pkh, _pk, _sk = Signature.generate_key () in - let dest = `Contract (Contract.Implicit pkh) in + let dest = Token.Contract (Contract.Implicit pkh) in test_allocated_and_deallocated_when_empty ctxt dest >>=? fun _ -> - let dest = `Collected_commitments Blinded_public_key_hash.zero in + let dest = Token.Collected_commitments Blinded_public_key_hash.zero in test_allocated_and_deallocated_when_empty ctxt dest >>=? fun _ -> - let dest = `Frozen_deposits pkh in + let dest = Token.Frozen_deposits pkh in test_allocated_and_still_allocated_when_empty ctxt dest false >>=? fun _ -> - let dest = `Block_fees in + let dest = Token.Block_fees in test_allocated_and_still_allocated_when_empty ctxt dest true >>=? fun _ -> let dest = let bond_id = Bond_id.Tx_rollup_bond_id (mk_rollup ()) in - `Frozen_bonds (Contract.Implicit pkh, bond_id) + Token.Frozen_bonds (Contract.Implicit pkh, bond_id) in test_allocated_and_deallocated_when_empty ctxt dest @@ -155,20 +169,34 @@ let check_sink_balances ctxt ctxt' dest amount = (`Contract pkh) instead. *) let force_allocation_if_need_be ctxt account = match account with - | `Delegate_balance pkh -> - let account = `Contract (Contract.Implicit pkh) in - wrap (Token.transfer ctxt `Minted account Tez.one_mutez) >|=? fst + | Token.Delegate_balance pkh -> + let account = Token.Contract (Contract.Implicit pkh) in + wrap + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container account) + Tez.one_mutez) + >|=? fst | _ -> return ctxt let test_transferring_to_sink ctxt sink amount expected_bupds = (* Transferring zero must be a noop, and must not return balance updates. *) - wrap (Token.transfer ctxt `Minted sink Tez.zero) >>=? fun (ctxt', bupds) -> + wrap + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container sink) + Tez.zero) + >>=? fun (ctxt', bupds) -> Assert.equal_bool ~loc:__LOC__ (ctxt == ctxt' && bupds = []) true >>=? fun _ -> (* Force the allocation of [dest] if need be. *) force_allocation_if_need_be ctxt sink >>=? fun ctxt -> (* Test transferring a non null amount. *) - wrap (Token.transfer ctxt `Minted sink amount) >>=? fun (ctxt', bupds) -> + wrap + (Token.transfer ctxt (Source_infinite Minted) (Sink_container sink) amount) + >>=? fun (ctxt', bupds) -> check_sink_balances ctxt ctxt' sink amount >>=? fun _ -> let expected_bupds = Receipt.(Minted, Debited amount, Block_application) :: expected_bupds @@ -178,7 +206,9 @@ let test_transferring_to_sink ctxt sink amount expected_bupds = (* Test transferring to go beyond capacity. *) wrap (Token.balance ctxt' sink) >>=? fun (ctxt', bal) -> let amount = Tez.of_mutez_exn Int64.max_int -! bal +! Tez.one_mutez in - wrap (Token.transfer ctxt' `Minted sink amount) >>= fun res -> + wrap + (Token.transfer ctxt' (Source_infinite Minted) (Sink_container sink) amount) + >>= fun res -> Assert.proto_error_with_info ~loc:__LOC__ res "Overflowing tez addition" let test_transferring_to_contract ctxt = @@ -187,7 +217,7 @@ let test_transferring_to_contract ctxt = let amount = random_amount () in test_transferring_to_sink ctxt - (`Contract dest) + (Contract dest) amount [(Contract dest, Credited amount, Block_application)] @@ -196,7 +226,7 @@ let test_transferring_to_collected_commitments ctxt = let bpkh = Blinded_public_key_hash.zero in test_transferring_to_sink ctxt - (`Collected_commitments bpkh) + (Collected_commitments bpkh) amount [(Commitments bpkh, Credited amount, Block_application)] @@ -206,7 +236,7 @@ let test_transferring_to_delegate_balance ctxt = let amount = random_amount () in test_transferring_to_sink ctxt - (`Delegate_balance pkh) + (Delegate_balance pkh) amount [(Contract dest, Credited amount, Block_application)] @@ -215,7 +245,7 @@ let test_transferring_to_frozen_deposits ctxt = let amount = random_amount () in test_transferring_to_sink ctxt - (`Frozen_deposits pkh) + (Frozen_deposits pkh) amount [(Deposits pkh, Credited amount, Block_application)] @@ -223,26 +253,39 @@ let test_transferring_to_collected_fees ctxt = let amount = random_amount () in test_transferring_to_sink ctxt - `Block_fees + Block_fees amount [(Block_fees, Credited amount, Block_application)] let test_transferring_to_burned ctxt = let amount = random_amount () in let minted_bupd = Receipt.(Minted, Debited amount, Block_application) in - wrap (Token.transfer ctxt `Minted `Burned amount) >>=? fun (_, bupds) -> + wrap + (Token.transfer ctxt (Source_infinite Minted) (Sink_infinite Burned) amount) + >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ (bupds = [minted_bupd; (Burned, Credited amount, Block_application)]) true >>=? fun () -> - wrap (Token.transfer ctxt `Minted `Storage_fees amount) >>=? fun (_, bupds) -> + wrap + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_infinite Storage_fees) + amount) + >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ (bupds = [minted_bupd; (Storage_fees, Credited amount, Block_application)]) true >>=? fun () -> - wrap (Token.transfer ctxt `Minted `Double_signing_punishments amount) + wrap + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_infinite Double_signing_punishments) + amount) >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ @@ -256,7 +299,11 @@ let test_transferring_to_burned ctxt = let pkh = Signature.Public_key_hash.zero in let p, r = (Random.bool (), Random.bool ()) in wrap - (Token.transfer ctxt `Minted (`Lost_endorsing_rewards (pkh, p, r)) amount) + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_infinite (Lost_endorsing_rewards (pkh, p, r))) + amount) >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ @@ -267,7 +314,12 @@ let test_transferring_to_burned ctxt = ]) true >>=? fun () -> - wrap (Token.transfer ctxt `Minted `Sc_rollup_refutation_punishments amount) + wrap + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_infinite Sc_rollup_refutation_punishments) + amount) >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ @@ -286,7 +338,7 @@ let test_transferring_to_frozen_bonds ctxt = let amount = random_amount () in test_transferring_to_sink ctxt - (`Frozen_bonds (contract, bond_id)) + (Frozen_bonds (contract, bond_id)) amount [(Frozen_bonds (contract, bond_id), Credited amount, Block_application)] @@ -309,11 +361,13 @@ let check_src_balances ctxt ctxt' src amount = let test_transferring_from_unbounded_source ctxt src expected_bupds = (* Transferring zero must not return balance updates. *) - wrap (Token.transfer ctxt src `Burned Tez.zero) >>=? fun (_, bupds) -> + wrap (Token.transfer ctxt src (Sink_infinite Burned) Tez.zero) + >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ (bupds = []) true >>=? fun () -> (* Test transferring a non null amount. *) let amount = random_amount () in - wrap (Token.transfer ctxt src `Burned amount) >>=? fun (_, bupds) -> + wrap (Token.transfer ctxt src (Sink_infinite Burned) amount) + >>=? fun (_, bupds) -> let expected_bupds = expected_bupds amount @ Receipt.[(Burned, Credited amount, Block_application)] @@ -332,48 +386,76 @@ let test_transferring_from_bounded_source ctxt src amount expected_bupds = balance_no_fail ctxt src >>=? fun (ctxt, balance) -> Assert.equal_tez ~loc:__LOC__ balance Tez.zero >>=? fun () -> (* Test transferring from an empty account. *) - wrap (Token.transfer ctxt src `Burned Tez.one) >>= fun res -> + wrap + (Token.transfer ctxt (Source_container src) (Sink_infinite Burned) Tez.one) + >>= fun res -> let error_title = match src with - | `Contract _ -> "Balance too low" - | `Delegate_balance _ | `Frozen_deposits _ | `Frozen_bonds _ -> + | Contract _ -> "Balance too low" + | Delegate_balance _ | Frozen_deposits _ | Frozen_bonds _ -> "Storage error (fatal internal error)" | _ -> "Underflowing tez subtraction" in Assert.proto_error_with_info ~loc:__LOC__ res error_title >>=? fun () -> (* Transferring zero must be a noop, and must not return balance updates. *) - wrap (Token.transfer ctxt src `Burned Tez.zero) >>=? fun (ctxt', bupds) -> + wrap + (Token.transfer ctxt (Source_container src) (Sink_infinite Burned) Tez.zero) + >>=? fun (ctxt', bupds) -> Assert.equal_bool ~loc:__LOC__ (ctxt == ctxt' && bupds = []) true >>=? fun _ -> (* Force the allocation of [dest] if need be. *) force_allocation_if_need_be ctxt src >>=? fun ctxt -> (* Test transferring everything. *) - wrap (Token.transfer ctxt `Minted src amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt src `Burned amount) >>=? fun (ctxt', bupds) -> + wrap + (Token.transfer ctxt (Source_infinite Minted) (Sink_container src) amount) + >>=? fun (ctxt, _) -> + wrap + (Token.transfer ctxt (Source_container src) (Sink_infinite Burned) amount) + >>=? fun (ctxt', bupds) -> check_src_balances ctxt ctxt' src amount >>=? fun _ -> let expected_bupds = expected_bupds @ Receipt.[(Burned, Credited amount, Block_application)] in Assert.equal_bool ~loc:__LOC__ (bupds = expected_bupds) true >>=? fun () -> (* Test transferring a smaller amount. *) - wrap (Token.transfer ctxt `Minted src amount) >>=? fun (ctxt, _) -> + wrap + (Token.transfer ctxt (Source_infinite Minted) (Sink_container src) amount) + >>=? fun (ctxt, _) -> (match src with - | `Frozen_bonds _ -> - wrap (Token.transfer ctxt src `Burned amount) >>= fun res -> + | Frozen_bonds _ -> + wrap + (Token.transfer + ctxt + (Source_container src) + (Sink_infinite Burned) + amount) + >>= fun res -> let error_title = "Partial spending of frozen bonds" in Assert.proto_error_with_info ~loc:__LOC__ res error_title | _ -> - wrap (Token.transfer ctxt src `Burned amount) >>=? fun (ctxt', bupds) -> + wrap + (Token.transfer + ctxt + (Source_container src) + (Sink_infinite Burned) + amount) + >>=? fun (ctxt', bupds) -> check_src_balances ctxt ctxt' src amount >>=? fun _ -> Assert.equal_bool ~loc:__LOC__ (bupds = expected_bupds) true) >>=? fun () -> (* Test transferring more than available. *) wrap (Token.balance ctxt src) >>=? fun (ctxt, balance) -> - wrap (Token.transfer ctxt src `Burned (balance +! Tez.one)) >>= fun res -> + wrap + (Token.transfer + ctxt + (Source_container src) + (Sink_infinite Burned) + (balance +! Tez.one)) + >>= fun res -> let error_title = match src with - | `Contract _ -> "Balance too low" - | `Frozen_bonds _ -> "Partial spending of frozen bonds" + | Contract _ -> "Balance too low" + | Frozen_bonds _ -> "Partial spending of frozen bonds" | _ -> "Underflowing tez subtraction" in Assert.proto_error_with_info ~loc:__LOC__ res error_title @@ -384,7 +466,7 @@ let test_transferring_from_contract ctxt = let amount = random_amount () in test_transferring_from_bounded_source ctxt - (`Contract src) + (Contract src) amount [(Contract src, Debited amount, Block_application)] @@ -393,7 +475,7 @@ let test_transferring_from_collected_commitments ctxt = let bpkh = Blinded_public_key_hash.zero in test_transferring_from_bounded_source ctxt - (`Collected_commitments bpkh) + (Collected_commitments bpkh) amount [(Commitments bpkh, Debited amount, Block_application)] @@ -403,7 +485,7 @@ let test_transferring_from_delegate_balance ctxt = let src = Contract.Implicit pkh in test_transferring_from_bounded_source ctxt - (`Delegate_balance pkh) + (Delegate_balance pkh) amount [(Contract src, Debited amount, Block_application)] @@ -412,7 +494,7 @@ let test_transferring_from_frozen_deposits ctxt = let amount = random_amount () in test_transferring_from_bounded_source ctxt - (`Frozen_deposits pkh) + (Frozen_deposits pkh) amount [(Deposits pkh, Debited amount, Block_application)] @@ -420,7 +502,7 @@ let test_transferring_from_collected_fees ctxt = let amount = random_amount () in test_transferring_from_bounded_source ctxt - `Block_fees + Block_fees amount [(Block_fees, Debited amount, Block_application)] @@ -432,46 +514,62 @@ let test_transferring_from_frozen_bonds ctxt = let amount = random_amount () in test_transferring_from_bounded_source ctxt - (`Frozen_bonds (contract, bond_id)) + (Frozen_bonds (contract, bond_id)) amount [(Frozen_bonds (contract, bond_id), Debited amount, Block_application)] let test_transferring_from_source () = Random.init 0 ; create_context () >>=? fun (ctxt, _) -> - test_transferring_from_unbounded_source ctxt `Invoice (fun am -> - [(Invoice, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Invoice) + (fun am -> [(Invoice, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Bootstrap (fun am -> - [(Bootstrap, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Bootstrap) + (fun am -> [(Bootstrap, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Initial_commitments (fun am -> - [(Initial_commitments, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Initial_commitments) + (fun am -> [(Initial_commitments, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Revelation_rewards (fun am -> - [(Nonce_revelation_rewards, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Revelation_rewards) + (fun am -> [(Nonce_revelation_rewards, Debited am, Block_application)]) >>=? fun _ -> test_transferring_from_unbounded_source ctxt - `Double_signing_evidence_rewards + (Source_infinite Double_signing_evidence_rewards) (fun am -> [(Double_signing_evidence_rewards, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Endorsing_rewards (fun am -> - [(Endorsing_rewards, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Endorsing_rewards) + (fun am -> [(Endorsing_rewards, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Baking_rewards (fun am -> - [(Baking_rewards, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Baking_rewards) + (fun am -> [(Baking_rewards, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Baking_bonuses (fun am -> - [(Baking_bonuses, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Baking_bonuses) + (fun am -> [(Baking_bonuses, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Minted (fun am -> - [(Minted, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Minted) + (fun am -> [(Minted, Debited am, Block_application)]) >>=? fun _ -> test_transferring_from_unbounded_source ctxt - `Liquidity_baking_subsidies + (Source_infinite Liquidity_baking_subsidies) (fun am -> [(Liquidity_baking_subsidies, Debited am, Block_application)]) >>=? fun _ -> test_transferring_from_contract ctxt >>=? fun _ -> @@ -495,23 +593,43 @@ let cast_to_container_type x = (** Generates all combinations of constructors. *) let build_test_cases () = create_context () >>=? fun (ctxt, pkh) -> - let origin = `Contract (Contract.Implicit pkh) in + let origin = Token.Contract (Contract.Implicit pkh) in let user1, _, _ = Signature.generate_key () in - let user1c = `Contract (Contract.Implicit user1) in + let user1c = Token.Contract (Contract.Implicit user1) in let user2, _, _ = Signature.generate_key () in - let user2c = `Contract (Contract.Implicit user2) in + let user2c = Token.Contract (Contract.Implicit user2) in let baker1, baker1_pk, _ = Signature.generate_key () in - let baker1c = `Contract (Contract.Implicit baker1) in + let baker1c = Token.Contract (Contract.Implicit baker1) in let baker2, baker2_pk, _ = Signature.generate_key () in - let baker2c = `Contract (Contract.Implicit baker2) in + let baker2c = Token.Contract (Contract.Implicit baker2) in (* Allocate contracts for user1, user2, baker1, and baker2. *) - wrap (Token.transfer ctxt origin user1c (random_amount ())) + wrap + (Token.transfer + ctxt + (Source_container origin) + (Sink_container user1c) + (random_amount ())) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin user2c (random_amount ())) + wrap + (Token.transfer + ctxt + (Source_container origin) + (Sink_container user2c) + (random_amount ())) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin baker1c (random_amount ())) + wrap + (Token.transfer + ctxt + (Source_container origin) + (Sink_container baker1c) + (random_amount ())) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin baker2c (random_amount ())) + wrap + (Token.transfer + ctxt + (Source_container origin) + (Sink_container baker2c) + (random_amount ())) >>=? fun (ctxt, _) -> (* Configure baker1, and baker2 as delegates by self-delegation, for which revealing their manager key is a prerequisite. *) @@ -532,81 +650,90 @@ let build_test_cases () = let baker2ic = Contract.Implicit baker2 in let src_list = [ - (`Invoice, random_amount ()); - (`Bootstrap, random_amount ()); - (`Initial_commitments, random_amount ()); - (`Minted, random_amount ()); - (`Liquidity_baking_subsidies, random_amount ()); - (`Collected_commitments Blinded_public_key_hash.zero, random_amount ()); - (`Delegate_balance baker1, random_amount ()); - (`Delegate_balance baker2, random_amount ()); - (`Block_fees, random_amount ()); - (user1c, random_amount ()); - (user2c, random_amount ()); - (baker1c, random_amount ()); - (baker2c, random_amount ()); - (`Frozen_bonds (user1ic, bond_id1), random_amount ()); - (`Frozen_bonds (baker2ic, bond_id2), random_amount ()); + (Token.Source_infinite Invoice, random_amount ()); + (Source_infinite Bootstrap, random_amount ()); + (Source_infinite Initial_commitments, random_amount ()); + (Source_infinite Minted, random_amount ()); + (Source_infinite Liquidity_baking_subsidies, random_amount ()); + ( Source_container (Collected_commitments Blinded_public_key_hash.zero), + random_amount () ); + (Source_container (Delegate_balance baker1), random_amount ()); + (Source_container (Delegate_balance baker2), random_amount ()); + (Source_container Block_fees, random_amount ()); + (Source_container user1c, random_amount ()); + (Source_container user2c, random_amount ()); + (Source_container baker1c, random_amount ()); + (Source_container baker2c, random_amount ()); + (Source_container (Frozen_bonds (user1ic, bond_id1)), random_amount ()); + (Source_container (Frozen_bonds (baker2ic, bond_id2)), random_amount ()); ] in let dest_list = [ - `Collected_commitments Blinded_public_key_hash.zero; - `Delegate_balance baker1; - `Delegate_balance baker2; - `Block_fees; - user1c; - user2c; - baker1c; - baker2c; - `Frozen_bonds (user1ic, bond_id1); - `Frozen_bonds (baker2ic, bond_id2); - `Burned; + Token.Sink_container (Collected_commitments Blinded_public_key_hash.zero); + Sink_container (Delegate_balance baker1); + Sink_container (Delegate_balance baker2); + Sink_container Block_fees; + Sink_container user1c; + Sink_container user2c; + Sink_container baker1c; + Sink_container baker2c; + Sink_container (Frozen_bonds (user1ic, bond_id1)); + Sink_container (Frozen_bonds (baker2ic, bond_id2)); + Sink_infinite Burned; ] in return (ctxt, List.product src_list dest_list) -let check_src_balances ctxt ctxt' src amount = - match cast_to_container_type src with - | None -> return_unit - | Some src -> check_src_balances ctxt ctxt' src amount - -let check_sink_balances ctxt ctxt' dest amount = - match cast_to_container_type dest with - | None -> return_unit - | Some dest -> check_sink_balances ctxt ctxt' dest amount - let rec check_balances ctxt ctxt' src dest amount = - match (cast_to_container_type src, cast_to_container_type dest) with - | None, None -> return_unit - | ( Some (`Delegate_balance d), - Some (`Contract (Contract.Implicit c) as contract) ) - | ( Some (`Contract (Contract.Implicit c) as contract), - Some (`Delegate_balance d) ) - when d = c -> + match (src, dest) with + | ( Token.Source_container (Delegate_balance d), + Token.Sink_container (Contract c as contract) ) + when Contract.Implicit d = c -> (* src and dest are in fact referring to the same contract *) - check_balances ctxt ctxt' contract contract amount - | Some src, Some dest when src = dest -> + check_balances + ctxt + ctxt' + (Source_container contract) + (Sink_container contract) + amount + | ( Source_container (Contract c as contract), + Sink_container (Delegate_balance d) ) + when Contract.Implicit d = c -> + (* src and dest are in fact referring to the same contract *) + check_balances + ctxt + ctxt' + (Source_container contract) + (Sink_container contract) + amount + | Source_container src, Sink_container dest when src = dest -> (* src and dest are the same contract *) wrap (Token.balance ctxt dest) >>=? fun (_, bal_dest) -> wrap (Token.balance ctxt' dest) >>=? fun (_, bal_dest') -> Assert.equal_tez ~loc:__LOC__ bal_dest bal_dest' - | Some src, None -> check_src_balances ctxt ctxt' src amount - | None, Some dest -> check_sink_balances ctxt ctxt' dest amount - | Some src, Some dest -> + | Source_container src, Sink_container dest -> check_src_balances ctxt ctxt' src amount >>=? fun _ -> check_sink_balances ctxt ctxt' dest amount + | Source_container src, _ -> check_src_balances ctxt ctxt' src amount + | _, Sink_container dest -> check_sink_balances ctxt ctxt' dest amount + | _, _ -> return_unit let test_all_combinations_of_sources_and_sinks () = Random.init 0 ; build_test_cases () >>=? fun (ctxt, cases) -> List.iter_es (fun ((src, amount), dest) -> - (match cast_to_container_type src with - | None -> return ctxt - | Some src -> - wrap (Token.transfer ctxt `Minted src amount) >>=? fun (ctxt, _) -> - return ctxt) + (match src with + | Token.Source_container src -> + wrap + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container src) + amount) + >>=? fun (ctxt, _) -> return ctxt + | _ -> return ctxt) >>=? fun ctxt -> wrap (Token.transfer ctxt src dest amount) >>=? fun (ctxt', _) -> check_balances ctxt ctxt' src dest amount) @@ -641,15 +768,20 @@ let coalesce_balance_updates bu1 bu2 = (** Check that elt has the same balance in ctxt1 and ctxt2. *) let check_balances_are_consistent ctxt1 ctxt2 elt = - match elt with - | #Token.container as elt -> - Token.balance ctxt1 elt >>=? fun (_, elt_bal1) -> - Token.balance ctxt2 elt >>=? fun (_, elt_bal2) -> - assert (elt_bal1 = elt_bal2) ; - return_unit - | `Invoice | `Bootstrap | `Initial_commitments | `Minted - | `Liquidity_baking_subsidies | `Burned -> - return_unit + Token.balance ctxt1 elt >>=? fun (_, elt_bal1) -> + Token.balance ctxt2 elt >>=? fun (_, elt_bal2) -> + assert (elt_bal1 = elt_bal2) ; + return_unit + +let check_balances_are_consistent_source ctxt1 ctxt2 src = + match src with + | Token.Source_container elt -> check_balances_are_consistent ctxt1 ctxt2 elt + | _ -> return_unit + +let check_balances_are_consistent_dest ctxt1 ctxt2 dest = + match dest with + | Token.Sink_container elt -> check_balances_are_consistent ctxt1 ctxt2 elt + | _ -> return_unit (** Test that [transfer_n] is equivalent to n debits followed by n credits. *) let test_transfer_n ctxt src dest = @@ -658,8 +790,8 @@ let test_transfer_n ctxt src dest = (* Debit all sources. *) List.fold_left_es (fun (ctxt, bal_updates) (src, am) -> - Token.transfer ctxt src `Burned am >>=? fun (ctxt, debit_logs) -> - return (ctxt, bal_updates @ debit_logs)) + Token.transfer ctxt src (Sink_infinite Burned) am + >>=? fun (ctxt, debit_logs) -> return (ctxt, bal_updates @ debit_logs)) (ctxt, []) src >>=? fun (ctxt, debit_logs) -> @@ -672,8 +804,8 @@ let test_transfer_n ctxt src dest = (* Credit the sink for each source. *) List.fold_left_es (fun (ctxt, bal_updates) (_, am) -> - Token.transfer ctxt `Minted dest am >>=? fun (ctxt, credit_logs) -> - return (ctxt, bal_updates @ credit_logs)) + Token.transfer ctxt (Source_infinite Minted) dest am + >>=? fun (ctxt, credit_logs) -> return (ctxt, bal_updates @ credit_logs)) (ctxt, []) src >>=? fun (ctxt2, credit_logs) -> @@ -691,46 +823,74 @@ let test_transfer_n ctxt src dest = in assert (bal_updates1 = debit_logs @ credit_logs) ; (* Check balances are the same in ctxt1 and ctxt2. *) - List.(iter_es (check_balances_are_consistent ctxt1 ctxt2) (map fst src)) - >>=? fun _ -> check_balances_are_consistent ctxt1 ctxt2 dest + List.( + iter_es (check_balances_are_consistent_source ctxt1 ctxt2) (map fst src)) + >>=? fun _ -> check_balances_are_consistent_dest ctxt1 ctxt2 dest let test_transfer_n_with_empty_source () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> - wrap (test_transfer_n ctxt [] `Block_fees) >>=? fun _ -> - let dest = `Delegate_balance pkh in + wrap (test_transfer_n ctxt [] (Sink_container Block_fees)) >>=? fun _ -> + let dest = Token.Sink_container (Delegate_balance pkh) in wrap (test_transfer_n ctxt [] dest) let test_transfer_n_with_non_empty_source () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> - let origin = `Contract (Contract.Implicit pkh) in + let origin = Token.Contract (Contract.Implicit pkh) in let user1, _, _ = Signature.generate_key () in - let user1c = `Contract (Contract.Implicit user1) in + let user1c = Token.Contract (Contract.Implicit user1) in let user2, _, _ = Signature.generate_key () in - let user2c = `Contract (Contract.Implicit user2) in + let user2c = Token.Contract (Contract.Implicit user2) in let user3, _, _ = Signature.generate_key () in - let user3c = `Contract (Contract.Implicit user3) in + let user3c = Token.Contract (Contract.Implicit user3) in let user4, _, _ = Signature.generate_key () in - let user4c = `Contract (Contract.Implicit user4) in + let user4c = Token.Contract (Contract.Implicit user4) in (* Allocate contracts for user1, user2, user3, and user4. *) let amount = match Tez.of_mutez 1000L with None -> assert false | Some x -> x in - wrap (Token.transfer ctxt origin user1c amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin user2c amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin user3c amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin user4c (random_amount ())) + wrap + (Token.transfer + ctxt + (Source_container origin) + (Sink_container user1c) + amount) + >>=? fun (ctxt, _) -> + wrap + (Token.transfer + ctxt + (Source_container origin) + (Sink_container user2c) + amount) + >>=? fun (ctxt, _) -> + wrap + (Token.transfer + ctxt + (Source_container origin) + (Sink_container user3c) + amount) + >>=? fun (ctxt, _) -> + wrap + (Token.transfer + ctxt + (Source_container origin) + (Sink_container user4c) + (random_amount ())) >>=? fun (ctxt, _) -> let sources = [ - (user2c, random_amount ()); - (user3c, random_amount ()); - (user4c, random_amount ()); + (Token.Source_container user2c, random_amount ()); + (Source_container user3c, random_amount ()); + (Source_container user4c, random_amount ()); ] in - wrap (test_transfer_n ctxt sources user1c) >>=? fun _ -> - wrap (test_transfer_n ctxt ((user1c, random_amount ()) :: sources) user1c) + wrap (test_transfer_n ctxt sources (Sink_container user1c)) >>=? fun _ -> + wrap + (test_transfer_n + ctxt + ((Source_container user1c, random_amount ()) :: sources) + (Sink_container user1c)) let tests = Tztest. diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml b/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml index 91d787b235d817f25438da593bdb20aa4b98f91f..658911e1927a785212373f5bd88a95445516f170 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml @@ -655,7 +655,7 @@ module Strategies (PVM : TestPVM with type hash = State_hash.t) = struct let module P = struct include PVM - let proof = pvm_proof + let proof_val = pvm_proof end in Unencodable (module P) in @@ -732,7 +732,7 @@ module Strategies (PVM : TestPVM with type hash = State_hash.t) = struct let module P = struct include PVM - let proof = pvm_proof + let proof_val = pvm_proof end in Unencodable (module P) in diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml index 306ecf4be37f14d9566c8cd59bb21c3368054fdb..2d0ba59a921a1b50ec0748965cbb1b7daa667c69 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml @@ -71,7 +71,11 @@ let new_context () = let contract = Contract_repr.Implicit pkh in let+ ctxt, _ = lift - @@ Token.transfer ctxt `Minted (`Contract contract) initial_staker_balance + @@ Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container (Contract contract)) + initial_staker_balance in ctxt in @@ -139,10 +143,10 @@ let deposit_stake_and_check_balances ctxt rollup staker = staker in let* () = - assert_balance_decreased ctxt ctxt' (`Contract staker_contract) stake + assert_balance_decreased ctxt ctxt' (Contract staker_contract) stake in let bond_id = Bond_id_repr.Sc_rollup_bond_id rollup in - let bonds_account = `Frozen_bonds (staker_contract, bond_id) in + let bonds_account = Token.Frozen_bonds (staker_contract, bond_id) in let+ () = assert_balance_increased ctxt ctxt' bonds_account stake in ctxt') @@ -267,7 +271,11 @@ let test_deposit_by_underfunded_staker () = let staker_contract = Contract_repr.Implicit staker in let* ctxt, _ = lift - @@ Token.transfer ctxt `Minted (`Contract staker_contract) staker_balance + @@ Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container (Contract staker_contract)) + staker_balance in assert_fails_with ~loc:__LOC__ @@ -306,10 +314,10 @@ let remove_staker_and_check_balances ctxt rollup staker = lift @@ Sc_rollup_stake_storage.remove_staker ctxt rollup staker in let* () = - assert_balance_unchanged ctxt ctxt' (`Contract staker_contract) + assert_balance_unchanged ctxt ctxt' (Contract staker_contract) in let bond_id = Bond_id_repr.Sc_rollup_bond_id rollup in - let bonds_account = `Frozen_bonds (staker_contract, bond_id) in + let bonds_account = Token.Frozen_bonds (staker_contract, bond_id) in let+ () = assert_balance_decreased ctxt ctxt' bonds_account stake in ctxt') @@ -330,10 +338,10 @@ let withdraw_stake_and_check_balances ctxt rollup staker = lift @@ Sc_rollup_stake_storage.withdraw_stake ctxt rollup staker in let* () = - assert_balance_increased ctxt ctxt' (`Contract staker_contract) stake + assert_balance_increased ctxt ctxt' (Contract staker_contract) stake in let bond_id = Bond_id_repr.Sc_rollup_bond_id rollup in - let bonds_account = `Frozen_bonds (staker_contract, bond_id) in + let bonds_account = Token.Frozen_bonds (staker_contract, bond_id) in let+ () = assert_balance_decreased ctxt ctxt' bonds_account stake in ctxt') @@ -2408,7 +2416,7 @@ let test_limit_on_number_of_messages_during_commitment_period with_gap () = | _ -> false let record ctxt rollup level message_index = - Sc_rollup_storage.Outbox.record_applied_message + Sc_rollup_storage.Outbox_aux.record_applied_message ctxt rollup (Raw_level_repr.of_int32_exn @@ Int32.of_int level) diff --git a/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml b/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml index b95ed7e35c17d1ff47b3017a1adc9c28cd0434f6..1733b032f9d6f4fcbdee42e42c7e9dca7ac67827 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml @@ -203,7 +203,7 @@ module type S = sig val set_count : t -> int32 -> t m val get_or_associate_index : - t -> value -> (t * [`Created | `Existed] * index) m + t -> value -> (t * Tx_rollup_l2_context_sig.created_existed * index) m val get : t -> value -> index option m @@ -224,7 +224,7 @@ module Test_index (Index : S) = struct let* ctxt, value = init_context_1 () in let* ctxt, created, idx1 = Index.get_or_associate_index ctxt value in - assert (created = `Created) ; + assert (created = Created) ; let* idx2 = Index.get ctxt value in assert (Some idx1 = idx2) ; @@ -244,7 +244,7 @@ module Test_index (Index : S) = struct assert (idx = None) ; let* ctxt, created, idx = Index.get_or_associate_index ctxt value in - assert (created = `Created) ; + assert (created = Created) ; let* count = Index.count ctxt in assert (count = 1l) ; @@ -260,14 +260,14 @@ module Test_index (Index : S) = struct let expected = Indexable.index_exn 0l in let* ctxt, created, idx = Index.get_or_associate_index ctxt value in - assert (created = `Created) ; + assert (created = Created) ; assert (idx = expected) ; let* idx = Index.get ctxt value in assert (idx = Some (Indexable.index_exn 0l)) ; let* ctxt, existed, idx = Index.get_or_associate_index ctxt value in - assert (existed = `Existed) ; + assert (existed = Existed) ; assert (idx = expected) ; let* count = Index.count ctxt in diff --git a/src/proto_alpha/lib_protocol/ticket_accounting.ml b/src/proto_alpha/lib_protocol/ticket_accounting.ml index 64c2273f18fd5dde2c9a2fde9d31ed2126e75f41..56b8cc6f7d8817f3e5a10bd0bd22b3f3f8719566 100644 --- a/src/proto_alpha/lib_protocol/ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/ticket_accounting.ml @@ -58,7 +58,7 @@ module Ticket_token_map = struct Gas.consume ctxt (Ticket_costs.add_z_cost b1 b2) >|? fun ctxt -> (Z.add b1 b2, ctxt) - let of_list ctxt token_amounts = + let of_list_with_merge ctxt token_amounts = Ticket_token_map.of_list ctxt ~merge_overlap token_amounts let add ctxt = Ticket_token_map.merge ctxt ~merge_overlap @@ -88,9 +88,9 @@ let ticket_balances_of_value ctxt ~include_lazy ty value = >|? fun ctxt -> ((token, Script_int.to_zint amount) :: acc, ctxt)) ([], ctxt) tickets - >>?= fun (list, ctxt) -> Ticket_token_map.of_list ctxt list + >>?= fun (list, ctxt) -> Ticket_token_map.of_list_with_merge ctxt list -let update_ticket_balances ctxt ~total_storage_diff token destinations = +let update_ticket_balances_raw ctxt ~total_storage_diff token destinations = List.fold_left_es (fun (tot_storage_diff, ctxt) (owner, delta) -> Ticket_balance_key.of_ex_token ctxt ~owner token @@ -122,7 +122,7 @@ let update_ticket_balances_for_self_contract ctxt ~self ticket_diffs = is_valid_balance_update (invalid_ticket_transfer_error ~ticket_token ~amount) >>?= fun () -> - update_ticket_balances + update_ticket_balances_raw ctxt ~total_storage_diff ticket_token @@ -137,7 +137,7 @@ let ticket_diffs_of_lazy_storage_diff ctxt ~storage_type_has_tickets Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt lazy_storage_diff - >>=? fun (diffs, ctxt) -> Ticket_token_map.of_list ctxt diffs + >>=? fun (diffs, ctxt) -> Ticket_token_map.of_list_with_merge ctxt diffs else return (Ticket_token_map.empty, ctxt) (* TODO #2465 @@ -250,6 +250,10 @@ let update_ticket_balances ctxt ~self ~ticket_diffs operations = ([], ctxt) destinations >>?= fun (destinations, ctxt) -> - update_ticket_balances ctxt ~total_storage_diff ticket_token destinations) + update_ticket_balances_raw + ctxt + ~total_storage_diff + ticket_token + destinations) (total_storage_diff, ctxt) ticket_op_diffs diff --git a/src/proto_alpha/lib_protocol/ticket_hash_builder.ml b/src/proto_alpha/lib_protocol/ticket_hash_builder.ml index fc7f79181e1838f526442cd1ea06e53dd8630829..1fdc9e9245dc11037887d73d661ea1919a51bcd2 100644 --- a/src/proto_alpha/lib_protocol/ticket_hash_builder.ml +++ b/src/proto_alpha/lib_protocol/ticket_hash_builder.ml @@ -41,11 +41,11 @@ let () = (fun () -> Failed_to_hash_node) let hash_bytes_cost bytes = - let module S = Saturation_repr in - let ( + ) = S.add in - let v0 = S.safe_int @@ Bytes.length bytes in - let ( lsr ) = S.shift_right in - S.safe_int 200 + (v0 + (v0 lsr 2)) |> Gas_limit_repr.atomic_step_cost + let ( + ) = Saturation_repr.add in + let v0 = Saturation_repr.safe_int @@ Bytes.length bytes in + let ( lsr ) = Saturation_repr.shift_right in + Saturation_repr.safe_int 200 + (v0 + (v0 lsr 2)) + |> Gas_limit_repr.atomic_step_cost let hash_of_node ctxt node = Raw_context.consume_gas ctxt (Script_repr.strip_locations_cost node) diff --git a/src/proto_alpha/lib_protocol/ticket_hash_repr.ml b/src/proto_alpha/lib_protocol/ticket_hash_repr.ml index 21c18691140415089203f9026c874c98861d4f2a..274f6366f32195b7e97585d8e2bc4f4c8f4ae405 100644 --- a/src/proto_alpha/lib_protocol/ticket_hash_repr.ml +++ b/src/proto_alpha/lib_protocol/ticket_hash_repr.ml @@ -23,16 +23,33 @@ (* *) (*****************************************************************************) -include Script_expr_hash +type t = Script_expr_hash.t -let of_script_expr_hash t = t +let encoding = Script_expr_hash.encoding + +let pp = Script_expr_hash.pp + +let to_b58check = Script_expr_hash.to_b58check + +let of_b58check_opt = Script_expr_hash.of_b58check_opt + +let of_b58check_exn = Script_expr_hash.of_b58check_exn -let zero = zero +let of_bytes_exn = Script_expr_hash.of_bytes_exn + +let of_bytes_opt = Script_expr_hash.of_bytes_opt include Compare.Make (struct - type nonrec t = t + type nonrec t = Script_expr_hash.t - let compare = compare + let compare = Script_expr_hash.compare end) -module Index = Script_expr_hash +let zero = Script_expr_hash.zero + +let of_script_expr_hash t = t + +module Index : Storage_description.INDEX with type t = Script_expr_hash.t = +struct + include Script_expr_hash +end diff --git a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml index d2aaa66055fcd27af2d51f600dfb689d07c57279..d11752cc0615ee9eec1646fa414bf4a8d38ecd14 100644 --- a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml @@ -76,7 +76,7 @@ let parse_value_type ctxt value_type = removing a value containing tickets. *) let collect_token_diffs_of_node ctxt has_tickets node ~get_token_and_amount acc = - Ticket_scanner.tickets_of_node + (Ticket_scanner.tickets_of_node [@coq_implicit "a" "a"]) ctxt (* It's currently not possible to have nested lazy structures, but this is for future proofing. *) @@ -120,7 +120,7 @@ let collect_token_diffs_of_big_map_update ctxt ~big_map_id has_tickets = match expr_opt with | Some expr -> - collect_token_diffs_of_node + (collect_token_diffs_of_node [@coq_implicit "a" "a"]) ctxt has_tickets expr @@ -174,12 +174,12 @@ let collect_token_diffs_of_big_map_updates ctxt big_map_id ~value_type updates We should have the non-serialized version of the value type. *) parse_value_type ctxt value_type - >>?= fun (Script_ir_translator.Ex_ty value_type, ctxt) -> + >>?= fun [@coq_match_gadt] (Script_ir_translator.Ex_ty value_type, ctxt) -> Ticket_scanner.type_has_tickets ctxt value_type >>?= fun (has_tickets, ctxt) -> List.fold_left_es (fun (acc, already_updated, ctxt) update -> - collect_token_diffs_of_big_map_update + (collect_token_diffs_of_big_map_update [@coq_implicit "a" "__Ex_ty_'a"]) ctxt ~big_map_id has_tickets @@ -204,7 +204,8 @@ let collect_token_diffs_of_big_map ctxt ~get_token_and_amount big_map_id acc = type. It would be more efficient if the value preserved. *) parse_value_type ctxt value_ty - >>?= fun (Script_ir_translator.Ex_ty value_type, ctxt) -> + >>?= fun [@coq_match_gadt] (Script_ir_translator.Ex_ty value_type, ctxt) + -> Ticket_scanner.type_has_tickets ctxt value_type >>?= fun (has_tickets, ctxt) -> (* Iterate over big-map items. *) @@ -216,7 +217,7 @@ let collect_token_diffs_of_big_map ctxt ~get_token_and_amount big_map_id acc = Big_map.list_values ctxt big_map_id >>=? fun (ctxt, exprs) -> List.fold_left_es (fun (acc, ctxt) node -> - collect_token_diffs_of_node + (collect_token_diffs_of_node [@coq_implicit "a" "__Ex_ty_'a"]) ctxt has_tickets node @@ -247,15 +248,23 @@ let collect_token_diffs_of_big_map_and_updates ctxt big_map_id updates acc = let collect_token_diffs_of_big_map_diff ctxt diff_item acc = Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step >>?= fun ctxt -> - match diff_item with - | Lazy_storage.Item (Lazy_storage_kind.Big_map, big_map_id, Remove) -> + match[@coq_match_gadt] diff_item with + | Lazy_storage.Item + (Lazy_storage_kind.Big_map, (big_map_id : Big_map.Id.t), Remove) -> (* Collect all removed tokens from the big-map. *) collect_token_diffs_of_big_map ctxt ~get_token_and_amount:neg_token_and_amount big_map_id acc - | Item (Lazy_storage_kind.Big_map, big_map_id, Update {init; updates}) -> ( + | Item + ( Lazy_storage_kind.Big_map, + (big_map_id : Big_map.Id.t), + (Update {init; updates} : + ( Big_map.Id.t, + Lazy_storage_kind.Big_map.alloc, + Lazy_storage_kind.Big_map.updates ) + Lazy_storage.diff) ) -> ( match init with | Lazy_storage.Existing -> (* Collect token diffs from the updates to the big-map. *) diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml index 992f01194c778d34eb29e9e6f6960e6bb0e53a52..67be20314fbe20122adcf6195ec9e564be05da9c 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml @@ -120,7 +120,7 @@ module Ticket_inspection = struct a Script_typed_ir.comparable_ty -> (a has_tickets -> ret) -> ret = fun key_ty k -> let open Script_typed_ir in - match key_ty with + match[@coq_match_with_default] key_ty with | Unit_t -> (k [@ocaml.tailcall]) False_ht | Never_t -> (k [@ocaml.tailcall]) False_ht | Int_t -> (k [@ocaml.tailcall]) False_ht @@ -155,7 +155,7 @@ module Ticket_inspection = struct The returned value matches the given shape of the [ty] value, except it collapses whole branches where no types embed tickets to [False_ht]. *) - let rec has_tickets_of_ty : + let rec has_tickets_of_ty_aux : type a ac ret. (a, ac) Script_typed_ir.ty -> (a, ret) continuation -> ret tzresult = fun ty k -> @@ -192,11 +192,11 @@ module Ticket_inspection = struct a packable type and tickets are not packable. *) (k [@ocaml.tailcall]) False_ht | Option_t (ty, _, _) -> - (has_tickets_of_ty [@ocaml.tailcall]) ty (fun ht -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) ty (fun ht -> let opt_hty = map_has_tickets (fun ht -> Option_ht ht) ht in (k [@ocaml.tailcall]) opt_hty) | List_t (ty, _) -> - (has_tickets_of_ty [@ocaml.tailcall]) ty (fun ht -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) ty (fun ht -> let list_hty = map_has_tickets (fun ht -> List_ht ht) ht in (k [@ocaml.tailcall]) list_hty) | Set_t (key_ty, _) -> @@ -231,7 +231,7 @@ module Ticket_inspection = struct | Chest_t -> (k [@ocaml.tailcall]) False_ht | Chest_key_t -> (k [@ocaml.tailcall]) False_ht - and has_tickets_of_pair : + and[@coq_mutual_as_notation] has_tickets_of_pair : type a ac b bc c ret. (a, ac) Script_typed_ir.ty -> (b, bc) Script_typed_ir.ty -> @@ -239,11 +239,11 @@ module Ticket_inspection = struct (c, ret) continuation -> ret tzresult = fun ty1 ty2 ~pair k -> - (has_tickets_of_ty [@ocaml.tailcall]) ty1 (fun ht1 -> - (has_tickets_of_ty [@ocaml.tailcall]) ty2 (fun ht2 -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) ty1 (fun ht1 -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) ty2 (fun ht2 -> (k [@ocaml.tailcall]) (pair_has_tickets pair ht1 ht2))) - and has_tickets_of_key_and_value : + and[@coq_mutual_as_notation] has_tickets_of_key_and_value : type k v vc t ret. k Script_typed_ir.comparable_ty -> (v, vc) Script_typed_ir.ty -> @@ -252,12 +252,12 @@ module Ticket_inspection = struct ret tzresult = fun key_ty val_ty ~pair k -> (has_tickets_of_comparable [@ocaml.tailcall]) key_ty (fun ht1 -> - (has_tickets_of_ty [@ocaml.tailcall]) val_ty (fun ht2 -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) val_ty (fun ht2 -> (k [@ocaml.tailcall]) (pair_has_tickets pair ht1 ht2))) let has_tickets_of_ty ctxt ty = Gas.consume ctxt (Ticket_costs.has_tickets_of_ty_cost ty) >>? fun ctxt -> - has_tickets_of_ty ty ok >|? fun ht -> (ht, ctxt) + has_tickets_of_ty_aux ty ok >|? fun ht -> (ht, ctxt) end module Ticket_collection = struct @@ -285,7 +285,7 @@ module Ticket_collection = struct ret tzresult Lwt.t = fun ctxt comp_ty acc k -> let open Script_typed_ir in - match comp_ty with + match[@coq_match_with_default] comp_ty with | Unit_t -> (k [@ocaml.tailcall]) ctxt acc | Never_t -> (k [@ocaml.tailcall]) ctxt acc | Int_t -> (k [@ocaml.tailcall]) ctxt acc @@ -319,7 +319,7 @@ module Ticket_collection = struct comparable. *) (tickets_of_comparable [@ocaml.tailcall]) ctxt key_ty acc k - let rec tickets_of_value : + let[@coq_axiom_with_reason "gadts"] rec tickets_of_value_aux : type a ac ret. include_lazy:bool -> allow_zero_amount_tickets:bool -> @@ -337,7 +337,7 @@ module Ticket_collection = struct | False_ht, _ -> (k [@ocaml.tailcall]) ctxt acc | Pair_ht (hty1, hty2), Pair_t (ty1, ty2, _, _) -> let l, r = x in - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ~allow_zero_amount_tickets ctxt @@ -346,7 +346,7 @@ module Ticket_collection = struct l acc (fun ctxt acc -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ~allow_zero_amount_tickets ctxt @@ -358,7 +358,7 @@ module Ticket_collection = struct | Union_ht (htyl, htyr), Union_t (tyl, tyr, _, _) -> ( match x with | L v -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ~allow_zero_amount_tickets ctxt @@ -368,7 +368,7 @@ module Ticket_collection = struct acc k | R v -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ~allow_zero_amount_tickets ctxt @@ -380,7 +380,7 @@ module Ticket_collection = struct | Option_ht el_hty, Option_t (el_ty, _, _) -> ( match x with | Some x -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ~allow_zero_amount_tickets ctxt @@ -437,7 +437,7 @@ module Ticket_collection = struct Forbidden_zero_ticket_quantity >>=? fun () -> (k [@ocaml.tailcall]) ctxt (Ex_ticket (comp_ty, x) :: acc) - and tickets_of_list : + and[@coq_axiom_with_reason "gadts"] tickets_of_list : type a ac ret. context -> include_lazy:bool -> @@ -452,7 +452,7 @@ module Ticket_collection = struct consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt -> match elements with | elem :: elems -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ~allow_zero_amount_tickets ctxt @@ -472,7 +472,7 @@ module Ticket_collection = struct k) | [] -> (k [@ocaml.tailcall]) ctxt acc - and tickets_of_map : + and[@coq_axiom_with_reason "gadts"] tickets_of_map : type k v vc ret. include_lazy:bool -> allow_zero_amount_tickets:bool -> @@ -499,7 +499,7 @@ module Ticket_collection = struct acc k - and tickets_of_big_map : + and[@coq_axiom_with_reason "gadts"] tickets_of_big_map : type k v ret. context -> allow_zero_amount_tickets:bool -> @@ -549,7 +549,7 @@ module Ticket_collection = struct | None -> (k [@ocaml.tailcall]) ctxt acc) let tickets_of_value ctxt ~include_lazy ht ty x = - tickets_of_value ctxt ~include_lazy ht ty x [] (fun ctxt ex_tickets -> + tickets_of_value_aux ctxt ~include_lazy ht ty x [] (fun ctxt ex_tickets -> return (ex_tickets, ctxt)) end @@ -557,6 +557,7 @@ type 'a has_tickets = | Has_tickets : 'a Ticket_inspection.has_tickets * ('a, _) Script_typed_ir.ty -> 'a has_tickets +[@@coq_force_gadt] let type_has_tickets ctxt ty = Ticket_inspection.has_tickets_of_ty ctxt ty >|? fun (has_tickets, ctxt) -> @@ -579,8 +580,8 @@ let tickets_of_node ctxt ~include_lazy ~allow_zero_amount_tickets has_tickets let (Has_tickets (ht, ty)) = has_tickets in match ht with | Ticket_inspection.False_ht -> return ([], ctxt) - | _ -> - Script_ir_translator.parse_data + | (_ : _ Ticket_inspection.has_tickets) -> + (Script_ir_translator.parse_data [@coq_implicit "A" "a"]) ctxt ~legacy:true ~allow_forged:true diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.mli b/src/proto_alpha/lib_protocol/ticket_scanner.mli index bb6be0d5e850620f0ef5bae9be70f3904dcf8267..8e10ed37e4ebe7f8b7604f3c70854444cead1763 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.mli +++ b/src/proto_alpha/lib_protocol/ticket_scanner.mli @@ -41,7 +41,7 @@ type ex_ticket = (** A type-witness that contains information about which branches of a type ['a] include tickets. This value is used for traversing only the relevant branches of values when scanning for tickets. *) -type 'a has_tickets +type 'a has_tickets [@@coq_phantom] (** [type_has_tickets ctxt ty] returns a [has_tickets] witness of the given shape [ty]. diff --git a/src/proto_alpha/lib_protocol/token.ml b/src/proto_alpha/lib_protocol/token.ml index 6e1de3ef52308cbbfd0702d3daea3efbccbc92f4..a326919d09f1076f26108c52647c1d7382e272c1 100644 --- a/src/proto_alpha/lib_protocol/token.ml +++ b/src/proto_alpha/lib_protocol/token.ml @@ -24,71 +24,73 @@ (*****************************************************************************) type container = - [ `Contract of Contract_repr.t - | `Collected_commitments of Blinded_public_key_hash.t - | `Delegate_balance of Signature.Public_key_hash.t - | `Frozen_deposits of Signature.Public_key_hash.t - | `Block_fees - | `Frozen_bonds of Contract_repr.t * Bond_id_repr.t ] + | Contract of Contract_repr.t + | Collected_commitments of Blinded_public_key_hash.t + | Delegate_balance of Signature.Public_key_hash.t + | Frozen_deposits of Signature.Public_key_hash.t + | Block_fees + | Frozen_bonds of Contract_repr.t * Bond_id_repr.t type infinite_source = - [ `Invoice - | `Bootstrap - | `Initial_commitments - | `Revelation_rewards - | `Double_signing_evidence_rewards - | `Endorsing_rewards - | `Baking_rewards - | `Baking_bonuses - | `Minted - | `Liquidity_baking_subsidies - | `Tx_rollup_rejection_rewards ] + | Invoice + | Bootstrap + | Initial_commitments + | Revelation_rewards + | Double_signing_evidence_rewards + | Endorsing_rewards + | Baking_rewards + | Baking_bonuses + | Minted + | Liquidity_baking_subsidies + | Tx_rollup_rejection_rewards -type source = [infinite_source | container] +type source = + | Source_infinite of infinite_source + | Source_container of container type infinite_sink = - [ `Storage_fees - | `Double_signing_punishments - | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool - | `Tx_rollup_rejection_punishments - | `Sc_rollup_refutation_punishments - | `Burned ] + | Storage_fees + | Double_signing_punishments + | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool + | Tx_rollup_rejection_punishments + | Sc_rollup_refutation_punishments + | Burned -type sink = [infinite_sink | container] +type sink = Sink_infinite of infinite_sink | Sink_container of container let allocated ctxt stored = match stored with - | `Contract contract -> + | Contract contract -> Contract_storage.allocated ctxt contract >|= fun allocated -> ok (ctxt, allocated) - | `Collected_commitments bpkh -> + | Collected_commitments bpkh -> Commitment_storage.exists ctxt bpkh >|= fun allocated -> ok (ctxt, allocated) - | `Delegate_balance delegate -> + | Delegate_balance delegate -> let contract = Contract_repr.Implicit delegate in Contract_storage.allocated ctxt contract >|= fun allocated -> ok (ctxt, allocated) - | `Frozen_deposits delegate -> + | Frozen_deposits delegate -> let contract = Contract_repr.Implicit delegate in Frozen_deposits_storage.allocated ctxt contract >|= fun allocated -> ok (ctxt, allocated) - | `Block_fees -> return (ctxt, true) - | `Frozen_bonds (contract, bond_id) -> + | Block_fees -> return (ctxt, true) + | Frozen_bonds (contract, bond_id) -> Contract_storage.bond_allocated ctxt contract bond_id let balance ctxt stored = match stored with - | `Contract contract -> + | Contract contract -> Contract_storage.get_balance ctxt contract >|=? fun balance -> (ctxt, balance) - | `Collected_commitments bpkh -> + | Collected_commitments bpkh -> Commitment_storage.committed_amount ctxt bpkh >|=? fun balance -> (ctxt, balance) - | `Delegate_balance delegate -> + | Delegate_balance delegate -> let contract = Contract_repr.Implicit delegate in Storage.Contract.Spendable_balance.get ctxt contract >|=? fun balance -> (ctxt, balance) - | `Frozen_deposits delegate -> + | Frozen_deposits delegate -> let contract = Contract_repr.Implicit delegate in Frozen_deposits_storage.find ctxt contract >|=? fun frozen_deposits -> let balance = @@ -97,45 +99,45 @@ let balance ctxt stored = | Some frozen_deposits -> frozen_deposits.current_amount in (ctxt, balance) - | `Block_fees -> return (ctxt, Raw_context.get_collected_fees ctxt) - | `Frozen_bonds (contract, bond_id) -> + | Block_fees -> return (ctxt, Raw_context.get_collected_fees ctxt) + | Frozen_bonds (contract, bond_id) -> Contract_storage.find_bond ctxt contract bond_id >|=? fun (ctxt, balance_opt) -> (ctxt, Option.value ~default:Tez_repr.zero balance_opt) -let credit ctxt dest amount origin = +let credit ctxt (dest : sink) amount origin = let open Receipt_repr in (match dest with - | #infinite_sink as infinite_sink -> + | Sink_infinite infinite_sink -> let sink = match infinite_sink with - | `Storage_fees -> Storage_fees - | `Double_signing_punishments -> Double_signing_punishments - | `Lost_endorsing_rewards (d, p, r) -> Lost_endorsing_rewards (d, p, r) - | `Tx_rollup_rejection_punishments -> Tx_rollup_rejection_punishments - | `Sc_rollup_refutation_punishments -> Sc_rollup_refutation_punishments - | `Burned -> Burned + | Storage_fees -> Storage_fees + | Double_signing_punishments -> Double_signing_punishments + | Lost_endorsing_rewards (d, p, r) -> Lost_endorsing_rewards (d, p, r) + | Tx_rollup_rejection_punishments -> Tx_rollup_rejection_punishments + | Sc_rollup_refutation_punishments -> Sc_rollup_refutation_punishments + | Burned -> Burned in return (ctxt, sink) - | #container as container -> ( + | Sink_container container -> ( match container with - | `Contract dest -> + | Contract dest -> Contract_storage.credit_only_call_from_token ctxt dest amount >|=? fun ctxt -> (ctxt, Contract dest) - | `Collected_commitments bpkh -> + | Collected_commitments bpkh -> Commitment_storage.increase_commitment_only_call_from_token ctxt bpkh amount >|=? fun ctxt -> (ctxt, Commitments bpkh) - | `Delegate_balance delegate -> + | Delegate_balance delegate -> let contract = Contract_repr.Implicit delegate in Contract_storage.increase_balance_only_call_from_token ctxt contract amount >|=? fun ctxt -> (ctxt, Contract contract) - | `Frozen_deposits delegate as dest -> + | Frozen_deposits delegate as dest -> allocated ctxt dest >>=? fun (ctxt, allocated) -> (if not allocated then Frozen_deposits_storage.init ctxt delegate else return ctxt) @@ -145,10 +147,10 @@ let credit ctxt dest amount origin = delegate amount >|=? fun ctxt -> (ctxt, Deposits delegate) - | `Block_fees -> + | Block_fees -> Raw_context.credit_collected_fees_only_call_from_token ctxt amount >>?= fun ctxt -> return (ctxt, Block_fees) - | `Frozen_bonds (contract, bond_id) -> + | Frozen_bonds (contract, bond_id) -> Contract_storage.credit_bond_only_call_from_token ctxt contract @@ -157,53 +159,53 @@ let credit ctxt dest amount origin = >>=? fun ctxt -> return (ctxt, Frozen_bonds (contract, bond_id)))) >|=? fun (ctxt, balance) -> (ctxt, (balance, Credited amount, origin)) -let spend ctxt src amount origin = +let spend ctxt (src : source) amount origin = let open Receipt_repr in (match src with - | #infinite_source as infinite_source -> + | Source_infinite infinite_source -> let src = match infinite_source with - | `Bootstrap -> Bootstrap - | `Invoice -> Invoice - | `Initial_commitments -> Initial_commitments - | `Minted -> Minted - | `Liquidity_baking_subsidies -> Liquidity_baking_subsidies - | `Revelation_rewards -> Nonce_revelation_rewards - | `Double_signing_evidence_rewards -> Double_signing_evidence_rewards - | `Endorsing_rewards -> Endorsing_rewards - | `Baking_rewards -> Baking_rewards - | `Baking_bonuses -> Baking_bonuses - | `Tx_rollup_rejection_rewards -> Tx_rollup_rejection_rewards + | Bootstrap -> Bootstrap + | Invoice -> Invoice + | Initial_commitments -> Initial_commitments + | Minted -> Minted + | Liquidity_baking_subsidies -> Liquidity_baking_subsidies + | Revelation_rewards -> Nonce_revelation_rewards + | Double_signing_evidence_rewards -> Double_signing_evidence_rewards + | Endorsing_rewards -> Endorsing_rewards + | Baking_rewards -> Baking_rewards + | Baking_bonuses -> Baking_bonuses + | Tx_rollup_rejection_rewards -> Tx_rollup_rejection_rewards in return (ctxt, src) - | #container as container -> ( + | Source_container container -> ( match container with - | `Contract src -> + | Contract src -> Contract_storage.spend_only_call_from_token ctxt src amount >|=? fun ctxt -> (ctxt, Contract src) - | `Collected_commitments bpkh -> + | Collected_commitments bpkh -> Commitment_storage.decrease_commitment_only_call_from_token ctxt bpkh amount >|=? fun ctxt -> (ctxt, Commitments bpkh) - | `Delegate_balance delegate -> + | Delegate_balance delegate -> let contract = Contract_repr.Implicit delegate in Contract_storage.decrease_balance_only_call_from_token ctxt contract amount >|=? fun ctxt -> (ctxt, Contract contract) - | `Frozen_deposits delegate -> + | Frozen_deposits delegate -> Frozen_deposits_storage.spend_only_call_from_token ctxt delegate amount >|=? fun ctxt -> (ctxt, Deposits delegate) - | `Block_fees -> + | Block_fees -> Raw_context.spend_collected_fees_only_call_from_token ctxt amount >>?= fun ctxt -> return (ctxt, Block_fees) - | `Frozen_bonds (contract, bond_id) -> + | Frozen_bonds (contract, bond_id) -> Contract_storage.spend_bond_only_call_from_token ctxt contract @@ -236,9 +238,10 @@ let transfer_n ?(origin = Receipt_repr.Block_application) ctxt src dest = List.fold_left_es (fun ctxt (source, _amount) -> match source with - | `Contract contract | `Frozen_bonds (contract, _) -> + | Source_container (Contract contract) + | Source_container (Frozen_bonds (contract, _)) -> Contract_storage.ensure_deallocated_if_empty ctxt contract - | #source -> return ctxt) + | _ -> return ctxt) ctxt sources >|=? fun ctxt -> diff --git a/src/proto_alpha/lib_protocol/token.mli b/src/proto_alpha/lib_protocol/token.mli index e7ff1c45c6b57c54e10ec330b9599cec2942f092..d6e72933ab8c1bb1b8264eca413fb59d7a87da6c 100644 --- a/src/proto_alpha/lib_protocol/token.mli +++ b/src/proto_alpha/lib_protocol/token.mli @@ -43,43 +43,45 @@ stake. *) type container = - [ `Contract of Contract_repr.t - | `Collected_commitments of Blinded_public_key_hash.t - | `Delegate_balance of Signature.Public_key_hash.t - | `Frozen_deposits of Signature.Public_key_hash.t - | `Block_fees - | `Frozen_bonds of Contract_repr.t * Bond_id_repr.t ] + | Contract of Contract_repr.t + | Collected_commitments of Blinded_public_key_hash.t + | Delegate_balance of Signature.Public_key_hash.t + | Frozen_deposits of Signature.Public_key_hash.t + | Block_fees + | Frozen_bonds of Contract_repr.t * Bond_id_repr.t (** [infinite_source] defines types of tokens provides which are considered to be ** of infinite capacity. *) type infinite_source = - [ `Invoice - | `Bootstrap - | `Initial_commitments - | `Revelation_rewards - | `Double_signing_evidence_rewards - | `Endorsing_rewards - | `Baking_rewards - | `Baking_bonuses - | `Minted - | `Liquidity_baking_subsidies - | `Tx_rollup_rejection_rewards ] + | Invoice + | Bootstrap + | Initial_commitments + | Revelation_rewards + | Double_signing_evidence_rewards + | Endorsing_rewards + | Baking_rewards + | Baking_bonuses + | Minted + | Liquidity_baking_subsidies + | Tx_rollup_rejection_rewards (** [source] is the type of token providers. Token providers that are not containers are considered to have infinite capacity. *) -type source = [infinite_source | container] +type source = + | Source_infinite of infinite_source + | Source_container of container type infinite_sink = - [ `Storage_fees - | `Double_signing_punishments - | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool - | `Tx_rollup_rejection_punishments - | `Sc_rollup_refutation_punishments - | `Burned ] + | Storage_fees + | Double_signing_punishments + | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool + | Tx_rollup_rejection_punishments + | Sc_rollup_refutation_punishments + | Burned (** [sink] is the type of token receivers. Token receivers that are not containers are considered to have infinite capacity. *) -type sink = [infinite_sink | container] +type sink = Sink_infinite of infinite_sink | Sink_container of container (** [allocated ctxt container] returns a new context because of possible access to carbonated data, and a boolean that is [true] when @@ -110,8 +112,8 @@ val balance : val transfer_n : ?origin:Receipt_repr.update_origin -> Raw_context.t -> - ([< source] * Tez_repr.t) list -> - [< sink] -> + (source * Tez_repr.t) list -> + sink -> (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t (** [transfer ?origin ctxt src dest amount] transfers [amount] Tez from source @@ -138,7 +140,7 @@ val transfer_n : val transfer : ?origin:Receipt_repr.update_origin -> Raw_context.t -> - [< source] -> - [< sink] -> + source -> + sink -> Tez_repr.t -> (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.ml index 6de7e88e16950e2d43247d7aebd28a041b4edd17..3d8da9c0aaed5233b61fc844b86e690ef9603b35 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.ml @@ -94,7 +94,13 @@ type 'a template = { inbox_merkle_root : Tx_rollup_inbox_repr.Merkle.root; } -let map_template f x = {x with messages = f x.messages} +let map_template f x = + { + level = x.level; + messages = f x.messages; + predecessor = x.predecessor; + inbox_merkle_root = x.inbox_merkle_root; + } let pp_template : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a template -> unit diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.mli b/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.mli index 8a396f24d3986633ca0b05015c5e4bb70e5fbc41..277059cb20e75dc74375c354acfa430411b45a3c 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.mli +++ b/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.mli @@ -33,7 +33,7 @@ module Hash : sig include S.HASH end -module Merkle_hash : S.HASH +module Merkle_hash : S.HASH [@@coq_plain_module] module Merkle : Merkle_list.T diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml index 6d6d94eb9305175226f8c21181aabba43267a374..4dd4b82529170058925d8f956d91662c3f82e4cc 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml @@ -50,10 +50,14 @@ open Tx_rollup_errors_repr *) +type hash_or_result = + | Hash of Tx_rollup_message_result_hash_repr.t + | Result of Tx_rollup_message_result_repr.t + let check_message_result ctxt {messages; _} result ~path ~index = (match result with - | `Hash hash -> ok (ctxt, hash) - | `Result result -> Tx_rollup_hash_builder.message_result ctxt result) + | Hash hash -> ok (ctxt, hash) + | Result result -> Tx_rollup_hash_builder.message_result ctxt result) >>? fun (ctxt, computed) -> Tx_rollup_gas.consume_check_path_commitment_cost ctxt >>? fun ctxt -> let cond = @@ -71,11 +75,13 @@ let check_message_result ctxt {messages; _} result ~path ~index = cond Tx_rollup_errors_repr.( Wrong_rejection_hash - {provided = computed; expected = `Valid_path (messages.root, index)}) + {provided = computed; expected = Valid_path (messages.root, index)}) >>? fun () -> ok ctxt -let adjust_commitments_count ctxt tx_rollup pkh ~(dir : [`Incr | `Decr]) = - let delta = match dir with `Incr -> 1 | `Decr -> -1 in +type direction = Incr | Decr + +let adjust_commitments_count ctxt tx_rollup pkh ~(dir : direction) = + let delta = match dir with Incr -> 1 | Decr -> -1 in Storage.Tx_rollup.Commitment_bond.find (ctxt, tx_rollup) pkh >>=? fun (ctxt, commitment) -> let count = @@ -249,7 +255,7 @@ let add_commitment ctxt tx_rollup state pkh commitment = commitment.level commitment_hash >>?= fun state -> - adjust_commitments_count ctxt tx_rollup pkh ~dir:`Incr >>=? fun ctxt -> + adjust_commitments_count ctxt tx_rollup pkh ~dir:Incr >>=? fun ctxt -> return (ctxt, state, to_slash) let pending_bonded_commitments : @@ -319,7 +325,7 @@ let remove_commitment ctxt rollup state = fail (Internal_error "Missing finalized_at field")) >>=? fun () -> (* Decrement the bond count of the committer *) - adjust_commitments_count ctxt rollup commitment.committer ~dir:`Decr + adjust_commitments_count ctxt rollup commitment.committer ~dir:Decr >>=? fun ctxt -> (* We remove the commitment *) Storage.Tx_rollup.Commitment.remove (ctxt, rollup) tail @@ -347,7 +353,7 @@ let check_agreed_and_disputed_results ctxt tx_rollup state check_message_result ctxt commitment - (`Hash disputed_result) + (Hash disputed_result) ~path:disputed_result_path ~index:disputed_position >>?= fun ctxt -> @@ -359,7 +365,7 @@ let check_agreed_and_disputed_results ctxt tx_rollup state let expected = Tx_rollup_message_result_hash_repr.init in fail_unless Tx_rollup_message_result_hash_repr.(agreed = expected) - (Wrong_rejection_hash {provided = agreed; expected = `Hash expected}) + (Wrong_rejection_hash {provided = agreed; expected = Hash expected}) >>=? fun () -> return ctxt | Some pred_level -> ( Storage.Tx_rollup.Commitment.find (ctxt, tx_rollup) pred_level @@ -372,7 +378,7 @@ let check_agreed_and_disputed_results ctxt tx_rollup state fail_unless Tx_rollup_message_result_hash_repr.(agreed = expected) (Wrong_rejection_hash - {provided = agreed; expected = `Hash expected}) + {provided = agreed; expected = Hash expected}) >>=? fun () -> return ctxt | None -> ( match Tx_rollup_state_repr.last_removed_commitment_hashes state with @@ -380,14 +386,14 @@ let check_agreed_and_disputed_results ctxt tx_rollup state fail_unless Tx_rollup_message_result_hash_repr.(agreed = last_hash) (Wrong_rejection_hash - {provided = agreed; expected = `Hash last_hash}) + {provided = agreed; expected = Hash last_hash}) >>=? fun () -> return ctxt | None -> fail (Internal_error "Missing commitment predecessor"))) else check_message_result ctxt commitment - (`Result agreed_result) + (Result agreed_result) ~path:agreed_result_path ~index:(disputed_position - 1) >>?= fun ctxt -> return ctxt diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.mli b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.mli index d273649533974c10a6dcb5cd42ac90730e3d623b..e588c662a69a224a649629e98401636cc66a7e77 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.mli +++ b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.mli @@ -28,11 +28,14 @@ (** This module introduces various functions to manipulate the storage related to commitments for transaction rollups. *) +type hash_or_result = + | Hash of Tx_rollup_message_result_hash_repr.t + | Result of Tx_rollup_message_result_repr.t + val check_message_result : Raw_context.t -> Tx_rollup_commitment_repr.Compact.t -> - [ `Hash of Tx_rollup_message_result_hash_repr.t - | `Result of Tx_rollup_message_result_repr.t ] -> + hash_or_result -> path:Tx_rollup_commitment_repr.Merkle.path -> index:int -> Raw_context.t tzresult diff --git a/src/proto_alpha/lib_protocol/tx_rollup_errors_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_errors_repr.ml index a79f10792ef97a45a705b1e5eb6c7c17b9458dd7..bd9596b5f0cb633a497445f4146fa2009c628994 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_errors_repr.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_errors_repr.ml @@ -25,6 +25,12 @@ (* *) (*****************************************************************************) +type error_or_commitment = Inbox | Commitment + +type valid_path_or_hash = + | Valid_path of Tx_rollup_commitment_repr.Merkle.h * int + | Hash of Tx_rollup_message_result_hash_repr.t + type error += | Tx_rollup_already_exists of Tx_rollup_repr.t | Tx_rollup_does_not_exist of Tx_rollup_repr.t @@ -61,7 +67,7 @@ type error += length : int; } | Wrong_path_depth of { - kind : [`Inbox | `Commitment]; + kind : error_or_commitment; provided : int; limit : int; } @@ -82,9 +88,7 @@ type error += } | Wrong_rejection_hash of { provided : Tx_rollup_message_result_hash_repr.t; - expected : - [ `Valid_path of Tx_rollup_commitment_repr.Merkle.h * int - | `Hash of Tx_rollup_message_result_hash_repr.t ]; + expected : valid_path_or_hash; } | Ticket_payload_size_limit_exceeded of {payload_size : int; limit : int} | Wrong_deposit_parameters @@ -411,14 +415,14 @@ let () = (Tag 0) ~title:"Inbox" (constant "inbox") - (function `Inbox -> Some () | _ -> None) - (fun () -> `Inbox); + (function Inbox -> Some () | _ -> None) + (fun () -> Inbox); case (Tag 1) ~title:"Commitment" (constant "commitment") - (function `Commitment -> Some () | _ -> None) - (fun () -> `Commitment); + (function Commitment -> Some () | _ -> None) + (fun () -> Commitment); ])) (req "provided" int31) (req "limit" int31)) @@ -593,16 +597,16 @@ let () = (Tag 0) ~title:"hash" Tx_rollup_message_result_hash_repr.encoding - (function `Hash h -> Some h | _ -> None) - (fun h -> `Hash h); + (function Hash h -> Some h | _ -> None) + (fun h -> Hash h); case (Tag 1) ~title:"valid_path" (obj2 (req "root" Tx_rollup_commitment_repr.Merkle_hash.encoding) (req "index" int31)) - (function `Valid_path (h, i) -> Some (h, i) | _ -> None) - (fun (h, i) -> `Valid_path (h, i)); + (function Valid_path (h, i) -> Some (h, i) | _ -> None) + (fun (h, i) -> Valid_path (h, i)); ]))) (function | Wrong_rejection_hash {provided; expected} -> Some (provided, expected) diff --git a/src/proto_alpha/lib_protocol/tx_rollup_gas.ml b/src/proto_alpha/lib_protocol/tx_rollup_gas.ml index 77c60ec8229b62b7f75bd08a5220e54b8f019cae..79ca4518da040a730ad2a96874b3728a46c0298e 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_gas.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_gas.ml @@ -53,7 +53,7 @@ let check_path_cost element_size path_depth = hash_cost element_size >>? fun element_hash_cost -> (* At each step of the way, we hash 2 hashes together *) hash_cost 64 >>? fun hash_cost -> - let rec acc_hash_cost acc i = + let[@coq_struct "i_value"] rec acc_hash_cost acc i = if Compare.Int.(i <= 0) then acc else acc_hash_cost (hash_cost + acc) (i - 1) in diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml index cf2c1dd815a70e52af25a0632bd7ebf03fbe3ae5..5ff39b2de8c9eff304858651752c28955716be30 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml @@ -317,12 +317,81 @@ type parameters = { tx_rollup_max_withdrawals_per_batch : int; } -module Make (Context : CONTEXT) = struct +module type BATCH_V1 = sig + open Tx_rollup_l2_batch.V1 + + type ctxt_type + + type 'a m + + val apply_batch : + ctxt_type -> + parameters -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt_type * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m + + val check_signature : + ctxt_type -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt_type * indexes * (Indexable.index_only, Indexable.unknown) t) m +end + +module type S = sig + type ctxt_type + + type 'a m + + (** The operations are versioned (see {!Tx_rollup_l2_batch}), + so their interpretations are. *) + + module Batch_V1 : + BATCH_V1 with type ctxt_type := ctxt_type and type 'a m := 'a m + + (** [apply_deposit ctxt deposit] credits a quantity of tickets to a layer2 + address in [ctxt]. + + This function can fail if the [deposit.amount] is not strictly-positive. + + If the [deposit] causes an error, then a withdrawal returning + the funds to the deposit's sender is returned. + *) + val apply_deposit : + ctxt_type -> + Tx_rollup_message.deposit -> + (ctxt_type * Message_result.deposit_result * Tx_rollup_withdraw.t option) m + + (** [apply_message ctxt parameters message] interprets the [message] in the + [ctxt]. + + That is, + + {ul {li Deposit tickets if the message is a deposit. } + {li Decodes the batch and interprets it for the + correct batch version. }} + + The function can fail with {!Invalid_batch_encoding} if it's not able + to decode the batch. + + The function can also return errors from subsequent functions, + see {!apply_deposit} and batch interpretations for various versions. + + The list of withdrawals in the message result followed the ordering + of the contents in the message. + *) + val apply_message : + ctxt_type -> + parameters -> + Tx_rollup_message.t -> + (ctxt_type * Message_result.t) m +end + +module Make (Context : CONTEXT) : + S with type ctxt_type = Context.t and type 'a m := 'a Context.m = struct open Context open Syntax open Message_result - type ctxt = Context.t + type ctxt_type = Context.t (** {3. Indexes. } *) @@ -336,8 +405,8 @@ module Make (Context : CONTEXT) = struct | Right v -> ( let+ ctxt, created, idx = get_or_associate_index ctxt v in match created with - | `Existed -> (ctxt, indexes, idx) - | `Created -> (ctxt, add_index indexes (v, idx), idx)) + | Existed -> (ctxt, indexes, idx) + | Created -> (ctxt, add_index indexes (v, idx), idx)) | Left i -> return (ctxt, indexes, i) let address_index ctxt indexes indexable = @@ -372,7 +441,7 @@ module Make (Context : CONTEXT) = struct (** [get_metadata ctxt idx] returns the metadata associated to [idx] in [ctxt]. It must have an associated metadata in the context, otherwise, something went wrong in {!check_signature}. *) - let get_metadata : ctxt -> address_index -> metadata m = + let get_metadata : ctxt_type -> address_index -> metadata m = fun ctxt idx -> let open Address_metadata in let* metadata = get ctxt idx in @@ -382,7 +451,7 @@ module Make (Context : CONTEXT) = struct (** [get_metadata_signer] gets the metadata for a signer using {!get_metadata}. It transforms a signer index to an address one. *) - let get_metadata_signer : ctxt -> Signer_indexable.index -> metadata m = + let get_metadata_signer : ctxt_type -> Signer_indexable.index -> metadata m = fun ctxt signer_idx -> get_metadata ctxt (address_of_signer_index signer_idx) (** [transfers ctxt source_idx destination_idx tidx amount] transfers [amount] @@ -402,7 +471,8 @@ module Make (Context : CONTEXT) = struct we only handle the creation part (i.e. in the layer2) in this module. *) let deposit ctxt aidx tidx amount = Ticket_ledger.credit ctxt tidx aidx amount - module Batch_V1 = struct + module Batch_V1 : + BATCH_V1 with type ctxt_type := ctxt_type and type 'a m := 'a m = struct open Tx_rollup_l2_batch.V1 (** [operation_with_signer_index ctxt indexes op] takes an operation @@ -419,10 +489,10 @@ module Make (Context : CONTEXT) = struct {b Note:} If the context already contains all the required information, we only read from it. *) let operation_with_signer_index : - ctxt -> + ctxt_type -> indexes -> ('signer, 'content) operation -> - (ctxt + (ctxt_type * indexes * (Indexable.index_only, 'content) operation * Bls_signature.pk) @@ -445,7 +515,7 @@ module Make (Context : CONTEXT) = struct (* If the address is created, we add it to [indexes]. *) match created with - | `Existed -> + | Existed -> (* If the public key existed in the context, it should not be added in [indexes]. However, the metadata might not have been initialized for the public key. Especially during @@ -463,7 +533,7 @@ module Make (Context : CONTEXT) = struct Address_metadata.init_with_public_key ctxt idx signer_pk in return (ctxt, indexes, signer_pk, idx) - | `Created -> + | Created -> (* If the index is created, we need to add to indexes and initialize the metadata. *) let indexes = @@ -542,9 +612,9 @@ module Make (Context : CONTEXT) = struct return (ctxt, indexes, transmitted, List.rev rev_ops) let check_signature : - ctxt -> + ctxt_type -> ('signer, 'content) t -> - (ctxt * indexes * (Indexable.index_only, 'content) t) m = + (ctxt_type * indexes * (Indexable.index_only, 'content) t) m = fun ctxt ({contents = transactions; aggregated_signature} as batch) -> let* ctxt, indexes, transmitted, rev_new_transactions = list_fold_left_m @@ -578,11 +648,11 @@ module Make (Context : CONTEXT) = struct {li The ticket exchanged index.}} *) let apply_operation_content : - ctxt -> + ctxt_type -> indexes -> Signer_indexable.index -> 'content operation_content -> - (ctxt * indexes * Tx_rollup_withdraw.t option) m = + (ctxt_type * indexes * Tx_rollup_withdraw.t option) m = fun ctxt indexes source_idx op_content -> match op_content with | Withdraw {destination = claimer; ticket_hash; qty = amount} -> @@ -614,7 +684,8 @@ module Make (Context : CONTEXT) = struct (** [check_counter ctxt signer counter] asserts that the provided [counter] is the successor of the one associated to the [signer] in the [ctxt]. *) let check_counter : - ctxt -> Indexable.index_only Signer_indexable.t -> int64 -> unit m = + ctxt_type -> Indexable.index_only Signer_indexable.t -> int64 -> unit m + = fun ctxt signer counter -> let* metadata = get_metadata_signer ctxt signer in fail_unless @@ -629,10 +700,10 @@ module Make (Context : CONTEXT) = struct (** [apply_operation ctxt indexes op] checks the counter validity for the [op.signer] with {!check_counter}, and then calls {!apply_operation_content} for each content in [op]. *) let apply_operation : - ctxt -> + ctxt_type -> indexes -> (Indexable.index_only, Indexable.unknown) operation -> - (ctxt * indexes * Tx_rollup_withdraw.t list) m = + (ctxt_type * indexes * Tx_rollup_withdraw.t list) m = fun ctxt indexes {signer; counter; contents} -> (* Before applying any operation, we check the counter *) let* () = check_counter ctxt signer counter in @@ -655,12 +726,14 @@ module Make (Context : CONTEXT) = struct is left untouched. *) let apply_transaction : - ctxt -> + ctxt_type -> indexes -> (Indexable.index_only, Indexable.unknown) transaction -> - (ctxt * indexes * transaction_result * Tx_rollup_withdraw.t list) m = + (ctxt_type * indexes * transaction_result * Tx_rollup_withdraw.t list) m + = fun initial_ctxt initial_indexes transaction -> - let rec fold (ctxt, prev_indexes, withdrawals) index ops = + let rec fold params index ops = + let ctxt, prev_indexes, withdrawals = params in match ops with | [] -> return (ctxt, prev_indexes, Transaction_success, withdrawals) | op :: rst -> @@ -688,7 +761,8 @@ module Make (Context : CONTEXT) = struct failed because of a [Counter_mismatch] the counters are left untouched. *) - let update_counters ctxt status transaction = + let[@coq_axiom_with_reason "match on extensible type not at the head"] update_counters + ctxt status transaction = match status with | Transaction_failure {reason = Counter_mismatch _; _} -> return ctxt | Transaction_failure _ | Transaction_success -> @@ -700,10 +774,10 @@ module Make (Context : CONTEXT) = struct transaction let apply_batch : - ctxt -> + ctxt_type -> parameters -> (Indexable.unknown, Indexable.unknown) t -> - (ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m = + (ctxt_type * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m = fun ctxt parameters batch -> let* ctxt, indexes, batch = check_signature ctxt batch in let {contents; _} = batch in @@ -736,9 +810,9 @@ module Make (Context : CONTEXT) = struct end let apply_deposit : - ctxt -> + ctxt_type -> Tx_rollup_message.deposit -> - (ctxt * deposit_result * Tx_rollup_withdraw.t option) m = + (ctxt_type * deposit_result * Tx_rollup_withdraw.t option) m = fun initial_ctxt Tx_rollup_message.{sender; destination; ticket_hash; amount} -> let apply_deposit () = let* ctxt, indexes, aidx = @@ -763,7 +837,10 @@ module Make (Context : CONTEXT) = struct return (initial_ctxt, Deposit_failure reason, Some withdrawal)) let apply_message : - ctxt -> parameters -> Tx_rollup_message.t -> (ctxt * Message_result.t) m = + ctxt_type -> + parameters -> + Tx_rollup_message.t -> + (ctxt_type * Message_result.t) m = fun ctxt parameters msg -> let open Tx_rollup_message in match msg with diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli index 44619b09fe58b5fdd318c0d8d34d280a2ea1a215..33e8af74ad1f395049946dd07d04217812cb0f9e 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli @@ -122,73 +122,80 @@ type parameters = { tx_rollup_max_withdrawals_per_batch : int; } -module Make (Context : CONTEXT) : sig - open Context +module type BATCH_V1 = sig + open Tx_rollup_l2_batch.V1 - type ctxt = t + type ctxt_type + + type 'a m + + (** [apply_batch ctxt parameters batch] interprets the batch + {!Tx_rollup_l2_batch.V1.t}. + + By construction, a failing transaction will not affect the [ctxt] + and other transactions will still be interpreted. + That is, this function can only fail because of internals errors. + Otherwise, the errors that caused the transactions to fail can be + observed in the result (see {!Message_result.Batch_V1.t}). + + The counters are incremented when the operation is part of a transaction + that is correctly signed and whose every operations have the expected + counter. In particular, the result of the application is not important + (i.e. the counters are updated even if the transaction failed). + + In addition, the list of withdrawals resulting from each + layer2-to-layer1 transfer message in the batch is returned. + *) + val apply_batch : + ctxt_type -> + parameters -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt_type * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m + + (** [check_signature ctxt batch] asserts that [batch] is correctly signed. + + We recall that [batch] may contain indexes, that is integers which + replace larger values. The [signer] field of the + {!Tx_rollup_l2_batch.operation} type is concerned. This field is either + the public key to be used to check the signature, or an index. + In case of the public key, [check_signature] will check whether or not + the related {!Tx_rollup_l2_address.t} has already an index assigned, + and allocate one if not. + + Overall, [check_signature] returns the revised context, the list of + newly allocated indexes, and an updated version of the batches where + all [signer] field have been replaced by valid indexes. + + {b Note:} What a user is expected to sign is the version of the + operation it sends to the network. This is potentially unsafe, + because it means the user signs indexes, not addresses nor + ticket hashes. This poses two threats: Tezos reorganization, + and malicious provider of indexes. A Tezos reorganization may + imply that an index allocated to one address in a given branch + is allocated to another address in another branch. We deal with + this issue by making the rollup node aware of the Tezos level at + each time an index is allocated. This allows to implement a RPC that + can safely tell a client to use either the full value or the index, + thanks to Tenderbake finality. To prevent the rollup node to lie, + we will make the rollup node provide Merkle proofs that allows the + client to verify that the index is correct. + *) + val check_signature : + ctxt_type -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt_type * indexes * (Indexable.index_only, Indexable.unknown) t) m +end + +module type S = sig + type ctxt_type + + type 'a m (** The operations are versioned (see {!Tx_rollup_l2_batch}), so their interpretations are. *) - module Batch_V1 : sig - open Tx_rollup_l2_batch.V1 - - (** [apply_batch ctxt parameters batch] interprets the batch - {!Tx_rollup_l2_batch.V1.t}. - - By construction, a failing transaction will not affect the [ctxt] - and other transactions will still be interpreted. - That is, this function can only fail because of internals errors. - Otherwise, the errors that caused the transactions to fail can be - observed in the result (see {!Message_result.Batch_V1.t}). - - The counters are incremented when the operation is part of a transaction - that is correctly signed and whose every operations have the expected - counter. In particular, the result of the application is not important - (i.e. the counters are updated even if the transaction failed). - - In addition, the list of withdrawals resulting from each - layer2-to-layer1 transfer message in the batch is returned. - *) - val apply_batch : - ctxt -> - parameters -> - (Indexable.unknown, Indexable.unknown) t -> - (ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m - - (** [check_signature ctxt batch] asserts that [batch] is correctly signed. - - We recall that [batch] may contain indexes, that is integers which - replace larger values. The [signer] field of the - {!Tx_rollup_l2_batch.operation} type is concerned. This field is either - the public key to be used to check the signature, or an index. - In case of the public key, [check_signature] will check whether or not - the related {!Tx_rollup_l2_address.t} has already an index assigned, - and allocate one if not. - - Overall, [check_signature] returns the revised context, the list of - newly allocated indexes, and an updated version of the batches where - all [signer] field have been replaced by valid indexes. - - {b Note:} What a user is expected to sign is the version of the - operation it sends to the network. This is potentially unsafe, - because it means the user signs indexes, not addresses nor - ticket hashes. This poses two threats: Tezos reorganization, - and malicious provider of indexes. A Tezos reorganization may - imply that an index allocated to one address in a given branch - is allocated to another address in another branch. We deal with - this issue by making the rollup node aware of the Tezos level at - each time an index is allocated. This allows to implement a RPC that - can safely tell a client to use either the full value or the index, - thanks to Tenderbake finality. To prevent the rollup node to lie, - we will make the rollup node provide Merkle proofs that allows the - client to verify that the index is correct. - *) - val check_signature : - ctxt -> - (Indexable.unknown, Indexable.unknown) t -> - (ctxt * indexes * (Indexable.index_only, Indexable.unknown) t) m - end + module Batch_V1 : + BATCH_V1 with type ctxt_type := ctxt_type and type 'a m := 'a m (** [apply_deposit ctxt deposit] credits a quantity of tickets to a layer2 address in [ctxt]. @@ -199,9 +206,9 @@ module Make (Context : CONTEXT) : sig the funds to the deposit's sender is returned. *) val apply_deposit : - ctxt -> + ctxt_type -> Tx_rollup_message.deposit -> - (ctxt * Message_result.deposit_result * Tx_rollup_withdraw.t option) m + (ctxt_type * Message_result.deposit_result * Tx_rollup_withdraw.t option) m (** [apply_message ctxt parameters message] interprets the [message] in the [ctxt]. @@ -222,5 +229,11 @@ module Make (Context : CONTEXT) : sig of the contents in the message. *) val apply_message : - ctxt -> parameters -> Tx_rollup_message.t -> (ctxt * Message_result.t) m + ctxt_type -> + parameters -> + Tx_rollup_message.t -> + (ctxt_type * Message_result.t) m end + +module Make (Context : CONTEXT) : + S with type ctxt_type = Context.t and type 'a m := 'a Context.m diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml index 37379c6fd0e979191ac2a36a8badee501ec5e740..9c4232d3aec78e57281583a56812a9174d19ac07 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml @@ -144,7 +144,7 @@ module V1 = struct let operation_content_encoding = Data_encoding.Compact.make ~tag_size compact_operation_content - let compact_operation encoding_signer = + let compact_operation_raw encoding_signer = Data_encoding.Compact.( conv (fun {signer; counter; contents} -> (signer, counter, contents)) @@ -154,30 +154,32 @@ module V1 = struct (req "counter" int64) (req "contents" @@ list ~bits:4 operation_content_encoding)) - let operation_encoding encoding_signer = - Data_encoding.Compact.(make ~tag_size (compact_operation encoding_signer)) + let operation_encoding_raw encoding_signer = + Data_encoding.Compact.( + make ~tag_size (compact_operation_raw encoding_signer)) - let compact_transaction encoding_signer = - Data_encoding.Compact.list ~bits:8 (operation_encoding encoding_signer) + let compact_transaction_raw encoding_signer = + Data_encoding.Compact.list ~bits:8 (operation_encoding_raw encoding_signer) - let transaction_encoding : + let transaction_encoding_raw : 'a -> ('b, Indexable.unknown) transaction Data_encoding.t = fun encoding_signer -> - Data_encoding.Compact.(make ~tag_size (compact_transaction encoding_signer)) + Data_encoding.Compact.( + make ~tag_size (compact_transaction_raw encoding_signer)) let compact_signer_index = Data_encoding.Compact.(conv Indexable.to_int32 Indexable.index_exn int32) let compact_signer_either = Signer_indexable.compact - let compact_operation = compact_operation compact_signer_either + let compact_operation = compact_operation_raw compact_signer_either let compact_transaction_signer_index = - compact_transaction compact_signer_index + compact_transaction_raw compact_signer_index - let compact_transaction = compact_transaction compact_signer_either + let compact_transaction = compact_transaction_raw compact_signer_either - let transaction_encoding = transaction_encoding compact_signer_either + let transaction_encoding = transaction_encoding_raw compact_signer_either let compact ~bits : (Indexable.unknown, Indexable.unknown) t Data_encoding.Compact.t = diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.mli b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.mli index e59261c998aaddf8cb2a553120d074cde94c9fd9..ef323fe52c7459cc6f221966007d929f32f5b87a 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.mli +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.mli @@ -77,21 +77,7 @@ type signer = (** A signer identified by a layer-2 address. Each such adress is in turn identified with a BLS public key. *) -module Signer_indexable : sig - type nonrec 'state t = ('state, signer) Indexable.t - - type nonrec index = signer Indexable.index - - type nonrec value = signer Indexable.value - - type either = signer Indexable.either - - val encoding : either Data_encoding.t - - val compare : either -> either -> int - - val pp : Format.formatter -> either -> unit -end +module Signer_indexable : Indexable.INDEXABLE with type v_t := signer (** {1 Layer-2 Batches Definitions} *) diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml index 453e1588df7779b402cced68c63c932b86a34278..8e9f1c5457633e09f889e3401f682e4e6873a346 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml @@ -119,7 +119,7 @@ let packed_key_encoding : packed_key Data_encoding.t = underlying storage. *) let value_encoding : type a. a key -> a Data_encoding.t = let open Data_encoding in - function + function[@coq_match_gadt_with_result] | Address_metadata _ -> metadata_encoding | Address_count -> int32 | Address_index _ -> Tx_rollup_l2_address.Indexable.index_encoding @@ -175,7 +175,8 @@ struct type 'a m = 'a S.m - module Syntax = struct + module Syntax : Tx_rollup_l2_context_sig.SYNTAX with type 'a m := 'a m = + struct include S.Syntax let ( let*? ) res f = @@ -274,7 +275,12 @@ struct end end - module Address_index = struct + module Address_index : + INDEX + with type t := t + and type 'a m := 'a m + and type hash := Tx_rollup_l2_address.t + and type index := address_index = struct let count ctxt = let open Syntax in let+ count = get ctxt Address_count in @@ -301,17 +307,22 @@ struct let open Syntax in let* index_opt = get ctxt addr in match index_opt with - | Some idx -> return (ctxt, `Existed, idx) + | Some idx -> return (ctxt, Existed, idx) | None -> let+ ctxt, idx = associate_index ctxt addr in - (ctxt, `Created, idx) + (ctxt, Created, idx) module Internal_for_tests = struct let set_count ctxt count = set ctxt Address_count count end end - module Ticket_index = struct + module Ticket_index : + INDEX + with type t := t + and type 'a m := 'a m + and type hash := Alpha_context.Ticket_hash.t + and type index := ticket_index = struct let count ctxt = let open Syntax in let+ count = get ctxt Ticket_count in @@ -338,17 +349,18 @@ struct let open Syntax in let* index_opt = get ctxt ticket in match index_opt with - | Some idx -> return (ctxt, `Existed, idx) + | Some idx -> return (ctxt, Existed, idx) | None -> let+ ctxt, idx = associate_index ctxt ticket in - (ctxt, `Created, idx) + (ctxt, Created, idx) module Internal_for_tests = struct let set_count ctxt count = set ctxt Ticket_count count end end - module Ticket_ledger = struct + module Ticket_ledger : TICKET_LEDGER with type t := t and type 'a m := 'a m = + struct let get_opt ctxt tidx aidx = get ctxt (Ticket_ledger (tidx, aidx)) let get ctxt tidx aidx = diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml index ba8d16138f3258f89e0d3c7f12bf1e3011db69f5..a706f3d14673dfa4256494c502d4ad28c85496bb 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml @@ -157,198 +157,137 @@ let () = (function Counter_overflow -> Some () | _ -> None) (fun () -> Counter_overflow) -(** This module type describes the API of the [Tx_rollup] context, - which is used to implement the semantics of the L2 operations. *) -module type CONTEXT = sig - (** The state of the [Tx_rollup] context. - - The context provides a type-safe, functional API to interact - with the state of a transaction rollup. The functions of this - module, manipulating and creating values of type [t] are called - “context operations” afterwards. *) - type t +type created_existed = Created | Existed - (** The monad used by the context. - - {b Note:} It is likely to be the monad of the underlying - storage. In the case of the proof verifier, as it is expected to - be run into the L1, the monad will also be used to perform gas - accounting. This is why all the functions of this module type - needs to be inside the monad [m]. *) +(** The necessary monadic operators the storage monad is required to + provide. *) +module type SYNTAX = sig type 'a m - (** The necessary monadic operators the storage monad is required to - provide. *) - module Syntax : sig - val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m + val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m - val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m + val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m - (** [let*?] is for binding the value from Result-only - expressions into the storage monad. *) - val ( let*? ) : ('a, error) result -> ('a -> 'b m) -> 'b m + (** [let*?] is for binding the value from Result-only + expressions into the storage monad. *) + val ( let*? ) : ('a, error) result -> ('a -> 'b m) -> 'b m - (** [fail err] shortcuts the current computation by raising an - error. + (** [fail err] shortcuts the current computation by raising an + error. - Said error can be handled with the [catch] combinator. *) - val fail : error -> 'a m + Said error can be handled with the [catch] combinator. *) + val fail : error -> 'a m - (** [catch p k h] tries to executes the monadic computation [p]. - If [p] terminates without an error, then its result is passed - to the continuation [k]. On the contrary, if an error [err] is - raised, it is passed to the error handler [h]. *) - val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m + (** [catch p k h] tries to executes the monadic computation [p]. + If [p] terminates without an error, then its result is passed + to the continuation [k]. On the contrary, if an error [err] is + raised, it is passed to the error handler [h]. *) + val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m - (** [return x] is the simplest computation inside the monad [m] which simply - computes [x] and nothing else. *) - val return : 'a -> 'a m + (** [return x] is the simplest computation inside the monad [m] which simply + computes [x] and nothing else. *) + val return : 'a -> 'a m - (** [list_fold_left_m f] is a monadic version of [List.fold_left - f], wherein [f] is not a pure computation, but a computation - in the monad [m]. *) - val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m + (** [list_fold_left_m f] is a monadic version of [List.fold_left + f], wherein [f] is not a pure computation, but a computation + in the monad [m]. *) + val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m - (** [fail_unless cond err] raises [err] iff [cond] is [false]. *) - val fail_unless : bool -> error -> unit m + (** [fail_unless cond err] raises [err] iff [cond] is [false]. *) + val fail_unless : bool -> error -> unit m - (** [fail_when cond err] raises [err] iff [cond] is [true]. *) - val fail_when : bool -> error -> unit m - end - - (** [bls_aggregate_verify] allows to verify the aggregated signature - of a batch. *) - val bls_verify : (Bls_signature.pk * bytes) list -> signature -> bool m + (** [fail_when cond err] raises [err] iff [cond] is [true]. *) + val fail_when : bool -> error -> unit m +end - (** The metadata associated to an address. *) - module Address_metadata : sig - (** [get ctxt idx] returns the current metadata associated to the - address indexed by [idx]. *) - val get : t -> address_index -> metadata option m +module type ADDRESS_METADATA = sig + type t - (** [incr_counter ctxt idx] increments the counter of the - address indexed by [idx]. + type 'a m - This function can fail with [Counter_overflow] iff the counter - has reached the [Int64.max_int] limit. + (** [get ctxt idx] returns the current metadata associated to the + address indexed by [idx]. *) + val get : t -> address_index -> metadata option m - This function can fail with [Unknown_address_index] if [idx] - has not been associated with a layer-2 address already. *) - val incr_counter : t -> address_index -> t m + (** [incr_counter ctxt idx] increments the counter of the + address indexed by [idx]. - (** [init_with_public_key ctxt idx pk] initializes the metadata - associated to the address indexed by [idx]. + This function can fail with [Counter_overflow] iff the counter + has reached the [Int64.max_int] limit. - This can fails with [Metadata_already_initialized] if this - function has already been called with [idx]. *) - val init_with_public_key : t -> address_index -> Bls_signature.pk -> t m + This function can fail with [Unknown_address_index] if [idx] + has not been associated with a layer-2 address already. *) + val incr_counter : t -> address_index -> t m - (**/**) + (** [init_with_public_key ctxt idx pk] initializes the metadata + associated to the address indexed by [idx]. - module Internal_for_tests : sig - val set : t -> address_index -> metadata -> t m - end - end + This can fails with [Metadata_already_initialized] if this + function has already been called with [idx]. *) + val init_with_public_key : t -> address_index -> Bls_signature.pk -> t m - (** Mapping between {!Tx_rollup_l2_address.address} and {!address_index}. + (**/**) - Addresses are supposed to be associated to a {!address_index} in - order to reduce the batches' size submitted from the layer1 to the - layer2. Therefore, the first time an address is used in a layer2 - operation, we associate it to a address_index that should be use - in future layer2 operations. - *) - module Address_index : sig - (** [init_counter ctxt] writes the default counter (i.e. [0L]) in - the context. *) - val init_counter : t -> t m - - (** [get ctxt addr] returns the index associated to [addr], if - any. *) - val get : t -> Tx_rollup_l2_address.t -> address_index option m - - (** [get_or_associate_index ctxt addr] associates a fresh [address_index] - to [addr], and returns it. If the [addr] has already been associated to - an index, it returns it. - It also returns the information on whether the index was created or - already existed. - - This function can fail with [Too_many_l2_addresses] iff there - is no fresh index available. *) - val get_or_associate_index : - t -> - Tx_rollup_l2_address.t -> - (t * [`Created | `Existed] * address_index) m + module Internal_for_tests : sig + val set : t -> address_index -> metadata -> t m + end +end - (** [count ctxt] returns the number of addresses that have been - involved in the transaction rollup. *) - val count : t -> int32 m +module type INDEX = sig + type t - (**/**) + type 'a m - module Internal_for_tests : sig - (** [set ctxt count] sets the [count] in [ctxt]. It is used to test - the behavior of [Too_many_l2_addresses]. *) - val set_count : t -> int32 -> t m - end - end + type hash - (** Mapping between {!Ticket_hash.t} and {!ticket_index}. + type index - Ticket hashes are supposed to be associated to a {!ticket_index} in - order to reduce the batches' size submitted from the layer1 to the - layer2. Therefore, the first time a ticket hash is used in a layer2 - operation, we associate it to a ticket_index that should be use - in future layer2 operations. - *) - module Ticket_index : sig - (** [init_counter ctxt] writes the default counter (i.e. [0L]) in + (** [init_counter ctxt] writes the default counter (i.e. [0L]) in the context. *) - val init_counter : t -> t m + val init_counter : t -> t m - (** [get ctxt ticket] returns the index associated to [ticket], if + (** [get ctxt hash] returns the index associated to [hash], if any. *) - val get : t -> Alpha_context.Ticket_hash.t -> ticket_index option m + val get : t -> hash -> index option m - (** [get_or_associate_index ctxt ticket] associates a fresh [ticket_index] - to [ticket], and returns it. If the [ticket] has already been associated + (** [get_or_associate_index ctxt hash] associates a fresh [index] + to [hash], and returns it. If the [hash] has already been associated to an index, it returns it. It also returns the information on whether the index was created or already existed. This function can fail with [Too_many_l2_tickets] iff there is no fresh index available. *) - val get_or_associate_index : - t -> - Alpha_context.Ticket_hash.t -> - (t * [`Created | `Existed] * ticket_index) m + val get_or_associate_index : t -> hash -> (t * created_existed * index) m - (** [count ctxt] returns the number of tickets that have been + (** [count ctxt] returns the number of tickets that have been involved in the transaction rollup. *) - val count : t -> int32 m + val count : t -> int32 m - (**/**) + (**/**) - module Internal_for_tests : sig - (** [set_count ctxt count] sets the [count] in [ctxt]. It is used to test + module Internal_for_tests : sig + (** [set_count ctxt count] sets the [count] in [ctxt]. It is used to test the behavior of [Too_many_l2_addresses]. *) - val set_count : t -> int32 -> t m - end + val set_count : t -> int32 -> t m end +end - (** The ledger of the layer 2 where are registered the amount of a - given ticket a L2 [account] has in its possession. *) - module Ticket_ledger : sig - (** [get ctxt tidx aidx] returns the quantity of tickets ([tidx]) [aidx] +module type TICKET_LEDGER = sig + type t + + type 'a m + + (** [get ctxt tidx aidx] returns the quantity of tickets ([tidx]) [aidx] owns. {b Note:} It is the responsibility of the caller to verify that [aidx] and [tidx] have been associated to an address and a ticket respectively. The function will return zero when the address has no such ticket. *) - val get : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t m + val get : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t m - (** [credit ctxt tidx aidx qty] updates the ledger to + (** [credit ctxt tidx aidx qty] updates the ledger to increase the number of tickets indexed by [tidx] the address [aidx] owns by [qty] units. @@ -362,9 +301,9 @@ module type CONTEXT = sig {b Note:} It is the responsibility of the caller to verify that [aidx] and [tidx] have been associated to an address and a ticket respectively. *) - val credit : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m + val credit : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m - (** [spend ctxt tidx aidx qty] updates the ledger to + (** [spend ctxt tidx aidx qty] updates the ledger to decrease the number of tickets indexed by [tidx] the address [aidx] owns by [qty] units. @@ -374,11 +313,76 @@ module type CONTEXT = sig {b Note:} It is the responsibility of the caller to verify that [aidx] and [tidx] have been associated to an address and a ticket respectively. *) - val spend : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m + val spend : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m - module Internal_for_tests : sig - val get_opt : - t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t option m - end + module Internal_for_tests : sig + val get_opt : + t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t option m end end + +(** This module type describes the API of the [Tx_rollup] context, + which is used to implement the semantics of the L2 operations. *) +module type CONTEXT = sig + (** The state of the [Tx_rollup] context. + + The context provides a type-safe, functional API to interact + with the state of a transaction rollup. The functions of this + module, manipulating and creating values of type [t] are called + “context operations” afterwards. *) + type t + + (** The monad used by the context. + + {b Note:} It is likely to be the monad of the underlying + storage. In the case of the proof verifier, as it is expected to + be run into the L1, the monad will also be used to perform gas + accounting. This is why all the functions of this module type + needs to be inside the monad [m]. *) + type 'a m + + module Syntax : SYNTAX with type 'a m := 'a m + + (** [bls_aggregate_verify] allows to verify the aggregated signature + of a batch. *) + val bls_verify : + (Bls_signature.pk * bytes) list -> Bls_signature.signature -> bool m + + (** The metadata associated to an address. *) + module Address_metadata : + ADDRESS_METADATA with type t := t and type 'a m := 'a m + + (** Mapping between {!Tx_rollup_l2_address.address} and {!address_index}. + + Addresses are supposed to be associated to a {!address_index} in + order to reduce the batches' size submitted from the layer1 to the + layer2. Therefore, the first time an address is used in a layer2 + operation, we associate it to a address_index that should be use + in future layer2 operations. + *) + module Address_index : + INDEX + with type t := t + and type 'a m := 'a m + and type hash := Tx_rollup_l2_address.t + and type index := address_index + + (** Mapping between {!Ticket_hash.t} and {!ticket_index}. + + Ticket hashes are supposed to be associated to a {!ticket_index} in + order to reduce the batches' size submitted from the layer1 to the + layer2. Therefore, the first time a ticket hash is used in a layer2 + operation, we associate it to a ticket_index that should be use + in future layer2 operations. + *) + module Ticket_index : + INDEX + with type t := t + and type 'a m := 'a m + and type hash := Alpha_context.Ticket_hash.t + and type index := ticket_index + + (** The ledger of the layer 2 where are registered the amount of a + given ticket a L2 [account] has in its possession. *) + module Ticket_ledger : TICKET_LEDGER with type t := t and type 'a m := 'a m +end diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_storage_sig.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_storage_sig.ml index 4a81f9cd418083f5e62455dde52f0f42a4b1eaad..2b62542033cea5ff22994a847dabedf0f2f04395 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_storage_sig.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_storage_sig.ml @@ -25,6 +25,39 @@ (* *) (*****************************************************************************) +(** The necessary monadic operators the monad of the storage backend + is required to provide. *) +module type SYNTAX = sig + type t + + type 'a m + + val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m + + val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m + + (** [fail err] shortcuts the current computation by raising an + error. + + Said error can be handled with the [catch] combinator. *) + val fail : error -> 'a m + + (** [catch p k h] tries to executes the monadic computation [p]. + If [p] terminates without an error, then its result is passed + to the continuation [k]. On the contrary, if an error [err] is + raised, it is passed to the error handler [h]. *) + val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m + + (** [return x] is the simplest computation inside the monad [m] which simply + computes [x] and nothing else. *) + val return : 'a -> 'a m + + (** [list_fold_left_m f] is a monadic version of [List.fold_left + f], wherein [f] is not a pure computation, but a computation + in the monad [m]. *) + val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m +end + (** This module type is the minimal API a storage backend has to implement to be compatible with the [Tx_rollup] layer-2 implementation. @@ -44,34 +77,7 @@ module type STORAGE = sig (** The monad of the storage backend. *) type 'a m - (** The necessary monadic operators the monad of the storage backend - is required to provide. *) - module Syntax : sig - val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m - - val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m - - (** [fail err] shortcuts the current computation by raising an - error. - - Said error can be handled with the [catch] combinator. *) - val fail : error -> 'a m - - (** [catch p k h] tries to executes the monadic computation [p]. - If [p] terminates without an error, then its result is passed - to the continuation [k]. On the contrary, if an error [err] is - raised, it is passed to the error handler [h]. *) - val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m - - (** [return x] is the simplest computation inside the monad [m] which simply - computes [x] and nothing else. *) - val return : 'a -> 'a m - - (** [list_fold_left_m f] is a monadic version of [List.fold_left - f], wherein [f] is not a pure computation, but a computation - in the monad [m]. *) - val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m - end + module Syntax : SYNTAX with type t := t and type 'a m := 'a m (** [get storage key] returns the value stored in [storage] for [key], if it exists. Returns [None] if it does not. *) diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_verifier.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_verifier.ml index 18aba02d2b14e5e687e9d1cd3243c0f426fd9cb0..11cd53048590dcc415ad4254c2e9e749b7687b81 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_verifier.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_verifier.ml @@ -75,17 +75,18 @@ module Verifier_storage : type 'a m = ('a, error) result Lwt.t module Syntax = struct - let ( let* ) = ( >>=? ) + let ( let* ) : 'a m -> ('a -> 'b m) -> 'b m = ( >>=? ) - let ( let+ ) = ( >|=? ) + let ( let+ ) : 'a m -> ('a -> 'b) -> 'b m = ( >|=? ) - let return = return + let return : 'a -> 'a m = return - let fail e = Lwt.return (Error e) + let fail (e : error) : 'a m = Lwt.return (Error e) let catch (m : 'a m) k h = m >>= function Ok x -> k x | Error e -> h e - let list_fold_left_m = List.fold_left_es + let list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m = + List.fold_left_es end let path k = [Bytes.to_string k] @@ -124,8 +125,8 @@ let verify_l2_proof proof parameters message = Note that if the proof is incorrect this function fails and the commit can not be rejected. *) -let compute_proof_after_hash ~max_proof_size ctxt parameters agreed proof - message = +let[@coq_axiom_with_reason "nested pattern with polymorphic variant"] compute_proof_after_hash + ~max_proof_size ctxt parameters agreed proof message = let proof_length = Data_encoding.Binary.length Tx_rollup_l2_proof.encoding proof in diff --git a/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml index a393b22676f9bfafe2e2dd6b31624b1646410891..528e762b54bcba3ae83f07ee02b15a68a878633a 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml @@ -71,7 +71,7 @@ let encoding = (fun deposit -> Deposit deposit); ] -let pp fmt = +let[@coq_axiom_with_reason "unresolved implicit arguments"] pp fmt = let open Format in function | Batch str -> diff --git a/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml b/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml index 7c93e0a7f75e9ead3844e75f1ac63651e02b17ee..3c7a6be8e9cbf86b649b01286d50a1e365652a22 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml @@ -35,8 +35,10 @@ let get_deposit_parameters : (a, comparable) Script_typed_ir.ty -> a -> deposit_parameters tzresult = fun ty contents -> let open Script_typed_ir in - match (ty, contents) with + match[@coq_match_gadt] (ty, contents) with | ( Pair_t (Ticket_t (ty, _), Tx_rollup_l2_address_t, _, _), - (ticket, l2_destination) ) -> + (contents : + _ Script_typed_ir.ticket * Script_typed_ir.tx_rollup_l2_address) ) -> + let ticket, l2_destination = contents in ok {ex_ticket = Ticket_scanner.Ex_ticket (ty, ticket); l2_destination} | _ -> error Alpha_context.Tx_rollup_errors.Wrong_deposit_parameters diff --git a/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml index 104b9f1e00d1d8195fc816d8ad61a5a4cb8502a9..ba4e6b1ece854710b2e369b23bd63789cf9bf64f 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml @@ -430,7 +430,7 @@ let update_burn_per_byte_helper : be the maximum amount. *) | Error _ -> {state with burn_per_byte = Tez_repr.max_mutez; inbox_ema} -let rec update_burn_per_byte : +let[@coq_struct "elapsed"] rec update_burn_per_byte : t -> elapsed:int -> factor:int -> final_size:int -> hard_limit:int -> t = fun state ~elapsed ~factor ~final_size ~hard_limit -> (* factor is expected to be a low number ~ 100 *) diff --git a/src/proto_alpha/lib_protocol/tx_rollup_ticket.ml b/src/proto_alpha/lib_protocol/tx_rollup_ticket.ml index d4549894b9f79c6c76387d66f6a2e356d337998b..ddece37a0b1adf75a354411b810537aeb3f2a901 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_ticket.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_ticket.ml @@ -31,8 +31,8 @@ let parse_ticket ~consume_deserialization_gas ~ticketer ~contents ~ty ctxt = Script.force_decode_in_context ~consume_deserialization_gas ctxt contents >>?= fun (contents, ctxt) -> Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty) - >>?= fun (Ex_comparable_ty contents_type, ctxt) -> - Script_ir_translator.parse_comparable_data + >>?= fun [@coq_match_gadt] (Ex_comparable_ty contents_type, ctxt) -> + (Script_ir_translator.parse_comparable_data [@coq_type_annotation]) ctxt contents_type (Micheline.root contents) @@ -46,8 +46,8 @@ let parse_ticket_and_operation ~consume_deserialization_gas ~ticketer ~contents Script.force_decode_in_context ~consume_deserialization_gas ctxt contents >>?= fun (contents, ctxt) -> Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty) - >>?= fun (Ex_comparable_ty contents_type, ctxt) -> - Script_ir_translator.parse_comparable_data + >>?= fun [@coq_match_gadt] (Ex_comparable_ty contents_type, ctxt) -> + (Script_ir_translator.parse_comparable_data [@coq_type_annotation]) ctxt contents_type (Micheline.root contents)